Platform	kernel	full-image	boot-image	fasl extension	kernel-build directory
DarwinPPC32	dppccl	dppccl.image	ppc-boot.image	.dfsl	darwinppc
LinuxPPC32	ppccl	ppccl.image	ppc-boot	.pfsl	linuxppc
DarwinPPC64	dppccl64	dppccl64.image	ppc-boot64.image	.d64fsl	darwinppc64
LinuxPPC64	ppccl64	ppccl64.image	ppc-boot64	.p64fsl	linuxppc64
LinuxX8664	lx86cl64	lx86cl64.image	x86-boot64	.lx64fsl	linuxx8664
LinuxX8632	lx86cl	lx86cl.image	x86-boot32	.lx32fsl	linuxx8632
DarwinX8664	dx86cl64	dx86cl64.image	x86-boot64.image	.dx64fsl	darwinx8664
DarwinX8632	dx86cl	dx86cl.image	x86-boot32.image	.dx32fsl	darwinx8632
FreeBSDX8664	fx86cl64	fx86cl64.image	fx86-boot64	.fx64fsl	freebsdx8664
FreeBSDX8632	fx86cl	fx86cl.image	fx86-boot32	.fx32fsl	freebsdx8632
SolarisX64	sx86cl64	sx86cl64.image	sx86-boot64	.sx64fsl	solarisx64
SolarisX86	sx86cl	sx86cl.image	sx86-boot32	.sx32fsl	solarisx86
Win64	wx86cl64.exe	sx86cl64.image	wx86-boot64.image	.wx64fsl	win64
Win32	wx86cl.exe	wx86cl.image	wx86-boot32.image	.wx32fsl	win32

keyword	character(s)
+ `:UNIX` +	+ `#\Linefeed` +
+ `:MACOS` +	+ `#\Return` +
+ `:CR` +	+ `#\Return` +
+ `:CRLF` +	+ `#\Return #\Linefeed` +
+ `:CP/M` +	+ `#\Return #\Linefeed` +
+ `:MSDOS` +	+ `#\Return #\Linefeed` +
+ `:DOS` +	+ `#\Return #\Linefeed` +
+ `:WINDOWS` +	+ `#\Return #\Linefeed` +
+ `:INFERRED` +	see below
+ `:UNICODE` +	+ `#\Line_Separator` +

+ construct +	+ status +
+ accessor-method-slot-definition +	+ + +
+ add-dependent +	+ + +
+ add-direct-method +	+ + +
+ add-direct-subclass +	+ + +
+ add-method +	+ + +
+ class-default-initargs +	+ + +
+ class-direct-default-initargs +	+ + +
+ class-direct-slots +	+ + +
+ class-direct-subclasses +	+ + +
+ class-direct-superclasses +	+ + +
+ class-finalized-p +	+ + +
+ class-prototype +	+ + +
+ class-slots +	+ + +
+ compute-applicable-methods +	+ - +
+ compute-applicable-methods-using-classes +	+ - +
+ compute-class-precedence-list +	+ + +
+ compute-direct-initargs +	+ + +
+ compute-discriminating-function +	+ - +
+ compute-effective-method +	+ + +
+ compute-effective-slot-definition +	+ + +
+ compute-slots +	+ + +
+ direct-slot-definition-class +	+ + +
+ effective-slot-definition-class +	+ + +
+ ensure-class +	+ + +
+ ensure-class-using-class +	+ + +
+ ensure-generic-function-using-class +	+ + +
+ eql-specializer-object +	+ + +
+ extract-lambda-list +	+ + +
+ extract-specializer-names +	+ + +
+ finalize-inheritance +	+ + +
+ find-method-combination +	+ + +
+ funcallable-standard-instance-access +	+ + +
+ generic-function-argument-precedence-order +	+ + +
+ generic-function-declarations +	+ + +
+ generic-function-lambda-list +	+ + +
+ generic-function-method-class +	+ + +
+ generic-function-method-combination +	+ + +
+ generic-function-methods +	+ + +
+ generic-function-name +	+ + +
+ intern-eql-specializer +	+ + +
+ make-method-lambda +	+ - +
+ map-dependents +	+ + +
+ method-function +	+ + +
+ method-generic-function +	+ + +
+ method-lambda-list +	+ + +
+ method-qualifiers +	+ + +
+ method-specializers +	+ + +
+ reader-method-class +	+ + +
+ remove-dependent +	+ + +
+ remove-direct-method +	+ + +
+ remove-direct-subclass +	+ + +
+ remove-method +	+ + +
+ set-funcallable-instance-function +	+ - +
+ slot-boundp-using-class +	+ + +
+ slot-definition-allocation +	+ + +
+ slot-definition-initargs +	+ + +
+ slot-definition-initform +	+ + +
+ slot-definition-initfunction +	+ + +
+ slot-definition-location +	+ + +
+ slot-definition-name +	+ + +
+ slot-definition-readers +	+ + +
+ slot-definition-type +	+ + +
+ slot-definition-writers +	+ + +
+ slot-makunbound-using-class +	+ + +
+ slot-value-using-class +	+ + +
+ specializer-direct-generic-functions +	+ + +
+ specializer-direct-methods +	+ + +
+ standard-instance-access +	+ + +
+ update-dependent +	+ + +
+ validate-superclass +	+ + +
+ writer-method-class +	+ + +

+
+

^[1]I believe that the acronym comes from MACLISP, + where it stood for "Garbage Collection of Truly + Worthless Atoms".

+
+

^[2]This is + sometimes called "The Write Barrier": all assignments which + might result in intergenerational references must be noted, as + if the other generations were write-protected.

^[3]Note that the implicit setfs that occur when + initializing an object - as in the case of a call to cons or + vector - can't introduce intergenerational references, since + the newly created object is always younger than the objects + used to initialize it.

The next step in creating a Lisp version of the currency + converter application is to construct the user + interface. Apple's + tutorial + describes in detail how to do this.

+ +

Apple's Tutorial

+ +

Apple's tutorial explains how to use InterfaceBuilder to create the + user interface, and how to use XCode to create project files and + write Objective-C code. Our project uses Lisp instead of + Objective-C, and does not use XCode project files, so you can skip + the part of the tutorial that explains how to use XCode.

+ +

Using InterfaceBuilder to Create the UI

+ +

We'll begin by using Apple's InterfaceBuilder application to + create a nibfile. The nibfile contains + archived versions of the Objective-C objects that define the + application's user interface. When you launch an application, + Mac OS X uses the archived objects in the nibfile to create the + windows and menus you see on the screen.

+ +

Start by locating Apple's InterfaceBuilder application. If + you installed Apple's Developer Tools, InterfaceBuilder should + be in the folder "/Developer/Applications/":

+ +

+ + +

NOTE: If you have not installed Apple's Developer Tools, you should + do that now. You will not be able to build the CurrencyConverter + example without them. The Developer Tools are distributed as an + optional install with Mac OS X 10.5 ("Leopard"). Look for the + "XCode Tools" package in the "Optional Installs" folder on the + Mac OS 10.5 install disk.

+ +

Once you have located InterfaceBuilder, double-click to launch + the application. InterfaceBuilder presents a window you can use + to choose a template for the nibfile you are going to create.

+ +

Click the "Application" icon and then click the "Choose" button to + create an application nibfile. InterfaceBuilder creates a new + application nibfile, but doesn't immediately save it. The + Objective-C objects that represent the new application's + interface appear in a new untitled window:

+ +

The intial window and menubar also appear on the screen. The + new application's name appears in the menus as + "NewApplication". Save the new nibfile into the + "currency-converter" folder that you created earlier + (on this + page). InterfaceBuilder 3.0 gives you a choice of file + formats when you save a new nibfile; use the "NIB 3.x" + format—the "XIB 3.x" format works fine for editing your + user interface, but will not work correctly if you try to use it + in a working application. Give the new file the name + "CurrencyConverter.nib".

+ +

NOTE: Most Objective-C application projects use a main + nibfile called "MainMenu.nib", and if you use XCode to create + a new application project, it creates a nibfile with that + name. Apple's CurrencyConverter tutorial assumes that the + name of the main nibfile is "MainMenu.nib".

+ +

So, why do we tell you to use a different name? Clozure CL + has a main nibfile built into it, whose name is + "MainMenu.nib". Normally you don't see it, and don't even + need to know that it exists. But the Clozure CL + application-building tools create a new application by + copying resources from the Clozure CL application, so that + your new application has available to it all the built-in + Clozure CL tools. We ask you to name your nibfile + "CurrencyConverter.nib" so that it can coexist with the + Clozure CL main nibfile without causing any problems.

+ +

This difference between a Lisp project and an Objective-C + project might be a little confusing at first. Just try to keep + in mind that whenever Apple's tutorial refers to the + "MainMenu.nib" file, it means the file we have just created + and named "CurrencyConverter.nib". In a Clozure CL project, + "MainMenu.nib" is the name of the main Lisp nibfile, not your + application's main nibfile.

+ + +

Skip straight to the part of Apple's tutorial +called Defining +the View: Building the User Interface. Read the introduction to +nibfiles, and follow the instructions to create the Currency Converter +interface. (Remember that when the tutorial tells you to open and edit +"MainMenu.nib", you will instead open and edit your +"CurrencyConverter.nib".) When you reach the end of the section +called Test +the Interface, and move on to the short section afterward +called What's +Next, you are done creating the interface for your +application. Save your nibfile and continue with the next section of +this HOWTO.

+ +

What if You Need to Use InterfaceBuilder 2.x?

+ +

If you are still using Mac OS X 10.4.x ("Tiger"), you can still + create a working nibfile and you can still follow the instructions + in this HOWTO to create a Cocoa application with Clozure CL. The + main obstacle to doing so is that the earlier versions of + InterfaceBuilder have a significantly different user interface, and + so you may find it hard to follow Apple's tutorial when working with + InterfaceBuilder.

+ +

If you are working with Mac OS X 10.4.x ("Tiger"), you can + look here to find a description + of how to build the user interface files with the earlier version of + InterfaceBuilder. When you have finished building your user + interface, you can continue with the next + section, "Creating a Lisp File".

+ +

One other thing: if you are using Mac OS X 10.4.x ("Tiger"), you + will be able to build Cocoa applications only on PPC Macs. The + Clozure CL Objective-C support for Intel systems works only on Mac + OS X 10.5.x ("Leopard").

+ + +

Adding Custom Classes to the nibfile

+ +

Once the user interface for your application looks right, there is + still one important task to complete before you can use it. You must + record some information in the nibfile about the classes of the + objects, so that the application can create them with the right + connections in place.

+ +

When you use XCode to write an Objective-C application, + InterfaceBuilder can read the Objective-C header files and use the + information in them to create descriptions of the classes in the + Objective-C code. When the application is written in Lisp, + InterfaceBuilder can't read the class descriptions from the code, + and so we'll have to manually tell the nibfile about any classes + that we use in the user interface.

+ +

As you will see in the following sections, we'll use Lisp code to + define two Objective-C classes: Converter, and + ConverterController. The Converter class implements the method that + performs the actual currency conversion for our application; the + ConverterController class provides communication between the user + interface and the Converter object. We need a way to create + instances of these two classes in the nibfile, so that launching the + application sets up all the objects correctly.

+ +

Create Instances of Custom Classes

+ +

In InterfaceBuilder's Library window, select the Cocoa Objects and + Controllers view:

+ +

Drag an Object from the Library window and drop it into the main + CurrencyConverter window:

+ +

Now tell InterfaceBuilder the name of the new object's class. With + the Object icon selected in the main CurrencyConverter window, + choose the Identity tab of the Inspector. At the top of the + Identity view is a "Class" field; type the name of your custom + class (in this case, "Converter") into the "Class" field and save + the nibfile:

+ +

Repeat the previous steps to create an instance of the + ConverterController class: drag an "Object" icon and drop it in the + main CurrencyConverter window. Then, change the name of the + Object's class to "ConverterController".

+ +

That's all it takes to add an instance of a custom class to the + nibfile. We do still have to add the names of instance variables and + actions, and we need to create the connections between the + instances.

+ +

Add Outlets and Actions

+ +

Now, using the "+" button below the "Class Outlets" section of the + Inspector, add outlets to the ConverterController class. The + outlets you need to add are named "amountField", "converter", + "dollarField", and "rateField".

+ +

We'll connect each of the "field" outlets to one of the text fields + in the CurrencyConverter UI, and we'll connect the "converter" + outlet to the Converter instance that we created before. When the + application launches, it creates the Converter and + ConverterController instances and establishes the connections that + we've specified in the nibfile.

+ + +

First, though, we need to tell the nibfile about actions as well as + outlets. With the "ConverterController" instance selected, use the + "+" button below the "Class Actions" section to add a new + action. Name the action "convert:":

+ +

In this application, the "convert:" action is the only action + defined for the user interface, so we are done with actions now. In + more complex applications you may need to define many actions and + outlets.

+ +

Now we'll connect outlets and actions to objects.

+ +

Add Connections

+ +

InterfaceBuilder enables you to connect objects by + "Control-dragging" from one to another. To "Control-drag", you hold + down the Control key while dragging from one object to the next.

+ +

Select the "ConverterController" instance in the nibfile's main + window, and Control-drag a connection to the "Exchange rate" text + field in the application's main window. (Be sure to connect to the + text field, not to its label!) When you release the mouse button, + InterfaceBuilder pops up a menu that lists the available + outlets. Choose "rateField" from the menu. The "rateField" outlet of + the "ConverterController" instance is now connected to the "Exchange + rate" text field.

+ +

Repeat the same steps for the "Dollars" field and the "Amount" + field, connecting them to the "dollarField" and "amountField" + outlets, respectively.

+ +

Finally, Control-drag a connection from the "ConverterController" + instance to the "Converter" instance. Choose "converter" from the + popup menu to connect the "converter" field of the + "ConverterController" instance to the "Converter" instance.

+ +

To confirm that the connections are correct, you can use the + Connections view in the inspector. With the "ConverterController" + instance selected, click the blue arrow icon at the top of the + Inspector window to display connections. You should see a list of + outlets and the types of objects they are connected to:

+ +

We need to add one more connection: from the "Convert" button in + the application window to the "ConverterController" + instance. Control drag a connection from the "Convert" button in the + application window to the "ConverterController" instance in the + nibfile's main window. InterfaceBuilder pops up a menu; choose the + "convert:" action from the menu to connect the button to the + action.

+ +

The nibfile now contains descriptions of the needed cusstom + classes and their connections. You can continue with the next + section, which explains how to write the Lisp code that implements + the application's behavior.

+ +

start|previous|next

+ + + + Index: /branches/new-random/examples/cocoa/currency-converter/HOWTO_files/pages/building_ui_tiger.html =================================================================== --- /branches/new-random/examples/cocoa/currency-converter/HOWTO_files/pages/building_ui_tiger.html (revision 13309) +++ /branches/new-random/examples/cocoa/currency-converter/HOWTO_files/pages/building_ui_tiger.html (revision 13309) @@ -0,0 +1,586 @@ + + + + CurrencyConverter HOWTO + + + + + +

Building the User Interface on "Tiger"

+ +

If you are using Mac OS X 10.4.x ("Tiger") to build your + application, then the Apple tutorial's section on building the + UI may be somewhat confusing. Apple's tutorial uses + InterfaceBuilder 3.x to show how to build an interface, and + there were many interface changes between versions 2.x and 3.x + of InterfaceBuilder. In this section we see how to build the UI + using InterfaceBuilder 2.x.

+ +

Launch InterfaceBuilder

+ +

Start by locating Apple's InterfaceBuilder application. If + you installed Apple's Developer Tools, InterfaceBuilder should + be in the folder "/Developer/Applications/":

+ +

NOTE: If you have not + installed Apple's Developer Tools, you should do that now. You + will not be able to build the CurrencyConverter example + without them. The Developer Tools are distributed as an + optional install with Mac OS X 10.4 ("Tiger"). Look for the + "XCode Tools" package in the "Optional Installs" folder on the + Mac OS 10.4 install disk.

+ +

Once you have located InterfaceBuilder, double-click to launch + the application. InterfaceBuilder presents a window you can use + to choose a template for the nibfile you are going to create.

+ +

Make sure the "Application" option is selected in the "Cocoa" + section and click the "New" button to create a new + nibfile. InterfaceBuilder creates a new application nibfile, but + doesn't immediately save it. The Objective-C objects that + represent the new application's interface appear in a new + untitled window:

+ +

Resize the Window

+ +

Make the window smaller by dragging the bottom-right corner + of the window inward.

+ +

Change the Title of the Window

+ +

InterfaceBuilder creates the initial window with the title + "Window". Change the title to the more appropriate "Currency + Converter":

+ +

Click the Window object in the "Currency Converter" + window.
+
+ +
+
Choose "Attributes" from the drop-down menu in the + Inspector window:
+
+ +
+
Change the "Window Title" field to read "Currency Converter":
+
+ +
+

+ +

Add Text Fields

+ +

In InterfaceBuilder's Palettes window, select the "Cocoa + Text" view, and find the NSTextView object:

+ +

Drag an NSTextView object and drop it into the "Currency + Converter" window:

+ +

If you drag a view near the edges of a window, + InterfaceBuilder displays blue guide lines that show the + standard placement of a view near the edge of the window. Drag + the text view to the right and upward until the guide lines + appear, and then let go. The text view is then positioned in + the standard way.

+ +

Now add two more text fields. You can drag them from the + palette as you did the first one, or you can duplicate the + first one. To duplicate, select the first text view and then + choose "Duplicate" from the "Edit" menu. Alternatively, you can + option-drag the text field to duplicate it.

+ +

Label the Text Fields

+ +

Now add labels to the text fields, to identify their + purposes for the user. For each text field, drag a Label object + from the palette and drop it next to the field. (Alternatively, + you can drop one Label and then duplicate it, just as you can + duplicate the text fields.)

+ +

Just as InterfaceBuilder displayed guidelines to help you + position the text field near the edge of the window, it also + displays guide lines to help you position the labels near the + text fields. Just drag each label until the blue guide lines + appear, then release the label.

+ +

Now change the text of the labels. Click a label to select + it. Then show the Inspector by choosing the "Show Inspector" + item from the "Tools" menu. Select the "Attributes" item from + the pull-down menu at the top of the Inspector window, and type + the correct text into the Title field. For example, here is how + to enter the text for the top label:

+ +

Here's how the labels should look after you have entered the + text for all three:

+ +

When you first enter the text for a label, the label may not + be wide enough to show it all. In that case, you'll see only + part of the text in the label. You can resize the label to make + the full text visible. Click the label to select it. Notice the + small blue dots that surround it. Grab a dot on the left side + and drag it to the left to make the label wider, until you can + see the entire text.

+ +

Change Text Field Attributes

+ +

The first two text fields accept user input; the last + displays the result of the conversion. We want the first two + text fields to be editable, so users can enter the values to use + in the conversion. We don't want the last field to be editable, + but we do want users to be able to copy text from it.

+ +

We can control all this behavior using text-field + attributes, configurable in the Inspector.

+ +

Select the first text field
Choose "Show Inspector" from the "Tools" menu
Make sure "Attributes" is selected in the pull-down + menu at the top of the Inspector window
Ensure that the "Editable" and "Enabled" boxes are + checked in the "Attributes" display of the Inspector window
Repeat this process for the second text field
Finally, repeat it again for the last text field, but + this time make sure the "Editable" box is unchecked

+ +

Add a Button

+ +

Now we add a button that activates the currency conversion.

+ +

Drag a Button object from the palette and drop it on + the window
+
+ +
+
Double-click the button and change its title to "Convert"
+
+ +
+
Select the button and then choose "Attributes" from + the pull-down menu at the top of the Inspector window. Almost + halfway down the "Attributes" view of the Inspector window, + find the "Key Equiv" field. Choose "Return" from the pulldown + menu in that field.
+
+ +
+
+
When you choose "Return", InterfaceBuilder enters "\R" in + the text field for the Key Equivalent. Now when a user hits + the "Return" key, your application will behave as if they had + clicked the "Convert" button.

+ +

Add a Separator

+ +

Now add a separator line to visually group the text fields + together. Drag a separator line from the palette and drop it + above the button.

+ +

Drag the ends of the separator line until it spans a + visually pleasing width. As always, you can use the blue + guidelines that InterfaceBuilder displays to adjust the size + and position of the line and other elements to conform to + Apple's Human Interface Guidelines.

+ +

Set Up the Menus

+ +

InterfaceBuilder creates the standard menus for a new + application, but it doesn't know the name of the + application. Consequently, the Application menu and several menu + items use the name "NewApplication" where they should use the + name of your application. Change the text of these items so that + they read "Currency Converter" instead of "NewApplication".

+ +

Double-click the text "NewApplication" in the + application menu of your application's menubar. Change the + text to "Currency Converter".
+
+ +
+
+
NOTE: This change isn't really enough to get your + application to display the right name for the Application menu + when it's launched; the section + on building the application explains how to make sure the + correct name appears.
Repeat this process for each menu item where the name + "NewApplication" appears. Using the same method you used to + change the name of the application menu, edit the "About + NewApplication" item, the "Hide NewApplication" item, and the + "Quit NewApplication" item in the application menu. Then edit + the "NewApplication Help" item in the "Help" menu.

+ +

Tighten Up the Window Layout

+ +

InterfaceBuilder provides layout tools with which you can + easily clean up the layout of a UI window and ensure it + conforms to Apple's user interface guidelines.

+ +

Select the "Exchange Rate" text label. Then + Shift-click the other two labels to include them in the + selection (actually, it doesn't matter which label you select first).
Choose "Layout" > "Size to Fit" to shrink the labels + to the smallest sizes that still show all the text
Choose "Layout" > "Alignment" > "Align Right Edges" to + line up the right sides of the labels
With all three labels still selected, drag them up and + to the left. Release them when the blue guidelines show at + the top and left side of the window.
Now select all three text fields. You can click one of + them, then Shift-click to add the others to the + selection. Drag them up and left, toward the labels. Again, + release them when the blue guide line appears to show you the + proper distance from the labels. A guide line also appears to + show you when the fields are vertically aligned with the + center label.
Next, grab the separator line and move it up and to the + left. Release it when its left edge is aligned with the left + edge of the bottom label, and its top is the recommended + distance from the bottom label and its text field. Then drag + the right end of the separator line to resize it until its + right edge is aligned with the right edge of the bottom text + field. Again, guide lines show when you have found the proper + distances.
Grab the button and move it up and left, again using + the guide lines to help you find a good position.
Finally, resize the window. When the blue guide lines + appear on the right and bottom of the window, it's the right + size for its contents.

+ +

Now your application window should look something like the + one in the illustration:

+ +

Enable Tabbing Between Text Fields

+ +

Users generally expect to be able to use the Tab key to move + from one text field to the next in a dialog + box. InterfaceBuilder enables you to specify the tabbing order + in text fields.

+ +

Choose "Layout" > "Keyboard Navigation" > "Show + Keyboard Check". InterfaceBuilder displays a set of small + icons that identify UI elements that can respond to key + events.
Select the "Exchange Rate" text field (the field, not + the label) and then choose "Layout" > "Keyboard Navigation" > + "Make Initial First Responder". A small "1" icon appears in + the text field to show that when the application launches, + that field receives keyboard events.
Control-drag from the "Exchange Rate" field to the + "Dollars" field. InterfaceBuilder shows the "Connections" + Inspector, and, because Keyboard Check is enabled, + automatically selects the "nextKeyView" outlet. Click the + "Connect" button in the Inspector window to confirm.
Repeat the previous steps to connect the "Dollars" + field back to the "Exchange Rate" field. That way, tabbing + moves the insertion point from the "Exchange Rate" field to + the "Dollars" field, and then back to the "Exchange Rate" + field. Control-drag from the "Dollars" field to the "Exchange + Rate" field, then click "Connect" to confirm.

+ +

We don't enable tabbing into the "Amount" field because it's + not an editable field; it's used only to show the result of a + conversion.

+ +

Set Up the Classes Used In the User Interface

+ +

The visual elements of your application's user interface are + all ready now. The last thing you must do is create descriptions + of any custom classes used by the application when users + interact with the interface.

+ +

When a user clicks the "Convert" button, it should send a + message to a custom class that causes the conversion to take + place. In order for the application to connect the user + interface to classes that perform these actions, you must add + descriptions of your classes to the nibfile. Fortunately, + InterfaceBuilder can create class descriptions and save them in + the nibfile for you.

+ +

ConverterController

+ +

ConverterController is the controller class that the user + interface communicates with directly when the "Convert" button + is pressed. Create a description of the ConverterController + class, and then create an instance of it.

+ +

In InterfaceBuilder's "CurrencyConverter.nib" window, + click the "Classes" tab. The window shows a browser view of + all available Objective-C classes:
+
+ +
+
Control-click the "NSObject" entry in the browser, and + choose "Subclass NSObject" from the popup + menu. InterfaceBuilder creates a new entry initially called + "MyObject". Change the name from "MyObject" to "ConverterController".
Select the "ConverterController" class in the browser, + then activate the Inspector window and choose "Attributes" + from the popup menu at the top of the Inspector. At the + bottom of the "Attributes" view is a list of actions or + outlets. Select "Outlets", and use the "Add" button to add + four fields:
+
+ +
+
Rename these four fields to: "amountField", "dollarField", + "rateField", and "converter":
+
+ +
Now add the action that is triggered when the + "Convert" button is pressed: switch to the Actions view and + use the "Add" button to add a new action:
+
+ +
+
Change the name of the action from "myAction:" to "convert:"
Now create an instance of the ConverterController + class. In the browser, Right-click the ConverterController + class and choose "Instantiate ConverterController". The + browser view automatically switches to the Instances view to + show you the newly-created instance of ConverterController as + a blue box icon. There is a small yellow flag next to the + ConverterController instances to show that it has outlets + that are not connected to anything. In our final step, we'll + create the correct connections for the instance's outlets, + which will enable the application to send messages correctly + to the objects that implement its behavior.

+ +

Converter

+ +

Converter is + the model + class that implements the actual conversion code. Create a + description of the Converter class, and then create an + instance of it. Repeat the steps you used to create the + ConverterController class and instance to create a Converter + class and instance:

+ +

Switch to the browser view in the + "CurrencyConverter.nib" window.
Control-click NSObject and choose "Subclass NSObject" + from the resulting popup menu.
Change the name of the newly-created class from + "MyObject" to "Converter"
Control-click the "Converter" class and choose + "Instantiate Converter" to create an instance of the + Converter class.

+ +

The model class, "Converter", has no outlets or actions, so + you don't need to add anything to it before instantiating + it. Your code will implement a conversion method, but + InterfaceBuilder doesn't need to know about it; the "convert:" + method in your code will know everything it needs to about the + "Converter" class. You just need to create the class + description and the instance so that your application will + start up with the correct objects created and connected.

+ +

Connecting the Outlets

+ +

The final step in setting up the user interface is + establishing connections between the outlets and objects in the + interface, so that messages are sent from the user interface to + the correct objects.

+ +

Connect the "Convert" button to the + "ConverterController" instance. Control-drag from the + "Convert" button to the "ConverterController" instance. Make + sure the "convert:" action is selected in the "Target/Action" + view of the Inspector window, then click the "connect" button + to confirm.
Connect the "ConverterController" instance to the text + fields. Control-drag from the "ConverterController" instance + to the "Exchange Rate" field. Select "rateField" in the + "Outlets" view of the Inspector window and click "connect" to + confirm. Then repeat this process, connecting "dollarField" to + the "Dollars" text field, and "amountField" to the "Amount" + field.
Finally, connect the "ConverterController" to the + "Converter" instance. Control-drag from the + "ConverterController" instance to the "Converter" + instance. Select the "converter" outlet in the Inspector + window and click "connect" to confirm.

+ +

The nibfile now contains descriptions of the custom classes + that your code will implement, including connections between + their outlets and the objects with which they must + communicate. You can save the nibfile and proceed to write the + code that implements their behavior.

+ +

You can continue now with the section on "Creating a Lisp File".

+ + + +

+ +

start|previous|next

+ + + Index: /branches/new-random/examples/cocoa/currency-converter/HOWTO_files/pages/conclusion.html =================================================================== --- /branches/new-random/examples/cocoa/currency-converter/HOWTO_files/pages/conclusion.html (revision 13309) +++ /branches/new-random/examples/cocoa/currency-converter/HOWTO_files/pages/conclusion.html (revision 13309) @@ -0,0 +1,40 @@ + + + + CurrencyConverter HOWTO + + + + + +

Conclusion

+ +

This concludes our HOWTO on building the Apple + CurrencyConverter example in Lisp with Clozure CL. Your own Lisp + applications are likely to be considerably more complex than the + Currency Converter, which, after all, just does a simple + multiplication. You can, however, use exactly the same steps to + build a much richer and more full-featured Cocoa + application.

+ +

A more complex application will still consist of one or more + nibfiles and one or more Lisp source files. You will still use + the Objective-C bridge to define Objective-C classes and + methods, and to use Cocoa library features. And you will still + use BUILD-APPLICATION to turn your source and nibfiles into + standalone Cocoa applications.

+ +

You should now be able to use Clozure CL to accomplish anything + that an Objective-C user can accomplish with Cocoa. Good luck!

+ +

start

+ + + + Index: /branches/new-random/examples/cocoa/currency-converter/HOWTO_files/pages/create_lisp.html =================================================================== --- /branches/new-random/examples/cocoa/currency-converter/HOWTO_files/pages/create_lisp.html (revision 13309) +++ /branches/new-random/examples/cocoa/currency-converter/HOWTO_files/pages/create_lisp.html (revision 13309) @@ -0,0 +1,51 @@ + + + + CurrencyConverter HOWTO + + + + + +

Creating a Lisp File

+ +

Now that you have created the nibfile that defines your + application's user interface, it's time to create the Lisp + source file that defines its behavior. When you work with + Objective C, as in Apple's tutorial, you use Apple's XCode + application to create and manage projects, to edit Objective C + source files, and to build the final application. In this HOWTO, + the Clozure CL application takes the place of XCode. The Lisp + project structure is much simpler than the XCode project + structure: to build the Lisp application we need only the + nibfile created in the previous section, and a single Lisp + source file.

+ +

Double-click Clozure CL to launch it. Clozure CL displays a Listener window:

+ +

Choose "New" from the "File" menu to create a new Lisp source + window. Save it with the name "CurrencyConverter.lisp" into the + same "currency-converter" folder where you saved your nibfile in + the earlier section. You should now have a "currency-converter" + folder that contains a "CurrencyConverter.lisp" item and a + "CurrencyConverter.nib" item.

+ +

Now you're ready to continue, and write the Lisp code that + implements the application's behavior.

+ +

start|previous|next

+ + + + Index: /branches/new-random/examples/cocoa/currency-converter/HOWTO_files/pages/making_project.html =================================================================== --- /branches/new-random/examples/cocoa/currency-converter/HOWTO_files/pages/making_project.html (revision 13309) +++ /branches/new-random/examples/cocoa/currency-converter/HOWTO_files/pages/making_project.html (revision 13309) @@ -0,0 +1,60 @@ + + + + CurrencyConverter HOWTO + + + + + +

Creating a Project

+ +

Example Files

+ +

This HOWTO is distributed with example files that include a + working nibfile (a file of user-interface objects, + named "CurrencyConverter.nib") and a Lisp source file (named + "CurrencyConverter.lisp"). You can build a working copy of the + example application by using these files, but you probably + shouldn't. If you want to understand how to build your own Lisp + application projects, you should follow the instructions here to + create your own source file and nibfile, and use the example + files only for reference in case something goes wrong.

+ +

Create the Project Folder

+ +

First, create a project folder to hold the files you are + going to create. When your project is complete, the folder will + contain a nibfile that defines the user interface, and + a Lisp source file that defines the behavior of the + application. Those two files are really all there is to a Lisp + application, though not all applications are as simple as this + currency converter. For more complex applications it makes sense + to split your UI into several nibfiles, and to split your + implementation into several source files. The basic principle + remains the same, however: nibfiles define your user interface, + and Lisp files define your application's behavior.

+ +

Create a folder somewhere convenient, and name it + "currency-converter". Next we will use Apple's InterfaceBuilder + application to create the user interface The next page tells you + how to do that; when you create your nibfile, save it into your + "currency-converter" folder.

+ +

start|next

+ + + + Index: /branches/new-random/examples/cocoa/currency-converter/HOWTO_files/pages/writing_lisp.html =================================================================== --- /branches/new-random/examples/cocoa/currency-converter/HOWTO_files/pages/writing_lisp.html (revision 13309) +++ /branches/new-random/examples/cocoa/currency-converter/HOWTO_files/pages/writing_lisp.html (revision 13309) @@ -0,0 +1,229 @@ + + + + CurrencyConverter HOWTO + + + + + +

Writing the Lisp Source

+ +

In this section we'll write Lisp code that duplicates the + features provided by the Objective-C code in Apple's + tutorial. In Apple's tutorial, the explanation of the Objective + C code begins with the + section Bridging + the Model and View: The Controller.

+ +

The Lisp code in this section of the HOWTO is considerably + simpler than the corresponding Objective-C code, in part + because we can ignore the conventions that XCode uses for + laying out source files. We can just write all our definitions + into a single Lisp source file, and load that file into Clozure CL + when we are ready to build the application.

+ +

First Things First

+ +

Place the following line at the top of your Lisp source file:

+ +

(in-package "CCL")

+ +

Clozure CL's Objective-C bridge code is defined in the "CCL" + package. Usually, when building an application, you'll create a + package for that application and import the definitions you need + to use. In order to keep the discussion short in this simple + example, we just place all our definitions in the "CCL" + package.

+ +

Defining the Converter Class

+ +

We begin by defining the Converter class. Recall from Apple's + tutorial that this is the Model class that implements the + conversion between dollars and other currencies. Here is the + Lisp definition that implements the class you created in + InterfaceBuilder:

+ +

+(defclass converter (ns:ns-object)
+  ()
+  (:metaclass ns:+ns-object))
+

+ +

This is an ordinary CLOS class definition, with a couple of + simple wrinkles. First, the superclass it inherits from is the + NS-OBJECT class in the "NS" package. NS-OBJECT is an Objective-C + class, the ancestor of all Objective-C objects. This CLOS + definition actually creates a new Objective-C class named + "Converter".

+ +

We tell Clozure CL how to build the right kind of class object + by including the :METACLASS option in the definition:

+ +

+  (:metaclass ns:+ns-object)
+

+ +

The Objective-C bridge knows that when the metaclass + is ns:+ns-object, it must lay out the class object + in memory as an Objective-C class, rather than a normal CLOS + STANDARD-CLASS.

+ +

Next, we define the method "convertCurrency:atRate:":

+ +

+(objc:defmethod (#/convertCurrency:atRate: :float) 
+    ((self converter) (currency :float) (rate :float))
+  (* currency rate))
+

+ +

This is the method that actually does the currency + conversion. It's a Lisp method that will be called when the + AppKit sends the Objective-C message "convertCurrency:atRate:" + It's very simple—really, it just multiples + currency times rate. Most of the text in the definition is + Objective-C bridge code that links the definition to the right + class with the right argument and return types.

+ +

objc:defmethod is a version of DEFMETHOD that + creates methods that can execute in response to Objective-C + message-sends.

+ +

The syntax #/convertCurrency:atRate: uses the + "#/" reader macro to read a symbol with case preserved, so that + you can see in your code the same name that Objective-C uses for + the method, without worrying about how the name might be + converted between Lisp and Objective-C conventions.

+ +

The number of arguments to an Objective-C method is the + number of colons in the name, plus one. Each colon indicates an + argument, and there is always an extra "self" argument that + refers to the object that receives the message. These are normal + Objective-C conventions, but we perhaps need to emphasize the + details, since we are using Lisp code to call the Objective-C + methods.

+ +

We indicate the return type and the types of arguments in + the method definition by surrounding parameters and the method + name with parentheses, and appending the type name.

+ +

Thus, for example,

+ +

+(#/convertCurrency:atRate: :float) 
+

+ +

means that the return type of the method is :FLOAT, and

+ +

+(self converter) 
+

+ +

means that the type of the receiving object is Converter.

+ +

You will see these same conventions repeated in the next + section.

+ +

Defining the ConverterController Class

+ +

The previous section defined the Model class, Converter. All + we need now is a definition for the ConverterController + class. Recall from your reading of Apple's Tutorial that the + CurrencyConverter example uses the Model-View-Controller + paradigm. You used InterfaceBuilder to construct the + application's views. The Converter class provides the model + that represents application data. Now we define the controller + class, ConverterController, which connects the View and the + Model.

+ +

Here's the definition of the ConverterController class:

+ +

+(defclass converter-controller (ns:ns-object)
+  ((amount-field :foreign-type :id :accessor amount-field)
+   (converter :foreign-type :id :accessor converter)
+   (dollar-field :foreign-type :id :accessor dollar-field)
+   (rate-field :foreign-type :id :accessor rate-field))
+  (:metaclass ns:+ns-object))
+

+ +

Once again we use the Objective-C bridge to define an + Objective-C class. This time, we provide several + instance-variable definitions in the class, and name accessors + for each of them explicitly. The :FOREIGN-TYPE + initargs enable us to specify the type of each field in the + foreign (Objective-C) class.

+ +

Each field in the definition of the ConverterController class + is an outlet that will be used to store a reference to one of + the text fields that you created in InterfaceBuilder. For + example, amount-field will be connected to the + "Amount" text field.

+ +

Why did we spell the name "amount-field" in Lisp code, and + "amountField" when creating the outlet in InterfaceBuilder? The + Objective-C bridge automatically converts Lisp-style field names + (like "amount-field") to Objective-C-style field names (like + "amountField"), when handling class definitions.

+ +

The converter field at launch time contains a + reference to the Converter object, whose class definition is in + the previous section.

+ +

The final piece of the implementation is a definition of the + "convert:" method. This is the method that is called when a + user clicks the "Convert" button in the user interface.

+ +

+(objc:defmethod (#/convert: :void) ((self converter-controller) sender)
+  (declare (ignore sender))
+  (let* ((conv (converter self))
+         (dollar-field (dollar-field self))
+         (rate-field (rate-field self))
+         (amount-field (amount-field self))
+         (dollars (#/floatValue dollar-field))
+         (rate (#/floatValue rate-field))
+         (amount (#/convertCurrency:atRate: conv dollars rate)))
+    (#/setFloatValue: amount-field amount)
+    (#/selectText: rate-field self)))
+

+ +

Just as in the Apple example, this method reads the dollar + and rate values, and passes them to the + "convertCurrency:atRate:" method of the Converter class. It then + sets the text of the amount-field to reflect the result of the + conversion. The only significant difference between this + implementation and Apple's is that the code is written in Lisp + rather than Objective-C.

+ +

This completes the definition of the CurrencyConverter's + behavior. All that remains is to actually build the Cocoa + application. The next section shows how to do that.

+ +

start|previous|next

+ + + + Index: /branches/new-random/examples/cocoa/currency-converter/HOWTO_files/stylesheets/styles.css =================================================================== --- /branches/new-random/examples/cocoa/currency-converter/HOWTO_files/stylesheets/styles.css (revision 13309) +++ /branches/new-random/examples/cocoa/currency-converter/HOWTO_files/stylesheets/styles.css (revision 13309) @@ -0,0 +1,55 @@ +body { + background-color: white; + font-family: "Helvetica Neue", Arial, Helvetica, Geneva, sans-serif; +} + +.title { + text-align: center; + font-size: 16pt; +} + +.subtitle { + font-size: medium; + font-weight: bold; + text-align: center; +} + +.byline { + text-align: center; + font-weight: bold; + font-size: small; +} + +.section-head { + padding-top: 2em; + padding-left: 1em; +} + +.body-text { + font: 12pt Georgia, "Times New Roman", Times, serif; + margin-left: 4em; + margin-right: 4em; + text-indent: 3em; +} + +.note { + font: 12pt Georgia, "Times New Roman", Times, serif; + margin-left: 6em; + margin-right: 6em; + text-indent: 0em; +} + +.inline-image { + text-align: center; +} + +.nav { + text-align: center; + font-size: large; + font-weight: bold; + padding-top: 4em; +} + +li, pre { + text-indent: 0; +} Index: /branches/new-random/examples/cocoa/currency-converter/currency-converter.lisp =================================================================== --- /branches/new-random/examples/cocoa/currency-converter/currency-converter.lisp (revision 13309) +++ /branches/new-random/examples/cocoa/currency-converter/currency-converter.lisp (revision 13309) @@ -0,0 +1,54 @@ +(in-package "CCL") + +;;; define the classes referenced in the nibfile + +(defclass converter (ns:ns-object) + () + (:metaclass ns:+ns-object)) + +(objc:defmethod (#/convertCurrency:atRate: :float) + ((self converter) (currency :float) (rate :float)) + (* currency rate)) + +(defclass converter-controller (ns:ns-object) + ((amount-field :foreign-type :id :accessor amount-field) + (converter :foreign-type :id :accessor converter) + (dollar-field :foreign-type :id :accessor dollar-field) + (rate-field :foreign-type :id :accessor rate-field)) + (:metaclass ns:+ns-object)) + +(objc:defmethod (#/convert: :void) ((self converter-controller) sender) + (declare (ignore sender)) + (let* ((conv (converter self)) + (dollar-field (dollar-field self)) + (rate-field (rate-field self)) + (amount-field (amount-field self)) + (dollars (#/floatValue dollar-field)) + (rate (#/floatValue rate-field)) + (amount (#/convertCurrency:atRate: conv dollars rate))) + (#/setFloatValue: amount-field amount) + (#/selectText: rate-field self))) + + + + +#| +"/Users/mikel/Valise/clozure/openmcl/example-code/currency-converter/CurrencyConverter.nib" + +building the app: + +(progn + (setf (current-directory) "/Users/mikel/Valise/clozure/openmcl/example-code/currency-converter/") + (load "currency-converter") + (require "build-application") + (ccl::build-application :name "CurrencyConverter" + :main-nib-name "CurrencyConverter" + :directory "/Users/mikel/Desktop/" + :nibfiles '(#P"/usr/local/openmcl/trunk/ccl/examples/cocoa/currency-converter/CurrencyConverter.xib"))) + +TODO NOTES: + +The name of the app in the main menu title is determined by the CFBundleName field in the +InfoPlist.strings file in the English.lproj resources folder. + +|# Index: /branches/new-random/examples/cocoa/easygui.lisp =================================================================== --- /branches/new-random/examples/cocoa/easygui.lisp (revision 13309) +++ /branches/new-random/examples/cocoa/easygui.lisp (revision 13309) @@ -0,0 +1,8 @@ +(in-package :cl-user) + +(let ((path (or *load-pathname* *loading-file-source-file*))) + (load (merge-pathnames ";easygui;easygui.asd" path))) + +(asdf:operate 'asdf:load-op 'easygui) + +(push :easygui *features*) Index: /branches/new-random/examples/cocoa/easygui/.cvsignore =================================================================== --- /branches/new-random/examples/cocoa/easygui/.cvsignore (revision 13309) +++ /branches/new-random/examples/cocoa/easygui/.cvsignore (revision 13309) @@ -0,0 +1,2 @@ +*~.* +*fsl Index: /branches/new-random/examples/cocoa/easygui/action-targets.lisp =================================================================== --- /branches/new-random/examples/cocoa/easygui/action-targets.lisp (revision 13309) +++ /branches/new-random/examples/cocoa/easygui/action-targets.lisp (revision 13309) @@ -0,0 +1,17 @@ +(in-package :easygui) + +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; +;;; action/targets + +(defclass generic-easygui-target (ns:ns-object) + ((handler :initarg :handler :reader target-handler)) + (:metaclass ns:+ns-object)) + +(objc:defmethod (#/activateAction :void) ((self generic-easygui-target)) + (funcall (target-handler self))) + +(defmethod (setf action) (handler (view view)) + (let ((target (make-instance 'generic-easygui-target + :handler handler))) + (#/setTarget: (cocoa-ref view) target) + (#/setAction: (cocoa-ref view) (@selector #/activateAction)))) Index: /branches/new-random/examples/cocoa/easygui/dialogs.lisp =================================================================== --- /branches/new-random/examples/cocoa/easygui/dialogs.lisp (revision 13309) +++ /branches/new-random/examples/cocoa/easygui/dialogs.lisp (revision 13309) @@ -0,0 +1,56 @@ +(in-package :easygui) + +;;; Contributed to Clozure CL by AWSC, Feb 2009. +;;; Permission is granted to use, redistribute, and modify. +;;; +;;; Provides some generally useful dialogs: +;;; y-or-n-dialog +;;; choose-file-dialog (original from Gary Byers) +;;; choose-new-file-dialog (adapted from that) +;;; user-pick-color (TODO: improve) +;;; To use them you will probably want to set *debug-cocoa-calls* to NIL. + +(defun y-or-n-dialog (message) + (let ((alert (make-instance 'ns:ns-alert))) + (#/setMessageText: alert (ccl::%make-nsstring message)) + (#/addButtonWithTitle: alert (ccl::%make-nsstring "Yes")) + (#/addButtonWithTitle: alert (ccl::%make-nsstring "No")) + (eql (#/runModal alert) #$NSAlertFirstButtonReturn))) + +(defvar *beepnsleep* t) + +(defun choose-file-dialog (&key directory file-types file button-string) + (gui::cocoa-choose-file-dialog :directory directory :file-types file-types :file file :button-string button-string)) + +(defun choose-new-file-dialog (&key directory file-types file button-string) + (declare (ignore button-string)) + (gui::cocoa-choose-new-file-dialog :directory directory :file-types file-types :file file)) + +(defun cocoa-choose-directory-dialog (&key directory button-string) + (declare (ignore button-string)) + (cocoa-choose-directory-dialog :directory directory)) + +(objc:defmethod (#/NSWindowWillCloseNotification :void) ((self ns:ns-color-panel)) + (dcc (#/stopModal (#/sharedApplication ns:ns-application)))) + +(defun user-pick-color (&key color (prompt "Pick a color") position) + "POSITION argument is provided only for Digitool MCL compatibility, it is ignored" + (declare (ignore position)) + (gui::with-autorelease-pool + (let* ((panel (dcc (#/sharedColorPanel ns:ns-color-panel)))) ; find or create the NSColorPanel + (dcc (#/setPickerMode: ns:ns-color-panel #$NSWheelModeColorPanel)) + (dcc (#/setTitle: panel (ccl::%make-nsstring prompt))) + (dcc (#/addObserver:selector:name:object: ; observe yourself close but + (dcc (#/defaultCenter ns:ns-notification-center)) ; sadly confound OK & CANCEL + panel + (objc:\@selector #/NSWindowWillCloseNotification) + (ccl::%make-nsstring "NSWindowWillCloseNotification") + panel)) + (when color (dcc (#/setColor: panel color))) + (dcc (#/runModalForWindow: (#/sharedApplication ns:ns-application) panel)) + (dcc (#/removeObserver:name:object: ; prevent pileup + (dcc (#/defaultCenter ns:ns-notification-center)) + panel + (ccl::%make-nsstring "NSWindowWillCloseNotification") + panel)) + (dcc (#/retain (dcc (#/color panel))))))) Index: /branches/new-random/examples/cocoa/easygui/easygui.asd =================================================================== --- /branches/new-random/examples/cocoa/easygui/easygui.asd (revision 13309) +++ /branches/new-random/examples/cocoa/easygui/easygui.asd (revision 13309) @@ -0,0 +1,38 @@ +;;; -*- lisp -*- + +#+openmcl +(eval-when (:compile-toplevel :load-toplevel :execute) + (require :asdf)) + +#-openmcl +(error "Requires OpenMCL") + + +(cl:defpackage :easygui-system (:use :cl :asdf)) + +(in-package :easygui-system) + +(defsystem cocoa.asd) + +(defmethod perform :after ((o compile-op) (sys (eql (find-system :cocoa.asd)))) + (require :cocoa)) + +(defmethod operation-done-p ((o compile-op) (sys (eql (find-system :cocoa.asd)))) + nil) + +(defsystem easygui + :depends-on (cocoa.asd) + :components ((:file "package") + (:file "new-cocoa-bindings" :depends-on ("package")) + (:file "events" :depends-on ("new-cocoa-bindings")) + (:file "rgb" :depends-on ("package")) + (:file "views" :depends-on ("events")) + (:file "action-targets" :depends-on ("views")) + (:file "dialogs" :depends-on ("new-cocoa-bindings")) + (:module "example" + :depends-on ("action-targets" "dialogs" "rgb") + :components + ((:file "tiny") + (:file "currency-converter") + (:file "view-hierarchy") + (:file "extended-demo"))))) Index: /branches/new-random/examples/cocoa/easygui/events.lisp =================================================================== --- /branches/new-random/examples/cocoa/easygui/events.lisp (revision 13309) +++ /branches/new-random/examples/cocoa/easygui/events.lisp (revision 13309) @@ -0,0 +1,82 @@ +(in-package :easygui) + +;;; Changed by AWSC (arthur.cater@ucd.ie) Feb 2009: +;;; Modified define-chaining-responder-method to allow subclasses of easygui +;;; views to inherit mouse handling behaviour. +;;; Changed by AWSC Apr 2009: +;;; Modified define-chaining-responder-method to bind *modifier-key-pattern* +;;; when Lisp mouse handlers are being called. +;;; The original work I changed is by an unknown author. +;;; Permission to use disseminate and further modify these changes is granted. + +;;; Event handling basics + +(defvar *modifier-key-pattern*) + +(defmacro define-chaining-responder-method (class-name + (objc-name lisp-name) + (self-arg event-arg) + &body arg-compute-forms) + `(objc:defmethod (,objc-name :void) ((,self-arg ,class-name) + ,event-arg) + (let ((superclasses (ccl:class-precedence-list (class-of (easygui-view-of ,self-arg))))) + (if (some #'(lambda (super) + (find-method #',lisp-name nil (list (class-name super)) nil)) + superclasses) + (let ((*modifier-key-pattern* (#/modifierFlags ,event-arg))) + (,lisp-name (easygui-view-of ,self-arg) + ,@arg-compute-forms)) + (,objc-name (#/nextResponder ,self-arg) ,event-arg))))) + +(defmacro define-useful-mouse-event-handling-routines (class-name) + `(progn + (define-chaining-responder-method ,class-name + (#/mouseDown: mouse-down) (self event) + :cocoa-event event + :location (let ((objc-pt (#/convertPoint:fromView: + self + (#/locationInWindow event) + nil))) + (point (ns:ns-point-x objc-pt) (ns:ns-point-y objc-pt))) + :button (#/buttonNumber event) + :click-count (#/clickCount event) + :delta (point (#/deltaX event) (#/deltaY event))) + (define-chaining-responder-method ,class-name + (#/mouseUp: mouse-up) (self event) + :cocoa-event event + :location (let ((objc-pt (#/convertPoint:fromView: + self + (#/locationInWindow event) + nil))) + (point (ns:ns-point-x objc-pt) (ns:ns-point-y objc-pt))) + :button (#/buttonNumber event) + :click-count (#/clickCount event) + :delta (point (#/deltaX event) (#/deltaY event))) + (define-chaining-responder-method ,class-name + (#/mouseDragged: mouse-dragged) (self event) + :cocoa-event event + :location (let ((objc-pt (#/convertPoint:fromView: + self + (#/locationInWindow event) + nil))) + (point (ns:ns-point-x objc-pt) (ns:ns-point-y objc-pt)))))) + +;;; Mouse: + +(defclass event-handler-mixin () ()) + +(defclass mouse-event-handler-mixin () ()) + + +(macrolet ((defgeneric-and-empty-method (name (&rest args) &rest options) + `(defgeneric ,name ,args + ,@options + (:method ,args + (declare (ignore ,@(remove-if (lambda (sym) (member sym lambda-list-keywords)) args))))))) + ;; TODO: mouse-move + (defgeneric-and-empty-method mouse-down (view &key cocoa-event location button + click-count delta)) + (defgeneric-and-empty-method mouse-up (view &key cocoa-event location button + click-count delta)) + (defgeneric-and-empty-method mouse-dragged (view &key cocoa-event location + delta))) Index: /branches/new-random/examples/cocoa/easygui/example/currency-converter.lisp =================================================================== --- /branches/new-random/examples/cocoa/easygui/example/currency-converter.lisp (revision 13309) +++ /branches/new-random/examples/cocoa/easygui/example/currency-converter.lisp (revision 13309) @@ -0,0 +1,41 @@ +(in-package :easygui-demo) + +(defclass converter-window (window) + () + (:default-initargs :size (point 383 175) + :position (point 125 513) + :title "Currency Converter" + :resizable-p nil + :minimizable-p t)) + +(defmethod initialize-view :after ((cw converter-window)) + (let ((currency-form (make-instance 'form-view + :autosize-cells-p t + :interline-spacing 9.0 + :position (point 15 70) + :size (point 353 90))) + (convert-button (make-instance 'push-button-view + :default-button-p t + :text "Convert" + :position (point 247 15))) + (line (make-instance 'box-view + :position (point 15 59) + :size (point 353 2)))) + (setf (action convert-button) + #'(lambda () + (let ((exchange-rate (read-from-string + (entry-text currency-form 1) nil nil)) + (amount (read-from-string (entry-text currency-form 0) + nil nil))) + (when (and (numberp exchange-rate) (numberp amount)) + (setf (entry-text currency-form 2) + (prin1-to-string (* exchange-rate amount))))))) + (setf (editable-p (car (last (add-entries currency-form + "Exchange Rate per $1:" + "Dollars to Convert:" + "Amount in other Currency:")))) + nil) + (add-subviews cw currency-form line convert-button) + (window-show cw))) + +;(make-instance 'converter-window) Index: /branches/new-random/examples/cocoa/easygui/example/extended-demo.lisp =================================================================== --- /branches/new-random/examples/cocoa/easygui/example/extended-demo.lisp (revision 13309) +++ /branches/new-random/examples/cocoa/easygui/example/extended-demo.lisp (revision 13309) @@ -0,0 +1,316 @@ +(in-package :easygui-demo) + +; --------------- +; Demo for the new control types for EasyGui within Clozure CL +; Contributed March 2009 by AWSC (arthur.cater@ucd.ie) +; based upon earlier work by an unknown author. +; Permission is given to disseminate, use, and modify. +; No warranty is expressed or implied. +; +; Tested in cclv1.2 on 32-bitPPC, in cclv1.3 on 32-bitPPC and 64-bitIntel Macs. +; Tested only in images constructed using (require :cocoa-application). + +(setf easygui::*debug-cocoa-calls* nil) + +(defclass view-hierarchy-demo-window (window) + ((with :initarg :with :initform :button) + (textbox :initarg :textbox :initform nil :accessor demo-textbox)) + (:default-initargs :size (point 480 270) + :position (point 125 513) + :resizable-p nil + :minimizable-p t + :title "View tree demo") + (:documentation "Shows a window with a simple view hierarchy and one or more controls + that manipulate this hierarchy.")) + +(defclass brown-drawing-view (drawing-view) ()) + +(defmethod draw-view-rectangle ((drawing brown-drawing-view) rectangle) + (declare (ignore rectangle)) + (let* ((cocoa-view (cocoa-ref drawing)) + (rect (dcc (#/bounds cocoa-view))) + (brown (dcc (#/brownColor ns:ns-color)))) + (with-focused-view cocoa-view + (dcc (#/setFill brown)) + (dcc (#_NSRectFill rect))))) + +(defmethod initialize-view :after ((w view-hierarchy-demo-window)) + (let (left-box right-box button left-button right-button checkbox popup pulldown slider + drawing text (leftp t) + (normalfont (gui::default-font :name "Monaco" :size 10.0 :attributes nil)) + (shoutfont (gui::default-font :name "Courier" :size 36.0 :attributes '(:bold :italic)))) + (labels ((to-left () + (retaining-objects (text) + (cond ((not leftp) + (remove-subviews right-box text) + (add-subviews left-box text)))) + (setf leftp t)) + (to-right () + (retaining-objects (text) + (cond (leftp + (remove-subviews left-box text) + (add-subviews right-box text)))) + (setf leftp nil)) + (to-other () + (retaining-objects (text) + (cond ((not leftp) + (remove-subviews right-box text) + (add-subviews left-box text)) + (leftp + (remove-subviews left-box text) + (add-subviews right-box text)))) + (setf leftp (not leftp))) + (generate-menu-items () + (list (make-instance 'menu-item-view :title "Left" :action #'to-left) + (make-instance 'menu-item-view :title "Right" :action #'to-right) + (make-instance 'menu-item-view :title "Other" :action #'to-other) + (make-instance 'pop-up-menu :title "Text Options" + :menu-items + (list (make-instance 'menu-item-view :title "Oink" + :action #'(lambda () (setf (view-font text) normalfont) + (setf (view-text text) "Oink!") + (setf (view-size text) (point 60 20)) + (setf (view-position text) (point 37 112)))) + (make-instance 'menu-item-view :title "SHOUT!" + :action #'(lambda () (setf (view-font text) shoutfont) + (setf (view-text text) "HEY!") + (setf (view-size text) (point 160 60)) + (setf (view-position text) (point 17 10)))) + (make-instance 'pop-up-menu :title "Whisper" + :menu-items + (list (make-instance 'menu-item-view :title "sh!" + :action #'(lambda () (setf (view-font text) normalfont) + (setf (view-text text) "sh!"))) + (make-instance 'menu-item-view :title "psst!" + :action #'(lambda () (setf (view-font text) normalfont) + (setf (view-text text) "psst!")))))))))) + (setf left-box (make-instance 'box-view + :position (point 17 51) + :size (point 208 199) + :title "Left" + :tip #'(lambda nil (unless leftp "The occupied box has no tooltip")) + :view-nick-name :leftbox) + right-box (make-instance 'box-view + :position (point 255 51) + :size (point 208 199) + :tip #'(lambda nil (if leftp "The occupied box has no tooltip")) + :title "Right" + :view-nick-name :rightbox) + button (make-instance 'push-button-view + :position (point 173 12) + :text "Change side" + :tip #'(lambda nil "Button tip does not work!") + :view-nick-name :push-button + :action #'to-other) + left-button (make-instance 'radio-button-view + :position (point 103 12) + :text "Left side" + :selected t + :view-nick-name :leftbutton + :tip #'(lambda nil (format nil + "Where's the amazing tooltip?~%The text is in the box on the ~:[right~;left~]" + leftp)) + :action #'to-left) + right-button (make-instance 'radio-button-view + :position (point 243 12) + :text "Right side" + :view-nick-name :rightbutton + :tip #'(lambda nil (format nil + "Where's the amazing tooltip?~%The text is in the box on the ~:[right~;left~]" + leftp)) + + :action #'to-right) + checkbox (make-instance 'check-box-view + :position (point 173 12) + :text "Right side" + :view-nick-name :checkbox + :tip #'(lambda nil (format nil + "Where's the amazing tooltip?~%The text is in the box on the ~:[right~;left~]" + leftp)) + :action #'to-other) + popup (make-instance 'pop-up-menu + :position (point 173 12) + :size (point 120 24) + :title "Command?" + :tip #'(lambda nil (format nil "Pop up menus can have tooltips,~%however their menu items cannot.")) + :view-nick-name :pop-up-menu + :menu-items (generate-menu-items)) + pulldown (make-instance 'pull-down-menu + :position (point 173 12) + :size (point 120 24) + :title "Command?" + :tip #'(lambda nil (format nil "Pull down menus can have tooltips,~%however their menu items cannot.")) + :view-nick-name :pull-down-menu + :menu-items (generate-menu-items)) + drawing (make-instance 'brown-drawing-view + :position (point 173 12) + :size (point 120 24) + :view-nick-name :drawing + :tip #'(lambda nil (format nil + "See the amazing tooltip!~%The text is in the box on the ~:[right~;left~]" + leftp)) + :mouse-down #'(lambda (view &key &allow-other-keys) + (declare (ignore view)) + (if (shift-key-p) (to-left) (to-other)))) + text (make-instance 'static-text-view + :text "Oink!" + :view-font normalfont + :tip :identify + :position (point 37 112) + :size (point 60 20) + :fore-color (make-rgb :red 0 :green 0 :blue 255) + :back-color (make-rgb :red 255 :green 220 :blue 200)) + slider (make-instance 'slider-view :min-value 0 :max-value 1 + ; :text "How right" ;; No provision for title or text? + :position (point 173 12) :size (point 136 24) + :view-nick-name :slider + :tip #'(lambda nil (format nil + "See the amazing tooltip!~%The text is in the box on the ~:[right~;left~]" + leftp)) + :action #'(lambda () + (if (> (dcc (#/floatValue (cocoa-ref slider))) 0.5) + (to-right) + (to-left))))) + (add-subviews w left-box right-box) + (case (slot-value w 'with) + (:button (add-subviews w button)) + (:radio (add-subviews w left-button right-button)) + (:check (add-subviews w checkbox)) + (:popup (add-subviews w popup)) + (:pulldown (add-subviews w pulldown)) + (:slider (add-subviews w slider)) + (:drawing (add-subviews w drawing)) + (otherwise (format t "~&** The WITH slot is ~s, it must be either :BUTTON :RADIO :CHECK :POPUP ~ + :PULLDOWN :DRAWING or :SLIDER~%" + (slot-value w 'with)))) + (add-subviews left-box text) + (setf (demo-textbox w) text) + (add-contextual-menu w + (make-instance 'contextual-menu + :menu-items (generate-menu-items)) + t) + (window-show w)))) + +(defparameter *w nil) + +(defparameter *run-file-chooser-anyway* nil) + +(defvar *closing-under-program-control* nil +"Used in demonstrating tailored window-closing behaviour.") + +(defmethod window-may-close ((w view-hierarchy-demo-window)) + (or *closing-under-program-control* + (when (y-or-n-dialog "Do you really want to close the window like this?") + (setf *w nil) + t))) + +(defun run-demo () + (flet ((example (with) + (when *w (let ((*closing-under-program-control* t)) (perform-close *w))) + (setf *w (make-instance 'view-hierarchy-demo-window :with with)))) + (dolist (spec `(("Did you know?" "Contextual Menus" ,#'(lambda nil (y-or-n-dialog + (format nil + "Did you know there are contextual menus ~ + available - in many but not all places - ~ + when you press control-click?")))) + ("Did you know?" "New TOOLS item" ,#'(lambda nil (y-or-n-dialog + (format nil + "Did you know there is a \"Choose Color\" ~ + item added to the TOOLS menu?~% + (Sadly however there is no keyboard ~ + shortcut for it and it simply prints the ~ + chosen color in the console window.)")))) + ("Did you know?" "Tooltips" ,#'(lambda nil (y-or-n-dialog + (format nil + "Did you know that some sorts of view ~ + have tooltips attached?~%~ + (Sadly however some do not work as intended.)~%~ + These may be fixed strings, dynamically ~ + generated strings, or cocoa descriptions.")))) + ("Did you know?" "Choose File menu items (not working)" + ,#'(lambda nil (y-or-n-dialog + (format nil + "Did you know that there are items in the File menu ~ + and in the Easygui Demo menu that let you use a ~ + Choose-File-Dialog? Sadly however they do not work properly ~ + right now and will probably crash your CCL session. ~ + If you want to go ahead anyway, first select the ~ + \"Run File Chooser Anyway\" item.")))) + ("Did you know?" "Flipped screen mode" ,#'(lambda nil (y-or-n-dialog + (format nil + "Did you know that it is possible to position windows ~ + and items within them as if screen coordinates had their ~ + origin at screen top-left, as in Digitool's MCL?")))) + ("Did you know?" "Cocoa tracing" ,#'(lambda nil (y-or-n-dialog + (format nil + "Did you know that debugging messages can be ~ + produced when Cocoa calls are made? ~ + This relies on the DCC macro being used conscientiously, ~ + it is not automatic.")))) + ("Did you know?" "Font and Color support" ,#'(lambda nil (y-or-n-dialog + (format nil + "Did you know that there is some limited support for ~ + handling text fonts and colors and backgrounds? ~ + Try out the \"SHOUT!\" options in a demo window menu.")))) + ("Did you know?" "Window Close behaviour" ,#'(lambda nil (y-or-n-dialog + (format nil + "Did you know that windows can be made to invoke Lisp ~ + code when they are told to close? The primary method ~ + for Window-Should-Close decides whether the window ~ + should close or not, before- and after-methods could ~ + be used for other purposes. The Demo Window behaves ~ + differently when you close the window as part of ~ + creating a new one, and when you press its close button.")))) + ("Give Example" "With Button" ,#'(lambda nil (example :button))) + ("Give Example" "With Radio Buttons" ,#'(lambda nil (example :radio))) + ("Give Example" "With Checkbox" ,#'(lambda nil (example :check))) + ("Give Example" "With Popup Menu" ,#'(lambda nil (example :popup))) + ("Give Example" "With Pulldown Menu" ,#'(lambda nil (example :pulldown))) + ("Give Example" "With Drawing" ,#'(lambda nil (example :drawing))) + ("Give Example" "With Slider" ,#'(lambda nil (example :slider))) + ("Flipping" "New windows are flipped" ,#'(lambda nil (setf *screen-flipped* t))) + ("Flipping" "New windows are not flipped" ,#'(lambda nil (setf *screen-flipped* nil))) + ("Tracing" "Cocoa Calls are traced" ,#'(lambda nil (setf easygui::*debug-cocoa-calls* t))) + ("Tracing" "Cocoa Calls are not traced" ,#'(lambda nil (setf easygui::*debug-cocoa-calls* nil))) + ("Color Picker" "Text" ,#'(lambda nil + (cl-user::process-run-function "Pick color for text in box" + #'(lambda nil + (gui::with-autorelease-pool + (let* ((textbox (if *w (demo-textbox *w))) + (color (if textbox + (get-fore-color textbox) + (make-rgb :red 0 :green 0 :blue 255)))) + (setf color (user-pick-color :color color + :prompt "Pick a text color")) + (when textbox + (set-fore-color textbox color) + (invalidate-view textbox)))))))) + ("Color Picker" "Background" ,#'(lambda nil + (cl-user::process-run-function "Pick color for text in box" + #'(lambda nil + (gui::with-autorelease-pool + (let* ((textbox (if *w (demo-textbox *w))) + (color (if textbox + (get-back-color textbox) + (make-rgb :red 255 :green 220 :blue 200)))) + (setf color (user-pick-color :color color + :prompt "Pick a background color")) + (when textbox + (set-back-color textbox color t)))))))) + ("Destroy this menu" ,#'(lambda nil (remove-topbar-item (list "Easygui Demo")))) + ("Run File Chooser Anyway" ,#'(lambda nil (setf *run-file-chooser-anyway* t))) + ("File" "Get a pathname" ,#'(lambda nil + (when *run-file-chooser-anyway* + (print "Getting a pathname(Easygui Demo Menu)...doomed to failure!") + (choose-file-dialog :button-string "Get a pathname(EG)")))))) + (add-topbar-item (cons "Easygui Demo" (butlast spec)) (first (last spec)))) + (add-topbar-item '("Tools" "Choose Color") #'(lambda nil + (print (user-pick-color)))) + (add-topbar-item '("File" "Get a pathname") #'(lambda nil + (when *run-file-chooser-anyway* + (running-on-main-thread () + (print "Getting a pathname(File Menu)...doomed to failure") + (print (choose-file-dialog :button-string "Get a pathname(FILE)")))))) + (y-or-n-dialog "Have you spotted the new \"Easygui Demo\" item in the menubar?"))) + +; (easygui-demo::run-extended-demo) Index: /branches/new-random/examples/cocoa/easygui/example/tiny.lisp =================================================================== --- /branches/new-random/examples/cocoa/easygui/example/tiny.lisp (revision 13309) +++ /branches/new-random/examples/cocoa/easygui/example/tiny.lisp (revision 13309) @@ -0,0 +1,62 @@ +;;; Another example: +;;; This one creates a full-window view and draws in it. +;;; This is the easygui equivalent of examples/cocoa/tiny.lisp. + +(in-package :easygui-demo) ; In user code, this might be easygui-user + +(defclass tiny-demo-drawing-view (drawing-view) () + (:default-initargs :accept-key-events-p t)) + +(defconstant short-pi (coerce pi 'short-float)) +(defparameter numsides 12) + +(defmethod draw-view-rectangle ((view tiny-demo-drawing-view) rectangle) + (declare (ignore rectangle)) + (let* ((view (cocoa-ref view)) + (bounds (#/bounds view)) + (width (ns:ns-rect-width bounds)) + (height (ns:ns-rect-height bounds))) + (macrolet ((X (tt) `(* (1+ (sin ,tt)) width 0.5)) + (Y (tt) `(* (1+ (cos ,tt)) height 0.5))) + ;; Fill the view with white + (#/set (#/whiteColor ns:ns-color)) + ;; Trace two polygons with N sides and connect all of the vertices + ;; with lines + (#/set (#/blackColor ns:ns-color)) + (loop + for f from 0.0 below (* 2 short-pi) by (* 2 (/ short-pi numsides)) + do (loop + for g from 0.0 below (* 2 short-pi) by (* 2 (/ short-pi numsides)) + do (#/strokeLineFromPoint:toPoint: + ns:ns-bezier-path + (ns:make-ns-point (X f) (Y f)) + (ns:make-ns-point (X g) (Y g)))))))) + +(defclass tiny-demo-window (window) () + (:default-initargs :size (point 400 400) + :position (point 100 350) + :title "Tiny rectangle drawing demo" + :resizable-p nil + :minimizable-p t)) + +(defmethod initialize-view :after ((window tiny-demo-window)) + (let ((draw-view (make-instance 'tiny-demo-drawing-view))) + (setf (content-view window) draw-view) + (window-show window))) + +;;; Mouse handling: +;;; (Drag up to increase number of points, down to decrease) +(defvar *original-point* nil) + +(defmethod mouse-down ((view tiny-demo-drawing-view) &key location + &allow-other-keys) + (setf *original-point* location)) + +(defmethod mouse-up ((view tiny-demo-drawing-view) &key location + &allow-other-keys) + (when *original-point* + (cond ((> (point-y location) (point-y *original-point*)) + (incf numsides)) + ((< (point-y location) (point-y *original-point*)) + (decf numsides))) + (redisplay view))) Index: /branches/new-random/examples/cocoa/easygui/example/view-hierarchy.lisp =================================================================== --- /branches/new-random/examples/cocoa/easygui/example/view-hierarchy.lisp (revision 13309) +++ /branches/new-random/examples/cocoa/easygui/example/view-hierarchy.lisp (revision 13309) @@ -0,0 +1,43 @@ +(in-package :easygui-user) + +(defclass view-hierarchy-demo-window (window) + () + (:default-initargs :size (point 480 270) + :position (point 125 513) + :resizable-p nil + :minimizable-p t + :title "View tree demo") + (:documentation "Shows a window with a simple view hierarchy and a button +action that manipulates this hierarchy.")) + +(defmethod initialize-view :after ((w view-hierarchy-demo-window)) + (let ((left-box (make-instance 'box-view + :position (point 17 51) + :size (point 208 199) + :title "Left")) + (right-box (make-instance 'box-view + :position (point 255 51) + :size (point 208 199) + :title "Right")) + (swap-button (make-instance 'push-button-view + :position (point 173 12) + :text "Switch sides")) + (text (make-instance 'static-text-view + :text "Oink!" + :position (point 37 112))) + (leftp t)) + (setf (action swap-button) + (lambda () + (retaining-objects (text) + (cond (leftp + (remove-subviews left-box text) + (add-subviews right-box text)) + (t + (remove-subviews right-box text) + (add-subviews left-box text)))) + (setf leftp (not leftp)))) + (add-subviews w left-box right-box swap-button) + (add-subviews left-box text) + (window-show w))) + +;;; (make-instance 'view-hierarchy-demo-window) Index: /branches/new-random/examples/cocoa/easygui/new-cocoa-bindings.lisp =================================================================== --- /branches/new-random/examples/cocoa/easygui/new-cocoa-bindings.lisp (revision 13309) +++ /branches/new-random/examples/cocoa/easygui/new-cocoa-bindings.lisp (revision 13309) @@ -0,0 +1,162 @@ +(in-package :easygui) + +;;; Helper types: + +;;; point: +(defclass eg-point () + ((x :initarg :x :reader point-x) + (y :initarg :y :reader point-y))) + +(defun point (x y) + (assert (>= x 0)) + (assert (>= y 0)) + (make-instance 'eg-point :x x :y y)) + +(defmethod print-object ((o eg-point) s) + (print-unreadable-object (o s :identity nil :type t) + (format s "(~,2,F/~,2,F)" (point-x o) (point-y o)))) + +;;; range: +(defclass eg-range () + ((start :initarg :start :reader range-start) + (end :initarg :end :reader range-end))) + +(defun range (start end) + (assert (>= end start)) + (make-instance 'eg-range :start start :end end)) + +(defun range-nsrange (range) + (ns:make-ns-range (range-start range) (range-end range))) + +(defclass eg-rectangle () + ((x :initarg :x :reader rectangle-x) + (y :initarg :y :reader rectangle-y) + (width :initarg :width :reader rectangle-width) + (height :initarg :height :reader rectangle-height))) + +(defun rectangle (x y width height) + (assert (>= x 0)) + (assert (>= y 0)) + (assert (>= width 0)) + (assert (>= height 0)) + (make-instance 'eg-rectangle :x x :y y :width width :height height)) + +(defun rectangle-nsrect (r) + (ns:make-ns-rect (rectangle-x r) (rectangle-y r) + (rectangle-width r) (rectangle-height r))) + +(defun nsrect-rectangle (r) + (rectangle (ns:ns-rect-x r) (ns:ns-rect-y r) + (ns:ns-rect-width r) (ns:ns-rect-height r))) + +;;; Base class for all Cocoa-based Easygui objects: +(defclass easy-cocoa-object () + ((ref :initarg :cocoa-ref) + (ref-valid-p :initform t :accessor cocoa-ref-valid-p))) + +(defgeneric cocoa-ref (eg-object) + (:method ((eg-object easy-cocoa-object)) + (if (cocoa-ref-valid-p eg-object) + (slot-value eg-object 'ref) + (error "Attempting to access an invalidated Cocoa object on ~A!" + eg-object)))) + +(defgeneric (setf cocoa-ref) (new eg-object) + (:method (new (eg-object easy-cocoa-object)) + (setf (cocoa-ref-valid-p eg-object) t + (slot-value eg-object 'ref) new))) + +(defvar *window-position-default-x* 200) +(defvar *window-position-default-y* 200) +(defvar *window-size-default-x* 200) +(defvar *window-size-default-y* 200) + +(defun ns-rect-from-points (posn size) + (ns:make-ns-rect (point-x posn) (point-y posn) + (point-x size) (point-y size))) + +(defparameter *flag-to-mask-alist* + `( ;; (:zoomable-p . #$NSZoomableWindowMask) ; doesn't work + (:minimizable-p . ,#$NSMiniaturizableWindowMask) + (:resizable-p . ,#$NSResizableWindowMask) + (:closable-p . ,#$NSClosableWindowMask))) + +(defun flag-mask (keyword enabled-p) + (if enabled-p + (or (cdr (assoc keyword *flag-to-mask-alist*)) 0) + 0)) + +(defparameter *key-to-mask-alist* + `((:control . ,#$NSControlKeyMask) + (:alt . ,#$NSAlternateKeyMask) + (:command . ,#$NSCommandKeyMask))) + +(defun key-mask (keyword) + (or (cdr (assoc keyword *key-to-mask-alist*)) 0)) + +;;; Memory management helpers: + +(defmacro maybe-invalidating-object ((eg-object) &body body) + `(if (= 1 (#/retainCount (cocoa-ref ,eg-object))) + (multiple-value-prog1 (progn ,@body) + (setf (cocoa-ref-valid-p ,eg-object) nil)) + (progn ,@body))) + +(defmethod retain-object ((o easy-cocoa-object)) + (#/retain (cocoa-ref o))) + +(defmethod release-object ((o easy-cocoa-object)) + (#/release (cocoa-ref o))) + +(defmacro retaining-objects ((&rest eg-objects) &body body) + "Retains EG-OBJECTS, runs BODY forms and releases them after control +has left BODY." + (let ((objects (gensym))) + `(let ((,objects (list ,@eg-objects))) + (mapc #'retain-object ,objects) + (unwind-protect (progn ,@body) + (mapc #'release-object ,objects))))) + +;;; debug macro for #/ funcalls: + +(defvar *debug-cocoa-calls* nil) +;; Default changed to NIL by arthur, March 2009 + +(defparameter *cocoa-pause* nil +"When *debug-cocoa-calls* is not NIL, then a numeric value of *cocoa-pause* causes +some sleep after every message produced by the DCC macro. Useful if something is +causing a crash. During development it happened to me :-(") + +(defmacro dcc (form) +;; Trace output identifies process, and may pause: arthur, March 2009 + `(progn + (when *debug-cocoa-calls* + (format *trace-output* "[~a]Calling ~A on ~S~%" + (ccl::process-serial-number ccl::*current-process*) ',(first form) (list ,@(rest form))) + (when (and *cocoa-pause* (numberp *cocoa-pause*)) (sleep *cocoa-pause*))) + ,form)) + +;;; Running things on the main thread: + +(defclass cocoa-thunk (ns:ns-object) + ((thunk :accessor thunk-of)) + (:metaclass ns:+ns-object)) + +(objc:defmethod (#/run :void) ((self cocoa-thunk)) + (funcall (thunk-of self))) + +(defun run-on-main-thread (waitp thunk) + (let ((thunk* (make-instance 'cocoa-thunk))) + (setf (thunk-of thunk*) thunk) + (#/performSelectorOnMainThread:withObject:waitUntilDone: + thunk* + (@selector #/run) + +null-ptr+ + (not (not waitp))))) + +(defmacro running-on-main-thread ((&key (waitp t)) &body body) + `(run-on-main-thread ,waitp (lambda () ,@body))) + +;;; Getting views from objc objects: + +(defgeneric easygui-view-of (cocoa-view)) Index: /branches/new-random/examples/cocoa/easygui/package.lisp =================================================================== --- /branches/new-random/examples/cocoa/easygui/package.lisp (revision 13309) +++ /branches/new-random/examples/cocoa/easygui/package.lisp (revision 13309) @@ -0,0 +1,58 @@ +(cl:defpackage :easygui + (:use :cl) + (:import-from :ccl with-autorelease-pool @selector lisp-string-from-nsstring +null-ptr+) + (:export #:point #:ns-point-from-point #:range #:rectangle #:window + #:point-x #:point-y #:rectangle-x #:rectangle-y #:rectangle-width + #:rectangle-height + ;; cocoa stuff + #:retain-object #:release-object #:retaining-objects + ;; view classes + #:view #:static-text-view #:text-input-view #:password-input-view + #:push-button-view + #:form-view #:form-cell-view #:box-view #:drawing-view #:slider-view + #:check-box-view #:radio-button-view + #:menu-item-view #:pop-up-menu #:pull-down-menu #:contextual-menu + ;; event methods + #:mouse-down #:mouse-dragged #:mouse-up #:view-key-event-handler + ;; operators + #:cocoa-ref + #:add-subviews #:remove-subviews #:view-subviews + #:window-show #:set-window-title + #:content-view #:view-container + #:initialize-view #:action #:view-text + #:add-entry #:add-entries #:editable-p + #:draw-view-rectangle + #:entry-text #:cell-count #:nth-cell #:selection #:redisplay + #:string-value-of #:integer-value-of #:float-value-of + #:double-value-of + #:view-named #:view-nick-name + #:view-size view-position + #:view-mouse-position + #:view-font #:with-focused-view + #:clear-page + #:check-box-check #:check-box-uncheck #:check-box-checked-p + #:radio-button-selected-p #:radio-button-select #:radio-button-deselect + #:dialog-item-enabled-p #:set-dialog-item-enabled-p + #:shift-key-p #:control-key-p #:alt-key-p #:command-key-p + #:get-fore-color #:get-back-color #:set-fore-color #:set-back-color + #:invalidate-view + #:menu-selection #:menu-items #:set-menu-item-title #:add-contextual-menu + #:application-main-menu + #:navigate-menu #:navigate-topbar #:add-topbar-item + #:make-rgb #:rgb-red #:rgb-green #:rgb-blue #:rgb-opacity + ;; canned dialogs + #:y-or-n-dialog #:user-pick-color + #:choose-file-dialog #:choose-new-file-dialog #:choose-directory-dialog + + #:dcc + #:perform-close #:window-may-close + ;; variables + #:*screen-flipped* + #:*suppress-window-flushing*)) + +(cl:defpackage :easygui-demo + (:use :cl :easygui) + (:export #:converter-window #:tiny-demo-window)) + +(cl:defpackage :easygui-user + (:use :cl :easygui)) Index: /branches/new-random/examples/cocoa/easygui/rgb.lisp =================================================================== --- /branches/new-random/examples/cocoa/easygui/rgb.lisp (revision 13309) +++ /branches/new-random/examples/cocoa/easygui/rgb.lisp (revision 13309) @@ -0,0 +1,33 @@ +(in-package :easygui) + +; -------------------------------------------------------------------------------- +; This provides for Clozure CL some RGB functions to match Allegro CL. +; Contributed by AWSC (arthur.cater@ucd.ie) March 2009. +; Permission to disseminate, use and modify is granted. +; -------------------------------------------------------------------------------- + +(defun make-rgb (&key (red 0) (green 0) (blue 0) (opacity 1.0)) + (assert (typep red '(integer 0 255)) (red) + "Value of RED component for make-rgb must be an integer 0-255 inclusive") + (assert (typep green '(integer 0 255)) (green) + "Value of GREEN component for make-rgb must be an integer 0-255 inclusive") + (assert (typep blue '(integer 0 255)) (blue) + "Value of BLUE component for make-rgb must be an integer 0-255 inclusive") + (assert (typep opacity '(single-float 0.0 1.0)) (opacity) + "Value of OPACITY component for make-rgb must be a single-float 0.0-1.0 inclusive") + (#/retain + (#/colorWithCalibratedRed:green:blue:alpha: + ns:ns-color + (/ red 255.0) + (/ green 255.0) + (/ blue 255.0) + opacity))) + +(defun rgb-red (color) (round (* 255 (#/redComponent color)))) + +(defun rgb-green (color) (round (* 255 (#/greenComponent color)))) + +(defun rgb-blue (color) (round (* 255 (#/blueComponent color)))) + +(defun rgb-opacity (color) (#/alphaComponent color)) + Index: /branches/new-random/examples/cocoa/easygui/views.lisp =================================================================== --- /branches/new-random/examples/cocoa/easygui/views.lisp (revision 13309) +++ /branches/new-random/examples/cocoa/easygui/views.lisp (revision 13309) @@ -0,0 +1,1650 @@ +(in-package :easygui) + +; ---------------------------------------------------------------------- +; This is the Clozure Common Lisp file named 'views.lisp', March 2009, +; in the folder ccl/examples/cocoa/easygui/ +; It has been modified by AWSC (arthur.cater@ucd.ie), based upon +; an earlier contribution by an unknown author, borrowing also from +; the 'Seuss.lisp' contribution of 'KD'. +; Permission to use, further modify, disseminate, is hereby granted. +; No warranty is expressed or implied. +; Suggestions for - or accomplishment of - further improvement are welcome. +; Accompanying documentation for this and related files will be written +; and placed in ccl/examples/cocoa/easygui/documentation.txt +; Testing has been only with Mac OS 10.5.6 on a 32 bit PPC +; A demo of some capabilities is in 'easygui-demo-2.lisp' +; ---------------------------------------------------------------------- +; It extends previous work in the following principal ways: +; - windows, views and subviews may have nicknames +; - checkboxes and radio-buttons are provided +; - menus (pop-up, pull-down, contextual, and main-menu) are provided +; - MCL-like coordinates (Y increases downward) may optionally be used +; for placing windows on the screen, placing subviews within windows, +; and graphics within drawing views. +; - views can generally respond to mouse entry, exit, movement +; - static text views can respond to mouse clicks +; - text views can have colored text and colored background +; - windows can decline to close, and/or invoke daemons upon closing. +; - views and windows can have specific OBJC subclassed counterparts +; - Shift, Command, Control and Option keys may be interrogated +; ---------------------------------------------------------------------- + +(defmacro running-on-this-thread ((&key (waitp t)) &rest body) +;; The purpose of this trivial macro is to mark places where it is thought possible that +;; it may be preferable to use running-on-main-thread. + (declare (ignore waitp)) + `(progn ,@body)) + + +(defparameter *screen-flipped* nil +"When NIL, window positions are taken as referring to their bottom left, +as per Cocoa's native coordinate system. +When non-NIL, window positions are taken to refer to their top left, +as per - for instance - Digitool's MCL. +The default orientation for graphics within a drawing view is set to +correspond at the time of creation of that drawing view.") + +(defvar *cocoa-event* nil "Allows SHIFT-KEY-P & friends to operate on mouse clicks") + +(defvar *suppress-window-flushing* nil " +When T, graphics output produced with calls to With-Focused-View will not be immediately +flushed. This can reduce flicker and increase speed when there are many related uses of +With-Focused-View. It is then necessary though to make sure that somebody somewhere +calls Flush-Graphics at an appropriate time. +The same effect can be obtained for an individual use of With-Focused-View by giving +:WITHOUT-FLUSH as the first form in its body.") + +(defun ns-point-from-point (eg-point) ;; probably belongs in new-cocoa-bindings.lisp + (ns:make-ns-point (point-x eg-point) (point-y eg-point))) + +(defmacro with-focused-view (cocoa-view &body forms) +;; From KD's SEUSS.LISP but with added :WITHOUT-FLUSH syntax element +;; If the first of forms is the keyword :WITHOUT-FLUSH, or if dynamically +;; the value of *suppress-window-flushing* is non-NIL, then graphics output is not +;; immediately flushed. + (let ((noflush (eq (first forms) ':without-flush))) + `(if (dcc (#/lockFocusIfCanDraw ,cocoa-view)) + (unwind-protect + (progn ,@forms) + (dcc (#/unlockFocus ,cocoa-view)) + ,(unless noflush + `(unless *suppress-window-flushing* (flush-graphics ,cocoa-view))))))) + +(defun flush-graphics (cocoa-view) + (running-on-this-thread () + (dcc (#/flushGraphics (#/currentContext ns:ns-graphics-context))) + (dcc (#/flushWindow (#/window cocoa-view))))) + +(defun cocoa-null (ptr) + (equalp ptr ccl:+null-ptr+)) + + + + +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; +;;; view protocol + +(defgeneric initialize-view (view) + (:documentation "Initializes the view with a cocoa object, sets it up +according to initargs.")) + +(defgeneric add-1-subview (view super-view) + (:documentation "Adds a subview to another view in the view hierarchy.")) + +(defgeneric remove-1-subview (view super-view) + (:documentation "Removes a view from its superview, possibly deallocating it. +To avoid deallocation, use RETAINING-OBJECTS")) + +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; +;;; mixins +;;; +;;; Some view classes have an associated 'value', which can be accessed and set through +;;; accessors STRING-VALUE-OF, INTEGER-VALUE-OF, FLOAT-VALUE-OF, DOUBLE-VALUE-OF +;;; Such classes include STATIC-TEXT-VIEW, TEXT-INPUT-VIEW, PASSWORD-INPUT-VIEW, FORM-CELL-VIEW, SLIDER-VIEW +;;; +;;; Some view classes have an associated 'title', accessible and settable through VIEW-TEXT +;;; Such classes include WINDOW, PUSH-BUTTON-VIEW, BOX-VIEW, RADIO-BUTTON-VIEW, CHECK-BOX-VIEW, MENU-VIEW, MENU-ITEM-VIEW +;;; +;;; Some view classes have an associated 'text', also accessible and settable through VIEW-TEXT +;;; Such classes include STATIC-TEXT-VIEW, TEXT-INPUT-VIEW, PASSWORD-INPUT-VIEW, FORM-CELL-VIEW +;;; +;;; Most of those, apart from STATIC-TEXT-VIEW, may be manually 'editable'. +;;; +;;; Some view classes have an associated 'action'. +;;; Such classes include PUSH-BUTTON-VIEW, SLIDER-VIEW, RADIO-BUTTON-VIEW, CHECK-BOX-VIEW, MENU-ITEM-VIEW +;;; +;;; Some view classes cannot ever have a contextual menu attached to them, even though their superview +;;; and their subviews (if any) possibly do. +;;; Such classes include PUSH-BUTTON-VIEW, RADIO-BUTTON-VIEW, CHECK-BOX-VIEW, MENU-VIEW, MENU-ITEM-VIEW +;;; Perhaps these should be the same classes as those with actions. +;;; +;;; No view classes inherit from 'one-selection-mixin' +;;; Apparently it was intended that TEXT-INPUT-VIEW might do so some day. +;;; +;;; Some view classes have a single 'content view'. +;;; Such classes include WINDOW, BOX-VIEW. +;;; +;;; Some view classes inherit from 'background-coloring-mixin' +;;; Such classes include STATIC-TEXT-VIEW ... for now +;;; +;;; Some view classes inherit from 'text-coloring-mixin' +;;; Such classes include ... +;;; +;;; Some view classes inherit from 'fonting-mixin' +;;; Such classes include ... +;;; +;;; Some view classes inherit from 'mouse-updownabout-mixin' +;;; Such classes include ... +;;; +;;; Some view classes inherit from 'mouse-tracking-mixin' +;;; Such classes include ... + + + +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; +;;; Mixins dealing with text string and numeric equivalents + +(defclass value-mixin () ()) + +(defclass string-value-mixin (value-mixin) ()) + +(defclass numeric-value-mixin (value-mixin) ()) + +(defclass view-text-mixin () + ((text :initarg :text :initarg :dialog-item-text))) + +(defclass view-text-via-stringvalue-mixin (view-text-mixin string-value-mixin) + ()) + +(defclass view-text-via-title-mixin (view-text-mixin) + ((text :initarg :title))) + +(macrolet ((def-type-accessor (class lisp-type cocoa-reader cocoa-writer + &key (new-value-form 'new-value) (return-value-converter 'identity)) + (let ((name (intern (format nil "~A-VALUE-OF" lisp-type)))) + `(progn + (defmethod ,name ((o ,class)) + (,return-value-converter (dcc (,cocoa-reader (cocoa-ref o))))) + (defmethod (setf ,name) (new-value (o ,class)) + (dcc (,cocoa-writer (cocoa-ref o) ,new-value-form))))))) + (def-type-accessor string-value-mixin string #/stringValue #/setStringValue: + :return-value-converter lisp-string-from-nsstring ) + (def-type-accessor numeric-value-mixin integer #/intValue #/setIntValue:) + (def-type-accessor numeric-value-mixin float #/floatValue #/setFloatValue: + :new-value-form (coerce new-value 'single-float)) + (def-type-accessor numeric-value-mixin double #/doubleValue #/setDoubleValue: + :new-value-form (coerce new-value 'double-float))) + +(defmethod view-text ((view view-text-via-stringvalue-mixin)) + (string-value-of view)) + +(defmethod view-text ((view view-text-via-title-mixin)) + (lisp-string-from-nsstring (dcc (#/title (cocoa-ref view))))) + +(defmethod (setf view-text) (new-text (view view-text-via-stringvalue-mixin)) + (setf (string-value-of view) (ccl::%make-nsstring new-text))) + +(defmethod (setf view-text) (new-text (view view-text-via-title-mixin)) + (dcc (#/setTitle: (cocoa-ref view) (ccl::%make-nsstring new-text))) + new-text) + +(defmethod initialize-view :after ((view view-text-mixin)) + (when (slot-boundp view 'text) + (setf (view-text view) (slot-value view 'text)))) + + + +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; +;;; Mixins dealing with mouse sensitivity (1) + +(defclass action-view-mixin () + ((action :initarg :action) + (enabled :accessor dialog-item-enabled-p :initarg :dialog-item-enabled-p :initform t))) + +(defclass decline-menu-mixin () ()) + +(defmethod set-dialog-item-enabled-p ((view action-view-mixin) value) + (unless (eq (not value) (not (dialog-item-enabled-p view))) + (setf (dialog-item-enabled-p view) value) + (dcc (#/setEnabled: (cocoa-ref view) (if value #$YES #$NO))))) + +(defmethod initialize-view :after ((view action-view-mixin)) + (when (and (slot-boundp view 'action) (slot-value view 'action)) + (setf (action view) (slot-value view 'action))) + (unless (dialog-item-enabled-p view) + (dcc (#/setEnabled: (cocoa-ref view) #$NO)))) + + + +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; +;;; Mixins dealing with text properties - font, foreground and background colors, editability + +(defclass text-coloring-mixin () ()) + +(defclass text-fonting-mixin () ()) + +(defclass editable-mixin () ()) + +(defclass background-coloring-mixin () + ((drawsbackground :initform t :initarg :draws-background))) + +(defmethod initialize-view :after ((view background-coloring-mixin)) + (dcc (#/setDrawsBackground: (cocoa-ref view) (slot-value view 'drawsbackground))) + (when (and (cocoa-ref view) (slot-boundp view 'background)) + (dcc (#/setBackgroundColor: (cocoa-ref view) (slot-value view 'background))))) + +(defmethod editable-p ((view editable-mixin)) + (dcc (#/isEditable (cocoa-ref view)))) + +(defmethod (setf editable-p) (editable-p (view editable-mixin)) + (check-type editable-p boolean) + (dcc (#/setEditable: (cocoa-ref view) editable-p)) + editable-p) + + + +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; +;;; Mixin dealing with selection: Possibly obsolete? + +(defclass one-selection-mixin () ()) + +(defmethod (setf selection) (selection (view one-selection-mixin)) + (dcc (#/setSelectedRange: (cocoa-ref view) (range-nsrange selection))) + selection) + +(defmethod selection ((view one-selection-mixin)) + (let ((range (dcc (#/selectedRange (cocoa-ref view))))) + (if (= (ns:ns-range-location range) #$NSNotFound) + nil + (range (ns:ns-range-location range) + (ns:ns-range-length range))))) + + + +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; +;;; Mixin for content views: window, box, perhaps others. + +(defclass content-view-mixin () + ((content-view) + (flipped :initarg :flipped :initform *screen-flipped*))) + +(defmethod initialize-view :after ((view content-view-mixin)) + (unless (slot-boundp view 'content-view) + (let ((containee (make-instance 'contained-view + :cocoa-ref (dcc (#/contentView (cocoa-ref view))) + :view-nick-name '%CONTENT-OF-CONTENT-VIEW% + :flipped (slot-value view 'flipped)))) + (setf (slot-value view 'content-view) containee + (slot-value containee 'parent) view)))) + +(defmethod (setf content-view) (new-content-view (view content-view-mixin)) + (setf (slot-value view 'content-view) new-content-view) + (dcc (#/setContentView: (cocoa-ref view) (cocoa-ref new-content-view))) + new-content-view) + + + +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; +;;; Mixin for views that can respond to mouse entry, exit, and movement + +(defclass mouse-tracking-mixin () + ((mouse-target :reader view-mouse-target :initform nil) + (mouse-enter :accessor view-mouse-enter :initarg :mouse-enter :initform nil) + (mouse-exit :accessor view-mouse-exit :initarg :mouse-exit :initform nil) + (mouse-move :accessor view-mouse-move :initarg :mouse-move :initform nil))) + +(defclass easygui-mouse-target (ns:ns-object) + ((view :initarg :view :reader mouse-target-view :initform nil)) + (:metaclass ns:+ns-object)) + +(defmethod initialize-view :after ((view mouse-tracking-mixin)) + (let ((cocoaview (cocoa-ref view))) + (when cocoaview + (let ((target (make-instance 'easygui-mouse-target :view view))) + (setf (slot-value view 'mouse-target) target) + (dcc (#/retain target)) + (dcc (#/addTrackingRect:owner:userData:assumeInside: + cocoaview + (dcc (#/bounds cocoaview)) + target + ccl:+null-ptr+ + #$NO)))))) + +(objc:define-objc-method ((:void :mouse-entered (:id event)) easygui-mouse-target) + (let* ((view (mouse-target-view self)) + (fn (view-mouse-enter view))) + (when fn (funcall fn view :event event :allow-other-keys t)))) + +(objc:define-objc-method ((:void :mouse-exited (:id event)) easygui-mouse-target) + (let* ((view (mouse-target-view self)) + (fn (view-mouse-exit view))) + (when fn (funcall fn view :event event :allow-other-keys t)))) + +(objc:define-objc-method ((:void :mouse-move (:id event)) easygui-mouse-target) + (let* ((view (mouse-target-view self)) + (fn (view-mouse-move view))) + (when fn (funcall fn view :event event :allow-other-keys t)))) + + + +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; +;;; Class for the sort of view that is contained by a content view. + +(defclass contained-view (view) + ((flipped :initarg :flipped))) + +(defmethod content-view ((view content-view-mixin)) + (assert (eql (cocoa-ref (slot-value view 'content-view)) + (dcc (#/contentView (cocoa-ref view))))) + (slot-value view 'content-view)) + +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; +;;; the actual views (when adding a new class, +;;; consider *view-class-to-ns-class-map*): + +(defclass view (easy-cocoa-object) + ((position :initarg :position :reader view-position) + (size :initarg :size :reader view-size) + (frame-inited-p :initform nil) + (parent :reader view-container :initform nil) + (subviews :reader view-subviews :initarg :subviews :initform nil) + ;; When adding/removing multiple subviews, prevent multiple redraws. + ;; But - what code does those redraws? + (subviews-busy :accessor view-subviews-busy :initform nil) + (nickname :accessor view-nick-name :initarg :view-nick-name :initform nil) + (contextmenu :initarg :contextual-menu :initform nil) + (background :initarg :back-color :initform (#/whiteColor ns:ns-color)) + (foreground :initarg :fore-color :initform (#/blackColor ns:ns-color)) + (font :reader view-font :initarg :font :initarg :view-font :initform nil) + (specifically :reader view-specifically :initarg :specifically :initform nil) + ;; Next three not yet operative + (tip :initarg :tip :reader view-tip :initform nil) + (tiptag :initform nil))) + +(defclass window (content-view-mixin view-text-via-title-mixin view) + ((text :initarg :title :initform "" :reader window-title) + (zoomable-p :initarg :zoomable-p :initform t :reader window-zoomable-p) + (minimizable-p :initarg :minimizable-p :initform t + :reader window-minimizable-p) + (resizable-p :initarg :resizable-p :initform t + :reader window-resizable-p) + (closable-p :initarg :closable-p :initform t :reader window-closable-p) + (level :initarg :window-level :accessor window-level + :initform (dcc (#_CGWindowLevelForKey #$kCGNormalWindowLevelKey))) + (hidden :initarg :hidden :reader window-hidden :initform nil) + (window-needs-display-on-show :initform t) + (optimized :initarg :optimized :initform t) ; Set to NIL if you anticipate overlapping views in this window + (style :initarg :window-style :initform #$NSTitledWindowMask)) + (:default-initargs :specifically 'cocoa-contained-view)) + +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; +;;; + +(defmethod clear-page ((view view)) + (let* ((cview (cocoa-ref view)) + (rect (dcc (#/bounds cview))) + (color (slot-value view 'background))) + (with-focused-view cview + (dcc (#/setFill color)) + (dcc (#_NSRectFill rect))))) + +(defmethod clear-page ((window content-view-mixin)) + (clear-page (content-view window))) + +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; +;;; + +(defclass static-text-view (view view-text-via-stringvalue-mixin action-view-mixin text-coloring-mixin text-fonting-mixin background-coloring-mixin mouse-tracking-mixin) + ((mousedown :initform nil :initarg :mouse-down :accessor static-text-view-mouse-down) + (mouseup :initform nil :initarg :mouse-up :accessor static-text-view-mouse-up) + (mousedragged :initform nil :initarg :mouse-dragged :accessor static-text-view-mouse-dragged))) + +(defclass text-input-view (view editable-mixin text-coloring-mixin text-fonting-mixin view-text-via-stringvalue-mixin + ;; XXX: requires NSTextView, but this is an + ;; NSTextField: + #+not-yet one-selection-mixin + mouse-tracking-mixin) + ((input-locked-p :initform nil :initarg :input-locked-p + :reader text-input-locked-p))) + +(defclass password-input-view (text-input-view) + ()) + +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; +;;; + +(defclass push-button-view (view view-text-via-title-mixin action-view-mixin decline-menu-mixin) + ((default-button-p :initarg :default-button-p :initform nil + :reader default-button-p) + (bezelstyle :reader bezel-style :initarg :bezel-style :initform :rounded))) + +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; +;;; + +(defclass form-view (view) + ((autosize-cells-p :initarg :autosize-cells-p :initform nil) + (interline-spacing :initarg :interline-spacing :initform 9) + ;; cell width + )) + +(defclass form-cell-view (view editable-mixin view-text-via-stringvalue-mixin) + ()) + +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; +;;; + +(defclass box-view (content-view-mixin view-text-via-title-mixin view) ()) + +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; +;;; + +(defclass drawing-view (view mouse-tracking-mixin) + ( + ;; TODO: make this a mixin + (accept-key-events-p :initform nil :initarg :accept-key-events-p + :accessor accept-key-events-p) + (flipped :initform *screen-flipped* :initarg :flipped :reader flipped-p) + (mousedown :initform nil :initarg :mouse-down :accessor drawing-view-mouse-down) + (mouseup :initform nil :initarg :mouse-up :accessor drawing-view-mouse-up) + (mousedragged :initform nil :initarg :mouse-dragged :accessor drawing-view-mouse-dragged) + (draw-fn :initform nil :initarg :draw-fn :accessor draw-fn))) + +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; +;;; + +(defclass slider-view (view numeric-value-mixin action-view-mixin) + ((max-value :initarg :max-value) + (min-value :initarg :min-value) + (tick-mark-count :initarg :tick-mark-count) + (tick-mark-values :initarg :tick-mark-values) + (discrete-tick-marks-p :initarg :discrete-tick-marks-p))) + +; ---------------------------------------------------------------------- +; Specialisations of ns-xxx classes always begin 'cocoa-'. +; They allow such things as +; - finding the easygui window associated with a ns-view & easygui::view +; - flipped windows, flipped drawing-views +; - clickable static text, editable text fields +; - tooltips +; ---------------------------------------------------------------------- + +(defun calculate-ns-tooltip (cview) + ;; Returns a Lisp string to bhe used as a tooltip, or NIL. + ;; Easygu Views may or may not be created with a specific :TIP keyword argument. + ;; If there is none, there will be no tooltip displayed for the corresponding cocoa-view. + ;; Otherwise, if the argument is + ;; - a string, that string is used + ;; - a function, then if its return value is + ;; - a string, that string is used + ;; - NIL, a string informing that the tooltip is null and cocoa-describing the cocoa-view + ;; (possibly useful for identifying this view if it turns up in errors or inspector) + ;; - else a string naming the type of the result returned (possibly useful for debugging) + ;; - the keyword :IDENTIFY, the cocoa-description of the cocoa-view + ;; - anything else, a string informing what type the argument is. + (let* ((egview (when (slot-boundp cview 'easygui-view) (slot-value cview 'easygui-view))) + (tip (when egview (slot-value egview 'tip)))) + (cond + ((stringp tip) + tip) + ((functionp tip) + (let ((it (funcall tip))) + (cond + ((stringp it) it) + ((null it) (format nil "Null tooltip for ~a" (lisp-string-from-nsstring (dcc (#/description cview))))) + (t (format nil "** Tooltip function returned non-string object of type ~s **" (type-of it)))))) + ((eq tip :identify) (lisp-string-from-nsstring (dcc (#/description cview)))) + ((null egview) + (format nil "** Cocoa view ~s has no EasyGui-View **" cview)) + ((null tip) (format nil "No tooltip for ~a" (lisp-string-from-nsstring (dcc (#/description cview))))) + (t (format nil "** Tip slot of Cocoa view ~s~%is of type ~s,~%not a string or a function or :IDENTIFY. **" cview tip))))) + +(defmacro define-tooltip-accessor (cocoa-class) + `(progn + (objc:defmethod #/view:stringForToolTip:point:userData: + ((self ,cocoa-class) + view + (tag :oolipag) + (point :oint) + (userdata :address)) + (declare (ignorable tag point userdata)) + (ccl::%make-nsstring (or (calculate-ns-tooltip view) ""))) + (objc:defmethod #/toolTip ((view ,cocoa-class)) + (ccl::%make-nsstring (or (calculate-ns-tooltip view) ""))))) + +(defclass cocoa-window (ns:ns-window) + ((easygui-window :reader easygui-window-of)) + (:metaclass ns:+ns-object)) + +(defmethod print-object ((object cocoa-window) stream) + (print-unreadable-object (object stream :type t :identity t) + (let ((egview (if (slot-boundp object 'easygui-window) (easygui-window-of object) nil))) + (format stream "[~:[~;~s~]]" egview (when egview (view-nick-name egview))))) + object) + +(defmethod easygui-window-of ((eview view)) + (if (cocoa-ref eview) (easygui-window-of (cocoa-ref eview)) nil)) + +(defmethod easygui-window-of ((nsview ns:ns-view)) + (let ((nswindow (dcc (#/window nsview)))) + (if (typep nswindow 'cocoa-window) (easygui-window-of nswindow) nil))) + +(defclass cocoa-extension-mixin () + ((easygui-view :initarg :eg-view :reader easygui-view-of))) + +(defmethod print-object ((object cocoa-extension-mixin) stream) + (print-unreadable-object (object stream :type t :identity t) + (let ((egview (if (slot-boundp object 'easygui-view) (easygui-view-of object) nil))) + (format stream "[~:[~;~s~]]" egview (when egview (view-nick-name egview))))) + object) + +(defclass cocoa-text-field (cocoa-extension-mixin ns:ns-text-field) () + (:metaclass ns:+ns-object)) + +(define-tooltip-accessor cocoa-text-field) + +(defclass cocoa-mouseable-text-field (cocoa-text-field) () + (:metaclass ns:+ns-object)) + +(define-tooltip-accessor cocoa-mouseable-text-field) + +(defclass cocoa-contained-view (cocoa-extension-mixin ns:ns-view) + ((flipped :initarg :flipped :initform *screen-flipped*)) + (:metaclass ns:+ns-object)) + +(define-tooltip-accessor cocoa-contained-view) + +(defclass cocoa-secure-text-field (cocoa-extension-mixin ns:ns-secure-text-field) () + (:metaclass ns:+ns-object)) + +(define-tooltip-accessor cocoa-secure-text-field) + +(defclass cocoa-button (cocoa-extension-mixin ns:ns-button) () + (:metaclass ns:+ns-object)) + +(define-tooltip-accessor cocoa-button) + +(defclass cocoa-pop-up-button (cocoa-extension-mixin ns:ns-pop-up-button) () + (:metaclass ns:+ns-object)) + +(define-tooltip-accessor cocoa-pop-up-button) + +(defclass cocoa-menu-item (cocoa-extension-mixin ns:ns-menu-item) () + (:metaclass ns:+ns-object)) + +(define-tooltip-accessor cocoa-menu-item) + +(defclass cocoa-form (cocoa-extension-mixin ns:ns-form) () + (:metaclass ns:+ns-object)) + +(define-tooltip-accessor cocoa-form) + +(defclass cocoa-form-cell (cocoa-extension-mixin ns:ns-form-cell) () + (:metaclass ns:+ns-object)) + +(define-tooltip-accessor cocoa-form-cell) + +(defclass cocoa-box (cocoa-extension-mixin ns:ns-box) () + (:metaclass ns:+ns-object)) + +(define-tooltip-accessor cocoa-box) + +(defclass cocoa-drawing-view (cocoa-extension-mixin ns:ns-view) + ((flipped :initarg :flipped :initform *screen-flipped*)) + (:metaclass ns:+ns-object)) + +(define-tooltip-accessor cocoa-drawing-view) + +(defclass cocoa-slider (cocoa-extension-mixin ns:ns-slider) () + (:metaclass ns:+ns-object)) + +(define-tooltip-accessor cocoa-slider) + +(defparameter *view-class-to-ns-class-map* + '((static-text-view . cocoa-mouseable-text-field) + (password-input-view . cocoa-secure-text-field) + (text-input-view . cocoa-text-field) + (push-button-view . cocoa-button) + (check-box-view . cocoa-button) + (radio-button-view . cocoa-button) + (menu-view . cocoa-pop-up-button) + (menu-item-view . cocoa-menu-item) + (form-view . cocoa-form) + (form-cell-view . cocoa-form-cell) + (box-view . cocoa-box) + (drawing-view . cocoa-drawing-view) + (slider-view . cocoa-slider))) + +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; +;;; view initialization: + +(defmethod shared-initialize :around ((view view) new-slots &rest initargs) + (declare (ignore new-slots initargs)) + (call-next-method) + (running-on-main-thread () + (initialize-view view))) + +(defmethod initialize-view ((view view)) + "Initializes the view using the class-to-ns-class map both as constraint +on valid values of the :SPECIFICALLY initarg, and as source of default value. +Also attaches contextual menu if there is one." + (when (slot-boundp view 'ref) + (return-from initialize-view nil)) + (let ((ns-view-class (cdr (assoc (class-name (class-of view)) + *view-class-to-ns-class-map* + :test #'subtypep))) + (specifically (view-specifically view)) + cocoaview) + (when specifically + (cond + ((not (find-class specifically nil)) + (cerror "Ignore ~a and use ~a default" "~a value for :SPECIFICALLY does not name a class" specifically ns-view-class)) + ((or (null ns-view-class) (subtypep specifically ns-view-class)) + (setf ns-view-class specifically)) + (t (cerror "Ignore ~a and use ~a default" "~a value for :SPECIFICALLY is not a subclass of ~a" specifically ns-view-class)))) + (if ns-view-class + (setf cocoaview + (cond + ((and (slot-boundp view 'position) + (slot-boundp view 'size)) + (setf (slot-value view 'frame-inited-p) t) + (make-instance ns-view-class + :with-frame (with-slots (position size) view + (ns-rect-from-points position size)))) + (t (make-instance ns-view-class))) + (cocoa-ref view) cocoaview) + (cerror "Continue with cocoa-ref unset" "No view class found for type ~a" (class-of view))) + (when (and cocoaview (slot-boundp view 'contextmenu)) + (let ((menu (slot-value view 'contextmenu))) + (cond + ((null menu)) + ((null ns-view-class)) + ((typep menu 'menu-view) + (dcc (#/setMenu: cocoaview (slot-value menu 'ns-menu)))) + (t (warn "Ignoring contextmenu value ~s for view ~s" menu view))))) + (when (and cocoaview + (slot-value view 'tip) + (dcc (#/respondsToSelector: cocoaview (\@selector #/bounds)))) + (let ((bounds (#/bounds cocoaview))) + (setf (slot-value view 'tiptag) + (dcc (#/addToolTipRect:owner:userData: cocoaview bounds cocoaview ccl:+null-ptr+))))))) + +(defun screen-height nil + (running-on-this-thread () + (ns:ns-rect-height (dcc (#/frame (#/objectAtIndex: (#/screens ns:ns-screen) 0)))))) + +(defmethod view-content-rect ((view view) &optional hidden) + (if hidden + (ns:make-ns-rect 0 0 0 0) + (with-slots (position size) view + ;(if (slot-boundp view 'size) + ; (format t "~&View ~s has size ~s~%" view size) + ; (format t "~&View ~s has size unbound~%" view)) + (let* ((height (if (slot-boundp view 'size) (point-y size) *window-size-default-y*)) + (stated (if (slot-boundp view 'position) (point-y position) *window-position-default-y*)) + (screentop (screen-height)) ;; TODO: dtrt for multiple screens + (bottom (if (and *screen-flipped* (typep view 'window)) + (- screentop height stated) + stated))) + (ns:make-ns-rect + (if (slot-boundp view 'position) (point-x position) *window-position-default-x*) + bottom + (if (slot-boundp view 'size) (point-x size) *window-size-default-x*) + height))))) + +(defmethod initialize-view ((win window)) + "Initialize size, title, flags." + (with-slots (level hidden optimized style flipped specifically) win + (unless (and (find-class specifically nil) (subtypep specifically 'cocoa-contained-view)) + (cerror "Ignore ~a and create content view of type ~a" + "Value given for \":specifically\" is ~a which is not a subtype of ~a" + specifically 'cocoa-contained-view) + (setf specifically 'cocoa-contained-view)) + (let* ((content-rect (view-content-rect win hidden)) + (style-mask (logior ;; (flag-mask :zoomable-p (zoomable-p win)) + (flag-mask :resizable-p (window-resizable-p win)) + (flag-mask :minimizable-p (window-minimizable-p win)) + (flag-mask :closable-p (window-closable-p win)) + (if (or (window-resizable-p win) (window-minimizable-p win) (window-closable-p win)) + #$NSTitledWindowMask + 0) + style)) + (c-win + (make-instance 'cocoa-window + :with-content-rect content-rect + :style-mask style-mask + :backing #$NSBackingStoreBuffered ; TODO? + :defer t)) + (containee (make-instance specifically))) + (setf (slot-value containee 'flipped) flipped) + (dcc (#/setFrame: containee content-rect)) + (dcc (#/setContentView: c-win containee)) + (dcc (#/setDelegate: c-win c-win)) + (dcc (#/setBackgroundColor: c-win (slot-value win 'background))) + (dcc (#/setLevel: c-win level)) + (when optimized (dcc (#/useOptimizedDrawing: c-win #$YES))) + (setf (cocoa-ref win) c-win) + (setf (slot-value c-win 'easygui-window) win) + (if hidden + (dcc (#/disableFlushWindow c-win)) + (window-show win)) + c-win))) + +(defmethod initialize-view :after ((view text-input-view)) + (setf (editable-p view) (not (text-input-locked-p view))) + (setf (slot-value (cocoa-ref view) 'easygui-view) view)) + +(defmethod initialize-view :after ((view static-text-view)) + (dcc (#/setEditable: (cocoa-ref view) nil)) + (dcc (#/setBordered: (cocoa-ref view) nil)) + (dcc (#/setBezeled: (cocoa-ref view) nil)) + (setf (slot-value (cocoa-ref view) 'easygui-view) view)) + +(defparameter *bezelstyle-alist* + `((:round . #.#$NSRoundedBezelStyle) + (:square . #.#$NSRegularSquareBezelStyle) + (:regular-square . #.#$NSRegularSquareBezelStyle) + (:thick-square . #.#$NSThickSquareBezelStyle) + (:thicker-square . #.#$NSThickerSquareBezelStyle) + (:disclosure . #.#$NSDisclosureBezelStyle) + (:Shadowless-square . #.#$NSShadowlessSquareBezelStyle) + (:circular . #.#$NSCircularBezelStyle) + (:textured-square . #.#$NSTexturedSquareBezelStyle) + (:help-button . #.#$NSHelpButtonBezelStyle) + (:small-square . #.#$NSSmallSquareBezelStyle) + (:textured-rounded . #.#$NSTexturedRoundedBezelStyle) + (:round-rect . #.#$NSRoundRectBezelStyle) + (:recessed . #.#$NSRecessedBezelStyle) + (:rounded-disclosure . #.#$NSRoundedDisclosureBezelStyle))) + +(defun bezel-style-lookup (key) + (rest (or (assoc key *bezelstyle-alist*) (first *bezelstyle-alist*)))) + +(defmethod (setf bezel-style) (stylename (view push-button-view)) + (setf (slot-value view 'bezelstyle) (if (assoc stylename *bezelstyle-alist*) stylename :round)) + (dcc (#/setBezelStyle: (cocoa-ref view) (bezel-style-lookup (slot-value view 'bezelstyle)))) + stylename) + +(defmethod initialize-view :after ((view push-button-view)) + (dcc (#/setBezelStyle: (cocoa-ref view) (bezel-style-lookup (bezel-style view)))) + (let ((default-button-p (slot-value view 'default-button-p))) + (typecase default-button-p + (cons + (dcc (#/setKeyEquivalent: (cocoa-ref view) + (ccl::%make-nsstring (string (first default-button-p))))) + (dcc (#/setKeyEquivalentModifierMask: + (cocoa-ref view) + (apply #'logior (mapcar #'key-mask (cdr default-button-p)))))) + (string + (dcc (#/setKeyEquivalent: (cocoa-ref view) (ccl::%make-nsstring default-button-p)))) + (null) + (t + (dcc (#/setKeyEquivalent: (cocoa-ref view) (ccl::@ #.(string #\return))))))) + (setf (slot-value (cocoa-ref view) 'easygui-view) view)) + +(defmethod initialize-view :after ((view box-view)) + (setf (slot-value (cocoa-ref view) 'easygui-view) view)) + +(defmethod initialize-view :after ((view form-view)) + (when (slot-boundp view 'interline-spacing) + (dcc (#/setInterlineSpacing: (cocoa-ref view) + (gui::cgfloat (slot-value view 'interline-spacing))))) + (setf (slot-value (cocoa-ref view) 'easygui-view) view)) + +(defmethod initialize-view :after ((view slider-view)) + (with-slots (discrete-tick-marks-p tick-mark-count tick-mark-values min-value max-value) view + (cond ((and (slot-boundp view 'tick-mark-count) + (slot-boundp view 'discrete-tick-marks-p) + (slot-boundp view 'tick-mark-values) + (/= (length tick-mark-values) tick-mark-count)) + (error "Incompatible tick mark specification: ~A doesn't match ~ + count of ~A" tick-mark-count tick-mark-values)) + ((or (not (slot-boundp view 'max-value)) + (not (slot-boundp view 'min-value))) + (error "A slider view needs both :min-value and :max-value set."))) + (dcc (#/setMinValue: (cocoa-ref view) (float min-value (or 1.0d0 ns:+cgfloat-zero+)))) + (dcc (#/setMaxValue: (cocoa-ref view) (float max-value (or 1.0d0 ns:+cgfloat-zero+)))) + (when (slot-boundp view 'tick-mark-count) + (dcc (#/setNumberOfTickMarks: (cocoa-ref view) tick-mark-count)) + (dcc (#/setAllowsTickMarkValuesOnly: + (cocoa-ref view) (not (not discrete-tick-marks-p)))))) + (setf (slot-value (cocoa-ref view) 'easygui-view) view)) + +(defmethod initialize-view :after ((view text-coloring-mixin)) + (dcc (#/setTextColor: (cocoa-ref view) (slot-value view 'foreground)))) + +(defmethod initialize-view :after ((view text-fonting-mixin)) + (when (slot-value view 'font) + (dcc (#/setFont: (cocoa-ref view) (slot-value view 'font))))) + +(defmethod (setf view-font) ((new ns:ns-font) (view view)) + (setf (slot-value view 'font) new) + (dcc (#/setFont: (cocoa-ref view) new))) + +; ---------------------------------------------------------------------- +; Modifying position / size of view / window +; ---------------------------------------------------------------------- + +(defmethod (setf view-position) (point (self view)) + (running-on-main-thread () + (setf (slot-value self 'position) point) + (when (slot-value self 'frame-inited-p) + (dcc (#/setFrame: (cocoa-ref self) (view-content-rect self))) + (dcc (#/setNeedsDisplay (cocoa-ref self)))))) + +(defmethod (setf view-position) (point (self window)) + (running-on-main-thread () + (setf (slot-value self 'position) point) + (unless (window-hidden self) + (let* ((contentrect (view-content-rect self nil)) + (framerect (dcc (#/frameRectForContentRect: (cocoa-ref self) contentrect)))) + (dcc (#/setFrame:display: (cocoa-ref self) framerect t)))))) + +(defmethod (setf view-size) (point (self view)) + (running-on-main-thread () + (setf (slot-value self 'size) point) + (when (slot-value self 'frame-inited-p) + (dcc (#/setFrame: (cocoa-ref self) (view-content-rect self))) + (dcc (#/setNeedsDisplay (cocoa-ref self)))))) + +(defmethod (setf view-size) (point (self window)) + (running-on-main-thread () + (setf (slot-value self 'size) point) + (unless (window-hidden self) + (let* ((contentrect (view-content-rect self nil)) + (framerect (dcc (#/frameRectForContentRect: (cocoa-ref self) contentrect)))) + (dcc (#/setFrame:display: (cocoa-ref self) framerect t)))))) + +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; +;;; view hierarchies: + +(defmethod set-needs-display ((view view) flag) + (running-on-this-thread () + (dcc (#/setNeedsDisplay: (cocoa-ref view) flag)))) + +(defmethod set-needs-display ((view content-view-mixin) flag) + (set-needs-display (content-view view) flag)) + +(defmethod set-needs-display ((view window) flag) + (if (window-hidden view) + (setf (slot-value view 'window-needs-display-on-show) flag) + (set-needs-display (content-view view) flag))) + +(defmethod add-1-subview :around ((view view) (cw-view content-view-mixin)) + (add-1-subview view (content-view cw-view))) + +(defmethod add-1-subview :around ((view view) (super-view view)) + "Correctly initialize view positions" + (call-next-method) + (with-slots (position size frame-inited-p) view + (unless frame-inited-p + (setf frame-inited-p t) + (running-on-this-thread () + (let ((cocoa-view (cocoa-ref view))) + (dcc (#/setFrameOrigin: cocoa-view (ns-point-from-point position))) + (if (slot-boundp view 'size) + (dcc (#/setFrameSize: cocoa-view (ns-point-from-point size))) + (dcc (#/sizeToFit cocoa-view)))))) + (set-needs-display view t) + (unless (view-subviews-busy super-view) (set-needs-display super-view t)))) + +(defmethod add-1-subview ((view view) (super-view view)) + (running-on-this-thread () + (setf (slot-value view 'parent) super-view) + (push view (slot-value super-view 'subviews)) + (dcc (#/addSubview: (cocoa-ref super-view) (cocoa-ref view))))) + +(defun add-subviews (superview subview &rest subviews) + (setf (view-subviews-busy superview) t) + (add-1-subview subview superview) + (dolist (subview subviews) + (add-1-subview subview superview)) + (set-needs-display superview t) + (setf (view-subviews-busy superview) nil) + superview) + +(defmethod remove-1-subview ((view view) (cw-view content-view-mixin)) + (remove-1-subview view (content-view cw-view))) + +(defmethod remove-1-subview ((view view) (super-view view)) + (assert (eql (cocoa-ref super-view) (dcc (#/superview (cocoa-ref view))))) + (assert (member view (view-subviews super-view))) + (assert (eq super-view (slot-value view 'parent))) + (maybe-invalidating-object (view) + (setf (slot-value super-view 'subviews) (delete view (slot-value super-view 'subviews))) + (setf (slot-value view 'parent) nil) + (running-on-this-thread () + (dcc (#/removeFromSuperview (cocoa-ref view)))))) + +(defun remove-subviews (superview subview &rest subviews) + (setf (view-subviews-busy superview) t) + (remove-1-subview subview superview) + (dolist (subview subviews) + (remove-1-subview subview superview)) + (set-needs-display superview t) + (setf (view-subviews-busy superview) nil) + superview) + +(defmethod window-show ((window window)) + (running-on-this-thread () + (let ((cwin (cocoa-ref window))) + (when (window-hidden window) + (setf (slot-value window 'hidden) nil) + (let* ((contentrect (view-content-rect window nil)) + (framerect (dcc (#/frameRectForContentRect: (cocoa-ref window) contentrect)))) + (dcc (#/setFrame:display: (cocoa-ref window) framerect nil))) + (when (dcc (#/isMiniaturized cwin)) (dcc (#/deminiaturize: cwin cwin))) + (when (slot-value window 'window-needs-display-on-show) + (setf (slot-value window 'window-needs-display-on-show) nil) + (dcc (#/setNeedsDisplay: (cocoa-ref (content-view window)) t)))) + (dcc (#/makeKeyAndOrderFront: cwin nil)) + (when (dcc (#/isFlushWindowDisabled cwin)) + (dcc (#/enableFlushWindow cwin)) + (dcc (#/flushWindow cwin))) + window))) + + +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; +;;; Forms: + +(defmethod add-entry (entry (view form-view)) + (make-instance 'form-cell-view + :cocoa-ref (dcc (#/addEntry: (cocoa-ref view) (ccl::%make-nsstring entry))))) + +(defun add-entries (view &rest entries) + (prog1 (mapcar (lambda (entry) (add-entry entry view)) entries) + (dcc (#/setAutosizesCells: (cocoa-ref view) + (slot-value view 'autosize-cells-p))))) + +(defmethod cell-count ((view form-view)) + (dcc (#/numberOfRows (cocoa-ref view)))) + +(defmethod nth-cell (index view) + (assert (< index (cell-count view))) + (let ((cocoa-cell (dcc (#/cellAtIndex: (cocoa-ref view) index)))) + (when cocoa-cell + (make-instance 'form-cell-view :cocoa-ref cocoa-cell)))) + +(defmethod (setf entry-text) (text view index) + (setf (view-text (nth-cell index view)) text)) + +(defmethod entry-text (view index) + (view-text (nth-cell index view))) + +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; +;;; Window closing + +(defmethod window-may-close ((w window)) +"This generic is intended to allow applications to define :BEFORE and/or :AFTER methods +invoked when windows are closed. The default primary method returns T to indicate that +the window may close. If an overriding primary method returns NIL, the window will not +close in response to user action but will still close if the application quits. +(This is because window-may-close is called when the COCOA-WINDOW (specialised NS:NS-WINDOW) +that is attached to an EASYGUI::WINDOW object receives a performClose: message, as when +a user clicks the close button for example.)" + (declare (ignore w)) + t) + +(defmethod perform-close ((w window)) +"This generic is intended to allow applications to mimic the user clicking a window's +close button." + (running-on-this-thread () + (dcc (#/performClose: (cocoa-ref w) ccl:+null-ptr+)))) + +(objc:define-objc-method ((: :window-should-close (:id sender)) cocoa-window) + (declare (ignore sender)) ; The cocoa-window has been set up as its own delegate. Naughty? + (if (window-may-close (easygui-window-of self)) #$YES #$NO)) + +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; +;;; Drawing: + +(defmethod clear-page ((cocoa-view cocoa-drawing-view)) + (let* ((view (easygui-view-of cocoa-view)) + (rect (dcc (#/bounds cocoa-view))) + (color (slot-value view 'background))) + (with-focused-view cocoa-view + (dcc (#/setFill color)) + (dcc (#_NSRectFill rect))))) + +(objc::defmethod (#/isFlipped :) ((self cocoa-drawing-view)) + (if (slot-value self 'flipped) #$YES #$NO)) + +(objc::defmethod (#/isFlipped :) ((self cocoa-contained-view)) + (if (slot-value self 'flipped) #$YES #$NO)) + +(defmethod initialize-view :after ((view drawing-view)) + (setf (slot-value (cocoa-ref view) 'flipped) (slot-value view 'flipped)) + (setf (slot-value (cocoa-ref view) 'easygui-view) view)) + +(objc:defmethod (#/drawRect: :void) ((self cocoa-drawing-view) + (rect :ect)) + (dcc (draw-view-rectangle (easygui-view-of self) (nsrect-rectangle rect)))) + +(objc:defmethod (#/acceptsFirstReponder: :boolean) ((view cocoa-drawing-view)) + (accept-key-events-p (easygui-view-of view))) + +(defgeneric draw-view-rectangle (view rectangle) + (:method ((view drawing-view) rectangle) + (declare (ignorable view rectangle)) + (when (draw-fn view) + (let ((cview (cocoa-ref view))) + (with-focused-view cview (funcall (draw-fn view) view cview)))) + nil)) + +(defmethod redisplay ((view drawing-view) + &key rect) + (setf rect (if rect + (rectangle-nsrect rect) + (dcc (#/bounds (cocoa-ref view))))) + (dcc (#/setNeedsDisplayInRect: (cocoa-ref view) rect))) + +(define-useful-mouse-event-handling-routines cocoa-drawing-view) +(define-useful-mouse-event-handling-routines cocoa-mouseable-text-field) + +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; +;; Around methods for VIEW provide bindings for *modifier-key-pattern* for all kinds of views, +;; allowing for Shift-Key-P and friends. +;; Primary methods do nothing, but may be overridden by user code. + +;(defmethod mouse-down :around ((view view) &key cocoa-event location button click-count delta) +; (declare (ignorable cocoa-event location button click-count delta)) +; (let ((*cocoa-event* cocoa-event) +; (*modifier-key-pattern* (dcc (#/modifierFlags cocoa-event)))) +; (call-next-method))) + +(defmethod mouse-down ((view view) &key cocoa-event location button click-count delta) + (declare (ignorable view cocoa-event location button click-count delta)) + nil) + +;(defmethod mouse-up :around ((view view) &key cocoa-event location button click-count delta) +; (declare (ignorable cocoa-event location button click-count delta)) +; (let ((*cocoa-event* cocoa-event) +; (*modifier-key-pattern* (dcc (#/modifierFlags cocoa-event)))) +; (call-next-method))) + +(defmethod mouse-up ((view view) &key cocoa-event location button click-count delta) + (declare (ignorable view cocoa-event location button click-count delta)) + nil) + +;(defmethod mouse-dragged :around ((view view) &key cocoa-event location button click-count delta) +; (declare (ignorable cocoa-event location button click-count delta)) +; (let ((*cocoa-event* cocoa-event) +; (*modifier-key-pattern* (dcc (#/modifierFlags cocoa-event)))) +; (call-next-method))) + +(defmethod mouse-dragged ((view view) &key cocoa-event location button click-count delta) + (declare (ignorable view cocoa-event location button click-count delta)) + nil) + +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; +;; Primary methods for DRAWING-VIEW. What now is the point? + +(defmethod mouse-down ((view drawing-view) &key cocoa-event location button click-count delta) + (let ((mousefn (drawing-view-mouse-down view)) + (*cocoa-event* cocoa-event) + (*modifier-key-pattern* (dcc (#/modifierFlags cocoa-event)))) + (when mousefn + (funcall mousefn view + :location location + :allow-other-keys t + :button button + :cocoa-event cocoa-event + :click-count click-count + :delta delta)))) + +(defmethod mouse-up ((view drawing-view) &key cocoa-event location button click-count delta) + (let ((mousefn (drawing-view-mouse-up view)) + (*cocoa-event* cocoa-event) + (*modifier-key-pattern* (dcc (#/modifierFlags cocoa-event)))) + (when mousefn + (funcall mousefn view + :location location + :allow-other-keys t + :button button + :cocoa-event cocoa-event + :click-count click-count + :delta delta)))) + +(defmethod mouse-dragged ((view drawing-view) &key cocoa-event location button click-count delta) + (let ((mousefn (drawing-view-mouse-dragged view)) + (*cocoa-event* cocoa-event) + (*modifier-key-pattern* (dcc (#/modifierFlags cocoa-event)))) + (when mousefn + (funcall mousefn view + :location location + :allow-other-keys t + :button button + :cocoa-event cocoa-event + :click-count click-count + :delta delta)))) + +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; +;; Primary methods for STATIC-TEXT-VIEW. What now is the point? + +(defmethod mouse-down ((view static-text-view) &key cocoa-event location button click-count delta) + (let ((mousefn (static-text-view-mouse-down view)) + (*cocoa-event* cocoa-event) + (*modifier-key-pattern* (dcc (#/modifierFlags cocoa-event)))) + (when mousefn + (funcall mousefn view + :location location + :allow-other-keys t + :button button + :cocoa-event cocoa-event + :click-count click-count + :delta delta)))) + +(defmethod mouse-up ((view static-text-view) &key cocoa-event location button click-count delta) + (let ((mousefn (static-text-view-mouse-up view)) + (*cocoa-event* cocoa-event) + (*modifier-key-pattern* (dcc (#/modifierFlags cocoa-event)))) + (when mousefn + (funcall mousefn view + :location location + :allow-other-keys t + :button button + :cocoa-event cocoa-event + :click-count click-count + :delta delta)))) + +(defmethod mouse-dragged ((view static-text-view) &key cocoa-event location button click-count delta) + (let ((mousefn (static-text-view-mouse-dragged view)) + (*cocoa-event* cocoa-event) + (*modifier-key-pattern* (dcc (#/modifierFlags cocoa-event)))) + (when mousefn + (funcall mousefn view + :location location + :allow-other-keys t + :button button + :cocoa-event cocoa-event + :click-count click-count + :delta delta)))) + +; ------------------- +(defmethod view-named (name (view view)) + (find name (view-subviews view) :key #'view-nick-name)) + +(defmethod view-named (name (container content-view-mixin)) + (view-named name (content-view container))) + +(defmethod view-subviews ((w content-view-mixin)) + (view-subviews (content-view w))) + +; ---------------------- + +(defmethod view-nickname-chain ((view view) &optional include-everything) " +Yields two values: +- a list of nicknames of containing views, starting with outermost container +- the view or window that contains the view with the first name in the list, + or NIL if the first name belongs to a window. +If include-everything is NIL (the default), the list does not contain the +autogenerated name for content views of windows or boxes, and contains names +of views or windows that have non-NIL names. The second value may then be +a view or window that has no nickname of its own. +If include-everything is T, the list does contain the autogenerated name of +content views of windows or boxes, it does contain NIL for views named NIL, +and the second value will always be NIL." + (do (chain + nickname + (outermost view (view-container outermost))) + ((or (null outermost) + (and (null (setf nickname (view-nick-name outermost))) + (not include-everything))) + (values chain outermost)) + (when (or include-everything (not (eq nickname '%CONTENT-OF-CONTENT-VIEW%))) + (push (view-nick-name outermost) chain)))) + +; ---------------------- + +(defclass check-box-view (view view-text-via-title-mixin action-view-mixin decline-menu-mixin) + ((checked :initarg :checked :initform nil))) + +(defmethod check-box-check ((self check-box-view) &optional perform) + (running-on-this-thread () + (unless (eql (dcc (#/state (cocoa-ref self))) #$NSOnState) + (if perform + (dcc (#/performClick: (cocoa-ref self) nil)) + (dcc (#/setState: (cocoa-ref self) #$NSOnState))) + t))) + +(defmethod initialize-view :after ((view check-box-view)) + (when (cocoa-ref view) + (dcc (#/setButtonType: (cocoa-ref view) #$NSSwitchButton)) + (when (slot-value view 'checked) (check-box-check view)) + (setf (slot-value (cocoa-ref view) 'easygui-view) view))) + +(defmethod check-box-uncheck ((self check-box-view) &optional perform) + (running-on-this-thread () + (unless (eql (dcc (#/state (cocoa-ref self))) #$NSOffState) + (if perform + (dcc (#/performClick: (cocoa-ref self) nil)) + (dcc (#/setState: (cocoa-ref self) #$NSOffState))) + t))) + +(defmethod check-box-checked-p ((self check-box-view)) + (eql (dcc (#/state (cocoa-ref self))) #$NSOnState)) + +(defmethod (setf check-box-checked-p) (new (self check-box-view)) + (if new + (check-box-check self) + (check-box-uncheck self)) + new) + +; ------------------------- +(defclass radio-button-view (view view-text-via-title-mixin action-view-mixin decline-menu-mixin) + ((selected :initarg :selected :reader radio-button-selected-p :initform nil) + (cluster :initarg :cluster :initform '#:default-cluster)) + (:default-initargs :action #'(lambda () nil))) + +(defun deselect-radio-button-cohorts (radio-button-view) + (when (view-container radio-button-view) + (dolist (sibling (view-subviews (view-container radio-button-view))) + (when (and (not (eq sibling radio-button-view)) + (typep sibling 'radio-button-view) + (eq (slot-value radio-button-view 'cluster) (slot-value sibling 'cluster)) + (eql (dcc (#/state (cocoa-ref sibling))) #$NSOnState)) + (setf (slot-value sibling 'selected) nil) + (dcc (#/setState: (cocoa-ref sibling) #$NSOffState)))))) + +(defmethod radio-button-select ((self radio-button-view) &optional perform) + (running-on-this-thread () + (if perform + (dcc (#/performClick: (cocoa-ref self) nil)) + (progn + (deselect-radio-button-cohorts self) + (setf (slot-value self 'selected) t) + (dcc (#/setState: (cocoa-ref self) #$NSOnState)))))) + +(defmethod initialize-view :after ((self radio-button-view)) + (when (cocoa-ref self) + (dcc (#/setButtonType: (cocoa-ref self) #$NSRadioButton)) + (when (slot-value self 'selected) (radio-button-select self)) + (setf (slot-value (cocoa-ref self) 'easygui-view) self))) + +(defmethod radio-button-deselect ((self radio-button-view)) + (running-on-this-thread () + (dcc (#/setState: (cocoa-ref self) #$NSOffState)) + (prog1 + (radio-button-selected-p self) + (setf (slot-value self 'selected) nil)))) + +(defmethod (setf action) (handler (view radio-button-view)) + (call-next-method + (lambda () + (deselect-radio-button-cohorts view) + (setf (slot-value view 'selected) t) + (funcall handler)) + view) + handler) + +; ---------------------------------------------------------------------- +; INVALIDATE-VIEW +; ---------------------------------------------------------------------- + +(defmethod invalidate-view ((view view) &optional total) + (declare (ignorable total)) + (let ((cview (cocoa-ref view))) + (dcc (#/setNeedsDisplay: cview #$YES)))) + +(defmethod invalidate-view ((window window) &optional total) + (declare (ignorable total)) + (let* ((cocoaview (cocoa-ref window)) + (contentview (dcc (#/contentView cocoaview)))) + (dcc (#/setNeedsDisplay: contentview #$YES)))) + +; ---------------------------------------------------------------------- +; Methods to GET- & SET- FORE- & BACK- COLOR +; ---------------------------------------------------------------------- + +(defmethod set-fore-color ((view view) (color ns:ns-color)) + (setf (slot-value view 'foreground) color)) + +(defmethod set-fore-color :before ((view view-text-via-stringvalue-mixin) (color ns:ns-color)) + (dcc (#/setTextColor: (cocoa-ref view) color))) + +(defmethod set-fore-color ((view cocoa-extension-mixin) (color ns:ns-color)) + (set-fore-color (easygui-view-of view) color)) + +(defmethod set-back-color ((view view) (color ns:ns-color) &optional redisplay-p) + (setf (slot-value view 'background) color) + (when redisplay-p (invalidate-view view))) + +(defmethod set-back-color :after ((view static-text-view) (color ns:ns-color) &optional redisplay-p) + (dcc (#/setBackgroundColor: (cocoa-ref view) color)) + (when redisplay-p (invalidate-view view))) + +(defmethod set-back-color ((view cocoa-extension-mixin) (color ns:ns-color) &optional redisplay-p) + (set-back-color (easygui-view-of view) color redisplay-p)) + +(defmethod get-fore-color ((view view)) + (slot-value view 'foreground)) + +(defmethod get-fore-color ((view cocoa-extension-mixin)) + (get-fore-color (easygui-view-of view))) + +(defmethod get-back-color ((view view)) + (slot-value view 'background)) + +(defmethod get-back-color ((view cocoa-extension-mixin)) + (get-back-color (easygui-view-of view))) + +; --------------------- Menus Begin --------------------- + +(defmethod view-text ((self ns:ns-menu)) + (lisp-string-from-nsstring (dcc (#/title self)))) + +(defmethod (setf view-text) (new (self ns:ns-menu)) + (running-on-this-thread () + (dcc (#/setTitle: self (ccl::%make-nsstring new))) + new)) + +(defclass menu-view (view view-text-via-title-mixin decline-menu-mixin) + ((selection :initarg :selection :reader menu-selection :initform nil) + (menu-kind :initarg :menu-kind :reader menu-kind :initform :pull-down-menu) + (menu-items :initarg :menu-items :reader menu-items :initform nil) + ns-menu + %result)) + +(defclass menu-item-view (view view-text-via-title-mixin action-view-mixin decline-menu-mixin) + (parent-menu + action + submenu) + (:default-initargs :action #'(lambda () nil))) + +;(defmethod (setf view-text) :after (new (menu menu-view)) +; (declare (ignorable new)) +; (dcc (#/setNeedsDisplay: (cocoa-ref menu) t))) + +(defmethod initialize-instance :after ((self menu-view) &rest args &key menu-items selection) + (declare (ignorable args selection)) + (let ((ns-menu nil)) + (if (slot-boundp self 'ns-menu) + (setf ns-menu (slot-value self 'ns-menu)) + (setf ns-menu (dcc (#/menu (cocoa-ref self))) + (slot-value self 'ns-menu) ns-menu)) + ;(format t "~&Initializing menu ~a with ~a items~%" self (length menu-items)) + (dolist (item menu-items) + ;(format t "~&Adding ~a to menu ~a~%" item self) + (cond + ((typep item 'menu-view) + (let ((intermediary (make-instance 'menu-item-view + :title (view-text item)))) + (setf (slot-value intermediary 'submenu) item) + (dcc (#/setSubmenu: (cocoa-ref intermediary) (slot-value item 'ns-menu))) + (dcc (#/addItem: ns-menu (cocoa-ref intermediary))))) + ((not (typep item 'menu-item-view)) + (warn "Ignoring so-called menu item ~s" item)) + ((slot-boundp item 'parent-menu) + (warn "Ignoring menu item ~s, which is already an item in some menu" item)) + (t (let ((coco (cocoa-ref item))) + (dcc (#/addItem: ns-menu coco)) + (setf (slot-value item 'parent-menu) self))))))) + +(defmethod (setf action) (new (menu-item menu-item-view)) + (call-next-method + #'(lambda () + (if (slot-boundp menu-item 'parent-menu) + (let ((parent (slot-value menu-item 'parent-menu))) + (setf (slot-value parent 'selection) menu-item) + (setf (slot-value parent '%result) (funcall new))) + (funcall new))) + menu-item) + new) + +(defmethod set-menu-item-title ((menu-item menu-item-view) title) + (running-on-this-thread () + (dcc (#/setTitle: (cocoa-ref menu-item) (ccl::%make-nsstring title))))) + +(defmethod set-menu-item-title ((menu-item ns:ns-menu-item) title) + (running-on-this-thread () + (dcc (#/setTitle: menu-item (ccl::%make-nsstring title))))) + +; ------------------- +(defclass pop-up-menu (menu-view) + () + (:default-initargs :menu-kind :pop-up-menu)) + +(defmethod initialize-instance :after ((self pop-up-menu) &rest args &key selection) + (declare (ignorable args)) + (with-slots (ns-menu menu-items) self + (setf (view-text self) + (cond + ((null menu-items) + "") + ((null selection) + (setf (slot-value self 'selection) (first menu-items)) + (view-text (first menu-items))) + ((stringp selection) + selection) + ((member selection menu-items) + (setf (slot-value self 'selection) selection) + (view-text selection)) + (t "")))) + (setf (slot-value (cocoa-ref self) 'easygui-view) self)) + +; ---------------------- +(defclass pull-down-menu (menu-view) + () + (:default-initargs :menu-kind :pull-down-menu)) + +(defmethod initialize-instance :after ((self pull-down-menu) &rest args &key title) + (declare (ignorable args)) + (running-on-this-thread () + (dcc (#/insertItemWithTitle:atIndex: (cocoa-ref self) (ccl::%make-nsstring (or title "")) 0)))) + +(defmethod initialize-view :after ((self pull-down-menu)) + (running-on-this-thread () + (when (cocoa-ref self) + (dcc (#/setPullsDown: (cocoa-ref self) #$YES)) + (setf (slot-value (cocoa-ref self) 'easygui-view) self)))) + +; ----------------------- +(defclass contextual-menu (menu-view) + () + (:default-initargs :menu-kind :contextual-menu)) + +(defgeneric add-contextual-menu (container menu &optional subviews)) + +(defmethod add-contextual-menu ((window window) (menu menu-view) &optional subviews) + (add-contextual-menu (content-view window) menu subviews)) + +(defmethod add-contextual-menu ((view view) (menu menu-view) &optional subviews) + (running-on-this-thread () + (dcc (#/setMenu: (cocoa-ref view) (slot-value menu 'ns-menu))) + (when subviews + (dolist (sub (view-subviews view)) + (unless (or (not (cocoa-null (dcc (#/menu (cocoa-ref sub))))) + (typep sub 'decline-menu-mixin)) + (add-contextual-menu sub menu subviews)))))) + +(defmethod add-contextual-menu ((view menu-view) (refusenik decline-menu-mixin) &optional subviews) + (declare (ignore subviews)) + (error "Cannot add a contextual menu to a view of class ~s" (type-of refusenik))) + +; ------------------------- +(defun application-object nil + (dcc (#/sharedApplication ns:ns-application))) + +(defun application-main-menu nil + (dcc (#/mainMenu (application-object)))) + +(defgeneric navigate-menu (titles menu)) + +(defmethod navigate-menu ((titles list) (menu menu-view)) +;; Returns NIL if the path of titles leads nowhere, when no appropriately titled menu-item or submenu exists; +;; Returns a EasyGui MENU-ITEM if the path of titles leads to a leaf item; +;; Returns a EasyGui MENU-VIEW if the path of titles leads to a submenu. + (cond + ((null titles) menu) + (t (let ((it (find (first titles) (menu-items menu) :test #'equalp :key #'view-text))) + (when it (navigate-menu (rest titles) it)))))) + +(defun navigate-native-menu (titles menu) +;; Returns a NIL or a NS:NS-MENU-ITEM or a NS:NS-MENU +;; Returns a NS:NS-MENU when the title path leads to a submenu, +;; Returns a NS;NS-MENU-ITEM when the title path leads to a leaf menu item, +;; Returns NIL when the title path leads nowhere. + (running-on-this-thread () + (if (null titles) + menu + (do ((number (dcc (#/numberOfItems menu))) + (index 0 (1+ index)) + item found) + ((or found (>= index number)) + (cond + ((or (null found) (null (rest titles))) found) + ((null (dcc (#/hasSubmenu found))) nil) + (t (navigate-native-menu (rest titles) (dcc (#/submenu found)))))) + (setf item (dcc (#/itemAtIndex: menu index))) + (if (or (equalp (first titles) (lisp-string-from-nsstring (dcc (#/title item)))) + ; The Apple menu item has title "" but its submenu has title "Apple", hence ... + (and (dcc (#/hasSubmenu item)) + (equalp (first titles) (lisp-string-from-nsstring (dcc (#/title (dcc (#/submenu item)))))))) + (setf found item)))))) + +(defmethod navigate-topbar ((titles list)) + (navigate-native-menu titles (application-main-menu))) + +(defun add-menu-item (menu titles &optional action) +;; Adds a chain of submenus and a final leaf item with the indicated action. +;; If the final leaf item already exists, its action will be changed. Perhaps this is too dangerous. +;; The Apple submenu may not be altered; the application's submenu cannot be found. + (cond + ((null titles) + (cerror "Return NIL" "No title path supplied")) + ((not (and (consp titles) (stringp (first titles)))) + (cerror "Return NIL, some empty submenus may have been created" "Title path is not a list of strings")) + ((not (typep menu 'ns:ns-menu)) + (cerror "Return NIL" "Not a Cocoa menu: ~s" menu)) + (t (let* ((ns-title (ccl::%make-nsstring (first titles))) + (item (dcc (#/itemWithTitle: menu ns-title))) + (ns-nullstring (ccl::%make-nsstring ""))) + (flet ((linkup (leaf action) ;; Modelled on code in easygui/action-targets.lisp + (let ((target (make-instance 'generic-easygui-target :handler (or action #'(lambda () nil)) :shooter leaf))) + (dcc (#/setTarget: leaf target)) + (dcc (#/setAction: leaf (\@selector #/activateAction)))))) + (cond + ((equalp (first titles) "-") + (if (rest titles) + (cerror "Leave menu unchanged" "A menu separator (an item having title \"-\") may not have a submenu") + (dcc (#/addItem: menu (dcc (#/separatorItem ns:ns-menu-item)))))) + ((cocoa-null item) ;; No such item, something must be added + (if (rest titles) + (let ((number (dcc (#/numberOfItems menu))) + (submenu (make-instance 'ns:ns-menu))) + (running-on-this-thread () + (dcc (#/addItemWithTitle:action:keyEquivalent: menu ns-title ccl:+null-ptr+ ns-nullstring)) + (setf item (dcc (#/itemAtIndex: menu number))) ;; That's where it got put + (dcc (#/initWithTitle: submenu ns-title)) + (dcc (#/setSubmenu: item submenu))) + (add-menu-item submenu (rest titles) action)) + (let ((number (dcc (#/numberOfItems menu)))) + (running-on-this-thread () + (dcc (#/addItemWithTitle:action:keyEquivalent: menu ns-title ccl:+null-ptr+ ns-nullstring)) + (setf item (dcc (#/itemAtIndex: menu number)))) + (linkup item action)))) + ((and (null (rest titles)) (dcc (#/hasSubmenu item))) + (cerror "Leave menu unchanged" "An Action may not be added to any item with a submenu")) + ((and (rest titles) (dcc (#/hasSubmenu item))) + (add-menu-item (dcc (#/submenu item)) (rest titles) action)) + ((rest titles) + (cerror "Leave menu unchanged" "An existing menu item cannot be converted to have a submenu")) + (t (linkup item action)))))))) ;; Change the action of an existing item: desirable, or dangerous? + +(defun add-topbar-item (titles &optional action) + (if (and (consp titles) (rest titles)) + (add-menu-item (application-main-menu) titles action) + (cerror "Return NIL" "Title path must be a list with at least two elements: ~s" titles))) + +(defun remove-menu-item (menu titles retain-if-empty) + (if (not (and (consp titles) (stringp (first titles)))) + (cerror "Return NIL" "Title path is not a list of strings") + (do ((number (dcc (#/numberOfItems menu))) + (index 0 (1+ index)) + item found) + ((or found (>= index number)) + (when found + (if (rest titles) + (when (dcc (#/hasSubmenu found)) + (remove-menu-item (dcc (#/submenu found)) (rest titles) retain-if-empty) + (unless (or retain-if-empty (> (dcc (#/numberOfItems (dcc (#/submenu found)))) 0)) + (dcc (#/removeItem: menu found)))) + (dcc (#/removeItem: menu found))))) + (setf item (dcc (#/itemAtIndex: menu index))) + (when (equalp (first titles) (lisp-string-from-nsstring (dcc (#/title item)))) + (setf found item))))) + +(defun remove-topbar-item (titles &key retain-if-empty) + (when (and (consp titles) + (not (member (first titles) '("" "Apple") :test #'equalp))) + (remove-menu-item (application-main-menu) titles retain-if-empty))) + +(defun add-application-submenu (title &rest trees) " +Adds a menu to the topbar application-menu with the given title. +Its menu-items names are got from the CARs of the trees. +The CDRs of these trees may consist either of further trees, allowing arbitrarily +deep menu structures, or of a one-element list that is expected to be a parameterless +function to be used as the Action of a leaf menu item. +Example: + (add-application-submenu \"Beeps\" + '(\"Normal\" #'normal-beep) + '(\"Stupid\" #'stupid-beep) + '(\"Choose\" (\"Custom beep 1\" #'custom-beep-1-not-implemented) + (\"Custom beep 2\" #'custom-beep-2-not-implemented))) +" + (labels ((valid-tree (tree) + (and (consp tree) (stringp (first tree)))) + (prepending (seq tree) + (cond + ((every #'valid-tree (rest tree)) + (dolist (subtree (rest tree)) + (prepending (append seq (list (first subtree))) (rest subtree)))) + ((and (consp tree) (stringp (first tree)) (consp (rest tree)) (null (cddr tree))) + (add-topbar-item (append seq (list (first tree))) (second tree))) + (t (cerror "Ignore this tree" "Malformed tree ~s" tree))))) + (if (every #'valid-tree trees) + (dolist (subtree trees) (prepending (list title) subtree)) + (cerror "Return NIL" "Malformed top-level trees")))) + +; --------------- +; Keyboard input handling + +(defmethod view-key-event-handler ((view window) char) + (declare (ignorable char)) + nil) + +(objc:define-objc-method ((:void :key-down (:id event)) cocoa-window) + (let ((*cocoa-event* event) + (*modifier-key-pattern* (#/modifierFlags event))) + (view-key-event-handler + (easygui-window-of self) + (schar (lisp-string-from-nsstring (dcc (#/charactersIgnoringModifiers event))) 0)))) + +(defun shift-key-p nil + (not (zerop (logand *modifier-key-pattern* (key-mask :shift))))) + +(defun control-key-p nil + (not (zerop (logand *modifier-key-pattern* (key-mask :control))))) + +(defun alt-key-p nil + (not (zerop (logand *modifier-key-pattern* (key-mask :alt))))) + +(defun command-key-p nil + (not (zerop (logand *modifier-key-pattern* (key-mask :command))))) + +(defmacro with-modifier-key-information (parameterless-function) +;; NOT TESTED YET! +"Wraps the function into a context where control-key-p &c will get their current values. +To be used primarily when placing a call to a function in another process." + (let ((gvar (gensym))) + `(let ((,gvar *modifier-key-pattern*)) + (function (lambda nil + (let ((*modifier-key-pattern* ,gvar)) + (funcall ,parameterless-function))))))) + +(defun view-mouse-position (view) + (let* ((w (cocoa-ref (easygui-window-of view))) + (mouselocation (dcc (#/mouseLocationOutsideOfEventStream w))) + (cview (if (typep view 'window) (content-view view) view)) + (nspt (dcc (#/convertPoint:fromView: (cocoa-ref cview) mouselocation NIL)))) + ;; todo: check point is inside bounds, lest negative coords + (point (ns:ns-point-x nspt) (ns:ns-point-y nspt)))) Index: /branches/new-random/examples/cocoa/interface-databases/HOWTO.html =================================================================== --- /branches/new-random/examples/cocoa/interface-databases/HOWTO.html (revision 13309) +++ /branches/new-random/examples/cocoa/interface-databases/HOWTO.html (revision 13309) @@ -0,0 +1,371 @@ + + + + Interface Databases HOWTO + + + + + +

Interface Databases HOWTO

+ + +

About Interface Databases

+ +

This HOWTO guide explains how to build interface databases + for Clozure CL (formerly OpenMCL).

+ +

Clozure CL's interface databases are + descriptions of foreign data structures and functions. Clozure + CL uses the interface databases to call C and Objective-C + functions, and to use C and Objective-C data + structures. Clozure CL provides the interface databases you + are most likely to need when writing Cocoa applications, but + it doesn't provide databases for every foreign library and + framework. For some applications, you may need to generate + interface databases yourself. This HOWTO shows how to do + that.

+ +

Online Documentation

+ +

The concepts explained here are also discussed in depth in + the OpenMCL online + documentation. See this + page for an explanation of how to generate interface + databases.

+ +

Interface Databases and the Foreign Function Interface

+ +

Clozure CL provides an integrated foreign function interface + that can call external C and Objective-C functions and methods, + define and instantiate Objective-C classes, and read and write + fields of C data structures. Using these features, a Lisp + program can interoperate freely with external libraries and + frameworks. Of special interest to Mac OS X programmers, Lisp + programs can link Mac OS X frameworks and use the features they + provide, including standard OS X features such as the AppKit, + CoreAudio, OpenGL, CoreAnimation, and so on.

+ +

Interface Databases and Frameworks

+ +

In order to use externally-defined functions and data + structures, Clozure CL needs descriptions of the entry points + and data fields, including their names and types. It reads + this information from the interface databases. A separate tool + called ffigen parses the header files that describe foreign + libraries and frameworks, such as the ones provided with + Apple's SDKs, to produce descriptions readable by Clozure CL's + parse-ffi subsystem. The parse-ffi subsystem then reads these + descriptions and writes the results of its processing to + files. These files, written by parse-ffi, are what we refer to + as interface databases.

+ +

Adding New Interface Databases

+ +

In order to generate a new set of interface databases, you + must follow these steps, explained in the following + sections:

+ +

Obtain and install the ffigen tool
Create an appropriately-named and -structured + subdirectory of the interfaces directory for your + platform
Write a script ("populate.sh") and then run it to populate the new interface + subdirectory
Using the parse-ffi subsystem, convert the ".ffi" files + created in the previous step to interface databases

+ +

1. Obtain and install ffigen

+ +

ffigen is a command-line tool, available from Clozure, that + parses C and Objective-C header files for use by the Clozure + CL parse-ffi subsystem. A "populate.sh" script drives the + ffigen tool to parse library or framework headers, and then + the Clozure CL parse-ffi subsystem converts the ffigen output + to interface databases. In order to generate interface + databases you must first obtain the latest version of ffigen + for the platform you are using.

+ +

ffigen is available from the Clozure ftp server + at clozure.com/pub/testing/. A + separate version of ffigen is available for each supported + platform. Make sure to get the latest version available for the + platform you are using. For example,

+ +

+      ffigen-apple-gcc-5465-x86-64-2007-11-06-00-00-59 
+

+ +

supports Apple's C compiler ("gcc") on the 64-bit Intel + platform ("x86-64").

+ +

Once you have the appropriate version of ffigen, unpack and + install it in a location where it will be convenient to + use. You might, for example, install it in /usr/local/ffigen, + or in ~/ffigen.

+ +

The ffigen distribution unpacks into a directory with the + following structure:

+ +

bin/

h-to-ffi.sh

ffigen/

bin/

ffigen

include/

+ +

To install ffigen, unpack the distribution, then move the + unpacked directory to its install location. For example, to + install it in /usr/local/ffigen:

+ +

+      tar zxf ffigen-apple-gcc-5465-x86-64-2007-11-06-00-00-59.tar.gz
+
+      mv ffigen-apple-gcc-5465-x86-64-2007-11-06-00-00-59\
+         /usr/local/ffigen
+

+ +

You can now add a line to your shell's init script to add the + h-to-ffi.sh script to your PATH, and the script will find the + ffigen tool automatically.

+ +

For example, if your shell is bash, you can add this line to + your .bashrc or .bash_profile:

+ +

PATH="/usr/local/ffigen/bin:${PATH}"

+ +

2. Create An Interfaces Subdirectory

+ +

Clozure CL finds interface databases by consulting a + search-list. It initializes the search list when starting up, + and the exact contents of the search list depend on the + platform Clozure CL is running on. For example, a Mac OS X + version of Clozure CL running on the 64-bit Intel platform + searches "ccl/darwin-x86-headers64/", but a Mac OS X version + running on the 32-bit PowerPC platform searches + "ccl/darwin-headers/". We'll call this search directory + the interfaces directory. For the rest of this + discussion we'll assume we are running Clozure CL on Mac OS X + on the 64-bit Intel platform.

+ +

Each supported foreign library or framework has a + corresponding subdirectory of the interfaces directory. For + example, we can find a "cocoa" subdrectory of + "ccl/darwin-x86-headers64/"; it contains the interface databases + for the Cocoa framework. Similarly, the "gl" subdirectory + contains the interface databases for OpenGL.

+ +

In order to add support for a new framework, we must first + add a subdirectory for the framework to the interfaces + directory. For example, suppose we want to add support for the + TWAIN framework. This framework is one of the standard frameworks + provided in Mac OS X 10.5, but not one of those supported + out-of-the-box by Clozure CL.

+ +

To add TWAIN interfaces for use by Clozure CL, follow these + steps:

+ +

Create a subdirectory called "twain" in the interfaces directory
+
Create a subdirectory of "twain" called "C".
+
If you look inside any of the existing interfaces + subdirectories, you see that each one contains a similar + "C" subdirectory. The ffigen tool populates these "C" + subdirectories with ".ffi" files when it parses the + framework or library headers.
+
+
Inside the "C" subdirectory, create a file called + "populate.sh"
+
Again, you can see that the existing interfaces + subdirectories contain "populate.sh" files in their "C" + subdirectories. This file is the script that drives the + ffigen tool for the particular interface databases we are + creating. The next section explains what to put in the + "populate.sh" file.
+

+ +

3. Write and Run a "populate.sh" Script

+ +

If you look in the directory

+ +

ccl/darwin-x86-headers64/cocoa/C/

+ +

for example, you'll find a script named populate.sh. The + script sets up flags for the C compiler, and then calls + h-to-ffi.sh on each of several header files that define the + Objective-C data structures and entry points used by the Cocoa + framework. The first step in generating or regenerating the + interface databases is to run one of these populate.sh + scripts.

+ +

You can create a populate.sh script by copying an existing + one from another set of interfaces, then replacing the + references to the libraries or frameworks that the + populate.sh script processes. A good place to start is with + an existing populate.sh script that processes a library or + framework that is similar to, or related to, the one you want + to add.

+ +

For example, for our TWAIN interfaces, we can copy the + populate.sh script from the existing qtkit subdirectory. The + contents of the qtkit script are:

+ + +

+#!/bin/sh
+# For now, things earlier than the 10.5 sdk are pointless
+rm -rf System Developer usr
+SDK=/Developer/SDKs/MacOSX10.5.sdk
+CFLAGS="-m64 -fobjc-abi-version=2 -isysroot ${SDK} -mmacosx-version-min=10.5"; export CFLAGS
+h-to-ffi.sh ${SDK}/System/Library/Frameworks/QTKit.framework/Headers/QTKit.h
+

+ + +

Now we just need to change the reference to the QTKit header + file so that it refers instead to the TWAIN header file:

+ +

+#!/bin/sh
+# For now, things earlier than the 10.5 sdk are pointless
+rm -rf System Developer usr
+SDK=/Developer/SDKs/MacOSX10.5.sdk
+CFLAGS="-m64 -fobjc-abi-version=2 -isysroot ${SDK} -mmacosx-version-min=10.5"; export CFLAGS
+h-to-ffi.sh ${SDK}/System/Library/Frameworks/TWAIN.framework/Headers/TWAIN.h
+

+ +

Next you must run the script to generate the ".ffi" files + that will be used in the next step. Assuming you installed + ffigen as described in step 1, and made sure that it's on your + PATH, all you have to do is cd to the directory that contains + your new populate.sh script and execute it:

+ +

+$ ./populate.sh
++++ /Developer/SDKs/MacOSX10.5.sdk/System/Library/Frameworks/TWAIN.framework/Headers/TWAIN.h
+

+ +

Now, if you look inside the C subdirectory of your twain + directory, you should find that it has been populated with + ".ff" files:

+ +

+oshirion:C mikel$ ls
+./           ../          Developer/   populate.sh*
+
+oshirion:C mikel$ ls Developer/SDKs/MacOSX10.5.sdk/System/Library/Frameworks/TWAIN.framework/Headers/
+./         ../        TWAIN.ffi
+        
+

+ +

4. Use parse-ffi to Generate Interface Databases

+ +

The ".ffi" files, created in the prevoius step, contain a + series of s-expressions readable by the Clozure CL parse-ffi + subsystem. Each s-expression describes a datastructure or + entry point in the foreign library.

+ +

Once you have created a set of these ".ffi" files by running + a populate.sh script, you must next use Clozure CL to convert + the ".ffi" files into interface database files.

+ +

First, launch Clozure CL
+
Next, evaluate this form to load the parse-ffi subsystem:
+
(require "PARSE-FFI")
+
+
Next, supposing you want to parse the TWAIN files + created in the previous section, evaluate the following form:
+
(ccl::parse-standard-ffi-files :twain)
+
The parse-ffi subsystem looks for a subdirectory named + "twain" in the interface databases directory for the + current platform.
+ +
The first time you run this expression, you'll see + warnings like this one:
+
```
+; Warning: Interface file #P"ccl:darwin-x86-headers64;twain;types.cdb.newest" does not exist.
+          
```
+
These warnings are normal.
+
+
Finally, evaluate the following form once more:
+
(ccl::parse-standard-ffi-files :twain)
+
In order to correctly describe some foreign definitions, + the parse-ffi subsystem needs information provided by the + first parse. Thus, to produce a complete and corrrect set of + interface databases, you should always evaluate + the parse-standard-ffi-files form twice.
+

+ +

+ + +

Conclusion

+ +

Assuming all went well, you should now find a new set of + interface database files in the twain subdirectory of the + interface databases directory for your current + platform. Congratulations! You have added a new set of + interface databases to your Clozure CL installation.

+ +

For more information about ffigen and the interface + translation process, refer to the online documentation for the + Interface + Translator.

+ + + + + Index: /branches/new-random/examples/cocoa/interface-databases/HOWTO_files/stylesheets/styles.css =================================================================== --- /branches/new-random/examples/cocoa/interface-databases/HOWTO_files/stylesheets/styles.css (revision 13309) +++ /branches/new-random/examples/cocoa/interface-databases/HOWTO_files/stylesheets/styles.css (revision 13309) @@ -0,0 +1,55 @@ +body { + background-color: white; + font-family: "Helvetica Neue", Arial, Helvetica, Geneva, sans-serif; +} + +.title { + text-align: center; + font-size: 16pt; +} + +.subtitle { + font-size: medium; + font-weight: bold; + text-align: center; +} + +.byline { + text-align: center; + font-weight: bold; + font-size: small; +} + +.section-head { + padding-top: 2em; + padding-left: 1em; +} + +.body-text { + font: 12pt Georgia, "Times New Roman", Times, serif; + margin-left: 4em; + margin-right: 4em; + text-indent: 3em; +} + +.note { + font: 12pt Georgia, "Times New Roman", Times, serif; + margin-left: 6em; + margin-right: 6em; + text-indent: 0em; +} + +.inline-image { + text-align: center; +} + +.nav { + text-align: center; + font-size: large; + font-weight: bold; + padding-top: 4em; +} + +li, pre { + text-indent: 0; +} Index: /branches/new-random/examples/cocoa/nib-loading/HOWTO.html =================================================================== --- /branches/new-random/examples/cocoa/nib-loading/HOWTO.html (revision 13309) +++ /branches/new-random/examples/cocoa/nib-loading/HOWTO.html (revision 13309) @@ -0,0 +1,441 @@ + + + + Nib-Loading HOWTO + + + + + +

Nib-Loading HOWTO

+ +

This HOWTO shows how you can load nibfiles + into a running copy of Clozure CL by evaluating Lisp forms. You + might want to load nibfiles this way to test user-interface + elements that you are working on for an application project, or + to enable an application to dynamically load optional + user-interface elements.

+ +

Nibfiles

+ +

A large part of developing Cocoa applications is creating + user-interface elements using the Cocoa frameworks. Although + it's perfectly possible to create any user-interface element + just by making method calls against the frameworks, the more + standard way to design a user interface is to use Apple's + InterfaceBuilder application to + create nibfiles—files of archived + Objective-C objects that implement the user-interface + elements.

+ +

InterfaceBuilder is an application that ships with Apple's + Developer Tools. The Developer Tools are an optional install + that comes with Mac OS X. Before you can use this HOWTO, you'll + need to make sure that Apple's Developer Tools are installed on + your system. Members of Apple's developer programs may download + the tools for free from + Apple's developer + website, but normally there is no need. You can simply + use the optional Developer Tools installer on the Mac OS X + system disks to install the tools.

+ +

Using Nibfiles

+ +

Using InterfaceBuilder, you can quickly and easily create + windows, dialog boxes, text fields, buttons, and other + user-interface elements. The elements you create with + InterfaceBuilder have the standard appearance and behavior + specified by Apple's Human Interface Guidelines.

+ +

InterfaceBuilder saves descriptions of these objects + in nibfiles. These files contain archived + representations of Objective-C classes and objects. When you + launch an application and it loads a nibfile, the Cocoa runtime + creates these Objective-C objects in memory, complete with any + instance-variable references to other objects that might have + been saved in the nibfile. In short, a nibfile is an archived + collection of user-interface objects that Cocoa can quickly and + easily revive in memory.

+ +

The normal way that Objective-C programmers use nibfiles is + by storing them in an application bundle. The application's + Info.plist file (also stored in the bundle) specifies which + nibfile is the application's main nibfile, and that file is + loaded automatically when the application starts up. The + application can dynamically load other nibfiles from the bundle + by making method calls.

+ +

Lisp applications written with Clozure CL can also use + nibfiles in this same fashion (see the "currency-converter" + HOWTO in the "cocoa" examples folder), but Lisp programmers are + accustomed to highly interactive development, and might want to + simply load an arbitrary nibfile into a running Clozure CL + session. Fortunately, this is easy to do.

+ +

How To Load a Nibfile

+ +

Let's start by loading a very simple nibfile from the Clozure + CL Listener window. Start by launching the Clozure CL + application.

+ +

In the same directory as this HOWTO file, you'll find a + nibfile named "hello.nib". This is an extremely simple nibfile + that creates a single Cocoa window with a greeting in it. We'll + use forms typed into the Listener window to load it.

+ +

We're going to call the Objective-C class + method loadNibFile:externalNameTable:withZone: to + load the nibfile into memory, creating the window that is + described in the file. First, though, we need to set up some + data structures that we'll pass to this method.

+ +

The arguments + to loadNibFile:externalNameTable:withZone: are a + pathname, a dictionary object, and a memory zone. As with every + Objective-C method call, we also pass the object that receives + the message, which in this case is the class NSBundle.

+ +

The pathname is just a reference to the nibfile we want to + load. The dictionary holds references to objects. In this + first simple example, we'll use it only to identify the + nibfile's owner, which in this case is the application + itself. The zone is a reference to the area of memory where + the nibfile objects will be allocated.

+ +

Don't worry if none of this makes sense to you; the code to + create these objects is simple and straightforward, and should + help clarify what's going on.

+ +

1. Get the Zone

+ +

First, we'll get a memory zone. We'll tell Cocoa to allocate + the nibfile objects in the same zone that the application + uses, so getting a zone is a simple matter of asking the + application for the one it's using.

+ +

Before we can ask the application anything, we need a + reference to it. When the Clozure CL application starts up, + it stores a reference to the Cocoa application object into + the special variable *NSApp*.

+ +

Start by changing to the CCL package; most of the utility + functions we'll use are defined in that package:

+ +

+        ? (in-package :ccl)
+        #<Package "CCL">
+

+ +

We have a reference to the running Clozure CL application + object in the special variable *NSApp*. We can ask it for its + zone, where it allocates objects in memory:

+ +

+        ? (setf *my-zone* (#/zone *NSApp*))
+        #<A Foreign Pointer #x8B000>
+

+ +

Now we have a reference to the application's zone, which is + one of the parameters we need to pass + to loadNibFile:externalNameTable:withZone:.

+ +

2. Make a Dictionary

+ +

The dictionary argument + to loadNibFile:externalNameTable:withZone: is + used for two purposes: to identify the nibfile's owner, and + to collect toplevel objects.

+ +

The nibfile's owner becomes the owner of all the toplevel + objects created when the nibfile is loaded, objects such as + windows, buttons, and so on. A nibfile's owner manages the + objects created when the nibfile is loaded, and provides a + way for your code to get references to those objects. You + supply an owner object in the dictionary, under the + key "NSNibOwner".

+ +

The toplevel objects are objects, such as windows, that are + created when the nibfile is loaded. To collect these, you + can pass an NSMutableArray object under the + key NSNibTopLevelObjects.

+ +

For this first example, we'll pass an owner object (the + application object), but we don't need to collect toplevel + objects, so we'll omit + the NSNibTopLevelObjects key.

+ +

+        ? (setf *my-dict* 
+        (#/dictionaryWithObject:forKey: ns:ns-mutable-dictionary
+        *my-app* 
+        #@"NSNibOwner"))
+        #<NS-MUTABLE-DICTIONARY {
+        NSNibOwner = <LispApplication: 0x1b8e10>;
+        } (#x137F3DD0)>
+        
+

+ +

3. Load the Nibfile

+ +

Now that we have the zone and the dictionary we need, we + can load the nibfile. We just need to create an NSString with + the proper pathname first:

+ +

+        ? (setf *nib-path* 
+        (%make-nsstring 
+        (namestring "/usr/local/openmcl/ccl/examples/cocoa/nib-loading/hello.nib")))
+        #<NS-MUTABLE-STRING "/usr/local/openmcl/ccl/examples/cocoa/nib-loading/hello.nib" (#x13902C10)>
+

+ +

Now we can actually load the nibfile, passing the method + the objects we've created:

+ +

+        ? (#/loadNibFile:externalNameTable:withZone: 
+        ns:ns-bundle
+        *nib-path*
+        *my-dict*
+        *my-zone*)
+        T
+

+ +

The window defined in the "hello.nib" file should appear + on the + screen. The loadNibFile:externalNameTable:withZone: + method returns T to indicate it loaded the + nibfile successfully; if it had failed, it would have + returned NIL.

+ +

At this point we no longer need the pathname and + dictionary objects. The *nib-path* we must release:

+ +

+        ? (setf *nib-path* (#/release *nib-path*))
+        NIL
+

+ +

The *my-dict* instance was not created with #/alloc (or with + MAKE-INSTANCE), so it is already autoreleased, and we don't need + to release it again. + +

Making a Nib-loading Function

+ +

Loading a nibfile seems like something we might want to do + repeatedly, and so it makes sense to make it as easy as possible + to do. Let's make a single function we can call to load a nib as + needed.

+ +

The nib-loading function can take the file to be loaded as a + parameter, and then perform the sequence of steps covered in the + previous section. If we just literally do that, the result will + look something like this:

+ +

+(defun load-nibfile (nib-path)
+  (let* ((app-zone (#/zone *NSApp*))
+         (nib-name (%make-nsstring (namestring nib-path)))
+         (dict (#/dictionaryWithObject:forKey: 
+                 ns-mutable-dictionary app #@"NSNibOwner")))
+    (#/loadNibFile:externalNameTable:withZone: ns:ns-bundle
+                                               nib-name
+                                               dict
+                                               app-zone
+                                             )))
+

+ +

The trouble with this function is that it leaks a string + every time we call it. We need to release the + nib-name before returning. So how about this + version instead?

+ +

+(defun load-nibfile (nib-path)
+  (let* ((app-zone (#/zone *NSApp*))
+         (nib-name (%make-nsstring (namestring nib-path)))
+         (dict (#/dictionaryWithObject:forKey: 
+                ns-mutable-dictionary app #@"NSNibOwner"))
+         (result (#/loadNibFile:externalNameTable:withZone: ns:ns-bundle
+                                                            nib-name
+                                                            dict
+                                                            app-zone)))
+    (#/release nib-name)
+    result))
+

+ +

This version solves the leaking problem by binding the result + of the load call to result, then releasing the + nib-name before returning the result of the + load.

+ +

There's just one more problem: what if we want to use the + dictionary to collect the nibfile's toplevel objects, so that we + can get access to them from our code? We'll need another version + of our function.

+ +

In order to collect toplevel objects, we'll want to pass an + NSMutableArray object in the dictionary, stored under the key + NSNibTopLevelObjects. So we first need to create such an + array object in the let form:

+ +

+(let* (...
+       (objects-array (#/arrayWithCapacity: ns:ns-mutable-array 16))
+       ...)
+  ...)
+

+ +

Now that we have the array in which to store the nibfile's + toplevel objects, we need to change the code that creates the + dictionary, so that it contains not only the owner object, but + also the array we just created:

+ +

+  (let* (...
+         (dict (#/dictionaryWithObjectsAndKeys: ns:ns-mutable-dictionary
+                    app #@"NSNibOwner"
+                    objects-array #&NSNibTopLevelObjects
+                    +null-ptr+))
+         ...)
+    ...)
+  
+

+ +

We now want to collect the objects in it. We'll do that by + making a local variable to store them, then iterating over the + array object to get them all. (Normally, when we want to keep + an object from an array, we have to retain it. Top-level nib + objects are a special case: they are created by the nib loading + process with a retain count of 1, and we are responsible for releasing + them when we're through with them.)

+ +

+  (let* (...
+         (toplevel-objects (list))
+         ...)
+    (dotimes (i (#/count objects-array))
+      (setf toplevel-objects 
+            (cons (#/objectAtIndex: objects-array i)
+                  toplevel-objects)))
+    ...)
+

+ +

After collecting the objects, we can release the array, then + return the list of objects. It's still possible we might want + to know whether the load succeeded, so we + use values to return both the toplevel objects and + the success or failure of the load.

+ +

The final version of the nib-loading code looks like + this:

+ +

+(defun load-nibfile (nib-path)
+  (let* ((app-zone (#/zone *NSApp*))
+         (nib-name (%make-nsstring (namestring nib-path)))
+         (objects-array (#/arrayWithCapacity: ns:ns-mutable-array 16))
+         (dict (#/dictionaryWithObjectsAndKeys: ns:ns-mutable-dictionary
+                    *NSApp* #@"NSNibOwner"
+                    objects-array #&NSNibTopLevelObjects
+		    +null-ptr+))
+         (toplevel-objects (list))
+         (result (#/loadNibFile:externalNameTable:withZone: ns:ns-bundle
+                                                            nib-name
+                                                            dict
+                                                            app-zone)))
+    (dotimes (i (#/count objects-array))
+      (setf toplevel-objects 
+            (cons (#/objectAtIndex: objects-array i)
+                  toplevel-objects)))
+    (#/release nib-name)
+    (values toplevel-objects result)))
+

+ +

Now we can call this function with some suitable nibfile, + such as simple "hello.nib" that comes with this HOWTO:

+ +

+? (ccl::load-nibfile "hello.nib")
+(#<LISP-APPLICATION <LispApplication: 0x1b8da0> (#x1B8DA0)>
+ #<NS-WINDOW <NSWindow: 0x171344d0> (#x171344D0)>)
+T
+
+

+ +

The "Hello!" window appears on the screen, and two values are + returned. The first value is the list of toplevel objects that + were loaded. The second value, T indicates that the + nibfile was loaded successfully.

+ +

What About Unloading Nibfiles?

+ +

Cocoa provides no general nibfile-unloading API. Instead, if + you want to unload a nib, the accepted approach is to close all + the windows associated with a nibfile and release all the + toplevel objects. This is one reason that you might want to use + the "NSNibTopLevelObjects" key with the dictionary + object that you pass + to loadNibFile:externalNameTable:withZone:—to + obtain a collection of toplevel objects that you release when + the nibfile is no longer needed.

+ +

In document-based Cocoa applications, the main nibfile is + usually owned by the application object, and is never unloaded + while the application runs. Auxliliary nibfiles are normally + owned by controller objects, usually instances of + NSWindowController subclasses. When you + use NSWindowController objects to load nibfiles, + they take responsibility for loading and unloading nibfile + objects.

+ +

When you're experimenting interactively with nibfile loading, + you may not start out by + creating NSWindowController objects to load + nibfiles, and so you may need to do more of the object + management yourself. On the one hand, loading nibfiles by hand + is not likely to be the source of major application problems. On + the other hand, if you experiment with nib-loading for a long + time in an interactive session, it's possible that you'll end up + with numerous discarded objects cluttering memory, along with + various references to live and possibly released objects. Keep + this in mind when using the Listener to explore Cocoa. You can + always restore your Lisp system to a clean state by restarting + it, but of course you then lose whatever state you have built up + in your explorations. It's often a good idea to work from a text + file rather than directly in the Listener, so that you have a + record of the experimenting you've done. That way, if you need + to start fresh (or if you accidentally cause the application to + crash), you don't lose all the information you gained.

+ +

+ + + + Index: /branches/new-random/examples/cocoa/nib-loading/HOWTO_files/stylesheets/styles.css =================================================================== --- /branches/new-random/examples/cocoa/nib-loading/HOWTO_files/stylesheets/styles.css (revision 13309) +++ /branches/new-random/examples/cocoa/nib-loading/HOWTO_files/stylesheets/styles.css (revision 13309) @@ -0,0 +1,55 @@ +body { + background-color: white; + font-family: "Helvetica Neue", Arial, Helvetica, Geneva, sans-serif; +} + +.title { + text-align: center; + font-size: 16pt; +} + +.subtitle { + font-size: medium; + font-weight: bold; + text-align: center; +} + +.byline { + text-align: center; + font-weight: bold; + font-size: small; +} + +.section-head { + padding-top: 2em; + padding-left: 1em; +} + +.body-text { + font: 12pt Georgia, "Times New Roman", Times, serif; + margin-left: 4em; + margin-right: 4em; + text-indent: 3em; +} + +.note { + font: 12pt Georgia, "Times New Roman", Times, serif; + margin-left: 6em; + margin-right: 6em; + text-indent: 0em; +} + +.inline-image { + text-align: center; +} + +.nav { + text-align: center; + font-size: large; + font-weight: bold; + padding-top: 4em; +} + +li, pre { + text-indent: 0; +} Index: /branches/new-random/examples/cocoa/nib-loading/hello.nib/designable.nib =================================================================== --- /branches/new-random/examples/cocoa/nib-loading/hello.nib/designable.nib (revision 13309) +++ /branches/new-random/examples/cocoa/nib-loading/hello.nib/designable.nib (revision 13309) @@ -0,0 +1,269 @@ + + + + 1050 + 9B18 + 629 + 949 + 343.00 +

+ 0 + + 3 +

+ + Index: /branches/new-random/examples/cocoa/nib-loading/nib-loading.lisp =================================================================== --- /branches/new-random/examples/cocoa/nib-loading/nib-loading.lisp (revision 13309) +++ /branches/new-random/examples/cocoa/nib-loading/nib-loading.lisp (revision 13309) @@ -0,0 +1,37 @@ +;;;; -*- Mode: Lisp; Syntax: ANSI-Common-Lisp; Base: 10; Package: cl-user -*- +;;;; *********************************************************************** +;;;; FILE IDENTIFICATION +;;;; +;;;; Name: nib-loading.lisp +;;;; Version: 0.1 +;;;; Project: cocoa examples +;;;; Purpose: examples of loading nibs dynamically in the IDE +;;;; +;;;; *********************************************************************** + +(in-package :ccl) + +(defun load-nibfile (nib-path) + (let* ((app-zone (#/zone *NSApp*)) + (nib-name (%make-nsstring (namestring nib-path))) + (objects-array (#/arrayWithCapacity: ns:ns-mutable-array 16)) + (dict (#/dictionaryWithObjectsAndKeys: ns:ns-mutable-dictionary + *NSApp* #&NSNibOwner + objects-array #&NSNibTopLevelObjects + +null-ptr+)) + (toplevel-objects (list)) + (result (#/loadNibFile:externalNameTable:withZone: ns:ns-bundle + nib-name + dict + app-zone))) + (dotimes (i (#/count objects-array)) + (setf toplevel-objects + (cons (#/objectAtIndex: objects-array i) + toplevel-objects))) + (#/release nib-name) + (values toplevel-objects result))) + +#| +(ccl::load-nibfile "/usr/local/openmcl/trunk/source/examples/cocoa/nib-loading/hello.nib") +|# + Index: /branches/new-random/examples/cocoa/qtvidcapture/QTVidCapture.nib/classes.nib =================================================================== --- /branches/new-random/examples/cocoa/qtvidcapture/QTVidCapture.nib/classes.nib (revision 13309) +++ /branches/new-random/examples/cocoa/qtvidcapture/QTVidCapture.nib/classes.nib (revision 13309) @@ -0,0 +1,31 @@ + + + + + IBClasses + + + ACTIONS + + startRecording + id + stopRecording + id + + CLASS + MyRecorderController + LANGUAGE + ObjC + OUTLETS + + mCaptureView + QTCaptureView + + SUPERCLASS + NSObject + + + IBVersion + 1 + + Index: /branches/new-random/examples/cocoa/qtvidcapture/QTVidCapture.nib/info.nib =================================================================== --- /branches/new-random/examples/cocoa/qtvidcapture/QTVidCapture.nib/info.nib (revision 13309) +++ /branches/new-random/examples/cocoa/qtvidcapture/QTVidCapture.nib/info.nib (revision 13309) @@ -0,0 +1,18 @@ + + + + + IBFramework Version + 677 + IBOldestOS + 5 + IBOpenObjects + + 21 + + IBSystem Version + 10A354 + targetFramework + IBCocoaFramework + + Index: /branches/new-random/examples/cocoa/qtvidcapture/qtvidcapture.lisp =================================================================== --- /branches/new-random/examples/cocoa/qtvidcapture/qtvidcapture.lisp (revision 13309) +++ /branches/new-random/examples/cocoa/qtvidcapture/qtvidcapture.lisp (revision 13309) @@ -0,0 +1,285 @@ +(in-package "CL-USER") + + +;;; This is supposed to be a (close) translation of Apple's "MyRecorder" +;;; example, which shows a simple use of QTKit's QTCaptureView, which +;;; was introduced in Leopard. The example requires a companion nib +;;; file - "QTVidCapture.nib" - which is basically identical to the +;;; "MainMenu.nib" from Apple's example (with the "MainMenu" menu removed +;;; and the window's title and position changed.) There's a little +;;; utility function at the bottom of this file that runs an "Open" panel +;;; that lets you select this nib file and tries to open a video capture +;;; window. + +;;; Apple's MyRecorder example is at: +;;; +;;; +;;; Related guides/tutorials are available at: +;;; + + +;;; I tried to point out some issues of syntax and bridge arcana that +;;; people new to Cocoa programming in CCL might need help with (I'm +;;; sure that I missed some of that.) I know very little about QTKit +;;; and QT video capture; the hope is that people looking to do +;;; something more ambituous will find Apple's guides and tutorials +;;; easier to understand after reading this. + +(eval-when (:compile-toplevel :load-toplevel :execute) + (require "COCOA")) + +(eval-when (:compile-toplevel :load-toplevel :execute) + ;; Some of this requires OSX 10.5, which is software-version 9 + ;; as far as we're concerned. + (if (< (parse-integer (software-version) :junk-allowed t) 9) + (error "This code requires OSX 10.5 or later")) + ;; + ;; Many class names in QTKit are prefixed with "QT". Persuade the + ;; bridge that it should treat "QT" specially when mapping from + ;; ObjC class names to lisp. + (ccl::define-special-objc-word "QT") + (objc:load-framework "QTKit" :qtkit)) + + +;;; The .nib file refers to this class via the name +;;; "MyRecorderController"; in lisp, that's basically any symbol whose +;;; pname is "MY-RECORDER-CONTROLLER". Likewise, there are references +;;; to the slot "m-capture-view" - or "mCaptureView" in ObjC - in +;;; the nib file. +;;; +;;; If you open the "QTVidCapture.nib" file in IB 3.0, select the +;;; "My Recorder" object in the main view, then choose the "Connections +;;; Inspector" item (cmd-5) from the "Tools" menu, you'll see that +;;; there's an "outlet" from the mCaptureView slot to the window's +;;; Capture View. This basically means that this slot in the +;;; MY-WINDOW-CONTROLLER instance will be initialized to refer to +;;; the window's QTCaptureView when the .nib file is loaded (if and +;;; only if there's a slot with that name. Changing the name of the +;;; outlet in the nib file - or the name of the slot in the class +;;; definition below - could keep this initialization from working. + +(defclass my-recorder-controller (ns:ns-object) + ((m-capture-view :foreign-type :id) + (m-capture-session :foreign-type :id) + (m-capture-movie-file-output :foreign-type :id) + (m-capture-video-device-input :foreign-type :id) + (m-capture-audio-device-input :foreign-type :id)) + (:metaclass ns:+ns-object)) + + +;;; This method will be called (if it's defined) on all objects +;;; in the .nib file have been initialized in ways specified in +;;; the init file (i.e., "outlet" instance variables are set up, +;;; "action" messages are associated with the objects that implement +;;; them, etc.) The order in which #/awakeFromNib methods are +;;; called isn't specified, but we can count on the m-capture-view +;;; slot being initialized to the QTCaptureView in the window. +;;; For a better explanation of what this code does, see the +;;; Apple tutorial. +;;; The Apple sample code from which this was derived was pretty +;;; casual about reporting errors; this code is equally casual. +;;; Most of the things that can cause errors (missing devices +;;; or resources, etc.) will store an NSError object in the +;;; location that the "perror" pointer points to; this NSError +;;; object can be used to report error conditons and (in some +;;; cases) try to recover from them. Real code should certainly +;;; try to address those issues. + +(objc:defmethod (#/awakeFromNib :void) ((self my-recorder-controller)) + (rlet ((perror (:* :id) +null-ptr+)) + ;; In ObjC, it's generally possible to refer to a class's slots + ;; as if they were simple variables in a method specialized on + ;; that class. OBJC:DEFMETHOD doesn't do that for us, but if + ;; we want to do that we can use WITH-SLOTS to get a similar + ;; effect. (I tend to use SETQ whenever its legal to do so; + ;; other people use SETF.) + (with-slots (m-capture-view + m-capture-session + m-capture-movie-file-output + m-capture-video-device-input + m-capture-audio-device-input) self + ;; Using MAKE-INSTANCE (with no initargs) to create an instance + ;; of an ObjC class is entirely equivalent to calling #/init + ;; on the value returned by calling #/alloc on the class, + (setq m-capture-session (make-instance 'ns:qt-capture-session)) + + ;; Some of the values below are (non-constant) ObjC variables. + ;; The #& reader macro lets us access those ObjC variables + ;; more-or-less as if they were lisp global variables. + (let* ((video-device (#/defaultInputDeviceWithMediaType: + ns:qt-capture-device + #&QTMediaTypeVideo)) + (success (#/open: video-device perror))) + (unless success + (setq video-device (#/defaultInputDeviceWithMediaType: + ns:qt-capture-device + #&QTMediaTypeMuxed) + success (#/open: video-device perror))) + (when success + ;; (MAKE-INSTANCE objc-class-or-class-name :with-WHATEVER ...) + ;; is basically the same as using #/initWithWhatever: + ;; to initialize a newly-allocated instance of that class. + ;; MAKE-INSTANCE can also deal with the case where a class + ;; has a mixture of ObjC and Lisp slots.) + (setq m-capture-video-device-input + (make-instance 'ns:qt-capture-device-input + :with-device video-device)) + (setq success (#/addInput:error: m-capture-session m-capture-video-device-input + perror))) + (when success + (unless (or (#/hasMediaType: video-device #&QTMediaTypeSound) + (#/hasMediaType: video-device #&QTMediaTypeMuxed)) + (let* ((audio-device (#/defaultInputDeviceWithMediaType: + ns:qt-capture-device + #&QTMediaTypeSound))) + (setq success (#/open: audio-device perror)) + (when success + (setq m-capture-audio-device-input + (make-instance 'ns:qt-capture-device-input + :with-device audio-device) + success (#/addInput:error: m-capture-session + m-capture-audio-device-input + perror)))))) + (when success + (setq m-capture-movie-file-output + (make-instance 'ns:qt-capture-movie-file-output) + success (#/addOutput:error: m-capture-session m-capture-movie-file-output perror))) + (when success + (#/setDelegate: m-capture-movie-file-output self) + (let* ((connection-enumerator + (#/objectEnumerator (#/connections m-capture-movie-file-output)))) + (do* ((connection (#/nextObject connection-enumerator) + (#/nextObject connection-enumerator))) + ((%null-ptr-p connection)) + (let* ((media-type (#/mediaType connection)) + (compression-options + (cond ((#/isEqualToString: media-type #&QTMediaTypeVideo) + (#/compressionOptionsWithIdentifier: + ns:qt-compression-options + #@"QTCompressionOptions240SizeH264Video")) + ((#/isEqualToString: media-type #&QTMediaTypeSound) + (#/compressionOptionsWithIdentifier: + ns:qt-compression-options + #@"QTCompressionOptionsHighQualityAACAudio")) + (t +null-ptr+)))) + (#/setCompressionOptions:forConnection: m-capture-movie-file-output + compression-options + connection)))) + (#/setCaptureSession: m-capture-view m-capture-session) + (#/startRunning m-capture-session) + ))))) + +;;; Similarly, we use WITH-SLOTS here so that we can access slots +;;; as if they were simple variables. We're basically just trying +;;; to close/free resources that have been associated with this +;;; MY-WINDOW-CONTROLLER instance. +;;; This method is called because the MY-RECORDER-CONTROLLER was +;;; specified as the "delegate" of the window in the nib file. +(objc:defmethod (#/windowWillClose: :void) ((self my-recorder-controller) + notification) + (declare (ignorable notification)) + (with-slots (m-capture-session + m-capture-video-device-input + m-capture-audio-device-input) self + (unless (%null-ptr-p m-capture-session) + (#/stopRunning m-capture-session)) + (unless (%null-ptr-p m-capture-video-device-input) + (if (#/isOpen (#/device m-capture-video-device-input)) + (#/close (#/device m-capture-video-device-input)))) + (unless (%null-ptr-p m-capture-audio-device-input) + (if (#/isOpen (#/device m-capture-audio-device-input)) + (#/close (#/device m-capture-video-device-input)))))) + +;;; This method is called when the MY-RECORDER-INSTANCE has had +;;; its reference count go to 0 It basically decrements the +;;; reference counts of the things it has allocated (possibly +;;; causing #/dealloc to be invoked on them), then calls the +;;; superclass method to deallocate itself. +;;; A lisp pointer to the MY-WINDOW-CONTROLLER object might +;;; continue to believe that the object its pointing to is +;;; still a MY-WINDOW-CONTROLLER, even after the actual object +;;; has been deallocated (basically, "deallocated" means "turned +;;; into free memory.) There isn't currently a good solution +;;; to this problem (such a solution involves deeper integration +;;; between the Lisp and its GC and the ObjC memory-management +;;; system.) It's a little hard to do this and the issue doesn't +;;; come up that often, but it's worth remembering that there is +;;; an issue here. +(objc:defmethod (#/dealloc :void) ((self my-recorder-controller)) + (with-slots (m-capture-session + m-capture-video-device-input + m-capture-audio-device-input + m-capture-movie-file-output) self + (#/release m-capture-session) + (#/release m-capture-video-device-input) + (#/release m-capture-audio-device-input) + (#/release m-capture-movie-file-output) + (call-next-method))) + +;;; This is an "action" method (specified in the nib file) that's +;;; invoked whenever the "start" button is pressed. "action" methods +;;; recieve the object that invoked the method as a "sender" argument. +;;; (In this case, the "sender" is the "start" button.) We don't +;;; care who sent the message and might ordinarily declare "sender" +;;; to be ignored. It's hard to know when the bridge might cause +;;; objc:defmethod to expand into code that includes incidental +;;; references to an argument, so it's generally best to say that +;;; something that we don't use is "ignorable": we don't intend to +;;; reference the variable, but don't really care if there are +;;; incidental references to it in the macroexpansion of OBJC:DEFMETHOD. + +(objc:defmethod (#/startRecording: :void) ((self my-recorder-controller) sender) + (declare (ignorable sender)) + (#/recordToOutputFileURL: (slot-value self 'm-capture-movie-file-output) + (#/fileURLWithPath: ns:ns-url + #@"/Users/Shared/My Recorded Movie.mov"))) + +;;; Likewise, another action method here. +(objc:defmethod (#/stopRecording: :void) ((self my-recorder-controller) sender) + (declare (ignorable sender)) + (#/recordToOutputFileURL: (slot-value self 'm-capture-movie-file-output) + +null-ptr+)) + +;;; This message is sent to us because we're the delegate object of +;;; our output-capture object +(objc:defmethod + (#/captureOutput:didFinishRecordingToOutputFileAtURL:forConnections:dueToError: :void) + ((self my-recorder-controller) captureoutput output-file-url connections error) + (declare (ignorable captureoutput connections error)) + (#/openURL: (#/sharedWorkspace ns:ns-workspace) output-file-url)) + + +;;; That's the end of the transliterated code. Here's a little function +;;; that runs an "Open" panel to allow the selection of a nib file, then +;;; tries to use a standard NSWindowController object to create and +;;; show a window using that nib file. + + +(defun open-window-using-selected-nib (&optional (prompt "Pick a nib file. Any nib file")) + ;;; There are a bunch of issues that make it easier to do all of the + ;;; work on the main Cocoa event thread, which is the value of + ;;; GUI:::*COCOA-EVENT-PROCESS*. + (process-interrupt + gui::*cocoa-event-process* + (lambda () + (let* ((panel (#/openPanel ns:ns-open-panel))) + ;; CCL::%MAKE-NSSTRING should probably be moved to some + ;; other package and exported from there. + (#/setTitle: panel (ccl::%make-nsstring prompt)) + (#/setAllowsMultipleSelection: panel nil) + (let* ((types (#/arrayWithObject: ns:ns-array #@"nib")) + (button (#/runModalForTypes: panel types))) + (when (eql button #$NSOKButton) + (let* ((filenames (#/filenames panel))) + (when (eql 1 (#/count filenames)) + (let* ((wc (make-instance 'ns:ns-window-controller + :with-window-nib-path + (#/objectAtIndex: filenames 0) + :owner (#/sharedApplication ns:ns-application)))) + (unless (%null-ptr-p wc) + (#/showWindow: wc +null-ptr+))))))))))) + + + + + Index: /branches/new-random/examples/cocoa/tiny.lisp =================================================================== --- /branches/new-random/examples/cocoa/tiny.lisp (revision 13309) +++ /branches/new-random/examples/cocoa/tiny.lisp (revision 13309) @@ -0,0 +1,91 @@ +;;;; -*- Mode: Lisp; Package: CCL -*- +;;;; tiny.lisp +;;;; +;;;; A fairly direct translation into Lisp of the Tiny application (Chapter 4) +;;;; from "Building Cocoa Applications" by Garfinkel and Mahoney +;;;; +;;;; The original Tiny example was meant to illustrate the programmatic use of +;;;; Cocoa without Interface Builder. Its purpose here is to illustrate the +;;;; programmatic use of the Cocoa bridge. +;;;; +;;;; Copyright (c) 2003 Randall D. Beer +;;;; +;;;; This software is licensed under the terms of the Lisp Lesser GNU Public +;;;; License , known as the LLGPL. The LLGPL consists of a preamble and +;;;; the LGPL. Where these conflict, the preamble takes precedence. The +;;;; LLGPL is available online at http://opensource.franz.com/preamble.html. +;;;; +;;;; Please send comments and bug reports to + +;;; Temporary package and module stuff + +(in-package "CCL") + +(require "COCOA") + + +;;; Define the DemoView class + +(defclass demo-view (ns:ns-view) + () + (:metaclass ns:+ns-object)) + + +;;; Define the drawRect: method for DemoView +;;; NOTE: The (THE NS-COLOR ...) forms are currently necessary for full +;;; optimization because the SET message has a nonunique type signature +;;; NOTE: This will be replaced by a DEFMETHOD once ObjC objects have been +;;; integrated into CLOS +;;; NOTE: The (@class XXX) forms will probably be replaced by +;;; (find-class 'XXX) once ObjC objects have been integrated into CLOS + +(defconstant short-pi (coerce pi 'short-float)) +(defconstant numsides 12) + +(objc:defmethod (#/drawRect: :void) ((self demo-view) (rect :ect)) + (declare (ignorable rect)) + (let* ((bounds (#/bounds self)) + (width (ns:ns-rect-width bounds)) + (height (ns:ns-rect-height bounds))) + (macrolet ((X (tt) `(* (1+ (sin ,tt)) width 0.5)) + (Y (tt) `(* (1+ (cos ,tt)) height 0.5))) + ;; Fill the view with white + (#/set (#/whiteColor ns:ns-color)) + (#_NSRectFill bounds) + ;; Trace two polygons with N sides and connect all of the vertices + ;; with lines + (#/set (#/blackColor ns:ns-color)) + (loop + for f from 0.0 below (* 2 short-pi) by (* 2 (/ short-pi numsides)) + do + (loop + for g from 0.0 below (* 2 short-pi) by (* 2 (/ short-pi numsides)) + do + (#/strokeLineFromPoint:toPoint: ns:ns-bezier-path (ns:make-ns-point (X f) (Y f)) (ns:make-ns-point (X g) (Y g)))))))) + + +;;; This performs the actions that would normally be performed by loading +;;; a nib file. + +(defun tiny-setup () + (with-autorelease-pool + (let* ((r (ns:make-ns-rect 100 350 400 400)) + (w (make-instance + 'ns:ns-window + :with-content-rect r + :style-mask (logior #$NSTitledWindowMask + #$NSClosableWindowMask + #$NSMiniaturizableWindowMask) + :backing #$NSBackingStoreBuffered + :defer t))) + (#/setTitle: w #@"Tiny Window Application") + (let ((my-view (make-instance 'demo-view :with-frame r))) + (#/setContentView: w my-view) + (#/setDelegate: w my-view)) + (#/performSelectorOnMainThread:withObject:waitUntilDone: + w (objc:@selector "makeKeyAndOrderFront:") nil nil) + w))) + + +;;; Neither the windowWillClose method nor the main from the original Tiny +;;; application is necessary here Index: /branches/new-random/examples/cocoa/ui-elements/HOWTO.html =================================================================== --- /branches/new-random/examples/cocoa/ui-elements/HOWTO.html (revision 13309) +++ /branches/new-random/examples/cocoa/ui-elements/HOWTO.html (revision 13309) @@ -0,0 +1,366 @@ + + + + UI Elements HOWTO + + + + + +

UI Elements HOWTO

+ +

This HOWTO shows how you can create Cocoa user-interface + elements by making lisp calls to instantiate and initialize + Objective-C objects.

+ +

Cocoa programmers usually create UI elements using Apple's + InterfaceBuilder application, and then load those elements from + a nibfile, but Cocoa supports creating all the + same UI elements by making Objective-C method calls. In fact, + that's how it loads nibfiles: by making method calls to + instantiate the objects described in them.

+ +

For Lisp programmers, accustomed to working incrementally and + interactively, it may sometimes make more sense to create + user-interface elements by making method calls interactively, + rather than by constructing a complete user interface in + InterfaceBuilder. This HOWTO shows how you can use Objective-C + method calls to create and display windows and other UI + elements.

+ +

For more information about how to load nibfiles from Lisp, + see the "nib-loading" example. For a complete discussion of how + to construct a Cocoa application using nibfiles created with + InterfaceBuilder, see the "currency-converter" example.

+ +

Creating a Window

+ +

Every user-interface element under Mac OS X appears either in + a window or in a menu. We'll begin by exploring how to create and + display windows.

+ +

First, switch to the CCL package, for + convenience. Most of Clozure CL's Objective-C utilities are in + the CCL package:

+ +

+? (in-package :ccl)
+#<Package "CCL">
+

+ +

Creating a Cocoa window follows the common Objective-C pattern + of allocating an object and then initializing it with some + starting data. To allocate a window, just call + the alloc method of the NSWindow + class:

+ +

+? (setf my-window (#/alloc (@class ns-window)))
+#<NS-WINDOW <NSWindow: 0x13b68580> (#x13B68580)>
+

+ +

The above expression creates a new window, but doesn't display + it. Before it shows up on the screen we must initialize it with + some appropriate values. For that, we'll use the + method initWithContentRect:styleMask:backing:defer:.

+ +

As always in Objective-C, the name of the method reveals + something about the arguments it expects. The NSRect + that we pass for the initWithContentRect: segment of + the method name describes the shape of the window. The mask + for styleMask: is a sequence of bits that specify + which window features are turned on. The backing: + argument is a constant of type NSBackingStoreType + that specifies how Cocoa will draw the contents of the + window. Finally, the defer: argument is a Boolean + that determines whether to display the window as soon as it's + created.

+ +

Next, we'll create data values to pass in these parameters, so + that we can display our new window on the screen. We'll build the + proper initialization form up piece-by-piece.

+ +

The first argument, of course, is the window object to be + initialized. We pass the window that we created before:

+ +

+(#/initWithContentRect:styleMask:backing:defer: my-window ...)
+

+ +

The next argument, the NSRect, is a structure + that we need only temporarily. Because NSRect values + appear so often in Cocoa code, Clozure CL provides a handy way to + allocate them temporarily, disposing of them + automatically. The with-ns-rect macro (in + the NS package) creates an NSRect value, + and then disposes of it when control leaves the scope of the + macro; for example:

+ +

+(ns:with-ns-rect (r 100 100 400 300)
+   ...)
+

+ +

We can use this rectangle to initialize the shape of our new + window:

+ +

+(ns:with-ns-rect (r 100 100 400 300)
+   (#/initWithContentRect:styleMask:backing:defer: 
+    my-window 
+    r 
+    ...))
+

+ +

To specify the window features we want, we must combine + several flags to form the proper style mask. Cocoa provides named + constants for each of the various window features. To create the + syle mask that describes a new window, use inclusive-or to + combine the named flags into a style mask:

+ +

+(logior  #$NSTitledWindowMask 
+         #$NSClosableWindowMask  
+         #$NSMiniaturizableWindowMask 
+         #$NSResizableWindowMask)
+

+ +

You can find definitions for all the window masks in the Apple + Developer documentation + for NSWindow + Constants.

+ +

Passing the window mask as the next argument gives us this + expression:

+ +

+(ns:with-ns-rect (r 100 100 400 300)
+  (#/initWithContentRect:styleMask:backing:defer: 
+   my-window 
+   r 
+   (logior  #$NSTitledWindowMask 
+            #$NSClosableWindowMask  
+            #$NSMiniaturizableWindowMask 
+            #$NSResizableWindowMask)
+   ...))
+

+ +

Like the style masks, the NSBackingStoreType value + is a named constant that describes which drawing strategy Cocoa + should use for the contents of the window. The value can + be NSBackingStoreRetained, NSBackingStoreNonretained, + or NSBackingStoreBuffered. For this example, we'll + use NSBackingStoreBuffered:

+ +

+(ns:with-ns-rect (r 100 100 400 300)
+  (#/initWithContentRect:styleMask:backing:defer: 
+   my-window 
+   r 
+   (logior  #$NSTitledWindowMask 
+            #$NSClosableWindowMask  
+            #$NSMiniaturizableWindowMask 
+            #$NSResizableWindowMask)
+   #$NSBackingStoreBuffered
+   ...))
+

+ +

Finally, the defer argument is just a Boolean. If + we pass a true value, Cocoa will defer displaying the window until + we explicitly tell it to. If we pass a False value, it will + instead display the window right away. We can pass the Lisp + values T or NIL, and the Objective-C + bridge automatically converts them for us, but in the spirit of + using Objective-C values for Objective-C operations, let's use the + Objective-C constants #$YES + and #$NO:

+ +

+(ns:with-ns-rect (r 100 100 400 300)
+  (#/initWithContentRect:styleMask:backing:defer: 
+   my-window 
+   r 
+   (logior  #$NSTitledWindowMask 
+            #$NSClosableWindowMask  
+            #$NSMiniaturizableWindowMask 
+            #$NSResizableWindowMask)
+   #$NSBackingStoreBuffered
+   #$NO))
+

+ +

There; the expression to initialize our window object is + finally complete. We can evaluate it in the Listener to + initialize the window:

+ +

+(ns:with-ns-rect (r 100 100 400 300)
+  (#/initWithContentRect:styleMask:backing:defer: 
+   my-window 
+   r 
+   (logior  #$NSTitledWindowMask 
+            #$NSClosableWindowMask  
+            #$NSMiniaturizableWindowMask 
+            #$NSResizableWindowMask)
+   #$NSBackingStoreBuffered
+   #$NO))
+

+ +

Then we can call makeKeyAndOrderFront: to display the window:

+ +

+(#/makeKeyAndOrderFront: my-window nil)
+

+ +

The window, empty, but with the shape and features we + specified, appears on the left lower corner of the screen.

+ +

Adding a Button

+ +

Once we have a window on the screen, we might like to put + something in it. Let's start by adding a button.

+ +

Creating a button object is as simple as creating a window + object; we simply allocate one:

+ +

+(setf my-button (#/alloc ns:ns-button))
+#<NS-BUTTON <NSButton: 0x13b7bec0> (#x13B7BEC0)>
+

+ +

As with the window, most of the interesting work is in + configuring the allocated button after it's allocated.

+ +

Instances of NSButton include pushbuttons with either text or + image labels (or both), checkboxes, and radio buttons. In order to + make a text pushbutton, we need to tell our button to use a + button-type of NSMomentaryPushInButton, an image + position of NSNoImage, and a border style + of NSRoundedBezelStyle. These style options are + represented by Cocoa constants.

+ +

We also need to give the button a frame rectangle that defines + its size and position. We can once again + use ns:with-ns-rect to specify a temporary rectangle + for the purpose of initializing our button:

+ +

+(ns:with-ns-rect (frame 10 10 72 32)
+  (#/initWithFrame: my-button frame)
+  (#/setButtonType: my-button #$NSMomentaryPushInButton)
+  (#/setImagePosition: my-button #$NSNoImage)
+  (#/setBezelStyle: my-button #$NSRoundedBezelStyle))
+;Compiler warnings :
+;   Undeclared free variable MY-BUTTON (4 references), in an anonymous lambda form
+NIL
+

+ +

Now we just need to add the button to the window. This we do by + asking the window for its content view, and asking that view to + add the button as a subview:

+ +

+(#/addSubview: (#/contentView my-window) my-button)
+

+ +

The button appears in the window with the rather uninspired + title "Button". Clicking it highlights the button but, since we + didn't give it any action to perform, does nothing else.

+ +

We can give the button a more interesting title and, perhaps + more importantly, an action to perform, by passing a string and an + action to it. First, let's set the button title:

+ +

+(let ((label (%make-nsstring "Hello!")))
+  (#/setTitle: my-button label)
+  (#/release label))
+;Compiler warnings :
+;   Undeclared free variable MY-BUTTON, in an anonymous lambda form
+NIL
+

+ +

The button changes to display the text "Hello!". Notice that we + are careful to save a reference to the button text and release it + after changing the button title. The normal memory-management + policy in Cocoa is that if we allocate an object (like the + NSString "Hello!") we are responsible for releasing it. Unlike + Lisp, Cocoa does not automatically garbage-collect all allocated + objects by default.

+ +

Giving the button an action is slightly more + complicated. Clicking a button causes the button object to send a + message to a target object. We haven't given our button a message + to send, nor a target object to send it to, so it doesn't do + anything. In order to get it do perform some kind of action, we + need to give it a target object and a message to send. Then, when + we click the button, it will send the message we specify to the + target we provide. Naturally, the target object had better be able + to respond to the message, or else we'll just see a runtime + error.

+ +

Let's define a class that knows how to respond to a greeting + message, and then make an object of that class to serve as our + button's target.

+ +

We can define a subclass of NSObject to handle + our button's message:

+ +

+(defclass greeter (ns:ns-object)
+  ()
+  (:metaclass ns:+ns-object))
+#<OBJC:OBJC-CLASS GREETER (#x13BAF810)>
+

+ +

We'll need to define a method to execute in response to the + button's message. Action methods accept one argument (in addition + to the receiver): a sender. Normally Cocoa passes the button + object itself as the sender argument; the method can do anything + it likes (or nothing at all) with the sender.

+ +

Here's a method that displays an alert dialog:

+ +

+(objc:defmethod #/greet: ((self greeter) (sender :id))
+  (declare (ignore sender))
+  (let ((title (%make-nsstring "Hello!"))
+        (msg (%make-nsstring "Hello, World!"))
+        (default-button (%make-nsstring "Hi!"))
+        (alt-button (%make-nsstring "Hello!"))
+        (other-button (%make-nsstring "Go Away")))
+    (#_NSRunAlertPanel title msg default-button alt-button other-button)
+    (#/release title)
+    (#/release msg)
+    (#/release default-button)
+    (#/release other-button)))
+

+ +

Now we can create an instance of the Greeter class and use it + as the button's target:

+ +

+(setf my-greeter (#/init (#/alloc greeter)))
+#<GREETER <Greeter: 0x136c58e0> (#x136C58E0)>
+
+(#/setTarget: my-button my-greeter)
+NIL
+
+(#/setAction: my-button (@SELECTOR "greet:"))
+NIL
+

+ +

Now, if you click the button, an Alert panel appears.

+ +

+ + + + Index: /branches/new-random/examples/cocoa/ui-elements/HOWTO_files/stylesheets/styles.css =================================================================== --- /branches/new-random/examples/cocoa/ui-elements/HOWTO_files/stylesheets/styles.css (revision 13309) +++ /branches/new-random/examples/cocoa/ui-elements/HOWTO_files/stylesheets/styles.css (revision 13309) @@ -0,0 +1,55 @@ +body { + background-color: white; + font-family: "Helvetica Neue", Arial, Helvetica, Geneva, sans-serif; +} + +.title { + text-align: center; + font-size: 16pt; +} + +.subtitle { + font-size: medium; + font-weight: bold; + text-align: center; +} + +.byline { + text-align: center; + font-weight: bold; + font-size: small; +} + +.section-head { + padding-top: 2em; + padding-left: 1em; +} + +.body-text { + font: 12pt Georgia, "Times New Roman", Times, serif; + margin-left: 4em; + margin-right: 4em; + text-indent: 3em; +} + +.note { + font: 12pt Georgia, "Times New Roman", Times, serif; + margin-left: 6em; + margin-right: 6em; + text-indent: 0em; +} + +.inline-image { + text-align: center; +} + +.nav { + text-align: center; + font-size: large; + font-weight: bold; + padding-top: 4em; +} + +li, pre { + text-indent: 0; +} Index: /branches/new-random/examples/gtk-minesweeper.lisp =================================================================== --- /branches/new-random/examples/gtk-minesweeper.lisp (revision 13309) +++ /branches/new-random/examples/gtk-minesweeper.lisp (revision 13309) @@ -0,0 +1,991 @@ +;;;-*-Mode: LISP; Package: (MINESWEEPER :USE (CL CCL)) -*- +;;; +;;; Copyright (C) 2001 Clozure Associates +;;; +;;; This is a GTK+-based MineSweeper game, derived from a C program +;;; developed by Eric Harlow and published in "Developing Linux Programs +;;; with GTK+ and GDK", (c) 1999 New Riders Publishing. +;;; +;;; Anyone who wants to use this code for any purpose is free to do so. +;;; In doing so, the user acknowledges that this code is provided "as is", +;;; without warranty of any kind, and that no other party is legally or +;;; otherwise responsible for any consequences of its use. + +(defpackage "MINESWEEPER" + (:use "CL" "CCL") + (:export "MINESWEEPER")) + +(in-package "MINESWEEPER") + +;;; +;;; Make GTK+ interface info available. +(eval-when (:compile-toplevel :execute) + (use-interface-dir :GTK2)) + +(eval-when (:compile-toplevel :load-toplevel :execute) + (require "OPENMCL-GTK-SUPPORT")) + + +(defconstant max-rows 35) +(defconstant max-cols 35) + +(defconstant button-width 24) +(defconstant button-height 26) + + +(defvar *nrows* 10) +(defvar *ncols* 10) +(defvar *ntotalbombs* 0) + +(defvar *bgameover* nil) +(defvar *bresetgame* nil) +(defvar *nbombsleft* nil) + +(defvar *table* nil) +(defvar *start-button* nil) +(defvar *bombs-label* nil) +(defvar *time-label* nil) +(defvar *vbox* nil) + +(defstruct cell + (buttonstate :button-unknown + :type (member :button-down :button-unknown :button-flagged)) + button + (bombsnearby 0) + (has-bomb nil) + row + col) + +;;; The original C Minesweeper example uses GtkToggleButtons to +;;; represent the cells on the grid. They seem to work reasonably +;;; well except for one minor (but annoying) feature: "enter" and +;;; "leave" events cause the cells under the mouse to be highlighted, +;;; making it difficult to distinguish "unpressed buttons" from "the +;;; button under the mouse". +;;; +;;; This defines a GtkQuietToggleButton class that's exactly like +;;; GtkToggleButton except for the fact that it does nothing on +;;; "enter" and "leave" events. It's not necessarily the most +;;; interesting example of subclassing a Gtk widget, but it -is- an +;;; example of doing so. +;;; +;;; GtkQuietToggleButtons seem to be better, but there is still some +;;; room for improvement. + +(defcallback enter-or-leave-quietly (:address widget :void) + (let* ((id (with-cstrs ((cell-id "cell-id")) + (#_gtk_object_get_data widget cell-id))) + (cell (cell-id->cell id)) + (desired-state + (if (member (cell-buttonstate cell) + '(:button-unknown :button-flagged)) + #$GTK_STATE_NORMAL + #$GTK_STATE_ACTIVE)) + (current-state (pref widget :tkidget.state))) + (unless (eql current-state desired-state) + (#_gtk_widget_set_state widget desired-state)))) + +(defcallback gtk_quiet_toggle_button_class_init (:address classptr :void) + (setf (pref classptr :tkuttonlass.enter) enter-or-leave-quietly + (pref classptr :tkuttonlass.leave) enter-or-leave-quietly)) + + +(defcallback gtk_quiet_toggle_button_init (:address widget :void) + (declare (ignore widget))) + + +;;; CCL::DEFLOADVAR behaves like DEFPARAMETER, but arranges to +;;; initialize the variable whenever a saved image start up +;;; as well as when the DEFLOADVAR is executed. +(ccl::defloadvar *gtk-quiet-toggle-button-type-info* + (let* ((p (#_malloc (ccl::%foreign-type-or-record-size :tkypenfo :bytes)))) + (setf + (pref p :tkypenfo.type_name) + (with-cstrs ((name "GtkQuietToggleButton")) (#_g_strdup name)) + (pref p :tkypenfo.object_size) + (ccl::%foreign-type-or-record-size :tkoggleutton :bytes) + (pref p :tkypenfo.class_size) + (ccl::%foreign-type-or-record-size :tkoggleuttonlass :bytes) + (pref p :tkypenfo.class_init_func) gtk_quiet_toggle_button_class_init + (pref p :tkypenfo.object_init_func) gtk_quiet_toggle_button_init + (pref p :tkypenfo.reserved_1) (%null-ptr) + (pref p :tkypenfo.reserved_2) (%null-ptr) + (pref p :tkypenfo.base_class_init_func) (%null-ptr)) + p)) + +(ccl::defloadvar *gtk-quiet-toggle-button-type* nil) + +(defun gtk-quiet-toggle-button-get-type () + (or *gtk-quiet-toggle-button-type* + (setq *gtk-quiet-toggle-button-type* + (#_gtk_type_unique (#_gtk_toggle_button_get_type) + *gtk-quiet-toggle-button-type-info*)))) + +(defcallback gtk_quiet_toggle_button_get_type (:unsigned-fullword) + (gtk-quiet-toggle-button-get-type)) + +(defun gtk-quiet-toggle-button-new () + (#_gtk_type_new (gtk-quiet-toggle-button-get-type))) + +(defcallback gtk_quiet_toggle_button_new (:address) + (gtk-quiet-toggle-button-new)) + +(defparameter *minesweeper-use-quiet-toggle-buttons* t) + +;;; Display message dialogs (as for the About... box). + +;;; A dialog widget has "grabbed" the focus. Call back here when +;;; the dialog is to be closed; yield the focus. +(defcallback close-show-message + (:address container :address data :void) + (declare (ignore container)) + (let* ((dialog-widget data)) + (#_gtk_grab_remove dialog-widget) + (#_gtk_widget_destroy dialog-widget))) + +(defcallback clear-show-message + (:address widget :address data :void) + (declare (ignore data)) + (#_gtk_grab_remove widget)) + +(defun show-message (title message) + (let* ((dialog-window (#_gtk_dialog_new))) + (with-cstrs ((destroy-name "destroy")) + (#_gtk_signal_connect_full dialog-window destroy-name clear-show-message + (%null-ptr) (%null-ptr) (%null-ptr) 0 0)) + (with-cstrs ((title title)) + (#_gtk_window_set_title dialog-window title)) + (#_gtk_container_set_border_width dialog-window 0) + + (let* ((button (with-cstrs ((ok "OK")) + (#_gtk_button_new_with_label ok)))) + (with-cstrs ((clicked "clicked")) + (#_gtk_signal_connect_full button clicked close-show-message (%null-ptr) dialog-window (%null-ptr) 0 0)) + (setf (pref button :tkbject.flags) + (logior (pref button :tkbject.flags) #$GTK_CAN_DEFAULT)) + (#_gtk_box_pack_start (pref dialog-window :tkialog.action_area) + button #$TRUE #$TRUE 0) + (#_gtk_widget_grab_default button) + (#_gtk_widget_show button)) + + (let* ((label (with-cstrs ((message message)) + (#_gtk_label_new message)))) + (#_gtk_misc_set_padding label 10 10) + (#_gtk_box_pack_start (pref dialog-window :tkialog.vbox) + label #$TRUE #$TRUE 0) + (#_gtk_widget_show label)) + + (#_gtk_widget_show dialog-window) + (#_gtk_grab_add dialog-window))) + + +(defun show-about () + (show-message "About ..." + "Minesweeper OpenMCL GTK+ example +Copyright 2001 Clozure Associates +Derived from Minesweeper v0.6 by Eric Harlow")) + +(defvar *win-main* ()) +(defvar *accel-group* ()) +(defvar *tooltips* ()) + +(defun reset-minesweeper-globals () + (setq *win-main* nil + *accel-group* nil + *tooltips* nil + *vbox* nil + *time-label* nil + *bombs-label* nil + *start-button* nil + *table* nil + *bgameover* nil + *bresetgame* nil)) + +(defun create-widget-from-xpm (window xpm-string-list) + (rlet ((mask (* :dkitmap))) + (with-string-vector (xpm-data xpm-string-list) + (let* ((pixmap-data (#_gdk_pixmap_create_from_xpm_d + (pref window :tkidget.window) + mask + (%null-ptr) + xpm-data)) + (pixmap-widget (#_gtk_pixmap_new pixmap-data (%get-ptr mask)))) + (#_gtk_widget_show pixmap-widget) + pixmap-widget)))) + +(defun create-menu-item (menu item-name accel tip func data) + ;; A null or zero-length item-name indicates a separator. + (let* ((menuitem nil)) + (if (and item-name (length item-name)) + (with-cstrs ((item-name item-name) + (activate "activate")) + (setq menuitem (#_gtk_menu_item_new_with_label item-name)) + (#_gtk_signal_connect_full menuitem activate func (%null-ptr) (or data (%null-ptr)) (%null-ptr) 0 0)) + (setq menuitem (#_gtk_menu_item_new))) + (#_gtk_menu_shell_append menu menuitem) + (#_gtk_widget_show menuitem) + + (unless *accel-group* + (setq *accel-group* + (#_gtk_accel_group_new)) + (#_gtk_window_add_accel_group *win-main* *accel-group*)) + + (if (and accel (char= (schar accel 0) #\^)) + (with-cstrs ((activate "activate")) + (#_gtk_widget_add_accelerator + menuitem activate *accel-group* (char-code (schar accel 1)) + #$GDK_CONTROL_MASK #$GTK_ACCEL_VISIBLE))) + + (if (and tip (length tip)) + (with-cstrs ((tip tip)) + (#_gtk_tooltips_set_tip + (or *tooltips* + (setq *tooltips* (#_gtk_tooltips_new))) + menuitem + tip + (%null-ptr)))) + menuitem)) + +(defun create-radio-menu-item (menu item-name group-ptr func data) + (with-cstrs ((item-name item-name) + (toggled "toggled")) + (let* ((menuitem (#_gtk_radio_menu_item_new_with_label + (%get-ptr group-ptr) + item-name))) + (setf (%get-ptr group-ptr) + (#_gtk_radio_menu_item_get_group menuitem)) + (#_gtk_menu_shell_append menu menuitem) + (#_gtk_widget_show menuitem) + (#_gtk_signal_connect_full menuitem toggled func (%null-ptr) (or data (%null-ptr)) (%null-ptr) 0 0) + menuitem))) + +(defun create-bar-sub-menu (menu name) + (with-cstrs ((name name)) + (let* ((menuitem (#_gtk_menu_item_new_with_label name))) + (#_gtk_menu_shell_append menu menuitem) + (#_gtk_widget_show menuitem) + (let* ((submenu (#_gtk_menu_new))) + (#_gtk_menu_item_set_submenu menuitem submenu) + submenu)))) + +;;; Represent xpm string vectors as lists of strings. WITH-STRING-VECTOR +;;; will produce a foreign vector of C strings out of such a list. +(defvar *xpm-one* + '( + "12 12 2 1" + " c None" + "X c #3333CC" + " " + " XX " + " XXX " + " X XX " + " XX " + " XX " + " XX " + " XX " + " XX " + " XXXXXX " + " " + " " + )) + +(defvar *xpm-two* + '( + "12 12 2 1" + " c None" + "X c #009900" + " " + " XXXXXX " + " X X " + " XX " + " XX " + " XX " + " XX " + " XX " + " XX " + " XXXXXXXX " + " " + " " + )) + + +(defvar *xpm-three* + '( + "12 12 2 1" + " c None" + "X c #AA0000" + " " + " XXXXX " + " XX " + " XX " + " XXXXXX " + " XX " + " XX " + " XX " + " XX " + " XXXXXX " + " " + " " + )) + + +(defvar *xpm-four* + '( + "12 12 2 1" + " c None" + "X c #000066" + " " + " XX XX " + " XX XX " + " XX XX " + " XX XX " + " XXXXXXXX " + " XX " + " XX " + " XX " + " XX " + " " + " " + )) + + + +(defvar *xpm-five* + '( + "12 12 2 1" + " c None" + "X c #992299" + " " + " XXXXXXXX " + " XX " + " XX " + " XXXXXXX " + " XX " + " XX " + " XX " + " XX XX " + " XXXXXXX " + " " + " " + )) + + +(defvar *xpm-six* + '( + "12 12 2 1" + " c None" + "X c #550055" + " " + " XXXXXX " + " XX " + " XX " + " XXXXXXX " + " XX XX " + " XX XX " + " XX XX " + " XX XX " + " XXXXXX " + " " + " " + )) + + + +(defvar *xpm-seven* + '( + "12 12 2 1" + " c None" + "X c #550000" + " " + " XXXXXXXX " + " XX " + " XX " + " XX " + " XX " + " XX " + " WX " + " XX " + " XX " + " " + " " + )) + + + +(defvar *xpm-eight* + '( + "12 12 2 1" + " c None" + "X c #441144" + " " + " XXXXXX " + " XX XX " + " XX XX " + " XXXXXX " + " XX XX " + " XX XX " + " XX XX " + " XX XX " + " XXXXXX " + " " + " " + )) + +(defvar *xpm-flag* + '( + "12 12 4 1" + " c None" + "X c #000000" + "R c #FF0000" + "r c #AA0000" + " " + " RRRRRRR " + " RRRRRrr " + " RRRrrrr " + " Rrrrrrr " + " X " + " X " + " X " + " X " + " X " + " XXX " + " " + )) + + +;;; +;;; --- A bomb. Ooops, you're not as smart as you thought. +;;; +(defvar *xpm-bomb* + '( + "12 12 4 1" + " c None" + "X c #000000" + "R c #FF0000" + "r c #AA0000" + " " + " X " + " X X X " + " XXXXX " + " XXXXX " + " XXXXXXXXX " + " XXXXX " + " XXXXX " + " X X X " + " X " + " " + " " + )) + + +;;; +;;; --- Wrong move! +;;; +(defvar *xpm-bigx* + '( + "12 12 4 1" + " c None" + "X c #000000" + "R c #FF0000" + "r c #AA0000" + "RRR RRR" + " RRR RRR " + " RRR RRR " + " RRRRRR " + " RRRR " + " RRRR " + " RRRR " + " RRRRRR " + " RRR RRR " + " RRR RRR " + "RRR RRR" + " " + )) + + +;;; +;;; --- Bitmap of a smile +;;; +(defvar *xpm-smile* + '( + "16 16 4 1" + " c None" + ". c #000000" + "X c #FFFF00" + "r c #AA0000" + " ...... " + " ..XXXXXX.. " + " ..XXXXXXXXXX. " + " .XXXXXXXXXXXX. " + " .XX..XXXX..XX. " + ".XXX..XXXX..XXX." + ".XXXXXXXXXXXXXX." + ".XXXXXXXXXXXXXX." + ".XXXXXXXXXXXXXX." + ".XXXXXXXXXXXXXX." + " .XX.XXXXXX.XX. " + " .XXX......XXX. " + " .XXXXXXXXXX. " + " ..XXXXXX.. " + " ...... " + " " + )) + + +;;; +;;; --- frown. You lost. +;;; +(defvar *xpm-frown* + '( + "16 16 4 1" + " c None" + ". c #000000" + "X c #FFFF00" + "r c #AA0000" + " ...... " + " ..XXXXXX.. " + " ..XXXXXXXXXX. " + " .XXXXXXXXXXXX. " + " .XX.X.XX.X.XX. " + ".XXXX.XXXX.XXXX." + ".XXX.X.XX.X.XXX." + ".XXXXXXXXXXXXXX." + ".XXXXXXXXXXXXXX." + ".XXXXXXXXXXXXXX." + " .XXX......XXX. " + " .XX.XXXXXX.XX. " + " .XXXXXXXXXX. " + " ..XXXXXX.. " + " ...... " + " " + )) + + +;;; +;;; --- We have a winner +;;; +(defvar *xpm-winner* + '( + "16 16 4 1" + " c None" + ". c #000000" + "X c #FFFF00" + "r c #AA0000" + " ...... " + " ..XXXXXX.. " + " ..XXXXXXXXXX. " + " .XXXXXXXXXXXX. " + " .XX...XX...XX. " + ".XX..........XX." + ".X.X...XX...X.X." + "..XXXXXXXXXXXX.." + ".XXXXXXXXXXXXXX." + ".XXXXXXXXXXXXXX." + " .XX.XXXXXX.XX. " + " .XXX......XXX. " + " .XXXXXXXXXX. " + " ..XXXXXX.. " + " ...... " + " " + )) + +(defvar *digits* + (vector nil *xpm-one* *xpm-two* *xpm-three* *xpm-four* *xpm-five* + *xpm-six* *xpm-seven* *xpm-eight*)) + +(defun set-grid (ncols nrows nbombs) + (when *table* + (#_gtk_widget_destroy *table*)) + (setq *table* (#_gtk_table_new ncols nrows #$FALSE)) + (#_gtk_box_pack_start *vbox* *table* #$FALSE #$FALSE 0) + (#_gtk_widget_realize *table*) + (reset-game ncols nrows nbombs t) + (#_gtk_widget_show *table*)) + + +;;; Menu callbacks. + +;;; This is called both when the start button is pressed and when +;;; the "New" menu item is selected. +(defcallback start-button-clicked (:address widget :address data :void) + (declare (ignore widget data)) + (set-start-button-icon *xpm-smile*) + (reset-game *ncols* *nrows* *ntotalbombs* nil)) + +(defcallback action-beginner + (:address widget :address data :void) + (declare (ignore data)) + (unless (zerop (pref widget :tkheckenutem.active)) + (set-grid 10 10 10))) + +(defcallback action-intermediate + (:address widget :address data :void) + (declare (ignore data)) + (unless (zerop (pref widget :tkheckenutem.active)) + (set-grid 20 15 40))) + +(defcallback action-advanced + (:address widget :address data :void) + (declare (ignore data)) + (unless (zerop (pref widget :tkheckenutem.active)) + (set-grid 30 20 100))) + +(defcallback action-quit (:address widget :address data :void) + (declare (ignore widget)) + (stop-timer) + (#_gtk_widget_destroy data) + (reset-minesweeper-globals)) + +(defcallback action-about (:void) + (show-about)) + +(defun create-menu (window vbox-main) + (setq *win-main* window) + (setq *accel-group* (#_gtk_accel_group_new)) + (#_gtk_window_add_accel_group *win-main* *accel-group*) + (let* ((menubar (#_gtk_menu_bar_new))) + (#_gtk_box_pack_start vbox-main menubar #$FALSE #$TRUE 0) + (#_gtk_widget_show menubar) + (let* ((game-menu (create-bar-sub-menu menubar "Game"))) + (create-menu-item game-menu + "New" "^N" "New Game" start-button-clicked nil) + (create-menu-item game-menu nil nil nil nil nil) + (rlet ((group (* t))) + (setf (%get-ptr group) (%null-ptr)) + (with-macptrs ((group-ptr group)) + (create-radio-menu-item game-menu "Beginner" group-ptr + action-beginner nil) + (create-radio-menu-item game-menu "Intermediate" group-ptr + action-intermediate nil) + (create-radio-menu-item game-menu "Advanced" group-ptr + action-advanced nil))) + (create-menu-item game-menu nil nil nil nil nil) + (create-menu-item game-menu "Quit" nil "Quit game" + action-quit *win-main*)) + (let* ((help-menu (create-bar-sub-menu menubar "Help"))) + (create-menu-item help-menu "About Minesweeper" nil "Gory Details" + action-about nil)))) + + + + +(defparameter *cells* + (let* ((a (make-array (list max-cols max-rows)))) + (dotimes (row max-rows a) + (dotimes (col max-cols) + (setf (aref a col row) + (make-cell :row row :col col)))))) + +;;; Callbacks can receive (foreign) pointer arguments. Since we'd +;;; rather keep information in lisp structures/arrays, that's not +;;; directly helpful. + +;;; We can identify a cell by its row and column and +;;; can easily pack the row and column into a fixnum. This function's +;;; caller can coerce that fixnum into a pointer (via ccl::%int-to-ptr). + +(defun cell->cell-id (cell) + (dpb (cell-row cell) + (byte 8 8) + (cell-col cell))) + +;;; The inverse operation: the caller (a callback) will generally have +;;; a foreign pointer; it can coerce that to a fixnum and obtain the +;;; corresponding cell by unpacking its indices from that fixnum. + +(defun cell-id->cell (cell-id) + (let* ((id (if (typep cell-id 'macptr) + (%ptr-to-int cell-id) + cell-id)) + (row (ldb (byte 8 8) id)) + (col (ldb (byte 8 0) id))) + (declare (fixnum id row col)) + (aref *cells* col row))) + +;;; Free widget. +(defcallback FreeChildCallback (:address widget :void) + (#_gtk_widget_destroy widget)) + +;;; Free all of the widgets contained in this one. +(defun free-children (widget) + (#_gtk_container_foreach + (#_g_type_check_instance_cast widget (#_gtk_container_get_type)) + FreeChildCallback (%null-ptr))) + +(defun add-image-to-mine (cell xpm-data) + (let* ((widget (create-widget-from-xpm *table* xpm-data))) + (#_gtk_container_add (cell-button cell) widget) + (#_gdk_drawable_unref widget) + nil)) + +(defun open-nearby-squares (col row) + (declare (fixnum col row)) + (let* ((mincol (max (1- col) 0)) + (maxcol (min (1+ col) (1- *ncols*))) + (minrow (max (1- row) 0)) + (maxrow (min (1+ row) (1- *nrows*)))) + (declare (fixnum mincol maxcol minrow maxrow)) + (do* ((i mincol (1+ i))) + ((> i maxcol)) + (declare (fixnum i)) + (do* ((j minrow (1+ j))) + ((> j maxrow)) + (declare (fixnum j)) + (display-hidden-info (aref *cells* i j)))))) + +(defun display-hidden-info (cell) + (case (cell-buttonstate cell) + (:button-down + (#_gtk_toggle_button_set_active (cell-button cell) #$TRUE)) + (:button-flagged + (#_gtk_toggle_button_set_active (cell-button cell) #$FALSE)) + (t + (setf (cell-buttonstate cell) :button-down) + (#_gtk_toggle_button_set_active (cell-button cell) #$TRUE) + (setf (pref (cell-button cell) :tkutton.button_down) #$TRUE) + (if (cell-has-bomb cell) + (add-image-to-mine cell *xpm-bomb*) + (let* ((nearby-bombs (cell-bombsnearby cell))) + (declare (fixnum nearby-bombs)) + (if (> nearby-bombs 0) + (add-image-to-mine cell (svref *digits* nearby-bombs)) + (open-nearby-squares (cell-col cell) (cell-row cell)))))))) + +(defun show-bombs () + (dotimes (i *ncols*) + (dotimes (j *nrows*) + (let* ((cell (aref *cells* i j)) + (buttonstate (cell-buttonstate cell)) + (has-bomb (cell-has-bomb cell))) + (if (and (eq buttonstate :button-unknown) has-bomb) + (display-hidden-info cell) + (when (and (eq buttonstate :button-flagged) (not has-bomb)) + (free-children (cell-button cell)) + (add-image-to-mine cell *xpm-bigx*))))))) + + + +(defcallback cell-toggled (:address widget :address data :void) + (let* ((cell (cell-id->cell data)) + (state (cell-buttonstate cell))) + (unless (eq state :button-flagged) + (if *bgameover* + (#_gtk_toggle_button_set_active widget + (if (eq state + :button-down) + #$TRUE + #$FALSE)) + (unless *bresetgame* + (start-timer) + (cond ((cell-has-bomb cell) + (setq *bgameover* t) + (set-start-button-icon *xpm-frown*) + (stop-timer) + (show-bombs)) + (t + (display-hidden-info cell) + (check-for-win)))))))) + + + +(defcallback button-press (:address widget :address event :address data :void) + (unless *bgameover* + (when (and (eql (pref event :dkventutton.type) #$GDK_BUTTON_PRESS) + (eql (pref event :dkventutton.button) 3)) + (let* ((cell (cell-id->cell data))) + (case (cell-buttonstate cell) + (:button-unknown + (free-children widget) + (setf (cell-buttonstate cell) :button-flagged) + (add-image-to-mine cell *xpm-flag*) + (decf *nbombsleft*)) + (:button-flagged + (free-children widget) + (setf (cell-buttonstate cell) :button-unknown) + (incf *nbombsleft*))) + (display-bomb-count) + (check-for-win))))) + + + + +(defun set-start-button-icon (xpm-list) + (let* ((widget (create-widget-from-xpm *start-button* xpm-list))) + (free-children *start-button*) + (#_gtk_container_add *start-button* widget))) + +(defun check-for-win () + (let* ((nmines 0)) + (declare (fixnum nmines)) + (dotimes (col *ncols*) + (declare (fixnum col)) + (dotimes (row *nrows*) + (declare (fixnum row)) + (when (member (cell-buttonstate (aref *cells* col row)) + '(:button-unknown :button-flagged)) + (incf nmines)))) + (when (= nmines (the fixnum *ntotalbombs*)) + (stop-timer) + (set-start-button-icon *xpm-winner*) + (setq *bgameover* t)))) + + +(defun create-button (table cell row column) + (let* ((button + (if *minesweeper-use-quiet-toggle-buttons* + (let* ((b (gtk-quiet-toggle-button-new)) + (id (cell->cell-id (aref *cells* column row)))) + (with-cstrs ((cell-id "cell-id")) + (#_gtk_object_set_data b cell-id (%int-to-ptr id))) + b) + (#_gtk_toggle_button_new))) + (cell-id (cell->cell-id cell))) + (with-cstrs ((toggled "toggled") + (button-press-event "button_press_event")) + (#_gtk_signal_connect_full button toggled cell-toggled + (%null-ptr) (%int-to-ptr cell-id) (%null-ptr) 0 0) + (#_gtk_signal_connect_full button button-press-event + button-press (%null-ptr) (%int-to-ptr cell-id) (%null-ptr) 0 0)) + (#_gtk_table_attach table button + column (1+ column) + (1+ row) (+ row 2) + (logior #$GTK_FILL #$GTK_EXPAND) + (logior #$GTK_FILL #$GTK_EXPAND) + 0 0) + (#_gtk_widget_set_usize button button-width button-height) + (#_gtk_widget_show button) + button)) + + +(defun count-nearby-bombs (col row) + (declare (fixnum col row)) + (let* ((mincol (max (1- col) 0)) + (maxcol (min (1+ col) (1- *ncols*))) + (minrow (max (1- row) 0)) + (maxrow (min (1+ row) (1- *nrows*))) + (ncount 0)) + (declare (fixnum mincol maxcol minrow maxrow ncount)) + (do* ((i mincol (1+ i))) + ((> i maxcol) ncount) + (declare (fixnum i)) + (do* ((j minrow (1+ j))) + ((> j maxrow)) + (declare (fixnum j)) + (if (cell-has-bomb (aref *cells* i j)) + (incf ncount)))))) + +(defun display-bomb-count () + (with-cstrs ((buf (format nil "Bombs: ~d" *nbombsleft*))) + (#_gtk_label_set_text *bombs-label* buf))) + +(defun update-seconds (seconds) + (with-cstrs ((buf (format nil "Time: ~d" seconds))) + (#_gtk_label_set_text *time-label* buf))) + +(defun create-minesweeper-buttons (table ngridcols ngridrows bnewbuttons) + (setq *nrows* ngridrows + *ncols* ngridcols + *bgameover* nil + *bresetgame* t) + (display-bomb-count) + (dotimes (ci *ncols*) + (declare (fixnum ci)) + (dotimes (ri *nrows*) + (declare (fixnum ri)) + (let* ((cell (aref *cells* ci ri))) + (setf (cell-has-bomb cell) nil + (cell-buttonstate cell) :button-unknown) + (if bnewbuttons + (setf (cell-button cell) (create-button table cell ri ci)) + (progn + (free-children (cell-button cell)) + (#_gtk_toggle_button_set_active (cell-button cell) #$FALSE)))))) + (do* ((nbombs *ntotalbombs*) + (state (make-random-state t))) + ((zerop nbombs)) + (declare (fixnum nbombs)) + (let* ((cell (aref *cells* (random *ncols* state) (random *nrows* state)))) + (unless (cell-has-bomb cell) + (setf (cell-has-bomb cell) t) + (decf nbombs)))) + (dotimes (ci *ncols*) + (declare (fixnum ci)) + (dotimes (ri *nrows*) + (declare (fixnum ri)) + (setf (cell-bombsnearby (aref *cells* ci ri)) + (count-nearby-bombs ci ri)))) + (setq *bresetgame* nil)) + +(defun reset-game (ncols nrows nbombs bnewbuttons) + (setq *ntotalbombs* nbombs + *nbombsleft* nbombs) + (create-minesweeper-buttons *table* ncols nrows bnewbuttons) + (stop-timer) + (update-seconds 0) + (set-start-button-icon *xpm-smile*)) + + + +;;; Timer stuff. + +(defvar *timer* nil) +(defvar *nseconds* 0) + +(defcallback timer-callback (:address data :void) + (declare (ignore data)) + (incf *nseconds*) + (update-seconds *nseconds*)) + +(defun start-timer () + (unless *timer* + (setq *nseconds* 0 + *timer* (#_gtk_timeout_add 1000 timer-callback *win-main*)))) + +(defun stop-timer () + (when *timer* + (#_gtk_timeout_remove *timer*) + (setq *timer* nil))) + + +;;; Finally ... + +(defun minesweeper () + (when *win-main* + (cerror + "Close current minesweeper game and start a new one" + "It seems that a minesweeper game is already active.") + (do* () + ((null *win-main*)) + (#_gtk_widget_destroy *win-main*) + (sleep 1))) + (let* ((window (#_gtk_window_new #$GTK_WINDOW_TOPLEVEL))) + (#_gtk_window_set_policy window #$FALSE #$FALSE #$TRUE) + (with-cstrs ((window-title "Minesweeper")) + (#_gtk_window_set_title window window-title) + (setq *vbox* (#_gtk_vbox_new #$FALSE 1)) + (#_gtk_widget_show *vbox*) + (create-menu window *vbox*) + (let* ((hbox (#_gtk_hbox_new #$TRUE 1))) + (#_gtk_widget_show hbox) + (#_gtk_box_pack_start *vbox* hbox #$FALSE #$FALSE 0) + (with-cstrs ((len0-string "")) + (setq *bombs-label* (#_gtk_label_new len0-string) + *time-label* (#_gtk_label_new len0-string))) + (#_gtk_box_pack_start hbox *bombs-label* #$FALSE #$FALSE 0) + (#_gtk_widget_show *bombs-label*) + (setq *start-button* (#_gtk_button_new)) + (with-cstrs ((clicked "clicked")) + (#_gtk_signal_connect_full *start-button* clicked start-button-clicked + (%null-ptr) (%null-ptr) (%null-ptr) 0 0)) + (#_gtk_box_pack_start hbox *start-button* #$FALSE #$FALSE 0) + (#_gtk_widget_show *start-button*) + (#_gtk_box_pack_start hbox *time-label* #$FALSE #$FALSE 0) + (#_gtk_widget_show *time-label*) + (#_gtk_widget_show hbox) + (#_gtk_container_add window *vbox*) + (with-cstrs ((destroy "destroy")) + (#_gtk_signal_connect_full window destroy action-quit (%null-ptr) window (%null-ptr) 0 0)) + (#_gtk_widget_show window) + + (set-start-button-icon *xpm-smile*) + (set-grid 10 10 10))))) Index: /branches/new-random/examples/gtk2-clock.lisp =================================================================== --- /branches/new-random/examples/gtk2-clock.lisp (revision 13309) +++ /branches/new-random/examples/gtk2-clock.lisp (revision 13309) @@ -0,0 +1,274 @@ +;;-*-Mode: LISP; Package: CCL -*- +;;; +;;; Copyright (C) 2006 Clozure Associates +;;; This file is part of OpenMCL. +;;; +;;; OpenMCL is licensed under the terms of the Lisp Lesser GNU Public +;;; License , known as the LLGPL and distributed with OpenMCL as the +;;; file "LICENSE". The LLGPL consists of a preamble and the LGPL, +;;; which is distributed with OpenMCL as the file "LGPL". Where these +;;; conflict, the preamble takes precedence. +;;; +;;; OpenMCL is referenced in the preamble as the "LIBRARY." +;;; +;;; The LLGPL is also available online at +;;; http://opensource.franz.com/preamble.html + +(in-package "CL-USER") + +(eval-when (:compile-toplevel :load-toplevel :execute) + (use-interface-dir :gtk2)) + + +;;; Loading "libgnomeui-2.so" seems to be the easiest way to force all of +;;; its dependent libraries to be loaded +(open-shared-library "libgnomeui-2.so") + +(defloadvar *gdk-threads-inited* nil) +(defloadvar *gthread-inited* nil) + + +;;; Set things up so that GDK will use lisp locks internally. +;;; There are a few advantages to this, including the fact +;;; that lisp locks are that newfangled recursive kind (a thread +;;; that owns the lock can lock it agains, which is slightly +;;; better than waiting forever for it to be released.) +(defvar *gdk-lock* (make-lock)) + + +;;; Callbacks called by #_gdk_threads_enter and #_gdk_threads_leave. +(defcallback lock-gdk-lock (:void) + (grab-lock *gdk-lock*)) + +(defcallback unlock-gdk-lock (:void) + (release-lock *gdk-lock*)) + + +(defmacro with-gdk-lock-grabbed (&body body) + `(with-lock-grabbed (*gdk-lock*) + ,@body)) + +;;; gtk_signal_connect is a C macro. Emulate it. +(defmacro gtk-signal-connect (object name function user-data) + `(external-call "gtk_signal_connect_full" + :address ,object + :address ,name + :address ,function + :tkallbackarshal (%null-ptr) + :gpointer ,user-data + :tkestroyotify (%null-ptr) + :gint 0 + :gint 0 + :gulong)) + +(defcallback window-destroy-handler (:address window :void) + (declare (ignore window)) + (#_gtk_main_quit)) + + + +(defconstant single-float-pi (coerce pi 'single-float)) + +;;; A global alist mapping clock windows to their offscreen pixmaps. +(defvar *gtk-clock-window-pixmaps* ()) + + +(defun draw-tick-at (pixmap gc nhour cx cy radius) + (let* ((radians (/ (* single-float-pi nhour) 6.0)) + (sin-radians (sin radians)) + (cos-radians (cos radians)) + (95%radius (* radius .95))) + (#_gdk_draw_line pixmap gc + (+ cx (floor (* 95%radius sin-radians))) + (+ cy (floor (* 95%radius cos-radians))) + (+ cx (floor (* radius sin-radians))) + (+ cy (floor (* radius cos-radians)))))) + +;;; It seems like this can get called when the drawing area's in the +;;; process of being destroyed. Try not to segfault in that case. +(defcallback gtk-clock-repaint (:address data :signed-fullword) + (if (or (%null-ptr-p data) + (%null-ptr-p (pref data :tkidget.style))) + #$FALSE + (let* ((drawing-area data) + (radius 0) + (white-gc (pref drawing-area :tkidget.style.white_gc)) + (black-gc (pref drawing-area :tkidget.style.black_gc)) + (area-width (pref drawing-area :tkidget.allocation.width)) + (area-height (pref drawing-area :tkidget.allocation.height)) + (dradians) + (midx 0) + (midy 0) + (vbox (pref drawing-area :tkidget.parent)) + (window (pref vbox :tkidget.parent)) + (pixmap (cdr (assoc window *gtk-clock-window-pixmaps*)))) + (rlet ((update-rect :dkectangle)) + ;; Clear pixmap (background image) + (#_gdk_draw_rectangle + pixmap white-gc #$TRUE 0 0 area-width area-height) + + ;; Calculate midpoint of clock. + (setq midx (ash area-width -1) + midy (ash area-height -1)) + + ;; Calculate radius + (setq radius (min midx midy)) + + ;; Draw circle + (#_gdk_draw_arc pixmap black-gc 0 0 0 + (+ midx midx) (+ midy midy) 0 (* 360 64)) + + ;; Draw tickmarks on clock face. + (do* ((nhour 1 (1+ nhour))) + ((> nhour 12)) + (draw-tick-at pixmap black-gc nhour midx midy radius)) + (multiple-value-bind (seconds minutes hours) + (get-decoded-time) + + ;; Get radians from seconds + (setq dradians (/ (* seconds single-float-pi) 30.0)) + + ;; Draw second hand. + (#_gdk_draw_line + pixmap black-gc midx midy + (+ midx (floor (* 0.9 radius (sin dradians)))) + (- midy (floor (* 0.9 radius (cos dradians))))) + + ;; Get radians from minutes & seconds. + (setq dradians (+ (/ (* minutes single-float-pi) 30.0) + (/ (* seconds single-float-pi) 1800.0))) + + ;; Draw minute hand. + (#_gdk_draw_line + pixmap black-gc midx midy + (+ midx (floor (* 0.7 radius (sin dradians)))) + (- midy (floor (* 0.7 radius (cos dradians))))) + + ;; Get radians from hours & minutes. + (setq dradians (+ (/ (* (mod hours 12) pi) 6.0) + (/ (* minutes pi) 360.0))) + + ;; Draw hour hand. + (#_gdk_draw_line + pixmap black-gc midx midy + (+ midx (floor (* 0.5 radius (sin dradians)))) + (- midy (floor (* 0.5 radius (cos dradians))))) + + ;; Setup the update rectangle; this will force an expose event. + ;; The expose event handler will then copy the pixmap to the + ;; window. + + (setf (pref update-rect :dkectangle.x) 0 + (pref update-rect :dkectangle.y) 0 + (pref update-rect :dkectangle.width) area-width + (pref update-rect :dkectangle.height) area-height) + + ;; Draw the update rectangle. + (#_gtk_widget_draw drawing-area update-rect) + #$TRUE))))) + + +;;; This is called when the window's created and whenever it's +;;; resized. Create a new pixmap of appropriate +;;; size; free the old one (if it's non-null). +(defcallback gtk-clock-configure-event + (:address widget :address event :address window :signed-fullword) + (declare (ignore event)) + (let* ((pair (assoc window *gtk-clock-window-pixmaps*))) + (if (cdr pair) + (#_gdk_drawable_unref (cdr pair))) + (setf (cdr pair) + (#_gdk_pixmap_new (pref widget :tkidget.window) + (pref widget :tkidget.allocation.width) + (pref widget :tkidget.allocation.height) + -1))) + #$TRUE) + +;;; Copy the window's pixmap to the exposed region of the window. +(defcallback gtk-clock-expose-event + (:address widget :address event :address window :signed-fullword) + (let* ((state (pref widget :tkidget.state)) + (pixmap (cdr (assoc window *gtk-clock-window-pixmaps*))) + (fg-gc (pref widget :tkidget.style.fg_gc)) + (x (pref event :dkventxpose.area.x)) + (y (pref event :dkventxpose.area.y)) + (width (pref event :dkventxpose.area.width)) + (height (pref event :dkventxpose.area.height))) + (#_gdk_draw_drawable + (pref widget :tkidget.window) + (%get-ptr fg-gc (ash state target::word-shift)) + pixmap + x y + x y + width height) + #$FALSE)) + +;;; When the window's destroyed, delete its entry from the +;;; *gtk-clock-window-pixmaps* alist. + +(defcallback gtk-clock-close (:address window :void) + (let* ((pair (assoc window *gtk-clock-window-pixmaps*))) + (if pair + (if (null (setq *gtk-clock-window-pixmaps* + (delete pair *gtk-clock-window-pixmaps*))) + (#_gtk_main_quit)) + (break "No entry for window!")))) + +(defun gtk-clock () + (let* ((window (#_gtk_window_new #$GTK_WINDOW_TOPLEVEL)) + (vbox (#_gtk_vbox_new #$FALSE 0))) + (push (cons window nil) *gtk-clock-window-pixmaps*) + (#_gtk_container_add window vbox) + (#_gtk_widget_show vbox) + (let* ((drawing-area (#_gtk_drawing_area_new))) + (#_gtk_drawing_area_size drawing-area 200 200) + (#_gtk_box_pack_start vbox drawing-area #$TRUE #$TRUE 0) + (#_gtk_widget_show drawing-area) + (with-cstrs ((expose-name "expose_event") + (configure-name "configure_event") + (destroy-name "destroy") + (window-title + "Takes a licking. Keeps on ticking.")) + (#_gtk_window_set_title window window-title) + (gtk-signal-connect drawing-area + expose-name + gtk-clock-expose-event + window) + (gtk-signal-connect drawing-area + configure-name + gtk-clock-configure-event + window) + (gtk-signal-connect window + destroy-name + gtk-clock-close + (%null-ptr))) + (#_gtk_widget_show window) + (#_gtk_timeout_add 1000 gtk-clock-repaint drawing-area) + (values)))) + + +(defun main (&rest args) + (unless *gthread-inited* + (#_g_thread_init (%null-ptr)) + (setq *gthread-inited* t)) + (unless *gdk-threads-inited* + ;; Tell GDK to use our locks. + (#_gdk_threads_set_lock_functions lock-gdk-lock unlock-gdk-lock) + (#_gdk_threads_init) + (setq *gdk-threads-inited* t)) + (process-run-function "GTK Event thread" + #'(lambda () + (#_gdk_threads_enter) + (rlet ((argc :int) + (argvp (:* t))) + (with-string-vector (argv args) + (setf (pref argc :int) (length args) + (%get-ptr argvp ) argv) + (#_gtk_init argc argvp))) + (gtk-clock) + (#_gtk_main) + (#_gdk_threads_leave)))) + +;;; calling (MAIN) starts an event thread and displays a clock. +;;; subsequent calls to (GTK-CLOCK) display additional clocks, +;;; if/when they can get a word in edgewise ... Index: /branches/new-random/examples/jfli/CPL.TXT =================================================================== --- /branches/new-random/examples/jfli/CPL.TXT (revision 13309) +++ /branches/new-random/examples/jfli/CPL.TXT (revision 13309) @@ -0,0 +1,94 @@ +Common Public License Version 1.0 + +THE ACCOMPANYING PROGRAM IS PROVIDED UNDER THE TERMS OF THIS COMMON PUBLIC LICENSE ("AGREEMENT"). ANY USE, REPRODUCTION OR DISTRIBUTION OF THE PROGRAM CONSTITUTES RECIPIENT'S ACCEPTANCE OF THIS AGREEMENT. + + +1. DEFINITIONS + +"Contribution" means: + +a) in the case of the initial Contributor, the initial code and documentation distributed under this Agreement, and + +b) in the case of each subsequent Contributor: + +i) changes to the Program, and + +ii) additions to the Program; + +where such changes and/or additions to the Program originate from and are distributed by that particular Contributor. A Contribution 'originates' from a Contributor if it was added to the Program by such Contributor itself or anyone acting on such Contributor's behalf. Contributions do not include additions to the Program which: (i) are separate modules of software distributed in conjunction with the Program under their own license agreement, and (ii) are not derivative works of the Program. + +"Contributor" means any person or entity that distributes the Program. + +"Licensed Patents " mean patent claims licensable by a Contributor which are necessarily infringed by the use or sale of its Contribution alone or when combined with the Program. + +"Program" means the Contributions distributed in accordance with this Agreement. + +"Recipient" means anyone who receives the Program under this Agreement, including all Contributors. + + +2. GRANT OF RIGHTS + +a) Subject to the terms of this Agreement, each Contributor hereby grants Recipient a non-exclusive, worldwide, royalty-free copyright license to reproduce, prepare derivative works of, publicly display, publicly perform, distribute and sublicense the Contribution of such Contributor, if any, and such derivative works, in source code and object code form. + +b) Subject to the terms of this Agreement, each Contributor hereby grants Recipient a non-exclusive, worldwide, royalty-free patent license under Licensed Patents to make, use, sell, offer to sell, import and otherwise transfer the Contribution of such Contributor, if any, in source code and object code form. This patent license shall apply to the combination of the Contribution and the Program if, at the time the Contribution is added by the Contributor, such addition of the Contribution causes such combination to be covered by the Licensed Patents. The patent license shall not apply to any other combinations which include the Contribution. No hardware per se is licensed hereunder. + +c) Recipient understands that although each Contributor grants the licenses to its Contributions set forth herein, no assurances are provided by any Contributor that the Program does not infringe the patent or other intellectual property rights of any other entity. Each Contributor disclaims any liability to Recipient for claims brought by any other entity based on infringement of intellectual property rights or otherwise. As a condition to exercising the rights and licenses granted hereunder, each Recipient hereby assumes sole responsibility to secure any other intellectual property rights needed, if any. For example, if a third party patent license is required to allow Recipient to distribute the Program, it is Recipient's responsibility to acquire that license before distributing the Program. + +d) Each Contributor represents that to its knowledge it has sufficient copyright rights in its Contribution, if any, to grant the copyright license set forth in this Agreement. + + +3. REQUIREMENTS + +A Contributor may choose to distribute the Program in object code form under its own license agreement, provided that: + +a) it complies with the terms and conditions of this Agreement; and + +b) its license agreement: + +i) effectively disclaims on behalf of all Contributors all warranties and conditions, express and implied, including warranties or conditions of title and non-infringement, and implied warranties or conditions of merchantability and fitness for a particular purpose; + +ii) effectively excludes on behalf of all Contributors all liability for damages, including direct, indirect, special, incidental and consequential damages, such as lost profits; + +iii) states that any provisions which differ from this Agreement are offered by that Contributor alone and not by any other party; and + +iv) states that source code for the Program is available from such Contributor, and informs licensees how to obtain it in a reasonable manner on or through a medium customarily used for software exchange. + +When the Program is made available in source code form: + +a) it must be made available under this Agreement; and + +b) a copy of this Agreement must be included with each copy of the Program. + +Contributors may not remove or alter any copyright notices contained within the Program. + +Each Contributor must identify itself as the originator of its Contribution, if any, in a manner that reasonably allows subsequent Recipients to identify the originator of the Contribution. + + +4. COMMERCIAL DISTRIBUTION + +Commercial distributors of software may accept certain responsibilities with respect to end users, business partners and the like. While this license is intended to facilitate the commercial use of the Program, the Contributor who includes the Program in a commercial product offering should do so in a manner which does not create potential liability for other Contributors. Therefore, if a Contributor includes the Program in a commercial product offering, such Contributor ("Commercial Contributor") hereby agrees to defend and indemnify every other Contributor ("Indemnified Contributor") against any losses, damages and costs (collectively "Losses") arising from claims, lawsuits and other legal actions brought by a third party against the Indemnified Contributor to the extent caused by the acts or omissions of such Commercial Contributor in connection with its distribution of the Program in a commercial product offering. The obligations in this section do not apply to any claims or Losses relating to any actual or alleged intellectual property infringement. In order to qualify, an Indemnified Contributor must: a) promptly notify the Commercial Contributor in writing of such claim, and b) allow the Commercial Contributor to control, and cooperate with the Commercial Contributor in, the defense and any related settlement negotiations. The Indemnified Contributor may participate in any such claim at its own expense. + +For example, a Contributor might include the Program in a commercial product offering, Product X. That Contributor is then a Commercial Contributor. If that Commercial Contributor then makes performance claims, or offers warranties related to Product X, those performance claims and warranties are such Commercial Contributor's responsibility alone. Under this section, the Commercial Contributor would have to defend claims against the other Contributors related to those performance claims and warranties, and if a court requires any other Contributor to pay any damages as a result, the Commercial Contributor must pay those damages. + + +5. NO WARRANTY + +EXCEPT AS EXPRESSLY SET FORTH IN THIS AGREEMENT, THE PROGRAM IS PROVIDED ON AN "AS IS" BASIS, WITHOUT WARRANTIES OR CONDITIONS OF ANY KIND, EITHER EXPRESS OR IMPLIED INCLUDING, WITHOUT LIMITATION, ANY WARRANTIES OR CONDITIONS OF TITLE, NON-INFRINGEMENT, MERCHANTABILITY OR FITNESS FOR A PARTICULAR PURPOSE. Each Recipient is solely responsible for determining the appropriateness of using and distributing the Program and assumes all risks associated with its exercise of rights under this Agreement, including but not limited to the risks and costs of program errors, compliance with applicable laws, damage to or loss of data, programs or equipment, and unavailability or interruption of operations. + + +6. DISCLAIMER OF LIABILITY + +EXCEPT AS EXPRESSLY SET FORTH IN THIS AGREEMENT, NEITHER RECIPIENT NOR ANY CONTRIBUTORS SHALL HAVE ANY LIABILITY FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING WITHOUT LIMITATION LOST PROFITS), HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE OR DISTRIBUTION OF THE PROGRAM OR THE EXERCISE OF ANY RIGHTS GRANTED HEREUNDER, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGES. + + +7. GENERAL + +If any provision of this Agreement is invalid or unenforceable under applicable law, it shall not affect the validity or enforceability of the remainder of the terms of this Agreement, and without further action by the parties hereto, such provision shall be reformed to the minimum extent necessary to make such provision valid and enforceable. + +If Recipient institutes patent litigation against a Contributor with respect to a patent applicable to software (including a cross-claim or counterclaim in a lawsuit), then any patent licenses granted by that Contributor to such Recipient under this Agreement shall terminate as of the date such litigation is filed. In addition, if Recipient institutes patent litigation against any entity (including a cross-claim or counterclaim in a lawsuit) alleging that the Program itself (excluding combinations of the Program with other software or hardware) infringes such Recipient's patent(s), then such Recipient's rights granted under Section 2(b) shall terminate as of the date such litigation is filed. + +All Recipient's rights under this Agreement shall terminate if it fails to comply with any of the material terms or conditions of this Agreement and does not cure such failure in a reasonable period of time after becoming aware of such noncompliance. If all Recipient's rights under this Agreement terminate, Recipient agrees to cease use and distribution of the Program as soon as reasonably practicable. However, Recipient's obligations under this Agreement and any licenses granted by Recipient relating to the Program shall continue and survive. + +Everyone is permitted to copy and distribute copies of this Agreement, but in order to avoid inconsistency the Agreement is copyrighted and may only be modified in the following manner. The Agreement Steward reserves the right to publish new versions (including revisions) of this Agreement from time to time. No one other than the Agreement Steward has the right to modify this Agreement. IBM is the initial Agreement Steward. IBM may assign the responsibility to serve as the Agreement Steward to a suitable separate entity. Each new version of the Agreement will be given a distinguishing version number. The Program (including Contributions) may always be distributed subject to the version of the Agreement under which it was received. In addition, after a new version of the Agreement is published, Contributor may elect to distribute the Program (including its Contributions) under the new version. Except as expressly stated in Sections 2(a) and 2(b) above, Recipient receives no rights or licenses to the intellectual property of any Contributor under this Agreement, whether expressly, by implication, estoppel or otherwise. All rights in the Program not expressly granted under this Agreement are reserved. + +This Agreement is governed by the laws of the State of New York and the intellectual property laws of the United States of America. No party to this Agreement will bring a legal action under this Agreement more than one year after the cause of action arose. Each party waives its rights to a jury trial in any resulting litigation. Index: /branches/new-random/examples/jfli/com/richhickey/jfli/LispInvocationHandler.java =================================================================== --- /branches/new-random/examples/jfli/com/richhickey/jfli/LispInvocationHandler.java (revision 13309) +++ /branches/new-random/examples/jfli/com/richhickey/jfli/LispInvocationHandler.java (revision 13309) @@ -0,0 +1,17 @@ +package com.richhickey.jfli; + +// Copyright (c) Rich Hickey. All rights reserved. +// The use and distribution terms for this software are covered by the +// Common Public License 1.0 (http://opensource.org/licenses/cpl.php) +// which can be found in the file CPL.TXT at the root of this distribution. +// By using this software in any fashion, you are agreeing to be bound by +// the terms of this license. +// You must not remove this notice, or any other, from this software. + +import java.lang.*; +import java.lang.reflect.*; + +public class LispInvocationHandler implements InvocationHandler +{ +public native Object invoke(Object proxy,Method method, Object[] args) throws Throwable; +} Index: /branches/new-random/examples/jfli/docs/jfli.css =================================================================== --- /branches/new-random/examples/jfli/docs/jfli.css (revision 13309) +++ /branches/new-random/examples/jfli/docs/jfli.css (revision 13309) @@ -0,0 +1,126 @@ +img { + border: 0; +} +body { + margin: 5px 10% 5px 55px; + padding: 5px; + border: 0; + background: #fff url(jfli_bkgrnd.gif) top left repeat-y; + color: #222; + font: small/1.6em "Lucida Grande", "Trebuchet MS", "Bitstream Vera Sans", Verdana, Helvetica, sans-serif; +} + + +a:link { + color: #339; + text-decoration: none; + border-bottom: 2px solid #ccf; +} +a:visited { + color: #339; + text-decoration: none; + border-bottom: 2px solid #ddd; +} +a:hover { + color: #66c; + text-decoration: none; + border-bottom: 2px solid #ccf; +} +a:active { + color: #339; + text-decoration: none; + border-bottom: 2px solid #ccf; +} + +p { + margin: 0 0 1em 0; + line-height: 140%; +} + + +h1 { + text-indent: -9999px; + margin: 0; + padding: 0; + border: 0; +} + +h1 a:link, h1 a:visited { + display: block; + width: 539px; + height: 86px; + background: #fff url(jfli_new.gif) top left no-repeat; + margin: 0; + padding: 0; + border: 0; + text-decoration: none; +} + +h1 a:hover { + background: #fff url(jfli_new.gif) top left no-repeat; + border: 0; +} + +h2 { + margin: .75em 0 .25em; + font: 170%/1.7em Georgia, serif; + color: #66c; +} +h3 { + margin: 1em 0 .25em; + font: 130%/1.4em Georgia, serif; + color: #339; +} +h4 { + margin: 1em 0 .25em; + font: 120%/1.3em Georgia, serif; + color: #888; +} + +pre, code { + color: #404; + /* + font-family: monaco, "Bitstream Vera Sans Mono", "Courier New", courier, monospace; + font-weight: normal; + font-size: small; + */ + font: small/1.6em monaco, "Bitstream Vera Sans Mono", "Courier New", courier, monospace; + line-height: 1.4em; +} +pre { + margin: 1em 0 1.4em; + margin-left: 3%; + width: 77%; + border-left: 4px solid #eee; + padding: 2px; + padding-left: 10px; +} + +ol li { + list-style: decimal outside; + line-height: 150%; + margin: 0 5px 5px 0; + padding: 0 0 0 5px; +} + +ul { + margin: 3px 0; + padding: 0 0 5px 0; +} + +ul li { + line-height: 150%; + margin-bottom: 5px; + padding-bottom: 0; + padding-left: 18px; + padding-top: 2px; + margin-left: 5px; + list-style: none; + background:url("bullet.gif") no-repeat 0px .5em; +} + +ul ul li { + margin-top: 4px; + list-style: none; + background:url("bullet2.gif") no-repeat 0px .5em; +} Index: /branches/new-random/examples/jfli/docs/jfli.html =================================================================== --- /branches/new-random/examples/jfli/docs/jfli.html (revision 13309) +++ /branches/new-random/examples/jfli/docs/jfli.html (revision 13309) @@ -0,0 +1,620 @@ + + + + + +
jfli + - a Java Foreign Language Interface for Common Lisp
+ +
Copyright (c) Rich Hickey. All rights reserved.
+ +
+ The use and distribution terms for this software are covered by the Common + Public License 1.0, which can be found in the file CPL.TXT at the root of + this distribution. By using this software in any fashion, you are agreeing to be + bound by the terms of this license. You must not remove this notice, or any + other, from this software. +
+ +
Contents
+ +
+
+ Introduction +
+
+ Download +
+
+ Setup and Configuration +
+
+ Quick Start +
+
+ API Reference +
+
+ JVM Creation and Initialization +
+
+ Wrapper Generation +
+
+ Object Creation +
+
+ Arrays +
+
+ Proxies - Java calling back to Lisp +
+
+ Utilities +
+
+
+
+ Summary +
+
+ + +
Introduction
+ +
+ My objective was to provide comprehensive, safe, dynamic and Lisp-y access to + Java and Java libraries as if they were Lisp libraries, for use in Lisp programs, + i.e. with an emphasis on working in Lisp rather than in Java. +
+ +
+ The approach I took was to embed a JVM instance in the Lisp process using JNI. I + was able to do this using LispWorks' own FLI and no C (or Java! *) code, which + is a tribute to the LW FLI. On top of the JNI layer (essentially a wrapper + around the entire JNI API), I built this user-level API using Java Reflection. + This first version was built with, and contains code specific to, Xanalys LispWorks. +
+ + +
+ jfli ("jay fly") provides: +
+ +
+ +
+ Automatic function generation for constructors, fields and methods, either by + named class, or entire package (sub)trees given a jar file. +
+ +
+ Java -> Lisp package and name mapping with an eye towards lack of surprise, lack + of conflict, and useful editor completion. +
+ +
+ setf-able setter generation for fields as well as for methods that follow the + JavaBeans property protocol. +
+ +
+ Java array creation and aref-like access to Java arrays. +
+ +
+ A 'new' macro that allows for keyword-style field and property initialization. +
+ +
+ Typed references to Java objects with an inheritance hierarchy on the Lisp side + mirroring that on the Java side - allowing for Lisp methods specialized on Java + class and interface types. +
+ +
+ Implementation of arbitrary Java interfaces in Lisp, and callbacks from Java to + Lisp via those interfaces. (* this required a single 5-line dummy Java proxy + stub, provided with jfli) +
+ +
+ Automatic lifetime maintenance of Lisp-referenced Java objects, boxing/unboxing + of primitive args/returns, string conversions, Java exception handling, overload + resolution etc. +
+
+ +
+ I built jfli using LWM and LWW (using Apple's and Sun's JVMs respectively), and + it works fine on both. Should be a trivial port to other LispWorks, and a + possible port to any Common Lisp with a robust FLI. Should also work with any + JVM with a conformant JNI implementation. +
+ +
Download
+ +
+ jfli is hosted on SourceForge +
+ +
Setup and Configuration
+ +
+ jfli is supplied in 2 Lisp files and an optional Java .jar file. The first Lisp + file, jni.lisp, defines a low-level API to the Java Native Interface, and is not + documented here. The second, jfli.lisp, depends upon jni.lisp, and provides the + user API documented here. Simply compile and load jni.lisp, then compile and + load jfli.lisp. (use-package :jfli) and you are ready to use the + API. Note that prior to creating the JVM you must tell the library how to find + the Java JNI library by setting *jni-lib-path*. +
+
+ If you wish to allow for callbacks from Java to Lisp, you must place jfli.jar in + your classpath when creating the JVM. +
+ + +
Quick Start
+
+ This sample session presumes you have already compiled jni.lisp and jfli.lisp into fasl files. +
+
+CL-USER 4 > (load "/lisp/jni") +; Loading fasl file C:\lisp\jni.fsl +#P"C:/lisp/jni.fsl" + +CL-USER 5 > (load "/lisp/jfli") +; Loading fasl file C:\lisp\jfli.fsl +#P"C:/lisp/jfli.fsl" + +;The user API is entirely in the jfli package +CL-USER 6 > (use-package :jfli) +T + +;tell the library where Java is located +CL-USER 7 > (setf *jni-lib-path* "/j2sdk1.4.2_01/jre/bin/client/jvm.dll") +"/j2sdk1.4.2_01/jre/bin/client/jvm.dll" + +;this starts the VM - note how you can set the classpath +CL-USER 8 > (create-jvm "-Djava.class.path=/lisp/jfli.jar") +0 +#<Pointer: JNI:PVM = #x081022A0> +#<Pointer: JNI:PENV = #x0086A858> + +;define wrappers for the members of Object +CL-USER 9 > (def-java-class "java.lang.Object") +NIL + +;and of Properties, a Hashtable-like class +CL-USER 10 > (def-java-class "java.util.Properties") +#<STANDARD-CLASS |java.util|:PROPERTIES. 2066B964> + +;the above will create these packages if they do not already exist +;use the packages for easy name access + +CL-USER 11 > (use-package "java.lang") +T + +CL-USER 12 > (use-package "java.util") +T + +;create a Properties instance, note keyword-style member inits, string conversion etc +;also note typed return value +CL-USER 13 > (setf p (new properties. :getproperty "fred" "ethel")) +#<PROPERTIES. 20664A94> + +;virtual functions work as normal +CL-USER 14 > (object.tostring p) +"{fred=ethel}" + +;setter was generated for member function because it follows the JavaBeans property protocol +CL-USER 15 > (setf (properties.getproperty p "ricky") "lucy") +"lucy" + +CL-USER 16 > (object.tostring p) +"{ricky=lucy, fred=ethel}" + +CL-USER 17 > (properties.size p) +2 + +;totally dynamic access, create wrappers as you need +CL-USER 18 > (def-java-class "java.lang.Class") +#<STANDARD-CLASS CLASS. 20680EC4> + +CL-USER 19 > (class.getname (object.getclass p)) +"java.util.Properties" + +CL-USER 20 > (def-java-class "java.util.Enumeration") +#<STANDARD-CLASS ENUMERATION. 20669274> + +;no need to wait for the vendor to enhance the language - you use Lisp! +CL-USER 21 > (defmacro doenum ((e enum) &body body) + (let ((genum (gensym))) + `(let ((,genum ,enum)) + (do () + ((not (enumeration.hasmoreelements ,genum))) + (let ((,e (enumeration.nextelement ,genum))) + ,@body))))) +DOENUM + +;can't do this in Java yet +CL-USER 22 > (doenum (prop (properties.elements p)) (print (object.tostring prop))) + +"lucy" +"ethel" +NIL + +;doc strings are created giving original Java signatures and indicating +overloads +CL-USER 23 > (documentation 'properties.getproperty 'function) +"java.lang.String getProperty(java.lang.String,java.lang.String) +java.lang.String getProperty(java.lang.String) +" + +CL-USER 24 > (documentation 'properties.new 'function) +"java.util.Properties() +java.util.Properties(java.util.Properties) +" +
+ +
API Reference
+ +
JVM Creation and Initialization
+
+ +
+ *jni-lib-path* +
+ Set this to point to your jvm dll prior to calling create-jvm. +
+
+ +
+ Function (create-jvm &rest option-strings) -> unspecified +
+ Creates/starts the JVM. This can only be done once (a Java limitation). You + must call this prior to calling any other jfli function. The option strings + can be used to control the JVM, esp. the classpath: +
+
+
(create-jvm "-Djava.class.path=/Lisp/jfli.jar")
+
+
+ See the JNI documentation for other initialization options. +
+
+ +
+ Function (enable-java-proxies) + -> unspecified +
+ Sets up the Java->Lisp callback support. Must be called (once) before any calls + to new-proxy, and requires jfli.jar be in the classpath. +
+
+
+ +
Wrapper Generation
+ +
+
+ Macro (def-java-class full-class-name) -> unspecified +
+ Given the package-qualified, case-correct name of a Java class as a string, will + generate wrapper functions for its public constructors, fields and methods. +
+
+ The core API for generation interfaces to Java is the def-java-class macro. This + macro will, at expansion time, use Java reflection to find all of the public + constructors, fields and methods of the given class and generate functions to + access them. +
+
The Generated API
When you e.g. (def-java-class "java.lang.ClassName + ") you get several symbols/functions: +
+
+ A package named |java.lang| (note case)
+ from which the following are exported: +
+
+ A class-symbol: classname. (note the dot is part of the name)
+ which can usually be used where a typename is required. It also serves as the + name of the Lisp typed reference class. +
+
+ Every non-interface class with a public constructor will get; +
+
+ A constructor, (classname.new &rest args) -> typed-reference, which + returns a typed reference to the newly created object +
+
+ A method defined on make-new, ultimately + calling classname.new, specialized on (the value of) the class-symbol +
+
+ Note that if the constructor is overloaded, there is just one function generated, + which handles overload resolution. The function documentation string describes + the constructor signature(s) from the Java perspective. The same argument + conversions are performed as are for fields (see below). +
+
+ All public fields will get a getter function:
+ (classname.fieldname [instance]) -> field value
+ and a setter:
+ (setf classname.fieldname [instance])
+ Instance field wrappers take a first arg which is the instance. Static fields + get a symbol-macro *classname.fieldname* +
+ If the type of the field is primitive, the field value will be converted to a + native Lisp value. If it is a Java String, it will be converted to a Lisp string. + Otherwise, a generic reference to the Java object is returned. Similarly, when + setting, Lisp values will be accepted for primitives, Lisp strings for Strings, + or (generic or typed) references for reference types. +
+
+
+ Every public method will get a wrapper function:
+ (classname.methodname &rest args) -> return-value
+ As with constructors, if a method is overloaded a single wrapper is created that + handles overload resolution. If a method follows the JavaBeans property protocol + (i.e. it is called getSomething or isSomething and + there is a corresponding setSomething), then a (setf + classname.methodname) will be defined that calls the latter. +
+ The same argument and return value conversions are performed as are for fields. + The function documentation string describes the method signature(s) from the + Java perspective. +
+ +
+
+ A Lisp class with the class-symbol as its name. It will have as its superclasses + other Lisp classes corresponding to the Java superclass/superinterfaces, some of + which may be forward-referenced-classes. An instance of this class will be + returned by classname.new/make-new/new, at which point the entire hierarchy will + consist of finalized standard-classes. +
+
+ Note that, due to the need to reference other Java types during the definition + of a class wrapper, symbols, classes, and packages relating to those other types + may also be created. In all cases they will be created with names and + packages as described above. +
+
+
+ +
+ Function (get-jar-classnames jar-file-name &rest packages) + -> list-of-strings +
+ Returns a list of class name strings. Packages should be strings of the form "java/lang + " for recursive lookup and "java/util/" (note trailing slash) for non-recursive. +
+
+
+ Function (dump-wrapper-defs-to-file filename classnames) -> + unspecified +
+ Given a list of classnames (say from get-jar-classnames), writes + calls to def-java-class to a file: +
+
+(dump-wrapper-defs-to-file "/lisp/java-lang.lisp" + (get-jar-classnames "/j2sdk1.4.2_01/jre/lib/rt.jar " "java/lang/")) +(compile-file "/lisp/java-lang") +(load "/lisp/java-lang") +(use-package "java.lang") +;Wrappers for all of java.lang are now available +
+
+
+ +
Object Creation
+
+
+ Generic Function (make-new class-symbol + &rest args) -> typed-reference +
+ Allows for definition of before/after methods on constructors. Calls classname.new. + The new macro expands into a call to this. +
+
+
+ Macro (new class-spec &rest args) -> typed-reference +
+
+ class-spec -> class-name | (class-name this-name)
+ class-name -> "package.qualified.ClassName" | classname.
+ args -> [actual-arg]* [init-arg-spec]*
+ init-arg-spec -> init-arg | (init-arg)
+ init-arg -> :settable-field-or-method [params]* value (note keyword)
+ | .method-name [args]* (note leading dot)
+
+ +
+ Creates a new instance of class-name, by expanding into a call to the make-new + generic function, then initializes it by setting fields or accessors and/or + calling member functions. If this-name is supplied, it will be bound to the + newly-allocated object and available to the init-args: +
+
+(new (button. this) shell *SWT.CENTER* ;the actual args + :gettext "Call Lisp" ;a javabean property + (.addlistener *swt.selection* ;a method call + (new-proxy (listener. + (handleevent (event) + (declare (ignore event)) + (setf (button.gettext this) ;this is bound to new instance + (format nil "~A ~A" + (lisp-implementation-type) + (lisp-implementation-version))) + nil)))) + .setsize 200 100 ;can omit parens + (.setlocation 40 40)) +
+ Expands into: +
+(LET* ((#:G598 (MAKE-NEW BUTTON. SHELL *SWT.CENTER*)) (THIS #:G598)) + (SETF (BUTTON.GETTEXT #:G598) "Call Lisp") + (BUTTON.ADDLISTENER #:G598 + *SWT.SELECTION* + (NEW-PROXY (LISTENER. + (HANDLEEVENT + (EVENT) + (DECLARE (IGNORE EVENT)) + (SETF (BUTTON.GETTEXT THIS) + (FORMAT NIL + "~A ~A" + (LISP-IMPLEMENTATION-TYPE) + (LISP-IMPLEMENTATION-VERSION))) + NIL)))) + (BUTTON.SETSIZE #:G598 200 100) + (BUTTON.SETLOCATION #:G598 40 40) + #:G598) +
+ +
+
+
Array Support
+
+
+ Generic Function (make-new-array type &rest dimensions) -> + reference to new array +
+ Generic function with methods defined for all Java class designators: +
+
+ A "package.qualified.ClassName" string +
+
+ (the value of) A class-symbol - classname. +
+
+ A primitive designator keyword - :boolean|:byte|:char|:double|:float|:int|:long|:short +
+
+
+
+ Creates a Java array of the requested type with the requested dimensions. +
+
+
+ Function (jlength array) -> integer +
+ Like length, for Java arrays +
+
+ +
+ Function (jref array &rest subscripts) -> reference +
+ Like aref, for Java arrays of non-primitive (reference) types, settable. +
+
+
+ Function (jref-xxx array &rest subscripts) -> value +
+ Where xxx = boolean|byte|char|double|float|int|long|short. Like jref, for Java + arrays of primitive types, settable. +
+
+ +
+ +
Proxies - Java calling back to Lisp
+
+
+ Proxies allow the creation of Java objects that implement one or more interfaces + in Lisp, and thus callbacks from Java to Lisp. You must call + enable-java-proxies before using this proxy API. A significant + limitation is that LispWorks appears to not support calls back into Lisp other + than from threads initiated by Lisp, so you must ensure that the proxy will not + be called from an arbitrary Java thread! +
+
+ Macro (new-proxy &rest interface-defs) -> reference +
+ interface-def -> (interface-name method-defs+)
+ interface-name -> "package.qualified.ClassName" | classname. (must name a Java + interface type)
+ method-def -> (method-name arg-defs* body)
+ arg-def -> arg-name | (arg-name arg-type) arg-type -> "package.qualified.ClassName + " | classname. | :primitive
+ method-name -> symbol | string (matched case-insensitively) +
+ +
+ Creates, registers and returns a Java object that implements the supplied + interfaces +
+
+
+ Function (unregister-proxy proxy) -> unspecified +
+ Stops handling for the proxy (which must have been created by new-proxy) + and removes references from the Lisp side. Make sure it is no longer referenced + from Java first! +
+
+
+ +
Utilities
+
+ +
+ Function (jeq obj1 obj2) -> boolean +
+ Are the 2 java objects the same object? Note that this is not the same as Object.equals() +
+
+
+ Function (find-java-class class-sym-or-string) -> + reference to Java Class object +
+ Given a Java class designator, returns the Java Class object. Use this in + preference to Class.forName() when using jfli. +
+
+ +
+ Function (make-typed-ref java-ref) -> typed-reference +
+ Given a generic Java reference, determines the full type of the object and + returns an instance of a typed reference wrapper. classname.new/make-new/new always return typed + references, but since Java methods might return Object or some interface type, + and we don't want to always incur the cost of type determination, field and + method wrapper functions return generic references. Use this function to create + a typed reference corresponding to the full actual type of the object when + desired. +
+
+
+ Function (box-xxx value) -> reference to Java primitive wrapper class +
Where xxx = boolean|byte|char|double|float|int|long|short|string. + Given a compatible Lisp value, creates an instance of the corresponding Java primitive wrapper class, + e.g. Integer. This should rarely be needed, but can be used to force overloading resolution
+
+
+ Function (unbox-xxx ref) -> Lisp value +
Where xxx = boolean|byte|char|double|float|int|long|short|string. + Given an instance of a Java primitive wrapper class, creates an instance of the corresponding + compatible Lisp value. This should rarely be needed, but can be used to unbox values returned by Java + Object-based APIs.
+
+
+ +
Summary
+
+I hope you find jfli useful. It is my sincere intent that it enhance the utility and interoperability of Common Lisp, +a language with which I am still becoming familiar, and grow to appreciate more every day. I welcome comments +and code contributions. +
+
+Rich Hickey, July 2004 +
+ + Index: /branches/new-random/examples/jfli/examples/session.lisp =================================================================== --- /branches/new-random/examples/jfli/examples/session.lisp (revision 13309) +++ /branches/new-random/examples/jfli/examples/session.lisp (revision 13309) @@ -0,0 +1,104 @@ +;this presumes you have already compiled jni.lisp and jfli.lisp into fasl files + +CL-USER 4 > (load "/lisp/jni") +; Loading fasl file C:\lisp\jni.fsl +#P"C:/lisp/jni.fsl" + +CL-USER 5 > (load "/lisp/jfli") +; Loading fasl file C:\lisp\jfli.fsl +#P"C:/lisp/jfli.fsl" + +;The user API is entirely in the jfli package +CL-USER 6 > (use-package :jfli) +T + +;tell the library where Java is located +CL-USER 7 > (setf *jni-lib-path* "/j2sdk1.4.2_01/jre/bin/client/jvm.dll") +"/j2sdk1.4.2_01/jre/bin/client/jvm.dll" + +;this starts the VM - note how you can set the classpath +CL-USER 8 > (create-jvm "-Djava.class.path=/lisp/jfli.jar") +0 +# +# + +;define wrappers for the members of Object +CL-USER 9 > (def-java-class "java.lang.Object") +NIL + +;and of Properties, a Hashtable-like class +CL-USER 10 > (def-java-class "java.util.Properties") +# + +;the above will create these packages if they do not already exist +;use the packages for easy name access + +CL-USER 11 > (use-package "java.lang") +T + +CL-USER 12 > (use-package "java.util") +T + +;create a Properties instance, note keyword-style member inits, string conversion etc +;also note typed return value +CL-USER 13 > (setf p (new properties. :getproperty "fred" "ethel")) +# + +;virtual functions work as normal +CL-USER 14 > (object.tostring p) +"{fred=ethel}" + +;setter was generated for member function because it follows the JavaBeans property protocol +CL-USER 15 > (setf (properties.getproperty p "ricky") "lucy") +"lucy" + +CL-USER 16 > (object.tostring p) +"{ricky=lucy, fred=ethel}" + +CL-USER 17 > (properties.size p) +2 + +;totally dynamic access, create wrappers as you need +CL-USER 18 > (def-java-class "java.lang.Class") +# + +CL-USER 19 > (class.getname (object.getclass p)) +"java.util.Properties" + +CL-USER 20 > (def-java-class "java.util.Enumeration") +# + +;no need to wait for the vendor to enhance the language - you use Lisp! +CL-USER 21 > (defmacro doenum ((e enum) &body body) + (let ((genum (gensym))) + `(let ((,genum ,enum)) + (do () + ((not (enumeration.hasmoreelements ,genum))) + (let ((,e (enumeration.nextelement ,genum))) + ,@body)))))(defmacro doenum ((e enum) &body body) + (let ((genum (gensym))) + `(let ((,genum ,enum)) + (do () + ((not (enumeration.hasmoreelements ,genum))) + (let ((,e (enumeration.nextelement ,genum))) + ,@body))))) +DOENUM + +;can't do this in Java yet can in Lisp +CL-USER 22 > (doenum (prop (properties.elements p)) (print (object.tostring prop))) + +"lucy" +"ethel" +NIL + +;doc strings are created giving original Java signatures and indicating overloads +CL-USER 23 > (documentation 'properties.getproperty 'function) +"java.lang.String getProperty(java.lang.String,java.lang.String) +java.lang.String getProperty(java.lang.String) +" + +CL-USER 24 > (documentation 'properties.new 'function) +"java.util.Properties() +java.util.Properties(java.util.Properties) +" + Index: /branches/new-random/examples/jfli/examples/swtdemo.lisp =================================================================== --- /branches/new-random/examples/jfli/examples/swtdemo.lisp (revision 13309) +++ /branches/new-random/examples/jfli/examples/swtdemo.lisp (revision 13309) @@ -0,0 +1,51 @@ +;Just load this from LispWorks menu +;note works on Windows, some issues on OS X due to windowing conflict w/IDE +(load "ccl:examples;jfli;jni") +(load "ccl:examples;jfli;jfli") +(use-package :jfli) +(create-jvm + "-Djava.class.path=/cygwin/home/gb/swt/swt.jar;/;/cygwin/usr/local/src/ccl-dev/examples/jfli/jfli.jar" + ) +(enable-java-proxies) + + + +(def-java-class "org.eclipse.swt.widgets.Display") +(def-java-class "org.eclipse.swt.widgets.Button") +(def-java-class "org.eclipse.swt.widgets.Shell") +(def-java-class "org.eclipse.swt.widgets.Listener") +(def-java-class "org.eclipse.swt.SWT") + +(use-package "org.eclipse.swt") +(use-package "org.eclipse.swt.widgets") + + +(defun swt-demo () + (let* ((display (new display.)) + (shell (new shell. display + :gettext "Using SWT from Lisp" + (.setsize 300 200) + (.setlocation 100 100))) + (button (new (button. this) shell *SWT.CENTER* + :gettext "Call Lisp" + (.addlistener *swt.selection* + (new-proxy (listener. + (handleevent (event) + (declare (ignore event)) + (setf (button.gettext this) + (format nil "~A ~A" + (lisp-implementation-type) + (lisp-implementation-version))) + nil)))) + (.setsize 200 100) + (.setlocation 40 40)))) + (declare (ignore button)) + (shell.open shell) + (do () + ((shell.isdisposed shell)) + (unless (display.readanddispatch display) + (display.sleep display))) + (display.dispose display))) + +(mp:process-run-function "swt-proc" '() #'swt-demo) + Index: /branches/new-random/examples/jfli/jfli-lw.lisp =================================================================== --- /branches/new-random/examples/jfli/jfli-lw.lisp (revision 13309) +++ /branches/new-random/examples/jfli/jfli-lw.lisp (revision 13309) @@ -0,0 +1,1390 @@ +; Copyright (c) Rich Hickey. All rights reserved. +; The use and distribution terms for this software are covered by the +; Common Public License 1.0 (http://opensource.org/licenses/cpl.php) +; which can be found in the file CPL.TXT at the root of this distribution. +; By using this software in any fashion, you are agreeing to be bound by +; the terms of this license. +; You must not remove this notice, or any other, from this software. + +#| + +jfli is a library that provides access to Java from Lisp +It depends on the jni package (included) +Callbacks from Java to Lisp also require jfli.jar (included) + +|# + +(defpackage :jfli + (:use :common-lisp :lispworks :jni) + (:export + + ;jvm creation + :*jni-lib-path* ;exposed from jni + :create-jvm ;exposed from jni, you must call this prior to calling any other jfli function + :enable-java-proxies + + ;wrapper generation + :def-java-class + :get-jar-classnames + :dump-wrapper-defs-to-file + + ;object creation etc + :find-java-class + :new + :make-new + :make-typed-ref + :jeq + + ;array support + :make-new-array + :jlength + :jref + :jref-boolean + :jref-byte + :jref-char + :jref-double + :jref-float + :jref-int + :jref-short + :jref-long + + ;proxy support + :new-proxy + :unregister-proxy + + ;conversions + :box-boolean + :box-byte + :box-char + :box-double + :box-float + :box-integer + :box-long + :box-short + :box-string + :unbox-boolean + :unbox-byte + :unbox-char + :unbox-double + :unbox-float + :unbox-integer + :unbox-long + :unbox-short + :unbox-string + +; :ensure-package +; :member-symbol +; :class-symbol +; :constructor-symbol + )) + +(in-package :jfli) + +#| +bootstrap the implementation of reflection wrappers with +a few (primitive, less safe and maybe faster) jni wrappers +|# + +(eval-when (:compile-toplevel :load-toplevel :execute) + (def-jni-functions "java.lang.Object" + ("getClass" () "Class") + ("hashCode" () "int") + ("toString" () "String") + ("equals" ((obj "Object")) "boolean")) + + (def-jni-functions "java.lang.Class" + ;should be :overloaded t, but we only use this version + ("forName" ((className "String")) "Class" :static t) + ("getConstructors" () "java.lang.reflect.Constructor<>") + ("getFields" () "java.lang.reflect.Field<>") + ("getMethods" () "java.lang.reflect.Method<>") + + ("getConstructor" ((parameter-types "Class<>")) "java.lang.reflect.Constructor") + ("getField" ((name "String")) + "java.lang.reflect.Field") + ("getMethod" ((name "String") (parameter-types "Class<>")) + "java.lang.reflect.Method") + + ("getSuperclass" () "Class") + ("getInterfaces" () "Class<>") + + ("getName" () "String") + ("isArray" () "boolean") + ("isPrimitive" () "boolean")) + + (def-jni-functions "java.lang.reflect.Field" + ("getName" () "java.lang.String") + ("getType" () "java.lang.Class") + ("getModifiers" () "int") + + ("get" ((obj "java.lang.Object")) "java.lang.Object" :raw-return t) + ("getBoolean" ((obj "java.lang.Object")) "boolean") + ("getByte" ((obj "java.lang.Object")) "byte") + ("getChar" ((obj "java.lang.Object")) "char") + ("getDouble" ((obj "java.lang.Object")) "double") + ("getFloat" ((obj "java.lang.Object")) "float") + ("getInt" ((obj "java.lang.Object")) "int") + ("getLong" ((obj "java.lang.Object")) "long") + ("getShort" ((obj "java.lang.Object")) "short") + + ("set" ((obj "java.lang.Object") (value "java.lang.Object")) "void") + ("setBoolean" ((obj "java.lang.Object") (b "boolean")) "void") + ("setByte" ((obj "java.lang.Object") (b "byte")) "void") + ("setChar" ((obj "java.lang.Object") (c "char")) "void") + ("setDouble" ((obj "java.lang.Object") (d "double")) "void") + ("setFloat" ((obj "java.lang.Object") (f "float")) "void") + ("setInt" ((obj "java.lang.Object") ( i "int")) "void") + ("setLong" ((obj "java.lang.Object") (l "long")) "void") + ("setShort" ((obj "java.lang.Object") (s "short")) "void")) + + (def-jni-functions "java.lang.reflect.Constructor" + ("getParameterTypes" () "java.lang.Class<>") + ("newInstance" ((initargs "java.lang.Object<>")) "java.lang.Object")) + + (def-jni-functions "java.lang.reflect.Method" + ("getName" () "java.lang.String") + ("getParameterTypes" () "java.lang.Class<>") + ("getReturnType" () "java.lang.Class") + ("getModifiers" () "int") + ("invoke" ((object "java.lang.Object") + (args "java.lang.Object<>")) "java.lang.Object" + :raw-return t)) + + (def-jni-functions "java.lang.reflect.Array" + ("get" ((array "java.lang.Object") (index "int")) "java.lang.Object" :static t) + ("getBoolean" + ((array "java.lang.Object") (index "int")) "boolean" :static t) + ("getByte" + ((array "java.lang.Object") (index "int")) "byte" :static t) + ("getChar" + ((array "java.lang.Object") (index "int")) "char" :static t) + ("getDouble" + ((array "java.lang.Object") (index "int")) "double" :static t) + ("getFloat" + ((array "java.lang.Object") (index "int")) "float" :static t) + ("getInt" + ((array "java.lang.Object") (index "int")) "int" :static t) + ("getShort" + ((array "java.lang.Object") (index "int")) "short" :static t) + ("getLong" + ((array "java.lang.Object") (index "int")) "long" :static t) + ("getLength" ((array "java.lang.Object")) "int" :static t) + ("newInstance" ((componentType "java.lang.Class") + (length "int")) "java.lang.Object" :static t :overloaded t) + ("newInstance" ((componentType "java.lang.Class") + (dimensions "int<>")) "java.lang.Object" :static t :overloaded t) + ("set" ((array "java.lang.Object") (index "int") (value "java.lang.Object")) + "void" :static t)) + + + (def-jni-function "java.lang.reflect.Modifier" + "isStatic" ((mod "int")) "boolean" :static t) + + (def-jni-constructor "java.lang.Boolean" ((value "boolean"))) + (def-jni-constructor "java.lang.Byte" ((value "byte"))) + (def-jni-constructor "java.lang.Character" ((value "char"))) + (def-jni-constructor "java.lang.Double" ((value "double"))) + (def-jni-constructor "java.lang.Float" ((value "float"))) + (def-jni-constructor "java.lang.Integer" ((value "int"))) + (def-jni-constructor "java.lang.Short" ((value "short"))) + + (def-jni-function "java.lang.Boolean" "booleanValue" () "boolean") + (def-jni-function "java.lang.Byte" "byteValue" () "byte") + (def-jni-function "java.lang.Character" "charValue" () "char") + (def-jni-function "java.lang.Double" "doubleValue" () "double") + (def-jni-function "java.lang.Float" "floatValue" () "float") + (def-jni-function "java.lang.Integer" "intValue" () "int") + (def-jni-function "java.lang.Short" "shortValue" () "short") + + (def-jni-constructor "java.util.jar.JarFile" ((filename "java.lang.String"))) + (def-jni-function "java.util.jar.JarFile" + "entries" () "java.util.Enumeration") + (def-jni-functions "java.util.Enumeration" + ("hasMoreElements" () "boolean") + ("nextElement" () "java.lang.Object")) + (def-jni-functions "java.util.zip.ZipEntry" + ("isDirectory" () "boolean") + ("getName" () "java.lang.String")) + + + (def-jni-functions "java.lang.Long" + ("valueOf" ((s "String")) "java.lang.Long" :static t) + ("intValue" () "int")) + + (def-jni-field "java.lang.Boolean" "TYPE" "Class" :static t) + (def-jni-field "java.lang.Byte" "TYPE" "Class" :static t) + (def-jni-field "java.lang.Character" "TYPE" "Class" :static t) + (def-jni-field "java.lang.Float" "TYPE" "Class" :static t) + (def-jni-field "java.lang.Integer" "TYPE" "Class" :static t) + (def-jni-field "java.lang.Double" "TYPE" "Class" :static t) + (def-jni-field "java.lang.Short" "TYPE" "Class" :static t) + (def-jni-field "java.lang.Long" "TYPE" "Class" :static t) + + (def-jni-constructor "com.richhickey.jfli.LispInvocationHandler" ()) + (def-jni-function "java.lang.reflect.Proxy" + "newProxyInstance" ((loader "java.lang.ClassLoader") + (interfaces "java.lang.Class<>") + (h "InvocationHandler")) "java.lang.Object" :static t) + + (def-jni-function "java.lang.ClassLoader" + "getSystemClassLoader" () "ClassLoader" :static t) + + ) ;eval-when + +;;;;;;;;;;;;;;;;;;;;;;;;;;; utilities ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; + +(eval-when (:compile-toplevel :load-toplevel) + (defun ensure-package (name) + "find the package or create it if it doesn't exist" + (or (find-package name) + (make-package name :use '()))) + (intern "Object" (ensure-package "java.lang")) + (intern "String" (ensure-package "java.lang"))) + +(defmacro do-jarray ((x array) &body body) + "jni-based, so not safe and not exported, but used by the implementation" + (let ((gcount (gensym)) + (gi (gensym)) + (garray (gensym))) + `(let* ((,garray ,array) + (,gcount (jni:get-array-length ,garray))) + (dotimes (,gi ,gcount) + (let ((,x (jaref ,garray ,gi))) + ,@body))))) + + +(defmacro doenum ((e enum) &body body) + "jni-based, so not safe and not exported, but used by the implementation" + (let ((genum (gensym))) + `(let ((,genum ,enum)) + (do () + ((not (enumeration.hasmoreelements ,genum))) + (let ((,e (enumeration.nextelement ,genum))) + ,@body))))) + +;probably insufficiently general, works as used here +(defmacro get-or-init (place init-form) + `(or ,place + (setf ,place ,init-form))) + +;from c.l.l. +(defmacro case-equal (exp &body clauses) + (let ((temp (gensym))) + `(let ((,temp ,exp)) + (cond ,@(mapcar #'(lambda (clause) + (destructuring-bind (keys . clause-forms) clause + (cond ((eq keys 'otherwise) + `(t ,@clause-forms)) + (t + (if (atom keys) (setq keys (list keys))) + `((member ,temp ',keys :test #'equal) + ,@clause-forms))))) + clauses))))) + +;create object. to bootstrap the hierarchy +(defclass |java.lang|::object. () + ((ref :reader ref :initarg :ref) + (lisp-allocated :reader lisp-allocated-p :initarg :lisp-allocated :initform nil)) + (:documentation "the superclass of all Java typed reference classes")) + +(defun get-ref (x) + "any function taking an object can be passed a raw java-ref ptr or a typed reference instance. +Will also convert strings for use as objects" + (etypecase x + (java-ref x) + (|java.lang|::object. (ref x)) + (string (convert-to-java-string x)) + (null nil))) + +(defun jeq (obj1 obj2) + "are these 2 java objects the same object? Note that is not the same as Object.equals()" + (is-same-object (get-ref obj1) (get-ref obj2))) + + +;;;;;;;;;;;;;;;;;;;;;;;; names and symbols ;;;;;;;;;;;;;;;;;;;;;;; +#| +The library does a lot with names and symbols, needing at various times to: + - find stuff in Java - full names w/case required + - create hopefully non-conflicting packages and member names + +When you (def-java-class "java.lang.String") you get a bunch of symbols/names: +a package named '|java.lang| +a class-symbol '|java.lang|:STRING. (note the dot and case), + which can usually be used where a typename is required + it also serves as the name of the Lisp typed reference class for string + its symbol-value is the canonic-class-symbol (see below) +a canonic-class-symbol '|java.lang|::|String| + can be used to reconstitute the full class name + +I've started trying to flesh out the notion of a Java class designator, which can either be +the full class name as a string, the class-symbol, or one of :boolean, :int etc +|# + +(defun canonic-class-symbol (full-class-name) + "(\"java.lang.Object\") -> '|java.lang|:|Object|" + (multiple-value-bind (package class) (split-package-and-class full-class-name) + (intern class (ensure-package package)))) + +(defun class-symbol (full-class-name) + "(\"java.lang.Object\") -> '|java.lang|:object." + (multiple-value-bind (package class) (split-package-and-class full-class-name) + (intern (string-upcase (string-append class ".")) (ensure-package package)))) + +(defun java-class-name (class-sym) + "inverse of class-symbol, only valid on class-syms created by def-java-class" + (let ((canonic-class-symbol (symbol-value class-sym))) + (string-append (package-name (symbol-package canonic-class-symbol)) + "." + canonic-class-symbol))) + +(defun member-symbol (full-class-name member-name) + "members are defined case-insensitively in case-sensitive packages, +prefixed by 'classname.' - +(member-symbol \"java.lang.Object\" \"toString\") -> '|java.lang|::OBJECT.TOSTRING" + (multiple-value-bind (package class) (split-package-and-class full-class-name) + (intern (string-upcase (string-append class "." member-name)) (ensure-package package)))) + +(defun constructor-symbol (full-class-name) + (member-symbol full-class-name "new")) + +(defun get-java-class-ref (canonic-class-symbol) + "class-ref is cached on the plist of the canonic class symbol" + (get-or-init (get canonic-class-symbol :class-ref) + (let ((class-name (string-append (package-name + (symbol-package canonic-class-symbol)) + "." + canonic-class-symbol))) + (try-null (jni-find-class (nsubstitute #\/ #\. class-name)))))) + +(defun find-java-class (class-sym-or-string) + "Given a Java class designator, returns the Java Class object." + (ctypecase class-sym-or-string + (symbol (case class-sym-or-string + (:int integer.type) + (:char character.type) + (:long long.type) + (:float float.type) + (:boolean boolean.type) + (:short short.type) + (:double double.type) + (:byte byte.type) + (otherwise (get-java-class-ref class-sym-or-string)))) + (string (get-java-class-ref (canonic-class-symbol class-sym-or-string))))) + +;;;;;;;;;;;;;;;;;;;;;; typed reference support ;;;;;;;;;;;;;;;;;;;;;;;; +#| +The library maintains a hierarchy of typed reference classes that parallel the +class hierarchy on the Java side +new returns a typed reference, but other functions that return objects +return raw references (for efficiency) +make-typed-ref can create fully-typed wrappers when desired +|# + +(defun get-superclass-names (full-class-name) + (let* ((class (get-java-class-ref (canonic-class-symbol full-class-name))) + (super (class.getsuperclass class)) + (interfaces (class.getinterfaces class)) + (supers ())) + (do-jarray (i interfaces) + (push i supers)) + ;hmmm - where should the base class go in the precedence list? + ;is it more important than the interfaces? this says no + (if super + (push super supers) + (push (find-java-class "java.lang.Object") supers)) + (setf supers (nreverse supers)) + ;now we need to fix up order so more derived classes are first + ;but don't have a total ordering, so merge one at a time + (let (result) + (dolist (s supers) + (setf result (merge 'list result (list s) + (lambda (x y) + (is-assignable-from x y))))) + (mapcar #'class.getname result)))) +#| +(defun get-superclass-names (full-class-name) + (let* ((class (get-java-class-ref (canonic-class-symbol full-class-name))) + (super (class.getsuperclass class)) + (interfaces (class.getinterfaces class)) + (supers ())) + (do-jarray (i interfaces) + (push (class.getname i) supers)) + ;hmmm - where should the base class go in the precedence list? + ;is it more important than the interfaces? this says no + (if super + (push (class.getname super) supers) + (push "java.lang.Object" supers)) + (nreverse supers))) +|# + +(defun ensure-java-class (full-class-name) + "walks the superclass hierarchy and makes sure all the classes are fully defined +(they may be undefined or just forward-referenced-class) +caches this has been done on the class-symbol's plist" + (let* ((class-sym (class-symbol full-class-name)) + (class (find-class class-sym nil))) + (if (or (eql class-sym '|java.lang|::object.) + (get class-sym :ensured)) + class + (let ((supers (get-superclass-names full-class-name))) + (dolist (super supers) + (ensure-java-class super)) + (unless (and class (subtypep class 'standard-object)) + (setf class + (clos:ensure-class class-sym :direct-superclasses (mapcar #'class-symbol supers)))) + (setf (get class-sym :ensured) t) + class)))) + +(defun ensure-java-hierarchy (class-sym) + "Works off class-sym for efficient use in new +This will only work on class-syms created by def-java-class, +as it depends upon symbol-value being the canonic class symbol" + (unless (get class-sym :ensured) + (ensure-java-class (java-class-name class-sym)))) + +(defun make-typed-ref (java-ref) + "Given a raw java-ref, determines the full type of the object +and returns an instance of a typed reference wrapper" + (when java-ref + (let ((class (object.getclass (get-ref java-ref)))) + (if (class.isarray class) + (error "typed refs not supported for arrays (yet)") + (make-instance (ensure-java-class (class.getname class)) :ref (get-ref java-ref) ))))) + + +;;;;;;;;;;;;;;;;;;;;;;;;; Wrapper Generation ;;;;;;;;;;;;;;;;;;;;;;;;;;; +#| +In an effort to reduce the volume of stuff generated when wrapping entire libraries, +the wrappers just generate minimal stubs, which, if and when invoked at runtime, +complete the work of building thunking closures, so very little code is generated for +things never called (Java libraries have huge numbers of symbols). +Not sure if this approach matters, but that's how it works +|# + +(defmacro def-java-class (full-class-name) + "Given the package-qualified, case-correct name of a java class, will generate +wrapper functions for its constructors, fields and methods." + (multiple-value-bind (package class) (split-package-and-class full-class-name) + (declare (ignore class)) + (let* ((class-sym (class-symbol full-class-name)) + (defs + (list* + `(ensure-package ,package) + ;build a path from the simple class symbol to the canonic + `(defconstant ,class-sym ',(canonic-class-symbol full-class-name)) + `(export ',class-sym (symbol-package ',class-sym)) + `(def-java-constructors ,full-class-name) + `(def-java-methods ,full-class-name) + `(def-java-fields ,full-class-name) + (unless (string= full-class-name "java.lang.Object") + (let ((supers (mapcar #'class-symbol (get-superclass-names full-class-name)))) + (append (mapcar (lambda (p) + `(ensure-package ,(package-name p))) + (remove (symbol-package class-sym) + (remove-duplicates (mapcar #'symbol-package supers)))) + (list `(defclass ,(class-symbol full-class-name) + ,supers ())))))))) + `(locally ,@defs)))) + +(defun get-jar-classnames (jar-file-name &rest packages) + "returns a list of strings, packages should be of the form \"java/lang\" + for recursive lookup and \"java/util/\" for non-recursive" + (let* ((jar (jarfile.new jar-file-name)) + (entries (jarfile.entries jar)) + (names ())) + (doenum (e entries) + (unless (zipentry.isdirectory e) + (let ((ename (zipentry.getname e))) + (flet ((matches (package) + (and (eql 0 (search package ename)) + (or (not (eql #\/ (schar package (1- (length package))))) ;recursive + (not (find #\/ ename :start (length package))))))) ;non-subdirectory + (when (and (eql (search ".class" ename) + (- (length ename) 6)) ;classname + ;don't grab anonymous inner classes + (not (and (find #\$ ename) + (digit-char-p (schar ename (1+ (position #\$ ename)))))) + (some #'matches packages)) + (push (nsubstitute #\. #\/ (subseq ename 0 (- (length ename) 6))) + names)))))) + names)) + +(defun dump-wrapper-defs-to-file (filename classnames) + "given a list of classnames (say from get-jar-classnames), writes +calls to def-java-class to a file" + (with-open-file (s filename :direction :output :if-exists :supersede) + (dolist (name (sort classnames #'string-lessp)) + (format s "(def-java-class ~S)~%" name)))) + +;;;;;;;;;;;;;;;;;;;;;;;;; constructors and new ;;;;;;;;;;;;;;;;;;;;;;;;;; +#| + +Every non-interface class with a public ctor will get; + a constructor, classname.new + a method defined on make-new, ultimately calling classname.new, + specialized on (the value of) it's class-symbol (e.g. canonic sym) + +Note that if the ctor is overloaded, there is just one function (taking a rest arg), +which handles overload resolution + +The new macro expands into a call to make-new +|# + +(defgeneric make-new (class-sym &rest args) + (:documentation "Allows for definition of before/after methods on ctors. +The new macro expands into call to this")) + +(defun build-ctor-doc-string (name ctors) + (with-output-to-string (s) + (dolist (c ctors) + (format s "~A(~{~#[~;~A~:;~A,~]~})~%" + name + (mapcar #'class-name-for-doc (jarray-to-list (constructor.getparametertypes c))))))) + +(defmacro def-java-constructors (full-class-name) +"creates and exports a ctor func classname.new, defines a method of +make-new specialized on the class-symbol" + (let ((ctor-list (get-ctor-list full-class-name))) + (when ctor-list + (let ((ctor-sym (constructor-symbol full-class-name)) + (class-sym (class-symbol full-class-name))) + `(locally + (defun ,ctor-sym (&rest args) + ,(build-ctor-doc-string full-class-name ctor-list) + (apply #'install-constructors-and-call ,full-class-name args)) + (export ',ctor-sym (symbol-package ',ctor-sym)) + (defmethod make-new ((class-sym (eql ,class-sym)) &rest args) + (apply (function ,ctor-sym) args))))))) + +(defun get-ctor-list (full-class-name) + (let* ((class-sym (canonic-class-symbol full-class-name)) + (class (get-java-class-ref class-sym)) + (ctor-array (class.getconstructors class)) + (ctor-list (jarray-to-list ctor-array))) + ctor-list)) + +(defun install-constructors-and-call (full-class-name &rest args) + "initially the constructor symbol for a class is bound to this function, +when first called it will replace itself with the appropriate direct thunk, +then call the requested ctor - subsequent calls will be direct" + (install-constructors full-class-name) + (apply (constructor-symbol full-class-name) args)) + +(defun install-constructors (full-class-name) + (let* ((ctor-list (get-ctor-list full-class-name))) + (when ctor-list + (setf (fdefinition (constructor-symbol full-class-name)) + (make-ctor-thunk ctor-list (class-symbol full-class-name)))))) + +(defun make-ctor-thunk (ctors class-sym) + (if (rest ctors) ;overloaded + (make-overloaded-ctor-thunk ctors class-sym) + (make-non-overloaded-ctor-thunk (first ctors) class-sym))) + +(defun make-non-overloaded-ctor-thunk (ctor class-sym) + (let ((arg-boxers (get-arg-boxers (constructor.getparametertypes ctor)))) + (lambda (&rest args) + (let ((arg-array (build-arg-array args arg-boxers))) + (ensure-java-hierarchy class-sym) + (prog1 + (make-instance class-sym + :ref (constructor.newinstance ctor arg-array) + :lisp-allocated t) + ;(constructor.newinstance ctor arg-array) + (when arg-array + (delete-local-ref arg-array))))))) + +(defun make-overloaded-ctor-thunk (ctors class-sym) + (let ((thunks (make-ctor-thunks-by-args-length ctors class-sym))) + (lambda (&rest args) + (let ((fn (cdr (assoc (length args) thunks)))) + (if fn + (apply fn + args) + (error "invalid arity")))))) + +(defun make-ctor-thunks-by-args-length (ctors class-sym) + "returns an alist of thunks keyed by number of args" + (let ((ctors-by-args-length (make-hash-table)) + (thunks-by-args-length nil)) + (dolist (ctor ctors) + (let ((params-len (get-array-length (constructor.getparametertypes ctor)))) + (push ctor (gethash params-len ctors-by-args-length)))) + (maphash #'(lambda (args-len ctors) + (push (cons args-len + (if (rest ctors);truly overloaded + (make-type-overloaded-ctor-thunk ctors class-sym) + ;only one ctor with this number of args + (make-non-overloaded-ctor-thunk (first ctors) class-sym))) + thunks-by-args-length)) + ctors-by-args-length) + thunks-by-args-length)) + +(defun make-type-overloaded-ctor-thunk (ctors class-sym) + "these methods have the same number of args and must be distinguished by type" + (let ((thunks (mapcar #'(lambda (ctor) + (list (make-non-overloaded-ctor-thunk ctor class-sym) + (jarray-to-list (constructor.getparametertypes ctor)))) + ctors))) + (lambda (&rest args) + (block fn + (let ((arg-types (get-types-of-args args))) + (dolist (thunk-info thunks) + (destructuring-bind (thunk param-types) thunk-info + (when (is-congruent-type-list param-types arg-types) + (return-from fn (apply thunk args))))) + (error "No matching constructor")))))) + +(defmacro new (class-spec &rest args) +"new class-spec args +class-spec -> class-name | (class-name this-name) +class-name -> \"package.qualified.ClassName\" | classname. +args -> [actual-arg]* [init-arg-spec]* +init-arg-spec -> init-arg | (init-arg) +init-arg -> :settable-field-or-method [params]* value ;note keyword + | + .method-name [args]* ;note dot + +Creates a new instance of class-name, using make-new generic function, +then initializes it by setting fields or accessors and/or calling member functions +If this-name is supplied it will be bound to the newly-allocated object and available +to the init-args" + (labels ((mem-sym? (x) + (or (keywordp x) + (and (symbolp x) (eql 0 (position #\. (symbol-name x)))))) + (mem-form? (x) + (and (listp x) (mem-sym? (first x)))) + (mem-init? (x) + (or (mem-sym? x) (mem-form? x))) + (init-forms (x) + (if x + (if (mem-form? (first x)) + (cons (first x) (init-forms (rest x))) + (let ((more (member-if #'mem-init? (rest x)))) + (cons (ldiff x more) (init-forms more))))))) + (let* ((inits (member-if #'mem-init? args)) + (real-args (ldiff args inits)) + (class-atom (if (atom class-spec) + class-spec + (first class-spec))) + (class-sym (if (symbolp class-atom) + ;(find-symbol (string-append (symbol-name class-atom) ".")) + class-atom + (multiple-value-bind (package class) (jni::split-package-and-class class-atom) + (find-symbol (string-append (string-upcase class) ".") package)))) + (class-name (subseq (symbol-name class-sym) 0 (1- (length (symbol-name class-sym))))) + (gthis (gensym))) + (flet ((expand-init (x) + (if (keywordp (first x)) ;setf field or property + `(setf (,(find-symbol (string-append class-name "." (symbol-name (first x)))) + ,gthis ,@(butlast (rest x))) + ,@(last (rest x))) + ;.memfunc + `(,(find-symbol (string-append class-name (symbol-name (first x)))) + ,gthis + ,@(rest x))))) + `(let* ((,gthis (make-new ,class-sym ,@real-args)) + ,@(when (listp class-spec) + `((,(second class-spec) ,gthis)))) + ,@(mapcar #'expand-init (init-forms inits)) + ,gthis))))) + +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; Fields ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; + +#| +all public fields will get a getter function classname.fieldname and a setter - (setf classname.fieldname) +instance fields take an first arg which is the instance +static fields also get a symbol-macro *classname.fieldname* +|# + +(defmacro def-java-fields (full-class-name) +"fields will get a getter function classname.fieldname and a setter - (setf classname.fieldname) +instance fields take an first arg which is the instance +static fields also get a symbol-macro *classname.fieldname*" + (let* ((class-sym (canonic-class-symbol full-class-name)) + (class (get-java-class-ref class-sym)) + (fields (jarray-to-list (class.getfields class))) + (defs nil)) + (dolist (field fields) + (let* ((field-name (field.getname field)) + (field-sym (member-symbol full-class-name field-name)) + (is-static (modifier.isstatic (field.getmodifiers field)))) + (if is-static + (let ((macsym (intern (string-append "*" (symbol-name field-sym) "*") + (symbol-package field-sym)))) + (push `(defun ,field-sym () + (install-static-field-and-get ,full-class-name ,field-name)) + defs) + (push `(defun (setf ,field-sym) (val) + (install-static-field-and-set ,full-class-name ,field-name val)) + defs) + (push `(export ',field-sym (symbol-package ',field-sym)) defs) + (push `(define-symbol-macro ,macsym (,field-sym)) defs) + (push `(export ',macsym (symbol-package ',macsym)) defs)) + (progn + (push `(defun ,field-sym (obj) + (install-field-and-get ,full-class-name ,field-name obj)) + defs) + (push `(defun (setf ,field-sym) (val obj) + (install-field-and-set ,full-class-name ,field-name val obj)) + defs) + (push `(export ',field-sym (symbol-package ',field-sym)) defs))))) + `(locally ,@(nreverse defs)))) + +(defun install-field-and-get (full-class-name field-name obj) + (install-field full-class-name field-name) + (funcall (member-symbol full-class-name field-name) obj)) + +(defun install-field-and-set (full-class-name field-name val obj) + (install-field full-class-name field-name) + (funcall (fdefinition `(setf ,(member-symbol full-class-name field-name))) val obj)) + +(defun install-static-field-and-get (full-class-name field-name) + (install-field full-class-name field-name) + (funcall (member-symbol full-class-name field-name))) + +(defun install-static-field-and-set (full-class-name field-name val) + (install-field full-class-name field-name) + (funcall (fdefinition `(setf ,(member-symbol full-class-name field-name))) val)) + +(defun install-field (full-class-name field-name) + (let* ((class-sym (canonic-class-symbol full-class-name)) + (class (get-java-class-ref class-sym)) + (field (class.getfield class field-name)) + (field-sym (member-symbol full-class-name field-name)) + (is-static (modifier.isstatic (field.getmodifiers field))) + (field-type-name (class.getname (field.gettype field))) + (boxer (get-boxer-fn field-type-name)) + (unboxer (get-unboxer-fn field-type-name))) + (if is-static + (progn + (setf (fdefinition field-sym) + (lambda () + (funcall unboxer (field.get field nil) t))) + (setf (fdefinition `(setf ,field-sym)) + (lambda (arg) + (field.set field nil + (get-ref (if (and boxer (not (boxed? arg))) + (funcall boxer arg) + arg))) + arg))) + (progn + (setf (fdefinition field-sym) + (lambda (obj) + (funcall unboxer (field.get field (get-ref obj)) t))) + (setf (fdefinition `(setf ,field-sym)) + (lambda (arg obj) + (field.set field (get-ref obj) + (get-ref (if (and boxer (not (boxed? arg))) + (funcall boxer arg) + arg))) + arg)))))) + +;;;;;;;;;;;;;;;;;;;;;;;;;;;;; methods ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; +#| +defines wrappers for all public methods of the class +As with ctors, if a method is overloaded a single wrapper is created that handles +overload resolution. +The wrappers have the name classname.methodname +If a method follows the JavaBeans property protocol (i.e. it is called getSomething or isSomething +and there is a corresponding setSomething, then a (setf classname.methodname) will be defined +that calls the latter +|# + +(defun class-name-for-doc (class) + (let ((name (class.getname class))) + (if (class.isarray class) + (decode-array-name name) + name))) + +(defun build-method-doc-string (name methods) + (with-output-to-string (s) + (dolist (m methods) + (format s "~A~A ~A(~{~#[~;~A~:;~A,~]~})~%" + (if (modifier.isstatic (method.getmodifiers m)) + "static " + "") + (class.getname (method.getreturntype m)) + name + (mapcar #'class-name-for-doc (jarray-to-list (method.getparametertypes m))))))) + +(defmacro def-java-methods (full-class-name) + (let ((methods-by-name (get-methods-by-name full-class-name)) + (defs nil)) + (maphash (lambda (name methods) + (let ((method-sym (member-symbol full-class-name name))) + (push `(defun ,method-sym (&rest args) + ,(build-method-doc-string name methods) + (apply #'install-methods-and-call ,full-class-name ,name args)) + defs) + (push `(export ',method-sym (symbol-package ',method-sym)) + defs) + ;build setters when finding beans property protocol + (flet ((add-setter-if (prefix) + (when (eql 0 (search prefix name)) + (let ((setname (string-append "set" (subseq name (length prefix))))) + (when (gethash setname methods-by-name) + (push `(defun (setf ,method-sym) (val &rest args) + (progn + (apply #',(member-symbol full-class-name setname) + (append args (list val))) + val)) + defs)))))) + (add-setter-if "get") + (add-setter-if "is")))) + methods-by-name) + `(locally ,@(nreverse defs)))) + +(defun install-methods-and-call (full-class-name method &rest args) + "initially all the member function symbols for a class are bound to this function, +when first called it will replace them with the appropriate direct thunks, +then call the requested method - subsequent calls via those symbols will be direct" + (install-methods full-class-name) + (apply (member-symbol full-class-name method) args)) + +(defun decode-array-name (tn) + (let ((prim (assoc tn + '(("Z" . "boolean") + ("B" . "byte") + ("C" . "char") + ("S" . "short") + ("I" . "int") + ("J" . "long") + ("F" . "float") + ("D" . "double") + ("V" . "void")) + :test #'string-equal))) + (if prim + (rest prim) + (let ((array-depth (count #\[ tn))) + (if (= 0 array-depth) + (subseq tn 1 (1- (length tn))) ;strip leading L and trailing ; + (with-output-to-string (s) + (write-string (decode-array-name (subseq tn array-depth)) s) + (dotimes (x array-depth) + (write-string "[]" s)))))))) + +(defun jarray-to-list (array) + (let (ret) + (do-jarray (x array) + (push x ret)) + (nreverse ret))) + +(defun get-methods-by-name (full-class-name) + "returns an #'equal hashtable of lists of java.lang.Method refs keyed by name" + (let* ((class-sym (canonic-class-symbol full-class-name)) + (class (get-java-class-ref class-sym)) + (method-array (class.getmethods class)) + (methods-by-name (make-hash-table :test #'equal))) + (do-jarray (method method-array) + (push method (gethash (method.getName method) methods-by-name))) + methods-by-name)) + +(defun install-methods (full-class-name) + (let ((methods-by-name (get-methods-by-name full-class-name))) + (maphash + (lambda (name methods) + (setf (fdefinition (member-symbol full-class-name name)) + (make-method-thunk methods))) + methods-by-name))) + +(defun make-method-thunk (methods) + (if (rest methods) ;overloaded + (make-overloaded-thunk methods) + (make-non-overloaded-thunk (first methods)))) + +(defun make-non-overloaded-thunk (method) + (let ((unboxer-fn (get-unboxer-fn (class.getname (method.getreturntype method)))) + (arg-boxers (get-arg-boxers (method.getparametertypes method))) + (is-static (modifier.isstatic (method.getmodifiers method)))) + (lambda (&rest args) + (let ((arg-array (build-arg-array (if is-static args (rest args)) arg-boxers))) + (prog1 + (funcall unboxer-fn + (method.invoke method + (if is-static nil (get-ref (first args))) + arg-array) t) + (when arg-array + (delete-local-ref arg-array))))))) + +(defun make-overloaded-thunk (methods) + (let ((thunks (make-thunks-by-args-length methods))) + (lambda (&rest args) + (let ((fn (cdr (assoc (length args) thunks)))) + (if fn + (apply fn + args) + (error "invalid arity")))))) + +(defun make-thunks-by-args-length (methods) + "returns an alist of thunks keyed by number of args" + (let ((methods-by-args-length (make-hash-table)) + (thunks-by-args-length nil)) + (dolist (method methods) + (let ((is-static (modifier.isstatic (method.getmodifiers method))) + (params-len (get-array-length (method.getparametertypes method)))) + (push method (gethash (if is-static params-len (1+ params-len)) + methods-by-args-length)))) + (maphash #'(lambda (args-len methods) + (push (cons args-len + (if (rest methods);truly overloaded + (make-type-overloaded-thunk methods) + ;only one method with this number of args + (make-non-overloaded-thunk (first methods)))) + thunks-by-args-length)) + methods-by-args-length) + thunks-by-args-length)) + +(defun make-type-overloaded-thunk (methods) + "these methods have the same number of args and must be distinguished by type" + (let ((thunks (mapcar #'(lambda (method) + (list (make-non-overloaded-thunk method) + (modifier.isstatic (method.getmodifiers method)) + (jarray-to-list (method.getparametertypes method)))) + methods))) + (lambda (&rest args) + (block fn + (let ((arg-types (get-types-of-args args))) + (dolist (thunk-info thunks) + (destructuring-bind (thunk is-static param-types) thunk-info + (when (is-congruent-type-list param-types (if is-static arg-types (rest arg-types))) + (return-from fn (apply thunk args))))) + (error "No matching method")))))) + + +;;;;;;;;;;;;;;;;;;;;;;;;;;;; array support ;;;;;;;;;;;;;;;;;;;;;;;;;;; + +(defun jref (array &rest subscripts) + "like aref, for Java arrays of non-primitive/reference types, settable" + (assert (every #'integerp subscripts)) + (do* + ((sub subscripts (rest sub)) + (a (get-ref array) (get-ref (array.get a (first sub))))) + ((null (rest sub)) + (array.get a (first sub))))) + +(defun (setf jref) (val array &rest subscripts) + (assert (every #'integerp subscripts)) + (do* + ((sub subscripts (rest sub)) + (a (get-ref array) (get-ref (array.get a (first sub))))) + ((null (rest sub)) + (array.set a (first sub) (get-ref val)) + val))) + +(eval-when (:compile-toplevel :load-toplevel :execute) + (defmacro def-refs (&rest types) + `(locally + ,@(mapcan + (lambda (type) + (let ((ref-sym (intern (string-upcase (string-append "jref-" (symbol-name type)))))) + (list + `(defun ,ref-sym (array &rest subscripts) + ,(format nil "like aref, for Java arrays of ~A, settable" (symbol-name type)) + (assert (every #'integerp subscripts)) + (do* + ((sub subscripts (rest sub)) + (a (get-ref array) (get-ref (array.get a (first sub))))) + ((null (rest sub)) + (,(intern (string-upcase (string-append "array.get" (symbol-name type)))) + a (first sub))))) + + `(defun (setf ,ref-sym) (val array &rest subscripts) + (assert (every #'integerp subscripts)) + (do* + ((sub subscripts (rest sub)) + (a (get-ref array) (get-ref (array.get a (first sub))))) + ((null (rest sub)) + (array.set a (first sub) + (,(intern (string-upcase (string-append "box-" + (symbol-name type)))) + val)) + val)))))) + types)))) + +;arrays of primitives have their own accessors +(def-refs boolean byte char double float int short long) + +(defun jlength (array) + "like length, for Java arrays" + (array.getlength (get-ref array))) + +(defgeneric make-new-array (type &rest dimensions) + (:documentation "generic function, with methods for all Java class designators") + (:method (type &rest dims) + (assert (every #'integerp dims)) + (if (rest dims) + (let* ((ndim (length dims)) + (dim-array (new-int-array ndim))) + (dotimes (i ndim) + (array.set dim-array i (box-int (nth i dims)))) + (array.newinstance> type dim-array)) + (array.newinstance type (first dims))))) + +(defmethod make-new-array ((type symbol) &rest dimensions) + (apply #'make-new-array (get-java-class-ref type) dimensions)) + +(defmethod make-new-array ((type string) &rest dimensions) + (apply #'make-new-array (find-java-class type) dimensions)) + +(defmethod make-new-array ((type (eql :char)) &rest dimensions) + (apply #'make-new-array character.type dimensions)) + +(defmethod make-new-array ((type (eql :int)) &rest dimensions) + (apply #'make-new-array integer.type dimensions)) + +(defmethod make-new-array ((type (eql :boolean)) &rest dimensions) + (apply #'make-new-array boolean.type dimensions)) + +(defmethod make-new-array ((type (eql :double)) &rest dimensions) + (apply #'make-new-array double.type dimensions)) + +(defmethod make-new-array ((type (eql :byte)) &rest dimensions) + (apply #'make-new-array byte.type dimensions)) + +(defmethod make-new-array ((type (eql :float)) &rest dimensions) + (apply #'make-new-array float.type dimensions)) + +(defmethod make-new-array ((type (eql :short)) &rest dimensions) + (apply #'make-new-array short.type dimensions)) + +(defmethod make-new-array ((type (eql :long)) &rest dimensions) + (apply #'make-new-array long.type dimensions)) + +;;;;;;;;;;;;;;;;;;;;;;;;;; arg/param helpers ;;;;;;;;;;;;;;;;;;;;;; + +(defun get-arg-boxers (param-types) + "returns a list with one entry per param, either nil or a function that boxes the arg" + (let (ret) + (do-jarray (param-type param-types) + (push (get-boxer-fn (class.getname param-type)) + ret)) + (nreverse ret))) + +(defun build-arg-array (args arg-boxers) + (when args + (let* ((arg-array (new-object-array (length args) + ;duplication of class-symbol logic + ;but must be fast + (get-java-class-ref '|java.lang|::|Object|) + nil))) + (do ((i 0 (incf i)) + (args args (rest args)) + (boxers arg-boxers (rest boxers))) + ((null args)) + (let ((arg (first args)) + (boxer (first boxers))) + (setf (jaref arg-array i) + (get-ref (if (and boxer (not (boxed? arg))) + (funcall boxer arg) + arg))))) + arg-array))) + +(defun get-types-of-args (args) + (let (ret) + (dolist (arg args) + (push (infer-box-type arg) + ret)) + (nreverse ret))) + +(defun is-congruent-type-list (param-types arg-types) + (every #'(lambda (arg-type param-type) + (if arg-type + (is-assignable-from arg-type param-type) + ;nil was passed - must be boolean or non-primitive target type + (or (not (class.isprimitive param-type)) + (is-assignable-from boolean.type param-type)))) + arg-types param-types)) + + +;;;;;;;;;;;;;;;;;;;;;;;; argument conversion and boxing ;;;;;;;;;;;;;;;;;;;;;;;;;; +(defun box-string (s) +"Given a string or symbol, returns reference to a Java string" + (local-ref-to-global-ref (convert-to-java-string s))) + +(defun unbox-string (ref &optional delete-local) + "Given a reference to a Java string, returns a Lisp string" + (declare (ignore delete-local)) + (convert-from-java-string (get-ref ref))) + +(defun get-boxer-fn (class-name) + (case-equal class-name + ("int" #'box-int) + ("boolean" #'box-boolean) + ("double" #'box-double) + ("java.lang.String" #'convert-to-java-string) + ("char" #'box-char) + ("byte" #'box-byte) + ("float" #'box-float) + ("long" #'box-long) + ("short" #'box-short) + (otherwise nil))) + +(defun get-boxer-fn-sym (class-name) + (case-equal class-name + ("int" 'box-int) + ("boolean" 'box-boolean) + ("double" 'box-double) + ("java.lang.String" 'convert-to-java-string) + ("char" 'box-char) + ("byte" 'box-byte) + ("float" 'box-float) + ("long" 'box-long) + ("short" 'box-short) + ("void" 'box-void) + (otherwise 'identity))) + +(defun boxed? (x) + (or (java-ref-p x) + (typep x '|java.lang|::object.))) + +(defun infer-box-type (x) + (cond + ((null x) nil) + ((boxed? x) (object.getclass (get-ref x))) + ((integerp x) integer.type) + ((numberp x) double.type) + ((eq x t) boolean.type) + ((or (stringp x) (symbolp x)) + (get-java-class-ref '|java.lang|::|String|)) + (t (error "can't infer box type")))) + +(defun get-unboxer-fn (class-name) + (case-equal class-name + ("int" #'unbox-int) + ("boolean" #'unbox-boolean) + ("double" #'unbox-double) + ("java.lang.String" #'unbox-string) + ("void" #'unbox-void) + ("char" #'unbox-char) + ("byte" #'unbox-byte) + ("float" #'unbox-float) + ("long" #'unbox-long) + ("short" #'unbox-short) + (otherwise #'unbox-ref))) + +(defun get-unboxer-fn-sym (class-name) + (case-equal class-name + ("int" 'unbox-int) + ("boolean" 'unbox-boolean) + ("double" 'unbox-double) + ("java.lang.String" 'unbox-string) + ("void" 'unbox-void) + ("char" 'unbox-char) + ("byte" 'unbox-byte) + ("float" 'unbox-float) + ("long" 'unbox-long) + ("short" 'unbox-short) + (otherwise 'unbox-ref))) + +(defun unbox-ref (x &optional delete-local) + (declare (ignore delete-local)) + (local-ref-to-global-ref x)) + +(defun unbox-void (x &optional delete-local) + (declare (ignore x delete-local)) + nil) + +(defun box-void (x) + (declare (ignore x)) + nil) + +(defun box-boolean (x) + (boolean.new x)) + +(defun unbox-boolean (obj &optional delete-local) + (prog1 + (boolean.booleanvalue (get-ref obj)) + (when delete-local (delete-local-ref obj)))) + +(defun box-byte (x) + (assert (integerp x)) + (byte.new x)) + +(defun unbox-byte (x &optional delete-local) + (prog1 + (byte.bytevalue (get-ref x)) + (when delete-local (delete-local-ref x)))) + +(defun box-char (x) + (character.new x)) + +(defun unbox-char (x &optional delete-local) + (prog1 + (character.charvalue (get-ref x)) + (when delete-local (delete-local-ref x)))) + +(defun box-double (x) + (assert (floatp x)) + (double.new (coerce x 'double-float))) + +(defun unbox-double (x &optional delete-local) + (prog1 + (double.doublevalue (get-ref x)) + (when delete-local (delete-local-ref x)))) + +(defun box-float (x) + (assert (floatp x)) + (float.new x)) + +(defun unbox-float (x &optional delete-local) + (prog1 + (float.floatvalue (get-ref x)) + (when delete-local (delete-local-ref x)))) + +(defun box-int (x) + (assert (integerp x)) + (integer.new x)) + +(defun unbox-int (x &optional delete-local) + (prog1 + (integer.intvalue (get-ref x)) + (when delete-local (delete-local-ref x)))) + +;can't directly construct Long because LW doesn't support long long fli on 32 bit platforms +(defun box-long (x) + (assert (integerp x)) + (long.valueof (princ-to-string x))) + +;here too, can only get an ints worth - aargh +(defun unbox-long (obj &optional delete-local) + (prog1 + (parse-integer (object.tostring (get-ref obj))) + (when delete-local (delete-local-ref obj)))) + +(defun box-short (x) + (assert (integerp x)) + (short.new x)) + +(defun unbox-short (x &optional delete-local) + (prog1 + (short.shortvalue (get-ref x)) + (when delete-local (delete-local-ref x)))) + + +;;;;;;;;;;;;;;;;;;;;;;;; proxy support ;;;;;;;;;;;;;;;;;;;;;;;;;;; + +(defun proxy-hashcode (proxy) + ;use the hashcode of the proxy's class, + ;because hashcode() on the proxy flows through to the invocation handler + ;is this rem guaranteed to be a fixnum? + (rem (object.hashcode (object.getclass proxy)) most-positive-fixnum)) + +(defvar *proxy-table* (make-hash-table :test #'jeq :hash-function #'proxy-hashcode)) + +;(defvar *proxy-list* nil) + +(defun store-proxy (proxy method-fn-alist) + ;(push (cons proxy method-fn-alist) *proxy-list*) + (setf (gethash proxy *proxy-table*) method-fn-alist)) + +(defun recall-proxy (proxy) + ;(cdr (assoc proxy *proxy-list* :test #'jeq)) + (gethash proxy *proxy-table*)) + +(defun unregister-proxy (proxy) +"Stops handling for the proxy and removes references from the Lisp side. +Make sure it is no longer referenced from Java first!" + (remhash proxy *proxy-table*)) + +(defun invocation-handler (proxy method args) + (let* ((method-fn-alist (recall-proxy proxy)) + (fn (and method-fn-alist (second (assoc (object.tostring method) method-fn-alist + :test #'equal))))) + (if fn + (funcall fn args) + (progn + ;(throw-new (find-java-class "java.lang.UnsupportedOperationException") + ; "No function registered in Lisp proxy object") + nil)))) + +(defun enable-java-proxies () + "must be called before any call to new-proxy, and requires jfli.jar be in the classpath" + (jni:register-invocation-handler #'invocation-handler)) + +(defun make-proxy-instance (&rest interface-defs) + (let* ((interfaces (mapcar #'first interface-defs)) + (method-fn-alist (mapcan #'second interface-defs)) + (len (length interfaces)) + (iarray (array.newinstance (get-java-class-ref '|java.lang|::|Class|) + len))) + (dotimes (x len) + (setf (jref iarray x) (nth x interfaces))) + (let ((proxy (proxy.newproxyinstance (classloader.getsystemclassloader) + iarray + (lispinvocationhandler.new)))) + (store-proxy proxy method-fn-alist) + proxy))) + +(defun find-java-class-in-macro (name) + (find-java-class + (if (symbolp name) + (symbol-value name) + name))) + +(defmacro new-proxy (&rest interface-defs) +"interface-def -> (interface-name method-defs+) +interface-name -> \"package.qualified.ClassName\" | classname. (must name a Java interface type) +method-def -> (method-name arg-defs* body) +arg-def -> arg-name | (arg-name arg-type) +arg-type -> \"package.qualified.ClassName\" | classname. | :primitive +method-name -> symbol | string (matched case-insensitively) + +Creates, registers and returns a Java object that implements the supplied interfaces" + + (labels ((process-idefs (idefs) + (when idefs + (cons (process-idef (first idefs)) + (process-idefs (rest idefs))))) + (process-idef (idef) + (destructuring-bind (interface-name &rest method-defs) idef + (let* ((methods (class.getmethods (find-java-class-in-macro interface-name))) + (ret `(list (find-java-class ,interface-name) + (list ,@(mapcar (lambda (method-def) + (process-method-def method-def methods)) + method-defs))))) + ;check to make sure every function is defined + (do-jarray (method methods) + (let ((mname (object.tostring method))) + (unless (member mname (rest (third ret)) :key #'second :test #'equal) + (warn (format nil "proxy doesn't define:~%~A" mname))))) + ret))) + (process-method-def (method-def methods) + (destructuring-bind (method-name (&rest arg-defs) &body body) method-def + (let ((method (matching-method method-name arg-defs methods)) + (gargs (gensym))) + `(list ,(object.tostring method) + (lambda (,gargs) + (,(get-boxer-fn-sym (class.getname (method.getreturntype method))) + (let ,(arg-lets arg-defs + (jarray-to-list (method.getparametertypes method)) + gargs + 0) + ,@body))))))) + (arg-lets (arg-defs params gargs idx) + (when arg-defs + (let ((arg (first arg-defs)) + (param (first params))) + (cons `(,(if (atom arg) arg (first arg)) + (,(get-unboxer-fn-sym (class.getname param)) + (jref ,gargs ,idx) t)) + (arg-lets (rest arg-defs) (rest params) gargs (1+ idx)))))) + (matching-method (method-name arg-defs methods) + (let (match) + (do-jarray (method methods) + (when (method-matches method-name arg-defs method) + (if match + (error (format nil "more than one method matches ~A" method-name)) + (setf match method)))) + (or match (error (format nil "no method matches ~A" method-name))))) + (method-matches (method-name arg-defs method) + (when (string-equal method-name (method.getname method)) + (let ((params (method.getparametertypes method))) + (when (= (length arg-defs) (jlength params)) + (is-congruent arg-defs params))))) + (is-congruent (arg-defs params) + (every (lambda (arg param) + (or (atom arg) ;no type spec matches anything + (jeq (find-java-class-in-macro (second arg)) param))) + arg-defs (jarray-to-list params)))) + `(make-proxy-instance ,@(process-idefs interface-defs)))) Index: /branches/new-random/examples/jfli/jfli.lisp =================================================================== --- /branches/new-random/examples/jfli/jfli.lisp (revision 13309) +++ /branches/new-random/examples/jfli/jfli.lisp (revision 13309) @@ -0,0 +1,1390 @@ +; Copyright (c) Rich Hickey. All rights reserved. +; The use and distribution terms for this software are covered by the +; Common Public License 1.0 (http://opensource.org/licenses/cpl.php) +; which can be found in the file CPL.TXT at the root of this distribution. +; By using this software in any fashion, you are agreeing to be bound by +; the terms of this license. +; You must not remove this notice, or any other, from this software. + +#| + +jfli is a library that provides access to Java from Lisp +It depends on the jni package (included) +Callbacks from Java to Lisp also require jfli.jar (included) + +|# + +(defpackage :jfli + (:use :common-lisp :jni) + (:export + + ;jvm creation + :*jni-lib-path* ;exposed from jni + :create-jvm ;exposed from jni, you must call this prior to calling any other jfli function + :enable-java-proxies + + ;wrapper generation + :def-java-class + :get-jar-classnames + :dump-wrapper-defs-to-file + + ;object creation etc + :find-java-class + :new + :make-new + :make-typed-ref + :jeq + + ;array support + :make-new-array + :jlength + :jref + :jref-boolean + :jref-byte + :jref-char + :jref-double + :jref-float + :jref-int + :jref-short + :jref-long + + ;proxy support + :new-proxy + :unregister-proxy + + ;conversions + :box-boolean + :box-byte + :box-char + :box-double + :box-float + :box-integer + :box-long + :box-short + :box-string + :unbox-boolean + :unbox-byte + :unbox-char + :unbox-double + :unbox-float + :unbox-integer + :unbox-long + :unbox-short + :unbox-string + +; :ensure-package +; :member-symbol +; :class-symbol +; :constructor-symbol + )) + +(in-package :jfli) + +#| +bootstrap the implementation of reflection wrappers with +a few (primitive, less safe and maybe faster) jni wrappers +|# + +(eval-when (:compile-toplevel :load-toplevel :execute) + (def-jni-functions "java.lang.Object" + ("getClass" () "Class") + ("hashCode" () "int") + ("toString" () "String") + ("equals" ((obj "Object")) "boolean")) + + (def-jni-functions "java.lang.Class" + ;should be :overloaded t, but we only use this version + ("forName" ((className "String")) "Class" :static t) + ("getConstructors" () "java.lang.reflect.Constructor<>") + ("getFields" () "java.lang.reflect.Field<>") + ("getMethods" () "java.lang.reflect.Method<>") + + ("getConstructor" ((parameter-types "Class<>")) "java.lang.reflect.Constructor") + ("getField" ((name "String")) + "java.lang.reflect.Field") + ("getMethod" ((name "String") (parameter-types "Class<>")) + "java.lang.reflect.Method") + + ("getSuperclass" () "Class") + ("getInterfaces" () "Class<>") + + ("getName" () "String") + ("isArray" () "boolean") + ("isPrimitive" () "boolean")) + + (def-jni-functions "java.lang.reflect.Field" + ("getName" () "java.lang.String") + ("getType" () "java.lang.Class") + ("getModifiers" () "int") + + ("get" ((obj "java.lang.Object")) "java.lang.Object" :raw-return t) + ("getBoolean" ((obj "java.lang.Object")) "boolean") + ("getByte" ((obj "java.lang.Object")) "byte") + ("getChar" ((obj "java.lang.Object")) "char") + ("getDouble" ((obj "java.lang.Object")) "double") + ("getFloat" ((obj "java.lang.Object")) "float") + ("getInt" ((obj "java.lang.Object")) "int") + ("getLong" ((obj "java.lang.Object")) "long") + ("getShort" ((obj "java.lang.Object")) "short") + + ("set" ((obj "java.lang.Object") (value "java.lang.Object")) "void") + ("setBoolean" ((obj "java.lang.Object") (b "boolean")) "void") + ("setByte" ((obj "java.lang.Object") (b "byte")) "void") + ("setChar" ((obj "java.lang.Object") (c "char")) "void") + ("setDouble" ((obj "java.lang.Object") (d "double")) "void") + ("setFloat" ((obj "java.lang.Object") (f "float")) "void") + ("setInt" ((obj "java.lang.Object") ( i "int")) "void") + ("setLong" ((obj "java.lang.Object") (l "long")) "void") + ("setShort" ((obj "java.lang.Object") (s "short")) "void")) + + (def-jni-functions "java.lang.reflect.Constructor" + ("getParameterTypes" () "java.lang.Class<>") + ("newInstance" ((initargs "java.lang.Object<>")) "java.lang.Object")) + + (def-jni-functions "java.lang.reflect.Method" + ("getName" () "java.lang.String") + ("getParameterTypes" () "java.lang.Class<>") + ("getReturnType" () "java.lang.Class") + ("getModifiers" () "int") + ("invoke" ((object "java.lang.Object") + (args "java.lang.Object<>")) "java.lang.Object" + :raw-return t)) + + (def-jni-functions "java.lang.reflect.Array" + ("get" ((array "java.lang.Object") (index "int")) "java.lang.Object" :static t) + ("getBoolean" + ((array "java.lang.Object") (index "int")) "boolean" :static t) + ("getByte" + ((array "java.lang.Object") (index "int")) "byte" :static t) + ("getChar" + ((array "java.lang.Object") (index "int")) "char" :static t) + ("getDouble" + ((array "java.lang.Object") (index "int")) "double" :static t) + ("getFloat" + ((array "java.lang.Object") (index "int")) "float" :static t) + ("getInt" + ((array "java.lang.Object") (index "int")) "int" :static t) + ("getShort" + ((array "java.lang.Object") (index "int")) "short" :static t) + ("getLong" + ((array "java.lang.Object") (index "int")) "long" :static t) + ("getLength" ((array "java.lang.Object")) "int" :static t) + ("newInstance" ((componentType "java.lang.Class") + (length "int")) "java.lang.Object" :static t :overloaded t) + ("newInstance" ((componentType "java.lang.Class") + (dimensions "int<>")) "java.lang.Object" :static t :overloaded t) + ("set" ((array "java.lang.Object") (index "int") (value "java.lang.Object")) + "void" :static t)) + + + (def-jni-function "java.lang.reflect.Modifier" + "isStatic" ((mod "int")) "boolean" :static t) + + (def-jni-constructor "java.lang.Boolean" ((value "boolean"))) + (def-jni-constructor "java.lang.Byte" ((value "byte"))) + (def-jni-constructor "java.lang.Character" ((value "char"))) + (def-jni-constructor "java.lang.Double" ((value "double"))) + (def-jni-constructor "java.lang.Float" ((value "float"))) + (def-jni-constructor "java.lang.Integer" ((value "int"))) + (def-jni-constructor "java.lang.Short" ((value "short"))) + + (def-jni-function "java.lang.Boolean" "booleanValue" () "boolean") + (def-jni-function "java.lang.Byte" "byteValue" () "byte") + (def-jni-function "java.lang.Character" "charValue" () "char") + (def-jni-function "java.lang.Double" "doubleValue" () "double") + (def-jni-function "java.lang.Float" "floatValue" () "float") + (def-jni-function "java.lang.Integer" "intValue" () "int") + (def-jni-function "java.lang.Short" "shortValue" () "short") + + (def-jni-constructor "java.util.jar.JarFile" ((filename "java.lang.String"))) + (def-jni-function "java.util.jar.JarFile" + "entries" () "java.util.Enumeration") + (def-jni-functions "java.util.Enumeration" + ("hasMoreElements" () "boolean") + ("nextElement" () "java.lang.Object")) + (def-jni-functions "java.util.zip.ZipEntry" + ("isDirectory" () "boolean") + ("getName" () "java.lang.String")) + + + (def-jni-functions "java.lang.Long" + ("valueOf" ((s "String")) "java.lang.Long" :static t) + ("intValue" () "int")) + + (def-jni-field "java.lang.Boolean" "TYPE" "Class" :static t) + (def-jni-field "java.lang.Byte" "TYPE" "Class" :static t) + (def-jni-field "java.lang.Character" "TYPE" "Class" :static t) + (def-jni-field "java.lang.Float" "TYPE" "Class" :static t) + (def-jni-field "java.lang.Integer" "TYPE" "Class" :static t) + (def-jni-field "java.lang.Double" "TYPE" "Class" :static t) + (def-jni-field "java.lang.Short" "TYPE" "Class" :static t) + (def-jni-field "java.lang.Long" "TYPE" "Class" :static t) + + (def-jni-constructor "com.richhickey.jfli.LispInvocationHandler" ()) + (def-jni-function "java.lang.reflect.Proxy" + "newProxyInstance" ((loader "java.lang.ClassLoader") + (interfaces "java.lang.Class<>") + (h "InvocationHandler")) "java.lang.Object" :static t) + + (def-jni-function "java.lang.ClassLoader" + "getSystemClassLoader" () "ClassLoader" :static t) + + ) ;eval-when + +;;;;;;;;;;;;;;;;;;;;;;;;;;; utilities ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; + +(eval-when (:compile-toplevel :load-toplevel :execute) + (defun ensure-package (name) + "find the package or create it if it doesn't exist" + (or (find-package name) + (make-package name :use '()))) + (intern "Object" (ensure-package "java.lang")) + (intern "String" (ensure-package "java.lang"))) + +(defmacro do-jarray ((x array) &body body) + "jni-based, so not safe and not exported, but used by the implementation" + (let ((gcount (gensym)) + (gi (gensym)) + (garray (gensym))) + `(let* ((,garray ,array) + (,gcount (jni:get-array-length ,garray))) + (dotimes (,gi ,gcount) + (let ((,x (jaref ,garray ,gi))) + ,@body))))) + + +(defmacro doenum ((e enum) &body body) + "jni-based, so not safe and not exported, but used by the implementation" + (let ((genum (gensym))) + `(let ((,genum ,enum)) + (do () + ((not (enumeration.hasmoreelements ,genum))) + (let ((,e (enumeration.nextelement ,genum))) + ,@body))))) + +;probably insufficiently general, works as used here +(defmacro get-or-init (place init-form) + `(or ,place + (setf ,place ,init-form))) + +;from c.l.l. +(defmacro case-equal (exp &body clauses) + (let ((temp (gensym))) + `(let ((,temp ,exp)) + (cond ,@(mapcar #'(lambda (clause) + (destructuring-bind (keys . clause-forms) clause + (cond ((eq keys 'otherwise) + `(t ,@clause-forms)) + (t + (if (atom keys) (setq keys (list keys))) + `((member ,temp ',keys :test #'equal) + ,@clause-forms))))) + clauses))))) + +;create object. to bootstrap the hierarchy +(defclass |java.lang|::object. () + ((ref :reader ref :initarg :ref) + (lisp-allocated :reader lisp-allocated-p :initarg :lisp-allocated :initform nil)) + (:documentation "the superclass of all Java typed reference classes")) + +(defun get-ref (x) + "any function taking an object can be passed a raw java-ref ptr or a typed reference instance. +Will also convert strings for use as objects" + (etypecase x + (java-ref x) + (|java.lang|::object. (ref x)) + (string (convert-to-java-string x)) + (null nil))) + +(defun jeq (obj1 obj2) + "are these 2 java objects the same object? Note that is not the same as Object.equals()" + (is-same-object (get-ref obj1) (get-ref obj2))) + + +;;;;;;;;;;;;;;;;;;;;;;;; names and symbols ;;;;;;;;;;;;;;;;;;;;;;; +#| +The library does a lot with names and symbols, needing at various times to: + - find stuff in Java - full names w/case required + - create hopefully non-conflicting packages and member names + +When you (def-java-class "java.lang.String") you get a bunch of symbols/names: +a package named '|java.lang| +a class-symbol '|java.lang|:STRING. (note the dot and case), + which can usually be used where a typename is required + it also serves as the name of the Lisp typed reference class for string + its symbol-value is the canonic-class-symbol (see below) +a canonic-class-symbol '|java.lang|::|String| + can be used to reconstitute the full class name + +I've started trying to flesh out the notion of a Java class designator, which can either be +the full class name as a string, the class-symbol, or one of :boolean, :int etc +|# + +(defun canonic-class-symbol (full-class-name) + "(\"java.lang.Object\") -> '|java.lang|:|Object|" + (multiple-value-bind (package class) (split-package-and-class full-class-name) + (intern class (ensure-package package)))) + +(defun class-symbol (full-class-name) + "(\"java.lang.Object\") -> '|java.lang|:object." + (multiple-value-bind (package class) (split-package-and-class full-class-name) + (intern (string-upcase (jni::string-append class ".")) (ensure-package package)))) + +(defun java-class-name (class-sym) + "inverse of class-symbol, only valid on class-syms created by def-java-class" + (let ((canonic-class-symbol (symbol-value class-sym))) + (jni::string-append (package-name (symbol-package canonic-class-symbol)) + "." + canonic-class-symbol))) + +(defun member-symbol (full-class-name member-name) + "members are defined case-insensitively in case-sensitive packages, +prefixed by 'classname.' - + (member-symbol \"java.lang.Object\" \"toString\") -> '|java.lang|::OBJECT.TOSTRING" + (multiple-value-bind (package class) (split-package-and-class full-class-name) + (intern (string-upcase (jni::string-append class "." member-name)) (ensure-package package)))) + +(defun constructor-symbol (full-class-name) + (member-symbol full-class-name "new")) + +(defun get-java-class-ref (canonic-class-symbol) + "class-ref is cached on the plist of the canonic class symbol" + (get-or-init (get canonic-class-symbol :class-ref) + (let ((class-name (jni::string-append (package-name + (symbol-package canonic-class-symbol)) + "." + canonic-class-symbol))) + (try-null (jni-find-class (nsubstitute #\/ #\. class-name)))))) + +(defun find-java-class (class-sym-or-string) + "Given a Java class designator, returns the Java Class object." + (ctypecase class-sym-or-string + (symbol (case class-sym-or-string + (:int integer.type) + (:char character.type) + (:long long.type) + (:float float.type) + (:boolean boolean.type) + (:short short.type) + (:double double.type) + (:byte byte.type) + (otherwise (get-java-class-ref class-sym-or-string)))) + (string (get-java-class-ref (canonic-class-symbol class-sym-or-string))))) + +;;;;;;;;;;;;;;;;;;;;;; typed reference support ;;;;;;;;;;;;;;;;;;;;;;;; +#| +The library maintains a hierarchy of typed reference classes that parallel the +class hierarchy on the Java side +new returns a typed reference, but other functions that return objects +return raw references (for efficiency) +make-typed-ref can create fully-typed wrappers when desired +|# + +(defun get-superclass-names (full-class-name) + (let* ((class (get-java-class-ref (canonic-class-symbol full-class-name))) + (super (class.getsuperclass class)) + (interfaces (class.getinterfaces class)) + (supers ())) + (do-jarray (i interfaces) + (push i supers)) + ;hmmm - where should the base class go in the precedence list? + ;is it more important than the interfaces? this says no + (if super + (push super supers) + (push (find-java-class "java.lang.Object") supers)) + (setf supers (nreverse supers)) + ;now we need to fix up order so more derived classes are first + ;but don't have a total ordering, so merge one at a time + (let (result) + (dolist (s supers) + (setf result (merge 'list result (list s) + (lambda (x y) + (is-assignable-from x y))))) + (mapcar #'class.getname result)))) +#|| +(defun get-superclass-names (full-class-name) + (let* ((class (get-java-class-ref (canonic-class-symbol full-class-name))) + (super (class.getsuperclass class)) + (interfaces (class.getinterfaces class)) + (supers ())) + (do-jarray (i interfaces) + (push (class.getname i) supers)) + ;hmmm - where should the base class go in the precedence list? + ;is it more important than the interfaces? this says no + (if super + (push (class.getname super) supers) + (push "java.lang.Object" supers)) + (nreverse supers))) +||# + +(defun ensure-java-class (full-class-name) + "walks the superclass hierarchy and makes sure all the classes are fully defined + (they may be undefined or just forward-referenced-class) +caches this has been done on the class-symbol's plist" + (let* ((class-sym (class-symbol full-class-name)) + (class (find-class class-sym nil))) + (if (or (eql class-sym '|java.lang|::object.) + (get class-sym :ensured)) + class + (let ((supers (get-superclass-names full-class-name))) + (dolist (super supers) + (ensure-java-class super)) + (unless (and class (subtypep class 'standard-object)) + (setf class + (ccl:ensure-class class-sym :direct-superclasses (mapcar #'class-symbol supers)))) + (setf (get class-sym :ensured) t) + class)))) + +(defun ensure-java-hierarchy (class-sym) + "Works off class-sym for efficient use in new +This will only work on class-syms created by def-java-class, +as it depends upon symbol-value being the canonic class symbol" + (unless (get class-sym :ensured) + (ensure-java-class (java-class-name class-sym)))) + +(defun make-typed-ref (java-ref) + "Given a raw java-ref, determines the full type of the object +and returns an instance of a typed reference wrapper" + (when java-ref + (let ((class (object.getclass (get-ref java-ref)))) + (if (class.isarray class) + (error "typed refs not supported for arrays (yet)") + (make-instance (ensure-java-class (class.getname class)) :ref (get-ref java-ref) ))))) + + +;;;;;;;;;;;;;;;;;;;;;;;;; Wrapper Generation ;;;;;;;;;;;;;;;;;;;;;;;;;;; +#| +In an effort to reduce the volume of stuff generated when wrapping entire libraries, +the wrappers just generate minimal stubs, which, if and when invoked at runtime, +complete the work of building thunking closures, so very little code is generated for +things never called (Java libraries have huge numbers of symbols). +Not sure if this approach matters, but that's how it works +|# + +(defmacro def-java-class (full-class-name) + "Given the package-qualified, case-correct name of a java class, will generate +wrapper functions for its constructors, fields and methods." + (multiple-value-bind (package class) (split-package-and-class full-class-name) + (declare (ignore class)) + (let* ((class-sym (class-symbol full-class-name)) + (defs + (list* + `(ensure-package ,package) + ;build a path from the simple class symbol to the canonic + `(defconstant ,class-sym ',(canonic-class-symbol full-class-name)) + `(export ',class-sym (symbol-package ',class-sym)) + `(def-java-constructors ,full-class-name) + `(def-java-methods ,full-class-name) + `(def-java-fields ,full-class-name) + (unless (string= full-class-name "java.lang.Object") + (let ((supers (mapcar #'class-symbol (get-superclass-names full-class-name)))) + (append (mapcar (lambda (p) + `(ensure-package ,(package-name p))) + (remove (symbol-package class-sym) + (remove-duplicates (mapcar #'symbol-package supers)))) + (list `(defclass ,(class-symbol full-class-name) + ,supers ())))))))) + `(locally ,@defs)))) + +(defun get-jar-classnames (jar-file-name &rest packages) + "returns a list of strings, packages should be of the form \"java/lang\" + for recursive lookup and \"java/util/\" for non-recursive" + (let* ((jar (jarfile.new jar-file-name)) + (entries (jarfile.entries jar)) + (names ())) + (doenum (e entries) + (unless (zipentry.isdirectory e) + (let ((ename (zipentry.getname e))) + (flet ((matches (package) + (and (eql 0 (search package ename)) + (or (not (eql #\/ (schar package (1- (length package))))) ;recursive + (not (find #\/ ename :start (length package))))))) ;non-subdirectory + (when (and (eql (search ".class" ename) + (- (length ename) 6)) ;classname + ;don't grab anonymous inner classes + (not (and (find #\$ ename) + (digit-char-p (schar ename (1+ (position #\$ ename)))))) + (some #'matches packages)) + (push (nsubstitute #\. #\/ (subseq ename 0 (- (length ename) 6))) + names)))))) + names)) + +(defun dump-wrapper-defs-to-file (filename classnames) + "given a list of classnames (say from get-jar-classnames), writes +calls to def-java-class to a file" + (with-open-file (s filename :direction :output :if-exists :supersede) + (dolist (name (sort classnames #'string-lessp)) + (format s "(def-java-class ~S)~%" name)))) + +;;;;;;;;;;;;;;;;;;;;;;;;; constructors and new ;;;;;;;;;;;;;;;;;;;;;;;;;; +#| + +Every non-interface class with a public ctor will get; + a constructor, classname.new + a method defined on make-new, ultimately calling classname.new, + specialized on (the value of) it's class-symbol (e.g. canonic sym) + +Note that if the ctor is overloaded, there is just one function (taking a rest arg), +which handles overload resolution + +The new macro expands into a call to make-new +|# + +(defgeneric make-new (class-sym &rest args) + (:documentation "Allows for definition of before/after methods on ctors. +The new macro expands into call to this")) + +(defun build-ctor-doc-string (name ctors) + (with-output-to-string (s) + (dolist (c ctors) + (format s "~A(~{~#[~;~A~:;~A,~]~})~%" + name + (mapcar #'class-name-for-doc (jarray-to-list (constructor.getparametertypes c))))))) + +(defmacro def-java-constructors (full-class-name) +"creates and exports a ctor func classname.new, defines a method of +make-new specialized on the class-symbol" + (let ((ctor-list (get-ctor-list full-class-name))) + (when ctor-list + (let ((ctor-sym (constructor-symbol full-class-name)) + (class-sym (class-symbol full-class-name))) + `(locally + (defun ,ctor-sym (&rest args) + ,(build-ctor-doc-string full-class-name ctor-list) + (apply #'install-constructors-and-call ,full-class-name args)) + (export ',ctor-sym (symbol-package ',ctor-sym)) + (defmethod make-new ((class-sym (eql ,class-sym)) &rest args) + (apply (function ,ctor-sym) args))))))) + +(defun get-ctor-list (full-class-name) + (let* ((class-sym (canonic-class-symbol full-class-name)) + (class (get-java-class-ref class-sym)) + (ctor-array (class.getconstructors class)) + (ctor-list (jarray-to-list ctor-array))) + ctor-list)) + +(defun install-constructors-and-call (full-class-name &rest args) + "initially the constructor symbol for a class is bound to this function, +when first called it will replace itself with the appropriate direct thunk, +then call the requested ctor - subsequent calls will be direct" + (install-constructors full-class-name) + (apply (constructor-symbol full-class-name) args)) + +(defun install-constructors (full-class-name) + (let* ((ctor-list (get-ctor-list full-class-name))) + (when ctor-list + (setf (fdefinition (constructor-symbol full-class-name)) + (make-ctor-thunk ctor-list (class-symbol full-class-name)))))) + +(defun make-ctor-thunk (ctors class-sym) + (if (rest ctors) ;overloaded + (make-overloaded-ctor-thunk ctors class-sym) + (make-non-overloaded-ctor-thunk (first ctors) class-sym))) + +(defun make-non-overloaded-ctor-thunk (ctor class-sym) + (let ((arg-boxers (get-arg-boxers (constructor.getparametertypes ctor)))) + (lambda (&rest args) + (let ((arg-array (build-arg-array args arg-boxers))) + (ensure-java-hierarchy class-sym) + (prog1 + (make-instance class-sym + :ref (constructor.newinstance ctor arg-array) + :lisp-allocated t) + ;(constructor.newinstance ctor arg-array) + (when arg-array + (delete-local-ref arg-array))))))) + +(defun make-overloaded-ctor-thunk (ctors class-sym) + (let ((thunks (make-ctor-thunks-by-args-length ctors class-sym))) + (lambda (&rest args) + (let ((fn (cdr (assoc (length args) thunks)))) + (if fn + (apply fn + args) + (error "invalid arity")))))) + +(defun make-ctor-thunks-by-args-length (ctors class-sym) + "returns an alist of thunks keyed by number of args" + (let ((ctors-by-args-length (make-hash-table)) + (thunks-by-args-length nil)) + (dolist (ctor ctors) + (let ((params-len (get-array-length (constructor.getparametertypes ctor)))) + (push ctor (gethash params-len ctors-by-args-length)))) + (maphash #'(lambda (args-len ctors) + (push (cons args-len + (if (rest ctors);truly overloaded + (make-type-overloaded-ctor-thunk ctors class-sym) + ;only one ctor with this number of args + (make-non-overloaded-ctor-thunk (first ctors) class-sym))) + thunks-by-args-length)) + ctors-by-args-length) + thunks-by-args-length)) + +(defun make-type-overloaded-ctor-thunk (ctors class-sym) + "these methods have the same number of args and must be distinguished by type" + (let ((thunks (mapcar #'(lambda (ctor) + (list (make-non-overloaded-ctor-thunk ctor class-sym) + (jarray-to-list (constructor.getparametertypes ctor)))) + ctors))) + (lambda (&rest args) + (block fn + (let ((arg-types (get-types-of-args args))) + (dolist (thunk-info thunks) + (destructuring-bind (thunk param-types) thunk-info + (when (is-congruent-type-list param-types arg-types) + (return-from fn (apply thunk args))))) + (error "No matching constructor")))))) + +(defmacro new (class-spec &rest args) +"new class-spec args +class-spec -> class-name | (class-name this-name) +class-name -> \"package.qualified.ClassName\" | classname. +args -> [actual-arg]* [init-arg-spec]* +init-arg-spec -> init-arg | (init-arg) +init-arg -> :settable-field-or-method [params]* value ;note keyword + | + .method-name [args]* ;note dot + +Creates a new instance of class-name, using make-new generic function, +then initializes it by setting fields or accessors and/or calling member functions +If this-name is supplied it will be bound to the newly-allocated object and available +to the init-args" + (labels ((mem-sym? (x) + (or (keywordp x) + (and (symbolp x) (eql 0 (position #\. (symbol-name x)))))) + (mem-form? (x) + (and (listp x) (mem-sym? (first x)))) + (mem-init? (x) + (or (mem-sym? x) (mem-form? x))) + (init-forms (x) + (if x + (if (mem-form? (first x)) + (cons (first x) (init-forms (rest x))) + (let ((more (member-if #'mem-init? (rest x)))) + (cons (ldiff x more) (init-forms more))))))) + (let* ((inits (member-if #'mem-init? args)) + (real-args (ldiff args inits)) + (class-atom (if (atom class-spec) + class-spec + (first class-spec))) + (class-sym (if (symbolp class-atom) + ;(find-symbol (jni::string-append (symbol-name class-atom) ".")) + class-atom + (multiple-value-bind (package class) (jni::split-package-and-class class-atom) + (find-symbol (jni::string-append (string-upcase class) ".") package)))) + (class-name (subseq (symbol-name class-sym) 0 (1- (length (symbol-name class-sym))))) + (gthis (gensym))) + (flet ((expand-init (x) + (if (keywordp (first x)) ;setf field or property + `(setf (,(find-symbol (jni::string-append class-name "." (symbol-name (first x)))) + ,gthis ,@(butlast (rest x))) + ,@(last (rest x))) + ;.memfunc + `(,(find-symbol (jni::string-append class-name (symbol-name (first x)))) + ,gthis + ,@(rest x))))) + `(let* ((,gthis (make-new ,class-sym ,@real-args)) + ,@(when (listp class-spec) + `((,(second class-spec) ,gthis)))) + ,@(mapcar #'expand-init (init-forms inits)) + ,gthis))))) + +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; Fields ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; + +#| +all public fields will get a getter function classname.fieldname and a setter - (setf classname.fieldname) +instance fields take an first arg which is the instance +static fields also get a symbol-macro *classname.fieldname* +|# + +(defmacro def-java-fields (full-class-name) +"fields will get a getter function classname.fieldname and a setter - (setf classname.fieldname) +instance fields take an first arg which is the instance +static fields also get a symbol-macro *classname.fieldname*" + (let* ((class-sym (canonic-class-symbol full-class-name)) + (class (get-java-class-ref class-sym)) + (fields (jarray-to-list (class.getfields class))) + (defs nil)) + (dolist (field fields) + (let* ((field-name (field.getname field)) + (field-sym (member-symbol full-class-name field-name)) + (is-static (modifier.isstatic (field.getmodifiers field)))) + (if is-static + (let ((macsym (intern (jni::string-append "*" (symbol-name field-sym) "*") + (symbol-package field-sym)))) + (push `(defun ,field-sym () + (install-static-field-and-get ,full-class-name ,field-name)) + defs) + (push `(defun (setf ,field-sym) (val) + (install-static-field-and-set ,full-class-name ,field-name val)) + defs) + (push `(export ',field-sym (symbol-package ',field-sym)) defs) + (push `(define-symbol-macro ,macsym (,field-sym)) defs) + (push `(export ',macsym (symbol-package ',macsym)) defs)) + (progn + (push `(defun ,field-sym (obj) + (install-field-and-get ,full-class-name ,field-name obj)) + defs) + (push `(defun (setf ,field-sym) (val obj) + (install-field-and-set ,full-class-name ,field-name val obj)) + defs) + (push `(export ',field-sym (symbol-package ',field-sym)) defs))))) + `(locally ,@(nreverse defs)))) + +(defun install-field-and-get (full-class-name field-name obj) + (install-field full-class-name field-name) + (funcall (member-symbol full-class-name field-name) obj)) + +(defun install-field-and-set (full-class-name field-name val obj) + (install-field full-class-name field-name) + (funcall (fdefinition `(setf ,(member-symbol full-class-name field-name))) val obj)) + +(defun install-static-field-and-get (full-class-name field-name) + (install-field full-class-name field-name) + (funcall (member-symbol full-class-name field-name))) + +(defun install-static-field-and-set (full-class-name field-name val) + (install-field full-class-name field-name) + (funcall (fdefinition `(setf ,(member-symbol full-class-name field-name))) val)) + +(defun install-field (full-class-name field-name) + (let* ((class-sym (canonic-class-symbol full-class-name)) + (class (get-java-class-ref class-sym)) + (field (class.getfield class field-name)) + (field-sym (member-symbol full-class-name field-name)) + (is-static (modifier.isstatic (field.getmodifiers field))) + (field-type-name (class.getname (field.gettype field))) + (boxer (get-boxer-fn field-type-name)) + (unboxer (get-unboxer-fn field-type-name))) + (if is-static + (progn + (setf (fdefinition field-sym) + (lambda () + (funcall unboxer (field.get field nil) t))) + (setf (fdefinition `(setf ,field-sym)) + (lambda (arg) + (field.set field nil + (get-ref (if (and boxer (not (boxed? arg))) + (funcall boxer arg) + arg))) + arg))) + (progn + (setf (fdefinition field-sym) + (lambda (obj) + (funcall unboxer (field.get field (get-ref obj)) t))) + (setf (fdefinition `(setf ,field-sym)) + (lambda (arg obj) + (field.set field (get-ref obj) + (get-ref (if (and boxer (not (boxed? arg))) + (funcall boxer arg) + arg))) + arg)))))) + +;;;;;;;;;;;;;;;;;;;;;;;;;;;;; methods ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; +#| +defines wrappers for all public methods of the class +As with ctors, if a method is overloaded a single wrapper is created that handles +overload resolution. +The wrappers have the name classname.methodname +If a method follows the JavaBeans property protocol (i.e. it is called getSomething or isSomething +and there is a corresponding setSomething, then a (setf classname.methodname) will be defined +that calls the latter +|# + +(defun class-name-for-doc (class) + (let ((name (class.getname class))) + (if (class.isarray class) + (decode-array-name name) + name))) + +(defun build-method-doc-string (name methods) + (with-output-to-string (s) + (dolist (m methods) + (format s "~A~A ~A(~{~#[~;~A~:;~A,~]~})~%" + (if (modifier.isstatic (method.getmodifiers m)) + "static " + "") + (class.getname (method.getreturntype m)) + name + (mapcar #'class-name-for-doc (jarray-to-list (method.getparametertypes m))))))) + +(defmacro def-java-methods (full-class-name) + (let ((methods-by-name (get-methods-by-name full-class-name)) + (defs nil)) + (maphash (lambda (name methods) + (let ((method-sym (member-symbol full-class-name name))) + (push `(defun ,method-sym (&rest args) + ,(build-method-doc-string name methods) + (apply #'install-methods-and-call ,full-class-name ,name args)) + defs) + (push `(export ',method-sym (symbol-package ',method-sym)) + defs) + ;build setters when finding beans property protocol + (flet ((add-setter-if (prefix) + (when (eql 0 (search prefix name)) + (let ((setname (jni::string-append "set" (subseq name (length prefix))))) + (when (gethash setname methods-by-name) + (push `(defun (setf ,method-sym) (val &rest args) + (progn + (apply #',(member-symbol full-class-name setname) + (append args (list val))) + val)) + defs)))))) + (add-setter-if "get") + (add-setter-if "is")))) + methods-by-name) + `(locally ,@(nreverse defs)))) + +(defun install-methods-and-call (full-class-name method &rest args) + "initially all the member function symbols for a class are bound to this function, +when first called it will replace them with the appropriate direct thunks, +then call the requested method - subsequent calls via those symbols will be direct" + (install-methods full-class-name) + (apply (member-symbol full-class-name method) args)) + +(defun decode-array-name (tn) + (let ((prim (assoc tn + '(("Z" . "boolean") + ("B" . "byte") + ("C" . "char") + ("S" . "short") + ("I" . "int") + ("J" . "long") + ("F" . "float") + ("D" . "double") + ("V" . "void")) + :test #'string-equal))) + (if prim + (rest prim) + (let ((array-depth (count #\[ tn))) + (if (= 0 array-depth) + (subseq tn 1 (1- (length tn))) ;strip leading L and trailing ; + (with-output-to-string (s) + (write-string (decode-array-name (subseq tn array-depth)) s) + (dotimes (x array-depth) + (write-string "[]" s)))))))) + +(defun jarray-to-list (array) + (let (ret) + (do-jarray (x array) + (push x ret)) + (nreverse ret))) + +(defun get-methods-by-name (full-class-name) + "returns an #'equal hashtable of lists of java.lang.Method refs keyed by name" + (let* ((class-sym (canonic-class-symbol full-class-name)) + (class (get-java-class-ref class-sym)) + (method-array (class.getmethods class)) + (methods-by-name (make-hash-table :test #'equal))) + (do-jarray (method method-array) + (push method (gethash (method.getName method) methods-by-name))) + methods-by-name)) + +(defun install-methods (full-class-name) + (let ((methods-by-name (get-methods-by-name full-class-name))) + (maphash + (lambda (name methods) + (setf (fdefinition (member-symbol full-class-name name)) + (make-method-thunk methods))) + methods-by-name))) + +(defun make-method-thunk (methods) + (if (rest methods) ;overloaded + (make-overloaded-thunk methods) + (make-non-overloaded-thunk (first methods)))) + +(defun make-non-overloaded-thunk (method) + (let ((unboxer-fn (get-unboxer-fn (class.getname (method.getreturntype method)))) + (arg-boxers (get-arg-boxers (method.getparametertypes method))) + (is-static (modifier.isstatic (method.getmodifiers method)))) + (lambda (&rest args) + (let ((arg-array (build-arg-array (if is-static args (rest args)) arg-boxers))) + (prog1 + (funcall unboxer-fn + (method.invoke method + (if is-static nil (get-ref (first args))) + arg-array) t) + (when arg-array + (delete-local-ref arg-array))))))) + +(defun make-overloaded-thunk (methods) + (let ((thunks (make-thunks-by-args-length methods))) + (lambda (&rest args) + (let ((fn (cdr (assoc (length args) thunks)))) + (if fn + (apply fn + args) + (error "invalid arity")))))) + +(defun make-thunks-by-args-length (methods) + "returns an alist of thunks keyed by number of args" + (let ((methods-by-args-length (make-hash-table)) + (thunks-by-args-length nil)) + (dolist (method methods) + (let ((is-static (modifier.isstatic (method.getmodifiers method))) + (params-len (get-array-length (method.getparametertypes method)))) + (push method (gethash (if is-static params-len (1+ params-len)) + methods-by-args-length)))) + (maphash #'(lambda (args-len methods) + (push (cons args-len + (if (rest methods);truly overloaded + (make-type-overloaded-thunk methods) + ;only one method with this number of args + (make-non-overloaded-thunk (first methods)))) + thunks-by-args-length)) + methods-by-args-length) + thunks-by-args-length)) + +(defun make-type-overloaded-thunk (methods) + "these methods have the same number of args and must be distinguished by type" + (let ((thunks (mapcar #'(lambda (method) + (list (make-non-overloaded-thunk method) + (modifier.isstatic (method.getmodifiers method)) + (jarray-to-list (method.getparametertypes method)))) + methods))) + (lambda (&rest args) + (block fn + (let ((arg-types (get-types-of-args args))) + (dolist (thunk-info thunks) + (destructuring-bind (thunk is-static param-types) thunk-info + (when (is-congruent-type-list param-types (if is-static arg-types (rest arg-types))) + (return-from fn (apply thunk args))))) + (error "No matching method")))))) + + +;;;;;;;;;;;;;;;;;;;;;;;;;;;; array support ;;;;;;;;;;;;;;;;;;;;;;;;;;; + +(defun jref (array &rest subscripts) + "like aref, for Java arrays of non-primitive/reference types, settable" + (assert (every #'integerp subscripts)) + (do* + ((sub subscripts (rest sub)) + (a (get-ref array) (get-ref (array.get a (first sub))))) + ((null (rest sub)) + (array.get a (first sub))))) + +(defun (setf jref) (val array &rest subscripts) + (assert (every #'integerp subscripts)) + (do* + ((sub subscripts (rest sub)) + (a (get-ref array) (get-ref (array.get a (first sub))))) + ((null (rest sub)) + (array.set a (first sub) (get-ref val)) + val))) + +(eval-when (:compile-toplevel :load-toplevel :execute) + (defmacro def-refs (&rest types) + `(locally + ,@(mapcan + (lambda (type) + (let ((ref-sym (intern (string-upcase (jni::string-append "jref-" (symbol-name type)))))) + (list + `(defun ,ref-sym (array &rest subscripts) + ,(format nil "like aref, for Java arrays of ~A, settable" (symbol-name type)) + (assert (every #'integerp subscripts)) + (do* + ((sub subscripts (rest sub)) + (a (get-ref array) (get-ref (array.get a (first sub))))) + ((null (rest sub)) + (,(intern (string-upcase (jni::string-append "array.get" (symbol-name type)))) + a (first sub))))) + + `(defun (setf ,ref-sym) (val array &rest subscripts) + (assert (every #'integerp subscripts)) + (do* + ((sub subscripts (rest sub)) + (a (get-ref array) (get-ref (array.get a (first sub))))) + ((null (rest sub)) + (array.set a (first sub) + (,(intern (string-upcase (jni::string-append "box-" + (symbol-name type)))) + val)) + val)))))) + types)))) + +;arrays of primitives have their own accessors +(def-refs boolean byte char double float int short long) + +(defun jlength (array) + "like length, for Java arrays" + (array.getlength (get-ref array))) + +(defgeneric make-new-array (type &rest dimensions) + (:documentation "generic function, with methods for all Java class designators") + (:method (type &rest dims) + (assert (every #'integerp dims)) + (if (rest dims) + (let* ((ndim (length dims)) + (dim-array (new-int-array ndim))) + (dotimes (i ndim) + (array.set dim-array i (box-int (nth i dims)))) + (array.newinstance> type dim-array)) + (array.newinstance type (first dims))))) + +(defmethod make-new-array ((type symbol) &rest dimensions) + (apply #'make-new-array (get-java-class-ref type) dimensions)) + +(defmethod make-new-array ((type string) &rest dimensions) + (apply #'make-new-array (find-java-class type) dimensions)) + +(defmethod make-new-array ((type (eql :char)) &rest dimensions) + (apply #'make-new-array character.type dimensions)) + +(defmethod make-new-array ((type (eql :int)) &rest dimensions) + (apply #'make-new-array integer.type dimensions)) + +(defmethod make-new-array ((type (eql :boolean)) &rest dimensions) + (apply #'make-new-array boolean.type dimensions)) + +(defmethod make-new-array ((type (eql :double)) &rest dimensions) + (apply #'make-new-array double.type dimensions)) + +(defmethod make-new-array ((type (eql :byte)) &rest dimensions) + (apply #'make-new-array byte.type dimensions)) + +(defmethod make-new-array ((type (eql :float)) &rest dimensions) + (apply #'make-new-array float.type dimensions)) + +(defmethod make-new-array ((type (eql :short)) &rest dimensions) + (apply #'make-new-array short.type dimensions)) + +(defmethod make-new-array ((type (eql :long)) &rest dimensions) + (apply #'make-new-array long.type dimensions)) + +;;;;;;;;;;;;;;;;;;;;;;;;;; arg/param helpers ;;;;;;;;;;;;;;;;;;;;;; + +(defun get-arg-boxers (param-types) + "returns a list with one entry per param, either nil or a function that boxes the arg" + (let (ret) + (do-jarray (param-type param-types) + (push (get-boxer-fn (class.getname param-type)) + ret)) + (nreverse ret))) + +(defun build-arg-array (args arg-boxers) + (when args + (let* ((arg-array (new-object-array (length args) + ;duplication of class-symbol logic + ;but must be fast + (get-java-class-ref '|java.lang|::|Object|) + nil))) + (do ((i 0 (incf i)) + (args args (rest args)) + (boxers arg-boxers (rest boxers))) + ((null args)) + (let ((arg (first args)) + (boxer (first boxers))) + (setf (jaref arg-array i) + (get-ref (if (and boxer (not (boxed? arg))) + (funcall boxer arg) + arg))))) + arg-array))) + +(defun get-types-of-args (args) + (let (ret) + (dolist (arg args) + (push (infer-box-type arg) + ret)) + (nreverse ret))) + +(defun is-congruent-type-list (param-types arg-types) + (every #'(lambda (arg-type param-type) + (if arg-type + (is-assignable-from arg-type param-type) + ;nil was passed - must be boolean or non-primitive target type + (or (not (class.isprimitive param-type)) + (is-assignable-from boolean.type param-type)))) + arg-types param-types)) + + +;;;;;;;;;;;;;;;;;;;;;;;; argument conversion and boxing ;;;;;;;;;;;;;;;;;;;;;;;;;; +(defun box-string (s) +"Given a string or symbol, returns reference to a Java string" + (local-ref-to-global-ref (convert-to-java-string s))) + +(defun unbox-string (ref &optional delete-local) + "Given a reference to a Java string, returns a Lisp string" + (declare (ignore delete-local)) + (convert-from-java-string (get-ref ref))) + +(defun get-boxer-fn (class-name) + (case-equal class-name + ("int" #'box-int) + ("boolean" #'box-boolean) + ("double" #'box-double) + ("java.lang.String" #'convert-to-java-string) + ("char" #'box-char) + ("byte" #'box-byte) + ("float" #'box-float) + ("long" #'box-long) + ("short" #'box-short) + (otherwise nil))) + +(defun get-boxer-fn-sym (class-name) + (case-equal class-name + ("int" 'box-int) + ("boolean" 'box-boolean) + ("double" 'box-double) + ("java.lang.String" 'convert-to-java-string) + ("char" 'box-char) + ("byte" 'box-byte) + ("float" 'box-float) + ("long" 'box-long) + ("short" 'box-short) + ("void" 'box-void) + (otherwise 'identity))) + +(defun boxed? (x) + (or (java-ref-p x) + (typep x '|java.lang|::object.))) + +(defun infer-box-type (x) + (cond + ((null x) nil) + ((boxed? x) (object.getclass (get-ref x))) + ((integerp x) integer.type) + ((numberp x) double.type) + ((eq x t) boolean.type) + ((or (stringp x) (symbolp x)) + (get-java-class-ref '|java.lang|::|String|)) + (t (error "can't infer box type")))) + +(defun get-unboxer-fn (class-name) + (case-equal class-name + ("int" #'unbox-int) + ("boolean" #'unbox-boolean) + ("double" #'unbox-double) + ("java.lang.String" #'unbox-string) + ("void" #'unbox-void) + ("char" #'unbox-char) + ("byte" #'unbox-byte) + ("float" #'unbox-float) + ("long" #'unbox-long) + ("short" #'unbox-short) + (otherwise #'unbox-ref))) + +(defun get-unboxer-fn-sym (class-name) + (case-equal class-name + ("int" 'unbox-int) + ("boolean" 'unbox-boolean) + ("double" 'unbox-double) + ("java.lang.String" 'unbox-string) + ("void" 'unbox-void) + ("char" 'unbox-char) + ("byte" 'unbox-byte) + ("float" 'unbox-float) + ("long" 'unbox-long) + ("short" 'unbox-short) + (otherwise 'unbox-ref))) + +(defun unbox-ref (x &optional delete-local) + (declare (ignore delete-local)) + (local-ref-to-global-ref x)) + +(defun unbox-void (x &optional delete-local) + (declare (ignore x delete-local)) + nil) + +(defun box-void (x) + (declare (ignore x)) + nil) + +(defun box-boolean (x) + (boolean.new x)) + +(defun unbox-boolean (obj &optional delete-local) + (prog1 + (boolean.booleanvalue (get-ref obj)) + (when delete-local (delete-local-ref obj)))) + +(defun box-byte (x) + (assert (integerp x)) + (byte.new x)) + +(defun unbox-byte (x &optional delete-local) + (prog1 + (byte.bytevalue (get-ref x)) + (when delete-local (delete-local-ref x)))) + +(defun box-char (x) + (character.new x)) + +(defun unbox-char (x &optional delete-local) + (prog1 + (character.charvalue (get-ref x)) + (when delete-local (delete-local-ref x)))) + +(defun box-double (x) + (assert (floatp x)) + (double.new (coerce x 'double-float))) + +(defun unbox-double (x &optional delete-local) + (prog1 + (double.doublevalue (get-ref x)) + (when delete-local (delete-local-ref x)))) + +(defun box-float (x) + (assert (floatp x)) + (float.new x)) + +(defun unbox-float (x &optional delete-local) + (prog1 + (float.floatvalue (get-ref x)) + (when delete-local (delete-local-ref x)))) + +(defun box-int (x) + (assert (integerp x)) + (integer.new x)) + +(defun unbox-int (x &optional delete-local) + (prog1 + (integer.intvalue (get-ref x)) + (when delete-local (delete-local-ref x)))) + +;can't directly construct Long because LW doesn't support long long fli on 32 bit platforms +(defun box-long (x) + (assert (integerp x)) + (long.valueof (princ-to-string x))) + +;here too, can only get an ints worth - aargh +(defun unbox-long (obj &optional delete-local) + (prog1 + (parse-integer (object.tostring (get-ref obj))) + (when delete-local (delete-local-ref obj)))) + +(defun box-short (x) + (assert (integerp x)) + (short.new x)) + +(defun unbox-short (x &optional delete-local) + (prog1 + (short.shortvalue (get-ref x)) + (when delete-local (delete-local-ref x)))) + + +;;;;;;;;;;;;;;;;;;;;;;;; proxy support ;;;;;;;;;;;;;;;;;;;;;;;;;;; + +(defun proxy-hashcode (proxy) + ;use the hashcode of the proxy's class, + ;because hashcode() on the proxy flows through to the invocation handler + ;is this rem guaranteed to be a fixnum? + (rem (object.hashcode (object.getclass proxy)) most-positive-fixnum)) + +(defvar *proxy-table* (make-hash-table :test 'jeq :hash-function 'proxy-hashcode)) + +;(defvar *proxy-list* nil) + +(defun store-proxy (proxy method-fn-alist) + ;(push (cons proxy method-fn-alist) *proxy-list*) + (setf (gethash proxy *proxy-table*) method-fn-alist)) + +(defun recall-proxy (proxy) + ;(cdr (assoc proxy *proxy-list* :test #'jeq)) + (gethash proxy *proxy-table*)) + +(defun unregister-proxy (proxy) +"Stops handling for the proxy and removes references from the Lisp side. +Make sure it is no longer referenced from Java first!" + (remhash proxy *proxy-table*)) + +(defun invocation-handler (proxy method args) + (let* ((method-fn-alist (recall-proxy proxy)) + (fn (and method-fn-alist (second (assoc (object.tostring method) method-fn-alist + :test #'equal))))) + (if fn + (funcall fn args) + (progn + ;(throw-new (find-java-class "java.lang.UnsupportedOperationException") + ; "No function registered in Lisp proxy object") + nil)))) + +(defun enable-java-proxies () + "must be called before any call to new-proxy, and requires jfli.jar be in the classpath" + (jni:register-invocation-handler #'invocation-handler)) + +(defun make-proxy-instance (&rest interface-defs) + (let* ((interfaces (mapcar #'first interface-defs)) + (method-fn-alist (mapcan #'second interface-defs)) + (len (length interfaces)) + (iarray (array.newinstance (get-java-class-ref '|java.lang|::|Class|) + len))) + (dotimes (x len) + (setf (jref iarray x) (nth x interfaces))) + (let ((proxy (proxy.newproxyinstance (classloader.getsystemclassloader) + iarray + (lispinvocationhandler.new)))) + (store-proxy proxy method-fn-alist) + proxy))) + +(defun find-java-class-in-macro (name) + (find-java-class + (if (symbolp name) + (symbol-value name) + name))) + +(defmacro new-proxy (&rest interface-defs) +"interface-def -> (interface-name method-defs+) +interface-name -> \"package.qualified.ClassName\" | classname. (must name a Java interface type) +method-def -> (method-name arg-defs* body) +arg-def -> arg-name | (arg-name arg-type) +arg-type -> \"package.qualified.ClassName\" | classname. | :primitive +method-name -> symbol | string (matched case-insensitively) + +Creates, registers and returns a Java object that implements the supplied interfaces" + + (labels ((process-idefs (idefs) + (when idefs + (cons (process-idef (first idefs)) + (process-idefs (rest idefs))))) + (process-idef (idef) + (destructuring-bind (interface-name &rest method-defs) idef + (let* ((methods (class.getmethods (find-java-class-in-macro interface-name))) + (ret `(list (find-java-class ,interface-name) + (list ,@(mapcar (lambda (method-def) + (process-method-def method-def methods)) + method-defs))))) + ;check to make sure every function is defined + (do-jarray (method methods) + (let ((mname (object.tostring method))) + (unless (member mname (rest (third ret)) :key #'second :test #'equal) + (warn (format nil "proxy doesn't define:~%~A" mname))))) + ret))) + (process-method-def (method-def methods) + (destructuring-bind (method-name (&rest arg-defs) &body body) method-def + (let ((method (matching-method method-name arg-defs methods)) + (gargs (gensym))) + `(list ,(object.tostring method) + (lambda (,gargs) + (,(get-boxer-fn-sym (class.getname (method.getreturntype method))) + (let ,(arg-lets arg-defs + (jarray-to-list (method.getparametertypes method)) + gargs + 0) + ,@body))))))) + (arg-lets (arg-defs params gargs idx) + (when arg-defs + (let ((arg (first arg-defs)) + (param (first params))) + (cons `(,(if (atom arg) arg (first arg)) + (,(get-unboxer-fn-sym (class.getname param)) + (jref ,gargs ,idx) t)) + (arg-lets (rest arg-defs) (rest params) gargs (1+ idx)))))) + (matching-method (method-name arg-defs methods) + (let (match) + (do-jarray (method methods) + (when (method-matches method-name arg-defs method) + (if match + (error (format nil "more than one method matches ~A" method-name)) + (setf match method)))) + (or match (error (format nil "no method matches ~A" method-name))))) + (method-matches (method-name arg-defs method) + (when (string-equal method-name (method.getname method)) + (let ((params (method.getparametertypes method))) + (when (= (length arg-defs) (jlength params)) + (is-congruent arg-defs params))))) + (is-congruent (arg-defs params) + (every (lambda (arg param) + (or (atom arg) ;no type spec matches anything + (jeq (find-java-class-in-macro (second arg)) param))) + arg-defs (jarray-to-list params)))) + `(make-proxy-instance ,@(process-idefs interface-defs)))) Index: /branches/new-random/examples/jfli/jni-lw.lisp =================================================================== --- /branches/new-random/examples/jfli/jni-lw.lisp (revision 13309) +++ /branches/new-random/examples/jfli/jni-lw.lisp (revision 13309) @@ -0,0 +1,1239 @@ +; Copyright (c) Rich Hickey. All rights reserved. +; The use and distribution terms for this software are covered by the +; Common Public License 1.0 (http://opensource.org/licenses/cpl.php) +; which can be found in the file CPL.TXT at the root of this distribution. +; By using this software in any fashion, you are agreeing to be bound by +; the terms of this license. +; You must not remove this notice, or any other, from this software. + +#| +This is a straight wrapper around the JNI API +Originally I intended to expose this API directly, but it turns out +that JNI is very sensitive to errors, and, given bad args, wrong types etc +causes the JVM (and Lisp) to crash, not very much in the spirit of safe, robust, +interactive development offered by Lisp + +So, now this just forms the substrate under jfli, which uses the Reflection API, and is much +more robust and error tolerant, at some cost in speed I guess. + +Bottom line is you shouldn't be using this API directly unless you are extending jfli, +and then you must take care not to allow bad end-user data to pass through to JNI. + +Caveat emptor. + +I have tried to limit LispWorks FLI code to this file. +|# + +(defpackage :jni + (:export + :*jni-lib-path* + :*pvm* + :*penv* + :register-invocation-handler + :create-jvm + :JNI-VERSION-1-2 + :JNI-VERSION-1-4 + :JNI-OK + :java-ref + :jvoid :jboolean :jbyte :jchar :jshort :jint :jlong :jfloat :jdouble :jsize + :jobject :jclass :jthrowable :jstring :jarray + :jboolean-array :jbyte-array :jchar-array :jshort-array :jint-array :jlong-array + :jfloat-array :jdouble-array :jobject-array + :jfield-id :jmethod-id :jweak + :pvm :penv + :jvalue + :arg-array + :jni-native-method :jni-env + :java-vm :java-vm-option :jdk-1-1-init-args + :jni-get-default-java-vm-init-args :java-vm-inits-args + :jni-create-java-vm :jni-get-created-java-vms + :try :try-null :try-neg + :local-ref-to-global-ref :local-ref-to-string + :def-jni-function :def-jni-functions :def-jni-constructor :def-jni-field + :jaref :convert-to-java-string :convert-from-java-string :java-ref-p + :is-name-of-primitive :split-package-and-class)) + +(in-package :jni) + +(defvar *jni-lib-path* +#+:MACOSX "/System/Library/Frameworks/JavaVM.framework/JavaVM" +#+:WIN32 "C:/j2sdk1.4.2_01/jre/bin/client/jvm.dll" +"Set this to point to your jvm dll prior to calling create-jvm") + +(defparameter *pvm* nil) +(defparameter *penv* nil) + +(defparameter *process-envs* nil) + +(defconstant JNI-VERSION-1-2 #X10002) +(defconstant JNI-VERSION-1-4 #X10004) +(defconstant JNI-OK 0) + +(defun load-jni-lib (&optional (libpath *jni-lib-path*)) + (fli:register-module :jni-lib + :real-name libpath + :connection-style :immediate)) + +(fli:define-c-typedef pvoid (:ptr :void)) +(fli:define-c-typedef const-char-* (:reference-pass :ef-mb-string)) +(fli:define-c-typedef const-jchar-* (:reference-pass :ef-wc-string)) +(fli:define-foreign-pointer (java-ref (:allow-null t) (:predicate java-ref-p)) pvoid) + +(fli:define-c-typedef jvoid :void) +(fli:define-c-typedef jboolean (:boolean (:unsigned :byte))) +(fli:define-c-typedef jbyte :byte) +(fli:define-c-typedef jchar :wchar-t) +(fli:define-c-typedef jshort :short) +(fli:define-c-typedef jint :int) +(fli:define-c-typedef jlong :long-long) +(fli:define-c-typedef jfloat :float) +(fli:define-c-typedef jdouble :double) +(fli:define-c-typedef jsize jint) +(fli:define-c-typedef jobject java-ref) +(fli:define-c-typedef jclass java-ref) +(fli:define-c-typedef jthrowable java-ref) +(fli:define-c-typedef jstring java-ref) +(fli:define-c-typedef jarray java-ref) +(fli:define-c-typedef jboolean-array java-ref) +(fli:define-c-typedef jbyte-array java-ref) +(fli:define-c-typedef jchar-array java-ref) +(fli:define-c-typedef jshort-array java-ref) +(fli:define-c-typedef jint-array java-ref) +(fli:define-c-typedef jlong-array java-ref) +(fli:define-c-typedef jfloat-array java-ref) +(fli:define-c-typedef jdouble-array java-ref) +(fli:define-c-typedef jobject-array java-ref) +(fli:define-c-typedef jfield-id pvoid) +(fli:define-c-typedef jmethod-id pvoid) +(fli:define-c-typedef jweak java-ref) + +(fli:define-c-typedef pvm (:ptr (:ptr java-vm))) +(fli:define-c-typedef penv (:ptr (:ptr jni-env))) +(fli:define-foreign-type pfunc (&rest fargs) + `(:ptr (:function ,@fargs))) + +(fli:define-c-union jvalue + (:z jboolean) + (:b jbyte) + (:c jchar) + (:s jshort) + (:i jint) + (:j jlong) + (:f jfloat) + (:d jdouble) + (:l jobject)) + +(fli:define-c-typedef arg-array (:c-array jvalue)) + +(eval-when (:compile-toplevel) + (defun build-struct-entries (name members) + (mapcar #'(lambda (member) + (if (= 2 (length member)) ;padding or other non-function entry + member + (destructuring-bind (func args ret &key lambda-list) member + (declare (ignore lambda-list)) + `(,func (pfunc ,(cons `(:ptr (:ptr ,name)) + (mapcar #'second args)) + ,ret))))) + members))) + +(eval-when (:compile-toplevel) + (defun build-access-functions (name global members) + (mapcar #'(lambda (member) + (if (= 2 (length member)) ;padding or other non-function entry + () + (destructuring-bind (func args ret &key lambda-list) member + (let ((thunk (intern (concatenate 'string (symbol-name func) "-thunk"))) + (genv (gensym)) + ;(func (intern (symbol-name f))) + ) + `(locally + (fli:define-foreign-funcallable + ,thunk + ,(cons `(this (:ptr (:ptr ,name))) args) + :result-type ,ret) + (defun ,func ,(if lambda-list + lambda-list + (mapcar #'first args)) + (let ((,genv ,global)) + (,thunk + (fli:foreign-slot-value (fli:dereference ,genv) ',func) + ,genv + ,@(mapcar #'first args)))) + (export ',func)))))) + members))) + +(defmacro defvtable (name global &rest members) + `(locally + (fli:define-c-struct ,name ,@(build-struct-entries name members)) + ,@(build-access-functions name global members))) + +(fli:define-c-struct jni-native-method + (name (:ptr :char)) + (signature (:ptr :char)) + (fn-ptr pvoid) + ) + +(defun current-env () + "memoizes attach-current-thread per process" + (or + *penv* + (cdr (assoc mp:*current-process* *process-envs*)) + (multiple-value-bind (ret env) (attach-current-thread) + (declare (ignore ret)) + (push (cons mp:*current-process* env) *process-envs*) + env))) + +(defvtable jni-env (current-env) + (reserved-0 pvoid) ;0 + (reserved-1 pvoid) ;1 + (reserved-2 pvoid) ;2 + (reserved-3 pvoid) ;3 + ;some mac nonsense requires this non-portable padding, so much for a binary spec + #+:MACOSX (cfm-padding (:foreign-array pvoid (225))) + (get-version () jint) ;4 + (define-class ((name const-char-*) ;5 + (loader jobject) + (buf (:ptr jbyte)) + (len jsize)) jclass) + (jni-find-class ((name const-char-*)) jclass) ;6 + (from-reflected-method ((method jobject)) jmethod-id) ;7 + (from-reflected-field ((field jobject)) jfield-id) ;8 + (to-reflected-method ((cls jclass) ;9 + (method-id jmethod-id) + (is-static jboolean)) jobject) + (get-superclass ((clazz jclass)) jclass) ;10 + (is-assignable-from ((sub jclass) ;11 + (sup jclass)) jboolean) + (to-reflected-field ((cls jclass) ;12 + (field-id jfield-id) + (is-static jboolean)) jobject) + (jni-throw ((obj jthrowable)) jint) ;13 + (throw-new ((clazz jclass) ;14 + (msg const-char-*)) jint) + (exception-occurred () jthrowable) ;15 + (exception-describe () :void) ;16 + (exception-clear () :void) ;17 + (fatal-error ((msg const-char-*)) :void) ;18 + (push-local-frame ((capacity jint)) jint) ;19 + (pop-local-frame ((result jobject)) jobject) ;20 + (new-global-ref ((lobj jobject)) jobject) ;21 + (delete-global-ref ((gref jobject)) :void) ;22 + (delete-local-ref ((lref jobject)) :void) ;23 + (is-same-object ((obj1 jobject) ;24 + (obj2 jobject)) jboolean) + (new-local-ref ((ref jobject)) jobject) ;25 + (ensure-local-capacity ((capacity jint)) jint) ;26 + (alloc-object ((clazz jclass)) jobject) ;27 + (new-object pvoid) ;28 + (new-object-v pvoid) ;29 + (new-object-a ((clazz jclass) ;30 + (method-id jmethod-id) + (args arg-array)) jobject) + (get-object-class ((obj jobject)) jclass) ;31 + (is-instance-of ((obj jobject) ;32 + (clazz jclass)) jboolean) + (get-method-id ((clazz jclass) ;33 + (name const-char-*) + (sig const-char-*)) jmethod-id) + + (call-object-method pvoid) ;34 + (call-object-method-v pvoid) ;35 + (call-object-method-a ((obj jobject) ;36 + (method-id jmethod-id) + (args arg-array)) jobject) + (call-boolean-method pvoid) ;37 + (call-boolean-method-v pvoid) ;38 + (call-boolean-method-a ((obj jobject) ;39 + (method-id jmethod-id) + (args arg-array)) jboolean) + (call-byte-method pvoid) ;40 + (call-byte-method-v pvoid) ;41 + (call-byte-method-a ((obj jobject) ;42 + (method-id jmethod-id) + (args arg-array)) jbyte) + (call-char-method pvoid) ;43 + (call-char-method-v pvoid) ;44 + (call-char-method-a ((obj jobject) ;45 + (method-id jmethod-id) + (args arg-array)) jchar) + (call-short-method pvoid) ;46 + (call-short-method-v pvoid) ;47 + (call-short-method-a ((obj jobject) ;48 + (method-id jmethod-id) + (args arg-array)) jshort) + (call-int-method pvoid) ;49 + (call-int-method-v pvoid) ;50 + (call-int-method-a ((obj jobject) ;51 + (method-id jmethod-id) + (args arg-array)) jint) + (call-long-method pvoid) ;52 + (call-long-method-v pvoid) ;53 + (call-long-method-a ((obj jobject) ;54 + (method-id jmethod-id) + (args arg-array)) jlong) + (call-float-method pvoid) ;55 + (call-float-method-v pvoid) ;56 + (call-float-method-a ((obj jobject) ;57 + (method-id jmethod-id) + (args arg-array)) jfloat) + (call-double-method pvoid) ;58 + (call-double-method-v pvoid) ;59 + (call-double-method-a ((obj jobject) ;60 + (method-id jmethod-id) + (args arg-array)) jdouble) + (call-void-method pvoid) ;61 + (call-void-method-v pvoid) ;62 + (call-void-method-a ((obj jobject) ;63 + (method-id jmethod-id) + (args arg-array)) jvoid) + + (call-nonvirtual-object-method pvoid) ;64 + (call-nonvirtual-object-method-v pvoid) ;65 + (call-nonvirtual-object-method-a ((obj jobject) ;66 + (clazz jclass) + (method-id jmethod-id) + (args arg-array)) jobject) + (call-nonvirtual-boolean-method pvoid) ;67 + (call-nonvirtual-boolean-method-v pvoid) ;68 + (call-nonvirtual-boolean-method-a ((obj jobject) ;69 + (clazz jclass) + (method-id jmethod-id) + (args arg-array)) jboolean) + (call-nonvirtual-byte-method pvoid) ;70 + (call-nonvirtual-byte-method-v pvoid) ;71 + (call-nonvirtual-byte-method-a ((obj jobject) ;72 + (clazz jclass) + (method-id jmethod-id) + (args arg-array)) jbyte) + (call-nonvirtual-char-method pvoid) ;73 + (call-nonvirtual-char-method-v pvoid) ;74 + (call-nonvirtual-char-method-a ((obj jobject) ;75 + (clazz jclass) + (method-id jmethod-id) + (args arg-array)) jchar) + (call-nonvirtual-short-method pvoid) ;76 + (call-nonvirtual-short-method-v pvoid) ;77 + (call-nonvirtual-short-method-a ((obj jobject) ;78 + (clazz jclass) + (method-id jmethod-id) + (args arg-array)) jshort) + (call-nonvirtual-int-method pvoid) ;79 + (call-nonvirtual-int-method-v pvoid) ;80 + (call-nonvirtual-int-method-a ((obj jobject) ;81 + (clazz jclass) + (method-id jmethod-id) + (args arg-array)) jint) + (call-nonvirtual-long-method pvoid) ;82 + (call-nonvirtual-long-method-v pvoid) ;83 + (call-nonvirtual-long-method-a ((obj jobject) ;84 + (clazz jclass) + (method-id jmethod-id) + (args arg-array)) jlong) + (call-nonvirtual-float-method pvoid) ;85 + (call-nonvirtual-float-method-v pvoid) ;86 + (call-nonvirtual-float-method-a ((obj jobject) ;87 + (clazz jclass) + (method-id jmethod-id) + (args arg-array)) jfloat) + (call-nonvirtual-double-method pvoid) ;88 + (call-nonvirtual-double-method-v pvoid) ;89 + (call-nonvirtual-double-method-a ((obj jobject) ;90 + (clazz jclass) + (method-id jmethod-id) + (args arg-array)) jdouble) + (call-nonvirtual-void-method pvoid) ;91 + (call-nonvirtual-void-method-v pvoid) ;92 + (call-nonvirtual-void-method-a ((obj jobject) ;93 + (clazz jclass) + (method-id jmethod-id) + (args arg-array)) jvoid) + (get-field-id ((clazz jclass) ;94 + (name const-char-*) + (sig const-char-*)) jfield-id) + + (get-object-field ((obj jobject) ;95 + (field-id jfield-id)) jobject) + (get-boolean-field ((obj jobject) ;96 + (field-id jfield-id)) jboolean) + (get-byte-field ((obj jobject) ;97 + (field-id jfield-id)) jbyte) + (get-char-field ((obj jobject) ;98 + (field-id jfield-id)) jchar) + (get-short-field ((obj jobject) ;99 + (field-id jfield-id)) jshort) + (get-int-field ((obj jobject) ;100 + (field-id jfield-id)) jint) + (get-long-field ((obj jobject) ;101 + (field-id jfield-id)) jlong) + (get-float-field ((obj jobject) ;102 + (field-id jfield-id)) jfloat) + (get-double-field ((obj jobject) ;103 + (field-id jfield-id)) jdouble) + + (set-object-field ((obj jobject) ;104 + (field-id jfield-id) + (val jobject)) jvoid) + (set-boolean-field ((obj jobject) ;105 + (field-id jfield-id) + (val jboolean)) jvoid) + (set-byte-field ((obj jobject) ;106 + (field-id jfield-id) + (val jbyte)) jvoid) + (set-char-field ((obj jobject) ;107 + (field-id jfield-id) + (val jchar)) jvoid) + (set-short-field ((obj jobject) ;108 + (field-id jfield-id) + (val jshort)) jvoid) + (set-int-field ((obj jobject) ;109 + (field-id jfield-id) + (val jint)) jvoid) + (set-long-field ((obj jobject) ;110 + (field-id jfield-id) + (val jlong)) jvoid) + (set-float-field ((obj jobject) ;111 + (field-id jfield-id) + (val jfloat)) jvoid) + (set-double-field ((obj jobject) ;112 + (field-id jfield-id) + (val jdouble)) jvoid) + + (get-static-method-id ((clazz jclass) ;113 + (name const-char-*) + (sig const-char-*)) jmethod-id) + + (call-static-object-method pvoid) ;114 + (call-static-object-method-v pvoid) ;115 + (call-static-object-method-a ((clazz jclass) ;116 + (method-id jmethod-id) + (args arg-array)) jobject) + (call-static-boolean-method pvoid) ;117 + (call-static-boolean-method-v pvoid) ;118 + (call-static-boolean-method-a ((clazz jclass) ;119 + (method-id jmethod-id) + (args arg-array)) jboolean) + (call-static-byte-method pvoid) ;120 + (call-static-byte-method-v pvoid) ;121 + (call-static-byte-method-a ((clazz jclass) ;122 + (method-id jmethod-id) + (args arg-array)) jbyte) + (call-static-char-method pvoid) ;123 + (call-static-char-method-v pvoid) ;124 + (call-static-char-method-a ((clazz jclass) ;125 + (method-id jmethod-id) + (args arg-array)) jchar) + (call-static-short-method pvoid) ;126 + (call-static-short-method-v pvoid) ;127 + (call-static-short-method-a ((clazz jclass) ;128 + (method-id jmethod-id) + (args arg-array)) jshort) + (call-static-int-method pvoid) ;129 + (call-static-int-method-v pvoid) ;130 + (call-static-int-method-a ((clazz jclass) ;131 + (method-id jmethod-id) + (args arg-array)) jint) + (call-static-long-method pvoid) ;132 + (call-static-long-method-v pvoid) ;133 + (call-static-long-method-a ((clazz jclass) ;134 + (method-id jmethod-id) + (args arg-array)) jlong) + (call-static-float-method pvoid) ;135 + (call-static-float-method-v pvoid) ;136 + (call-static-float-method-a ((clazz jclass) ;137 + (method-id jmethod-id) + (args arg-array)) jfloat) + (call-static-double-method pvoid) ;138 + (call-static-double-method-v pvoid) ;139 + (call-static-double-method-a ((clazz jclass) ;140 + (method-id jmethod-id) + (args arg-array)) jdouble) + (call-static-void-method pvoid) ;141 + (call-static-void-method-v pvoid) ;142 + (call-static-void-method-a ((clazz jclass) ;143 + (method-id jmethod-id) + (args arg-array)) jvoid) + + (get-static-field-id ((clazz jclass) ;144 + (name const-char-*) + (sig const-char-*)) jfield-id) + + (get-static-object-field ((clazz jclass) ;145 + (field-id jfield-id)) jobject) + (get-static-boolean-field ((clazz jclass) ;146 + (field-id jfield-id)) jboolean) + (get-static-byte-field ((clazz jclass) ;147 + (field-id jfield-id)) jbyte) + (get-static-char-field ((clazz jclass) ;148 + (field-id jfield-id)) jchar) + (get-static-short-field ((clazz jclass) ;149 + (field-id jfield-id)) jshort) + (get-static-int-field ((clazz jclass) ;150 + (field-id jfield-id)) jint) + (get-static-long-field ((clazz jclass) ;151 + (field-id jfield-id)) jlong) + (get-static-float-field ((clazz jclass) ;152 + (field-id jfield-id)) jfloat) + (get-static-double-field ((clazz jclass) ;153 + (field-id jfield-id)) jdouble) + + (set-static-object-field ((clazz jclass) ;154 + (field-id jfield-id) + (val jobject)) jvoid) + (set-static-boolean-field ((clazz jclass) ;155 + (field-id jfield-id) + (val jboolean)) jvoid) + (set-static-byte-field ((clazz jclass) ;156 + (field-id jfield-id) + (val jbyte)) jvoid) + (set-static-char-field ((clazz jclass) ;157 + (field-id jfield-id) + (val jchar)) jvoid) + (set-static-short-field ((clazz jclass) ;158 + (field-id jfield-id) + (val jshort)) jvoid) + (set-static-int-field ((clazz jclass) ;159 + (field-id jfield-id) + (val jint)) jvoid) + (set-static-long-field ((clazz jclass) ;160 + (field-id jfield-id) + (val jlong)) jvoid) + (set-static-float-field ((clazz jclass) ;161 + (field-id jfield-id) + (val jfloat)) jvoid) + (set-static-double-field ((clazz jclass) ;162 + (field-id jfield-id) + (val jdouble)) jvoid) + + (new-string ((uchars (:reference-pass :ef-wc-string)) ;163 + (len jsize)) jstring) + (get-string-length ((str jstring)) jsize) ;164 + (get-string-chars ((str jstring) ;165 + (is-copy (:reference-return jboolean))) + ;(:c-array jchar 1000) + (:ptr :wchar-t) + ;(:ef-wc-string :external-format :unicode) + :lambda-list (str &optional is-copy)) + (release-string-chars ((str jstring) ;166 + (chars (:ptr jchar))) jvoid) + + (new-string-utf ((chars const-char-*)) jstring) ;167 + (get-string-utf-length ((str jstring)) jsize) ;168 + (get-string-utf-chars ((str jstring) ;169 + (is-copy (:reference-return jboolean))) + ;(:c-array :char 1000) + (:ptr :char) + :lambda-list (str &optional is-copy)) + (release-string-utf-chars ((str jstring) ;170 + (chars (:ptr :char))) jvoid) + + (get-array-length ((array jarray)) jsize) ;171 + + (new-object-array ((len jsize) ;172 + (element-type jclass) + (initial-element jobject)) jarray) + (get-object-array-element ((array jobject-array) ;173 + (index jsize)) jobject) + (set-object-array-element ((array jobject-array) ;174 + (index jsize) + (val jobject)) jvoid) + + (new-boolean-array ((len jsize)) jboolean-array) ;175 + (new-byte-array ((len jsize)) jbyte-array) ;176 + (new-char-array ((len jsize)) jchar-array) ;177 + (new-short-array ((len jsize)) jshort-array) ;178 + (new-int-array ((len jsize)) jint-array) ;179 + (new-long-array ((len jsize)) jlong-array) ;180 + (new-float-array ((len jsize)) jfloat-array) ;181 + (new-double-array ((len jsize)) jdouble-array) ;182 + + (get-boolean-array-elements ((array jboolean-array) ;183 + (is-copy (:reference-return jboolean))) + (:ptr jboolean) + :lambda-list (array &optional is-copy)) + (get-byte-array-elements ((array jbyte-array) ;184 + (is-copy (:reference-return jboolean))) + (:ptr jbyte) + :lambda-list (array &optional is-copy)) + (get-char-array-elements ((array jchar-array) ;185 + (is-copy (:reference-return jboolean))) + (:ptr jchar) + :lambda-list (array &optional is-copy)) + (get-short-array-elements ((array jshort-array) ;186 + (is-copy (:reference-return jboolean))) + (:ptr jshort) + :lambda-list (array &optional is-copy)) + (get-int-array-elements ((array jint-array) ;187 + (is-copy (:reference-return jboolean))) + (:ptr jint) + :lambda-list (array &optional is-copy)) + (get-long-array-elements ((array jlong-array) ;188 + (is-copy (:reference-return jboolean))) + (:ptr jlong) + :lambda-list (array &optional is-copy)) + (get-float-array-elements ((array jfloat-array) ;189 + (is-copy (:reference-return jboolean))) + (:ptr jfloat) + :lambda-list (array &optional is-copy)) + (get-double-array-elements ((array jdouble-array) ;190 + (is-copy (:reference-return jboolean))) + (:ptr jdouble) + :lambda-list (array &optional is-copy)) + + (release-boolean-array-elements ((array jboolean-array) ;191 + (elems (:ptr jboolean)) + (mode jint)) jvoid + :lambda-list (array elems &optional (mode 0))) + (release-byte-array-elements ((array jbyte-array) ;192 + (elems (:ptr jbyte)) + (mode jint)) jvoid + :lambda-list (array elems &optional (mode 0))) + (release-char-array-elements ((array jchar-array) ;193 + (elems (:ptr jchar)) + (mode jint)) jvoid + :lambda-list (array elems &optional (mode 0))) + (release-short-array-elements ((array jshort-array) ;194 + (elems (:ptr jshort)) + (mode jint)) jvoid + :lambda-list (array elems &optional (mode 0))) + (release-int-array-elements ((array jint-array) ;195 + (elems (:ptr jint)) + (mode jint)) jvoid + :lambda-list (array elems &optional (mode 0))) + (release-long-array-elements ((array jlong-array) ;196 + (elems (:ptr jlong)) + (mode jint)) jvoid + :lambda-list (array elems &optional (mode 0))) + (release-float-array-elements ((array jfloat-array) ;197 + (elems (:ptr jfloat)) + (mode jint)) jvoid + :lambda-list (array elems &optional (mode 0))) + (release-double-array-elements ((array jdouble-array) ;198 + (elems (:ptr jdouble)) + (mode jint)) jvoid + :lambda-list (array elems &optional (mode 0))) + + (get-boolean-array-region ((array jboolean-array) ;199 + (start jsize) + (len jsize) + (buf (:ptr jboolean))) jvoid) + (get-byte-array-region ((array jbyte-array) ;200 + (start jsize) + (len jsize) + (buf (:ptr jbyte))) jvoid) + (get-char-array-region ((array jchar-array) ;201 + (start jsize) + (len jsize) + (buf (:ptr jchar))) jvoid) + (get-short-array-region ((array jshort-array) ;202 + (start jsize) + (len jsize) + (buf (:ptr jshort))) jvoid) + (get-int-array-region ((array jint-array) ;203 + (start jsize) + (len jsize) + (buf (:ptr jint))) jvoid) + (get-long-array-region ((array jlong-array) ;204 + (start jsize) + (len jsize) + (buf (:ptr jlong))) jvoid) + (get-float-array-region ((array jfloat-array) ;205 + (start jsize) + (len jsize) + (buf (:ptr jfloat))) jvoid) + (get-double-array-region ((array jdouble-array) ;206 + (start jsize) + (len jsize) + (buf (:ptr jdouble))) jvoid) + + (set-boolean-array-region ((array jboolean-array) ;207 + (start jsize) + (len jsize) + (buf (:ptr jboolean))) jvoid) + (set-byte-array-region ((array jbyte-array) ;208 + (start jsize) + (len jsize) + (buf (:ptr jbyte))) jvoid) + (set-char-array-region ((array jchar-array) ;209 + (start jsize) + (len jsize) + (buf (:ptr jchar))) jvoid) + (set-short-array-region ((array jshort-array) ;210 + (start jsize) + (len jsize) + (buf (:ptr jshort))) jvoid) + (set-int-array-region ((array jint-array) ;211 + (start jsize) + (len jsize) + (buf (:ptr jint))) jvoid) + (set-long-array-region ((array jlong-array) ;212 + (start jsize) + (len jsize) + (buf (:ptr jlong))) jvoid) + (set-float-array-region ((array jfloat-array) ;213 + (start jsize) + (len jsize) + (buf (:ptr jfloat))) jvoid) + (set-double-array-region ((array jdouble-array) ;214 + (start jsize) + (len jsize) + (buf (:ptr jdouble))) jvoid) + + (register-natives ((clazz jclass) ;215 + (methods (:ptr jni-native-method)) + (n-methods jsize)) jint) + (unregister-natives ((clazz jclass)) jint) ;216 + (monitor-enter ((obj jobject)) jint) ;217 + (monitor-exit ((obj jobject)) jint) ;218 + + (get-java-vm ((vm (:reference-return pvm))) jint ;219 + :lambda-list (&optional (vm t))) + + (get-string-region ((str jstring) ;220 + (start jsize) + (len jsize) + (buf (:ptr jchar))) jvoid) + (get-string-utf-region ((str jstring) ;221 + (start jsize) + (len jsize) + (buf (:ptr :char))) jvoid) + + (get-primitive-array-critical ((array jarray) ;222 + (is-copy (:reference-return jboolean))) pvoid + :lambda-list (array &optional is-copy)) + (release-primitive-array-critical ((array jarray) ;223 + (carray pvoid) + (mode jint)) jvoid + :lambda-list (array carray &optional (mode 0))) + + (get-string-critical ((str jstring) ;224 + (is-copy (:reference-return jboolean))) + (:ptr jchar) + :lambda-list (str &optional is-copy)) + (release-string-critical ((str jstring) ;225 + (cstring (:ptr jchar))) jvoid) + (new-weak-global-ref ((obj jobject)) jweak) ;226 + (delete-weak-global-ref ((ref jweak)) jvoid) ;227 + (exception-check () jboolean) ;228 + ) + +(defun get-pvm () + (or *pvm* + (error "JVM not loaded"))) + +(defvtable java-vm (get-pvm) + (reserved-0 pvoid) + (reserved-1 pvoid) + (reserved-2 pvoid) +#+:MACOSX (cfm-padding (:foreign-array pvoid (4))) + (destroy-java-vm () jint) + (attach-current-thread ((penv (:reference-return penv)) (args pvoid)) jint + :lambda-list (&optional args (penv t))) + (detach-current-thread () jint) + (get-env ((penv (:reference-return penv)) (interface-id jint)) jint + :lambda-list (interface-id &optional (penv t)))) + +(fli:define-c-struct java-vm-option + (option-string (:ptr :char)) + (extra-info pvoid)) + +(fli:define-c-struct jdk-1-1-init-args + (version jint) + (properties (:ptr (:ptr char))) + (check-source jint) + (native-stack-size jint) + (java-stack-size jint) + (min-heap-size jint) + (max-heap-size jint) + (verify-mode jint) + (class-path (:ptr :char)) + (vprintf pvoid) + (exit pvoid) + (abort pvoid) + (enable-class-gc jint) + (enable-verbose-gc jint) + (disable-async-gc jint) + (reserved-0 jint) + (reserved-1 jint) + (reserved-2 jint)) + +(fli:define-foreign-function (jni-get-default-java-vm-init-args "JNI_GetDefaultJavaVMInitArgs") + ((init-args (:ptr jdk-1-1-init-args))) + :result-type jint) + +(fli:define-c-struct java-vm-init-args + (version jint) + (n-options jint) + (options (:ptr java-vm-option)) + (ignore-unrecognized jboolean)) + +(fli:define-foreign-function (jni-create-java-vm "JNI_CreateJavaVM" :source) + ((pvm (:reference-return pvm)) + (penv (:reference-return penv)) + (vm-args (:ptr java-vm-init-args))) + :result-type jint + :lambda-list (vm-args &optional (pvm t) (penv t)) +; :module :jni-lib ;refused on Mac OSX, even though register-module is supported + ) + +(fli:define-foreign-function (jni-get-created-java-vms "JNI_GetCreatedJavaVMs" :source) + ((vm-buf (:c-array pvm)) + (buf-len jsize) + (n-vms (:reference-return jsize))) + :result-type jint) + +(defun cleanup-jni-gref (gref) + "set as a special free action to free java classes when no longer used by Lisp" + (when (java-ref-p gref) + (delete-global-ref gref))) + +(defun create-jvm (&rest option-strings) + "Creates the JVM, this can only be done once. +The option strings can be used to control the JVM, esp. the classpath: +\"-Djava.class.path=/Users/rich/Lisp/jfli.jar\"" + (when *pvm* + (error "JVM already created, can only be started once")) + (load-jni-lib) + (let ((nopts (length option-strings)) + (option-array nil)) + (fli:with-dynamic-foreign-objects ((ia java-vm-init-args)) + (when option-strings + (setf option-array (fli:allocate-dynamic-foreign-object :type 'java-vm-option :nelems nopts)) + (dotimes (n nopts) + (setf (fli:foreign-slot-value (fli:dereference option-array + :index n + :copy-foreign-object nil) 'option-string) + (fli:convert-to-dynamic-foreign-string (nth n option-strings))))) + (fli:with-foreign-slots (VERSION N-OPTIONS OPTIONS IGNORE-UNRECOGNIZED) ia + (setf version JNI-VERSION-1-4 + n-options nopts + OPTIONS option-array + IGNORE-UNRECOGNIZED nil) + (multiple-value-bind (ret vm env) + (jni-create-java-vm ia) + (setf *pvm* vm) + (add-special-free-action #'cleanup-jni-gref) + (values ret vm env)))))) + +;this is the FLI side of proxy support + +(defvar *invocation-handler* nil + "this will be set by jfli:enable-java-proxies to a function of 3 args") + +;this will be set as the implementation of a native java function +(fli:define-foreign-callable ("LispInvocationHandler_invoke" :result-type jobject) + ((env penv) (obj jobject) (proxy jobject) (method jobject) (args jobject)) + (do-invoke env obj proxy method args)) + +(defun do-invoke (env obj proxy method args) + ;(declare (ignore env)) + (when *invocation-handler* + (let ((*penv* env)) + (prog1 + (funcall *invocation-handler* proxy method args) + ;(jfli::invocation-handler proxy method args) + (delete-local-ref obj))))) + +(defun register-invocation-handler (invocation-handler) + "sets up the Lisp handler and binds the native function - jfli.jar must be in the classpath" + (setf *invocation-handler* invocation-handler) + (fli:with-dynamic-foreign-objects ((method jni-native-method)) + (let ((lih (try-null (jni-find-class "com/richhickey/jfli/LispInvocationHandler")))) + (fli:with-foreign-slots (name signature fn-ptr) method + (setf name (fli:convert-to-dynamic-foreign-string "invoke") + signature (fli:convert-to-dynamic-foreign-string "(Ljava/lang/Object;Ljava/lang/reflect/Method;[Ljava/lang/Object;)Ljava/lang/Object;") + fn-ptr (fli:make-pointer :symbol-name "LispInvocationHandler_invoke"))) + (register-natives lih method 1)))) + + +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; +;the code below provides for the generation of wrapper functions that use JNI to access +;methods and fields. This low-level interface is unsafe, in that JNI will not +;check arg types etc on calls, and therefore should only be used to build safer high-level interfaces +;i.e. use jfli! +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; + +;found on c.l.l +(eval-when (:compile-toplevel :load-toplevel) +(defun replace-substrings (string substring replacement) + (declare (optimize (speed 3)) + (type simple-string string substring replacement)) + (assert (> (length substring) 0) (substring) + "Substring ~A must be of length ~D > 0" + substring (length substring)) + (with-output-to-string (stream) + (loop with substring-length = (length substring) + for index = 0 then (+ match-index substring-length) + for match-index = (search substring string :start2 index) + do + (write-string string stream :start index :end match-index) + (when match-index + (write-string replacement stream)) + while match-index))) + + +(defun local-ref-to-global-ref (lref) + (when lref + (let ((gref (new-global-ref lref))) + (flag-special-free-action gref) + (delete-local-ref lref) + gref))) + +(defun local-ref-to-string (lref) + (prog1 + (convert-from-java-string lref) + (delete-local-ref lref))) + +(defun convert-to-java-string (s) + (when s + (try-null (new-string-utf (string s))))) + +(defun convert-from-java-string (s) + (when s + (let ((chars (try-null (get-string-utf-chars s)))) + (prog1 + (fli:convert-from-foreign-string chars :external-format :utf-8) + (release-string-utf-chars s chars))))) + +(defun jaref (array index) + (try (get-object-array-element array index))) + +(defun (setf jaref) (val array index) + (try (set-object-array-element array index val))) + +(defun convert-string-arg (s) + "if s is stringp, make into java string, else presume it is a java string and return it" + ;presumably faster than checking if s is a foreign pointer? + (if (or (stringp s) (symbolp s)) + (convert-to-java-string s) + s)) + +(defun process-arg (val type) + (if (string-equal "java.lang.String" type) + `(convert-string-arg ,val) + val)) + +(defmacro set-arg (args i val type) + `(setf (fli:foreign-slot-value (fli:dereference (fli:foreign-array-pointer ,args ,i) + :copy-foreign-object nil) + ',(slot-from-typename type)) + ,(process-arg val type))) + +(defmacro with-arg-array (arg-array-name args &body body) + (let ((i -1)) + `(fli:with-dynamic-foreign-objects () + (let ((,arg-array-name + (fli:allocate-dynamic-foreign-object :type + '(:c-array jvalue ,(length args))))) + ,@(mapcar #'(lambda (arg) + (list 'set-arg arg-array-name (incf i) (first arg) (second arg))) + args) + + ,@body)))) + +(defun build-descriptor (params return-type) + (string-append + "(" + (apply #'string-append (mapcar #'(lambda (p) + (type-descriptor-from-typename (second p))) + params)) + ")" + (type-descriptor-from-typename return-type))) + +(defun get-class-and-method-id (class-name method-name descriptor is-static) + (let ((class (local-ref-to-global-ref + (try-null (jni-find-class class-name))))) + (values class + (if is-static + (try-null (get-static-method-id class method-name descriptor)) + (try-null (get-method-id class method-name descriptor)))))) + + +(defun get-class-and-field-id (class-name field-name descriptor is-static) + (let ((class (local-ref-to-global-ref + (try-null (jni-find-class class-name))))) + (values class + (if is-static + (try-null (get-static-field-id class field-name descriptor)) + (try-null (get-field-id class field-name descriptor)))))) + +(defun is-name-of-primitive (s) + (member s '("boolean" "byte" "char" "short" "int" "long" "float" "double" "void") + :test #'string-equal)) + +(defun package-qualified-name (classname packagename) + (cond + ((is-name-of-primitive (subseq classname 0 (position #\< classname))) classname) + ((find #\. classname) classname) ;already qualified, presumably by another package + (t (string-append packagename "." classname)))) + +(defun split-package-and-class (name) + (let ((p (position #\. name :from-end t))) + (unless p (error "must supply package-qualified classname")) + (values (subseq name 0 p) + (subseq name (1+ p))))) + +(defun slot-from-typename (tn) + (let ((prim (assoc tn + '(("boolean" . :z) + ("byte" . :b) + ("char" . :c) + ("short" . :s) + ("int" . :i) + ("long" . :j) + ("float" . :f) + ("double" . :d)) + :test #'string-equal))) + (if prim + (rest prim) + :l))) + +(defun name-component-from-typename (tn) + (if (is-name-of-primitive tn) + tn + "object")) + +(defun type-descriptor-from-typename (tn) + (let ((prim (assoc tn + '(("boolean" . "Z") + ("byte" . "B") + ("char" . "C") + ("short" . "S") + ("int" . "I") + ("long" . "J") + ("float" . "F") + ("double" . "D") + ("void" . "V")) + :test #'string-equal))) + (if prim + (rest prim) + (let ((array-depth (count #\< tn)) + (tn-with-slashes (replace-substrings tn "." "/"))) + (if (= 0 array-depth) + (string-append "L" tn-with-slashes ";") + (with-output-to-string (s) + (dotimes (x array-depth) + (write-string "[" s)) + (write-string (type-descriptor-from-typename + (subseq tn-with-slashes 0 (position #\< tn-with-slashes))) s))))))) + +;not an exact reciprocal of type-descriptor-from-typename since reflection uses . not / as separator +(defun typename-from-reflection-type-descriptor (tn) + (let ((prim (assoc tn + '(("Z" . "boolean") + ("B" . "byte") + ("C" . "char") + ("S" . "short") + ("I" . "int") + ("J" . "long") + ("F" . "float") + ("D" . "double") + ("V" . "void")) + :test #'string-equal))) + (if prim + (rest prim) + (let ((array-depth (count #\[ tn))) + (if (= 0 array-depth) + (subseq tn 1 (1- (length tn))) ;strip leading L and trailing ; + (with-output-to-string (s) + (write-string (typename-from-reflection-type-descriptor (subseq tn array-depth)) s) + (dotimes (x array-depth) + (write-string "<>" s)))))))) + +(defun method-name-from-typename (tn static) + (find-symbol (string-upcase (string-append "call-" + (if static "static-" "") + (name-component-from-typename tn) + "-method-a")) :jni)) + +(defun field-get-name-from-typename (tn static) + (find-symbol (string-upcase (string-append "get-" + (if static "static-" "") + (name-component-from-typename tn) + "-field")) :jni)) + +(defun field-set-name-from-typename (tn static) + (find-symbol (string-upcase (string-append "set-" + (if static "static-" "") + (name-component-from-typename tn) + "-field")) :jni)) +(defun process-return (return-type f &key raw-return) + (cond + ((or raw-return (is-name-of-primitive return-type)) f) + ((string-equal "java.lang.String" return-type) `(local-ref-to-string ,f)) + (t `(local-ref-to-global-ref ,f)))) + +;JNI wrapper generators - will create functions in current package +;this needs more docs +(defmacro define-java-function (fname class-name return-type method-name params &key static raw-return) + (let ((this (gensym)) + (class (gensym)) + (id (gensym)) + (args (gensym))) + `(let (,class ,id) + (defun ,fname ,(if static (mapcar #'first params) + (cons this (mapcar #'first params))) + (when (null ,class) + (multiple-value-setq (,class ,id) + (get-class-and-method-id ,(replace-substrings class-name "." "/") + ,method-name ,(build-descriptor params return-type) ,static))) + (with-arg-array ,args ,(mapcar #'(lambda (param) + (list (first param) (second param))) + params) + ,(process-return return-type + `(try (,(method-name-from-typename return-type static) + ,(if static class this) ,id ,args)) + :raw-return raw-return)))))) + +(defmacro define-java-field (getname class-name field-type field-name &key static) + (let ((this (gensym)) + (class (gensym)) + (id (gensym)) + (val (gensym))) + `(let (,class ,id) + (flet ((load-ids () + (when (null ,class) + (multiple-value-setq (,class ,id) + (get-class-and-field-id ,(replace-substrings class-name "." "/") + ,field-name ,(type-descriptor-from-typename field-type) + ,static))))) + (defun ,getname ,(if static () (list this)) + (load-ids) + ,(process-return field-type + `(try (,(field-get-name-from-typename field-type static) + ,(if static class this) ,id)))) + (defun (setf ,getname) ,(if static (list val) (list this val)) + (load-ids) + (try (,(field-set-name-from-typename field-type static) + ,(if static class this) ,id ,(process-arg val field-type))) + ,val))))) + +(defmacro define-java-constructor (fname class-name params) + (let ((class (gensym)) + (id (gensym)) + (args (gensym))) + `(let (,class ,id) + (defun ,fname ,(mapcar #'first params) + (when (null ,class) + (multiple-value-setq (,class ,id) + (get-class-and-method-id ,(replace-substrings class-name "." "/") + "" ,(build-descriptor params "void") nil))) + (with-arg-array ,args ,(mapcar #'(lambda (param) + (list (first param) (second param))) + params) + (local-ref-to-global-ref (try-null (new-object-a ,class ,id ,args)))))))) + +(defun make-func-name (class method params append-param-types) + ;probably a format one-liner that can do this + (let ((base (string-append class "." method))) + (if append-param-types + (string-append base + (let ((param-types (mapcar #'second params))) + (if param-types + (string-append "<" + (reduce #'(lambda (x y) + (string-append x "-" y)) param-types) + ">") + "<>"))) + base))) + +;these just do some name twiddling before calling define-java-xxx above +(defmacro def-jni-function (package-and-class method params return-typename + &key static overloaded raw-return) + (multiple-value-bind (package class) (split-package-and-class package-and-class) + (let* ((fname (make-func-name class method params overloaded)) + (fsym (read-from-string fname))) + `(locally ,(list 'define-java-function + fsym + package-and-class + (package-qualified-name return-typename package) + method + (mapcar #'(lambda (p) + (list (first p) (package-qualified-name (second p) package))) + params) + :static static :raw-return raw-return))))) + +(defmacro def-jni-functions (package-and-class &rest decls) + `(locally ,@(mapcar #'(lambda (decl) + (list* 'def-jni-function package-and-class decl)) + decls))) + +(defmacro def-jni-constructor (package-and-class params &key overloaded) + (multiple-value-bind (package class) (split-package-and-class package-and-class) + (let* ((fname (make-func-name class "new" params overloaded)) + (fsym (read-from-string fname))) + `(locally ,(list 'define-java-constructor + fsym + package-and-class + (mapcar #'(lambda (p) + (list (first p) (package-qualified-name (second p) package))) + params)))))) + +(defmacro def-jni-field (package-and-class field typename &key static) + (multiple-value-bind (package class) (split-package-and-class package-and-class) + (let ((getsym (read-from-string (string-append class "." field + (if static "-accessor" "")))) + (macsym (read-from-string (string-append class "." field)))) + `(locally + ,(list 'define-java-field getsym package-and-class + (package-qualified-name typename package) field :static static) + ,(when static + `(define-symbol-macro ,macsym (,getsym))))))) + +;we're going to use a little Java to do exception handling below +(def-jni-function "java.lang.Object" + "toString" () "String") + +(def-jni-function "java.lang.reflect.InvocationTargetException" + "getTargetException" () "java.lang.Throwable") + +(def-jni-functions "java.lang.Throwable" + ("getMessage" () "String") + ("getStackTrace" () "StackTraceElement<>")) + +(defmacro do-jarray ((x array) &body body) + (let ((gcount (gensym)) + (gi (gensym)) + (garray (gensym))) + `(let* ((,garray ,array) + (,gcount (get-array-length ,garray))) + (dotimes (,gi ,gcount) + (let ((,x (jaref ,garray ,gi))) + ,@body))))) + +#| +It is critical that if you call a JNI function that might throw an exception that you clear it, +otherwise the next Java call you make will cause a crash +|# +(defun handle-exception () + (let ((e (exception-occurred))) + (when (not (fli:null-pointer-p e)) ;allow for safe calling in non-exceptional state + (exception-clear) + ;if the exception occurs in the reflection target, we really want that + (when (is-instance-of e (jni-find-class "java/lang/reflect/InvocationTargetException")) + (setf e (invocationtargetexception.gettargetexception e))) + (error "~A" (with-output-to-string (s) + (format s "~A~%" (object.tostring e)) + (do-jarray (x (throwable.getstacktrace e)) + (format s "~A~%" (object.tostring x)))))))) + +(defun try (result) + (if (exception-check) + (handle-exception) + result)) + +;JNI will sometimes indicate theere is an exception via a return value +;so take advantage of that when possible vs. the call back to exception-check +(defun try-null (result) + (if (fli:null-pointer-p result) + (handle-exception) + result)) + +(defun try-neg (result) + (if (minusp result) + (handle-exception) + result)) + + +) + Index: /branches/new-random/examples/jfli/jni.lisp =================================================================== --- /branches/new-random/examples/jfli/jni.lisp (revision 13309) +++ /branches/new-random/examples/jfli/jni.lisp (revision 13309) @@ -0,0 +1,1617 @@ +; Copyright (c) Rich Hickey. All rights reserved. +; The use and distribution terms for this software are covered by the +; Common Public License 1.0 (http://opensource.org/licenses/cpl.php) +; which can be found in the file CPL.TXT at the root of this distribution. +; By using this software in any fashion, you are agreeing to be bound by +; the terms of this license. +; You must not remove this notice, or any other, from this software. + +#| +This is a straight wrapper around the JNI API +Originally I intended to expose this API directly, but it turns out +that JNI is very sensitive to errors, and, given bad args, wrong types etc +causes the JVM (and Lisp) to crash, not very much in the spirit of safe, robust, +interactive development offered by Lisp + +So, now this just forms the substrate under jfli, which uses the Reflection API, and is much +more robust and error tolerant, at some cost in speed I guess. + +Bottom line is you shouldn't be using this API directly unless you are extending jfli, +and then you must take care not to allow bad end-user data to pass through to JNI. + +Caveat emptor. + +I have tried to limit LispWorks FLI code to this file. +|# + +(defpackage :jni + (:export + :*jni-lib-path* + :*pvm* + :*penv* + :register-invocation-handler + :create-jvm + :JNI-VERSION-1-2 + :JNI-VERSION-1-4 + :JNI-OK + :java-ref + :jvoid :jboolean :jbyte :jchar :jshort :jint :jlong :jfloat :jdouble :jsize + :jobject :jclass :jthrowable :jstring :jarray + :jboolean-array :jbyte-array :jchar-array :jshort-array :jint-array :jlong-array + :jfloat-array :jdouble-array :jobject-array + :jfield-id :jmethod-id :jweak + :pvm :penv + :jvalue + :arg-array + :jni-native-method :jni-env + :java-vm :java-vm-option :jdk-1-1-init-args + :jni-get-default-java-vm-init-args :java-vm-inits-args + :jni-create-java-vm :jni-get-created-java-vms + :try :try-null :try-neg + :local-ref-to-global-ref :local-ref-to-string + :def-jni-function :def-jni-functions :def-jni-constructor :def-jni-field + :jaref :convert-to-java-string :convert-from-java-string :java-ref-p + :is-name-of-primitive :split-package-and-class + ;; Export JNIEnv function names, too + :get-array-length :is-same-object :jni-find-class :is-assignable-from + :delete-local-ref :new-object-array :new-int-array + )) + +(in-package :jni) + +(defclass java-object (ccl::foreign-standard-object) + ()) + +(ccl::defloadvar *java-object-domain* nil) + +(or *java-object-domain* + (setq *java-object-domain* + (ccl::register-foreign-object-domain :java + :recognize #'ccl::false + :class-of (lambda (x) + (declare (ignore x)) + (find-class 'java-object)) + :classp #'ccl::false + :instance-class-wrapper + (lambda (x) + (declare (ignore x)) + (ccl::class-own-wrapper + (find-class 'java-object))) + :class-own-wrapper + #'ccl::false + :slots-vector #'ccl::false + :class-ordinal #'ccl::false + :set-class-ordinal + #'ccl::false))) + +(deftype java-ref () 'java-object) + +(defun java-ref-p (x) + (and (eql (ccl::typecode x) target::subtag-macptr) + (eql (ccl::%macptr-domain x) *java-object-domain*))) + + +(eval-when (:compile-toplevel :load-toplevel :execute) + (ccl:use-interface-dir :jni)) + +(defun string-append (&rest args) + (declare (dynamic-extent args)) + (do* ((a args (cdr a))) + ((null a) (apply #'concatenate 'string args)) + (let* ((arg (car a))) + (unless (typep arg 'string) + (setf (car a) (string arg)))))) + +(defvar *jni-lib-path* +#+:darwin-target "/System/Library/Frameworks/JavaVM.framework/JavaVM" +#+:win32-target "C:/Program Files/Java/jre6/bin/client/jvm.dll" +"Set this to point to your jvm dll prior to calling create-jvm") + +(ccl::defloadvar *pvm* nil) + +;;; Map between lisp and Java booleans +(eval-when (:compile-toplevel) + (declaim (inline jboolean-arg jboolean-result jobject-result jobject-arg))) + +(defun jboolean-arg (val) + (if (and val (not (eql val #$JNI_FALSE))) + #$JNI_TRUE + #$JNI_FALSE)) + +(defun jobject-arg (val) + (or val ccl::+null-ptr+)) + + +(defun jboolean-result (val) + (not (eql val #$JNI_FALSE))) + +;;; Might also want to register p for termination (finalization). +(defun jobject-result (val) + (unless (ccl::%null-ptr-p val) + (ccl::%set-macptr-domain val *java-object-domain*) + val)) + + + +(defconstant JNI-VERSION-1-2 #$JNI_VERSION_1_2) +(defconstant JNI-VERSION-1-4 #$JNI_VERSION_1_4) +(defconstant JNI-OK #$JNI_OK) + +(defun load-jni-lib (&optional (libpath *jni-lib-path*)) + (ccl:open-shared-library libpath)) + +(defun current-env () + "return a pointer to the current thread's JNIEnv, creating that environment +if necessary." + (rlet ((pjnienv :address)) + (let* ((jvm (get-pvm))) + (unless (eql jni-ok + (ff-call (pref jvm #>JavaVM.GetEnv) + :address jvm + :address pjnienv + :jint jni-version-1-4 + :jint)) + ;; On Darwin, attaching the current thread to a JVM instance + ;; overwrites the thread's Mach exception ports, which CCL + ;; happens to be using. We can work around this by calling + ;; a function in the CCL kernel and having that function + ;; call the vm's AttachCurrentThread function and then restore + ;; the thread's exception ports before returning. Yes, that + ;; -is- total nonsense. + (unless (eql jni-ok + (ff-call + (ccl::%kernel-import target::kernel-import-jvm-init) + :address (pref jvm #>JavaVM.AttachCurrentThread) + :address jvm + :address pjnienv + :address (ccl::%null-ptr) + :jint)) + (error "Can't attach thread to JVM ~s" jvm))) + (let* ((result (pref pjnienv :address))) + (ccl::%set-macptr-type result (load-time-value (ccl::foreign-type-ordinal (ccl::foreign-pointer-type-to (ccl::parse-foreign-type #>JNIEnv))))) + result)))) + + +;;; JNIEnv functions. + +(defun process-jnienv-call-args (specs) + (ccl::collect ((args)) + (do* ((specs specs (cddr specs))) + ((null specs) (args)) + (let* ((type (car specs)) + (valform (cadr specs))) + (args type) + (case type + (:jboolean (args `(jboolean-arg ,valform))) + ((:jobject :jclass :jstring :jthrowable :jarray #>jbooleanArray + #>jbyteArray #>jcharArray #>jshortArray #>jintArray + #>jlongArray #>jfloatArray #>jdoubleArray #>jobjectArray) + (args `(jobject-arg ,valform))) + (t (args valform))))))) + +(defmacro jnienv-call ((slot result-type) &rest specs) + ;; We might want to special-case some result-types for finalization. + (let* ((env (gensym)) + (accessor (ccl::escape-foreign-name (concatenate 'string "JNIEnv." slot))) + (form + `(let* ((,env (current-env))) + (ff-call (pref ,env ,accessor) :address ,env ,@(process-jnienv-call-args specs) ,result-type)))) + (case result-type + (:jboolean `(jboolean-result ,form)) + ((:jobject :jclass :jstring :jthrowable :jarray #>jbooleanArray + #>jbyteArray #>jcharArray #>jshortArray #>jintArray + #>jlongArray #>jfloatArray #>jdoubleArray #>jobjectArray) + `(jobject-result ,form)) + (t form)))) + + +(defun get-version () + (jnienv-call ("GetVersion" :jint))) + +(defun define-class (name loader buf len) + (ccl::with-utf-8-cstrs ((cname name)) + (jnienv-call ("DefineClass" :jclass) + :address cname + :jobject loader + (:* :jbyte) buf + :jsize len))) + +(defun jni-find-class (name) + (ccl::with-utf-8-cstrs ((cname name)) + (jnienv-call ("FindClass" :jclass) :address cname))) + + +(defun from-reflected-method (method) + (jnienv-call ("FromReflectedMethod" #>jmethodID) :jobject method)) + +(defun from-reflected-field (field) + (jnienv-call ("FromReflectedField" #>jfieldID) :jobject field)) + +(defun to-reflected-method (cls method-id is-static) + + (jnienv-call ("ToReflectedMethod" :jobject) + :jclass cls + #>jmethodID method-id + :jboolean is-static)) + +(defun get-superclass (sub) + (jnienv-call ("GetSuperclass" :jclass) :jclass sub)) + +(defun is-assignable-from (sub sup) + + (jnienv-call ("IsAssignableFrom" :jboolean) :jclass sub :jclass sup)) + +(defun to-reflected-field (cls field-id is-static) + + (jnienv-call ("ToReflectedField" :jobject) + :jclass cls + #>jfieldID field-id + :jboolean is-static)) + +(defun jni-throw (obj) + (jnienv-call ("Throw" :jint) :jthrowable obj)) + +(defun throw-new (clazz msg) + (ccl::with-utf-8-cstrs ((cmsg msg)) + (jnienv-call ("ThrowNew" :jint) :jclass clazz :address cmsg))) + +(defun exception-occurred () + (jnienv-call ("ExceptionOccurred" :jthrowable))) + +(defun exception-describe () + (jnienv-call ("ExceptionDescribe" :void))) + +(defun exception-clear () + (jnienv-call ("ExceptionClear" :void))) + +(defun fatal-error (msg) + (ccl::with-utf-8-cstrs ((cmsg msg)) + (jnienv-call ("FatalError" :void) :address cmsg))) + +(defun push-local-frame (capacity) + (jnienv-call ("PushLocalFrame" :jint) :jint capacity)) + +(defun pop-local-frame (result) + + (jnienv-call ("PopLocalFrame" :jobject) :jobject result)) + +(defun new-global-ref (lobj) + (jnienv-call ("NewGlobalRef" :jobject) :jobject lobj)) + +(defun delete-global-ref (gref) + (jnienv-call ("DeleteGlobalRef" :void) :jobject gref)) + +(defun delete-local-ref (obj) + (jnienv-call ("DeleteLocalRef" :void) :jobject obj)) + +(defun is-same-object (obj1 obj2) + + (jnienv-call ("IsSameObject" :jboolean) :jobject obj1 :jobject obj2)) + +(defun new-local-ref (ref) + + (jnienv-call ("NewLocalRef" :jobject) :jobject ref)) + +(defun ensure-local-capacity (capacity) + (jnienv-call ("EnsureLocalCapacity" :jint) :jint capacity)) + +(defun alloc-object (clazz) + (jnienv-call ("AllocObject" :jobject) :jclass clazz)) + +;;; We probably can't get very far with NewObject or NewObjectV, which +;;; depend on the underlying varargs mechanism. NewObjectA is more +;;; tractable. + +(defun new-object-a (clazz method-id args) + + (jnienv-call ("NewObjectA" :jobject) :jclass clazz #>jmethodID method-id (:* :jvalue) args)) + +(defun get-object-class (obj) + (jnienv-call ("GetObjectClass" :jclass) :jobject obj)) + +(defun is-instance-of (obj clazz) + + (jnienv-call ("IsInstanceOf" :jboolean) :jobject obj :jclass clazz)) + +(defun get-method-id (clazz name sig) + (ccl::with-utf-8-cstrs ((cname name) + (csig sig)) + (jnienv-call ("GetMethodID" #>jmethodID) + :jclass clazz :address cname :address csig))) + +;;; Likewise for Call*Method and Call*MethodV vs Call*MethodA. + +(defun call-object-method-a (obj method-id args) + (jnienv-call ("CallObjectMethodA" :jobject) + :jobject obj + #>jmethodID method-id + (:* :jvalue) args)) + +(defun call-boolean-method-a (obj method-id args) + + (jnienv-call ("CallBooleanMethodA" :jboolean) + :jobject obj + #>jmethodID method-id + (:* :jvalue) args)) + +(defun call-byte-method-a (obj method-id args) + (jnienv-call ("CallByteMethodA" :jbyte) + :jobject obj + #>jmethodID method-id + (:* :jvalue) args)) + +(defun call-byte-method-a (obj method-id args) + (jnienv-call ("CallCharMethodA" :jchar) + :jobject obj + #>jmethodID method-id + (:* :jvalue) args)) + +(defun call-short-method-a (obj method-id args) + (jnienv-call ("CallShortMethodA" :jshort) + :jobject obj + #>jmethodID method-id + (:* :jvalue) args)) + +(defun call-int-method-a (obj method-id args) + (jnienv-call ("CallIntMethodA" :jint) + :jobject obj + #>jmethodID method-id + (:* :jvalue) args)) + +(defun call-long-method-a (obj method-id args) + (jnienv-call ("CallLongMethodA" :jlong) + :jobject obj + #>jmethodID method-id + (:* :jvalue) args)) + +(defun call-float-method-a (obj method-id args) + (jnienv-call ("CallFloatMethodA" :jfloat) + :jobject obj + #>jmethodID method-id + (:* :jvalue) args)) + +(defun call-double-method-a (obj method-id args) + (jnienv-call ("CallDoubleMethodA" :jdouble) + :jobject obj + #>jmethodID method-id + (:* :jvalue) args)) + +(defun call-void-method-a (obj method-id args) + (jnienv-call ("CallVoidMethodA" :void) + :jobject obj + #>jmethodID method-id + (:* :jvalue) args)) + +;;; Nonvirtual method calls. +(defun call-nonvirtual-object-method-a (obj method-id args) + (jnienv-call ("CallNonvirtualObjectMethodA" :jobject) + :jobject obj + #>jmethodID method-id + (:* :jvalue) args)) + +(defun call-nonvirtual-boolean-method-a (obj method-id args) + + (jnienv-call ("CallNonvirtualBooleanMethodA" :jboolean) + :jobject obj + #>jmethodID method-id + (:* :jvalue) args)) + +(defun call-nonvirtual-byte-method-a (obj method-id args) + (jnienv-call ("CallNonvirtualByteMethodA" :jbyte) + :jobject obj + #>jmethodID method-id + (:* :jvalue) args)) + +(defun call-nonvirtual-char-method-a (obj method-id args) + (jnienv-call ("CallNonvirtualCharMethodA" :jchar) + :jobject obj + #>jmethodID method-id + (:* :jvalue) args)) + +(defun call-nonvirtual-short-method-a (obj method-id args) + (jnienv-call ("CallNonvirtualShortMethodA" :jshort) + :jobject obj + #>jmethodID method-id + (:* :jvalue) args)) + + +(defun call-nonvirtual-int-method-a (obj method-id args) + (jnienv-call ("CallNonvirtualIntMethodA" :jint) + :jobject obj + #>jmethodID method-id + (:* :jvalue) args)) + +(defun call-nonvirtual-long-method-a (obj method-id args) + (jnienv-call ("CallNonvirtualLongMethodA" :jlong) + :jobject obj + #>jmethodID method-id + (:* :jvalue) args)) + +(defun call-nonvirtual-float-method-a (obj method-id args) + (jnienv-call ("CallNonvirtualFloatMethodA" :jfloat) + :jobject obj + #>jmethodID method-id + (:* :jvalue) args)) + +(defun call-nonvirtual-double-method-a (obj method-id args) + (jnienv-call ("CallNonvirtualDoubleMethodA" :jdouble) + :jobject obj + #>jmethodID method-id + (:* :jvalue) args)) + +(defun call-nonvirtual-void-method-a (obj method-id args) + (jnienv-call ("CallNonvirtualVoidMethodA" :void) + :jobject obj + #>jmethodID method-id + (:* :jvalue) args)) + +(defun get-field-id (clazz name sig) + (ccl::with-utf-8-cstrs ((cname name) + (csig sig)) + (jnienv-call ("GetFieldID" #>jfieldID) + :jclass clazz + :address cname + :address csig))) + +(defun get-object-field (obj field-id) + + (jnienv-call ("GetObjectField" :jobject) + :jobject obj + #>jfieldID field-id)) + +(defun get-boolean-field (obj field-id) + + (jnienv-call ("GetBooleanField" :jboolean) + :jobject obj + #>jfieldID field-id)) + +(defun get-byte-field (obj field-id) + (jnienv-call ("GetByteField" :jbyte) + :jobject obj + #>jfieldID field-id)) + +(defun get-char-field (obj field-id) + (jnienv-call ("GetCharField" :jchar) + :jobject obj + #>jfieldID field-id)) + +(defun get-short-field (obj field-id) + (jnienv-call ("GetShortField" :jshort) + :jobject obj + #>jfieldID field-id)) + + +(defun get-int-field (obj field-id) + (jnienv-call ("GetIntField" :jint) + :jobject obj + #>jfieldID field-id)) + +(defun get-long-field (obj field-id) + (jnienv-call ("GetLongField" :jlong) + :jobject obj + #>jfieldID field-id)) + +(defun get-float-field (obj field-id) + (jnienv-call ("GetFloatField" :jfloat) + :jobject obj + #>jfieldID field-id)) + +(defun get-double-field (obj field-id) + (jnienv-call ("GetDoubleField" :jdouble) + :jobject obj + #>jfieldID field-id)) + +(defun set-object-field (obj field-id val) + (jnienv-call ("SetObjectField" :void) + :jobject obj + #>jfieldID field-id + :jobject val)) + +(defun set-boolean-field (obj field-id val) + (jnienv-call ("SetBooleanField" :void) + :jobject obj + #>jfieldID field-id + :jboolean val)) + +(defun set-byte-field (obj field-id val) + (jnienv-call ("SetByteField" :void) + :jobject obj + #>jfieldID field-id + :jbyte val)) + +(defun set-char-field (obj field-id val) + (jnienv-call ("SetCharField" :void) + :jobject obj + #>jfieldID field-id + :jchar val)) + +(defun set-short-field (obj field-id val) + (jnienv-call ("SetShortField" :void) + :jobject obj + #>jfieldID field-id + :jshort val)) + +(defun set-int-field (obj field-id val) + (jnienv-call ("SetIntField" :void) + :jobject obj + #>jfieldID field-id + :jint val)) + +(defun set-long-field (obj field-id val) + (jnienv-call ("SetLongField" :void) + :jobject obj + #>jfieldID field-id + :jlong val)) + +(defun set-float-field (obj field-id val) + (jnienv-call ("SetFloatField" :void) + :jobject obj + #>jfieldID field-id + :jfloat val)) + +(defun set-double-field (obj field-id val) + (jnienv-call ("SetDoubleField" :void) + :jobject obj + #>jfieldID field-id + :jdouble val)) + +(defun get-static-method-id (clazz name sig) + (ccl::with-utf-8-cstrs ((cname name) + (csig sig)) + (jnienv-call ("GetStaticMethodID" #>jmethodID) + :jclass clazz + :address cname + :address csig))) + +(defun call-static-object-method-a (clazz method-id args) + + (jnienv-call ("CallStaticObjectMethodA" :jobject) + :jclass clazz + #>jmethodID method-id + (:* :jvalue) args)) + +(defun call-static-boolean-method-a (clazz method-id args) + + (jnienv-call ("CallStaticBooleanMethodA" :jboolean) + :jclass clazz + #>jmethodID method-id + (:* :jvalue) args)) + +(defun call-static-byte-method-a (clazz method-id args) + (jnienv-call ("CallStaticByteMethodA" :jbyte) + :jclass clazz + #>jmethodID method-id + (:* :jvalue) args)) + +(defun call-static-char-method-a (clazz method-id args) + (jnienv-call ("CallStaticCharMethodA" :jchar) + :jclass clazz + #>jmethodID method-id + (:* :jvalue) args)) + +(defun call-static-short-method-a (clazz method-id args) + (jnienv-call ("CallStaticShortMethodA" :jshort) + :jclass clazz + #>jmethodID method-id + (:* :jvalue) args)) + +(defun call-static-int-method-a (clazz method-id args) + (jnienv-call ("CallStaticIntMethodA" :jint) + :jclass clazz + #>jmethodID method-id + (:* :jvalue) args)) + +(defun call-static-long-method-a (clazz method-id args) + (jnienv-call ("CallStaticLongMethodA" :jlong) + :jclass clazz + #>jmethodID method-id + (:* :jvalue) args)) + +(defun call-static-float-method-a (clazz method-id args) + (jnienv-call ("CallStaticFloatMethodA" :jfloat) + :jclass clazz + #>jmethodID method-id + (:* :jvalue) args)) + +(defun call-static-double-method-a (clazz method-id args) + (jnienv-call ("CallStaticDoubleMethodA" :jdouble) + :jclass clazz + #>jmethodID method-id + (:* :jvalue) args)) + +(defun call-static-void-method-a (clazz method-id args) + (jnienv-call ("CallStaticVoidMethodA" :void) + :jclass clazz + #>jmethodID method-id + (:* :jvalue) args)) + +(defun get-static-field-id (clazz name sig) + (ccl::with-utf-8-cstrs ((cname name) + (csig sig)) + (jnienv-call ("GetStaticFieldID" #>jfieldID) + :jclass clazz + :address cname + :address csig))) + +(defun get-static-object-field (clazz field-id) + (jnienv-call ("GetStaticObjectField" :jobject) + :jclass clazz + #>jfieldID field-id)) + +(defun get-static-boolean-field (clazz field-id) + + (jnienv-call ("GetStaticBooleanField" :jboolean) + :jclass clazz + #>jfieldID field-id)) + +(defun get-static-byte-field (clazz field-id) + (jnienv-call ("GetStaticByteField" :jbyte) + :jclass clazz + #>jfieldID field-id)) + +(defun get-static-char-field (clazz field-id) + (jnienv-call ("GetStaticCharField" :jchar) + :jclass clazz + #>jfieldID field-id)) + +(defun get-static-short-field (clazz field-id) + (jnienv-call ("GetStaticShortField" :jshort) + :jclass clazz + #>jfieldID field-id)) + +(defun get-static-int-field (clazz field-id) + (jnienv-call ("GetStaticIntField" :jint) + :jclass clazz + #>jfieldID field-id)) + +(defun get-static-long-field (clazz field-id) + (jnienv-call ("GetStaticLongField" :jlong) + :jclass clazz + #>jfieldID field-id)) + +(defun get-static-float-field (clazz field-id) + (jnienv-call ("GetStaticFloatField" :jfloat) + :jclass clazz + #>jfieldID field-id)) + +(defun get-static-double-field (clazz field-id) + (jnienv-call ("GetStaticDoubleField" :jdouble) + :jclass clazz + #>jfieldID field-id)) + + +(defun set-static-object-field (clazz field-id value) + (jnienv-call ("SetStaticObjectField" :void) + :jclass clazz + #>jfieldID field-id + :jobject value)) + +(defun set-static-boolean-field (clazz field-id value) + (jnienv-call ("SetStaticBooleanField" :void) + :jclass clazz + #>jfieldID field-id + :jboolean value)) + +(defun set-static-byte-field (clazz field-id value) + (jnienv-call ("SetStaticByteField" :void) + :jclass clazz + #>jfieldID field-id + :jbyte value)) + +(defun set-static-char-field (clazz field-id value) + (jnienv-call ("SetStaticCharField" :void) + :jclass clazz + #>jfieldID field-id + :jchar value)) + +(defun set-static-short-field (clazz field-id value) + (jnienv-call ("SetStaticShortField" :void) + :jclass clazz + #>jfieldID field-id + :jshort value)) + +(defun set-static-int-field (clazz field-id value) + (jnienv-call ("SetStaticIntField" :void) + :jclass clazz + #>jfieldID field-id + :jint value)) + +(defun set-static-long-field (clazz field-id value) + (jnienv-call ("SetStaticLongField" :void) + :jclass clazz + #>jfieldID field-id + :jlong value)) + +(defun set-static-float-field (clazz field-id value) + (jnienv-call ("SetStaticFloatField" :void) + :jclass clazz + #>jfieldID field-id + :jfloat value)) + +(defun set-static-double-field (clazz field-id value) + (jnienv-call ("SetStaticDoubleField" :void) + :jclass clazz + #>jfieldID field-id + :jdouble value)) + +(defun new-string (unicode len) + (ccl::with-native-utf-16-cstrs ((cstring unicode)) + (jnienv-call ("NewString" :jstring) + (:* :jchar) cstring + :jsize len))) + +(defun get-string-length (str) + (jnienv-call ("GetStringLength" :jsize) + :jstring str)) + +(defun get-string-chars (str is-copy) + (jnienv-call ("GetStringChars" (:* :jchar)) + :jstring str + (:* :jboolean) is-copy)) + +(defun release-string-chars (str chars) + (jnienv-call ("ReleaseStringChars" :void) + :jstring str + (:* :jchar) chars)) + +(defun new-string-utf (string) + (ccl::with-utf-8-cstrs ((cstring string)) + (jnienv-call ("NewStringUTF" :jstring) + :address cstring))) + +(defun get-string-utf-chars (str) + (rlet ((is-copy :jboolean)) + (let* ((chars (jnienv-call ("GetStringUTFChars" (:* :char)) + :jstring str + (:* :jboolean) is-copy))) + (values chars (pref is-copy :jboolean))))) + +(defun release-string-utf-chars (str chars) + (jnienv-call ("ReleaseStringUTFChars" :void) + :jstring str + (:* :char) chars)) + +(defun get-array-length (array) + (jnienv-call ("GetArrayLength" :jsize) + :jArray array)) + +(defun new-object-array (len clazz init) + (jnienv-call ("NewObjectArray" #>jobjectArray) + :jsize len + :jclass clazz + :jobject init)) + +(defun get-object-array-element (array index) + (jnienv-call ("GetObjectArrayElement" :jobject) + #>jobjectArray array + :jsize index)) + +(defun set-object-array-element (array index val) + (jnienv-call ("SetObjectArrayElement" :void) + #>jobjectArray array + :jsize index + :jobject val)) + +(defun new-boolean-array (len) + (jnienv-call ("NewBooleanArray" #>jbooleanArray) + :jsize len)) + +(defun new-byte-array (len) + (jnienv-call ("NewByteArray" #>jbyteArray) + :jsize len)) + +(defun new-char-array (len) + (jnienv-call ("NewCharArray" #>jcharArray) + :jsize len)) + +(defun new-short-array (len) + (jnienv-call ("NewShortArray" #>jshortArray) + :jsize len)) + +(defun new-int-array (len) + (jnienv-call ("NewIntArray" #>jintArray) + :jsize len)) + +(defun new-long-array (len) + (jnienv-call ("NewLongArray" #>jlongArray) + :jsize len)) + +(defun new-float-array (len) + (jnienv-call ("NewFloatArray" #>jfloatArray) + :jsize len)) + +(defun new-double-array (len) + (jnienv-call ("NewDoubleArray" #>jdoubleArray) + :jsize len)) + + +(defun get-boolean-array-elements (array is-copy) + (jnienv-call ("GetBooleanArrayElements" (:* :jboolean)) + #>jbooleanArray array + (:* :jboolean) is-copy)) + +(defun get-byte-array-elements (array is-copy) + (jnienv-call ("GetByteArrayElements" (:* :jbyte)) + #>jbyteArray array + (:* :jboolean) is-copy)) + +(defun get-char-array-elements (array is-copy) + (jnienv-call ("GetCharArrayElements" (:* :jchar)) + #>jcharArray array + (:* :jboolean) is-copy)) + +(defun get-short-array-elements (array is-copy) + (jnienv-call ("GetShortArrayElements" (:* :jshort)) + #>jshortArray array + (:* :jboolean) is-copy)) + +(defun get-int-array-elements (array is-copy) + (jnienv-call ("GetIntArrayElements" (:* :jint)) + #>jintArray array + (:* :jboolean) is-copy)) + +(defun get-long-array-elements (array is-copy) + (jnienv-call ("GetLongArrayElements" (:* :jlong)) + #>jlongArray array + (:* :jboolean) is-copy)) + +(defun get-float-array-elements (array is-copy) + (jnienv-call ("GetFloatArrayElements" (:* :jfloat)) + #>jfloatArray array + (:* :jboolean) is-copy)) + +(defun get-double-array-elements (array is-copy) + (jnienv-call ("GetDoubleArrayElements" (:* :jdouble)) + #>jdoubleArray array + (:* :jboolean) is-copy)) + +(defun release-boolean-array-elements (array elems mode) + (jnienv-call ("ReleaseBooleanArrayElements" :void) + #>jbooleanArray array + (:* jboolean) elems + :jint mode)) + +(defun release-byte-array-elements (array elems mode) + (jnienv-call ("ReleaseByteArrayElements" :void) + #>jbyteArray array + (:* jbyte) elems + :jint mode)) + +(defun release-char-array-elements (array elems mode) + (jnienv-call ("ReleaseCharArrayElements" :void) + #>jcharArray array + (:* jchar) elems + :jint mode)) + +(defun release-short-array-elements (array elems mode) + (jnienv-call ("ReleaseShortArrayElements" :void) + #>jshortArray array + (:* jshort) elems + :jint mode)) + +(defun release-int-array-elements (array elems mode) + (jnienv-call ("ReleaseIntArrayElements" :void) + #>jintArray array + (:* jint) elems + :jint mode)) + +(defun release-long-array-elements (array elems mode) + (jnienv-call ("ReleaseLongArrayElements" :void) + #>jlongArray array + (:* jlong) elems + :jint mode)) + +(defun release-float-array-elements (array elems mode) + (jnienv-call ("ReleaseFloatArrayElements" :void) + #>jfloatArray array + (:* jfloat) elems + :jint mode)) + +(defun release-double-array-elements (array elems mode) + (jnienv-call ("ReleaseDoubleArrayElements" :void) + #>jdoubleArray array + (:* jdouble) elems + :jint mode)) + + +(defun get-boolean-array-region (array start len buf) + (jnienv-call ("GetBooleanArrayRegion" :void) + #>jbooleanArray array + :jsize start + :jsize len + (:* :jboolean) buf)) + +(defun get-byte-array-region (array start len buf) + (jnienv-call ("GetByteArrayRegion" :void) + #>jbyteArray array + :jsize start + :jsize len + (:* :jbyte) buf)) + +(defun get-char-array-region (array start len buf) + (jnienv-call ("GetCharArrayRegion" :void) + #>jcharArray array + :jsize start + :jsize len + (:* :jchar) buf)) + +(defun get-short-array-region (array start len buf) + (jnienv-call ("GetShortArrayRegion" :void) + #>jshortArray array + :jsize start + :jsize len + (:* :jshort) buf)) + +(defun get-int-array-region (array start len buf) + (jnienv-call ("GetIntArrayRegion" :void) + #>jintArray array + :jsize start + :jsize len + (:* :jint) buf)) + +(defun get-long-array-region (array start len buf) + (jnienv-call ("GetLongArrayRegion" :void) + #>jlongArray array + :jsize start + :jsize len + (:* :jlong) buf)) + +(defun get-float-array-region (array start len buf) + (jnienv-call ("GetFloatArrayRegion" :void) + #>jfloatArray array + :jsize start + :jsize len + (:* :jfloat) buf)) + +(defun get-double-array-region (array start len buf) + (jnienv-call ("GetDoubleArrayRegion" :void) + #>jdoubleArray array + :jsize start + :jsize len + (:* :jdouble) buf)) + +(defun set-boolean-array-region (array start len buf) + (jnienv-call ("SetBooleanArrayRegion" :void) + #>jbooleanArray array + :jsize start + :jsize len + (:* :jboolean) buf)) + +(defun set-byte-array-region (array start len buf) + (jnienv-call ("SetByteArrayRegion" :void) + #>jbyteArray array + :jsize start + :jsize len + (:* :jbyte) buf)) + +(defun set-char-array-region (array start len buf) + (jnienv-call ("SetCharArrayRegion" :void) + #>jcharArray array + :jsize start + :jsize len + (:* :jchar) buf)) + +(defun set-short-array-region (array start len buf) + (jnienv-call ("SetShortArrayRegion" :void) + #>jshortArray array + :jsize start + :jsize len + (:* :jshort) buf)) + +(defun set-int-array-region (array start len buf) + (jnienv-call ("SetIntArrayRegion" :void) + #>jintArray array + :jsize start + :jsize len + (:* :jint) buf)) + +(defun set-long-array-region (array start len buf) + (jnienv-call ("SetLongArrayRegion" :void) + #>jlongArray array + :jsize start + :jsize len + (:* :jlong) buf)) + +(defun set-float-array-region (array start len buf) + (jnienv-call ("SetFloatArrayRegion" :void) + #>jfloatArray array + :jsize start + :jsize len + (:* :jfloat) buf)) + +(defun set-double-array-region (array start len buf) + (jnienv-call ("SetDoubleArrayRegion" :void) + #>jdoubleArray array + :jsize start + :jsize len + (:* :jdouble) buf)) + + +(defun register-natives (clazz methods nmethods) + (jnienv-call ("RegisterNatives":jint) + :jclass clazz + (:* #>JNINativeMethod) methods + :jint nmethods)) + + +(defun unregister-natives (clazz) + (jnienv-call ("UnregisterNatives" :jint) + :jclass clazz)) + +(defun monitor-enter (obj) + (jnienv-call ("MonitorEnter" :jint) + :jobject obj)) + +(defun monitor-exit (obj) + (jnienv-call ("MonitorExit" :jint) + :jobject obj)) + +(defun get-java-vm (vm) + (jnienv-call ("GetJavaVM" :jint) + (:* (:* #>JavaVM)) vm)) + +(defun get-string-region (str start len buf) + (jnienv-call ("GetStringRegion" :void) + :jstring str + :jsize start + :jsize len + (:* :jchar) buf)) + +(defun get-string-utf-region (str start len buf) + (jnienv-call ("GetStringUTFRegion" :void) + :jstring str + :jsize start + :jsize len + (:* :char) buf)) + +(defun get-primitive-array-critical (array is-copy) + (jnienv-call ("GetPrimitiveArrayCritical" (:* :void)) + :jarray array + (:* :jboolean) is-copy)) + +(defun release-primitive-array-critical(jarray carray mode) + (jnienv-call ("ReleasePrimitiveArrayCritical" :void) + :jarray jarray + (:* :void) carray + :jint mode)) + +(defun get-string-critical (string is-copy) + (jnienv-call ("GetStringCritical" (:* :jchar)) + :jstring string + (:* :jboolean) is-copy)) + +(defun release-string-critical (string cstring) + (jnienv-call ("ReleaseStringCritical" :void) + :jstring string + (:* :jchar) cstring)) + +(defun new-weak-global-ref (obj) + (jnienv-call ("NewWeakGlobalRef" :jweak) + :jobject obj)) + +(defun delete-weak-global-ref (ref) + (jnienv-call ("DeleteWeakGlobalRef" :void) + :jweak ref)) + +(defun exception-check () + (jnienv-call ("ExceptionCheck" :jboolean))) + + +(defun new-direct-byte-buffer (address capacity) + (jnienv-call ("NewDirectByteBuffer" :jobject) + :address address + :jlong capacity)) + +(defun get-direct-buffer-address (buf) + (jnienv-call ("GetDirectBufferAddress" :address) + :jobject buf)) + +(defun get-direct-buffer-capacity (buf) + (jnienv-call ("GetDirectBufferCapacity" :jlong) + :jobject buf)) + +;;; End of jnienv functions. (Finally.) + +(defun get-pvm () + (or *pvm* + (error "JVM not loaded"))) + +#+later +(defun cleanup-jni-gref (gref) + "set as a special free action to free java classes when no longer used by Lisp" + (when (java-ref-p gref) + (delete-global-ref gref))) + +(defun create-jvm (&rest args) + (declare (dynamic-extent args)) + "Creates the JVM, this can only be done once. +The option strings can be used to control the JVM, esp. the classpath: +\"-Djava.class.path=/Users/rich/Lisp/jfli.jar\"" + (when *pvm* + (error "JVM already created, can only be started once")) + (load-jni-lib) + (ccl::call-with-string-vector + (lambda (argv) + (let* ((nargs (length args))) + (rlet ((initargs :avanitrgs) + (env (:* :nv)) + (vm (:* :ava))) + (%stack-block ((options (* nargs (ccl::record-length :avaption)))) + (do* ((i 0 (1+ i)) + (p options (%inc-ptr p (ccl::record-length :avaption)))) + ((= i nargs)) + (setf (pref p :avaption.option~~tring) + (paref argv (:* (:* :char)) i))) + (setf (pref initargs :avanit~~rgs.version) #$JNI_VERSION_1_4 + (pref initargs :avanit rgs.nptions) nargs + (pref initargs :avanit rgs.options) options + (pref initargs :avanit rgs.ignorenrecognized) #$JNI_TRUE) + ;; In Darwin, JNI_CreateJavaVM will clobber the calling thread's + ;; Mach exception ports, despite the fact that CCL is using them. + ;; To work around this, call a function in the lisp kernel which + ;; restores the thread's exception ports after calling + ;; JNI_CreateJavaVM for us. + (let* ((result + (ff-call (ccl::%kernel-import target::kernel-import-jvm-init) + :address (foreign-symbol-address "JNI_CreateJavaVM") + :address vm + :address env + :address initargs + :int))) + (if (>= result 0) + (progn + (setq *pvm* (%get-ptr vm)) + (values result (%get-ptr vm) (%get-ptr env))) + (error "Can't create Java VM: result = ~d" result))))))) + args)) + + +;;;this is the FLI side of proxy support + +(defvar *invocation-handler* nil + "this will be set by jfli:enable-java-proxies to a function of 3 args") + + + +;;;this will be set as the implementation of a native java function + +(defcallback |LispInvocationHandler_invoke| + (:address env :jobject obj :jobject proxy :jobject method :jobject args :jobject) + (jobject-result obj) + (jobject-result proxy) + (jobject-result method) + (jobject-result args) + (jobject-arg + (do-invoke env obj proxy method args))) + + +(defun do-invoke (env obj proxy method args) + (declare (ignore env)) ;it's not like we're on another thread + (when *invocation-handler* + (prog1 + (funcall *invocation-handler* proxy method args) + ;;(jfli::invocation-handler proxy method args) + (delete-local-ref obj)))) + +(defun try (result) + (if (exception-check) + (handle-exception) + result)) + +;JNI will sometimes indicate theere is an exception via a return value +;so take advantage of that when possible vs. the call back to exception-check +(defun try-null (result) + (if (or (null result) (ccl:%null-ptr-p result)) + (handle-exception) + result)) + +(defun register-invocation-handler (invocation-handler) + "sets up the Lisp handler and binds the native function - jfli.jar must be in the classpath" + (setf *invocation-handler* invocation-handler) + (rlet ((method #>JNINativeMethod)) + (let ((lih (try-null (jni-find-class "com/richhickey/jfli/LispInvocationHandler")))) + (with-cstrs ((name "invoke") + (signature "(Ljava/lang/Object;Ljava/lang/reflect/Method;[Ljava/lang/Object;)Ljava/lang/Object;")) + (setf (pref method #>JNINativeMethod.name) name + (pref method #>JNINativeMethod.signature) signature + (pref method #>JNINativeMethod.fnPtr) |LispInvocationHandler_invoke|) + (register-natives lih method 1))))) + + +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; +;the code below provides for the generation of wrapper functions that use JNI to access +;methods and fields. This low-level interface is unsafe, in that JNI will not +;check arg types etc on calls, and therefore should only be used to build safer high-level interfaces +;i.e. use jfli! +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; + +;found on c.l.l +(eval-when (:compile-toplevel :load-toplevel :execute) +(defun replace-substrings (string substring replacement) + (declare (optimize (speed 3)) + (type simple-string string substring replacement)) + (assert (> (length substring) 0) (substring) + "Substring ~A must be of length ~D > 0" + substring (length substring)) + (with-output-to-string (stream) + (loop with substring-length = (length substring) + for index = 0 then (+ match-index substring-length) + for match-index = (search substring string :start2 index) + do + (write-string string stream :start index :end match-index) + (when match-index + (write-string replacement stream)) + while match-index))) + + +(defun local-ref-to-global-ref (lref) + (when lref + (let ((gref (new-global-ref lref))) + #+laster + (flag-special-free-action gref) + (delete-local-ref lref) + gref))) + +(defun local-ref-to-string (lref) + (prog1 + (convert-from-java-string lref) + (delete-local-ref lref))) + +(defun convert-to-java-string (s) + (when s + (try-null (new-string-utf (string s))))) + +(defun convert-from-java-string (s) + (when s + (let ((chars (try-null (get-string-utf-chars s)))) + (prog1 + (ccl::%get-utf-8-cstring chars) + (release-string-utf-chars s chars))))) + +(defun jaref (array index) + (try (get-object-array-element array index))) + +(defun (setf jaref) (val array index) + (try (set-object-array-element array index val))) + +(defun convert-string-arg (s) + "if s is stringp, make into java string, else presume it is a java string and return it" + ;presumably faster than checking if s is a foreign pointer? + (if (or (stringp s) (symbolp s)) + (convert-to-java-string s) + s)) + +(defun process-arg (val type) + (if (string-equal "java.lang.String" type) + `(convert-string-arg ,val) + `(or ,val ccl::+null-ptr+))) + +(defmacro set-arg (args i val type) + `(setf (pref (paref ,args (:* :jvalue) ,i) + ,(jvalue-accessor-from-typename type)) + ,(process-arg val type))) + +(defmacro with-arg-array (arg-array-name args &body body) + (let ((i -1)) + `(%stack-block ((,arg-array-name (* ,(length args) (ccl::record-length :jvalue)))) + ,@(mapcar #'(lambda (arg) + (list 'set-arg arg-array-name (incf i) (first arg) (second arg))) + args) + + ,@body))) + +(defun build-descriptor (params return-type) + (string-append + "(" + (apply #'string-append (mapcar #'(lambda (p) + (type-descriptor-from-typename (second p))) + params)) + ")" + (type-descriptor-from-typename return-type))) + +(defun get-class-and-method-id (class-name method-name descriptor is-static) + (let ((class (local-ref-to-global-ref + (try-null (jni-find-class class-name))))) + (values class + (if is-static + (try-null (get-static-method-id class method-name descriptor)) + (try-null (get-method-id class method-name descriptor)))))) + + +(defun get-class-and-field-id (class-name field-name descriptor is-static) + (let ((class (local-ref-to-global-ref + (try-null (jni-find-class class-name))))) + (values class + (if is-static + (try-null (get-static-field-id class field-name descriptor)) + (try-null (get-field-id class field-name descriptor)))))) + +(defun is-name-of-primitive (s) + (member s '("boolean" "byte" "char" "short" "int" "long" "float" "double" "void") + :test #'string-equal)) + +(defun package-qualified-name (classname packagename) + (cond + ((is-name-of-primitive (subseq classname 0 (position #\< classname))) classname) + ((find #\. classname) classname) ;already qualified, presumably by another package + (t (string-append packagename "." classname)))) + +(defun split-package-and-class (name) + (let ((p (position #\. name :from-end t))) + (unless p (error "must supply package-qualified classname")) + (values (subseq name 0 p) + (subseq name (1+ p))))) + +(defun slot-from-typename (tn) + (let ((prim (assoc tn + '(("boolean" . :z) + ("byte" . :b) + ("char" . :c) + ("short" . :s) + ("int" . :i) + ("long" . :j) + ("float" . :f) + ("double" . :d)) + :test #'string-equal))) + (if prim + (rest prim) + :l))) + +(defun jvalue-accessor-from-typename (tn) + (let ((prim (assoc tn + '(("boolean" . :jvalue.z) + ("byte" . :jvalue.b) + ("char" . :jvalue.c) + ("short" . :jvalue.s) + ("int" . :jvalue.i) + ("long" . :jvalue.j) + ("float" . :jvalue.f) + ("double" . :jvalue.d)) + :test #'string-equal))) + (if prim + (rest prim) + :jvalue.l))) + +(defun name-component-from-typename (tn) + (if (is-name-of-primitive tn) + tn + "object")) + +(defun type-descriptor-from-typename (tn) + (let ((prim (assoc tn + '(("boolean" . "Z") + ("byte" . "B") + ("char" . "C") + ("short" . "S") + ("int" . "I") + ("long" . "J") + ("float" . "F") + ("double" . "D") + ("void" . "V")) + :test #'string-equal))) + (if prim + (rest prim) + (let ((array-depth (count #\< tn)) + (tn-with-slashes (replace-substrings tn "." "/"))) + (if (= 0 array-depth) + (string-append "L" tn-with-slashes ";") + (with-output-to-string (s) + (dotimes (x array-depth) + (write-string "[" s)) + (write-string (type-descriptor-from-typename + (subseq tn-with-slashes 0 (position #\< tn-with-slashes))) s))))))) + +;not an exact reciprocal of type-descriptor-from-typename since reflection uses . not / as separator +(defun typename-from-reflection-type-descriptor (tn) + (let ((prim (assoc tn + '(("Z" . "boolean") + ("B" . "byte") + ("C" . "char") + ("S" . "short") + ("I" . "int") + ("J" . "long") + ("F" . "float") + ("D" . "double") + ("V" . "void")) + :test #'string-equal))) + (if prim + (rest prim) + (let ((array-depth (count #\[ tn))) + (if (= 0 array-depth) + (subseq tn 1 (1- (length tn))) ;strip leading L and trailing ; + (with-output-to-string (s) + (write-string (typename-from-reflection-type-descriptor (subseq tn array-depth)) s) + (dotimes (x array-depth) + (write-string "<>" s)))))))) + +(defun method-name-from-typename (tn static) + (find-symbol (string-upcase (string-append "call-" + (if static "static-" "") + (name-component-from-typename tn) + "-method-a")) :jni)) + +(defun field-get-name-from-typename (tn static) + (find-symbol (string-upcase (string-append "get-" + (if static "static-" "") + (name-component-from-typename tn) + "-field")) :jni)) + +(defun field-set-name-from-typename (tn static) + (find-symbol (string-upcase (string-append "set-" + (if static "static-" "") + (name-component-from-typename tn) + "-field")) :jni)) +(defun process-return (return-type f &key raw-return) + (cond + ((or raw-return (is-name-of-primitive return-type)) f) + ((string-equal "java.lang.String" return-type) `(local-ref-to-string ,f)) + (t `(local-ref-to-global-ref ,f)))) + +;JNI wrapper generators - will create functions in current package +;this needs more docs +(defmacro define-java-function (fname class-name return-type method-name params &key static raw-return) + (let ((this (gensym)) + (class (gensym)) + (id (gensym)) + (args (gensym))) + `(let (,class ,id) + (defun ,fname ,(if static (mapcar #'first params) + (cons this (mapcar #'first params))) + (when (null ,class) + (multiple-value-setq (,class ,id) + (get-class-and-method-id ,(replace-substrings class-name "." "/") + ,method-name ,(build-descriptor params return-type) ,static))) + (with-arg-array ,args ,(mapcar #'(lambda (param) + (list (first param) (second param))) + params) + ,(process-return return-type + `(try (,(method-name-from-typename return-type static) + ,(if static class this) ,id ,args)) + :raw-return raw-return)))))) + +(defmacro define-java-field (getname class-name field-type field-name &key static) + (let ((this (gensym)) + (class (gensym)) + (id (gensym)) + (val (gensym))) + `(let (,class ,id) + (flet ((load-ids () + (when (null ,class) + (multiple-value-setq (,class ,id) + (get-class-and-field-id ,(replace-substrings class-name "." "/") + ,field-name ,(type-descriptor-from-typename field-type) + ,static))))) + (defun ,getname ,(if static () (list this)) + (load-ids) + ,(process-return field-type + `(try (,(field-get-name-from-typename field-type static) + ,(if static class this) ,id)))) + (defun (setf ,getname) ,(if static (list val) (list this val)) + (load-ids) + (try (,(field-set-name-from-typename field-type static) + ,(if static class this) ,id ,(process-arg val field-type))) + ,val))))) + +(defmacro define-java-constructor (fname class-name params) + (let ((class (gensym)) + (id (gensym)) + (args (gensym))) + `(let (,class ,id) + (defun ,fname ,(mapcar #'first params) + (when (null ,class) + (multiple-value-setq (,class ,id) + (get-class-and-method-id ,(replace-substrings class-name "." "/") + "" ,(build-descriptor params "void") nil))) + (with-arg-array ,args ,(mapcar #'(lambda (param) + (list (first param) (second param))) + params) + (local-ref-to-global-ref (try-null (new-object-a ,class ,id ,args)))))))) + +(defun make-func-name (class method params append-param-types) + ;probably a format one-liner that can do this + (let ((base (string-append class "." method))) + (if append-param-types + (string-append base + (let ((param-types (mapcar #'second params))) + (if param-types + (string-append "<" + (reduce #'(lambda (x y) + (string-append x "-" y)) param-types) + ">") + "<>"))) + base))) + +;these just do some name twiddling before calling define-java-xxx above +(defmacro def-jni-function (package-and-class method params return-typename + &key static overloaded raw-return) + (multiple-value-bind (package class) (split-package-and-class package-and-class) + (let* ((fname (make-func-name class method params overloaded)) + (fsym (read-from-string fname))) + `(locally ,(list 'define-java-function + fsym + package-and-class + (package-qualified-name return-typename package) + method + (mapcar #'(lambda (p) + (list (first p) (package-qualified-name (second p) package))) + params) + :static static :raw-return raw-return))))) + +(defmacro def-jni-functions (package-and-class &rest decls) + `(locally ,@(mapcar #'(lambda (decl) + (list* 'def-jni-function package-and-class decl)) + decls))) + +(defmacro def-jni-constructor (package-and-class params &key overloaded) + (multiple-value-bind (package class) (split-package-and-class package-and-class) + (let* ((fname (make-func-name class "new" params overloaded)) + (fsym (read-from-string fname))) + `(locally ,(list 'define-java-constructor + fsym + package-and-class + (mapcar #'(lambda (p) + (list (first p) (package-qualified-name (second p) package))) + params)))))) + +(defmacro def-jni-field (package-and-class field typename &key static) + (multiple-value-bind (package class) (split-package-and-class package-and-class) + (let ((getsym (read-from-string (string-append class "." field + (if static "-accessor" "")))) + (macsym (read-from-string (string-append class "." field)))) + `(locally + ,(list 'define-java-field getsym package-and-class + (package-qualified-name typename package) field :static static) + ,(when static + `(define-symbol-macro ,macsym (,getsym))))))) + +;we're going to use a little Java to do exception handling below +(def-jni-function "java.lang.Object" + "toString" () "String") + +(def-jni-function "java.lang.reflect.InvocationTargetException" + "getTargetException" () "java.lang.Throwable") + +(def-jni-functions "java.lang.Throwable" + ("getMessage" () "String") + ("getStackTrace" () "StackTraceElement<>")) + +(defmacro do-jarray ((x array) &body body) + (let ((gcount (gensym)) + (gi (gensym)) + (garray (gensym))) + `(let* ((,garray ,array) + (,gcount (get-array-length ,garray))) + (dotimes (,gi ,gcount) + (let ((,x (jaref ,garray ,gi))) + ,@body))))) + +#|| +It is critical that if you call a JNI function that might throw an exception that you clear it, +otherwise the next Java call you make will cause a crash +||# + +(defun handle-exception () + (let ((e (exception-occurred))) + (when (not (ccl:%null-ptr-p e)) ;allow for safe calling in non-exceptional state + (exception-clear) + ;if the exception occurs in the reflection target, we really want that + (when (is-instance-of e (jni-find-class "java/lang/reflect/InvocationTargetException")) + (setf e (invocationtargetexception.gettargetexception e))) + (error "~A" (with-output-to-string (s) + (format s "~A~%" (object.tostring e)) + (do-jarray (x (throwable.getstacktrace e)) + (format s "~A~%" (object.tostring x)))))))) + + + + + +(defun try-neg (result) + (if (minusp result) + (handle-exception) + result)) + + +) + + Index: /branches/new-random/examples/mswin.lisp =================================================================== --- /branches/new-random/examples/mswin.lisp (revision 13309) +++ /branches/new-random/examples/mswin.lisp (revision 13309) @@ -0,0 +1,207 @@ +;;;-*-Mode: LISP; Package: ccl -*- +;;; +;;; Copyright (C) 2008, Clozure Associates and contributors +;;; This file is part of OpenMCL. +;;; +;;; OpenMCL is licensed under the terms of the Lisp Lesser GNU Public +;;; License , known as the LLGPL and distributed with OpenMCL as the +;;; file "LICENSE". The LLGPL consists of a preamble and the LGPL, +;;; which is distributed with OpenMCL as the file "LGPL". Where these +;;; conflict, the preamble takes precedence. +;;; +;;; OpenMCL is referenced in the preamble as the "LIBRARY." +;;; +;;; The LLGPL is also available online at +;;; http://opensource.franz.com/preamble.html + +;;; This is very preliminary and very much a work-in-progress. + +(in-package "CL-USER") + +;;; This is a simple demo that creates an almost totally uninteresting +;;; window and does limited event handling. It's intended to excercise +;;; Clozure CL's FFI a little and to serve as a proof of the concept +;;; that Windows GUI programming is possible. It's not necessarily +;;; a good way to create or manage a window or a good way to structure +;;; a program or much of anything else ... + +(eval-when (:compile-toplevel :load-toplevel :execute) + (open-shared-library "user32.dll")) + +;;; This function is called by Windows to process events ("messages") +;;; for a given class of window. (It's specified when the window +;;; class is registered; see below.) Note that - on Win32 -most +;;; Windows API functions and the functions that they call follow an +;;; unusual calling sequence in which the callee pops its arguments +;;; off of the stack before returning; this is indicated by the +;;; keyword :DISCARD-STACK-ARGS in the DEFCALLBACK argument list. + +(defcallback simple-wndproc (;; See comment above. + :discard-stack-args + ;: the window to which this message is directed, + ;; of a null pointer if the message isn't + ;; directed to a window: + #>HWND hwnd + ;; An integer which idenfifies the type + ;; of message, usually matching a + ;; predefined constant whose name starts + ;; with WM_ : + #>UINT msg + ;; A parameter to the message. In 16-bit + ;; Windows, this was a 16-bit integer and + ;; therefore couldn't convey much information. + ;; On 32 and 64-bit Windows, it's a 32-bit + ;; integer and therefore -could- contain + ;; more information, but usually doesn't ... + ;; Its value (and how it should be interpreted) + ;; depend on the value of "msg": + #>WPARAM wparam + ;; Another parameter, as wide as a pointer + ;; is (and sometimes used as a pointer.): + #>LPARAM lparam + ;; The callback function should return a + ;; pointer-sized (32/64-bit) integer: 0 + ;; to indicate that the message was + ;; handled, and non-zero otherwise. + #>LRESULT) + ;; At a bare minimum, a windows message procedure (wndproc) like this + ;; one should handle the the WM_DESTROY message; if we actually did + ;; any drawing of the window's content, we should handle WM_PAINT + ;; messages, ... + ;; There are a fairly large number of other message constants that + ;; we could receive; if we don't want to handle them ourselves - and + ;; in this simple example, we don't - we can just pass all of our + ;; arguments to the default window procedure and return whatever it + ;; returns. + #+debug (format t "~& hwnd = ~s, msg = ~s, wparam = ~s, lparam = ~x" + hwnd msg wparam lparam) + (cond ((eql msg #$WM_DESTROY) + ;; If there were resources attached to the window - bitmaps, + ;; etc. - we'd want to free them here. Posting a quit message + ;; (WM_QUIT) will arrange that we receive a WM_QUIT messsage + ;; in very short order. + (#_PostQuitMessage 0) ; exit status 0: all is well. + 0) ; and we'll return 0 + (t + ;; In a more realistic example, we'd handle more cases here. + ;; Like many functions that deal with characters and strings, + ;; DefWindowProc is actually implemented as two functions: + ;; DefWindowProcA is the "ANSI" (8-bit character) version, + ;; and DefWindowProcW is the wide-character (UTF-16LE) + ;; version. + (#_DefWindowProcA hwnd msg wparam lparam)))) + + +;;; Register a named window class. ("class" in this sense has nothing to +;;; do with CLOS or any other object system: windows of the same class +;;; share a common window procedure callback and other attributes, which +;;; we define here.) +;;; If the registration attempt is succesful, it'll return an "atom" +;;; (a small integer that identifies the registered class); otherwise, +;;; it returns 0. +(defvar *simple-window-class-atom* nil) + +(defun register-simple-window-class (class-name) + ;; We'll use an ANSI version that accepts a simple C string as the + ;; class name. + (or *simple-window-class-atom* + (setq *simple-window-class-atom* + (with-cstrs ((cname class-name)) + (rlet ((wc #>WNDCLASSEX)) ; an "extended" WNDCLASS structure + (setf (pref wc #>WNDCLASSEX.cbSize) (ccl::record-length #>WNDCLASSEX) + (pref wc #>WNDCLASSEX.style) (logior #$CS_HREDRAW #$CS_VREDRAW) + (pref wc #>WNDCLASSEX.lpfnWndProc) simple-wndproc + (pref wc #>WNDCLASSEX.cbClsExtra) 0 + (pref wc #>WNDCLASSEX.cbWndExtra) 0 + (pref wc #>WNDCLASSEX.hInstance) (#_GetModuleHandleA (%null-ptr)) + (pref wc #>WNDCLASSEX.hIcon) (%null-ptr) + (pref wc #>WNDCLASSEX.hCursor) (#_LoadCursorA (%null-ptr) #$IDC_ARROW) + (pref wc #>WNDCLASSEX.hbrBackground) (#_GetStockObject #$WHITE_BRUSH) + (pref wc #>WNDCLASSEX.lpszMenuName) (%null-ptr) + (pref wc #>WNDCLASSEX.lpszClassName) cname + (pref wc #>WNDCLASSEX.hIconSm) (%null-ptr)) + (let* ((atom (#_RegisterClassExA wc))) + (if (eql 0 atom) + (let* ((err (#_GetLastError))) + (error "Error registering windows class ~s: ~d (~a)" class-name + err + (ccl::%windows-error-string err)))) + atom)))))) + +;;; Main function: register a window class, make an instance of that +;;; class, handle events for that window until it's closed. +(defun make-simple-ms-window () + (let* ((class-atom (register-simple-window-class "very-simple"))) + (with-cstrs ((title "Look! A window!")) + (let* ((hwnd (#_CreateWindowExA 0 ;extended style + (%int-to-ptr class-atom) ; class name/atom + title + (logior #$WS_EX_COMPOSITED #$WS_OVERLAPPEDWINDOW) ; style + #$CW_USEDEFAULT ; x pos + #$CW_USEDEFAULT ; y pos + #$CW_USEDEFAULT ; width + #$CW_USEDEFAULT ; height + (%null-ptr) ;parent window + (%null-ptr) ; menu handle + (#_GetModuleHandleA (%null-ptr)) ; us + (%null-ptr)))) ;info for MDI parents/children + (when (%null-ptr-p hwnd) + (error "CreateWindow failed: ~a" (ccl::%windows-error-string (#_GetLastError)))) + ;; Depending on how the lisp process was created, the first call + ;; to #_ShowWindow in that process might ignore its argument + ;; (and instead use an argument specified in the STARTUPINFO + ;; structure passed to #_CreateProcess.) SLIME under FSF Emacs + ;; runs the lisp with this flag set, and it's possible to waste + ;; a week or two trying to track this down. (Trust me.) + (#_ShowWindow hwnd #$SW_SHOW) + ;; In case the parent process said to ignore #_ShowWindow's argument + ;; the first time it's called, call #_ShowWindow again. This seems + ;; to be harmless, if a little strange ... + (#_ShowWindow hwnd #$SW_SHOW) + (#_UpdateWindow hwnd) + ;; Loop, fetching messages, translating virtual key events + ;; into character-oriented events and dispatching each + ;; message until #_GetMessageA returns 0. + (rlet ((msg #>MSG)) + (do* ((result (#_GetMessageA msg + (%null-ptr) ; for any window created by this thread) + 0 + 0) + (#_GetMessageA msg (%null-ptr) 0 0))) + ((eql 0 result) ; message was WM_QUIT + (pref msg #>MSG.wParam)) + (cond ((< result 0) + (let* ((error (#_GetLastError))) + (format t "~& GetMessage: error = ~d (~a)" error + (ccl::%windows-error-string error))) + (return)) + (t + (#_TranslateMessage msg) + (#_DispatchMessageA msg))))))))) + + +#|| + +;;; At the moment, attempts to create a window when running under SLIME +;;; fail for unknown reasons. If those reasons have anything to do with +;;; the lisp process's "WindowStation" or the current thread's "Desktop" +;;; objects, these functions (which return information about those objects) +;;; may be useful. + +(defun get-ws-info (ws) + (rlet ((flags #>USEROBJECTFLAGS)) + (unless (eql 0 (#_GetUserObjectInformationA ws #$UOI_FLAGS flags (ccl::record-length #>USEROBJECTFLAGS) (%null-ptr))) + (pref flags #>USEROBJECTFLAGS.dwFlags)))) + +;;; This only works on Vista or later. +(defun get-desktop-info (desktop) + (rlet ((pbool #>BOOLEAN #$false)) + (if (eql 0 (#_GetUserObjectInformationA desktop 6 pbool (ccl::record-length #>BOOLEAN) (%null-ptr))) + (ccl::%windows-error-string (#_GetLastError)) + (pref pbool #>BOOLEAN)))) + +(defun get-ui-object-name (handle) + (%stack-block ((name 1000)) + (unless (eql 0 (#_GetUserObjectInformationA handle #$UOI_NAME name 1000 (%null-ptr))) + (%get-cstring name)))) +||# Index: /branches/new-random/examples/opengl-ffi.lisp =================================================================== --- /branches/new-random/examples/opengl-ffi.lisp (revision 13309) +++ /branches/new-random/examples/opengl-ffi.lisp (revision 13309) @@ -0,0 +1,160 @@ +;;; Example openmcl FFI by hamlink +;;; +;;; 2d Gasket example taken from +;;; "Interactive Computer Graphics: +;;; A Top-Down Approach with OpenGL" by Ed Angel + +(eval-when (:compile-toplevel :load-toplevel :execute) + (ccl:use-interface-dir :GL)) + +(defpackage "2DGASKET") +(defpackage "OPENGL" + (:nicknames :opengl :gl) + (:export "INITIALIZE-GLUT" + "WITH-MATRIX-MODE")) + +;;; Opening "libglut.so" should also open "libGL.so", "libGLU.so", +;;; and other libraries that they depend on. +;;; It seems that it does on some platforms and not on others; +;;; explicitly open what we require here. +(eval-when (:compile-toplevel :load-toplevel :execute) + #+linux-target + (dolist (lib '("libGL.so" "libGLU.so" "libglut.so")) + (open-shared-library lib)) + #+darwin-target + (let* ((s (make-semaphore))) + (process-interrupt ccl::*initial-process* + (lambda () + (open-shared-library "GLUT.framework/GLUT") + (signal-semaphore s))) + (wait-on-semaphore s)) + ) + +(in-package :opengl) + +;; glut complains if it's initialized redundantly +(let ((glut-initialized-p nil)) + (defun initialize-glut () + (let ((command-line-strings (list "ccl"))) + (when (not glut-initialized-p) + (ccl::with-string-vector (argv command-line-strings) + (rlet ((argvp (* t)) ; glutinit takes (* (:signed 32)) and (* (* (:unsigned 8))) + (argcp :signed)) ; so why are these declared as (* t) and :signed? + (setf (%get-long argcp) (length command-line-strings) + (%get-ptr argvp) argv) + (#_glutInit argcp argvp))) + (setf glut-initialized-p t)))) + ;; When a saved image is restarted, it needs to know that glut + ;; hasn't been initialized yet. + (defun uninitialize-glut () + (setf glut-initialized-p nil)) + ) + +(pushnew #'uninitialize-glut ccl::*save-exit-functions* + :key #'ccl::function-name) + +(defparameter *matrix-mode* #$GL_MODELVIEW) +(defmacro with-matrix-mode (mode &body body) + `(unwind-protect + (let ((*matrix-mode* ,mode)) + (#_glMatrixMode *matrix-mode*) + ,@body) + (#_glMatrixMode *matrix-mode*))) + +(in-package :2dgasket) + +(defun myinit () + (#_glClearColor 1.0 1.0 1.0 0.0) ; white background + (#_glColor3f 1.0 0.0 0.0) ; red pen color + + (opengl:with-matrix-mode #$GL_PROJECTION + (#_glLoadIdentity) + (#_gluOrtho2D 0.0D0 500.0D0 0.0D0 500.0D0)) + + ; (#_glEnable #$GL_DEPTH_TEST) ; for 3d only + + (#_srand (#_time (%null-ptr))) + ) + +;; 2d gasket using points + +(ccl::defcallback display-cb (:void) + (let ((bounds #2a((0.0 0.0) (250.0 500.0) (500.0 0.0))) + (point #(75.0 50.0))) + (#_glClear #$GL_COLOR_BUFFER_BIT) + (#_glBegin #$GL_POINTS) + (dotimes (i 5000) + (let ((j (random 3))) + (setf (aref point 0) (/ (+ (aref point 0) (aref bounds j 0)) 2.0) + (aref point 1) (/ (+ (aref point 1) (aref bounds j 1)) 2.0)) + (#_glVertex2f (aref point 0) (aref point 1)))) + (#_glEnd) + (#_glFlush))) + +(defun main () ; no int argc or char **argv + (opengl:initialize-glut) + (#_glutInitDisplayMode (logior #$GLUT_RGB + #$GLUT_SINGLE + #+ignore #$GLUT_DEPTH)) + (#_glutInitWindowSize 500 500) + (#_glutInitWindowPosition 0 0) + (ccl::with-cstrs ((title "simple OpenGL example")) + (#_glutCreateWindow title)) + (#_glutDisplayFunc display-cb) + (myinit) + + ;; It appears that glut provides no mechanism for doing the event loop + ;; yourself -- if you want to do that, you should use some other set of + ;; libraries and make your own GUI toolkit. + + (#_glutMainLoop) ; this never returns + ) + + +;;; With native threads, #_glutMainLoop doesn't necessarily interfere +;;; with scheduling: we can just run all of the OpenGL code in a +;;; separate thread (which'll probably spend most of its time blocked +;;; in GLUT's event loop.) On OSX (especially) it may work best to +;;; force the GLUT event loop to run on the main thread, which +;;; ordinarily does period "housekeeping" tasks. Start another thread +;;; to do those tasks, and force the initial/main thread to run the +;;; GLUT event loop. +;;; + +;;; Try to detect cases where we're already running some sort of event +;;; loop on OSX. There are other ways to lose, of course. + +#+darwin-target +(progn + (eval-when (:compile-toplevel :execute) + (use-interface-dir :cocoa)) + ;; If the current (window system) process is visible (has a UI), + ;; we can't possibly win. + (rlet ((psn #>ProcessSerialNumber)) + (and (eql 0 (#_GetCurrentProcess psn)) + (not (eql #$false (#_IsProcessVisible psn))) + (error "This is a GLUT example; it can't possibly work ~ + in a GUI environment.")))) +(progn + (ccl:process-run-function + "housekeeping" + #'ccl::housekeeping-loop) + (ccl:process-interrupt + ccl::*initial-process* + (lambda () + ;; CCL::%SET-TOPLEVEL is sort of like PROCESS-PRESET for the + ;; initial process; CCL::TOPLEVEL is sort of like PROCESS-RESET + ;; for that process. + (ccl::%set-toplevel + (lambda () + ;;; Set the OSX Window Server's notion of the name of the + ;;; current process. + (rlet ((psn #>ProcessSerialNumber)) + (#_GetCurrentProcess psn) + (with-cstrs ((name "simple OpenGL example")) + (ccl::external-call "_CPSSetProcessName" :address psn :address name :void))) + (ccl::%set-toplevel nil) + (main))) + (ccl::toplevel)))) + + Index: /branches/new-random/examples/rubix/.cvsignore =================================================================== --- /branches/new-random/examples/rubix/.cvsignore (revision 13309) +++ /branches/new-random/examples/rubix/.cvsignore (revision 13309) @@ -0,0 +1,1 @@ +*~.* Index: /branches/new-random/examples/rubix/blocks.lisp =================================================================== --- /branches/new-random/examples/rubix/blocks.lisp (revision 13309) +++ /branches/new-random/examples/rubix/blocks.lisp (revision 13309) @@ -0,0 +1,410 @@ +(in-package :cl-user) + +(defparameter *cube* nil) + +(defparameter *camera-pos* #(10.0 5.0 12.0)) + +(defparameter *selection-buffer-size* 256) + +;; some things have no scale or rotation, such as point light sources +;; (note lights use a 4d vector to hold both positoin and pointsourceness) +(defclass positioned-object () + ((location :initform nil :initarg :location :accessor location)) + (:default-initargs :location (make-array 3 :initial-element 0.0))) + +(defmethod move-relative ((obj positioned-object) v) + (add-vectors (location obj) v (location obj)) + (location obj)) +(defmethod move-relative-3 ((obj positioned-object) dx dy dz) + (incf (elt (location obj) 0) dx) + (incf (elt (location obj) 1) dy) + (incf (elt (location obj) 2) dz) + (location obj)) +(defmethod move-absolute ((obj positioned-object) p) + (dotimes (i 3) (setf (elt (location obj) i) (elt p i))) + (location obj)) +(defmethod move-absolute-3 ((obj positioned-object) x y z) + (setf (elt (location obj) 0) x + (elt (location obj) 1) y + (elt (location obj) 2) z) + (location obj)) + +(defmethod gl-translate ((obj positioned-object)) + (#_glTranslatef (elt (location obj) 0) + (elt (location obj) 1) + (elt (location obj) 2))) + +(defclass rotated-object () + ((quaternion :initform nil :initarg :quaternion :accessor quaternion)) + (:default-initargs :quaternion (make-instance 'quaternion))) + +(defmethod rotate-relative ((obj rotated-object) quaternion) + ;; recall mulquats applies q2's rotation first... + (mulquats quaternion (quaternion obj) (quaternion obj)) + (quaternion obj)) +(defmethod rotate-absolute ((obj rotated-object) quaternion) + (setf (w (quaternion obj)) (w quaternion)) + (dotimes (i 3) + (setf (elt (xyz (quaternion obj)) i) (elt quaternion i))) + (quaternion obj)) + +(defmethod gl-rotate ((obj rotated-object)) + (let ((axis-angle (quat->axis-angle (quaternion obj)))) + (#_glRotatef (cdr axis-angle) + (elt (car axis-angle) 0) + (elt (car axis-angle) 1) + (elt (car axis-angle) 2)))) + +(defclass scaled-object () + ((dilation :initform nil :initarg :dilation :accessor dilation)) + (:default-initargs :dilation (make-array 3 :initial-element 1.0))) + +(defmethod gl-scale ((obj scaled-object)) + (#_glScalef (elt (dilation obj) 0) + (elt (dilation obj) 1) + (elt (dilation obj) 2))) + +(defclass transformed-object (positioned-object + rotated-object + scaled-object) + ()) + +(defmacro with-transformation ((transformed-object) &body body) + (let ((tobj-sym (gensym))) + `(let ((,tobj-sym ,transformed-object)) + (#_glPushMatrix) + (gl-translate ,tobj-sym) + (gl-rotate ,tobj-sym) + (gl-scale ,tobj-sym) + ,@body + (#_glPopMatrix)))) + +(defmethod render ((obj transformed-object)) ; should this be on something else? + (#_glMatrixMode #$GL_MODELVIEW) + (with-transformation (obj) + (render-children obj))) + +(defclass block (transformed-object) + (;; need to generate matrices of this form so that copy-ivector-etc will work + (vertices :initform (coerce + (list (make-array 3 :initial-contents '(-0.5 -0.5 0.5) + :element-type 'single-float) + (make-array 3 :initial-contents '( 0.5 -0.5 0.5) + :element-type 'single-float) + (make-array 3 :initial-contents '( 0.5 0.5 0.5) + :element-type 'single-float) + (make-array 3 :initial-contents '(-0.5 0.5 0.5) + :element-type 'single-float) + (make-array 3 :initial-contents '(-0.5 -0.5 -0.5) + :element-type 'single-float) + (make-array 3 :initial-contents '( 0.5 -0.5 -0.5) + :element-type 'single-float) + (make-array 3 :initial-contents '( 0.5 0.5 -0.5) + :element-type 'single-float) + (make-array 3 :initial-contents '(-0.5 0.5 -0.5) + :element-type 'single-float)) + 'vector) + :initarg :vertices :accessor vertices + ;; :allocation :class + ))) + +;; I expect that especially with the FFI overhead, one call to render +;; a static object's prefabbed display list will beat out a lot of +;; calls to render the various portions... this will be an interesting +;; conversionn and test going from code to DL, and good prep for +;; moving from DL-creating code to DL file readers +#+ignore +(defmethod render-children ((obj block)) + (let ((curve-radius 0.1)) ; 90-degree curve in 3 sections for edges and for corners + ;; strip for faces 0134 and their edges + ;; strip for face 2 and edges to 0 and 3 + ;; strip for face 5 and edges to 0 and 3 + ;; edges 15, 54, 42, and 21 + ;; corner + )) + +(defmethod render-children ((obj block)) + (flet ((norm (axis) (#_glNormal3f (aref axis 0) (aref axis 1) (aref axis 2))) + (material (color) + (ccl::%stack-block ((foreign-float-vector (* 4 4))) ; make room for 4 double-floats + (ccl::%copy-ivector-to-ptr color + 0 ; offset to first element (alignment padding) + foreign-float-vector ; destination + 0 ; byte offset in destination + (* 4 4)) ; number of bytes to copy + (#_glMaterialfv #$GL_FRONT_AND_BACK + #$GL_AMBIENT_AND_DIFFUSE + foreign-float-vector))) + (quad (a b c d) + (ccl::%stack-block ((ffv (* 4 3))) + (ccl::%copy-ivector-to-ptr (aref (vertices obj) a) 0 ffv 0 (* 4 3)) + (#_glVertex3fv ffv)) + (ccl::%stack-block ((ffv (* 4 3))) + (ccl::%copy-ivector-to-ptr (aref (vertices obj) b) 0 ffv 0 (* 4 3)) + (#_glVertex3fv ffv)) + (ccl::%stack-block ((ffv (* 4 3))) + (ccl::%copy-ivector-to-ptr (aref (vertices obj) c) 0 ffv 0 (* 4 3)) + (#_glVertex3fv ffv)) + (ccl::%stack-block ((ffv (* 4 3))) + (ccl::%copy-ivector-to-ptr (aref (vertices obj) d) 0 ffv 0 (* 4 3)) + (#_glVertex3fv ffv)) + t)) + (opengl:with-gl (#$GL_QUADS) + (norm *x-axis*) (material *hel-orange*) (quad 1 2 6 5) + (norm *y-axis*) (material *hel-yellow*) (quad 2 3 7 6) + (norm *z-axis*) (material *hel-green*) (quad 0 3 2 1) + (norm *neg-x-axis*) (material *hel-red*) (quad 0 4 7 3) + (norm *neg-y-axis*) (material *hel-white*) (quad 0 1 5 4) + (norm *neg-z-axis*) (material *hel-blue*) (quad 4 5 6 7)))) + +(defclass rubix-cube (transformed-object) + ((blocks :initform nil :initarg :blocks :accessor blocks) + (faces :initform nil :initarg :faces :accessor faces) + (faces-axes :initform (coerce (list *neg-x-axis* *neg-y-axis* *neg-z-axis* + *x-axis* *y-axis* *z-axis*) 'vector) + :initarg :faces-axes :reader faces-axes + ;; :allocation :class + ) + (face-turning-p :initform nil :initarg :face-turning-p :accessor face-turning-p) + (turning-face :initform nil :initarg :turning-face :accessor turning-face) + (face-theta :initform nil :initarg :face-theta :accessor face-theta) + ;; vertices for rendering full cube's faces for selection + (vertices :initform (coerce + (list (make-array 3 :initial-contents '(-0.5 -0.5 0.5) + :element-type 'single-float) + (make-array 3 :initial-contents '( 0.5 -0.5 0.5) + :element-type 'single-float) + (make-array 3 :initial-contents '( 0.5 0.5 0.5) + :element-type 'single-float) + (make-array 3 :initial-contents '(-0.5 0.5 0.5) + :element-type 'single-float) + (make-array 3 :initial-contents '(-0.5 -0.5 -0.5) + :element-type 'single-float) + (make-array 3 :initial-contents '( 0.5 -0.5 -0.5) + :element-type 'single-float) + (make-array 3 :initial-contents '( 0.5 0.5 -0.5) + :element-type 'single-float) + (make-array 3 :initial-contents '(-0.5 0.5 -0.5) + :element-type 'single-float)) + 'vector) + :initarg :vertices :reader vertices + ;; :allocation :class + )) + (:default-initargs + :blocks (let ((list nil)) + (loop for x from -1.0 to 1.0 do + (loop for y from -1.0 to 1.0 do + (loop for z from -1.0 to 1.0 do + (push (make-instance 'block + :location (coerce (list (/ x 3.0) + (/ y 3.0) + (/ z 3.0)) 'vector) + :dilation (coerce (list (/ 1.0 3.0) + (/ 1.0 3.0) + (/ 1.0 3.0)) 'vector)) + list)))) + (coerce list 'vector)))) + +(defparameter *child-positions* (let ((list nil)) + (loop for x from -1.0 to 1.0 do + (loop for y from -1.0 to 1.0 do + (loop for z from -1.0 to 1.0 do + (push (coerce (list (/ x 3.0) + (/ y 3.0) + (/ z 3.0)) 'vector) + list)))) + (coerce list 'vector))) + +;; blocks in faces start at a corner, go clockwise around the face, +;; and finish in the center; blocks in the cube are numbered to +;; correspond to *child-positions*; faces that share blocks are +;; associated in faces-neighbors -- all 3 of these variables depend on +;; each other +(defparameter *initial-blocks-in-faces* #2a((0 1 2 5 8 7 6 3 4) + (0 9 18 19 20 11 2 1 10) + (0 3 6 15 24 21 18 9 12) + (26 23 20 19 18 21 24 25 22) + (26 25 24 15 6 7 8 17 16) + (26 17 8 5 2 11 20 23 14))) + +(defmethod shared-initialize :after ((obj rubix-cube) slot-names &key) + (declare (ignore slot-names)) + (setf (faces obj) (make-array (list 6 9))) + (dotimes (face 6) + (dotimes (blok 9) + (setf (aref (faces obj) face blok) + (aref (blocks obj) (aref *initial-blocks-in-faces* face blok)))))) + +(let ((faces-neighbors #2a((1 5 4 2) + (2 3 5 0) + (0 4 3 1) + (5 1 2 4) + (3 2 0 5) + (4 0 1 3)))) + (defun faces-neighbor (face neighbor) + (aref faces-neighbors face neighbor)) + (defun faces-index-from-neighbor (face neighbor) + (loop for i from 0 to 3 do + (when (= face (faces-neighbor (faces-neighbor face neighbor) i)) + (return i)))) + ) + +(defmethod turnfaceclockwise ((cube rubix-cube) face &aux temp) + (with-slots (faces) cube + ;; rotate blocks through adjacent faces + (dotimes (neighbor 4) + (let* ((neighbors-face (faces-neighbor face neighbor)) + (my-index (faces-index-from-neighbor face neighbor)) + (my-block-index (* 2 my-index)) + (his-new-block-index (* 2 (mod (+ neighbor 3) 4)))) + (setf (aref faces neighbors-face (mod my-block-index 8)) + (aref faces face (mod (+ 2 his-new-block-index) 8))) + (setf (aref faces neighbors-face (mod (1+ my-block-index) 8)) + (aref faces face (mod (1+ his-new-block-index) 8))) + (setf (aref faces neighbors-face (mod (+ 2 my-block-index) 8)) + (aref faces face (mod his-new-block-index 8))))) + ;; rotate blocks in this face + (setf temp (aref faces face 0) + (aref faces face 0) (aref faces face 6) + (aref faces face 6) (aref faces face 4) + (aref faces face 4) (aref faces face 2) + (aref faces face 2) temp + temp (aref faces face 1) + (aref faces face 1) (aref faces face 7) + (aref faces face 7) (aref faces face 5) + (aref faces face 5) (aref faces face 3) + (aref faces face 3) temp) + ;; update positions and orientation of blocks in this face + (dotimes (i 9) + (move-absolute (aref faces face i) + (elt *child-positions* (aref *initial-blocks-in-faces* face i))) + (rotate-relative (aref faces face i) + (axis-angle->quat (aref (faces-axes cube) face) + 90.0))) + )) + +(defmethod turnfacecounterclockwise ((cube rubix-cube) face &aux temp) + (with-slots (faces) cube + ;; rotate blocks through adjacent faces + (dotimes (neighbor 4) + (let* ((neighbors-face (faces-neighbor face neighbor)) + (my-index (faces-index-from-neighbor face neighbor)) + (my-block-index (* 2 my-index)) + (his-new-block-index (* 2 (mod (+ neighbor 1) 4)))) + (setf (aref faces neighbors-face (mod my-block-index 8)) + (aref faces face (mod (+ 2 his-new-block-index) 8))) + (setf (aref faces neighbors-face (mod (1+ my-block-index) 8)) + (aref faces face (mod (1+ his-new-block-index) 8))) + (setf (aref faces neighbors-face (mod (+ 2 my-block-index) 8)) + (aref faces face (mod his-new-block-index 8))))) + ;; rotate blocks in this face + (setf temp (aref faces face 0) + (aref faces face 0) (aref faces face 2) + (aref faces face 2) (aref faces face 4) + (aref faces face 4) (aref faces face 6) + (aref faces face 6) temp + temp (aref faces face 1) + (aref faces face 1) (aref faces face 3) + (aref faces face 3) (aref faces face 5) + (aref faces face 5) (aref faces face 7) + (aref faces face 7) temp) + ;; update positions and orientation of blocks in this face + (dotimes (i 9) + (move-absolute (aref faces face i) + (elt *child-positions* (aref *initial-blocks-in-faces* face i))) + (rotate-relative (aref faces face i) + (axis-angle->quat (aref (faces-axes cube) face) + -90.0))) + )) + +(defmethod render-children ((obj rubix-cube)) + (flet ((in-face-p (face blok) + (dotimes (i 9) + (when (eq (aref (blocks obj) blok) + (aref (faces obj) face i)) + (return t))))) + (cond ((not (face-turning-p obj)) + (dotimes (blok 27) + (render (aref (blocks obj) blok)))) + (t + (dotimes (blok 27) + (unless (in-face-p (turning-face obj) blok) + (render (aref (blocks obj) blok)))) + (opengl:with-rotation ((face-theta obj) + (aref (faces-axes obj) (turning-face obj))) + (dotimes (blok 9) + (render (aref (faces obj) (turning-face obj) blok)))))))) + + +(defmethod render-for-selection ((objc rubix-cube) picked-point) + (let ((gl-uint-size (ccl::foreign-size :uint :bytes)) ; 4, as it turns out... + (selection-buffer-size 256)) + (ccl::%stack-block ((selection-buffer (* gl-uint-size selection-buffer-size))) + (#_glSelectBuffer selection-buffer-size selection-buffer) + (let (;; FYI - this loses a lot of structure and becomes a lot + ;; longer in C++ for lack of macros + (hits (opengl:with-render-mode (#$GL_SELECT) + (#_glInitNames) + (#_glPushName 0) + (opengl:with-culling (#$GL_FRONT) + ;; set up the modified camera looking around the mouse's region + (opengl:with-matrix-mode (#$GL_PROJECTION) + (opengl:with-matrix (t) + (#_glFrustum -0.01d0 0.01d0 -0.01d0 0.01d0 10.0d0 20.0d0) + (opengl:with-matrix-mode (#$GL_MODELVIEW) + (opengl:with-matrix (t) + (mylookat *camera-pos* picked-point *y-axis*) + ;; NOW render the cube like we were doing before + (opengl:with-matrix-mode (#$GL_MODELVIEW) + (with-transformation (objc) + (render-children-for-selection objc))))))) + (#_glFlush))))) + (when (and (numberp hits) + (< 0 hits)) + ;; the first hit name is at selectBuf[3], though i don't recall why + (ccl::%get-unsigned-long selection-buffer (* 3 4))))))) + +(defmethod render-children-for-selection ((objc rubix-cube)) + (flet ((norm (axis) (#_glNormal3f (aref axis 0) (aref axis 1) (aref axis 2))) + (material (color) + (ccl::%stack-block ((foreign-float-vector (* 4 4))) ; make room for 4 single-floats + (ccl::%copy-ivector-to-ptr color + 0 ; offset to first element (alignment padding) + foreign-float-vector ; destination + 0 ; byte offset in destination + (* 4 4)) ; number of bytes to copy + (#_glMaterialfv #$GL_FRONT_AND_BACK + #$GL_AMBIENT_AND_DIFFUSE + foreign-float-vector))) + (quad (a b c d) + (ccl::%stack-block ((ffv (* 4 3))) + (ccl::%copy-ivector-to-ptr (aref (vertices objc) a) 0 ffv 0 (* 4 3)) + (#_glVertex3fv ffv)) + (ccl::%stack-block ((ffv (* 4 3))) + (ccl::%copy-ivector-to-ptr (aref (vertices objc) b) 0 ffv 0 (* 4 3)) + (#_glVertex3fv ffv)) + (ccl::%stack-block ((ffv (* 4 3))) + (ccl::%copy-ivector-to-ptr (aref (vertices objc) c) 0 ffv 0 (* 4 3)) + (#_glVertex3fv ffv)) + (ccl::%stack-block ((ffv (* 4 3))) + (ccl::%copy-ivector-to-ptr (aref (vertices objc) d) 0 ffv 0 (* 4 3)) + (#_glVertex3fv ffv)) + t)) + (#_glLoadName 0) + (opengl:with-gl (#$GL_QUADS) + (norm *x-axis*) (material *hel-orange*) (quad 1 2 6 5)) + (#_glLoadName 1) + (opengl:with-gl (#$GL_QUADS) + (norm *y-axis*) (material *hel-yellow*) (quad 2 3 7 6)) + (#_glLoadName 2) + (opengl:with-gl (#$GL_QUADS) + (norm *z-axis*) (material *hel-green*) (quad 0 3 2 1)) + (#_glLoadName 3) + (opengl:with-gl (#$GL_QUADS) + (norm *neg-x-axis*) (material *hel-red*) (quad 0 4 7 3)) + (#_glLoadName 4) + (opengl:with-gl (#$GL_QUADS) + (norm *neg-y-axis*) (material *hel-white*) (quad 0 1 5 4)) + (#_glLoadName 5) + (opengl:with-gl (#$GL_QUADS) + (norm *neg-z-axis*) (material *hel-blue*) (quad 4 5 6 7)))) Index: /branches/new-random/examples/rubix/lights.lisp =================================================================== --- /branches/new-random/examples/rubix/lights.lisp (revision 13309) +++ /branches/new-random/examples/rubix/lights.lisp (revision 13309) @@ -0,0 +1,79 @@ +(in-package :cl-user) + +;; ah, lights, one of my favorite subjects in OpenGL -- because they way +;; they work when you're using C++ stinks! I seem to recall i have extensive +;; discussions of how i would rather deal with TL&M if i was using lisp in +;; one of my code files somewhere, but first let me get it working then i can +;; get it working properly + +(defclass light () + ((lightid :initform 0 :initarg :lightid :accessor lightid) + (on-p :initform nil :accessor on-p) + (pointsourcep :initform nil :initarg :pointsourcep :accessor pointsourcep) + (location :initform nil :initarg :location :accessor location) + (ambient :initform nil :initarg :ambient :accessor ambient) + (diffuse :initform nil :initarg :diffuse :accessor diffuse) + (specular :initform nil :initarg :specular :accessor specular)) + (:default-initargs :location (make-array 4 :initial-element 0.0 ; lights are special! + :element-type 'single-float) + :ambient (make-array 4 :initial-element 0.0 + :element-type 'single-float) + :diffuse (make-array 4 :initial-element 0.0 + :element-type 'single-float) + :specular (make-array 4 :initial-element 0.0 + :element-type 'single-float))) + +(defmethod on ((light light)) + (#_glEnable (lightid light)) + (setf (on-p light) t)) +(defmethod off ((light light)) + (#_glDisable (lightid light)) + (setf (on-p light) nil)) + +(defmethod setlocation ((light light) pos) + (dotimes (i 3) (setf (elt (location light) i) (elt pos i))) + (ccl::%stack-block ((foreign-float-vector (* 4 4))) ; make room for 4 single-floats + (ccl::%copy-ivector-to-ptr (location light) ; source + 0 ; offset to first element (alignment padding) + foreign-float-vector ; destination + 0 ; byte offset in destination + (* 4 4)) ; number of bytes to copy + (#_glLightfv (lightid light) #$GL_POSITION foreign-float-vector))) +(defmethod setpointsource ((light light) bool) + (setf (pointsourcep light) (if bool t nil) ; <- don't hang on to non-nils + (elt (location light) 3) (if bool 1.0 0.0)) + (ccl::%stack-block ((foreign-float-vector (* 4 4))) ; make room for 4 single-floats + (ccl::%copy-ivector-to-ptr (location light) ; source + 0 ; offset to first element (alignment padding) + foreign-float-vector ; destination + 0 ; byte offset in destination + (* 4 4)) ; number of bytes to copy + (#_glLightfv (lightid light) #$GL_POSITION foreign-float-vector))) + +(defmethod setambient ((light light) color) + (dotimes (i 4) (setf (elt (ambient light) i) (elt color i))) + (ccl::%stack-block ((foreign-float-vector (* 4 4))) ; make room for 4 single-floats + (ccl::%copy-ivector-to-ptr (ambient light) ; source + 0 ; offset to first element (alignment padding) + foreign-float-vector ; destination + 0 ; byte offset in destination + (* 4 4)) ; number of bytes to copy + (#_glLightfv (lightid light) #$GL_AMBIENT foreign-float-vector))) +(defmethod setdiffuse ((light light) color) + (dotimes (i 4) (setf (elt (diffuse light) i) (elt color i))) + (ccl::%stack-block ((foreign-float-vector (* 4 4))) ; make room for 4 single-floats + (ccl::%copy-ivector-to-ptr (diffuse light) ; source + 0 ; offset to first element (alignment padding) + foreign-float-vector ; destination + 0 ; byte offset in destination + (* 4 4)) ; number of bytes to copy + (#_glLightfv (lightid light) #$GL_DIFFUSE foreign-float-vector))) +(defmethod setspecular ((light light) color) + (dotimes (i 4) (setf (elt (specular light) i) (elt color i))) + (ccl::%stack-block ((foreign-float-vector (* 4 4))) ; make room for 4 single-floats + (ccl::%copy-ivector-to-ptr (specular light) ; source + 0 ; offset to first element (alignment padding) + foreign-float-vector ; destination + 0 ; byte offset in destination + (* 4 4)) ; number of bytes to copy + (#_glLightfv (lightid light) #$GL_SPECULAR foreign-float-vector))) Index: /branches/new-random/examples/rubix/loader.lisp =================================================================== --- /branches/new-random/examples/rubix/loader.lisp (revision 13309) +++ /branches/new-random/examples/rubix/loader.lisp (revision 13309) @@ -0,0 +1,15 @@ +(in-package :cl-user) + +(require "COCOA") + +(let* ((containing-dir (make-pathname :directory (pathname-directory *load-truename*) :defaults nil))) + (flet ((load-relative (path) + (load (merge-pathnames path containing-dir)))) + (load-relative "opengl.lisp") + (load-relative "vectors.lisp") + (load-relative "lights.lisp") + (load-relative "blocks.lisp") + (load-relative "rubix.lisp"))) + + +; (gui::execute-in-gui #'run-rubix-demo) Index: /branches/new-random/examples/rubix/opengl.lisp =================================================================== --- /branches/new-random/examples/rubix/opengl.lisp (revision 13309) +++ /branches/new-random/examples/rubix/opengl.lisp (revision 13309) @@ -0,0 +1,173 @@ +(eval-when (:compile-toplevel :load-toplevel :execute) + (ccl:use-interface-dir :GL)) + +;;; Cocoa-based OpenGL package, for handy macros and classes of common +;;; things like transformations, lights, cameras, quaternions, etc. +;;; (note not all of this has been consolidated into this package yet) + +#| + +To use this functionality from cocoa, subclass NSOpenGLView, +specialize drawRect on your class to render whatever you like, +and make an intance in a window. + +|# + +#| +;;; Some design notes for OpenGL programming in lisp... + +OpenGL is a very stateful API. with-X macros are invaluable for +managing OpenGL's stacks and modes. + +The rubix demo is not set up this way, but really the main +objects in a scene need to contain references to their structure, +so that the structure can be reused between identical objects. +For large objects that are not always going to be present, the +structure could be compiled into a fasl and loaded only when +necessary using a sentinel in place of the structure reference. + +Objects should capture the instance-specific state of objects in +a scene and be used to parameterize the drawing of skeleton-based +things. This can get tricky, but generic functions that draw +skeleton structures when passed specific data about the object's +state and the object's structure are probably the way to go. + +Display lists are handy for static models. Something that loaded +easily-edited display list descriptions and turned them into fasl +data that rebuilt the display lists would be useful... if I can +find some EBNF and regexp forms my parser would build the ASTs +that could be turned into objects easily enough and from there +fasl data is easy to generate and save. If the file created a +fasl that set a hash entry from a structure id to a usable opengl +display list that would be good. A function that requested a +structure by id that loaded a file if there was no hash entry +would be slick. + +Since this is lisp, it should be possible to create a display +list or an analogous lexical closure depending on what you want +from the same model information (to be later rendered as a static +object or rendered with a instance-state-driven function). I +don't know how many DLs OpenGL can have at one time or how big +they can be, it'd be good to know. + +|# + +(defpackage "OPENGL" + (:nicknames :opengl :gl) + (:export ;; Cocoa helpers + "WITH-OPENGL-CONTEXT" + "NEW-PIXEL-FORMAT" + ;; OpenGL helpers + "WITH-MATRIX-MODE" + "WITH-RENDER-MODE" + "WITH-ROTATION" + "WITH-GL" + "WITH-CULLING" + "WITH-MATRIX" + "UNPROJECT" + )) + +(in-package :opengl) + +;; WITH-OPENGL-CONTEXT is not needed in the PREPARE-OPENGL +;; and DRAW-RECT functions of a specialized NS-OPENGL-VIEW +(defparameter *opengl-context* nil) +(defmacro with-opengl-context (context &body body) + (let ((contextsym (gensym))) + `(let ((,contextsym ,context)) + (unwind-protect + (let ((*opengl-context* ,contextsym)) + (#/makeCurrentContext ,contextsym) + ,@body) + ;; the following resets the current context to what it was + ;; previously as far as the special bindings are concerned + (if *opengl-context* + (#/makeCurrentContext *opengl-context*) + (#/clearCurrentConext ns:ns-opengl-context)))))) + +(defun new-pixel-format (&rest attributes) + ;; take a list of opengl pixel format attributes (enums and other + ;; small ints), make an array (character array?), and create and + ;; return an NSOpenGLPixelFormat + (let* ((attribute-size (ccl::foreign-size :penixelormatttribute :bytes)) + (nattributes (length attributes))) + (ccl::%stack-block ((objc-attributes (* attribute-size (1+ nattributes)))) + (loop for i from 0 to nattributes + for attribute in attributes do + (setf (ccl:paref objc-attributes (:* :penixelormat ttribute) i) attribute) ; <- autocoerced? + finally (setf (ccl:paref objc-attributes (:* :penixelormat ttribute) nattributes) 0)) ; <- objc nil = null ptr + (make-instance ns:ns-opengl-pixel-format :with-attributes objc-attributes)))) + +#| +(setf pf (opengl:new-pixel-format #$NSOpenGLPFADoubleBuffer #$NSOpenGLPFADepthSize 32)) +(%stack-block ((a-long 4)) + (#/getValues:forAttribute:forVirtualScreen: pf a-long #$NSOpenGLPFADepthSize 0) + (%get-long a-long)) +|# + +(defparameter *matrix-mode* #$GL_MODELVIEW) +(defmacro with-matrix-mode ((mode) &body body) + `(unwind-protect + (let ((*matrix-mode* ,mode)) + (#_glMatrixMode *matrix-mode*) + ,@body) + (#_glMatrixMode *matrix-mode*))) + +(defparameter *render-mode* #$GL_RENDER) +(defmacro with-render-mode ((mode) &body body) + `(block nil + (unwind-protect + (let ((*render-mode* ,mode)) + (#_glRenderMode *render-mode*) + ,@body) + (return (#_glRenderMode *render-mode*))))) + +(defmacro with-rotation ((angle axis) &body body) + (let ((anglesym (gensym)) + (axissym (gensym))) + `(let ((,anglesym ,angle) + (,axissym ,axis)) + (unwind-protect + (with-matrix-mode (#$GL_MODELVIEW) + (#_glPushMatrix) + (#_glRotatef ,anglesym (aref ,axissym 0) (aref ,axissym 1) (aref ,axissym 2)) + ,@body) + (#_glPopMatrix))))) + +(defmacro with-gl ((value) &body body) + `(progn (#_glBegin ,value) + ,@body + (#_glEnd))) + +(defmacro with-culling ((cull-face) &body body) + `(progn (#_glEnable #$GL_CULL_FACE) + (#_glCullFace ,cull-face) + ,@body + (#_glDisable #$GL_CULL_FACE))) + +(defmacro with-matrix ((load-identity-p) &body body) + `(progn (#_glPushMatrix) + ,@(when load-identity-p `((#_glLoadIdentity))) + ,@body + (#_glPopMatrix))) + +(defun unproject (x y) + (let (;; yeah, yeah... I think I know how big these are... + (gl-int-size (ccl::foreign-size :int :bytes)) + (gl-double-size (ccl::foreign-size :double :bytes))) + (ccl::%stack-block ((viewport (* gl-int-size 4)) + (modelview-matrix (* gl-double-size 16)) + (projection-matrix (* gl-double-size 16)) + (wx gl-double-size) + (wy gl-double-size) + (wz gl-double-size)) + (#_glGetIntegerv #$GL_VIEWPORT viewport) + (#_glGetDoublev #$GL_MODELVIEW_MATRIX modelview-matrix) + (#_glGetDoublev #$GL_PROJECTION_MATRIX projection-matrix) + (#_gluUnProject (ccl::%double-float x) (ccl::%double-float y) 0.0d0 + modelview-matrix projection-matrix viewport + wx wy wz) + (coerce (list (ccl::%get-double-float wx) + (ccl::%get-double-float wy) + (ccl::%get-double-float wz)) + 'vector)))) Index: /branches/new-random/examples/rubix/rubix.lisp =================================================================== --- /branches/new-random/examples/rubix/rubix.lisp (revision 13309) +++ /branches/new-random/examples/rubix/rubix.lisp (revision 13309) @@ -0,0 +1,245 @@ +(in-package :cl-user) + + +(defparameter light0 nil) +(defparameter light0-pos (make-array 3 :initial-contents '(5.0 3.0 0.0) ;; default to distant light source + :element-type 'single-float)) +(defparameter diffuse0 (make-array 4 :initial-contents '(0.0 0.0 0.0 1.0) + :element-type 'single-float)) +(defparameter ambient0 (make-array 4 :initial-contents '(1.0 1.0 1.0 1.0) + :element-type 'single-float)) +(defparameter specular0 (make-array 4 :initial-contents '(0.0 0.0 0.0 1.0) + :element-type 'single-float)) + +(defparameter global-ambient (make-array 4 :initial-contents '(1.0 1.0 1.0 1.0) :element-type 'single-float)) ;; really really dim grey light + +(defclass rubix-opengl-view (ns:ns-opengl-view) + () + (:metaclass ns:+ns-object)) + +(objc:defmethod (#/prepareOpenGL :void) ((self rubix-opengl-view)) + (declare (special *the-origin* *y-axis*)) + (opengl:with-matrix-mode (#$GL_PROJECTION) ;; default is GL_MODELVIEW + (#_glLoadIdentity) + (#_glFrustum -0.6d0 0.6d0 -0.6d0 0.6d0 10.0d0 20.0d0)) + (#_glLoadIdentity) + (mylookat *camera-pos* *the-origin* *y-axis*) + + (#_glShadeModel #$GL_SMOOTH) + (#_glClearColor 0.05 0.05 0.05 0.0) + ;; these next three are all needed to enable the z-buffer + (#_glClearDepth 1.0d0) + (#_glEnable #$GL_DEPTH_TEST) + (#_glDepthFunc #$GL_LEQUAL) + (#_glHint #$GL_PERSPECTIVE_CORRECTION_HINT #$GL_NICEST) + + (setf *cube* (make-instance 'rubix-cube)) + + (#_glEnable #$GL_LIGHTING) + + (setf light0 (make-instance 'light :lightid #$GL_LIGHT0)) + (setpointsource light0 t) + (setlocation light0 light0-pos) + (setdiffuse light0 diffuse0) + (setambient light0 ambient0) + (setspecular light0 specular0) + (on light0) + + (ccl::%stack-block ((foreign-float-vector (* 4 4))) ; make room for 4 single-floats + (ccl::%copy-ivector-to-ptr global-ambient ; source + 0 ; offset to first element (alignment padding) + foreign-float-vector ; destination + 0 ; byte offset in destination + (* 4 4)) ; number of bytes to copy + (#_glLightModelfv #$GL_LIGHT_MODEL_AMBIENT foreign-float-vector)) ;; <- coersion issue + + (#_glFlush)) + +(objc:defmethod (#/drawRect: :void) ((self rubix-opengl-view) (a-rect :ns-rect)) + (declare (ignorable a-rect)) + ;; drawing callback + (#_glClear (logior #$GL_COLOR_BUFFER_BIT #$GL_DEPTH_BUFFER_BIT)) + (render *cube*) + (#_glFlush)) + +;; want to be able to send keystrokes to the rubix cube +#+ignore +(objc:defmethod (#/acceptsFirstResponder :) ((self rubix-opengl-view)) + t) + +;; want to be able to click and start dragging (without moving the window) +(objc:defmethod (#/acceptsFirstMouse: :) ((self rubix-opengl-view) + event) + (declare (ignore event)) + t) + + +(defparameter *rubix-face-snap* 8.0) ; degrees + +(objc:defmethod (#/mouseDown: :void) ((self rubix-opengl-view) the-event) + ;; this makes dragging spin the cube + (cond ((zerop (logand #$NSControlKeyMask (#/modifierFlags the-event))) ; not ctrl-click + (let ((dragging-p t)) + (let ((last-loc (#/locationInWindow the-event))) + (loop while dragging-p do + (let ((the-event (#/nextEventMatchingMask: + (#/window self) + (logior #$NSLeftMouseUpMask + #$NSLeftMouseDraggedMask)))) + (let ((mouse-loc (#/locationInWindow the-event))) + (cond ((eq #$NSLeftMouseDragged (#/type the-event)) + (let ((deltax (float + (- (pref mouse-loc :oint.x) + (pref last-loc :oint.x)) + 0.0f0)) + (deltay (float + (- (pref last-loc :oint.y) + (pref mouse-loc :oint.y)) + 0.0f0)) + (vert-rot-axis (cross *y-axis* *camera-pos*))) + (setf (pref last-loc :oint.x) (pref mouse-loc :oint.x) + (pref last-loc :oint.y) (pref mouse-loc :oint.y)) + (rotate-relative *cube* + (mulquats (axis-angle->quat vert-rot-axis deltay) + (axis-angle->quat *y-axis* deltax)))) + (#/setNeedsDisplay: self t)) + (t + (setf dragging-p nil)))))) + (#/setNeedsDisplay: self t)))) + (t;; ctrl-click, do what right-click does... note that once + ;; ctrl-click is done dragging will not require ctrl be held down + + ;; NOTE THE GRATUITOUS CUT-AND-PASTE, debug the right-mouse-down + ;; version preferentially and update this one with fixes as needed + (let* ((first-loc (#/locationInWindow the-event)) + (pick-loc (#/convertPoint:fromView: self first-loc +null-ptr+))) + (let ((dragging-p t) + (reference-snap 0)) + (setf (turning-face *cube*) (render-for-selection + *cube* + (opengl:unproject (pref pick-loc :oint.x) + (pref pick-loc :oint.y))) + (face-turning-p *cube*) (when (numberp (turning-face *cube*)) t) + (face-theta *cube*) 0.0) + (loop while (and dragging-p (face-turning-p *cube*)) do + (let ((the-event (#/nextEventMatchingMask: + (#/window self) + (logior #$NSLeftMouseUpMask + #$NSLeftMouseDraggedMask)))) + (let ((mouse-loc (#/locationInWindow the-event))) + (cond ((eq #$NSLeftMouseDragged (#/type the-event)) + (let ((deltax (float + (- (ns:ns-point-x mouse-loc) + (ns:ns-point-x first-loc)) + 0.0f0))) + (multiple-value-bind (snap-to snap-dist) (round deltax 90.0) + (cond ((>= *rubix-face-snap* (abs snap-dist)) ; snap + ;; update cube structure + (let ((rotations (- snap-to reference-snap))) + (cond ((zerop rotations) nil) + ((< 0 rotations) + (dotimes (i rotations) + (turnfaceclockwise *cube* (turning-face *cube*))) + (setf reference-snap snap-to)) + ((> 0 rotations) + (dotimes (i (abs rotations)) + (turnfacecounterclockwise *cube* (turning-face *cube*))) + (setf reference-snap snap-to)))) + ;; determine where face will be drawn + (setf (face-theta *cube*) 0.0)) + (t ; no snap + (setf (face-theta *cube*) (- deltax (* 90.0 reference-snap)))) + ))) + (#/setNeedsDisplay: self t)) + (t + (setf (face-turning-p *cube*) nil + (turning-face *cube*) nil + (face-theta *cube*) nil + dragging-p nil)))))) + (#/setNeedsDisplay: self t))) + ))) + +(objc:defmethod (#/rightMouseDown: :void) ((self rubix-opengl-view) the-event) + ;; this makes dragging left/right turn a face counterclockwise/clockwise + ;; ... clicked-on face determines face turned + ;; ... with an n-degree "snap" + ;; ... with the snap updating the data structure + ;; ... releasing the mouse clears rotation angle (face will snap to last position) + (let* ((first-loc (#/locationInWindow the-event)) + (pick-loc (#/convertPoint:fromView: self first-loc +null-ptr+))) + (let ((dragging-p t) + (reference-snap 0)) + (setf (turning-face *cube*) (render-for-selection + *cube* + (opengl:unproject (pref pick-loc :oint.x) + (pref pick-loc :oint.y))) + (face-turning-p *cube*) (when (numberp (turning-face *cube*)) t) + (face-theta *cube*) 0.0) + (loop while (and dragging-p (face-turning-p *cube*)) do + (let ((the-event (#/nextEventMatchingMask: + (#/window self) + (logior #$NSRightMouseUpMask + #$NSRightMouseDraggedMask)))) + (let ((mouse-loc (#/locationInWindow the-event))) + (cond ((eq #$NSRightMouseDragged (#/type the-event)) + (let ((deltax (float + (- (pref mouse-loc :oint.x) + (pref first-loc :oint.x)) + 0.0f0))) + (multiple-value-bind (snap-to snap-dist) (round deltax 90.0) + (cond ((>= *rubix-face-snap* (abs snap-dist)) ; snap + ;; update cube structure + (let ((rotations (- snap-to reference-snap))) + (cond ((zerop rotations) nil) + ((< 0 rotations) + (dotimes (i rotations) + (turnfaceclockwise *cube* (turning-face *cube*))) + (setf reference-snap snap-to)) + ((> 0 rotations) + (dotimes (i (abs rotations)) + (turnfacecounterclockwise *cube* (turning-face *cube*))) + (setf reference-snap snap-to)))) + ;; determine where face will be drawn + (setf (face-theta *cube*) 0.0)) + (t ; no snap + (setf (face-theta *cube*) (- deltax (* 90.0 reference-snap)))) + ))) + (#/setNeedsDisplay: self t)) + (t + (setf (face-turning-p *cube*) nil + (turning-face *cube*) nil + (face-theta *cube*) nil + dragging-p nil)))))) + (#/setNeedsDisplay: self t)))) + +(defclass rubix-window (ns:ns-window) + () + (:metaclass ns:+ns-object)) + +(defparameter *aluminum-margin* 5.0f0) + +(defun run-rubix-demo () + (let* ((w (gui::new-cocoa-window :class (find-class 'rubix-window) + :title "Rubix Cube" + :height 250 + :width 250 + :expandable nil)) + (w-content-view (#/contentView w))) + (let ((w-frame (#/frame w-content-view))) + (ns:with-ns-rect (glview-rect *aluminum-margin* + *aluminum-margin* + (- (pref w-frame :ect.size.width) + (* 2 *aluminum-margin*)) + (- (pref w-frame :ect.size.height) + *aluminum-margin*)) + ;; Q: why make-objc-instance here? + (let ((glview (make-instance 'rubix-opengl-view + :with-frame glview-rect + :pixel-format #+ignore + (#/defaultPixelFormat nsLns-opengl-view) + (opengl:new-pixel-format ;#$NSOpenGLPFADoubleBuffer + #$NSOpenGLPFAAccelerated + #$NSOpenGLPFAColorSize 32 + #$NSOpenGLPFADepthSize 32)))) + (#/addSubview: w-content-view glview) + w))))) Index: /branches/new-random/examples/rubix/vectors.lisp =================================================================== --- /branches/new-random/examples/rubix/vectors.lisp (revision 13309) +++ /branches/new-random/examples/rubix/vectors.lisp (revision 13309) @@ -0,0 +1,170 @@ +(in-package :cl-user) + +;; A stylistic ideosynchracy of C++ was passing result pointers into functions +;; to reduce the impact of the lack of garbage collection. It reduces consing +;; and allows functions to modify wrapped vectors and the like in place, so +;; it's laudable to keep around, but in general I've made such things an +;; optional final argument. + +;; To-do list: +;; When i make foreign function calls in to glut, glu, or opengl, i should +;; do type checking to trap errors in lisp. + +(defparameter *x-axis* (make-array 3 :initial-contents '( 1.0 0.0 0.0) + :element-type 'single-float)) +(defparameter *y-axis* (make-array 3 :initial-contents '( 0.0 1.0 0.0) + :element-type 'single-float)) +(defparameter *z-axis* (make-array 3 :initial-contents '( 0.0 0.0 1.0) + :element-type 'single-float)) +(defparameter *neg-x-axis* (make-array 3 :initial-contents '(-1.0 0.0 0.0) + :element-type 'single-float)) +(defparameter *neg-y-axis* (make-array 3 :initial-contents '( 0.0 -1.0 0.0) + :element-type 'single-float)) +(defparameter *neg-z-axis* (make-array 3 :initial-contents '( 0.0 0.0 -1.0) + :element-type 'single-float)) +(defparameter *the-origin* (make-array 3 :initial-contents '( 0.0 0.0 0.0) + :element-type 'single-float)) + +(defparameter *hel-white* (make-array 4 :initial-contents '(1.0 1.0 1.0 1.0) + :element-type 'single-float)) +(defparameter *hel-grey* (make-array 4 :initial-contents '(0.3 0.3 0.3 1.0) + :element-type 'single-float)) +(defparameter *hel-black* (make-array 4 :initial-contents '(0.0 0.0 0.0 1.0) + :element-type 'single-float)) +(defparameter *hel-red* (make-array 4 :initial-contents '(1.0 0.0 0.0 1.0) + :element-type 'single-float)) +(defparameter *hel-green* (make-array 4 :initial-contents '(0.0 0.33 0.0 1.0) + :element-type 'single-float)) +(defparameter *hel-blue* (make-array 4 :initial-contents '(0.0 0.0 1.0 1.0) + :element-type 'single-float)) +(defparameter *hel-yellow* (make-array 4 :initial-contents '(1.0 1.0 0.0 1.0) + :element-type 'single-float)) +(defparameter *hel-cyan* (make-array 4 :initial-contents '(0.0 1.0 1.0 1.0) + :element-type 'single-float)) +(defparameter *hel-magenta* (make-array 4 :initial-contents '(1.0 0.0 1.0 1.0) + :element-type 'single-float)) +(defparameter *hel-peach* (make-array 4 :initial-contents '(1.0 0.3 0.2 1.0) + :element-type 'single-float)) +(defparameter *hel-pink* (make-array 4 :initial-contents '(1.0 0.3 0.3 1.0) + :element-type 'single-float)) +(defparameter *hel-orange* (make-array 4 :initial-contents '(1.0 0.3 0.0 1.0) + :element-type 'single-float)) + +(defun radians (degrees) + (/ (* 3.14159 degrees) 180.0)) +(defun degrees (radians) + (/ (* 180.0 radians) 3.14159)) +(defun mag (p) + (let ((p0 (elt p 0)) + (p1 (elt p 1)) + (p2 (elt p 2))) + (+ (* p0 p0) (* p1 p1) (* p2 p2)))) +(defun normalize (p) + (let ((d 0.0)) + (dotimes (i 3) (incf d (expt (elt p i) 2))) + (when (< 0.0 d) + (setf d (sqrt d)) + (dotimes (i 3) (setf (elt p i) (/ (elt p i) d)))) + p)) + +(defun add-vectors (a b &optional result) + (or result (setf result (make-array 3))) + (dotimes (i 3) + (setf (elt result i) (+ (elt a i) (elt b i)))) + result) +(defun scale-vector (a n &optional result) + (or result (setf result (make-array 3))) + (dotimes (i 3) + (setf (elt result i) (* (elt a i) n))) + result) +#+ignore ; overridden by lower defn anyway +(defun cross (a b c &optional norm) + (or norm (setf norm (make-array 3))) + (let ((a0 (elt a 0)) (a1 (elt a 1)) (a2 (elt a 2)) + (b0 (elt b 0)) (b1 (elt b 1)) (b2 (elt b 2)) + (c0 (elt c 0)) (c1 (elt c 1)) (c2 (elt c 2))) + (setf (elt norm 0) (- (* (- b1 a1) (- c2 a2)) (* (- b2 a2) (- c1 a1))) + (elt norm 1) (- (* (- b2 a2) (- c0 a0)) (* (- b0 a0) (- c2 a2))) + (elt norm 2) (- (* (- b0 a0) (- c1 a1)) (* (- b1 a1) (- c0 a0))))) + norm) +(defun cross (v1 v2 &optional crossproduct) + (or crossproduct (setf crossproduct (make-array 3))) + (setf (elt crossproduct 0) (- (* (elt v1 1) (elt v2 2)) + (* (elt v1 2) (elt v2 1))) + (elt crossproduct 1) (- (* (elt v1 2) (elt v2 0)) + (* (elt v1 0) (elt v2 2))) + (elt crossproduct 2) (- (* (elt v1 0) (elt v2 1)) + (* (elt v1 1) (elt v2 0)))) + crossproduct) +(defun dot (v1 v2) + (+ (* (elt v1 0) (elt v2 0)) + (* (elt v1 1) (elt v2 1)) + (* (elt v1 2) (elt v2 2)))) + + +;; quaterion class (note that in my c++ code i use a type for this, +;; but since the quaternions aren't ever going to be in the C world +;; the lisp representation doesn't matter) +(defclass quaternion () + ((w :initform 1.0 :initarg :w :accessor w) + (xyz :initform nil :initarg :xyz :accessor xyz)) + (:default-initargs :xyz (make-array 3 :initial-element 0.0))) +(defmethod addquats ((q1 quaternion) (q2 quaternion) &optional result) + (or result (setf result (make-instance 'quaternion))) + (setf (w result) (+ (w q1) (w q2))) + (add-vectors (xyz q1) (xyz q2) (xyz result)) + result) +;; this computes q1*q2 not the other way around, so it does q2's rotation first +(defmethod mulquats ((q1 quaternion) (q2 quaternion) &optional result) + (or result (setf result (make-instance 'quaternion))) + (let ((t1 (make-array 3 :initial-element 0.0)) + (t2 (make-array 3 :initial-element 0.0)) + (t3 (make-array 3 :initial-element 0.0))) + (scale-vector (xyz q1) (w q2) t1) + (scale-vector (xyz q2) (w q1) t2) + (cross (xyz q1) (xyz q2) t3) + + (setf (w result) (- (* (w q1) (w q2)) (dot (xyz q1) (xyz q2)))) + (add-vectors t1 t2 (xyz result)) + (add-vectors t3 (xyz result) (xyz result)) + result)) + +;; unit quaternions are made up of the axis of rotation (xyz) as a vector with +;; magnitude sin(theta/2) and a scalar (w) with magnitude cos(theta/2); +(defun axis-angle->quat (axis angle &optional q) + (or q (setf q (make-instance 'quaternion))) + (let ((theta (radians angle))) + (setf (w q) (cos (/ theta 2.0))) + (dotimes (i 3) (setf (elt (xyz q) i) (elt axis i))) + (normalize (xyz q)) + (scale-vector (xyz q) (sin (/ theta 2.0)) (xyz q)) + q)) +(defun quat->axis-angle (q &optional axis-angle) ; <- cons pair, bleah + (or axis-angle (setf axis-angle (cons (make-array 3 :initial-element 0.0) + 0.0))) + (let ((len (mag (xyz q)))) + (cond ((> len 0.0001) + (setf (cdr axis-angle) (degrees (* 2.0 (acos (w q))))) + (dotimes (i 3) (setf (elt (car axis-angle) i) + (/ (elt (xyz q) i) len)))) + (t ;; if len is near 0, angle of rotation is too, which can cause + ;; trouble elsewhere, so just return zero + (setf (cdr axis-angle) 0.0) + (setf (elt (car axis-angle) 0) 0.0 + (elt (car axis-angle) 1) 0.0 + (elt (car axis-angle) 2) 1.0))) + axis-angle)) + +;; this wraps a 9-number function with a point/point/vector function +;; note that this could REALLY stand to do some type checking... +(defun myLookAt (camera-position target-position upvector) + (#_gluLookAt + (coerce (elt camera-position 0) 'double-float) + (coerce (elt camera-position 1) 'double-float) + (coerce (elt camera-position 2) 'double-float) + (coerce (elt target-position 0) 'double-float) + (coerce (elt target-position 1) 'double-float) + (coerce (elt target-position 2) 'double-float) + (coerce (elt upvector 0) 'double-float) + (coerce (elt upvector 1) 'double-float) + (coerce (elt upvector 2) 'double-float))) Index: /branches/new-random/examples/webkit.lisp =================================================================== --- /branches/new-random/examples/webkit.lisp (revision 13309) +++ /branches/new-random/examples/webkit.lisp (revision 13309) @@ -0,0 +1,86 @@ + +;;;-*-Mode: LISP; Package: CCL -*- + +(in-package "CCL") + +(eval-when (:compile-toplevel :load-toplevel :execute) + (require "COCOA")) + +(eval-when (:compile-toplevel :load-toplevel :execute) + (objc:load-framework "WebKit" :webkit)) + + +(defun pathname-to-file-url (pathname) + ;; NATIVE-TRANSLATED-NAMESTRING returns a simple string that can be + ;; passed to a filesystem function. (It may be exactly the same as + ;; what NAMESTRING returns, or it may differ if special characters + ;; were escaped in NAMESTRING's result.) + (with-autorelease-pool + (#/retain + (#/fileURLWithPath: ns:ns-url (%make-nsstring + (native-translated-namestring pathname)))))) + +(defun url-from-string (s) + (with-autorelease-pool + (#/retain (#/URLWithString: ns:ns-url (%make-nsstring (string s)))))) + + +(defun %browser-window (urlspec) + (gui::assume-cocoa-thread) + ;; Content rect for window, bounds rect for view. + (ns:with-ns-rect (r 100.0 100.0 800.0 600.0) + (with-autorelease-pool + (let* ((url (if (typep urlspec 'pathname) + (pathname-to-file-url urlspec) + (url-from-string urlspec))) + ;; Create a window with titlebar, close & iconize buttons + (w (make-instance + 'ns:ns-window + :with-content-rect r + :style-mask (logior #$NSTitledWindowMask + #$NSClosableWindowMask + #$NSMiniaturizableWindowMask + #$NSResizableWindowMask) + ;; Backing styles other than #$NSBackingStoreBuffered + ;; don't work at all in Cocoa. + :backing #$NSBackingStoreBuffered + :defer t))) + (#/setTitle: w (#/absoluteString url)) + ;; Create a web-view instance, + (let* ((v (make-instance + 'ns:web-view + :with-frame r + :frame-name #@"frame" ; could be documented a bit better ... + :group-name #@"group"))) ; as could this + ;; Make the view be the window's content view. + (#/setContentView: w v) + ;; Start a URL request. The request is processed + ;; asynchronously, but apparently needs to be initiated + ;; from the event-handling thread. + (let* ((webframe (#/mainFrame v)) + (request (#/requestWithURL: ns:ns-url-request url))) + ;; Failing to wait until the main thread has + ;; initiated the request seems to cause + ;; view-locking errors. Maybe that's just + ;; an artifact of some other problem. + (#/loadRequest: webframe request) + ;; Make the window visible & activate it + ;; The view knows how to draw itself and respond + ;; to events. + (#/makeKeyAndOrderFront: w +null-ptr+)) + v))))) + +(defun browser-window (urlspec) + (let* ((ip ccl::*initial-process*)) + (if (eq ccl::*current-process* ip) + (%browser-window urlspec) + (let* ((s (make-semaphore)) + (v nil)) + (process-interrupt ip (lambda () + (setq v (%browser-window urlspec)) + (signal-semaphore s))) + (wait-on-semaphore s) + v)))) + + +;;; (browser-window "http://openmcl.clozure.com") Index: /branches/new-random/l1-fasls/.cvsignore =================================================================== --- /branches/new-random/l1-fasls/.cvsignore (revision 13309) +++ /branches/new-random/l1-fasls/.cvsignore (revision 13309) @@ -0,0 +1,3 @@ +*fsl + + Index: /branches/new-random/level-0/.cvsignore =================================================================== --- /branches/new-random/level-0/.cvsignore (revision 13309) +++ /branches/new-random/level-0/.cvsignore (revision 13309) @@ -0,0 +1,2 @@ +*fsl +*~.* Index: /branches/new-random/level-0/PPC/.cvsignore =================================================================== --- /branches/new-random/level-0/PPC/.cvsignore (revision 13309) +++ /branches/new-random/level-0/PPC/.cvsignore (revision 13309) @@ -0,0 +1,6 @@ +*.pfsl +*.p64fsl +*.dfsl +*.d64fsl + +*~.* Index: /branches/new-random/level-0/PPC/PPC32/.cvsignore =================================================================== --- /branches/new-random/level-0/PPC/PPC32/.cvsignore (revision 13309) +++ /branches/new-random/level-0/PPC/PPC32/.cvsignore (revision 13309) @@ -0,0 +1,6 @@ +*.pfsl +*.p64fsl +*.dfsl +*.d64fsl + +*~.* Index: /branches/new-random/level-0/PPC/PPC32/ppc32-bignum.lisp =================================================================== --- /branches/new-random/level-0/PPC/PPC32/ppc32-bignum.lisp (revision 13309) +++ /branches/new-random/level-0/PPC/PPC32/ppc32-bignum.lisp (revision 13309) @@ -0,0 +1,1786 @@ +;;-*- Mode: Lisp; Package: CCL -*- +;;; +;;; Copyright (C) 2009 Clozure Associates +;;; Copyright (C) 1994-2001 Digitool, Inc +;;; This file is part of Clozure CL. +;;; +;;; Clozure CL is licensed under the terms of the Lisp Lesser GNU Public +;;; License , known as the LLGPL and distributed with Clozure CL as the +;;; file "LICENSE". The LLGPL consists of a preamble and the LGPL, +;;; which is distributed with Clozure CL as the file "LGPL". Where these +;;; conflict, the preamble takes precedence. +;;; +;;; Clozure CL is referenced in the preamble as the "LIBRARY." +;;; +;;; The LLGPL is also available online at +;;; http://opensource.franz.com/preamble.html + + +(in-package "CCL") + +(eval-when (:compile-toplevel :execute) + (require "PPC32-ARCH") + (require "PPC-LAPMACROS") + + ;; Set RES to 1 if (u< x y), to 0 otherwise. + (defppclapmacro sltu (res x y) + `(progn + (subfc ,res ,x ,y) + (subfe ,res ,res ,res) + (neg ,res ,res))) + + (defppclapmacro 48x32-divide (x-hi16 x-lo y freg temp-freg freg2 immx) + `(let ((temp 16) + (temp.h 16) + (temp.l 20) + (zero 8) + (zero.h 8) + (zero.l 12)) + (stwu tsp -24 tsp) + (stw tsp 4 tsp) + (lwi ,immx #x43300000) ; 1075 = 1022+53 + (stw ,immx zero.h tsp) + (stw rzero zero.l tsp) + (lfd ,temp-freg zero tsp) + (rlwimi ,immx ,x-hi16 0 16 31) + (stw ,immx temp.h tsp) + (stw ,x-lo temp.l tsp) + (lfd ,freg temp tsp) + + (fsub ,freg ,freg ,temp-freg) + (lwi ,immx #x43300000) + (stw ,immx temp.h tsp) + (stw ,y temp.l tsp) + (lfd ,freg2 temp tsp) + (lwz tsp 0 tsp) + (fsub ,freg2 ,freg2 ,temp-freg) + (fdiv ,freg ,freg ,freg2) + )) + + ) + +;;; %BIGNUM-REF needs to access bignums as obviously as possible, and it needs +;;; to be able to return 32 bits somewhere no one looks for real objects. +;;; +;;; The easiest thing to do is to store the 32 raw bits in two fixnums +;;; and return multiple values. +(defppclapfunction %bignum-ref ((bignum arg_y) (i arg_z)) + (vref32 imm0 bignum i imm1) + (digit-h temp0 imm0) + (digit-l temp1 imm0) + (vpush temp0) + (vpush temp1) + (la temp0 8 vsp) ; ?? why not (mr temp0 vsp) before vpushing? + (set-nargs 2) ; that doesn't make any difference. And, in this case, + ; we can get away without setting nargs (since the caller + ; called us with 2 args, but that's horrible style.) + (ba .SPvalues)) + + +;;; Set the 0th element of DEST (a bignum or some other 32-bit ivector) +;;; to the Ith element of the bignum SRC. +(defppclapfunction %ref-digit ((bignum arg_x) (i arg_y) (dest arg_z)) + (la imm1 ppc32::misc-data-offset i) + (lwzx imm0 bignum imm1) + (stw imm0 ppc32::misc-data-offset dest) + (blr)) + +;;; BIGNUM[I] := DIGIT[0] +(defppclapfunction %set-digit ((bignum arg_x) (i arg_y) (digit arg_z)) + (la imm1 ppc32::misc-data-offset i) + (lwz imm0 ppc32::misc-data-offset digit) + (stwx imm0 bignum imm1) + (blr)) + +;;; Return 0 if the 0th digit in X is 0. +(defppclapfunction %digit-zerop ((x arg_z)) + (lwz imm0 ppc32::misc-data-offset x) + (cntlzw imm0 imm0) + (srwi imm0 imm0 5) + (rlwimi imm0 imm0 4 27 27) + (addi arg_z imm0 (target-nil-value)) + (blr)) + +;;; store the sign of bignum (0 or -1) in the one-word bignum "digit". +(defppclapfunction %bignum-sign-digit ((bignum arg_y) (digit arg_z)) + (vector-length imm0 bignum imm0) + (la imm0 (- ppc32::misc-data-offset 4) imm0) ; Reference last (most significant) digit + (lwzx imm0 bignum imm0) + (srawi imm0 imm0 31) ;propagate sign bit + (stw imm0 ppc32::misc-data-offset digit) + (blr)) + +;;; Return the sign of bignum (0 or -1) as a fixnum +(defppclapfunction %bignum-sign ((bignum arg_z)) + (vector-length imm0 bignum imm0) + (la imm0 (- ppc32::misc-data-offset 4) imm0) ; Reference last (most significant) digit + (lwzx imm0 bignum imm0) + (srawi imm0 imm0 31) ;propagate sign bit + (box-fixnum arg_z imm0) + (blr)) + +;;; Count the sign bits in the most significant digit of bignum; +;;; return fixnum count. +(defppclapfunction %bignum-sign-bits ((bignum arg_z)) + (vector-length imm0 bignum imm0) + (la imm0 (- ppc32::misc-data-offset 4) imm0) ; Reference last (most significant) digit + (lwzx imm0 bignum imm0) + (cmpwi imm0 0) + (not imm0 imm0) + (blt @wasneg) + (not imm0 imm0) + @wasneg + (cntlzw imm0 imm0) + (box-fixnum arg_z imm0) + (blr)) + +(defppclapfunction %digit-0-or-plusp ((bignum arg_y) (idx arg_z)) + (la imm0 ppc32::misc-data-offset idx) + (lwzx imm0 bignum imm0) + (xoris imm0 imm0 #x8000) ; invert sign bit + (srwi imm0 imm0 31) + (bit0->boolean arg_z imm0 imm0) ; return T if sign bit was clear before inversion + (blr)) + +;;; For oddp, evenp +(defppclapfunction %bignum-oddp ((bignum arg_z)) + (lwz imm0 ppc32::misc-data-offset bignum) + (clrlwi imm0 imm0 31) + (bit0->boolean arg_z imm0 imm0) + (blr)) + +(defppclapfunction bignum-plusp ((bignum arg_z)) + (vector-length imm0 bignum imm0) + (la imm0 (- ppc32::misc-data-offset 4) imm0) ; Reference last (most significant) digit + (lwzx imm0 bignum imm0) + (xoris imm0 imm0 #x8000) ; invert sign bit + (srwi imm0 imm0 31) + (bit0->boolean arg_z imm0 imm0) ; return T if sign bit was clear before inversion + (blr)) + +(defppclapfunction %fixnum-to-bignum-set ((bignum arg_y) (fixnum arg_z)) + (unbox-fixnum imm0 fixnum) + (stw imm0 ppc32::misc-data-offset bignum) + (blr)) + +(defppclapfunction bignum-minusp ((bignum arg_z)) + (vector-length imm0 bignum imm0) + (la imm0 (- ppc32::misc-data-offset 4) imm0) ; Reference last (most significant) digit + (lwzx imm0 bignum imm0) + (srwi imm0 imm0 31) + (rlwimi imm0 imm0 4 27 27) + (addi arg_z imm0 (target-nil-value)) ; return T if sign bit was clear before inversion + (blr)) + + +;;; Add the digits A[I] and B[J], and the incoming carry C (a fixnum). +;;; Store the result in R[K], and return the outgoing carry. +;;; If I is NIL, A is a fixnum. If J is NIL, B is a fixnum. + +(defppclapfunction %add-with-carry ((r 12) (k 8) (c 4) (a 0) (i arg_x) (b arg_y) (j arg_z)) + (cmpwi cr1 j (target-nil-value)) + (cmpwi cr0 i (target-nil-value)) + (lwz temp0 a vsp) + (unbox-fixnum imm1 temp0) + (unbox-fixnum imm2 b) + (beq cr0 @got-a) + (la imm1 ppc32::misc-data-offset i) + (lwzx imm1 temp0 imm1) + @got-a + (beq cr1 @got-b) + (la imm2 ppc32::misc-data-offset j) + (lwzx imm2 b imm2) + @got-b + (lwz temp0 c vsp) + (unbox-fixnum imm0 temp0) + (addic imm0 imm0 -1) + (lwz temp1 r vsp) + (lwz temp0 k vsp) + (la vsp 16 vsp) + (adde imm0 imm1 imm2) + (la imm2 ppc32::misc-data-offset temp0) + (stwx imm0 temp1 imm2) + (addze imm0 rzero) + (box-fixnum arg_z imm0) + (blr)) + + + + + +;;; Store the result of A[I] - B[J] - borrow into R[K], returning the borrow. +;;; If I is NIL, A is a fixnum; likewise for J and B. +(defppclapfunction %subtract-with-borrow ((r 12) (k 8) (borrow 4) (a 0) (i arg_x) (b arg_y) (j arg_z)) + (cmpwi cr0 i (target-nil-value)) + (cmpwi cr1 j (target-nil-value)) + (lwz temp0 a vsp) + (unbox-fixnum imm2 b) + (unbox-fixnum imm1 temp0) + (beq cr1 @got-b) + (la imm2 ppc32::misc-data-offset j) + (lwzx imm2 b imm2) + @got-b + (beq cr0 @got-a) + (la imm1 ppc32::misc-data-offset i) + (lwzx imm1 temp0 imm1) + @got-a + (lwz temp0 borrow vsp) + (unbox-fixnum imm0 temp0) + (addic imm0 imm0 -1) + (lwz temp0 r vsp) + (lwz temp1 k vsp) + (la vsp 16 vsp) + (subfe imm0 imm2 imm1) + (la imm1 ppc32::misc-data-offset temp1) + (stwx imm0 temp0 imm1) + (addze imm0 rzero) + (box-fixnum arg_z imm0) + (blr)) + +;; multiply i'th digit of x by y and add to result starting at digit i +(defppclapfunction %multiply-and-add-harder-loop-2 + ((x-ptr 4) (y-ptr 0) (resptr arg_x)(residx arg_y) (count arg_z)) + (let ((tem imm0) + (y imm1) + (prod-h imm2) + (prod-l imm3) + (x imm4) + (xptr temp2) + (yidx temp1) + (yptr temp0)) + (lwz xptr x-ptr vsp) + (la tem ppc32::misc-data-offset residx) + (lwzx x xptr tem) + (lwz yptr y-ptr vsp) + (li yidx 0) ; init yidx 0 + (addc prod-h rzero rzero) ; init carry 0, mumble 0 + @loop + (subi count count '1) + (cmpwi count 0) + (la tem ppc32::misc-data-offset yidx) ; get yidx + (lwzx y yptr tem) + (mullw prod-l x y) + (addc prod-l prod-l prod-h) + (mulhwu prod-h x y) + (addze prod-h prod-h) + (la tem ppc32::misc-data-offset residx) + (lwzx y resptr tem) + (addc prod-l prod-l y) + (addze prod-h prod-h) + (stwx prod-l resptr tem) + (addi residx residx '1) + (addi yidx yidx '1) + (bgt @loop) + (la tem ppc32::misc-data-offset residx) + (stwx prod-h resptr tem) + (la vsp 8 vsp) + (blr))) + + + +;;; Multiply X[I] by the unboxed value of the (non-negative) fixnum Y; +;;; add the incoming carry from CARRY[0] to the 64-bit product. Store +;;; the low word of the 64-bit sum in R[0] and the high word in +;;; CARRY[0]. + +(defppclapfunction %multiply-and-add ((r 4) (carry 0) (x arg_y) (i arg_x) (y arg_z)) + (unbox-fixnum imm0 arg_z) + (la imm1 ppc32::misc-data-offset i) + (lwzx imm1 x imm1) + (mulhwu imm2 imm0 imm1) + (mullw imm1 imm0 imm1) + (lwz temp0 carry vsp) + (lwz imm0 ppc32::misc-data-offset temp0) + (addc imm1 imm1 imm0) + (addze imm2 imm2) + (stw imm2 ppc32::misc-data-offset temp0) + (lwz arg_z r vsp) + (la vsp 8 vsp) + (stw imm1 ppc32::misc-data-offset arg_z) + (blr)) + +(defppclapfunction %floor ((q 4) (r 0) (num-high arg_x) (num-low arg_y) (denom-arg arg_z)) + (let ((rem imm0) + (rem-low imm1) + (quo imm2) + (temp imm3) + (denom imm4)) + (lwz denom ppc32::misc-data-offset denom) + (lwz rem ppc32::misc-data-offset num-high) + (lwz rem-low ppc32::misc-data-offset num-low) + (mr temp denom) + (sltu quo rem denom) + (subi temp temp quo) + (and temp temp denom) + (sub rem temp rem) + (li temp0 '32) + @loop + (subi temp0 temp0 '1) + (cmpwi temp0 0) + (slwi rem rem 1) + (srwi temp rem-low 31) + (or rem rem temp) + (slwi rem-low rem-low 1) + (sltu rem rem denom) + (slwi quo quo 1) + (or quo quo temp) + (subi temp temp 1) + (and temp temp denom) + (sub rem rem temp) + (bne @loop) + (not quo quo) + (lwz temp0 q vsp) + (stw quo ppc32::misc-data-offset temp0) + (lwz arg_z r vsp) + (la vsp 8 vsp) + (stw rem ppc32::misc-data-offset arg_z) + (blr))) + +(defppclapfunction %bignum-ref-hi ((bignum arg_y) (i arg_z)) + (la imm1 ppc32::misc-data-offset i) + (lhzx imm0 bignum imm1) + (box-fixnum arg_z imm0) + (blr)) + + +(defppclapfunction %bignum-set ((bignum 0) (i arg_x) (high arg_y) (low arg_z)) + (compose-digit imm0 high low) + (lwz arg_z bignum vsp) + (vset32 imm0 arg_z i imm1) + (la vsp 4 vsp) + (blr)) + + + + +; this is silly +(defppclapfunction %add-the-carry ((b-h arg_x) (b-l arg_y) (carry-in arg_z)) + (let ((a imm0) + (b imm1) + (temp imm2) + (c imm3)) + (compose-digit b b-h b-l) + (unbox-fixnum c carry-in) + (add b c b) + (digit-h temp0 b) + (digit-l temp1 b) + (vpush temp0) + (vpush temp1) + (la temp0 8 vsp) + (set-nargs 2) + (ba .SPvalues))) + + + + +;;; %SUBTRACT-WITH-BORROW -- Internal. +;;; +;;; This should be in assembler, and should not cons intermediate results. It +;;; returns a 32bit digit and a borrow resulting from subtracting b from a, and +;;; subtracting a possible incoming borrow. +;;; +;;; We really do: a - b - 1 + borrow, where borrow is either 0 or 1. +;;; + +(defppclapfunction %subtract-with-borrow-1 ((a-h 4) (a-l 0) (b-h arg_x) (b-l +arg_y) (borrow-in arg_z)) + (let ((a imm0) + (b imm1) + (temp imm2) + (c imm3)) + (lwz temp0 a-h vsp) + (lwz temp1 a-l vsp) + (compose-digit a temp0 temp1) + (compose-digit b b-h b-l) + (unbox-fixnum c borrow-in) + (li temp -1) + (addc temp c temp) + (subfe a b a) + (addze c rzero) + (box-fixnum c c) + (digit-h temp0 a) + (digit-l temp1 a) + (vpush temp0) + (vpush temp1) + (vpush c) + (la temp0 20 vsp) + (set-nargs 3) + (ba .SPvalues))) + + + +(defppclapfunction %subtract-one ((a-h arg_y)(a-l arg_z)) + (let ((a imm0)) + (compose-digit a a-h a-l) + (subi a a 1) + (digit-h temp0 a) + (vpush temp0) + (digit-l temp0 a) + (vpush temp0) + (la temp0 8 vsp) + (set-nargs 2) + (ba .spvalues))) + + + + +;;; %MULTIPLY-AND-ADD -- Internal. +;;; +;;; This multiplies x-digit and y-digit, producing high and low digits +;;; manifesting the result. Then it adds the low digit, res-digit, and +;;; carry-in-digit. Any carries (note, you still have to add two digits at a +;;; time possibly producing two carries) from adding these three digits get +;;; added to the high digit from the multiply, producing the next carry digit. +;;; Res-digit is optional since two uses of this primitive multiplies a single +;;; digit bignum by a multiple digit bignum, and in this situation there is no +;;; need for a result buffer accumulating partial results which is where the +;;; res-digit comes from. +;;; [slh] I assume that the returned carry "digit" can only be 0, 1 or 2 + + +(defppclapfunction %multiply-and-add-1 ((x-high 8) + (x-low 4) + (y-high 0) + (y-low arg_x) + (carry-in-high arg_y) + (carry-in-low arg_z)) + (let ((x imm0) + (y imm1) + (carry-in imm2) + (lo imm3) + (hi imm4)) + (compose-digit carry-in carry-in-high carry-in-low) + (vpop temp0) + (compose-digit y temp0 y-low) + (vpop temp0) + (vpop temp1) + (compose-digit x temp1 temp0) + (mullw lo x y) + (mulhwu hi x y) + (addc lo lo carry-in) + (addze hi hi) + (digit-h temp0 hi) + (digit-l temp1 hi) + (digit-h temp2 lo) + (digit-l temp3 lo) + (vpush temp0) + (vpush temp1) + (vpush temp2) + (vpush temp3) + (set-nargs 4) + (la temp0 16 vsp) + (ba .SPvalues))) + + +(defppclapfunction %logcount-complement ((bignum arg_y) (idx arg_z)) + (let ((arg imm0) + (shift imm1) + (temp imm2)) + (la arg ppc32::misc-data-offset idx) + (lwzx arg bignum arg) + (not. shift arg) + (li arg_z 0) + (if ne + (progn + @loop + (la temp -1 shift) + (and. shift shift temp) + (la arg_z '1 arg_z) + (bne @loop))) + (blr))) + +(defppclapfunction %logcount ((bignum arg_y) (idx arg_z)) + (let ((arg imm0) + (shift imm1) + (temp imm2)) + (la arg ppc32::misc-data-offset idx) + (lwzx arg bignum arg) + (mr. shift arg) + (li arg_z 0) + (if ne + (progn + @loop + (la temp -1 shift) + (and. shift shift temp) + (la arg_z '1 arg_z) + (bne @loop))) + (blr))) + +; return res +(defppclapfunction bignum-add-loop-2 ((aptr arg_x)(bptr arg_y) (result arg_z)) + (let ((idx imm0) + (count imm1) + (x imm2) + (y imm3) + (len-a temp0) + (len-b temp1) + (tem temp2)) + (li idx ppc32::misc-data-offset) + (lwz imm4 ppc32::misc-header-offset aptr) + (header-length len-a imm4) + (lwz imm4 ppc32::misc-header-offset bptr) + (header-length len-b imm4) + ; make a be shorter one + (cmpw len-a len-b) + (li count 0) + ; initialize carry 0 + (addc x rzero rzero) + (ble @loop) + ; b shorter - swap em + (mr tem len-a) + (mr len-a len-b) + (mr len-b tem) + (mr tem aptr) + (mr aptr bptr) + (mr bptr tem) + @loop + (lwzx y aptr idx) + (lwzx x bptr idx) + (addi count count '1) + (cmpw count len-a) + (adde x x y) + (stwx x result idx) + (addi idx idx '1) + (blt @loop) + ; now propagate carry thru longer (b) using sign of shorter + ;(SUBI imm4 idx '1) ; y has hi order word of a + ;(lwzx y aptr imm4) + (cmpw len-a len-b) + (adde imm4 rzero rzero) ; get carry + (srawi y y 31) ; p.o.s clobbers carry + (addic imm4 imm4 -1) ; restore carry + (beq @l3) ; unless equal + @loop2 + (lwzx x bptr idx) + (adde x x y) + (stwx x result idx) + (addi count count '1) + (cmpw count len-b) + (addi idx idx '1) + (blt @loop2) + ; y has sign of shorter - get sign of longer to x + @l3 + (subi imm4 idx '1) + (lwzx x bptr imm4) + (adde imm4 rzero rzero) ; get carry + (srawi x x 31) ; clobbers carry + (addic imm4 imm4 -1) + (adde x x y) + (stwx x result idx) + (blr))) + +;; same as above but with initial a index and finishes +(defppclapfunction bignum-add-loop-+ ((init-a 0)(aptr arg_x)(bptr arg_y)(length arg_z)) + (let ((idx imm0) + (count imm1) + (x imm2) + (y imm3) + (aidx imm4)) + (li idx ppc32::misc-data-offset) + (lwz aidx init-a vsp) + (addi aidx aidx ppc32::misc-data-offset) + (li count 0) + ; initialize carry 0 + (addc x rzero rzero) + @loop + (lwzx x aptr aidx) + (lwzx y bptr idx) + (adde x x y) + (stwx x aptr aidx) + (addi count count '1) + (cmpw count length) + (addi idx idx '1) + (addi aidx aidx '1) + (blt @loop) + (lwzx x aptr aidx) ; add carry into next one + (adde x x rzero) + (stwx x aptr aidx) + (la vsp 4 vsp) + (blr))) + + + +(defppclapfunction bignum-negate-loop-really ((big arg_x) (len arg_y) (result arg_z)) + (let ((idx imm0) + (one imm1) + (x imm2)) + (li idx ppc32::misc-data-offset) + (li one '1) + ; initialize carry 1 + (li x -1) + (addic x x 1) + @loop + ;(addi count count '1) + ;(cmpw count len) + (subf. len one len) + (lwzx x big idx) + (not x x) + (adde x x rzero) + (stwx x result idx) + (addi idx idx '1) + (bgt @loop) + ; return carry + (li x 0) + (adde x x rzero) + (box-fixnum arg_z x) + (blr))) + +(defppclapfunction bignum-negate-to-pointer ((big arg_x) (len arg_y) (result arg_z)) + (let ((idx imm0) + (one imm1) + (x imm2) + (oidx imm3) + (ptr imm4)) + (li idx ppc32::misc-data-offset) + (li oidx 0) + (macptr-ptr ptr result) + (li one '1) + ; initialize carry 1 + (li x -1) + (addic x x 1) + @loop + ;(addi count count '1) + ;(cmpw count len) + (subf. len one len) + (lwzx x big idx) + (not x x) + (adde x x rzero) + (stwx x ptr oidx) + (addi idx idx '1) + (addi oidx oidx 4) + (bgt @loop) + ; return carry + (li x 0) + (adde x x rzero) + (box-fixnum arg_z x) + (blr))) + +;; she do tolerate len = jidx +(defppclapfunction bignum-shift-left-loop ((nbits 4)(result 0) (bignum arg_x) (len arg_y) (jidx arg_z)) + (let ((y imm0) + (idx imm1) + (bits imm2) + (rbits imm3) + (x imm4) + (iidx temp0) + (resptr temp1)) + (li iidx 0) + (lwz bits nbits vsp) + (lwz resptr result vsp) + (unbox-fixnum bits bits) + (subfic rbits bits 32) + ;(dbg) + (lwz imm4 ppc32::misc-data-offset bignum) + (slw imm4 imm4 bits) + (la y (+ ppc32::misc-data-offset -4) jidx) + (stwx imm4 y resptr) + + (cmpw len jidx) + (beq @done) + @loop + (addi idx iidx ppc32::misc-data-offset) + (lwzx x bignum idx) + (srw x x rbits) + (addi idx idx '1) + (lwzx y bignum idx) + (slw y y bits) + (or x x y) + (addi idx jidx ppc32::misc-data-offset) + (stwx x resptr idx) + (addi jidx jidx '1) + (cmpw jidx len) + (addi iidx iidx '1) + (blt @loop) + @done + ; do first - lo order + + ; do last - hi order + (addi idx iidx ppc32::misc-data-offset) + ;(dbg t) + (lwzx y bignum idx) + (sraw y y rbits) + (addi idx len ppc32::misc-data-offset) + (stwx y resptr idx) + (la vsp 8 vsp) + (blr))) + + + +(defppclapfunction bignum-shift-right-loop-1 ((nbits 4)(result 0) (bignum arg_x) (len arg_y) (iidx arg_z)) + (let ((y imm0) + (idx imm1) + (bits imm2) + (rbits imm3) + (x imm4) + (jidx temp0) + (resptr temp1)) + (li jidx 0) + (lwz bits nbits vsp) + (lwz resptr result vsp) + (unbox-fixnum bits bits) + (cmpw jidx len) + (subfic rbits bits 32) + (bge @done) + @loop + (addi idx iidx ppc32::misc-data-offset) + (lwzx x bignum idx) + (srw x x bits) + (addi idx idx '1) + (lwzx y bignum idx) + (slw y y rbits) + (or x x y) + (addi idx jidx ppc32::misc-data-offset) + (stwx x resptr idx) + (addi jidx jidx '1) + (cmpw jidx len) + (addi iidx iidx '1) + (blt @loop) + @done + (addi idx iidx ppc32::misc-data-offset) + (lwzx x bignum idx) + (sraw x x bits) + (addi idx jidx ppc32::misc-data-offset) + (stwx x resptr idx) + (la vsp 8 vsp) + (blr))) + + +(defppclapfunction %compare-digits ((a arg_x) (b arg_y) (idx arg_z)) + (la imm0 ppc32::misc-data-offset idx) + (lwzx imm1 a imm0) + (lwzx imm0 b imm0) + (cmplw imm1 imm0) + (li arg_z '0) + (beqlr) + (li arg_z '1) + (bgtlr) + (li arg_z '-1) + (blr)) + + + +;; returns number of bits in digit-hi,digit-lo that are sign bits +;; 32 - digits-sign-bits is integer-length + +(defppclapfunction %digits-sign-bits ((hi arg_y) (lo arg_z)) + (rlwinm. imm1 hi (- 16 ppc32::fixnumshift) 0 15) + (rlwimi imm1 lo (- 32 ppc32::fixnumshift) 16 31) + (not imm1 imm1) + (blt @wasneg) + (not imm1 imm1) + @wasneg + (cntlzw imm1 imm1) + (box-fixnum arg_z imm1) + (blr)) + +(defppclapfunction bignum-logtest-loop ((count arg_x) (s1 arg_y) (s2 arg_z)) + (addi imm1 rzero ppc32::misc-data-offset) + @loop + (lwzx imm2 s1 imm1) + (lwzx imm3 s2 imm1) + (and. imm2 imm3 imm2) + (addi imm1 imm1 4) + (bne @true) + (subic. count count 4) + (bgt @loop) + (li arg_z (target-nil-value)) + (blr) + @true + (li arg_z (+ (target-nil-value) ppc32::t-offset)) + (blr)) + +;;; dest[idx] <- (lognot src[idx]) +(defppclapfunction %bignum-lognot ((idx arg_x) (src arg_y) (dest arg_z)) + (la imm1 ppc32::misc-data-offset idx) + (lwzx imm0 src imm1) + (not imm0 imm0) + (stwx imm0 dest imm1) + (blr)) + +;;; dest[idx] <- (logand x[idx] y[idx]) +(defppclapfunction %bignum-logand ((idx 0) (x arg_x) (y arg_y) (dest arg_z)) + (vpop temp0) + (la imm1 ppc32::misc-data-offset temp0) + (lwzx imm0 x imm1) + (lwzx imm2 y imm1) + (and imm0 imm0 imm2) + (stwx imm0 dest imm1) + (blr)) + +;;; dest[idx] <- (logandc2 x[idx] y[idx]) +(defppclapfunction %bignum-logandc2 ((idx 0) (x arg_x) (y arg_y) (dest arg_z)) + (vpop temp0) + (la imm1 ppc32::misc-data-offset temp0) + (lwzx imm0 x imm1) + (lwzx imm2 y imm1) + (andc imm0 imm0 imm2) + (stwx imm0 dest imm1) + (blr)) + +;;; dest[idx] <- (logandc1 x[idx] y[idx]) +(defppclapfunction %bignum-logandc1 ((idx 0) (x arg_x) (y arg_y) (dest arg_z)) + (vpop temp0) + (la imm1 ppc32::misc-data-offset temp0) + (lwzx imm0 x imm1) + (lwzx imm2 y imm1) + (andc imm0 imm2 imm0) + (stwx imm0 dest imm1) + (blr)) + + + +(defppclapfunction digit-lognot-move ((index arg_x) (source arg_y) (dest arg_z)) + (let ((scaled-index imm1)) + (vref32 imm0 source index scaled-index) ; imm1 has c(index) + data-offset + (not imm0 imm0) + (stwx imm0 dest scaled-index) + (blr))) + +; if dest not nil store unboxed result in dest(0), else return boxed result +(defppclapfunction fix-digit-logandc2 ((fix arg_x) (big arg_y) (dest arg_z)) ; index 0 + (let ((w1 imm0) + (w2 imm1)) + (unbox-fixnum w1 fix) + (lwz w2 ppc32::misc-data-offset big) + (cmpwi dest (target-nil-value)) + (not w2 w2) + (and w1 w1 w2) + (bne @store) + (box-fixnum arg_z w1) + (blr) + @store + (stw w1 ppc32::misc-data-offset dest) + (blr))) + + + +(defppclapfunction fix-digit-logand ((fix arg_x) (big arg_y) (dest arg_z)) ; index 0 + (let ((w1 imm0) + (w2 imm1)) + (unbox-fixnum w1 fix) + (lwz w2 ppc32::misc-data-offset big) + (cmpwi dest (target-nil-value)) + (and w1 w1 w2) + (bne @store) + (box-fixnum arg_z w1) + (blr) + @store + (stw w1 ppc32::misc-data-offset dest) + (blr))) + + + +(defppclapfunction fix-digit-logandc1 ((fix arg_x) (big arg_y) (dest arg_z)) ; index 0 + (let ((w1 imm0) + (w2 imm1)) + (unbox-fixnum w1 fix) + (lwz w2 ppc32::misc-data-offset big) + (cmpwi dest (target-nil-value)) + (not w1 w1) + (and w1 w1 w2) + (bne @store) + (box-fixnum arg_z w1) + (blr) + @store + (stw w1 ppc32::misc-data-offset dest) + (blr))) + +;;; dest[idx] <- (logior x[idx] y[idx]) +(defppclapfunction %bignum-logior ((idx 0) (x arg_x) (y arg_y) (dest arg_z)) + (vpop temp0) + (la imm1 ppc32::misc-data-offset temp0) + (lwzx imm0 x imm1) + (lwzx imm2 y imm1) + (or imm0 imm0 imm2) + (stwx imm0 dest imm1) + (blr)) + +;;; dest[idx] <- (logxor x[idx] y[idx]) +(defppclapfunction %bignum-logxor ((idx 0) (x arg_x) (y arg_y) (dest arg_z)) + (vpop temp0) + (la imm1 ppc32::misc-data-offset temp0) + (lwzx imm0 x imm1) + (lwzx imm2 y imm1) + (xor imm0 imm0 imm2) + (stwx imm0 dest imm1) + (blr)) + + + +(defppclapfunction bignum-xor-loop ((count 0) (s1 arg_x) (s2 arg_y) (dest arg_z)) + (lwz imm0 count vsp) + (addi imm1 rzero ppc32::misc-data-offset) + @loop + (lwzx imm2 s1 imm1) + (lwzx imm3 s2 imm1) + (xor imm2 imm3 imm2) + (subic. imm0 imm0 4) + (stwx imm2 dest imm1) + (addi imm1 imm1 4) + (bgt @loop) + @out + (la vsp 4 vsp) + (blr)) + +#+nomore +(defppclapfunction try-guess-loop-1 ((guess-h 8)(guess-l 4)(len-y 0) + (xidx arg_x) (xptr arg_y) (yptr arg_z)) + (let ((guess imm0) + (carry imm1) + (y imm2) + (x imm2) + (prod-l imm3) + (prod-h imm4) + (tem imm4) + (yidx temp0) + (end-y temp1) + (carry-bit temp2)) + (lwz x guess-h vsp) + (lwz tem guess-l vsp) + (compose-digit guess x tem) + (lwz end-y len-y vsp) + (li yidx 0) + (li carry 0) + (li carry-bit '1) + @loop + ; multiply guess by ydigit, add carry to lo, hi is new carry + ; then get an xdigit subtract prod-lo from it and store result in x (remember carry) + (addi tem yidx ppc32::misc-data-offset) ; get yidx + (lwzx y yptr tem) + (mullw prod-l guess y) + (mulhwu prod-h guess y) + (addc prod-l prod-l carry) + (adde carry prod-h rzero) + ; get back saved carry + (li tem '-1) + (addc tem carry-bit tem) + (addi tem xidx ppc32::misc-data-offset) + (lwzx x xptr tem) + (subfe x prod-l x) + (stwx x xptr tem) + ; save carry + (adde prod-l rzero rzero) + (box-fixnum carry-bit prod-l) + (addi yidx yidx '1) + (cmpw yidx end-y) + (addi xidx xidx '1) + (blt @loop) + ; finally subtract carry from last x digit + @done + (li prod-l '-1) ; get back saved carry again - box clobbered it? + (addc prod-l carry-bit prod-l) + (addi tem xidx ppc32::misc-data-offset) ; maybe still there - nope + (lwzx x xptr tem) + (subfe x carry x) + (stwx x xptr tem) + (la vsp 12 vsp) + (blr))) + +;; x0 is at index, x1 at index-1, x2 at index-2 +;; y1 is at index, y2 at index-1 +;; this doesnt help much +(defppclapfunction truncate-guess-loop ((guess-h 8)(guess-l 4)(x 0) + (xidx arg_x)(yptr arg_y) (yidx arg_z)) + (let ((guess imm0) + (y1 imm1) + (y2 imm1) + (gy1-lo imm2) ; look out below + (gy1-hi imm2) + (gy2-lo imm2) + (gy2-hi imm2) + (xptr temp0) + (m imm3) + (tem imm4) + (y1-idx 28) + (y2-idx 24) + (x0-idx 20) + (x1-idx 16) + (x2-idx 12)) + (stwu tsp -32 tsp) + (stw tsp 4 tsp) + (lwz y1 guess-h vsp) + (lwz tem guess-l vsp) + (compose-digit guess y1 tem) + (addi tem yidx ppc32::misc-data-offset) + (lwzx y1 yptr tem) + (stw y1 y1-idx tsp) + (subi tem tem 4) + (lwzx y2 yptr tem) + (stw y2 y2-idx tsp) + (lwz xptr x vsp) + (addi tem xidx ppc32::misc-data-offset) + (lwzx y1 xptr tem) ; its x0 + (stw y1 x0-idx tsp) + (subi tem tem 4) + (lwzx y1 xptr tem) + (stw y1 x1-idx tsp) + (subi tem tem 4) + (lwzx y1 xptr tem) + (stw y1 x2-idx tsp) + @loop + (lwz y1 y1-idx tsp) ; get y1 + (mullw gy1-lo guess y1) + (lwz m x1-idx tsp) ; get x1 + (subc m m gy1-lo) ; x1 - gy1-lo => m + (mulhwu gy1-hi guess y1) + (lwz tem x0-idx tsp) ; get x0 + (subfe. tem gy1-hi tem) ; - val not used just cr + (lwz y2 y2-idx tsp) ; get y2 + (mulhwu gy2-hi guess y2) ; does it pay to do this now even tho may not need? + (bne @done) + (cmpl :cr0 gy2-hi m) ; if > or = and foo then more - L means logical means unsigned + (blt @done) ; if < done + (bne @more) ; if = test lo + (mullw gy2-lo guess y2) + (lwz tem x2-idx tsp) ; get x2 + (cmpl :cr0 gy2-lo tem) + (ble @done) + @more + (subi guess guess 1) + (b @loop) + @done + (digit-h temp0 guess) + (vpush temp0) + (digit-l temp0 guess) + (vpush temp0) + (la temp0 20 vsp) + (lwz tsp 0 tsp) + (set-nargs 2) + (ba .spvalues))) + +(defppclapfunction normalize-bignum-loop ((sign arg_x)(res arg_y)(len arg_z)) + (let ((idx imm0) + (usign imm1) + (val imm2)) + (unbox-fixnum usign sign) + (cmpwi len 0) + (addi idx len (- ppc32::misc-data-offset 4)) + (beqlr) ; huh - can this ever happen? + @loop + (lwzx val res idx) + (cmpw val usign) + (subi idx idx '1) + (bne @neq) + (subic. len len '1) + (bgt @loop) + ; fall through - its all sign - return 1 + (li arg_z '1) + (blr) + @neq + (rlwinm usign usign 0 0 0) ; hi bit + (rlwinm val val 0 0 0) + (cmpw usign val) ; is hi bit = sign, if so then done + (beqlr) + (addi len len '1) ; if not, need 1 more + (blr))) + +(defppclapfunction %normalize-bignum-2 ((fixp arg_y)(res arg_z)) + (let ((idx imm0) + (usign imm1) + (val imm2) + (len arg_x) + (oldlen temp0)) + (lwz imm4 (- ppc32::fulltag-misc) res) + (header-length len imm4) + (cmpwi len 0) + (mr oldlen len) + (addi idx len (- ppc32::misc-data-offset 4)) + (beqlr) ; huh - can this ever happen? + (lwzx val res idx) ; high order word + (srawi usign val 31) ; get sign + @loop + (lwzx val res idx) + (cmpw val usign) + (subi idx idx '1) + (bne @neq) + (subic. len len '1) + (bgt @loop) + ; fall through - its all sign - return 1 + (li len '1) + (rlwinm usign usign 0 0 0) ; hi bit + (b @more) + @neq + (rlwinm usign usign 0 0 0) ; hi bit + (rlwinm val val 0 0 0) + (cmpw usign val) ; is hi bit = sign, if so then done + (beq @more) + (addi len len '1) ; if not, need 1 more + (b @big) + @more + (cmpwi :cr1 fixp (target-nil-value)) + (cmpwi len '1) + (beq :cr1 @big) ; dont return fixnum + (bgt @big) + ;; stuff for maybe fixnum + ;(dbg t) + (lwz val ppc32::misc-data-offset res) + (rlwinm imm4 val 0 0 2) ; hi 3 bits same? - we assume fixnumshift is 2 + (srawi usign usign 2) + (cmpw usign imm4) + (bne @big) + (box-fixnum arg_z val) + (blr) + @big + (cmpw oldlen len) + (beqlr) ; same length - done + (li imm4 ppc32::subtag-bignum) ; set new length + (rlwimi imm4 len (- ppc32::num-subtag-bits ppc32::fixnumshift) 0 (- 31 ppc32::num-subtag-bits)) + (stw imm4 ppc32::misc-header-offset res) + ; 0 to tail if negative + (cmpwi usign 0) + (beqlr) + ; zero from len inclusive to oldlen exclusive + ;(dbg t) + (addi idx len ppc32::misc-data-offset) + @loop2 + (stwx rzero idx res) + (addi len len '1) + (cmpw len oldlen) + (addi idx idx '1) + (blt @loop2) + (blr))) + +(defppclapfunction %count-digit-leading-zeros ((high arg_y) (low arg_z)) + (compose-digit imm0 high low) + (cntlzw imm0 imm0) + (box-fixnum arg_z imm0) + (blr)) + +(defppclapfunction %count-digit-trailing-zeros ((high arg_y) (low arg_z)) + (compose-digit imm0 high low) + (neg imm1 imm0) + (and imm0 imm0 imm1) + (cntlzw imm0 imm0) + (subfic imm0 imm0 31) + (box-fixnum arg_z imm0) + (blr)) + + +(defppclapfunction %bignum-count-trailing-zero-bits ((bignum arg_z)) + (let ((ndigits arg_x) + (nbits arg_y) + (digit imm0) + (ptr imm1)) + (li ptr ppc32::misc-data-offset) + (li ndigits '-32) + @next + (lwzx digit bignum ptr) + (cmpwi digit 0) + (la ptr 4 ptr) + (addi ndigits ndigits '32) + (beq @next) + (neg ptr digit) + (and digit digit ptr) + (cntlzw digit digit) + (subfic digit digit 31) + (box-fixnum nbits digit) + (add arg_z nbits ndigits) + (blr))) + + +(defppclapfunction %bignum-trim-leading-zeros ((bignum arg_x) + (start arg_y) + (len arg_z)) + (add imm1 start len) + (la imm1 (- ppc32::misc-data-offset 4) imm1) + @loop + (cmpwi cr0 len '1) + (lwzx imm0 bignum imm1) + (cmpwi cr1 imm0 0) + (la imm1 -4 imm1) + (bnelr cr1) + (la len '-1 len) + (bne @loop) + (blr)) + +;;; Set length of bignum to new-len (zeroing out any trailing words between +;;; the old length and the new. +(defppclapfunction %shrink-bignum ((new-len arg_y) (bignum arg_z)) + (let ((old-len temp0) + (old-idx imm0) + (new-idx imm2) + (header imm1)) + (getvheader header bignum) + (header-length old-len header) + (cmpw old-len new-len) + (la old-idx ppc32::misc-data-offset old-len) + (la new-idx ppc32::misc-data-offset new-len) + (beqlr) + @loop + (subi old-idx old-idx 4) + (cmpw old-idx new-idx) + (stwx ppc32::rzero bignum old-idx) + (bne @loop) + (slwi header new-len (- ppc32::num-subtag-bits ppc32::fixnumshift)) + (ori header header ppc32::subtag-bignum) + (stw header ppc32::misc-header-offset bignum) + (blr))) + +;;; Especially when large operands are involved, the GNU Multiple Precision +;;; library's algorithm's are often faster than Clozure CL's. GMP's MPN +;;; library defines operations on "limb vectors", which are basically +;;; just sequences of 32-bit digits (least-significant digit first), which +;;; is just about exactly the same way that Clozure CL stores bignums. +;;; We might want to (eventually) link some or all of GMP into Clozure CL; +;;; in the meantime, it seems that we get some performance benefit from +;;; using GMP representation and algorithms in some mixture of LAP and Lisp. +;;; To approximate the "limb vector" representation, we copy operands to +;;; (and results from) stack-allocated macptrs. Since those macptrs are +;;; word-aligned, we can use fixnums to represent word-aligned pointers. +;;; Obviously, it costs a little to copy back and forth like this; we +;;; only win when operands are fairly large, and when we can replace an +;;; N^2 algorithm with something cheaper. + +;;; Macptr MUST be word-aligned (low 2 bits must be 0). Extract +;;; such an address, return it as a fixnum. +(defppclapfunction macptr->fixnum ((ptr arg_z)) + (macptr-ptr arg_z ptr) + (blr)) + +;;; Copy the limb SRC points to to where DEST points. +(defppclapfunction copy-limb ((src arg_y) (dest arg_z)) + (lwz imm0 0 src) + (stw imm0 0 dest) + (blr)) + +;;; Return T iff LIMB contains 0. +(defppclapfunction limb-zerop ((limb arg_z)) + (lwz imm0 0 limb) + (cntlzw imm0 imm0) + (srwi imm0 imm0 5) + (bit0->boolean arg_z imm0 imm0) + (blr)) + +;;; Return -1,0,1 according to whether the contents of Y are +;;; <,=,> the contents of Z. +(defppclapfunction compare-limbs ((y arg_y) (z arg_z)) + (lwz imm1 0 z) + (lwz imm0 0 y) + (cmplw imm0 imm1) + (li arg_z 0) + (beqlr) + (li arg_z '1) + (bgtlr) + (li arg_z '-1) + (blr)) + +;;; Add a fixnum to the limb LIMB points to. Ignore overflow. +(defppclapfunction add-fixnum-to-limb ((fixnum arg_y) (limb arg_z)) + (unbox-fixnum imm0 fixnum) + (lwz imm1 0 limb) + (add imm1 imm1 imm0) + (stw imm1 0 limb) + (blr)) + +;;; Store a fixnum value where LIMB points. +(defppclapfunction copy-fixnum-to-limb ((fixnum arg_y) (limb arg_z)) + (unbox-fixnum imm0 fixnum) + (stwu imm0 0 limb) + (blr)) + +;;; Increment a "LIMB VECTOR" (bignum) by a small amount. The caller +;;; knows that carries will only propagate for a word or two. +(defppclapfunction mpn-incr-u ((limb arg_y) (fixby arg_z)) + (let ((by imm0) + (sum imm1)) + (unbox-fixnum by fixby) + @loop + (lwz sum 0 limb) + (add sum sum by) + (cmplw sum by) + (stw sum 0 limb) + (li by 1) + (la limb 4 limb) + (blt @loop) + (blr))) + +;;; Store XP-YP at WP; return carry (0 or 1). +;;; wp, xp, yp: word-aligned, unboxed ptrs (fixnums) +;;; size: boxed fixnum +;;; returns boxed carry +(defppclapfunction mpn-sub-n ((wp 0) (xp arg_x) (yp arg_y) (size arg_z)) + (vpop imm0) + (subi size size '1) + (cmpwi size 0) + (lwz imm3 0 xp) + (lwz imm4 0 yp) + (sub imm1 xp imm0) ; imm1 = xp-wp + (sub imm2 yp imm0) ; imm2 = yp-wp + (addi imm1 imm1 4) ; imm1 = xp-wp+4 + (addi imm2 imm2 4) ; imm2 = yp-wp+4 + (subfc imm3 imm4 imm3) + (stw imm3 0 imm0) ; wp[0] + (beq @done) + @top + (subi size size '1) + (cmpwi size 0) + (lwzx imm3 imm1 imm0) ; imm3 = xp[i] + (lwzx imm4 imm2 imm0) ; imm4 = xp[i] + (subfe imm3 imm4 imm3) + (stwu imm3 4 imm0) + (bne @top) + @done + (subfe imm0 rzero rzero) + (subfic imm0 imm0 0) + (box-fixnum arg_z imm0) + (blr)) + +;;; Store XP+YP at WP; return carry (0 or 1). +;;; wp, xp, yp = word-aligned, unboxed macptrs (fixnums). +;;; size = boxed fixnum +;;; result = boxed carry +(defppclapfunction mpn-add-n ((wp 0) (xp arg_x) (yp arg_y) (size arg_z)) + (vpop imm0) + (subi size size '1) + (cmpwi size 0) + (lwz imm3 0 xp) + (lwz imm4 0 yp) + (sub imm1 xp imm0) ; imm1 = xp-wp + (sub imm2 yp imm0) ; imm2 = yp-wp + (addi imm1 imm1 4) ; imm1 = xp-wp+4 + (addi imm2 imm2 4) ; imm2 = yp-wp+4 + (addc imm3 imm3 imm4) + (stw imm3 0 imm0) ; wp[0] + (beq @done) + @top + (subi size size '1) + (cmpwi size 0) + (lwzx imm3 imm1 imm0) ; imm3 = xp[i] + (lwzx imm4 imm2 imm0) ; imm4 = xp[i] + (adde imm3 imm4 imm3) + (stwu imm3 4 imm0) + (bne @top) + @done + (addze imm0 rzero) + (box-fixnum arg_z imm0) + (blr)) + +;;; Add the single limb LIMB to S1P (propagating carry.) Store the +;;; result at RP. RP and S1P may be the same place, so check for +;;; that and do nothing after carry stops propagating. Return carry. +(defppclapfunction mpn-add-1 ((rp-offset 0) (s1p arg_x) (size arg_y) (limb arg_z)) + (let ((rp temp0)) + (vpop rp) + (subi size size '1) + (cmpwi cr2 size 0) + (cmpw cr1 rp s1p) ;a common case + (subi rp rp 4) + (subi s1p s1p 4) + (lwz imm0 0 limb) + (lwzu imm1 4 s1p) + (addc imm1 imm1 imm0) + (addze. imm0 rzero) + (stwu imm1 4 rp) + (beq cr2 @done) + @top + (beq cr0 @finish) ; branch if no more carry + (subi size size '1) + (cmpwi cr2 size 0) + (lwzu imm1 4 s1p) + (addc imm1 imm1 imm0) + (addze. imm0 rzero) + (stwu imm1 4 rp) + (bne cr2 @top) + (box-fixnum arg_z imm0) + (blr) + @finish + (beq cr1 @done) + @loop + (subi size size '1) + (cmpwi cr2 size 0) + (lwzu imm1 4 s1p) + (stwu imm1 4 rp) + (bne cr2 @loop) + @done + (box-fixnum arg_z imm0) + (blr))) +;;; Multiply the limb vector S1 by the single limb at LIMBPTR, storing +;;; the result at RES. Store the "carry out" (high word of last 64-bit +;;; partial product) at the limb RESULT. +;;; res, s1, limbptr, result: +;;; unboxed, word-aligned ptrs (fixnums). size: boxed fixnum +;;; It'd be hard to transliterate the GMP code here; the GMP version +;;; uses lots more immediate registers than we can easily use in LAP +;;; (and is much more aggressively pipelined). +(defppclapfunction mpn-mul-1 ((res-offset 4) + (s1-offset 0) + (size arg_x) + (limbptr arg_y) + (result arg_z)) + (let ((limb imm0) + (resptr temp0) + (s1 temp1) + (src imm1) + (prod-low imm2) + (prod-high imm3) + (carry imm4)) + (lwz resptr res-offset vsp) + (lwz s1 s1-offset vsp) + (la vsp 8 vsp) + (la resptr -4 resptr) ; pre-decrement + (la s1 -4 s1) + (addic carry carry 0) + (li carry 0) + (lwz limb 0 limbptr) + @loop + (subi size size '1) + (cmpwi size 0) + (lwzu src 4 s1) + (mulhwu prod-high src limb) + (mullw prod-low src limb) + (addc prod-low prod-low carry) + (addze carry prod-high) + (stwu prod-low 4 resptr) + (bne @loop) + (stw carry 0 result) + (blr))) + +;;; multiply s1*limb and add result to res +;;; res, s1, limbptr, result: +;;; unboxed, word-aligned ptrs (fixnums). +;;; size: boxed fixnum +;;; limbptr: source "limb". +;;; result: carry out (high word of product). +(defppclapfunction mpn-addmul-1 ((res-offset 4) + (s1-offset 0) + (size arg_x) + (limbptr arg_y) + (result arg_z)) + (let ((limb imm0) + (resptr temp0) + (s1 temp1) + (src imm1) + (prod-low imm2) + (prod-high imm3) + (carry imm4) + (prev imm4)) + (lwz resptr res-offset vsp) + (lwz s1 s1-offset vsp) + (la vsp 8 vsp) + (la resptr -4 resptr) ; pre-decrement + (la s1 -4 s1) + (addic carry carry 0) + (li carry 0) + (lwz limb 0 limbptr) + @loop + (subi size size '1) + (cmpwi size 0) + (lwzu src 4 s1) + (mulhwu prod-high src limb) + (mullw prod-low src limb) + (addc prod-low prod-low carry) + (addze prod-high prod-high) + (lwz prev 4 resptr) + (addc prev prev prod-low) + (stwu prev 4 resptr) + (addze carry prod-high) + (bne @loop) + (stw carry 0 result) + (blr))) + +;;; Multiply the UN-word limb vector at UP and the VN-word limb vector +;;; at VP, store the result at RP. +(defppclapfunction mpn-mul-basecase ((rp-offset 4) + (up-offset 0) + (un arg_x) + (vp arg_y) + (vn arg_z)) + (let ((resptr temp0) + (s1 temp1) + (up temp2) + (rp temp3) + (size nargs) + (limb imm0) + (src imm1) + (prod-low imm2) + (prod-high imm3) + (prev imm4) + (carry imm4)) + (lwz resptr rp-offset vsp) + (la rp -4 resptr) + (lwz up up-offset vsp) + (la s1 -4 up) + (la vsp 8 vsp) + (mr size un) + (lwz limb 0 vp) + (subi vn vn '1) + (cmpwi cr2 vn 0) + (li carry 0) + @mul-1-loop + (subi size size '1) + (cmpwi size 0) + (lwzu src 4 s1) + (mulhwu prod-high src limb) + (mullw prod-low src limb) + (addc prod-low prod-low carry) + (addze carry prod-high) + (stwu prod-low 4 rp) + (bne @mul-1-loop) + (stw carry 4 rp) + @again + (beq cr2 @done) + (subi vn vn '1) + (cmpwi cr2 vn 0) + (mr rp resptr) + (la resptr 4 resptr) + (la s1 -4 up) + (lwzu limb 4 vp) + (mr size un) + (addic carry carry 0) + (li carry 0) + @addmul-1-loop + (subi size size '1) + (cmpwi size 0) + (lwzu src 4 s1) + (mulhwu prod-high src limb) + (mullw prod-low src limb) + (addc prod-low prod-low carry) + (addze prod-high prod-high) + (lwz prev 4 rp) + (addc prev prev prod-low) + (stwu prev 4 rp) + (addze carry prod-high) + (bne @addmul-1-loop) + (stw carry 4 rp) + (b @again) + @done + (li arg_z (target-nil-value)) + (blr))) + +;;; left-shift src by 1 bit, storing result at res. Return +;;; the bit that was shifted out. +(defppclapfunction mpn-lshift-1 ((resptr arg_x) (s1ptr arg_y) (size-arg arg_z)) + (let ((size temp0) + (last-bit imm0) + (prev imm1) + (curr imm2) + (sleft imm3) + (sright imm4)) + (subi size size-arg '1) + (cmpwi size 0) + (add resptr resptr size-arg) + (add s1ptr s1ptr size-arg) + (lwzu prev -4 s1ptr) + (srwi last-bit prev 31) + (box-fixnum arg_z last-bit) + (beq @end1) + @loop + (subi size size '1) + (cmpwi size 0) + (lwzu curr -4 s1ptr) + (slwi sleft prev 1) + (srwi sright curr 31) + (or sright sright sleft) + (stwu sright -4 resptr) + (beq @end2) + (subi size size '1) + (cmpwi size 0) + (lwzu prev -4 s1ptr) + (slwi sleft curr 1) + (srwi sright prev 31) + (or sright sright sleft) + (stwu sright -4 resptr) + (bne @loop) + @end1 + (slwi sleft prev 1) + (stwu sleft -4 resptr) + (blr) + @end2 + (slwi sleft curr 1) + (stwu sleft -4 resptr) + (blr))) + +;;; Do a 32x32=64 unsigned multiply of the words at X and Y. Store +;;; result (low word first) at RESULT. +(defppclapfunction umulppm ((x arg_x) (y arg_y) (result arg_z)) + (lwz imm0 0 x) + (lwz imm1 0 y) + (mullw imm2 imm0 imm1) + (mulhwu imm3 imm0 imm1) + (stw imm2 0 result) + (stw imm3 4 result) + (blr)) + + +;;; for truncate-by-fixnum etal +;;; doesnt store quotient - just returns rem in 2 halves +(defppclapfunction %floor-loop-no-quo ((q arg_x)(yhi arg_y)(ylo arg_z)) + (let ((a imm1) + (b imm2) + (y imm3) + (quo imm0) + (qidx temp0) + (qlen temp1)) + (lwz imm4 (- ppc32::fulltag-misc) q) + (header-length qlen imm4) + (subi qidx qlen 4) + (mr b rzero) + (compose-digit y yhi ylo) + @loop + (rlwinm a b -16 16 31) + (rlwinm b b 16 0 15) + (la imm4 ppc32::misc-data-offset q) + (lwzx imm4 qidx imm4) ; q contents + (rlwimi b imm4 16 16 31) ; hi 16 to lo b + ;(dbg) + (48x32-divide a b y fp0 fp1 fp2 imm4) + (fctiwz fp0 fp0) + (stwu tsp -32 tsp) + (stw tsp 4 tsp) + (stfd fp0 24 tsp) + (lwz quo (+ 24 4) tsp) ; 16 quo bits above stuff used by 48x32 + ; now mul quo by y + (mullw imm4 y quo) + ; and subtract from a,b + (subfc b imm4 b) + ; new a and b are low 2 digits of this (b) and last digit in array + ; and do it again on low 3 digits + ;(dbg) + (rlwinm a b -16 16 31) + (rlwinm b b 16 0 15) + (la imm4 ppc32::misc-data-offset q) + (lwzx imm4 qidx imm4) + (rlwimi b imm4 0 16 31) + (48x32-divide a b y fp0 fp1 fp2 imm4) + (fctiwz fp0 fp0) + (stfd fp0 16 tsp) ; quo lo + (subi qidx qidx 4) + (cmpwi :cr1 qidx 0) + (lwz quo (+ 16 4) tsp) + (lwz tsp 0 tsp) + (mullw imm4 y quo) + (subfc b imm4 b) ; b is remainder + (bge :cr1 @loop) + (digit-h temp0 b) + (vpush temp0) + (digit-l temp0 b) + (vpush temp0) + (la temp0 8 vsp) + (set-nargs 2) + (ba .SPvalues))) + + +; store result in dest, return rem in 2 halves +(defppclapfunction %floor-loop-quo ((q-stk 0)(dest arg_x)(yhi arg_y)(ylo arg_z)) + (let ((a imm1) + (b imm2) + (y imm3) + (quo imm0) + (qidx temp0) + (qlen temp1) + (q temp2)) + (vpop q) + (lwz imm4 (- ppc32::fulltag-misc) q) + (header-length qlen imm4) + (subi qidx qlen 4) + (mr b rzero) + (compose-digit y yhi ylo) + @loop + (rlwinm a b -16 16 31) + (rlwinm b b 16 0 15) + (la imm4 ppc32::misc-data-offset q) + (lwzx imm4 qidx imm4) ; q contents + (rlwimi b imm4 16 16 31) ; hi 16 to lo b + (48x32-divide a b y fp0 fp1 fp2 imm4) + (fctiwz fp0 fp0) + (stwu tsp -32 tsp) + (stw tsp 4 tsp) + (stfd fp0 24 tsp) + (lwz quo (+ 24 4) tsp) ; 16 quo bits above stuff used by 48x32 + ; now mul quo by y + (mullw imm4 y quo) + ; and subtract from a,b + (subfc b imm4 b) + ; new a and b are low 2 digits of this (b) and last digit in array + ; and do it again on low 3 digits + ;(dbg) + (rlwinm a b -16 16 31) + (rlwinm b b 16 0 15) + (la imm4 ppc32::misc-data-offset q) + (lwzx imm4 qidx imm4) + (rlwimi b imm4 0 16 31) + (48x32-divide a b y fp0 fp1 fp2 imm4) + (fctiwz fp0 fp0) + (stfd fp0 16 tsp) ; quo lo + (lwz quo (+ 16 4) tsp) + (mullw imm4 y quo) + (subfc b imm4 b) ; b is remainder + (lwz quo (+ 24 4) tsp) ; quo-hi + (rlwinm quo quo 16 0 15) + (lwz imm4 (+ 16 4) tsp) ; quo lo + (lwz tsp 0 tsp) + (rlwimi quo imm4 0 16 31) + (la imm4 ppc32::misc-data-offset dest) + (stwx quo qidx imm4) + (subic. qidx qidx 4) + (bge @loop) + (digit-h temp0 b) + (vpush temp0) + (digit-l temp0 b) + (vpush temp0) + (la temp0 8 vsp) + (set-nargs 2) + (ba .SPvalues))) + +;;; get xidx thing from x, yidx thing from y if same return #xffff +;;; #xffff otherwise get another thing from x and 1- xidx and do as +;;; %floor of xthing otherx ything +;;; Huh? +(defppclapfunction %floor-99 ((x-stk 0)(xidx arg_x)(yptr arg_y)(yidx arg_z)) + (let ((xptr temp0) + (a imm1) + (b imm2) + (y imm3) + (quo imm0)) + (vpop xptr) + (la imm4 ppc32::misc-data-offset XIDX) + (lwzx a xptr imm4) + (la imm4 ppc32::misc-data-offset YIDX) + (lwzx y yptr imm4) + (cmpw a y) + (bne @more) + (li imm4 #xffff) + (rlwinm imm4 imm4 ppc32::fixnumshift (- 16 ppc32::fixnumshift) (- 31 ppc32::fixnum-shift)) + (vpush imm4) + (vpush imm4) + (la temp0 8 vsp) + (set-nargs 2) + (ba .spvalues) + @MORE + ; a has 16 bits from ahi, bhi gets alo blo gets bhi + (la imm4 (- ppc32::misc-data-offset 4) xidx) + (lwzx b xptr imm4) + (rlwinm b b 16 16 31) ; bhi to blo + (rlwimi b a 16 0 15) ; alo to bhi + (rlwinm a a 16 16 31) ; a gets alo + (48x32-divide a b y fp0 fp1 fp2 imm4) + (fctiwz fp0 fp0) + (stwu tsp -32 tsp) + (stw tsp 4 tsp) + (stfd fp0 24 tsp) + (lwz quo (+ 24 4) tsp) ; 16 quo bits above stuff used by 48x32 + ; now mul quo by y + (mullw imm4 y quo) + ; and subtract from a,b + (subfc b imm4 b) + ; AND AGAIN + (rlwinm a b -16 16 31) ; a gets b hi + (rlwinm b b 16 0 15) ; b lo to b hi + (la imm4 (- ppc32::misc-data-offset 4) xidx) + (lwzx imm4 imm4 xptr) + (rlwimi b imm4 0 16 31) + (48x32-divide a b y fp0 fp1 fp2 imm4) + (fctiwz fp0 fp0) + (stfd fp0 16 tsp) ; quo lo + (lwz quo (+ 24 4) tsp) ; quo-hi + (box-fixnum temp0 quo) + (vpush temp0) + (lwz quo (+ 16 4) tsp) ; quo lo + (lwz tsp 0 tsp) + (box-fixnum temp0 quo) + (vpush temp0) + (la temp0 8 vsp) + (set-nargs 2) + (ba .SPvalues))) + +; End of ppc32-bignum.lisp Index: /branches/new-random/level-0/PPC/PPC64/.cvsignore =================================================================== --- /branches/new-random/level-0/PPC/PPC64/.cvsignore (revision 13309) +++ /branches/new-random/level-0/PPC/PPC64/.cvsignore (revision 13309) @@ -0,0 +1,6 @@ +*.pfsl +*.p64fsl +*.dfsl +*.d64fsl + +*~.* Index: /branches/new-random/level-0/PPC/PPC64/ppc64-bignum.lisp =================================================================== --- /branches/new-random/level-0/PPC/PPC64/ppc64-bignum.lisp (revision 13309) +++ /branches/new-random/level-0/PPC/PPC64/ppc64-bignum.lisp (revision 13309) @@ -0,0 +1,340 @@ +;;-*- Mode: Lisp; Package: CCL -*- +;;; +;;; Copyright (C) 2009 Clozure Associates +;;; Copyright (C) 1994-2001 Digitool, Inc +;;; This file is part of Clozure CL. +;;; +;;; Clozure CL is licensed under the terms of the Lisp Lesser GNU Public +;;; License , known as the LLGPL and distributed with Clozure CL as the +;;; file "LICENSE". The LLGPL consists of a preamble and the LGPL, +;;; which is distributed with Clozure CL as the file "LGPL". Where these +;;; conflict, the preamble takes precedence. +;;; +;;; Clozure CL is referenced in the preamble as the "LIBRARY." +;;; +;;; The LLGPL is also available online at +;;; http://opensource.franz.com/preamble.html + + +(in-package "CCL") + +;;; The caller has allocated a two-digit bignum (quite likely on the stack). +;;; If we can fit in a single digit (if the high word is just a sign +;;; extension of the low word), truncate the bignum in place (the +;;; trailing words should already be zeroed. +(defppclapfunction %fixnum-to-bignum-set ((bignum arg_y) (fixnum arg_z)) + (unbox-fixnum imm0 fixnum) + (srdi imm1 imm0 32) + (srawi imm2 imm0 31) + (cmpw imm2 imm1) + (stw imm0 ppc64::misc-data-offset bignum) + (li imm2 ppc64::one-digit-bignum-header) + (beq @chop) + (stw imm1 (+ ppc64::misc-data-offset 4) bignum) + (blr) + @chop + (std imm2 ppc64::misc-header-offset bignum) + (blr)) + +(defppclapfunction %multiply-and-add-loop + ((x 8) (y 0) (r arg_x) (idx arg_y) (ylen arg_z)) + (let ((cc nargs) + (xx imm2) + (yy imm3) + (rr imm4) + (i imm0) + (j imm1)) + (srdi i idx 1) + (la i ppc64::misc-data-offset i) + (ld temp0 x vsp) + (lwzx xx temp0 i) ;x[i] + (ld temp0 y vsp) + (mr temp1 r) + (li cc 0) + (li j ppc64::misc-data-offset) + @loop + (lwzx yy temp0 j) + (mulld yy xx yy) + ;; 64-bit product now in %yy + (lwzx rr temp1 i) + ;; add in digit from r[i] + (add rr rr yy) + ;; add in carry + (add rr rr cc) + (stwx rr temp1 i) + (srdi cc rr 32) ;get carry digit into low word + (cmpdi ylen '1) + (la i 4 i) + (la j 4 j) + (subi ylen ylen '1) + (bne @loop) + (stwx cc temp1 i) + (set-nargs 0) + (la vsp 16 vsp) + (blr))) + +(defppclapfunction %multiply-and-add-loop64 + ((x 8) (y 0) (r arg_x) (idx arg_y) (ylen arg_z)) + (let ((i imm0) + (j imm1) + (xx imm2) + (yy imm3) + (rr imm4) + (dd imm5) + (cc nargs)) + (ld temp0 x vsp) + (la i ppc64::misc-data-offset idx) + (ldx xx temp0 i) ;x[i] + (rotldi xx xx 32) + (ld temp0 y vsp) + (li cc 0) + (li j ppc64::misc-data-offset) + @loop + (ldx yy temp0 j) ;y[j] + (rotldi yy yy 32) + (mulld dd xx yy) ;low + (ldx rr r i) ;r[i] + (rotldi rr rr 32) + (addc rr rr dd) ;r[i] = r[i] + low + (mulhdu dd xx yy) ;high + (addze dd dd) ;carry from addding in low + (addc rr rr cc) ;add in carry digit + (addze cc dd) + (rotldi rr rr 32) + (stdx rr r i) ;update r[i] + (cmpdi ylen '1) + (la i 8 i) + (la j 8 j) + (subi ylen ylen '1) + (bne @loop) + (rotldi cc cc 32) + (stdx cc r i) + (set-nargs 0) + (la vsp 16 vsp) + (blr))) + +;;; Multiply the (32-bit) digits X and Y, producing a 64-bit result. +;;; Add the 32-bit "prev" digit and the 32-bit carry-in digit to that 64-bit +;;; result; return the halves as (VALUES high low). +(defppclapfunction %multiply-and-add4 ((x 0) (y arg_x) (prev arg_y) (carry-in arg_z)) + (let ((unboxed-x imm0) + (unboxed-y imm1) + (unboxed-prev imm2) + (unboxed-carry-in imm3) + (result64 imm4) + (high arg_y) + (low arg_z)) + (ld temp0 x vsp) + (unbox-fixnum unboxed-x temp0) + (unbox-fixnum unboxed-y y) + (unbox-fixnum unboxed-prev prev) + (unbox-fixnum unboxed-carry-in carry-in) + (mulld result64 unboxed-x unboxed-y) + (add result64 result64 unboxed-prev) + (add result64 result64 unboxed-carry-in) + (clrlsldi low result64 32 ppc64::fixnumshift) + (clrrdi high result64 32) + (srdi high high (- 32 ppc64::fixnumshift)) + (std high 0 vsp) + (set-nargs 2) + (vpush low) + (la temp0 '2 vsp) + (ba .SPvalues))) + +(defppclapfunction %multiply-and-add3 ((x arg_x) (y arg_y) (carry-in arg_z)) + (let ((unboxed-x imm0) + (unboxed-y imm1) + (unboxed-carry-in imm2) + (result64 imm3) + (high arg_y) + (low arg_z)) + (unbox-fixnum unboxed-x arg_x) + (unbox-fixnum unboxed-y y) + (unbox-fixnum unboxed-carry-in carry-in) + (mulld result64 unboxed-x unboxed-y) + (add result64 result64 unboxed-carry-in) + (clrlsldi low result64 32 ppc64::fixnumshift) + (clrrdi high result64 32) + (srdi high high (- 32 ppc64::fixnumshift)) + (vpush high) + (set-nargs 2) + (vpush low) + (la temp0 '2 vsp) + (ba .SPvalues))) + +;;; Return the (possibly truncated) 32-bit quotient and remainder +;;; resulting from dividing hi:low by divisor. +(defppclapfunction %floor ((num-high arg_x) (num-low arg_y) (divisor arg_z)) + (let ((unboxed-num imm0) + (unboxed-low imm1) + (unboxed-divisor imm2) + (unboxed-quo imm3) + (unboxed-rem imm4)) + (sldi unboxed-num num-high (- 32 ppc64::fixnumshift)) + (unbox-fixnum unboxed-low num-low) + (unbox-fixnum unboxed-divisor divisor) + (or unboxed-num unboxed-low unboxed-num) + (divdu unboxed-quo unboxed-num unboxed-divisor) + (mulld unboxed-rem unboxed-quo unboxed-divisor) + (sub unboxed-rem unboxed-num unboxed-rem) + (clrlsldi arg_y unboxed-quo 32 ppc64::fixnumshift) + (clrlsldi arg_z unboxed-rem 32 ppc64::fixnumshift) + (mr temp0 vsp) + (vpush arg_y) + (vpush arg_z) + (set-nargs 2) + (ba .SPvalues))) + +;;; Multiply two (UNSIGNED-BYTE 32) arguments, return the high and +;;; low halves of the 64-bit result +(defppclapfunction %multiply ((x arg_y) (y arg_z)) + (let ((unboxed-x imm0) + (unboxed-y imm1) + (unboxed-high imm2) + (unboxed-low imm3)) + (unbox-fixnum unboxed-x x) + (unbox-fixnum unboxed-y y) + (mulld imm2 unboxed-x unboxed-y) + (clrlsldi arg_y imm2 32 ppc64::fixnumshift) ; arg_y = low32 + (srdi imm2 imm2 32) + (box-fixnum arg_z imm2) ; arg_z = high32 + (mr temp0 vsp) + (vpush arg_z) + (set-nargs 2) + (vpush arg_y) + (ba .SPvalues))) + +;;; Any words in the "tail" of the bignum should have been +;;; zeroed by the caller. +(defppclapfunction %set-bignum-length ((newlen arg_y) (bignum arg_z)) + (sldi imm0 newlen (- ppc64::num-subtag-bits ppc64::fixnumshift)) + (ori imm0 imm0 ppc64::subtag-bignum) + (std imm0 ppc64::misc-header-offset bignum) + (blr)) + +;;; Count the sign bits in the most significant digit of bignum; +;;; return fixnum count. +(defppclapfunction %bignum-sign-bits ((bignum arg_z)) + (vector-size imm0 bignum imm0) + (sldi imm0 imm0 2) + (la imm0 (- ppc64::misc-data-offset 4) imm0) ; Reference last (most significant) digit + (lwzx imm0 bignum imm0) + (cmpwi imm0 0) + (not imm0 imm0) + (blt @wasneg) + (not imm0 imm0) + @wasneg + (cntlzw imm0 imm0) + (box-fixnum arg_z imm0) + (blr)) + +(defppclapfunction %signed-bignum-ref ((bignum arg_y) (index arg_z)) + (srdi imm0 index 1) + (la imm0 ppc64::misc-data-offset imm0) + (lwax imm0 bignum imm0) + (box-fixnum arg_z imm0) + (blr)) + + +;;; If the bignum is a one-digit bignum, return the value of the +;;; single digit as a fixnum. Otherwise, if it's a two-digit-bignum +;;; and the two words of the bignum can be represented in a fixnum, +;;; return that fixnum; else return nil. +(defppclapfunction %maybe-fixnum-from-one-or-two-digit-bignum ((bignum arg_z)) + (ld imm1 ppc64::misc-header-offset bignum) + (cmpdi cr1 imm1 ppc64::one-digit-bignum-header) + (cmpdi cr2 imm1 ppc64::two-digit-bignum-header) + (beq cr1 @one) + (bne cr2 @no) + (ld imm0 ppc64::misc-data-offset bignum) + (rotldi imm0 imm0 32) + (box-fixnum arg_z imm0) + (unbox-fixnum imm1 arg_z) + (cmpd imm0 imm1) + (beqlr) + @no + (li arg_z nil) + (blr) + @one + (lwa imm0 ppc64::misc-data-offset bignum) + (box-fixnum arg_z imm0) + (blr)) + + +(defppclapfunction %digit-logical-shift-right ((digit arg_y) (count arg_z)) + (unbox-fixnum imm0 digit) + (unbox-fixnum imm1 count) + (srw imm0 imm0 imm1) + (box-fixnum arg_z imm0) + (blr)) + +(defppclapfunction %ashr ((digit arg_y) (count arg_z)) + (unbox-fixnum imm0 digit) + (unbox-fixnum imm1 count) + (sraw imm0 imm0 imm1) + (box-fixnum arg_z imm0) + (blr)) + +(defppclapfunction %ashl ((digit arg_y) (count arg_z)) + (unbox-fixnum imm0 digit) + (unbox-fixnum imm1 count) + (slw imm0 imm0 imm1) + (clrlsldi arg_z imm0 32 ppc64::fixnumshift) + (blr)) + +(defppclapfunction macptr->fixnum ((ptr arg_z)) + (macptr-ptr imm0 ptr) + (andi. imm1 imm0 7) + (li arg_z nil) + (bne @done) + (mr arg_z imm0) + @done + (blr)) + +(defppclapfunction fix-digit-logand ((fix arg_x) (big arg_y) (dest arg_z)) ; index 0 + (let ((w1 imm0) + (w2 imm1)) + (ld w2 ppc64::misc-data-offset big) + (unbox-fixnum w1 fix) + (rotldi w2 w2 32) + (cmpdi dest nil) + (and w1 w1 w2) + (bne @store) + (box-fixnum arg_z w1) + (blr) + @store + (rotldi w1 w1 32) + (std w1 ppc64::misc-data-offset dest) + (blr))) + + + +(defppclapfunction fix-digit-logandc2 ((fix arg_x) (big arg_y) (dest arg_z)) + (cmpdi dest nil) + (ld imm1 ppc64::misc-data-offset big) + (unbox-fixnum imm0 fix) + (rotldi imm1 imm1 32) + (andc imm1 imm0 imm1) + (bne @store) + (box-fixnum arg_z imm1) + (blr) + @store + (rotldi imm1 imm1 32) + (std imm1 ppc64::misc-data-offset dest) + (blr)) + +(defppclapfunction fix-digit-logandc1 ((fix arg_x) (big arg_y) (dest arg_z)) + (cmpdi dest nil) + (ld imm1 ppc64::misc-data-offset big) + (unbox-fixnum imm0 fix) + (rotldi imm1 imm1 32) + (andc imm1 imm1 imm0) + (bne @store) + (box-fixnum arg_z imm1) + (blr) + @store + (rotldi imm1 imm1 32) + (std imm1 ppc64::misc-data-offset dest) + (blr)) + + Index: /branches/new-random/level-0/PPC/ppc-array.lisp =================================================================== --- /branches/new-random/level-0/PPC/ppc-array.lisp (revision 13309) +++ /branches/new-random/level-0/PPC/ppc-array.lisp (revision 13309) @@ -0,0 +1,848 @@ +;;;-*- Mode: Lisp; Package: CCL -*- +;;; +;;; Copyright (C) 2009 Clozure Associates +;;; Copyright (C) 1994-2001 Digitool, Inc +;;; This file is part of Clozure CL. +;;; +;;; Clozure CL is licensed under the terms of the Lisp Lesser GNU Public +;;; License , known as the LLGPL and distributed with Clozure CL as the +;;; file "LICENSE". The LLGPL consists of a preamble and the LGPL, +;;; which is distributed with Clozure CL as the file "LGPL". Where these +;;; conflict, the preamble takes precedence. +;;; +;;; Clozure CL is referenced in the preamble as the "LIBRARY." +;;; +;;; The LLGPL is also available online at +;;; http://opensource.franz.com/preamble.html + +(in-package "CCL") + +(eval-when (:compile-toplevel :execute) + #+ppc32-target + (require "PPC32-ARCH") + #+ppc64-target + (require "PPC64-ARCH") + (require "PPC-LAPMACROS")) + + +;;; Users of this shouldn't make assumptions about return value. + + +#+ppc32-target +(eval-when (:compile-toplevel :execute) +;;; Assumptions made by %init-misc + (assert (and (< ppc32::max-32-bit-ivector-subtag + ppc32::max-8-bit-ivector-subtag + ppc32::max-16-bit-ivector-subtag) + (eql ppc32::max-32-bit-ivector-subtag ppc32::subtag-simple-base-string) + (eql ppc32::max-16-bit-ivector-subtag ppc32::subtag-s16-vector) + (eql ppc32::max-8-bit-ivector-subtag 223)))) + +#+ppc32-target +(defppclapfunction %init-misc ((val arg_y) + (miscobj arg_z)) + (getvheader imm0 miscobj) + (header-size imm3 imm0) + (cmpwi cr3 imm3 0) + (extract-fulltag imm1 imm0) + (cmpwi cr0 imm1 ppc32::fulltag-nodeheader) + (extract-lowbyte imm2 imm0) + (beqlr cr3) ; Silly 0-length case + (li imm4 ppc32::misc-data-offset) + (bne cr0 @imm) + ; Node vector. Don't need to memoize, since initial value is + ; older than vector. + @node-loop + (cmpwi cr0 imm3 1) + (subi imm3 imm3 1) + (stwx val miscobj imm4) + (la imm4 4 imm4) + (bne cr0 @node-loop) + (blr) + @imm + (cmpwi cr0 imm2 ppc32::subtag-double-float-vector) + (cmpwi cr1 imm2 ppc32::max-32-bit-ivector-subtag) + (cmpwi cr2 imm2 ppc32::max-8-bit-ivector-subtag) + (cmpwi cr3 imm2 ppc32::max-16-bit-ivector-subtag) + (extract-typecode imm0 val :CR6) ; don't clobber CR0 + (cmpwi cr7 imm0 ppc32::tag-fixnum) + (beq cr0 @dfloat) + (ble cr1 @32) + (ble cr2 @8) + (ble cr3 @16) + ; Bit vector. + (cmplwi cr0 val '1) + (la imm3 31 imm3) + (srwi imm3 imm3 5) + (unbox-fixnum imm0 val) + (neg imm0 imm0) + (ble+ cr0 @set-32) + @bad + (li arg_x '#.$xnotelt) + (save-lisp-context) + (set-nargs 3) + (call-symbol %err-disp) + @dfloat + (cmpwi cr0 imm0 ppc32::subtag-double-float) + (li imm4 ppc32::misc-dfloat-offset) + (bne- cr0 @bad) + (lfd fp0 ppc32::double-float.value val) + @dfloat-loop + (cmpwi cr0 imm3 1) + (subi imm3 imm3 1) + (stfdx fp0 miscobj imm4) + (la imm4 8 imm4) + (bne cr0 @dfloat-loop) + (blr) + @32 + (cmpwi cr4 imm2 ppc32::subtag-s32-vector) + (cmpwi cr0 imm2 ppc32::subtag-single-float-vector) + (cmpwi cr2 imm0 ppc32::subtag-bignum) + (cmpwi cr3 imm2 ppc32::subtag-fixnum-vector) + (beq cr1 @char32) ; ppc32::max-32-bit-ivector-subtag + (beq cr4 @s32) + (beq cr3 @fixnum) + (bne cr0 @u32) + ;@sfloat + (cmpwi cr0 imm0 ppc32::subtag-single-float) + (bne- cr0 @bad) + (lwz imm0 ppc32::single-float.value val) + (b @set-32) + @fixnum + (unbox-fixnum imm0 val) + (beq+ cr7 @set-32) + (b @bad) + @char32 + (unbox-base-char imm0 val cr0) + (b @set-32) + @s32 + (unbox-fixnum imm0 val) + (beq+ cr7 @set-32) + (bne- cr2 @bad) + (getvheader imm0 val) + (cmpwi cr0 imm0 (logior (ash 1 ppc32::num-subtag-bits) ppc32::subtag-bignum)) + (lwz imm0 ppc32::misc-data-offset val) + (beq+ cr0 @set-32) + (b @bad) + @u32 + (extract-unsigned-byte-bits. imm0 val 30) + (unbox-fixnum imm0 val) + (beq cr0 @set-32) + (bne- cr2 @bad) + ; a one-digit bignum is ok if that digit is positive. + ; a two-digit bignum is ok if the sign-digit is 0. + (getvheader imm0 val) + (cmpwi cr2 imm0 (logior (ash 2 ppc32::num-subtag-bits) ppc32::subtag-bignum)) + (lwz imm0 ppc32::misc-data-offset val) + (cmpwi cr3 imm0 0) + (bgt- cr2 @bad) ; more than two digits. + (beq cr2 @two-digits) + (bgt+ cr3 @set-32) + (b @bad) + @two-digits + (lwz imm1 (+ 4 ppc32::misc-data-offset) val) + (cmpwi cr0 imm1 0) + (bne- cr0 @bad) + (b @set-32) + @16 + (cmpwi cr0 imm2 ppc32::subtag-u16-vector) + (la imm3 1 imm3) + (srwi imm3 imm3 1) + (beq cr3 @s16) ; ppc32::max-16-bit-ivector-subtag + (extract-unsigned-byte-bits. imm0 val 16) + (unbox-fixnum imm0 val) + (beq+ cr0 @set-16) + (b @bad) + @s16 + (slwi imm0 val (- 32 (+ 16 ppc32::fixnumshift))) + (srawi imm0 imm0 (- 32 (+ 16 ppc32::fixnumshift))) + (cmpw cr0 imm0 val) + (unbox-fixnum imm0 val) + (bne- cr7 @bad) + (beq+ cr0 @set-16) + (b @bad) + @8 + (cmpwi cr0 imm0 ppc32::subtag-s8-vector) + (la imm3 3 imm3) + (srwi imm3 imm3 2) + (beq cr2 @char8) ; ppc32::max-8-bit-ivector-subtag + (beq cr0 @s8) + (extract-unsigned-byte-bits. imm0 val 8) + (unbox-fixnum imm0 val) + (beq+ cr0 @set-8) + (b @bad) + @s8 + (slwi imm0 val (- 32 (+ 8 ppc32::fixnumshift))) + (srawi imm0 imm0 (- 32 (+ 8 ppc32::fixnumshift))) + (cmpw cr0 imm0 val) + (unbox-fixnum imm0 val) + (bne- cr7 @bad) + (beq+ cr0 @set-8) + (b @bad) + @char8 + (unbox-base-char imm0 val cr0) ; this type checks val + @set-8 ; propagate low 8 bits into low 16 + (rlwimi imm0 imm0 8 (- 32 16) (- 31 8)) + @set-16 ; propagate low 16 bits into high 16 + (rlwimi imm0 imm0 16 0 (- 31 16)) + @set-32 + (cmpwi cr0 imm3 1) + (subi imm3 imm3 1) + (stwx imm0 miscobj imm4) + (la imm4 4 imm4) + (bne cr0 @set-32) + (blr)) + +#+ppc64-target +(defppclapfunction %init-misc ((val arg_y) + (miscobj arg_z)) + (getvheader imm0 miscobj) + ;(extract-lowtag imm2 imm0) + (clrldi imm2 imm0 (- 64 ppc64::nlowtagbits)) + (header-size imm3 imm0) + (cmpdi cr3 imm3 0) + (extract-fulltag imm1 imm0) + (cmpdi cr0 imm2 ppc64::lowtag-nodeheader) + (extract-lowbyte imm2 imm0) + (beqlr cr3) ; Silly 0-length case + (li imm4 ppc64::misc-data-offset) + (bne cr0 @imm) + ;; Node vector. Don't need to memoize, since initial value is + ;; older than vector. + @node-loop + (cmpdi cr0 imm3 1) + (subi imm3 imm3 1) + (stdx val miscobj imm4) + (la imm4 ppc64::node-size imm4) + (bne cr0 @node-loop) + (blr) + @imm + (extract-typecode imm0 val) + (cmpdi cr0 imm1 ppc64::ivector-class-64-bit) + (cmpdi cr1 imm1 ppc64::ivector-class-32-bit) + (cmpdi cr2 imm1 ppc64::ivector-class-8-bit) + (cmpwi cr7 imm0 ppc64::tag-fixnum) + (beq cr0 @64) + (beq cr1 @32) + (beq cr2 @8) + ;; u16, s16, or bit-vector. Val must be a fixnum. + (cmpdi cr0 imm2 ppc64::subtag-u16-vector) + (cmpdi cr1 imm2 ppc64::subtag-s16-vector) + (bne cr7 @bad) ; not a fixnum + (beq cr0 @u16) + (beq cr1 @s16) + ; Bit vector. + (cmpldi cr0 val '1) + (la imm3 31 imm3) + (srdi imm3 imm3 5) + (unbox-fixnum imm0 val) + (neg imm0 imm0) + (ble+ cr0 @set-32) + @bad + (li arg_x '#.$xnotelt) + (save-lisp-context) + (set-nargs 3) + (call-symbol %err-disp) + @64 + (cmpdi cr3 imm2 ppc64::subtag-fixnum-vector) + (cmpdi cr1 imm2 ppc64::subtag-double-float-vector) + (cmpdi cr2 imm2 ppc64::subtag-s64-vector) + (beq cr3 @fixnum) + (beq cr1 @dfloat) + (beq cr2 @u64) + ;; s64 + (unbox-fixnum imm0 val) + (beq cr7 @set-64) ; all fixnums are (SIGNED-BYTE 64) + (bne cr3 @bad) ; as are 2-digit bignums + (getvheader imm1 val) + (ld imm0 ppc64::misc-data-offset val) + (cmpdi imm1 ppc64::two-digit-bignum-header) + (rotldi imm0 imm0 32) + (beq @set-64) + (b @bad) +@fixnum + (unbox-fixnum imm0 val) + (beq cr7 @set-64) ; all fixnums are (SIGNED-BYTE 64) + (b @bad) ; as are 2-digit bignums + ;; u64 if fixnum and positive, 2-digit bignum and positive, or + ;; 3-digit bignum with most-significant digit 0. + @u64 + (cmpdi cr2 val 0) + (bne cr7 @u64-maybe-bignum) + (bge cr2 @set-64) + (b @bad) + @u64-maybe-bignum + (bne cr3 @bad) + (ld imm0 ppc64::misc-data-offset val) + (getvheader imm1 val) + (rotldi imm0 imm0 32) + (cmpdi cr2 imm1 ppc64::two-digit-bignum-header) + (cmpdi cr3 imm1 ppc64::three-digit-bignum-header) + (cmpdi cr0 imm0 0) + (beq cr2 @u32-two-digit) + (bne cr3 @bad) + (lwz imm1 (+ 8 ppc64::misc-data-offset) val) + (cmpwi imm0 0) + (beq @set-64) + (b @bad) + @u32-two-digit + (bgt cr0 @set-64) + (b @bad) + @dfloat + (cmpdi cr0 imm0 ppc64::subtag-double-float) + (bne- cr0 @bad) + (ld imm0 ppc64::double-float.value val) + (b @set-64) + @32 + (cmpdi cr3 imm2 ppc64::subtag-simple-base-string) + (cmpdi cr2 imm2 ppc64::subtag-s32-vector) + (cmpdi cr0 imm2 ppc64::subtag-single-float-vector) + (beq cr3 @char32) + (beq cr2 @s32) + (bne cr0 @u32) + ;@sfloat + (cmpdi cr0 imm0 ppc64::subtag-single-float) + (srdi imm0 val 32) + (bne- cr0 @bad) + (b @set-32) + @s32 + ;; Must be a fixnum (and a (SIGNED-BYTE 32)). + (bne cr7 @bad) + (unbox-fixnum imm0 val) + (sldi imm1 imm0 32) + (sradi imm1 imm1 32) + (cmpd imm1 imm0) + (bne @bad) + (b @set-32) + @char32 + (unbox-base-char imm0 val cr0) ; this type checks val + (b @set-32) + @u32 + ;; Also has to be a fixnum (and an (UNSIGNED-BYTE 32)). + (unbox-fixnum imm0 val) + (clrrdi. imm1 imm0 32) ; ~Z if any high bits set + (bne cr7 @bad) + (bne cr0 @bad) + (b @set-32) + @u16 + (unbox-fixnum imm0 val) + (clrrdi. imm1 imm0 16) + (bne cr7 @bad) + (bne cr0 @bad) + (b @set-16) + @s16 + (sldi imm0 val (- 64 (+ 16 ppc64::fixnumshift))) + (sradi imm0 imm0 (- 64 (+ 16 ppc64::fixnumshift))) + (cmpw cr0 imm0 val) + (unbox-fixnum imm0 val) + (bne- cr7 @bad) + (beq+ cr0 @set-16) + (b @bad) + @8 + (cmpdi cr0 imm2 ppc64::subtag-s8-vector) + (beq cr0 @s8) + (extract-unsigned-byte-bits. imm0 val 8) + (unbox-fixnum imm0 val) + (beq+ cr0 @set-8) + (b @bad) + @s8 + (sldi imm0 val (- 64 (+ 8 ppc64::fixnumshift))) + (sradi imm0 imm0 (- 64 (+ 8 ppc64::fixnumshift))) + (cmpd cr0 imm0 val) + (unbox-fixnum imm0 val) + (bne- cr7 @bad) + (beq+ cr0 @set-8) + (b @bad) + @char8 + (unbox-base-char imm0 val cr0) ; this type checks val + @set-8 ; propagate low 8 bits into low 16 + (la imm3 1 imm3) + (rlwimi imm0 imm0 8 (- 32 16) (- 31 8)) + (srdi imm3 imm3 1) + @set-16 ; propagate low 16 bits into high 16 + (la imm3 1 imm3) + (rlwimi imm0 imm0 16 0 (- 31 16)) + (srdi imm3 imm3 1) + @set-32 ; propagate low 32 bits into high 32 + (la imm3 1 imm3) + (rldimi imm0 imm0 32 0) + (srdi imm3 imm3 1) + @set-64 + (cmpdi cr0 imm3 1) + (subi imm3 imm3 1) + (stdx imm0 miscobj imm4) + (la imm4 8 imm4) + (bne cr0 @set-64) + (blr)) + +;;; Make a new vector of size newsize whose subtag matches that of oldv-arg. +;;; Blast the contents of the old vector into the new one as quickly as +;;; possible; leave remaining elements of new vector undefined (0). +;;; Return new-vector. +#+ppc32-target +(defppclapfunction %extend-vector ((start-arg arg_x) (oldv-arg arg_y) (newsize arg_z)) + (let ((oldv save0) + (oldsize save1) + (oldsubtag save2) + (start-offset save3)) + (save-lisp-context) + (:regsave save3 0) + (vpush save0) + (vpush save1) + (vpush save2) + (vpush save3) + (mr oldv oldv-arg) + (mr start-offset start-arg) + (getvheader imm0 oldv) + (header-length oldsize imm0) + (header-subtag[fixnum] oldsubtag imm0) + (mr arg_y newsize) + (mr arg_z oldsubtag) + (bla .SPmisc-alloc) + (extrwi imm0 oldsubtag ppc32::ntagbits (- 32 (+ ppc32::fixnumshift ppc32::ntagbits))) + (cmpwi cr0 oldsize 0) + (cmpwi cr1 imm0 ppc32::fulltag-nodeheader) + (cmpwi cr2 oldsubtag '#.ppc32::max-32-bit-ivector-subtag) + (la imm1 ppc32::misc-data-offset start-offset) + (li imm3 ppc32::misc-data-offset) + (beq cr0 @done) + (bne cr1 @imm) + ;; copy nodes. New vector is "new", so no memoization required. + @node-loop + (cmpwi cr0 oldsize '1) + (lwzx temp0 oldv imm1) + (addi imm1 imm1 4) + (subi oldsize oldsize '1) + (stwx temp0 arg_z imm3) + (addi imm3 imm3 4) + (bne cr0 @node-loop) + ;;Restore registers. New vector's been in arg_z all this time. + @done + (lwz save3 0 vsp) + (lwz save2 4 vsp) + (lwz save1 8 vsp) + (lwz save0 12 vsp) + (restore-full-lisp-context) + (blr) + @imm + (unbox-fixnum imm2 oldsize) + (unbox-fixnum imm3 start-offset) + (li imm1 ppc32::misc-data-offset) + (la imm4 ppc32::misc-data-offset start-offset) + (cmpwi cr1 oldsubtag '#.ppc32::max-8-bit-ivector-subtag) + (cmpwi cr0 oldsubtag '#.ppc32::max-16-bit-ivector-subtag) + (ble cr2 @fullword-loop) + (cmpwi cr2 oldsubtag '#.ppc32::subtag-bit-vector) + (ble cr1 @8-bit) + (ble cr0 @16-bit) + (beq cr2 @1-bit) + ;; 64-bit (double-float) vectors. There's a different + ;; initial offset, but we're always word-aligned, so that + ;; part's easy. + (li imm1 ppc32::misc-dfloat-offset) ; scaled destination pointer + (slwi imm2 imm2 1) ; twice as many fullwords + (slwi imm3 imm3 3) ; convert dword count to byte offset + (la imm4 ppc32::misc-dfloat-offset imm3) ; scaled source pointer + (b @fullword-loop) + ;; The bitvector case is hard if START-OFFSET isn't on an 8-bit boundary, + ;; and can be turned into the 8-bit case otherwise. + ;; The 8-bit case is hard if START-OFFSET isn't on a 16-bit boundary, + ;; and can be turned into the 16-bit case otherwise. + ;; The 16-bit case is hard if START-OFFSET isn't on a 32-bit boundary, + ;; and can be turned into the 32-bit case otherwise. + ;; Hmm. + @1-bit + (clrlwi. imm0 imm3 (- 32 3)) + (bne- cr0 @hard-1-bit) + (srwi imm3 imm3 3) ; bit offset to byte offset + (addi imm2 imm2 7) + (srwi imm2 imm2 3) ; bit count to byte count + @8-bit + ; If the byte offset's even, copy half as many halfwords + (clrlwi. imm0 imm3 (- 32 1)) + (bne- cr0 @hard-8-bit) + (addi imm2 imm2 1) + (srwi imm2 imm2 1) ; byte count to halfword count + (srwi imm3 imm3 1) ; byte offset to halfword offset + @16-bit + ; If the halfword offset's even, copy half as many fullwords + (clrlwi. imm0 imm3 (- 32 1)) + (bne- cr0 @hard-16-bit) + (addi imm2 imm2 1) + (srwi imm2 imm2 1) ; halfword count to fullword count + (li imm1 ppc32::misc-data-offset) + @fullword-loop + (cmpwi cr0 imm2 1) + (lwzx imm0 oldv imm4) + (addi imm4 imm4 4) + (subi imm2 imm2 1) + (stwx imm0 arg_z imm1) + (addi imm1 imm1 4) + (bne cr0 @fullword-loop) + (b @done) + ;;; This can just do a uvref/uvset loop. Cases that can + ;;; cons (x32, double-float) have already been dealt with. + @hard-1-bit + @hard-8-bit + @hard-16-bit + (let ((newv save4) + (outi save5) + (oldlen save6)) + (vpush save4) + (vpush save5) + (vpush save6) + (mr newv arg_z) + (sub oldlen oldsize start-offset) + (li outi 0) + @hard-loop + (mr arg_y oldv) + (mr arg_z start-offset) + (bla .SPmisc-ref) + (mr arg_x newv) + (mr arg_y outi) + (bla .SPmisc-set) + (la outi '1 outi) + (cmpw cr0 outi oldlen) + (la start-offset '1 start-offset) + (bne @hard-loop) + (mr arg_z newv) + (vpop save6) + (vpop save5) + (vpop save4) + (b @done)))) + +#+ppc64-target +(defppclapfunction %extend-vector ((start-arg arg_x) (oldv-arg arg_y) (newsize arg_z)) + (let ((oldv save0) + (oldsize save1) + (oldsubtag save2) + (start-offset save3)) + (save-lisp-context) + (:regsave save3 0) + (vpush save0) + (vpush save1) + (vpush save2) + (vpush save3) + (mr oldv oldv-arg) + (mr start-offset start-arg) + (getvheader imm0 oldv) + (header-length oldsize imm0) + (header-subtag[fixnum] oldsubtag imm0) + (mr arg_y newsize) + (mr arg_z oldsubtag) + (bla .SPmisc-alloc) + (unbox-fixnum imm0 oldsubtag) + (extract-lowtag imm1 imm0) + (extract-fulltag imm2 imm0) + (cmpdi cr0 oldsize 0) + (cmpdi cr1 imm1 ppc64::lowtag-nodeheader) + (cmpdi cr2 imm2 ppc64::ivector-class-8-bit) + (cmpdi cr3 imm2 ppc64::ivector-class-32-bit) + (cmpdi cr4 imm2 ppc64::ivector-class-64-bit) + (cmpdi cr5 imm0 ppc64::subtag-bit-vector) + (li imm3 ppc64::misc-data-offset) + (beq cr0 @done) + (bne cr1 @imm) + (la imm1 ppc64::misc-data-offset start-offset) + ;; copy nodes. New vector is "new", so no memoization required. + @node-loop + (cmpdi cr0 oldsize '1) + (ldx temp0 oldv imm1) + (addi imm1 imm1 8) + (subi oldsize oldsize '1) + (stdx temp0 arg_z imm3) + (addi imm3 imm3 8) + (bne cr0 @node-loop) + ;;Restore registers. New vector's been in arg_z all this time. + @done + (ld save3 0 vsp) + (ld save2 8 vsp) + (ld save1 16 vsp) + (ld save0 24 vsp) + (restore-full-lisp-context) + (blr) + @imm + (beq cr2 @8-bit) + (beq cr3 @32-bit) + (beq cr4 @64-bit) + (beq cr5 @1-bit) + (srdi imm1 start-offset 2) + (la imm1 ppc64::misc-data-offset imm1) + @16-loop + (cmpdi cr0 oldsize '1) + (lhzx imm4 oldv imm1) + (addi imm1 imm1 2) + (subi oldsize oldsize '1) + (sthx imm4 arg_z imm3) + (addi imm3 imm3 2) + (bne cr0 @16-loop) + (b @done) + @8-bit + (srdi imm1 start-offset 3) + (la imm1 ppc64::misc-data-offset imm1) + @8-loop + (cmpdi cr0 oldsize '1) + (lbzx imm4 oldv imm1) + (addi imm1 imm1 1) + (subi oldsize oldsize '1) + (stbx imm4 arg_z imm3) + (addi imm3 imm3 1) + (bne cr0 @8-loop) + (b @done) + @32-bit + (srdi imm1 start-offset 1) + (la imm1 ppc64::misc-data-offset imm1) + @32-loop + (cmpdi cr0 oldsize '1) + (lwzx imm4 oldv imm1) + (addi imm1 imm1 4) + (subi oldsize oldsize '1) + (stwx imm4 arg_z imm3) + (addi imm3 imm3 4) + (bne cr0 @32-loop) + (b @done) + @64-bit + (la imm1 ppc64::misc-data-offset start-offset) + @64-loop + (cmpdi cr0 oldsize '1) + (ldx imm4 oldv imm1) + (addi imm1 imm1 8) + (subi oldsize oldsize '1) + (stdx imm4 arg_z imm3) + (addi imm3 imm3 8) + (bne cr0 @64-loop) + (b @done) + @1-bit + (let ((newv save4) + (outi save5) + (oldlen save6)) + (vpush save4) + (vpush save5) + (vpush save6) + (mr newv arg_z) + (sub oldlen oldsize start-offset) + (li outi 0) + @hard-loop + (mr arg_y oldv) + (mr arg_z start-offset) + (bla .SPmisc-ref) + (mr arg_x newv) + (mr arg_y outi) + (bla .SPmisc-set) + (la outi '1 outi) + (cmpd cr0 outi oldlen) + (la start-offset '1 start-offset) + (bne @hard-loop) + (mr arg_z newv) + (vpop save6) + (vpop save5) + (vpop save4) + (b @done)))) + + +;;; argument is a vector header or an array header. Or else. +(defppclapfunction %array-header-data-and-offset ((a arg_z)) + (let ((offset arg_y) + (disp arg_x) + (temp temp0)) + (li offset 0) + (mr temp a) + @loop + (ldr a target::arrayH.data-vector temp) + (lbz imm0 target::misc-subtag-offset a) + (cmpri cr0 imm0 target::subtag-vectorH) + (ldr disp target::arrayH.displacement temp) + (mr temp a) + (add offset offset disp) + (ble cr0 @loop) + (vpush a) + (vpush offset) + (set-nargs 2) + (la temp0 (* 2 (ash 1 target::word-shift)) vsp) + (ba .SPvalues))) + + +;;; If the bit-arrays are all simple-bit-vectorp, we can do the operations +;;; 32 bits at a time. (other case have to worry about alignment/displacement.) +#+ppc32-target +(defppclapfunction %simple-bit-boole ((op 0) (b1 arg_x) (b2 arg_y) (result arg_z)) + (la imm0 4 vsp) + (save-lisp-context imm0) + (vector-size imm4 result imm4) + (srwi. imm3 imm4 5) + (clrlwi imm4 imm4 27) + (bl @get-dispatch) + (cmpwi cr1 imm4 0) + (mflr loc-pc) + (lwz temp0 op vsp) + (add loc-pc loc-pc temp0) + (add loc-pc loc-pc temp0) + (mtctr loc-pc) + (li imm0 ppc32::misc-data-offset) + (b @testw) + @nextw + (cmpwi cr0 imm3 1) + (subi imm3 imm3 1) + (lwzx imm1 b1 imm0) + (lwzx imm2 b2 imm0) + (bctrl) + (stwx imm1 result imm0) + (addi imm0 imm0 4) + @testw + (bne cr0 @nextw) + (beq cr1 @done) + ;; Not sure if we need to make this much fuss about the partial word + ;; in this simple case, but what the hell. + (lwzx imm1 b1 imm0) + (lwzx imm2 b2 imm0) + (bctrl) + (lwzx imm2 result imm0) + (slw imm2 imm2 imm4) + (srw imm2 imm2 imm4) + (subfic imm4 imm4 32) + (srw imm1 imm1 imm4) + (slw imm1 imm1 imm4) + (or imm1 imm1 imm2) + (stwx imm1 result imm0) + @done + (restore-full-lisp-context) + (blr) + + @get-dispatch + (blrl) + @disptach + (li imm1 0) ; boole-clr + (blr) + (li imm1 -1) ; boole-set + (blr) + (blr) ; boole-1 + (blr) + (mr imm1 imm2) ; boole-2 + (blr) + (not imm1 imm1) ; boole-c1 + (blr) + (not imm1 imm2) ; boole-c2 + (blr) + (and imm1 imm1 imm2) ; boole-and + (blr) + (or imm1 imm1 imm2) ; boole-ior + (blr) + (xor imm1 imm1 imm2) ; boole-xor + (blr) + (eqv imm1 imm1 imm2) ; boole-eqv + (blr) + (nand imm1 imm1 imm2) ; boole-nand + (blr) + (nor imm1 imm1 imm2) ; boole-nor + (blr) + (andc imm1 imm2 imm1) ; boole-andc1 + (blr) + (andc imm1 imm1 imm2) ; boole-andc2 + (blr) + (orc imm1 imm2 imm1) ; boole-orc1 + (blr) + (orc imm1 imm1 imm2) ; boole-orc2 + (blr)) + +#+ppc64-target +(defppclapfunction %simple-bit-boole ((op 0) (b1 arg_x) (b2 arg_y) (result arg_z)) + (la imm0 8 vsp) + (save-lisp-context imm0) + (vector-size imm4 result imm4) + (srdi. imm3 imm4 6) + (clrldi imm4 imm4 (- 64 6)) + (bl @get-dispatch) + (cmpdi cr1 imm4 0) ; at most low 6 bits set in imm4 + (mflr loc-pc) + (ld temp0 op vsp) + (add loc-pc loc-pc temp0) + (mtctr loc-pc) + (li imm0 ppc64::misc-data-offset) + (b @testd) + @nextd + (cmpdi cr0 imm3 1) + (subi imm3 imm3 1) + (ldx imm1 b1 imm0) + (ldx imm2 b2 imm0) + (bctrl) + (stdx imm1 result imm0) + (addi imm0 imm0 8) + @testd + (bne cr0 @nextd) + (beq cr1 @done) + ;; Not sure if we need to make this much fuss about the partial word + ;; in this simple case, but what the hell. + (ldx imm1 b1 imm0) + (ldx imm2 b2 imm0) + (bctrl) + (ldx imm2 result imm0) + (sld imm2 imm2 imm4) + (srd imm2 imm2 imm4) + (subfic imm4 imm4 64) + (srd imm1 imm1 imm4) + (sld imm1 imm1 imm4) + (or imm1 imm1 imm2) + (stdx imm1 result imm0) + @done + (restore-full-lisp-context) + (blr) + + @get-dispatch + (blrl) + @disptach + (li imm1 0) ; boole-clr + (blr) + (li imm1 -1) ; boole-set + (blr) + (blr) ; boole-1 + (blr) + (mr imm1 imm2) ; boole-2 + (blr) + (not imm1 imm1) ; boole-c1 + (blr) + (not imm1 imm2) ; boole-c2 + (blr) + (and imm1 imm1 imm2) ; boole-and + (blr) + (or imm1 imm1 imm2) ; boole-ior + (blr) + (xor imm1 imm1 imm2) ; boole-xor + (blr) + (eqv imm1 imm1 imm2) ; boole-eqv + (blr) + (nand imm1 imm1 imm2) ; boole-nand + (blr) + (nor imm1 imm1 imm2) ; boole-nor + (blr) + (andc imm1 imm2 imm1) ; boole-andc1 + (blr) + (andc imm1 imm1 imm2) ; boole-andc2 + (blr) + (orc imm1 imm2 imm1) ; boole-orc1 + (blr) + (orc imm1 imm1 imm2) ; boole-orc2 + (blr)) + + +(defppclapfunction %aref2 ((array arg_x) (i arg_y) (j arg_z)) + (check-nargs 3) + (ba .SParef2)) + +(defppclapfunction %aref3 ((array 0) (i arg_x) (j arg_y) (k arg_z)) + (check-nargs 4) + (vpop temp0) + (ba .SParef3)) + + +(defppclapfunction %aset2 ((array 0) (i arg_x) (j arg_y) (newval arg_z)) + (check-nargs 4) + (vpop temp0) + (ba .SPaset2)) + +(defppclapfunction %aset3 ((array #.target::node-size) (i 0) (j arg_x) (k arg_y) (newval arg_z)) + (check-nargs 5) + (vpop temp0) + (vpop temp1) + (ba .SPaset3)) + + Index: /branches/new-random/level-0/PPC/ppc-clos.lisp =================================================================== --- /branches/new-random/level-0/PPC/ppc-clos.lisp (revision 13309) +++ /branches/new-random/level-0/PPC/ppc-clos.lisp (revision 13309) @@ -0,0 +1,331 @@ +;;;-*- Mode: Lisp; Package: CCL -*- +;;; +;;; Copyright (C) 2009 Clozure Associates +;;; Copyright (C) 1994-2001 Digitool, Inc +;;; This file is part of Clozure CL. +;;; +;;; Clozure CL is licensed under the terms of the Lisp Lesser GNU Public +;;; License , known as the LLGPL and distributed with Clozure CL as the +;;; file "LICENSE". The LLGPL consists of a preamble and the LGPL, +;;; which is distributed with Clozure CL as the file "LGPL". Where these +;;; conflict, the preamble takes precedence. +;;; +;;; Clozure CL is referenced in the preamble as the "LIBRARY." +;;; +;;; The LLGPL is also available online at +;;; http://opensource.franz.com/preamble.html + +(in-package "CCL") + +;;; It's easier to keep this is LAP; we want to play around with its +;;; constants. + +;;; This just maps a SLOT-ID to a SLOT-DEFINITION or NIL. +;;; The map is a vector of (UNSIGNED-BYTE 8); this should +;;; be used when there are less than 255 slots in the class. +(defppclapfunction %small-map-slot-id-lookup ((slot-id arg_z)) + (ldr temp1 'map nfn) + (svref arg_x slot-id.index slot-id) + (getvheader imm0 temp1) + (header-length imm3 imm0) + (ldr temp0 'table nfn) + (cmplr arg_x imm3) + (srri imm0 arg_x target::word-shift) + (la imm0 target::misc-data-offset imm0) + (li imm1 target::misc-data-offset) + (bge @have-scaled-table-index) + (lbzx imm1 temp1 imm0) + (slri imm1 imm1 target::word-shift) + (la imm1 target::misc-data-offset imm1) + @have-scaled-table-index + (ldrx arg_z temp0 imm1) + (blr)) + +;;; The same idea, only the map is a vector of (UNSIGNED-BYTE 32). +(defppclapfunction %large-map-slot-id-lookup ((slot-id arg_z)) + (ldr temp1 'map nfn) + (svref arg_x slot-id.index slot-id) + (getvheader imm0 temp1) + (header-length imm3 imm0) + (ldr temp0 'table nfn) + (cmplr arg_x imm3) + #+ppc64-target + (progn + (srdi imm0 imm0 1) + (la imm0 target::misc-data-offset imm0)) + #+pp32-target + (progn + (la imm0 target::misc-data-offset arg_x)) + (li imm1 target::misc-data-offset) + (bge @have-scaled-table-index) + (lwzx imm1 temp1 imm0) + (slri imm1 imm1 target::word-shift) + (la imm1 target::misc-data-offset imm1) + @have-scaled-table-index + (ldrx arg_z temp0 imm1) + (blr)) + +(defppclapfunction %small-slot-id-value ((instance arg_y) (slot-id arg_z)) + (ldr temp1 'map nfn) + (svref arg_x slot-id.index slot-id) + (getvheader imm0 temp1) + (ldr temp0 'table nfn) + (header-length imm3 imm0) + (cmplr arg_x imm3) + (srri imm0 arg_x target::word-shift) + (la imm0 target::misc-data-offset imm0) + (bge @missing) + (lbzx imm1 temp1 imm0) + (cmpri imm1 0) + (slri imm1 imm1 target::word-shift) + (la imm1 target::misc-data-offset imm1) + (beq @missing) + (ldrx arg_z temp0 imm1) + (ldr arg_x 'class nfn) + (ldr nfn '%maybe-std-slot-value nfn) + (ldr temp0 target::misc-data-offset nfn) + (set-nargs 3) + (mtctr temp0) + (bctr) + @missing ; (%slot-id-ref-missing instance id) + (ldr nfn '%slot-id-ref-missing nfn) + (set-nargs 2) + (ldr temp0 target::misc-data-offset nfn) + (mtctr temp0) + (bctr)) + +(defppclapfunction %large-slot-id-value ((instance arg_y) (slot-id arg_z)) + (ldr temp1 'map nfn) + (svref arg_x slot-id.index slot-id) + (getvheader imm0 temp1) + (ldr temp0 'table nfn) + (header-length imm3 imm0) + (cmplr arg_x imm3) + #+ppc64-target + (progn + (srdi imm0 arg_x 1) + (la imm0 target::misc-data-offset imm0)) + #+ppc32-target + (progn + (la imm0 target::misc-data-offset arg_x)) + (bge @missing) + (lwzx imm1 temp1 imm0) + (cmpri imm1 0) + (slri imm1 imm1 target::word-shift) + (la imm1 target::misc-data-offset imm1) + (beq @missing) + @have-scaled-table-index + (ldr arg_x 'class nfn) + (ldr nfn '%maybe-std-slot-value-using-class nfn) + (ldrx arg_z temp0 imm1) + (ldr temp0 target::misc-data-offset nfn) + (set-nargs 3) + (mtctr temp0) + (bctr) + @missing ; (%slot-id-ref-missing instance id) + (ldr nfn '%slot-id-ref-missing nfn) + (set-nargs 2) + (ldr temp0 target::misc-data-offset nfn) + (mtctr temp0) + (bctr)) + +(defppclapfunction %small-set-slot-id-value ((instance arg_x) + (slot-id arg_y) + (new-value arg_z)) + (ldr temp1 'map nfn) + (svref imm3 slot-id.index slot-id) + (getvheader imm0 temp1) + (ldr temp0 'table nfn) + (header-length imm5 imm0) + (cmplr imm3 imm5) + (srri imm0 imm3 target::word-shift) + (la imm0 target::misc-data-offset imm0) + (bge @missing) + (lbzx imm1 temp1 imm0) + (cmpwi imm1 0) + (slri imm1 imm1 target::word-shift) + (la imm1 target::misc-data-offset imm1) + (beq @missing) + @have-scaled-table-index + (ldr temp1 'class nfn) + (ldrx arg_y temp0 imm1) + (ldr nfn '%maybe-std-setf-slot-value-using-class nfn) + (set-nargs 4) + (ldr temp0 target::misc-data-offset nfn) + (vpush temp1) + (mtctr temp0) + (bctr) + @missing ; (%slot-id-set-missing instance id new-value) + (ldr nfn '%slot-id-set-missing nfn) + (set-nargs 3) + (ldr temp0 target::misc-data-offset nfn) + (mtctr temp0) + (bctr)) + +(defppclapfunction %large-set-slot-id-value ((instance arg_x) + (slot-id arg_y) + (new-value arg_z)) + (ldr temp1 'map nfn) + (svref imm3 slot-id.index slot-id) + (getvheader imm0 temp1) + (ldr temp0 'table nfn) + (header-length imm5 imm0) + (cmplr imm3 imm5) + #+ppc64-target (srdi imm3 imm3 1) + (la imm0 target::misc-data-offset imm3) + (bge @missing) + (lwzx imm1 temp1 imm0) + (cmpwi imm1 0) + (slri imm1 imm1 target::word-shift) + (la imm1 target::misc-data-offset imm1) + (beq @missing) + @have-scaled-table-index + (ldr temp1 'class nfn) + (ldrx arg_y temp0 imm1) + (ldr nfn '%maybe-std-setf-slot-value-using-class nfn) + (set-nargs 4) + (svref temp0 0 nfn) + (vpush temp1) + (mtctr temp0) + (bctr) + @missing ; (%slot-id-set-missing instance id new-value) + (ldr nfn '%slot-id-ref-missing nfn) + (set-nargs 3) + (ldr temp0 target::misc-data-offset nfn) + (mtctr temp0) + (bctr)) + +#-dont-use-lexprs +(defparameter *gf-proto* + (nfunction + gag + (lambda (&lap &lexpr args) + (ppc-lap-function + gag + () + (mflr loc-pc) + (vpush-argregs) + (vpush nargs) + (add imm0 vsp nargs) + (la imm0 (ash 1 target::word-shift) imm0) ; caller's vsp + (bla .SPlexpr-entry) + (mtlr loc-pc) ; return to kernel + (mr arg_z vsp) ; lexpr + (svref arg_y gf.dispatch-table nfn) ; dispatch table + (set-nargs 2) + (svref nfn gf.dcode nfn) ; dcode function + (ldr temp0 target::misc-data-offset nfn) + (mtctr temp0) + (bctr))))) + +#+dont-use-lexprs +(defparameter *gf-proto* + (nfunction + gag + (lambda (&lap &rest args) + (ppc-lap-function + gag + () + ;;(bkpt) + (mflr loc-pc) + (bla .SPstack-rest-arg) + (vpop arg_z) + (stru sp (- target::lisp-frame.size) sp) + (str fn target::lisp-frame.savefn sp) + (str loc-pc target::lisp-frame.savelr sp) + (str vsp target::lisp-frame.savevsp sp) + (mr fn nfn) + ;; If we were called for multiple values, call the dcode + ;; for multiple values. + (ref-global imm0 ret1valaddr) + (cmpr imm0 loc-pc) + (svref arg_y gf.dispatch-table fn) ; dispatch table + (set-nargs 2) + (svref nfn gf.dcode fn) ; dcode function + (beq @multiple) + (ldr temp0 target::misc-data-offset nfn) + (mtctr temp0) + (bctrl) + (ldr tsp 0 tsp) + (restore-full-lisp-context) + (blr) + @multiple + (bl @getback) + (mflr loc-pc) + (stru sp (- target::lisp-frame.size) sp) + (str fn target::lisp-frame.savefn sp) + (str loc-pc target::lisp-frame.savelr sp) + (str vsp target::lisp-frame.savevsp sp) + (mtlr imm0) + (li fn 0) + (ldr temp0 target::misc-data-offset nfn) + (mtctr temp0) + (bctr) + @getback + (blrl) + @back + (ldr tsp 0 tsp) + (ba .SPnvalret))))) + + + +(defppclapfunction funcallable-trampoline () + (svref nfn gf.dcode nfn) + (svref temp0 0 nfn) + (mtctr temp0) + (bctr)) + +;;; This can't reference any of the function's constants. +(defppclapfunction unset-fin-trampoline () + (mflr loc-pc) + (bla .SPheap-rest-arg) ; cons up an &rest arg, vpush it + (vpop arg_z) ; whoops, didn't really want to + (bla .SPsavecontextvsp) + (li arg_x '#.$XNOFINFUNCTION) + (mr arg_y nfn) + (set-nargs 3) + (bla .SPksignalerr) + (li arg_z nil) + (ba .SPpopj)) + +;;; is a winner - saves ~15% +(defppclapfunction gag-one-arg ((arg arg_z)) + (check-nargs 1) + (svref arg_y gf.dispatch-table nfn) ; mention dt first + (set-nargs 2) + (svref nfn gf.dcode nfn) + (ldr temp0 target::misc-data-offset nfn) + (mtctr temp0) + (bctr)) + + +(defppclapfunction gag-two-arg ((arg0 arg_y) (arg1 arg_z)) + (check-nargs 2) + (svref arg_x gf.dispatch-table nfn) ; mention dt first + (set-nargs 3) + (svref nfn gf.dcode nfn) + (ldr temp0 target::misc-data-offset nfn) + (mtctr temp0) + (bctr)) + +(defparameter *cm-proto* + (nfunction + gag + (lambda (&lap &lexpr args) + (ppc-lap-function + gag + () + (mflr loc-pc) + (vpush-argregs) + (vpush nargs) + (add imm0 vsp nargs) + (la imm0 target::node-size imm0) ; caller's vsp + (bla .SPlexpr-entry) + (mtlr loc-pc) ; return to kernel + (mr arg_z vsp) ; lexpr + (svref arg_y combined-method.thing nfn) ; thing + (set-nargs 2) + (svref nfn combined-method.dcode nfn) ; dcode function + (ldr temp0 target::misc-data-offset nfn) + (mtctr temp0) + (bctr))))) Index: /branches/new-random/level-0/PPC/ppc-def.lisp =================================================================== --- /branches/new-random/level-0/PPC/ppc-def.lisp (revision 13309) +++ /branches/new-random/level-0/PPC/ppc-def.lisp (revision 13309) @@ -0,0 +1,1281 @@ +;;; -*- Mode: Lisp; Package: CCL -*- +;;; +;;; Copyright (C) 2009 Clozure Associates +;;; Copyright (C) 1994-2001 Digitool, Inc +;;; This file is part of Clozure CL. +;;; +;;; Clozure CL is licensed under the terms of the Lisp Lesser GNU Public +;;; License , known as the LLGPL and distributed with Clozure CL as the +;;; file "LICENSE". The LLGPL consists of a preamble and the LGPL, +;;; which is distributed with Clozure CL as the file "LGPL". Where these +;;; conflict, the preamble takes precedence. +;;; +;;; Clozure CL is referenced in the preamble as the "LIBRARY." +;;; +;;; The LLGPL is also available online at +;;; http://opensource.franz.com/preamble.html + +(in-package "CCL") + +;;; Do an FF-CALL to MakeDataExecutable so that the data cache gets flushed. +;;; If the GC moves this function while we're trying to flush the cache, +;;; it'll flush the cache: no harm done in that case. +(defppclapfunction %make-code-executable ((codev arg_z)) + (let ((len imm2) + (word-offset imm0)) + (save-lisp-context) + (getvheader word-offset codev) + (header-size len word-offset) + ;; The idea is that if we GC here, no harm is done (since the GC + ;; will do any necessary cache-flushing.) The idea may be + ;; incorrect: if we pass an address that's not mapped anymore, + ;; could we fault ? + (stru sp (- (+ #+eabi-target ppc32::eabi-c-frame.minsize + #+poweropen-target target::c-frame.minsize target::lisp-frame.size)) sp) ; make an FFI frame. + (la imm0 target::misc-data-offset codev) + (slri len len 2) + (str imm0 #+eabi-target ppc32::eabi-c-frame.param0 #+poweropen-target target::c-frame.param0 sp) + (str len #+eabi-target ppc32::eabi-c-frame.param1 #+poweropen-target target::c-frame.param1 sp) + (ref-global imm3 kernel-imports) + (ldr arg_z target::kernel-import-MakeDataExecutable imm3) + (bla #+eabi-target .SPeabi-ff-call #+poweropen-target .SPpoweropen-ffcall) + (li arg_z nil) + (restore-full-lisp-context) + (blr))) + +(defppclapfunction %get-kernel-global-from-offset ((offset arg_z)) + (check-nargs 1) + (unbox-fixnum imm0 offset) + (addi imm0 imm0 (target-nil-value)) + (ldr arg_z 0 imm0) + (blr)) + +(defppclapfunction %set-kernel-global-from-offset ((offset arg_y) (new-value arg_z)) + (check-nargs 2) + (unbox-fixnum imm0 offset) + (addi imm0 imm0 (target-nil-value)) + (str new-value 0 imm0) + (blr)) + + + +(defppclapfunction %get-kernel-global-ptr-from-offset ((offset arg_y) + (ptr arg_z)) + (check-nargs 2) + (unbox-fixnum imm0 offset) + (addi imm0 imm0 (target-nil-value)) + (ldr imm0 0 imm0) + (str imm0 target::macptr.address ptr) + (blr)) + + + + +(defppclapfunction %fixnum-ref ((fixnum arg_y) #| &optional |# (offset arg_z)) + (cmpri cr0 nargs '1) + (check-nargs 1 2) + (bne cr0 @2-args) + (mr fixnum offset) + (li offset 0) + @2-args + (unbox-fixnum imm0 offset) + (ldrx arg_z imm0 fixnum) + (blr)) + + +#+ppc32-target +(defppclapfunction %fixnum-ref-natural ((fixnum arg_y) #| &optional |# (offset arg_z)) + (cmpri cr0 nargs '1) + (check-nargs 1 2) + (bne cr0 @2-args) + (mr fixnum offset) + (li offset 0) + @2-args + (unbox-fixnum imm0 offset) + (lwzx imm0 imm0 fixnum) + (ba .SPmakeu32)) + +#+ppc64-target +(defppclapfunction %fixnum-ref-natural ((fixnum arg_y) #| &optional |# (offset arg_z)) + (cmpdi cr0 nargs '1) + (check-nargs 1 2) + (bne cr0 @2-args) + (mr fixnum offset) + (li offset 0) + @2-args + (unbox-fixnum imm0 offset) + (ldx imm0 imm0 fixnum) + (ba .SPmakeu64)) + +(defppclapfunction %fixnum-set ((fixnum arg_x) (offset arg_y) #| &optional |# (new-value arg_z)) + (cmpi cr0 nargs '2) + (check-nargs 2 3) + (bne cr0 @3-args) + (mr fixnum offset) + (li offset 0) + @3-args + (unbox-fixnum imm0 offset) + (strx new-value imm0 fixnum) + (mr arg_z new-value) + (blr)) + +#+ppc32-target +(defppclapfunction %fixnum-set-natural ((fixnum arg_x) (offset arg_y) #| &optional |# (new-value arg_z)) + (cmpwi cr0 nargs '2) + (check-nargs 2 3) + (bne cr0 @3-args) + (mr fixnum offset) + (li offset 0) + @3-args + (unbox-fixnum imm0 offset) + (extract-typecode imm1 new-value) + (cmpwi cr0 imm1 ppc32::tag-fixnum) + (cmpwi cr1 imm1 ppc32::subtag-bignum) + (srwi imm2 new-value ppc32::fixnumshift) + (beq cr0 @store) + (beq cr1 @bignum) + @notu32 + (uuo_interr arch::error-object-not-unsigned-byte-32 new-value) + @bignum + (getvheader imm0 new-value) + (cmpwi cr1 imm0 ppc32::one-digit-bignum-header) + (cmpwi cr2 imm0 ppc32::two-digit-bignum-header) + (lwz imm2 ppc32::misc-data-offset new-value) + (cmpwi cr0 imm2 0) + (beq cr1 @one) + (bne cr2 @notu32) + (lwz imm1 (+ 4 ppc32::misc-data-offset) new-value) + (cmpwi cr1 imm1 0) + (bgt cr0 @notu32) + (beq cr1 @store) + (b @notu32) + @one + (blt cr0 @notu32) + @store + (stwx imm2 imm0 fixnum) + (mr arg_z new-value) + (blr)) + +#+ppc64-target +(defppclapfunction %fixnum-set-natural ((fixnum arg_x) (offset arg_y) #| &optional |# (new-value arg_z)) + (cmpdi cr0 nargs '2) + (check-nargs 2 3) + (bne cr0 @3-args) + (mr fixnum offset) + (li offset 0) + @3-args + (unbox-fixnum imm0 offset) + (extract-typecode imm1 new-value) + (cmpdi cr0 imm1 ppc64::tag-fixnum) + (cmpdi cr1 imm1 ppc64::subtag-bignum) + (srdi imm2 new-value ppc64::fixnumshift) + (beq cr0 @store) + (beq cr1 @bignum) + @notu64 + (uuo_interr arch::error-object-not-unsigned-byte-64 new-value) + @bignum + (ld imm2 ppc64::misc-data-offset new-value) + (getvheader imm0 new-value) + (cmpdi cr1 imm0 ppc64::two-digit-bignum-header) + (rotldi imm2 imm2 32) + (cmpdi cr2 imm0 ppc64::three-digit-bignum-header) + (cmpdi cr0 imm2 0) + (beq cr1 @two) + (bne cr2 @notu64) + (lwz imm1 (+ 8 ppc64::misc-data-offset) new-value) + (cmpwi cr1 imm1 0) + (bgt cr0 @notu64) + (beq cr1 @store) + (b @notu64) + @two + (blt cr0 @notu64) + @store + (stdx imm2 imm0 fixnum) + (mr arg_z new-value) + (blr)) + + +(defppclapfunction %current-frame-ptr () + (check-nargs 0) + (mr arg_z sp) + (blr)) + +(defppclapfunction %current-vsp () + (check-nargs 0) + (mr arg_z vsp) + (blr)) + + + + +(defppclapfunction %set-current-vsp ((new-vsp arg_z)) + (check-nargs 1) + (mr vsp new-vsp) + (blr)) + +(defppclapfunction %current-tsp () + (check-nargs 0) + (mr arg_z tsp) + (blr)) + + + +(defppclapfunction %set-current-tsp ((new-tsp arg_z)) + (check-nargs 1) + (mr tsp new-tsp) + (blr)) + +(defppclapfunction %%frame-backlink ((p arg_z)) + (check-nargs 1) + (ldr arg_z target::lisp-frame.backlink arg_z) + (blr)) + + + + + +(defppclapfunction %%frame-savefn ((p arg_z)) + (check-nargs 1) + (ldr arg_z target::lisp-frame.savefn arg_z) + (blr)) + +(defppclapfunction %cfp-lfun ((p arg_z)) + (ldr arg_y target::lisp-frame.savefn p) + (extract-typecode imm0 arg_y) + (cmpri imm0 target::subtag-function) + (ldr loc-pc target::lisp-frame.savelr p) + (bne @no) + (ldr arg_x target::misc-data-offset arg_y) + (sub imm1 loc-pc arg_x) + (la imm1 (- target::misc-data-offset) imm1) + (getvheader imm0 arg_x) + (header-length imm0 imm0) + (cmplr imm1 imm0) + (box-fixnum imm1 imm1) + (bge @no) + (vpush arg_y) + (vpush imm1) + @go + (set-nargs 2) + (la temp0 '2 vsp) + (ba .SPvalues) + @no + (li imm0 nil) + (vpush imm0) + (vpush imm0) + (b @go)) + + + + +(defppclapfunction %%frame-savevsp ((p arg_z)) + (check-nargs 1) + (ldr arg_z target::lisp-frame.savevsp arg_z) + (blr)) + + + + + +#+ppc32-target +(eval-when (:compile-toplevel :execute) + (assert (eql ppc32::t-offset #x11))) + +(defppclapfunction %uvector-data-fixnum ((uv arg_z)) + (check-nargs 1) + (trap-unless-fulltag= arg_z target::fulltag-misc) + (la arg_z target::misc-data-offset arg_z) + (blr)) + +(defppclapfunction %catch-top ((tcr arg_z)) + (check-nargs 1) + (ldr arg_z target::tcr.catch-top tcr) + (cmpri cr0 arg_z 0) + (bne @ret) + (li arg_z nil) + @ret + (blr)) + +(defppclapfunction %catch-tsp ((catch arg_z)) + (check-nargs 1) + (la arg_z (- (+ target::fulltag-misc + (ash 1 (1+ target::word-shift)))) arg_z) + (blr)) + + + +;;; Same as %address-of, but doesn't cons any bignums +;;; It also left shift fixnums just like everything else. +(defppclapfunction %fixnum-address-of ((x arg_z)) + (check-nargs 1) + (box-fixnum arg_z x) + (blr)) + + + +(defppclapfunction %save-standard-binding-list ((bindings arg_z)) + (ldr imm0 target::tcr.vs-area target::rcontext) + (ldr imm1 target::area.high imm0) + (push bindings imm1) + (blr)) + +(defppclapfunction %saved-bindings-address () + (ldr imm0 target::tcr.vs-area target::rcontext) + (ldr imm1 target::area.high imm0) + (la arg_z (- target::node-size) imm1) + (blr)) + +(defppclapfunction %code-vector-pc ((code-vector arg_y) (pcptr arg_z)) + (macptr-ptr imm0 pcptr) + (ldr loc-pc 0 imm0) + (sub imm0 loc-pc code-vector) + (subi imm0 imm0 target::misc-data-offset) + (getvheader imm1 code-vector) + (header-size imm1 imm1) + (slri imm1 imm1 2) + (cmplr imm0 imm1) + (li arg_z nil) + (bgelr) + (box-fixnum arg_z imm0) + (blr)) + +;;; FF-call, in LAP. +#+eabi-target +(progn + (defppclapfunction %%ff-call ((fploads 8) + (single-offset 4) + (double-offset 0) + (framesize arg_x) ;always even, negative, includes frame overhead + (buf arg_y) + (entry arg_z)) + (check-nargs 6) + (la imm0 12 vsp) + (save-lisp-context imm0) + (stwux sp sp framesize) + (stw sp 4 sp) + (macptr-ptr imm2 buf) + (mr imm1 imm2) + (la imm3 ppc32::eabi-c-frame.param0 sp) + (li imm0 0) + (lwz temp1 single-offset vsp) + (lwz temp2 double-offset vsp) + @copy + (addi imm0 imm0 8) + (cmpw imm0 temp1) + (lfd fp0 0 imm2) + (la imm2 8 imm2) + (stfd fp0 0 imm3) + (la imm3 8 imm3) + (blt @copy) + ;; We've copied the gpr-save area and the "other" arg words. + ;; Sadly, we may still need to load up to 8 FPRs, and we have + ;; to use some pretty ugly code to do so. + (add temp1 temp1 imm1) + (add temp2 temp2 imm1) + (lwz temp0 fploads vsp) + @load-fp1 + (lbz imm0 (+ ppc32::misc-data-offset 0) temp0) + (cmpwi imm0 1) + (blt @loaded) + (bne @load-fp1-double) + (lfs fp1 0 temp1) + (la temp1 4 temp1) + (b @load-fp2) + @load-fp1-double + (lfd fp1 0 temp2) + (la temp2 8 temp2) + @load-fp2 + (lbz imm0 (+ ppc32::misc-data-offset 1) temp0) + (cmpwi imm0 1) + (blt @loaded) + (bne @load-fp2-double) + (lfs fp2 0 temp1) + (la temp1 4 temp1) + (b @load-fp3) + @load-fp2-double + (lfd fp2 0 temp2) + (la temp2 8 temp2) + @load-fp3 + (lbz imm0 (+ ppc32::misc-data-offset 2) temp0) + (cmpwi imm0 1) + (blt @loaded) + (bne @load-fp3-double) + (lfs fp3 0 temp1) + (la temp1 4 temp1) + (b @load-fp4) + @load-fp3-double + (lfd fp3 0 temp2) + (la temp2 8 temp2) + @load-fp4 + (lbz imm0 (+ ppc32::misc-data-offset 3) temp0) + (cmpwi imm0 1) + (blt @loaded) + (bne @load-fp4-double) + (lfs fp4 0 temp1) + (la temp1 4 temp1) + (b @load-fp5) + @load-fp4-double + (lfd fp4 0 temp2) + (la temp2 8 temp2) + @load-fp5 + (lbz imm0 (+ ppc32::misc-data-offset 4) temp0) + (cmpwi imm0 1) + (blt @loaded) + (bne @load-fp5-double) + (lfs fp5 0 temp1) + (la temp1 4 temp1) + (b @load-fp6) + @load-fp5-double + (lfd fp5 0 temp2) + (la temp2 8 temp2) + @load-fp6 + (lbz imm0 (+ ppc32::misc-data-offset 5) temp0) + (cmpwi imm0 1) + (blt @loaded) + (bne @load-fp6-double) + (lfs fp6 0 temp1) + (la temp1 4 temp1) + (b @load-fp7) + @load-fp6-double + (lfd fp6 0 temp2) + (la temp2 8 temp2) + @load-fp7 + (lbz imm0 (+ ppc32::misc-data-offset 6) temp0) + (cmpwi imm0 1) + (blt @loaded) + (bne @load-fp7-double) + (lfs fp7 0 temp1) + (la temp1 4 temp1) + (b @load-fp8) + @load-fp7-double + (lfd fp7 0 temp2) + (la temp2 8 temp2) + @load-fp8 + (lbz imm0 (+ ppc32::misc-data-offset 0) temp0) + (cmpwi imm0 1) + (blt @loaded) + (bne @load-fp8-double) + (lfs fp8 0 temp1) + (b @loaded) + @load-fp8-double + (lfd fp8 0 temp2) + @loaded + (vpush buf) + (bla .SPeabi-ff-call) + (vpop buf) + (macptr-ptr imm2 buf) + (stw imm0 0 imm2) + (stw imm1 4 imm2) + (stfs fp1 8 imm2) + (stfd fp1 16 imm2) + (restore-full-lisp-context) + (li arg_z (target-nil-value)) + (blr)) + + (defun %ff-call (entry &rest specs-and-vals) + "Call the foreign function at address entrypoint passing the values of +each arg as a foreign argument of type indicated by the corresponding +arg-type-keyword. Returns the foreign function result (coerced to a Lisp +object of type indicated by result-type-keyword), or NIL if +result-type-keyword is :VOID or NIL" + (declare (dynamic-extent specs-and-vals)) + (let* ((len (length specs-and-vals)) + (other-offset 8) + (single-float-offset 8) + (double-float-offset 0) + (nsingle-floats 0) + (ndouble-floats 0) + (nother-words 0) + (nfpr-args 0) + (ngpr-args 0)) + (declare (fixnum len other-offset single-float-offset double-float-offset + nsingle-floats ndouble-floats nother-words nfpr-args ngpr-args)) + (unless (oddp len) + (error "Length of ~s is even. Missing result ?" specs-and-vals)) + + (let* ((result-spec (or (car (last specs-and-vals)) :void)) + (nargs (ash (the fixnum (1- len)) -1)) + (fpr-reloads (make-array 8 :element-type '(unsigned-byte 8)))) + (declare (fixnum nargs) (dynamic-extent fpr-reloads)) + (do* ((i 0 (1+ i)) + (specs specs-and-vals (cddr specs)) + (spec (car specs) (car specs))) + ((= i nargs)) + (declare (fixnum i)) + (ecase spec + (:double-float (incf nfpr-args) + (if (<= nfpr-args 8) + (incf ndouble-floats) + (progn + (if (oddp nother-words) + (incf nother-words)) + (incf nother-words 2)))) + (:single-float (incf nfpr-args) + (if (<= nfpr-args 8) + (incf nsingle-floats) + (incf nother-words))) + ((:signed-doubleword :unsigned-doubleword) + (if (oddp ngpr-args) + (incf ngpr-args)) + (incf ngpr-args 2) + (when (> ngpr-args 8) + (if (oddp nother-words) + (incf nother-words)) + (incf nother-words 2))) + ((:signed-byte :unsigned-byte :signed-halfword :unsigned-halfword + :signed-fullword :unsigned-fullword :address) + (incf ngpr-args) + (if (> ngpr-args 8) + (incf nother-words))))) + (let* ((single-words (+ 8 nother-words nsingle-floats)) + (total-words (if (zerop ndouble-floats) + single-words + (+ (the fixnum (+ ndouble-floats ndouble-floats)) + (the fixnum (logand (lognot 1) + (the fixnum (1+ single-words)))))))) + (declare (fixnum total-words single-words)) + (%stack-block + ((buf (ash total-words 2))) + (setq single-float-offset (+ other-offset nother-words)) + (setq double-float-offset + (logand (lognot 1) + (the fixnum (1+ (the fixnum (+ single-float-offset nsingle-floats)))))) + ;;; Make another pass through the arg/value pairs, evaluating each arg into + ;;; the buffer. + (do* ((i 0 (1+ i)) + (specs specs-and-vals (cddr specs)) + (spec (car specs) (car specs)) + (val (cadr specs) (cadr specs)) + (ngpr 0) + (nfpr 0) + (gpr-byte-offset 0) + (other-byte-offset (ash other-offset 2)) + (single-byte-offset (ash single-float-offset 2)) + (double-byte-offset (ash double-float-offset 2))) + ((= i nargs)) + (declare (fixnum i gpr-byte-offset single-byte-offset double-byte-offset + ngpr nfpr)) + (case spec + (:double-float + (cond ((< nfpr 8) + (setf (uvref fpr-reloads nfpr) 2 + (%get-double-float buf double-byte-offset) val + double-byte-offset (+ double-byte-offset 8))) + (t + (setq other-byte-offset (logand (lognot 7) + (the fixnum (+ other-byte-offset 4)))) + (setf (%get-double-float buf other-byte-offset) val) + (setq other-byte-offset (+ other-byte-offset 8)))) + (incf nfpr)) + (:single-float + (cond ((< nfpr 8) + (setf (uvref fpr-reloads nfpr) 1 + (%get-single-float buf single-byte-offset) val + single-byte-offset (+ single-byte-offset 4))) + + (t + (setf (%get-single-float buf other-byte-offset) val + other-byte-offset (+ other-byte-offset 4)))) + (incf nfpr)) + (:address + (cond ((< ngpr 8) + (setf (%get-ptr buf gpr-byte-offset) val + gpr-byte-offset (+ gpr-byte-offset 4))) + (t + (setf (%get-ptr buf other-byte-offset) val + other-byte-offset (+ other-byte-offset 4)))) + (incf ngpr)) + ((:signed-doubleword :unsigned-doubleword) + (when (oddp ngpr) + (incf ngpr) + (incf gpr-byte-offset 4)) + (cond ((< ngpr 8) + (if (eq spec :signed-doubleword) + (setf (%get-signed-long-long buf gpr-byte-offset) val) + (setf (%get-unsigned-long-long buf gpr-byte-offset) val)) + (incf gpr-byte-offset 8)) + (t + (when (logtest other-byte-offset 7) + (incf other-byte-offset 4)) + (if (eq spec :signed-doubleword) + (setf (%get-signed-long-long buf other-byte-offset) val) + (setf (%get-unsigned-long-long buf other-byte-offset) val)) + (incf other-byte-offset 8))) + (incf ngpr 2)) + ((:unsigned-byte :unsigned-halfword :unsigned-fullword) + (cond ((< ngpr 8) + (setf (%get-unsigned-long buf gpr-byte-offset) val + gpr-byte-offset (+ gpr-byte-offset 4))) + (t + (setf (%get-unsigned-long buf other-byte-offset) val + other-byte-offset (+ other-byte-offset 4)))) + (incf ngpr)) + (t + (cond ((< ngpr 8) + (setf (%get-long buf gpr-byte-offset) val + gpr-byte-offset (+ gpr-byte-offset 4))) + (t + (setf (%get-long buf other-byte-offset) val + other-byte-offset (+ other-byte-offset 4)))) + (incf ngpr)))) + (%%ff-call fpr-reloads + single-float-offset + double-float-offset + (the fixnum (- + (ash (the fixnum + (+ 6 + (the fixnum (logand + (lognot 1) + (the fixnum (1+ total-words)))))) + 2))) + buf + entry) + (ecase result-spec + (:void nil) + (:single-float (%get-single-float buf 8)) + (:double-float (%get-double-float buf 16)) + (:address (%get-ptr buf)) + (:signed-doubleword (%get-signed-long-long buf 0)) + (:unsigned-doubleword (%get-unsigned-long-long buf 0)) + (:signed-fullword (%get-signed-long buf)) + (:unsigned-fullword (%get-unsigned-long buf)) + (:signed-halfword (%get-signed-word buf 2)) + (:unsigned-halfword (%get-unsigned-word buf 2)) + (:signed-byte (%get-signed-byte buf 3)) + (:unsigned-byte (%get-unsigned-byte buf 3)))))))) + ) + + + + + +;;; In the PowerOpen ABI, all arguments are passed in a contiguous +;;; block. The first 13 (!) FP args are passed in FP regs; doubleword +;;; arguments are aligned on word boundaries. +#+poweropen-target +(progn + #+ppc32-target + (progn + (defun %ff-call (entry &rest specs-and-vals) + (declare (dynamic-extent specs-and-vals)) + (let* ((len (length specs-and-vals)) + (total-words 0)) + (declare (fixnum len total-words)) + (unless (oddp len) + (error "Length of ~s is even. Missing result ?" specs-and-vals)) + (let* ((result-spec (or (car (last specs-and-vals)) :void)) + (nargs (ash (the fixnum (1- len)) -1)) + (fpr-reload-sizes (make-array 13 :element-type '(unsigned-byte 8))) + (fpr-reload-offsets (make-array 13 :element-type '(unsigned-byte 16)))) + (declare (fixnum nargs) (dynamic-extent fpr-reload-sizes fpr-reload-offsets)) + (do* ((i 0 (1+ i)) + (specs specs-and-vals (cddr specs)) + (spec (car specs) (car specs))) + ((= i nargs)) + (declare (fixnum i)) + (case spec + ((:double-float :signed-doubleword :unsigned-doubleword) + (incf total-words 2)) + ((:single-float :signed-byte :unsigned-byte :signed-halfword + :unsigned-halfword :signed-fullword + :unsigned-fullword :address) + (incf total-words)) + (t (if (typep spec 'unsigned-byte) + (incf total-words spec) + (error "Invalid argument spec ~s" spec))))) + (%stack-block ((buf (ash (logand (lognot 1) (1+ (max 6 total-words))) 2))) + (do* ((i 0 (1+ i)) + (fpr 0) + (offset 0 (+ offset 4)) + (specs specs-and-vals (cddr specs)) + (spec (car specs) (car specs)) + (val (cadr specs) (cadr specs))) + ((= i nargs)) + (declare (fixnum i offset fpr)) + (case spec + (:double-float + (when (< fpr 13) + (setf (uvref fpr-reload-sizes fpr) 2 + (uvref fpr-reload-offsets fpr) offset)) + (incf fpr) + (setf (%get-double-float buf offset) val) + (incf offset 4)) + (:single-float + (when (< fpr 13) + (setf (uvref fpr-reload-sizes fpr) 1 + (uvref fpr-reload-offsets fpr) offset)) + (incf fpr) + (setf (%get-single-float buf offset) val)) + (:signed-doubleword + (setf (%get-signed-long-long buf offset) val) + (incf offset 4)) + (:unsigned-doubleword + (setf (%get-unsigned-long-long buf offset) val) + (incf offset 4)) + (:address + (setf (%get-ptr buf offset) val)) + ((:unsigned-byte :unsigned-halfword :unsigned-fullword) + (setf (%get-unsigned-long buf offset) val)) + (t + (if (typep spec 'unsigned-byte) + (dotimes (i spec (decf offset 4)) + (setf (%get-ptr buf offset) + (%get-ptr val (* i 4))) + (incf offset 4)) + (setf (%get-long buf offset) val))))) + (let* ((frame-size (if (<= total-words 8) + (ash + (+ ppc32::c-frame.size ppc32::lisp-frame.size) + -2) + (+ + (ash + (+ ppc32::c-frame.size ppc32::lisp-frame.size) + -2) + (logand (lognot 1) + (1+ (- total-words 8))))))) + + (%%ff-call + fpr-reload-sizes + fpr-reload-offsets + (- (logandc2 (+ frame-size 3) 3)) + total-words + buf + entry)) + (ecase result-spec + (:void nil) + (:single-float (%get-single-float buf 8)) + (:double-float (%get-double-float buf 16)) + (:address (%get-ptr buf)) + (:signed-doubleword (%get-signed-long-long buf 0)) + (:unsigned-doubleword (%get-unsigned-long-long buf 0)) + (:signed-fullword (%get-signed-long buf)) + (:unsigned-fullword (%get-unsigned-long buf)) + (:signed-halfword (%get-signed-word buf 2)) + (:unsigned-halfword (%get-unsigned-word buf 2)) + (:signed-byte (%get-signed-byte buf 3)) + (:unsigned-byte (%get-unsigned-byte buf 3))))))) + + + (defppclapfunction %%ff-call ((reload-sizes 8) + (reload-offsets 4) + (frame-size 0) + (total-words arg_x) + (buf arg_y) + (entry arg_z)) + (check-nargs 6) + (la imm0 12 vsp) + (save-lisp-context imm0) + (lwz imm0 frame-size vsp) + (stwux sp sp imm0) + (stw sp ppc32::c-frame.savelr sp) + (macptr-ptr imm2 buf) + (mr imm1 imm2) + (la imm3 ppc32::c-frame.param0 sp) + (li temp1 0) + @copy + (addi temp1 temp1 '1) + (cmpw temp1 total-words) + (lwz imm0 0 imm2) + (la imm2 4 imm2) + (stw imm0 0 imm3) + (la imm3 4 imm3) + (blt @copy) + (lwz temp0 reload-sizes vsp) + (lwz temp1 reload-offsets vsp) + @load-fp1 + (lbz imm0 (+ ppc32::misc-data-offset 0) temp0) + (cmpwi imm0 1) + (lhz imm2 (+ ppc32::misc-data-offset 0) temp1) + (blt @loaded) + (bne @load-fp1-double) + (lfsx fp1 imm1 imm2) + (b @load-fp2) + @load-fp1-double + (lfdx fp1 imm1 imm2) + + @load-fp2 + (lbz imm0 (+ ppc32::misc-data-offset 1) temp0) + (cmpwi imm0 1) + (lhz imm2 (+ ppc32::misc-data-offset 2) temp1) + (blt @loaded) + (bne @load-fp2-double) + (lfsx fp2 imm1 imm2) + (b @load-fp3) + @load-fp2-double + (lfdx fp2 imm1 imm2) + + @load-fp3 + (lbz imm0 (+ ppc32::misc-data-offset 2) temp0) + (cmpwi imm0 1) + (lhz imm2 (+ ppc32::misc-data-offset 4) temp1) + (blt @loaded) + (bne @load-fp3-double) + (lfsx fp3 imm1 imm2) + (b @load-fp4) + @load-fp3-double + (lfdx fp3 imm1 imm2) + + @load-fp4 + (lbz imm0 (+ ppc32::misc-data-offset 3) temp0) + (cmpwi imm0 1) + (lhz imm2 (+ ppc32::misc-data-offset 6) temp1) + (blt @loaded) + (bne @load-fp4-double) + (lfsx fp4 imm1 imm2) + (b @load-fp5) + @load-fp4-double + (lfdx fp4 imm1 imm2) + + @load-fp5 + (lbz imm0 (+ ppc32::misc-data-offset 4) temp0) + (cmpwi imm0 1) + (lhz imm2 (+ ppc32::misc-data-offset 8) temp1) + (blt @loaded) + (bne @load-fp5-double) + (lfsx fp5 imm1 imm2) + (b @load-fp6) + @load-fp5-double + (lfdx fp5 imm1 imm2) + + @load-fp6 + (lbz imm0 (+ ppc32::misc-data-offset 5) temp0) + (cmpwi imm0 1) + (lhz imm2 (+ ppc32::misc-data-offset 10) temp1) + (blt @loaded) + (bne @load-fp1-double) + (lfsx fp6 imm1 imm2) + (b @load-fp7) + @load-fp6-double + (lfdx fp6 imm1 imm2) + + @load-fp7 + (lbz imm0 (+ ppc32::misc-data-offset 6) temp0) + (cmpwi imm0 1) + (lhz imm2 (+ ppc32::misc-data-offset 12) temp1) + (blt @loaded) + (bne @load-fp1-double) + (lfsx fp7 imm1 imm2) + (b @load-fp8) + @load-fp7-double + (lfdx fp7 imm1 imm2) + + @load-fp8 + (lbz imm0 (+ ppc32::misc-data-offset 7) temp0) + (cmpwi imm0 1) + (lhz imm2 (+ ppc32::misc-data-offset 14) temp1) + (blt @loaded) + (bne @load-fp8-double) + (lfsx fp8 imm1 imm2) + (b @load-fp9) + @load-fp8-double + (lfdx fp8 imm1 imm2) + + @load-fp9 + (lbz imm0 (+ ppc32::misc-data-offset 8) temp0) + (cmpwi imm0 1) + (lhz imm2 (+ ppc32::misc-data-offset 16) temp1) + (blt @loaded) + (bne @load-fp9-double) + (lfsx fp9 imm1 imm2) + (b @load-fp10) + @load-fp9-double + (lfdx fp9 imm1 imm2) + + @load-fp10 + (lbz imm0 (+ ppc32::misc-data-offset 9) temp0) + (cmpwi imm0 1) + (lhz imm2 (+ ppc32::misc-data-offset 18) temp1) + (blt @loaded) + (bne @load-fp10-double) + (lfsx fp10 imm1 imm2) + (b @load-fp11) + @load-fp10-double + (lfdx fp10 imm1 imm2) + + @load-fp11 + (lbz imm0 (+ ppc32::misc-data-offset 10) temp0) + (cmpwi imm0 1) + (lhz imm2 (+ ppc32::misc-data-offset 20) temp1) + (blt @loaded) + (bne @load-fp11-double) + (lfsx fp11 imm1 imm2) + (b @load-fp12) + @load-fp11-double + (lfdx fp11 imm1 imm2) + + @load-fp12 + (lbz imm0 (+ ppc32::misc-data-offset 11) temp0) + (cmpwi imm0 1) + (lhz imm2 (+ ppc32::misc-data-offset 22) temp1) + (blt @loaded) + (bne @load-fp12-double) + (lfsx fp12 imm1 imm2) + (b @load-fp13) + @load-fp12-double + (lfdx fp12 imm1 imm2) + + @load-fp13 + (lbz imm0 (+ ppc32::misc-data-offset 12) temp0) + (cmpwi imm0 1) + (lhz imm2 (+ ppc32::misc-data-offset 24) temp1) + (blt @loaded) + (bne @load-fp13-double) + (lfsx fp13 imm1 imm2) + (b @loaded) + @load-fp13-double + (lfdx fp13 imm1 imm2) + @loaded + (vpush buf) + (bla .SPpoweropen-ffcall) + @called + (vpop buf) + (macptr-ptr imm2 buf) + (stw imm0 0 imm2) + (stw imm1 4 imm2) + (stfs fp1 8 imm2) + (stfd fp1 16 imm2) + (restore-full-lisp-context) + (li arg_z (target-nil-value)) + (blr)) + ) + + #+ppc64-target + (progn + ;;; There are a few funky, non-obvious things going on here. + ;;; The main %FF-CALL function uses WITH-VARIABLE-C-FRAME; + ;;; the compiler will generate code to pop that frame off + ;;; of the C/control stack, but the subprim that implements + ;;; %ff-call has already popped it off. To put things back + ;;; in balance, the LAP function %%FF-RESULT pushes an + ;;; extra frame on the cstack. + ;;; %FF-CALL calls %%FF-RESULT to box the result, which may + ;;; be in r3/imm0 or in fp1. It's critical that the call + ;;; to %%FF-RESULT not be compiled as "multiple-value returning", + ;;; since the MV machinery may clobber IMM0. + (defppclapfunction %%ff-result ((spec arg_z)) + (stdu sp -160 sp) + (ld arg_y ':void nfn) + (cmpd cr0 spec arg_y) + (ld arg_x ':address nfn) + (cmpd cr1 spec arg_x) + (ld temp3 ':single-float nfn) + (cmpd cr2 spec temp3) + (ld arg_y ':double-float nfn) + (cmpd cr3 spec arg_y) + (ld arg_x ':unsigned-doubleword nfn) + (cmpd cr4 spec arg_x) + (ld temp3 ':signed-doubleword nfn) + (cmpd cr5 spec temp3) + (beq cr0 @void) + (beq cr1 @address) + (beq cr2 @single-float) + (beq cr3 @double-float) + (beq cr4 @unsigned-doubleword) + (beq cr5 @signed-doubleword) + (box-fixnum arg_z imm0) + (blr) + @void + (li arg_z nil) + (blr) + @address + (li imm1 ppc64::macptr-header) + (subi allocptr allocptr (- ppc64::macptr.size ppc64::fulltag-misc)) + (tdlt allocptr allocbase) + (std imm1 ppc64::misc-header-offset allocptr) + (mr arg_z allocptr) + (clrrdi allocptr allocptr 4) + (std imm0 ppc64::macptr.address arg_z) + (blr) + @single-float + (put-single-float fp1 arg_z) + (blr) + @double-float + (li imm1 ppc64::double-float-header) + (subi allocptr allocptr (- ppc64::double-float.size ppc64::fulltag-misc)) + (tdlt allocptr allocbase) + (std imm1 ppc64::misc-header-offset allocptr) + (mr arg_z allocptr) + (clrrdi allocptr allocptr 4) + (stfd fp1 ppc64::macptr.address arg_z) + (blr) + @unsigned-doubleword + (ba .SPmakeu64) + @signed-doubleword + (ba .SPmakes64)) + + ;;; This is just here so that we can jump to a subprim from lisp. + (defppclapfunction %do-ff-call ((regbuf arg_y) (entry arg_z)) + (cmpdi cr0 regbuf nil) + (bnea cr0 .SPpoweropen-ffcall-return-registers) + (ba .SPpoweropen-ffcall)) + + (defun %ff-call (entry &rest specs-and-vals) + (declare (dynamic-extent specs-and-vals)) + (let* ((len (length specs-and-vals)) + (total-words 0) + (registers nil)) + (declare (fixnum len total-words)) + (let* ((result-spec (or (car (last specs-and-vals)) :void)) + (nargs (ash (the fixnum (1- len)) -1))) + (declare (fixnum nargs)) + (ecase result-spec + ((:address :unsigned-doubleword :signed-doubleword + :single-float :double-float + :signed-fullword :unsigned-fullword + :signed-halfword :unsigned-halfword + :signed-byte :unsigned-byte + :void) + (do* ((i 0 (1+ i)) + (specs specs-and-vals (cddr specs)) + (spec (car specs) (car specs))) + ((= i nargs)) + (declare (fixnum i)) + (case spec + (:registers nil) + ((:address :unsigned-doubleword :signed-doubleword + :single-float :double-float + :signed-fullword :unsigned-fullword + :signed-halfword :unsigned-halfword + :signed-byte :unsigned-byte + :hybrid-int-float :hybrid-float-float + :hybrid-float-int) + (incf total-words)) + (t (if (typep spec 'unsigned-byte) + (incf total-words spec) + (error "unknown arg spec ~s" spec))))) + (%stack-block ((fp-args (* 13 8))) + (with-variable-c-frame + total-words frame + (with-macptrs ((argptr)) + (%setf-macptr-to-object argptr frame) + (let* ((offset ppc64::c-frame.param0) + (n-fp-args 0)) + (declare (fixnum offset n-fp-args)) + (do* ((i 0 (1+ i)) + (specs specs-and-vals (cddr specs)) + (spec (car specs) (car specs)) + (val (cadr specs) (cadr specs))) + ((= i nargs)) + (declare (fixnum i)) + (case spec + (:registers (setq registers val)) + (:address (setf (%get-ptr argptr offset) val) + (incf offset 8)) + ((:signed-doubleword :signed-fullword :signed-halfword + :signed-byte) + + (setf (%%get-signed-longlong argptr offset) val) + (incf offset 8)) + ((:unsigned-doubleword :unsigned-fullword :unsigned-halfword + :unsigned-byte) + (setf (%%get-unsigned-longlong argptr offset) val) + (incf offset 8)) + (:hybrid-int-float + (setf (%%get-unsigned-longlong argptr offset) val) + (when (< n-fp-args 13) + (setf (%get-double-float fp-args (* n-fp-args 8)) + (%double-float (%get-single-float argptr (+ offset 4))))) + (incf n-fp-args) + (incf offset 8)) + (:hybrid-float-int + (setf (%%get-unsigned-longlong argptr offset) val) + (when (< n-fp-args 13) + (setf (%get-double-float fp-args (* n-fp-args 8)) + (%double-float (%get-single-float argptr offset)))) + (incf n-fp-args) + (incf offset 8)) + (:hybrid-float-float + (setf (%%get-unsigned-longlong argptr offset) val) + (when (< n-fp-args 13) + (setf (%get-double-float fp-args (* n-fp-args 8)) + (%double-float (%get-single-float argptr offset)))) + (incf n-fp-args) + (when (< n-fp-args 13) + (setf (%get-double-float fp-args (* n-fp-args 8)) + (%double-float (%get-single-float argptr (+ offset 4))))) + (incf n-fp-args) + (incf offset 8)) + (:double-float + (setf (%get-double-float argptr offset) val) + (when (< n-fp-args 13) + (setf (%get-double-float fp-args (* n-fp-args 8)) val)) + (incf n-fp-args) + (incf offset 8)) + (:single-float + (setf (%get-single-float argptr offset) val) + (when (< n-fp-args 13) + (setf (%get-double-float fp-args (* n-fp-args 8)) + (%double-float val))) + (incf n-fp-args) + (incf offset 8)) + (t + (let* ((p 0)) + (declare (fixnum p)) + (dotimes (i (the fixnum spec)) + (setf (%get-ptr argptr offset) (%get-ptr val p)) + (incf p 8) + (incf offset 8)))))) + (%load-fp-arg-regs n-fp-args fp-args) + (%do-ff-call registers entry) + (values (%%ff-result result-spec))))))))))) + + ) + ) + + + +(defppclapfunction %get-object ((macptr arg_y) (offset arg_z)) + (check-nargs 2) + (trap-unless-typecode= arg_y target::subtag-macptr) + (macptr-ptr imm0 arg_y) + (trap-unless-lisptag= arg_z target::tag-fixnum imm1) + (unbox-fixnum imm1 arg_z) + (ldrx arg_z imm0 imm1) + (blr)) + + +(defppclapfunction %set-object ((macptr arg_x) (offset arg_y) (value arg_z)) + (check-nargs 3) + (trap-unless-typecode= arg_x target::subtag-macptr) + (macptr-ptr imm0 arg_x) + (trap-unless-lisptag= arg_y target::tag-fixnum imm1) + (unbox-fixnum imm1 arg_y) + (strx arg_z imm0 imm1) + (blr)) + + +(defppclapfunction %apply-lexpr-with-method-context ((magic arg_x) + (function arg_y) + (args arg_z)) + ;; Somebody's called (or tail-called) us. + ;; Put magic arg in ppc::next-method-context (= ppc::temp1). + ;; Put function in ppc::nfn (= ppc::temp2). + ;; Set nargs to 0, then spread "args" on stack (clobbers arg_x, arg_y, arg_z, + ;; but preserves ppc::nfn/ppc::next-method-context. + ;; Jump to the function in ppc::nfn. + (mr ppc::next-method-context magic) + (mr ppc::nfn function) + (set-nargs 0) + (mflr loc-pc) + (bla .SPspread-lexpr-z) + (mtlr loc-pc) + (ldr temp0 target::misc-data-offset nfn) + (mtctr temp0) + (bctr)) + + +(defppclapfunction %apply-with-method-context ((magic arg_x) + (function arg_y) + (args arg_z)) + ;; Somebody's called (or tail-called) us. + ;; Put magic arg in ppc::next-method-context (= ppc::temp1). + ;; Put function in ppc::nfn (= ppc::temp2). + ;; Set nargs to 0, then spread "args" on stack (clobbers arg_x, arg_y, arg_z, + ;; but preserves ppc::nfn/ppc::next-method-context. + ;; Jump to the function in ppc::nfn. + (mr ppc::next-method-context magic) + (mr ppc::nfn function) + (set-nargs 0) + (mflr loc-pc) + (bla .SPspreadargZ) + (mtlr loc-pc) + (ldr temp0 target::misc-data-offset nfn) + (mtctr temp0) + (bctr)) + + + + +(defppclapfunction %apply-lexpr-tail-wise ((method arg_y) (args arg_z)) + ;; This assumes + ;; a) that "args" is a lexpr made via the .SPlexpr-entry mechanism + ;; b) That the LR on entry to this function points to the lexpr-cleanup + ;; code that .SPlexpr-entry set up + ;; c) That there weren't any required args to the lexpr, e.g. that + ;; (%lexpr-ref args (%lexpr-count args) 0) was the first arg to the gf. + ;; The lexpr-cleanup code will be EQ to either (lisp-global ret1valaddr) + ;; or (lisp-global lexpr-return1v). In the former case, discard a frame + ;; from the cstack (multiple-value tossing). Restore FN and LR from + ;; the first frame that .SPlexpr-entry pushed, restore vsp from (+ + ;; args node-size), pop the argregs, and jump to the function. + (mflr loc-pc) + (ref-global imm0 ret1valaddr) + (cmpr cr2 loc-pc imm0) + (ldr nargs 0 args) + (mr imm5 nargs) + (cmpri cr0 nargs 0) + (cmpri cr1 nargs '2) + (mr nfn method) + (ldr temp0 target::misc-data-offset nfn) + (mtctr temp0) + (if (:cr2 :eq) + (la sp target::lisp-frame.size sp)) + (ldr loc-pc target::lisp-frame.savelr sp) + (ldr fn target::lisp-frame.savefn sp) + (ldr imm0 target::lisp-frame.savevsp sp) + (sub vsp imm0 nargs) + (mtlr loc-pc) + (la sp target::lisp-frame.size sp) + (beqctr) + (vpop arg_z) + (bltctr cr1) + (vpop arg_y) + (beqctr cr1) + (vpop arg_x) + (bctr)) + + +(defun %copy-function (proto &optional target) + (let* ((total-size (uvsize proto)) + (new (or target (allocate-typed-vector :function total-size)))) + (declare (fixnum total-size)) + (when target + (unless (eql total-size (uvsize target)) + (error "Wrong size target ~s" target))) + (%copy-gvector-to-gvector proto 0 new 0 total-size) + new)) + +(defun replace-function-code (target-fn proto-fn) + (if (typep target-fn 'function) + (if (typep proto-fn 'function) + (setf (uvref target-fn 0) + (uvref proto-fn 0)) + (report-bad-arg proto-fn 'function)) + (report-bad-arg target-fn 'function))) + +(defun closure-function (fun) + (while (and (functionp fun) (not (compiled-function-p fun))) + (setq fun (%svref fun 1)) + (when (vectorp fun) + (setq fun (svref fun 0)))) + fun) + + +;;; For use by (setf (apply ...) ...) +;;; (apply+ f butlast last) = (apply f (append butlast (list last))) +#+ppc-target +(defun apply+ (&lap function arg1 arg2 &rest other-args) + (ppc-lap-function apply+ () + (check-nargs 3 nil) + (vpush arg_x) + (mr temp0 arg_z) ; last + (mr arg_z arg_y) ; butlast + (subi nargs nargs '2) ; remove count for butlast & last + (mflr loc-pc) + (bla .SPspreadargz) + (cmpri cr0 nargs '3) + (mtlr loc-pc) + (addi nargs nargs '1) ; count for last + (blt cr0 @nopush) + (vpush arg_x) +@nopush + (mr arg_x arg_y) + (mr arg_y arg_z) + (mr arg_z temp0) + (ldr temp0 'funcall nfn) + (ba .SPfuncall))) + +(lfun-bits #'apply+ (logior $lfbits-rest-bit + (dpb 3 $lfbits-numreq 0))) + +;;; end of ppc-def.lisp Index: /branches/new-random/level-0/PPC/ppc-float.lisp =================================================================== --- /branches/new-random/level-0/PPC/ppc-float.lisp (revision 13309) +++ /branches/new-random/level-0/PPC/ppc-float.lisp (revision 13309) @@ -0,0 +1,731 @@ +;;;-*- Mode: Lisp; Package: CCL -*- +;;; +;;; Copyright (C) 2009 Clozure Associates +;;; Copyright (C) 1994-2001 Digitool, Inc +;;; This file is part of Clozure CL. +;;; +;;; Clozure CL is licensed under the terms of the Lisp Lesser GNU Public +;;; License , known as the LLGPL and distributed with Clozure CL as the +;;; file "LICENSE". The LLGPL consists of a preamble and the LGPL, +;;; which is distributed with Clozure CL as the file "LGPL". Where these +;;; conflict, the preamble takes precedence. +;;; +;;; Clozure CL is referenced in the preamble as the "LIBRARY." +;;; +;;; The LLGPL is also available online at +;;; http://opensource.franz.com/preamble.html + +(in-package "CCL") + +(eval-when (:compile-toplevel :execute) + (require "NUMBER-MACROS") + (require :number-case-macro)) + + +;;; make a float from hi - high 24 bits mantissa (ignore implied higher bit) +;;; lo - low 28 bits mantissa +;;; exp - take low 11 bits +;;; sign - sign(sign) => result +;;; hi result - 1 bit sign: 11 bits exp: 20 hi bits of hi arg +;;; lo result - 4 lo bits of hi arg: 28 lo bits of lo arg +;;; no error checks, no tweaks, no nuthin + +#+ppc32-target +(defppclapfunction %make-float-from-fixnums ((float 4)(hi 0) (lo arg_x) (exp arg_y) (sign arg_z)) + (rlwinm imm0 sign 0 0 0) ; just leave sign bit + (rlwimi imm0 exp (- 20 ppc32::fixnumshift) 1 11) ; exp left 20 right 2 keep 11 bits + (lwz imm1 hi vsp) + (srawi imm1 imm1 ppc32::fixnumshift) ; fold into below? nah keep for later + (rlwimi imm0 imm1 (- 32 4) 12 31) ; right 4 - keep 20 - stuff into hi result + (rlwinm imm1 imm1 28 0 3) ; hi goes left 28 - keep 4 hi bits + (rlwimi imm1 lo (- 32 ppc32::fixnumshift) 4 31) ; stuff in 28 bits of lo + (lwz temp0 float vsp) ; the float + (stw imm0 ppc32::double-float.value temp0) + (stw imm1 ppc32::double-float.val-low temp0) + (la vsp 8 vsp) + (blr)) + +#+ppc64-target +(defppclapfunction %make-float-from-fixnums ((float 8)(hi 0) (lo arg_x) (exp arg_y) (sign arg_z)) + (rlwinm imm0 sign 0 0 0) ; just leave sign bit + (rlwimi imm0 exp (- 20 ppc64::fixnumshift) 1 11) ; exp left 20 right 2 keep 11 bits + (ld imm1 hi vsp) + (srawi imm1 imm1 ppc64::fixnumshift) ; fold into below? nah keep for later + (rlwimi imm0 imm1 (- 32 4) 12 31) ; right 4 - keep 20 - stuff into hi result + (rlwinm imm1 imm1 28 0 3) ; hi goes left 28 - keep 4 hi bits + (rlwimi imm1 lo (- 32 ppc64::fixnumshift) 4 31) ; stuff in 28 bits of lo + (ld temp0 float vsp) ; the float + (stw imm0 ppc64::double-float.value temp0) + (stw imm1 ppc64::double-float.val-low temp0) + (la vsp '2 vsp) + (blr)) + +#+ppc32-target +(defppclapfunction %make-short-float-from-fixnums ((float 0) (sig arg_x) (exp arg_y) (sign arg_z)) + (unbox-fixnum imm0 sig) + (rlwimi imm0 exp (- 29 8) 1 8) + (inslwi imm0 sign 1 0) + (vpop arg_z) + (stw imm0 ppc32::single-float.value arg_z) + (blr)) + + +(defppclapfunction %%double-float-abs! ((n arg_y)(val arg_z)) + (get-double-float fp1 n) + (fabs fp1 fp1) + (put-double-float fp1 val) + (blr)) + +#+ppc32-target +(defppclapfunction %%short-float-abs! ((n arg_y) (val arg_z)) + (get-single-float fp1 n) + (fabs fp0 fp1) + (put-single-float fp0 val) + (blr)) + +#+ppc64-target +(defppclapfunction %short-float-abs ((n arg_z)) + (get-single-float fp1 n) + (fabs fp0 fp1) + (put-single-float fp0 arg_z) + (blr)) + +(defppclapfunction %double-float-negate! ((src arg_y) (res arg_z)) + (get-double-float fp0 src) + (fneg fp1 fp0) + (put-double-float fp1 res) + (blr)) + +#+ppc32-target +(defppclapfunction %short-float-negate! ((src arg_y) (res arg_z)) + (get-single-float fp0 src) + (fneg fp1 fp0) + (put-single-float fp1 res) + (blr)) + +#+ppc64-target +;;; Non-destructive. +(defppclapfunction %short-float-negate ((src arg_z)) + (get-single-float fp0 src) + (fneg fp1 fp0) + (put-single-float fp1 arg_z) + (blr)) + + +;;; rets hi (25 bits) lo (28 bits) exp sign +#+ppc32-target +(defppclapfunction %integer-decode-double-float ((n arg_z)) + (lwz imm0 ppc32::double-float.value n) + (rlwinm imm1 imm0 (+ 1 ppc32::fixnumshift) (- 32 ppc32::fixnumshift 1) ; sign boxed + (- 32 ppc32::fixnumshift 1)) + (add imm1 imm1 imm1) ; imm1 = (fixnum 2) (neg) or 0 (pos) + (subfic temp0 imm1 '1) ; sign boxed + (rlwinm. imm2 imm0 (- 32 20) 21 31) ; right 20, keep 11 bits exp - test for 0 + ;(subi imm2 imm2 (+ 53 1022)) ; unbias and scale + (slwi imm2 imm2 ppc32::fixnumshift) ; box + (mr temp1 imm2) ; boxed unbiased exponent + (rlwinm imm0 imm0 12 0 19) ; 20 bits of hi float left 12 + (beq @denorm) ; cr set way back + (addi imm0 imm0 1) ; add implied 1 + @denorm + (rlwinm imm0 imm0 (+ (- 32 12) 4 ppc32::fixnumshift) 0 31) + (lwz imm1 ppc32::double-float.val-low n) ; + (rlwimi imm0 imm1 (+ 4 ppc32::fixnumshift) + (1+ (- 31 4 ppc32::fixnumshift)) + (- 31 ppc32::fixnumshift)) ; high 4 bits in fixnum pos + (rlwinm imm1 imm1 (- 4 ppc32::fixnumshift) + (- 4 ppc32::fixnumshift) + (- 31 ppc32::fixnum-shift)) ; 28 bits thats 2 2 29 + (vpush imm0) ; hi 25 bits of mantissa (includes implied 1) + (vpush imm1) ; lo 28 bits of mantissa + (vpush temp1) ; exp + (vpush temp0) ; sign + (set-nargs 4) + (la temp0 '4 vsp) + (ba .SPvalues)) + + +;;; hi is 25 bits lo is 28 bits +;;; big is 32 lo, 21 hi right justified +#+ppc32-target +(defppclapfunction make-big-53 ((hi arg_x)(lo arg_y)(big arg_z)) + (rlwinm imm0 lo (- 32 ppc32::fixnumshift) 4 31) + (rlwimi imm0 hi (- 32 4 ppc32::fixnumshift) 0 3) + (stw imm0 (+ ppc32::misc-data-offset 0) big) ; low goes in 1st wd + (rlwinm imm0 hi (- 32 (+ ppc32::fixnumshift 4)) 11 31) ; high in second + (stw imm0 (+ ppc32::misc-data-offset 4) big) + (blr)) + + + +(defppclapfunction dfloat-significand-zeros ((dfloat arg_z)) + (lwz imm1 target::double-float.value dfloat) + (rlwinm. imm1 imm1 12 0 19) + (cntlzw imm1 imm1) + (beq @golo) + (box-fixnum arg_z imm1) + (blr) + @golo + (lwz imm1 target::double-float.val-low dfloat) + (cntlzw imm1 imm1) + (addi imm1 imm1 20) + (box-fixnum arg_z imm1) + (blr)) + +(defppclapfunction sfloat-significand-zeros ((sfloat arg_z)) + #+ppc32-target (lwz imm1 ppc32::single-float.value sfloat) + #+ppc64-target (srdi imm1 sfloat 32) + (rlwinm imm1 imm1 9 0 22) + (cntlzw imm1 imm1) + (box-fixnum arg_z imm1) + (blr)) + + + +#+ppc32-target +(defppclapfunction %%scale-dfloat! ((float arg_x)(int arg_y)(result arg_z)) + (let ((fl.h 8) + (fl.l 12) + (sc.h 16) + (sc.l 20)) + (clear-fpu-exceptions) + (lwz imm0 ppc32::double-float.value float) + (lwz imm1 ppc32::double-float.val-low float) + (stwu tsp -24 tsp) + (stw tsp 4 tsp) + (stw imm0 fl.h tsp) + (stw imm1 fl.l tsp) + (unbox-fixnum imm0 int) + ;(addi imm0 imm0 1022) ; bias exponent - we assume no ovf + (slwi imm0 imm0 20) ; more important - get it in right place + (stw imm0 sc.h tsp) + (stw rzero sc.l tsp) + (lfd fp0 fl.h tsp) + (lfd fp1 sc.h tsp) + (lwz tsp 0 tsp) + (fmul fp2 fp0 fp1) + (stfd fp2 ppc32::double-float.value result) + (blr))) + +#+ppc64-target +(defppclapfunction %%scale-dfloat! ((float arg_x)(int arg_y)(result arg_z)) + (let ((fl.h 16) + (fl.l 20) + (sc.h 24) + (sc.l 28)) + (clear-fpu-exceptions) + (lwz imm0 ppc64::double-float.value float) + (lwz imm1 ppc64::double-float.val-low float) + (stdu tsp -32 tsp) + (std tsp 8 tsp) + (stw imm0 fl.h tsp) + (stw imm1 fl.l tsp) + (unbox-fixnum imm0 int) + ;(addi imm0 imm0 1022) ; bias exponent - we assume no ovf + (slwi imm0 imm0 20) ; more important - get it in right place + (stw imm0 sc.h tsp) + (stw rzero sc.l tsp) + (lfd fp0 fl.h tsp) + (lfd fp1 sc.h tsp) + (la tsp 32 tsp) + (fmul fp2 fp0 fp1) + (stfd fp2 ppc64::double-float.value result) + (blr))) + +#+ppc32-target +(defppclapfunction %%scale-sfloat! ((float arg_x)(int arg_y)(result arg_z)) + (let ((sc.h 12)) + (clear-fpu-exceptions) + (lfs fp0 ppc32::single-float.value float) + (unbox-fixnum imm0 int) + (slwi imm0 imm0 IEEE-single-float-exponent-offset) + (stwu tsp -16 tsp) + (stw tsp 4 tsp) + (stw imm0 sc.h tsp) + (lfs fp1 sc.h tsp) + (lwz tsp 0 tsp) + (fmuls fp2 fp0 fp1) + (stfs fp2 ppc32::single-float.value result) + (blr))) + + +#+ppc64-target +(defppclapfunction %%scale-sfloat! ((float arg_y)(int arg_z)) + (let ((sc.h 16)) + (clear-fpu-exceptions) + (get-single-float fp0 float) + (unbox-fixnum imm0 int) + (slwi imm0 imm0 IEEE-single-float-exponent-offset) + (stwu tsp -32 tsp) + (stw tsp 8 tsp) + (stw imm0 sc.h tsp) + (lfs fp1 sc.h tsp) + (la tsp 32 tsp) + (fmuls fp2 fp0 fp1) + (put-single-float fp2 arg_z) + (blr))) + +(defppclapfunction %copy-double-float ((f1 arg_y) (f2 arg_z)) + (lfd fp0 target::double-float.value f1) + (stfd fp0 target::double-float.value f2) + (blr)) + + +#+ppc32-target +(defppclapfunction %copy-short-float ((f1 arg_y) (f2 arg_z)) + (lfs fp0 ppc32::single-float.value f1) + (stfs fp0 ppc32::single-float.value f2) + (blr)) + +#+ppc32-target +(defppclapfunction %double-float-exp ((n arg_z)) + (lwz imm1 target::double-float.value n) + (rlwinm arg_z imm1 (- 32 (- 20 target::fixnumshift)) 19 29) ; right 20 left 2 = right 18 = left 14 + (blr)) + + + +#+ppc32-target +(defppclapfunction set-%double-float-exp ((float arg_y) (exp arg_z)) + (lwz imm1 target::double-float.value float) + (rlwimi imm1 exp (- 20 target::fixnumshift) 1 11) + (stw imm1 target::double-float.value float) ; hdr - tag = 8 - 2 + (blr)) + + + +#+ppc32-target +(defppclapfunction %short-float-exp ((n arg_z)) + (lwz imm1 ppc32::single-float.value n) + (rlwinm arg_z imm1 (- 32 (- 23 ppc32::fixnumshift)) 22 29) + (blr)) + + + +#+ppc32-target +(defppclapfunction set-%short-float-exp ((float arg_y) (exp arg_z)) + (lwz imm1 ppc32::single-float.value float) + (rlwimi imm1 exp (- 23 ppc32::fixnumshift) 1 8) + (stw imm1 ppc32::single-float.value float) + (blr)) + + +(defppclapfunction %short-float->double-float ((src arg_y) (result arg_z)) + (get-single-float fp0 src) + (put-double-float fp0 result) + (blr)) + +#+ppc32-target +(defppclapfunction %double-float->short-float ((src arg_y) (result arg_z)) + ;(clear-fpu-exceptions) + (get-double-float fp0 src) + (frsp fp1 fp0) + (put-single-float fp1 result) + (blr)) + +#+ppc64-target +(defppclapfunction %double-float->short-float ((src arg_z)) + ;(clear-fpu-exceptions) + (get-double-float fp0 src) + (frsp fp1 fp0) + (put-single-float fp1 arg_z) + (blr)) + + + +#+ppc32-target +(defppclapfunction %int-to-sfloat! ((int arg_y) (sfloat arg_z)) + (int-to-freg int fp0 imm0) + (frsp fp1 fp0) + (stfs fp1 ppc32::single-float.value sfloat) + (blr)) + +#+ppc64-target +(defppclapfunction %int-to-sfloat ((int arg_z)) + (int-to-freg int fp0 imm0) + (frsp fp1 fp0) + (stfs fp1 ppc64::tcr.single-float-convert ppc64::rcontext) + (ld arg_z ppc64::tcr.single-float-convert ppc64::rcontext) + (blr)) + + +(defppclapfunction %int-to-dfloat ((int arg_y) (dfloat arg_z)) + (int-to-freg int fp0 imm0) + (stfd fp0 target::double-float.value dfloat) + (blr)) + + + + +; Manipulating the FPSCR. +; This returns the bottom 8 bits of the FPSCR +(defppclapfunction %get-fpscr-control () + (mffs fp0) + (stfd fp0 target::tcr.lisp-fpscr-high target::rcontext) + (lbz imm0 (+ target::tcr.lisp-fpscr-high 7) target::rcontext) + (box-fixnum arg_z imm0) + (blr)) + +; Returns the high 24 bits of the FPSCR +(defppclapfunction %get-fpscr-status () + (mffs fp0) + (stfd fp0 target::tcr.lisp-fpscr-high target::rcontext) + (lwz imm0 target::tcr.lisp-fpscr-low tsp) + (clrrwi imm0 imm0 8) + (srwi arg_z imm0 (- 8 target::fixnumshift)) + (blr)) + +; Set the high 24 bits of the FPSCR; leave the low 8 unchanged +(defppclapfunction %set-fpscr-status ((new arg_z)) + (slwi imm0 new (- 8 target::fixnumshift)) + (stw imm0 target::tcr.lisp-fpscr-low target::rcontext) + (lfd fp0 target::tcr.lisp-fpscr-high target::rcontext) + (mtfsf #xfc fp0) ; set status fields [0-5] + (blr)) + +; Set the low 8 bits of the FPSCR. Zero the upper 24 bits +(defppclapfunction %set-fpscr-control ((new arg_z)) + (unbox-fixnum imm0 new) + (clrlwi imm0 imm0 24) ; ensure that "status" fields are clear + (stw imm0 target::tcr.lisp-fpscr-low target::rcontext) + (lfd fp0 target::tcr.lisp-fpscr-high target::rcontext) + (mtfsf #xff fp0) ; set all fields [0-7] + (blr)) + + +(defppclapfunction %ffi-exception-status () + (ldr imm0 target::tcr.ffi-exception target::rcontext) + (mtcrf #xfc imm0) + (mcrfs :cr6 :cr6) + (mcrfs :cr7 :cr7) + (crand ppc::fpscr-fex-bit ppc::fpscr-oe-bit ppc::fpscr-ox-bit) + (bt ppc::fpscr-fex-bit @set) + (crand ppc::fpscr-fex-bit ppc::fpscr-ve-bit ppc::fpscr-vx-bit) + (bt ppc::fpscr-fex-bit @set) + (crand ppc::fpscr-fex-bit ppc::fpscr-ue-bit ppc::fpscr-ux-bit) + (bt ppc::fpscr-fex-bit @set) + (crand ppc::fpscr-fex-bit ppc::fpscr-ze-bit ppc::fpscr-zx-bit) + (bt ppc::fpscr-fex-bit @set) + (crand ppc::fpscr-fex-bit ppc::fpscr-xe-bit ppc::fpscr-xx-bit) + (bf ppc::fpscr-fex-bit @ret) + @set + (oris imm0 imm0 #xc000) + @ret + (srwi arg_z imm0 (- 8 target::fixnumshift)) + (blr)) + + +; See if the binary double-float operation OP set any enabled +; exception bits in the fpscr +(defun %df-check-exception-2 (operation op0 op1 fp-status) + (declare (type (unsigned-byte 24) fp-status)) + (when (logbitp (- 23 ppc::fpscr-fex-bit) fp-status) + (%set-fpscr-status 0) + ;; Ensure that operands are heap-consed + (%fp-error-from-status fp-status + (%get-fpscr-control) + operation + (%copy-double-float op0 (%make-dfloat)) + (%copy-double-float op1 (%make-dfloat))))) + +(defun %sf-check-exception-2 (operation op0 op1 fp-status) + (declare (type (unsigned-byte 24) fp-status)) + (when (logbitp (- 23 ppc::fpscr-fex-bit) fp-status) + (%set-fpscr-status 0) + ;; Ensure that operands are heap-consed + (%fp-error-from-status fp-status + (%get-fpscr-control) + operation + #+ppc32-target + (%copy-short-float op0 (%make-sfloat)) + #+ppc64-target op0 + #+ppc32-target + (%copy-short-float op1 (%make-sfloat)) + #+ppc64-target op1))) + +(defun %df-check-exception-1 (operation op0 fp-status) + (declare (fixnum fp-status)) + (when (logbitp (- 23 ppc::fpscr-fex-bit) fp-status) + (%set-fpscr-status 0) + ;; Ensure that operands are heap-consed + (%fp-error-from-status fp-status + (%get-fpscr-control) + operation + (%copy-double-float op0 (%make-dfloat))))) + +(defun %sf-check-exception-1 (operation op0 fp-status) + (declare (type (unsigned-byte 24) fp-status)) + (when (logbitp (- 23 ppc::fpscr-fex-bit) fp-status) + (%set-fpscr-status 0) + ; Ensure that operands are heap-consed + (%fp-error-from-status fp-status + (%get-fpscr-control) + operation + #+ppc32-target + (%copy-short-float op0 (%make-sfloat)) + #+ppc64-target op0))) + + +(defun fp-condition-from-fpscr (status-bits control-bits) + (declare (fixnum status-bits control-bits)) + (cond + ((and (logbitp (- 23 ppc::fpscr-vx-bit) status-bits) + (logbitp (- 31 ppc::fpscr-ve-bit) control-bits)) + 'floating-point-invalid-operation) + ((and (logbitp (- 23 ppc::fpscr-ox-bit) status-bits) + (logbitp (- 31 ppc::fpscr-oe-bit) control-bits)) + 'floating-point-overflow) + ((and (logbitp (- 23 ppc::fpscr-ux-bit) status-bits) + (logbitp (- 31 ppc::fpscr-ue-bit) control-bits)) + 'floating-point-underflow) + ((and (logbitp (- 23 ppc::fpscr-zx-bit) status-bits) + (logbitp (- 31 ppc::fpscr-ze-bit) control-bits)) + 'division-by-zero) + ((and (logbitp (- 23 ppc::fpscr-xx-bit) status-bits) + (logbitp (- 31 ppc::fpscr-xe-bit) control-bits)) + 'floating-point-inexact))) + +;;; This assumes that the FEX and one of {VX OX UX ZX XX} is set. +(defun %fp-error-from-status (status-bits control-bits operation &rest operands) + (declare (type (unsigned-byte 16) status-bits)) + (case operation + (sqrt (setq operands (cdr operands)))) + (let* ((condition-class (fp-condition-from-fpscr status-bits control-bits))) + (if condition-class + (error (make-instance condition-class + :operation operation + :operands operands))))) + +(defun fp-minor-opcode-operation (minor-opcode) + (case minor-opcode + (25 '*) + (18 '/) + (20 '-) + (21 '+) + (22 'sqrt) + (t 'unknown))) + +;;; Don't we already have about 20 versions of this ? +(defppclapfunction %double-float-from-macptr! ((ptr arg_x) (byte-offset arg_y) (dest arg_z)) + (ldr imm0 target::macptr.address ptr) + (unbox-fixnum imm1 byte-offset) + (lfdx fp1 imm0 imm1) + (put-double-float fp1 dest) + (blr)) + + +(defvar *rounding-mode-alist* + '((:nearest . 0) (:zero . 1) (:positive . 2) (:negative . 3))) + +(defun get-fpu-mode (&optional (mode nil mode-p)) + (let* ((flags (%get-fpscr-control))) + (declare (type (unsigned-byte 8) flags)) + (if mode-p + (ecase mode + (:rounding-mode (car (nth (logand flags 3) *rounding-mode-alist*))) + (:overflow (logbitp (- 31 ppc::fpscr-oe-bit) flags)) + (:underflow (logbitp (- 31 ppc::fpscr-ue-bit) flags)) + (:division-by-zero (logbitp (- 31 ppc::fpscr-ze-bit) flags)) + (:invalid (logbitp (- 31 ppc::fpscr-ve-bit) flags)) + (:inexact (logbitp (- 31 ppc::fpscr-xe-bit) flags))) + `(:rounding-mode ,(car (nth (logand flags 3) *rounding-mode-alist*)) + :overflow ,(logbitp (- 31 ppc::fpscr-oe-bit) flags) + :underflow ,(logbitp (- 31 ppc::fpscr-ue-bit) flags) + :division-by-zero ,(logbitp (- 31 ppc::fpscr-ze-bit) flags) + :invalid ,(logbitp (- 31 ppc::fpscr-ve-bit) flags) + :inexact ,(logbitp (- 31 ppc::fpscr-xe-bit) flags))))) + +;;; did we document this? +(defun set-fpu-mode (&key (rounding-mode :nearest rounding-p) + (overflow t overflow-p) + (underflow t underflow-p) + (division-by-zero t zero-p) + (invalid t invalid-p) + (inexact t inexact-p)) + (let* ((mask (logior (if rounding-p #x03 #x00) + (if invalid-p + (ash 1 (- 31 ppc::fpscr-ve-bit)) + #x00) + (if overflow-p + (ash 1 (- 31 ppc::fpscr-oe-bit)) + #x00) + (if underflow-p + (ash 1 (- 31 ppc::fpscr-ue-bit)) + #x00) + (if zero-p + (ash 1 (- 31 ppc::fpscr-ze-bit)) + #x00) + (if inexact-p + (ash 1 (- 31 ppc::fpscr-xe-bit)) + #x00))) + (new (logior (or (cdr (assoc rounding-mode *rounding-mode-alist*)) + (error "Unknown rounding mode: ~s" rounding-mode)) + (if invalid (ash 1 (- 31 ppc::fpscr-ve-bit)) 0) + (if overflow (ash 1 (- 31 ppc::fpscr-oe-bit)) 0) + (if underflow (ash 1 (- 31 ppc::fpscr-ue-bit)) 0) + (if division-by-zero (ash 1 (- 31 ppc::fpscr-ze-bit)) 0) + (if inexact (ash 1 (- 31 ppc::fpscr-xe-bit)) 0)))) + (declare (type (unsigned-byte 8) new mask)) + (%set-fpscr-control (logior (logand new mask) + (logandc2 (%get-fpscr-control) mask))))) + + +;;; Copy a single float pointed at by the macptr in single +;;; to a double float pointed at by the macptr in double + +(defppclapfunction %single-float-ptr->double-float-ptr ((single arg_y) (double arg_z)) + (check-nargs 2) + (macptr-ptr imm0 single) + (lfs fp0 0 imm0) + (macptr-ptr imm0 double) + (stfd fp0 0 imm0) + (blr)) + +;;; Copy a double float pointed at by the macptr in double +;;; to a single float pointed at by the macptr in single. +(defppclapfunction %double-float-ptr->single-float-ptr ((double arg_y) (single arg_z)) + (check-nargs 2) + (macptr-ptr imm0 double) + (lfd fp0 0 imm0) + (macptr-ptr imm0 single) + (stfs fp0 0 imm0) + (blr)) + + +(defppclapfunction %set-ieee-single-float-from-double ((src arg_y) (macptr arg_z)) + (check-nargs 2) + (macptr-ptr imm0 macptr) + (get-double-float fp1 src) + (stfs fp1 0 imm0) + (blr)) + +#+ppc32-target +(defun host-single-float-from-unsigned-byte-32 (u32) + (let* ((f (%make-sfloat))) + (setf (uvref f ppc32::single-float.value-cell) u32) + f)) + +#+ppc64-target +(defppclapfunction host-single-float-from-unsigned-byte-32 ((u32 arg_z)) + (sldi arg_z arg_z (- 32 ppc64::fixnumshift)) + (ori arg_z arg_z ppc64::subtag-single-float) + (blr)) + + +#+ppc32-target +(defun single-float-bits (f) + (uvref f ppc32::single-float.value-cell)) + +#+ppc64-target +(defppclapfunction single-float-bits ((f arg_z)) + (srdi arg_z f (- 32 ppc64::fixnumshift)) + (blr)) + +(defun double-float-bits (f) + (values (uvref f target::double-float.value-cell) + (uvref f target::double-float.val-low-cell))) + +(defun double-float-from-bits (high low) + (let* ((f (%make-dfloat))) + (setf (uvref f target::double-float.value-cell) high + (uvref f target::double-float.val-low-cell) low) + f)) + +(defppclapfunction %double-float-sign ((n arg_z)) + (lwz imm0 target::double-float.value n) + (cmpwi imm0 0) + (li arg_z nil) + (bgelr) + (li arg_z t) + (blr)) + +(defppclapfunction %short-float-sign ((n arg_z)) + #+ppc32-target (lwz imm0 ppc32::single-float.value n) + #+ppc64-target (srdi imm0 n 32) + (cmpwi imm0 0) + (li arg_z nil) + (bgelr) + (li arg_z t) + (blr)) + +#+32-bit-target +(defppclapfunction %single-float-sqrt! ((src arg_y) (dest arg_z)) + (get-single-float fp1 src) + (fsqrts fp2 fp1) + (put-single-float fp2 dest) + (blr)) + +#+64-bit-target +(defppclapfunction %single-float-sqrt ((arg arg_z)) + (get-single-float fp1 arg) + (fsqrts fp2 fp1) + (put-single-float fp2 arg_z) + (blr)) + +(defppclapfunction %double-float-sqrt! ((src arg_y) (dest arg_z)) + (get-double-float fp1 src) + (fsqrt fp2 fp1) + (put-double-float fp2 dest) + (blr)) + +#+poweropen-target +(defppclapfunction %get-fp-arg-regs ((ptr arg_z)) + (macptr-ptr imm0 ptr) + (stfd fp1 0 imm0) + (stfd fp2 8 imm0) + (stfd fp3 16 imm0) + (stfd fp4 24 imm0) + (stfd fp5 32 imm0) + (stfd fp6 40 imm0) + (stfd fp7 48 imm0) + (stfd fp8 56 imm0) + (stfd fp9 64 imm0) + (stfd fp10 72 imm0) + (stfd fp11 80 imm0) + (stfd fp12 88 imm0) + (stfd fp13 96 imm0) + (blr)) + +#+poweropen-target +(defppclapfunction %load-fp-arg-regs ((n arg_y) (ptr arg_z)) + (cmpdi cr0 n '0) + (cmpdi cr1 n '1) + (cmpdi cr2 n '2) + (cmpdi cr3 n '3) + (cmpdi cr4 n '4) + (cmpdi cr5 n '5) + (cmpdi cr6 n '6) + (cmpdi cr7 n '7) + (beqlr cr0) + (macptr-ptr imm0 ptr) + (cmpdi cr0 n '8) + (lfd fp1 0 imm0) + (beqlr cr1) + (cmpdi cr1 n '9) + (lfd fp2 8 imm0) + (beqlr cr2) + (cmpdi cr2 n '10) + (lfd fp3 16 imm0) + (beqlr cr3) + (cmpdi cr3 n '11) + (lfd fp4 24 imm0) + (beqlr cr4) + (cmpdi cr4 n '12) + (lfd fp5 32 imm0) + (beqlr cr5) + (lfd fp6 40 imm0) + (beqlr cr6) + (lfd fp7 48 imm0) + (beqlr cr7) + (lfd fp8 56 imm0) + (beqlr cr0) + (lfd fp9 64 imm0) + (beqlr cr1) + (lfd fp10 72 imm0) + (beqlr cr2) + (lfd fp11 80 imm0) + (beqlr cr3) + (lfd fp12 88 imm0) + (beqlr cr4) + (lfd fp13 96 imm0) + (blr)) Index: /branches/new-random/level-0/PPC/ppc-hash.lisp =================================================================== --- /branches/new-random/level-0/PPC/ppc-hash.lisp (revision 13309) +++ /branches/new-random/level-0/PPC/ppc-hash.lisp (revision 13309) @@ -0,0 +1,168 @@ +;;; -*- Mode: Lisp; Package: CCL -*- +;;; +;;; Copyright (C) 2009 Clozure Associates +;;; Copyright (C) 1994-2001 Digitool, Inc +;;; This file is part of Clozure CL. +;;; +;;; Clozure CL is licensed under the terms of the Lisp Lesser GNU Public +;;; License , known as the LLGPL and distributed with Clozure CL as the +;;; file "LICENSE". The LLGPL consists of a preamble and the LGPL, +;;; which is distributed with Clozure CL as the file "LGPL". Where these +;;; conflict, the preamble takes precedence. +;;; +;;; Clozure CL is referenced in the preamble as the "LIBRARY." +;;; +;;; The LLGPL is also available online at +;;; http://opensource.franz.com/preamble.html + +;;; level-0;ppc;ppc-hash.lisp + + +(in-package "CCL") + +(eval-when (:compile-toplevel :execute) + (require "HASHENV" "ccl:xdump;hashenv")) + + + + +;;; This should stay in LAP so that it's fast +;;; Equivalent to cl:mod when both args are positive fixnums +(defppclapfunction fast-mod ((number arg_y) (divisor arg_z)) + #+ppc32-target + (progn + (divwu imm0 number divisor) + (mullw arg_z imm0 divisor)) + #+ppc64-target + (progn + (divdu imm0 number divisor) + (mulld arg_z imm0 divisor)) + (subf arg_z arg_z number) + (blr)) + + +(defppclapfunction fast-mod-3 ((number arg_x) (divisor arg_y) (recip arg_z)) + #+ppc32-target + (progn + (srwi imm0 number ppc32::fixnumshift) + (mulhw imm1 imm0 recip) + (mullw imm0 imm1 divisor)) + #+ppc64-target + (progn + (srdi imm0 number ppc64::fixnumshift) + (mulhd imm1 imm0 recip) + (mulld imm0 imm1 divisor)) + (sub number number imm0) + (sub number number divisor) + (srari imm0 number (1- target::nbits-in-word)) + (and divisor divisor imm0) + (add arg_z number divisor) + (blr)) + +#+ppc32-target +(defppclapfunction %dfloat-hash ((key arg_z)) + (lwz imm0 ppc32::double-float.value key) + (lwz imm1 ppc32::double-float.val-low key) + (add imm0 imm0 imm1) + (box-fixnum arg_z imm0) + (blr)) + +#+ppc64-target +(defppclapfunction %dfloat-hash ((key arg_z)) + (ld imm0 ppc64::double-float.value key) + (box-fixnum arg_z imm0) + (blr)) + +#+ppc32-target +(defppclapfunction %sfloat-hash ((key arg_z)) + (lwz imm0 ppc32::single-float.value key) + (box-fixnum arg_z imm0) + (blr)) + +#+ppc64-target +(defppclapfunction %sfloat-hash ((key arg_z)) + (lis imm0 #x8000) + (srdi imm1 key 32) + (cmpw imm0 imm1) + (srdi arg_z key (- 32 ppc64::fixnumshift)) + (bnelr) + (li arg_z 0) + (blr)) + +(defppclapfunction %macptr-hash ((key arg_z)) + (ldr imm0 target::macptr.address key) + (slri imm1 imm0 24) + (add imm0 imm0 imm1) + (clrrri arg_z imm0 target::fixnumshift) + (blr)) + +#+ppc32-target +(defppclapfunction %bignum-hash ((key arg_z)) + (let ((header imm3) + (offset imm2) + (ndigits imm1) + (immhash imm0)) + (li immhash 0) + (li offset ppc32::misc-data-offset) + (getvheader header key) + (header-size ndigits header) + (let ((next header)) + @loop + (cmpwi cr0 ndigits 1) + (subi ndigits ndigits 1) + (lwzx next key offset) + (addi offset offset 4) + (rotlwi immhash immhash 13) + (add immhash immhash next) + (bne cr0 @loop)) + (clrrwi arg_z immhash ppc32::fixnumshift) + (blr))) + +#+ppc64-target +(defppclapfunction %bignum-hash ((key arg_z)) + (let ((header imm3) + (offset imm2) + (ndigits imm1) + (immhash imm0)) + (li immhash 0) + (li offset ppc64::misc-data-offset) + (getvheader header key) + (header-size ndigits header) + (let ((next header)) + @loop + (cmpdi cr0 ndigits 1) + (subi ndigits ndigits 1) + (lwzx next key offset) + (rotldi immhash immhash 13) + (addi offset offset 4) + (add immhash immhash next) + (bne cr0 @loop)) + (clrrdi arg_z immhash ppc64::fixnumshift) + (blr))) + + +(defppclapfunction %get-fwdnum () + (ref-global arg_z target::fwdnum) + (blr)) + + +(defppclapfunction %get-gc-count () + (ref-global arg_z target::gc-count) + (blr)) + + +;;; Setting a key in a hash-table vector needs to +;;; ensure that the vector header gets memoized as well +(defppclapfunction %set-hash-table-vector-key ((vector arg_x) (index arg_y) (value arg_z)) + (ba .SPset-hash-key)) + +(defppclapfunction %set-hash-table-vector-key-conditional ((offset 0) (vector arg_x) (old arg_y) (new arg_z)) + (ba .SPset-hash-key-conditional)) + +;;; Strip the tag bits to turn x into a fixnum +(defppclapfunction strip-tag-to-fixnum ((x arg_z)) + (unbox-fixnum imm0 x) + (box-fixnum arg_z imm0) + (blr)) + +;;; end of ppc-hash.lisp Index: /branches/new-random/level-0/PPC/ppc-io.lisp =================================================================== --- /branches/new-random/level-0/PPC/ppc-io.lisp (revision 13309) +++ /branches/new-random/level-0/PPC/ppc-io.lisp (revision 13309) @@ -0,0 +1,32 @@ +;;; -*- Mode: Lisp; Package: CCL; -*- +;;; +;;; Copyright (C) 2009 Clozure Associates +;;; Copyright (C) 1994-2001 Digitool, Inc +;;; This file is part of Clozure CL. +;;; +;;; Clozure CL is licensed under the terms of the Lisp Lesser GNU Public +;;; License , known as the LLGPL and distributed with Clozure CL as the +;;; file "LICENSE". The LLGPL consists of a preamble and the LGPL, +;;; which is distributed with Clozure CL as the file "LGPL". Where these +;;; conflict, the preamble takes precedence. +;;; +;;; Clozure CL is referenced in the preamble as the "LIBRARY." +;;; +;;; The LLGPL is also available online at +;;; http://opensource.franz.com/preamble.html + + + +(in-package "CCL") + +;;; not very smart yet + +(defppclapfunction %get-errno () + (ldr imm1 target::tcr.errno-loc target::rcontext) + (lwz imm0 0 imm1) + (stw rzero 0 imm1) + (neg imm0 imm0) + (box-fixnum arg_z imm0) + (blr)) + +; end Index: /branches/new-random/level-0/PPC/ppc-misc.lisp =================================================================== --- /branches/new-random/level-0/PPC/ppc-misc.lisp (revision 13309) +++ /branches/new-random/level-0/PPC/ppc-misc.lisp (revision 13309) @@ -0,0 +1,1066 @@ +;;; -*- Mode: Lisp; Package: CCL -*- +;;; +;;; Copyright (C) 2009 Clozure Associates +;;; Copyright (C) 1994-2001 Digitool, Inc +;;; This file is part of Clozure CL. +;;; +;;; Clozure CL is licensed under the terms of the Lisp Lesser GNU Public +;;; License , known as the LLGPL and distributed with Clozure CL as the +;;; file "LICENSE". The LLGPL consists of a preamble and the LGPL, +;;; which is distributed with Clozure CL as the file "LGPL". Where these +;;; conflict, the preamble takes precedence. +;;; +;;; Clozure CL is referenced in the preamble as the "LIBRARY." +;;; +;;; The LLGPL is also available online at +;;; http://opensource.franz.com/preamble.html + +;;; level-0;x86;x86-misc.lisp + + +(in-package "CCL") + +;;; Copy N bytes from pointer src, starting at byte offset src-offset, +;;; to ivector dest, starting at offset dest-offset. +;;; It's fine to leave this in lap. +;;; Depending on alignment, it might make sense to move more than +;;; a byte at a time. +;;; Does no arg checking of any kind. Really. + +(defppclapfunction %copy-ptr-to-ivector ((src (* 1 target::node-size) ) + (src-byte-offset 0) + (dest arg_x) + (dest-byte-offset arg_y) + (nbytes arg_z)) + (let ((src-reg imm0) + (src-byteptr imm1) + (src-node-reg temp0) + (dest-byteptr imm2) + (val imm3) + (node-temp temp1)) + (cmpri cr0 nbytes 0) + (ldr src-node-reg src vsp) + (macptr-ptr src-reg src-node-reg) + (ldr src-byteptr src-byte-offset vsp) + (unbox-fixnum src-byteptr src-byteptr) + (unbox-fixnum dest-byteptr dest-byte-offset) + (la dest-byteptr target::misc-data-offset dest-byteptr) + (b @test) + @loop + (subi nbytes nbytes '1) + (cmpri cr0 nbytes '0) + (lbzx val src-reg src-byteptr) + (la src-byteptr 1 src-byteptr) + (stbx val dest dest-byteptr) + (la dest-byteptr 1 dest-byteptr) + @test + (bne cr0 @loop) + (mr arg_z dest) + (la vsp '2 vsp) + (blr))) + +(defppclapfunction %copy-ivector-to-ptr ((src (* 1 target::node-size)) + (src-byte-offset 0) + (dest arg_x) + (dest-byte-offset arg_y) + (nbytes arg_z)) + (ldr temp0 src vsp) + (cmpri cr0 nbytes 0) + (ldr imm0 src-byte-offset vsp) + (unbox-fixnum imm0 imm0) + (la imm0 target::misc-data-offset imm0) + (unbox-fixnum imm2 dest-byte-offset) + (ldr imm1 target::macptr.address dest) + (b @test) + @loop + (subi nbytes nbytes '1) + (cmpri cr0 nbytes 0) + (lbzx imm3 temp0 imm0) + (addi imm0 imm0 1) + (stbx imm3 imm1 imm2) + (addi imm2 imm2 1) + @test + (bne cr0 @loop) + (mr arg_z dest) + (la vsp '2 vsp) + (blr)) + +#+ppc32-target +(defppclapfunction %copy-ivector-to-ivector ((src 4) + (src-byte-offset 0) + (dest arg_x) + (dest-byte-offset arg_y) + (nbytes arg_z)) + (lwz temp0 src vsp) + (cmpwi cr0 nbytes 0) + (cmpw cr2 temp0 dest) ; source and dest same? + (rlwinm imm3 nbytes 0 (- 30 target::fixnum-shift) 31) + (lwz imm0 src-byte-offset vsp) + (rlwinm imm1 imm0 0 (- 30 target::fixnum-shift) 31) + (or imm3 imm3 imm1) + (unbox-fixnum imm0 imm0) + (la imm0 target::misc-data-offset imm0) + (unbox-fixnum imm2 dest-byte-offset) + (rlwimi imm1 imm2 0 30 31) + (or imm3 imm3 imm1) + (cmpwi cr1 imm3 0) ; is everybody multiple of 4? + (la imm2 target::misc-data-offset imm2) + (beq cr2 @SisD) ; source and dest same + @fwd + (beq :cr1 @wtest) + (b @test) + + @loop + (subi nbytes nbytes '1) + (cmpwi cr0 nbytes 0) + (lbzx imm3 temp0 imm0) + (addi imm0 imm0 1) + (stbx imm3 dest imm2) + (addi imm2 imm2 1) + @test + (bne cr0 @loop) + (mr arg_z dest) + (la vsp 8 vsp) + (blr) + + @words ; source and dest different - words + (subi nbytes nbytes '4) + (cmpwi cr0 nbytes 0) + (lwzx imm3 temp0 imm0) + (addi imm0 imm0 4) + (stwx imm3 dest imm2) + (addi imm2 imm2 4) + @wtest + (bgt cr0 @words) + @done + (mr arg_z dest) + (la vsp 8 vsp) + (blr) + + @SisD + (cmpw cr2 imm0 imm2) ; cmp src and dest + (bgt cr2 @fwd) + ;(B @bwd) + + + ; Copy backwards when src & dest are the same and we're sliding down + @bwd ; ok + (unbox-fixnum imm3 nbytes) + (add imm0 imm0 imm3) + (add imm2 imm2 imm3) + (b @test2) + @loop2 + (subi nbytes nbytes '1) + (cmpwi cr0 nbytes 0) + (subi imm0 imm0 1) + (lbzx imm3 temp0 imm0) + (subi imm2 imm2 1) + (stbx imm3 dest imm2) + @test2 + (bne cr0 @loop2) + (b @done)) + +#+ppc64-target +(defppclapfunction %copy-ivector-to-ivector ((src-offset 8) + (src-byte-offset-offset 0) + (dest arg_x) + (dest-byte-offset arg_y) + (nbytes arg_z)) + (let ((src temp0) + (src-byte-offset imm0)) + (subi nbytes nbytes '1) + (ld src-byte-offset src-byte-offset-offset vsp) + (cmpdi nbytes 0 ) + (ld src src-offset vsp) + (la vsp '2 vsp) + (cmpd cr1 src dest) + (cmpdi cr2 src-byte-offset dest-byte-offset) + (unbox-fixnum src-byte-offset src-byte-offset) + (unbox-fixnum imm1 dest-byte-offset) + (la imm0 target::misc-data-offset src-byte-offset) + (la imm1 target::misc-data-offset imm1) + (bne cr1 @test) + ;; Maybe overlap, or maybe nothing to do. + (beq cr2 @done) ; same vectors, same offsets + (blt cr2 @back) ; copy backwards, avoid overlap + (b @test) + @loop + (subi nbytes nbytes '1) + (lbzx imm3 src imm0) + (cmpdi nbytes 0) + (addi imm0 imm0 1) + (stbx imm3 dest imm1) + (addi imm1 imm1 1) + @test + (bge @loop) + @done + (mr arg_z dest) + (blr) + @back + ;; nbytes was predecremented above + (unbox-fixnum imm2 nbytes) + (add imm0 imm2 imm0) + (add imm1 imm2 imm1) + (b @back-test) + @back-loop + (subi nbytes nbytes '1) + (lbzx imm3 src imm0) + (cmpdi nbytes 0) + (subi imm0 imm0 1) + (stbx imm3 dest imm1) + (subi imm1 imm1 1) + @back-test + (bge @back-loop) + (mr arg_z dest) + (blr))) + + +(defppclapfunction %copy-gvector-to-gvector ((src (* 1 target::node-size)) + (src-element 0) + (dest arg_x) + (dest-element arg_y) + (nelements arg_z)) + (subi nelements nelements '1) + (cmpri nelements 0) + (ldr imm0 src-element vsp) + (ldr temp0 src vsp) + (la vsp '2 vsp) + (cmpr cr1 temp0 dest) + (cmpri cr2 src-element dest-element) + (la imm0 target::misc-data-offset imm0) + (la imm1 target::misc-data-offset dest-element) + (bne cr1 @test) + ;; Maybe overlap, or maybe nothing to do. + (beq cr2 @done) ; same vectors, same offsets + (blt cr2 @back) ; copy backwards, avoid overlap + (b @test) + @loop + (subi nelements nelements '1) + (cmpri nelements 0) + (ldrx temp1 temp0 imm0) + (addi imm0 imm0 '1) + (strx temp1 dest imm1) + (addi imm1 imm1 '1) + @test + (bge @loop) + @done + (mr arg_z dest) + (blr) + @back + ;; We decremented NELEMENTS by 1 above. + (add imm1 nelements imm1) + (add imm0 nelements imm0) + (b @back-test) + @back-loop + (subi nelements nelements '1) + (cmpri nelements 0) + (ldrx temp1 temp0 imm0) + (subi imm0 imm0 '1) + (strx temp1 dest imm1) + (subi imm1 imm1 '1) + @back-test + (bge @back-loop) + (mr arg_z dest) + (blr)) + + + + + +#+ppc32-target +(defppclapfunction %heap-bytes-allocated () + (lwz imm2 target::tcr.last-allocptr ppc32::rcontext) + (cmpwi cr1 imm2 0) + (cmpwi allocptr -8) ;void_allocptr + (lwz imm0 target::tcr.total-bytes-allocated-high ppc32::rcontext) + (lwz imm1 target::tcr.total-bytes-allocated-low ppc32::rcontext) + (sub imm2 imm2 allocptr) + (beq cr1 @go) + (beq @go) + (addc imm1 imm1 imm2) + (addze imm0 imm0) + @go + (ba .SPmakeu64)) + +#+ppc64-target +(defppclapfunction %heap-bytes-allocated () + (ld imm2 target::tcr.last-allocptr ppc64::rcontext) + (cmpri cr1 imm2 0) + (cmpri allocptr -16) ;void_allocptr + (ld imm0 target::tcr.total-bytes-allocated-high ppc64::rcontext) + (sub imm2 imm2 allocptr) + (beq cr1 @go) + (beq @go) + (add imm0 imm0 imm2) + @go + (ba .SPmakeu64)) + + +(defppclapfunction values () + (:arglist (&rest values)) + (vpush-argregs) + (add temp0 nargs vsp) + (ba .SPvalues)) + +;; It would be nice if (%setf-macptr macptr (ash (the fixnum value) ash::fixnumshift)) +;; would do this inline. +#+ppc-target +(defppclapfunction %setf-macptr-to-object ((macptr arg_y) (object arg_z)) + (check-nargs 2) + (trap-unless-typecode= arg_y target::subtag-macptr) + (str arg_z target::macptr.address arg_y) + (blr)) + +(defppclapfunction %fixnum-from-macptr ((macptr arg_z)) + (check-nargs 1) + (trap-unless-typecode= arg_z target::subtag-macptr) + (ldr imm0 target::macptr.address arg_z) + (trap-unless-lisptag= imm0 target::tag-fixnum imm1) + (mr arg_z imm0) + (blr)) + +#+ppc32-target +(defppclapfunction %%get-unsigned-longlong ((ptr arg_y) (offset arg_z)) + (trap-unless-typecode= ptr ppc32::subtag-macptr) + (macptr-ptr imm1 ptr) + (unbox-fixnum imm2 offset) + (add imm2 imm2 imm1) + (lwz imm0 0 imm2) + (lwz imm1 4 imm2) + (ba .SPmakeu64)) + +#+ppc64-target +(defppclapfunction %%get-unsigned-longlong ((ptr arg_y) (offset arg_z)) + (trap-unless-typecode= ptr ppc64::subtag-macptr) + (macptr-ptr imm1 ptr) + (unbox-fixnum imm2 offset) + (ldx imm0 imm2 imm1) + (ba .SPmakeu64)) + +#+ppc32-target +(defppclapfunction %%get-signed-longlong ((ptr arg_y) (offset arg_z)) + (trap-unless-typecode= ptr ppc32::subtag-macptr) + (macptr-ptr imm1 ptr) + (unbox-fixnum imm2 offset) + (add imm2 imm2 imm1) + (lwz imm0 0 imm2) + (lwz imm1 4 imm2) + (ba .SPmakes64)) + +#+ppc64-target +(defppclapfunction %%get-signed-longlong ((ptr arg_y) (offset arg_z)) + (trap-unless-typecode= ptr ppc64::subtag-macptr) + (macptr-ptr imm1 ptr) + (unbox-fixnum imm2 offset) + (ldx imm0 imm2 imm1) + (ba .SPmakes64)) + +#+ppc32-target +(defppclapfunction %%set-unsigned-longlong ((ptr arg_x) + (offset arg_y) + (val arg_z)) + (save-lisp-context) + (trap-unless-typecode= ptr ppc32::subtag-macptr) + (bla .SPgetu64) + (macptr-ptr imm2 ptr) + (unbox-fixnum imm3 offset) + (add imm2 imm3 imm2) + (stw imm0 0 imm2) + (stw imm1 4 imm2) + (ba .SPpopj)) + +#+ppc64-target +(defppclapfunction %%set-unsigned-longlong ((ptr arg_x) + (offset arg_y) + (val arg_z)) + (save-lisp-context) + (trap-unless-typecode= ptr ppc64::subtag-macptr) + (bla .SPgetu64) + (macptr-ptr imm2 ptr) + (unbox-fixnum imm3 offset) + (stdx imm0 imm3 imm2) + (ba .SPpopj)) + +#+ppc32-target +(defppclapfunction %%set-signed-longlong ((ptr arg_x) + (offset arg_y) + (val arg_z)) + (save-lisp-context) + (trap-unless-typecode= ptr ppc32::subtag-macptr) + (bla .SPgets64) + (macptr-ptr imm2 ptr) + (unbox-fixnum imm3 offset) + (add imm2 imm3 imm2) + (stw imm0 0 imm2) + (stw imm1 4 imm2) + (ba .SPpopj)) + +#+ppc64-target +(defppclapfunction %%set-signed-longlong ((ptr arg_x) + (offset arg_y) + (val arg_z)) + (save-lisp-context) + (trap-unless-typecode= ptr target::subtag-macptr) + (bla .SPgets64) + (macptr-ptr imm2 ptr) + (unbox-fixnum imm3 offset) + (stdx imm0 imm3 imm2) + (ba .SPpopj)) + +(defppclapfunction interrupt-level () + (ldr arg_z target::tcr.tlb-pointer target::rcontext) + (ldr arg_z target::interrupt-level-binding-index arg_z) + (blr)) + + +(defppclapfunction disable-lisp-interrupts () + (li imm0 '-1) + (ldr imm1 target::tcr.tlb-pointer target::rcontext) + (ldr arg_z target::interrupt-level-binding-index imm1) + (str imm0 target::interrupt-level-binding-index imm1) + (blr)) + +(defppclapfunction set-interrupt-level ((new arg_z)) + (ldr imm1 target::tcr.tlb-pointer target::rcontext) + (trap-unless-lisptag= new target::tag-fixnum imm0) + (str new target::interrupt-level-binding-index imm1) + (blr)) + +;;; If we're restoring the interrupt level to 0 and an interrupt +;;; was pending, restore the level to 1 and zero the pending status. +(defppclapfunction restore-interrupt-level ((old arg_z)) + (cmpri :cr1 old 0) + (ldr imm0 target::tcr.interrupt-pending target::rcontext) + (ldr imm1 target::tcr.tlb-pointer target::rcontext) + (cmpri :cr0 imm0 0) + (bne :cr1 @store) + (beq :cr0 @store) + (str rzero target::tcr.interrupt-pending target::rcontext) + (li old '1) + @store + (str old target::interrupt-level-binding-index imm1) + (blr)) + + + +(defppclapfunction %current-tcr () + (mr arg_z target::rcontext) + (blr)) + +(defppclapfunction %tcr-toplevel-function ((tcr arg_z)) + (check-nargs 1) + (cmpr tcr target::rcontext) + (mr imm0 vsp) + (ldr temp0 target::tcr.vs-area tcr) + (ldr imm1 target::area.high temp0) + (beq @room) + (ldr imm0 target::area.active temp0) + @room + (cmpr imm1 imm0) + (li arg_z nil) + (beqlr) + (ldr arg_z (- target::node-size) imm1) + (blr)) + +(defppclapfunction %set-tcr-toplevel-function ((tcr arg_y) (fun arg_z)) + (check-nargs 2) + (cmpr tcr target::rcontext) + (mr imm0 vsp) + (ldr temp0 target::tcr.vs-area tcr) + (ldr imm1 target::area.high temp0) + (beq @check-room) + (ldr imm0 target::area.active temp0) + @check-room + (cmpr imm1 imm0) + (push rzero imm1) + (bne @have-room) + (str imm1 target::area.active temp0) + (str imm1 target::tcr.save-vsp tcr) + @have-room + (str fun 0 imm1) + (blr)) + +;;; This needs to be done out-of-line, to handle EGC memoization. +(defppclapfunction %store-node-conditional ((offset 0) (object arg_x) (old arg_y) (new arg_z)) + (ba .SPstore-node-conditional)) + +(defppclapfunction %store-immediate-conditional ((offset 0) (object arg_x) (old arg_y) (new arg_z)) + (vpop temp0) + (unbox-fixnum imm0 temp0) + (let ((current temp1)) + @again + (lrarx current object imm0) + (cmpr current old) + (bne @lose) + (strcx. new object imm0) + (bne @again) + (isync) + (li arg_z (+ target::t-offset (target-nil-value))) + (blr) + @lose + (li imm0 target::reservation-discharge) + (strcx. rzero rzero imm0) + (li arg_z nil) + (blr))) + +(defppclapfunction set-%gcable-macptrs% ((ptr target::arg_z)) + (li imm0 (+ (target-nil-value) (target::kernel-global gcable-pointers))) + @again + (lrarx arg_y rzero imm0) + (str arg_y target::xmacptr.link ptr) + (strcx. ptr rzero imm0) + (bne @again) + (isync) + (blr)) + +;;; Atomically increment or decrement the gc-inhibit-count kernel-global +;;; (It's decremented if it's currently negative, incremented otherwise.) +(defppclapfunction %lock-gc-lock () + (li imm0 (+ (target-nil-value) (target::kernel-global gc-inhibit-count))) + @again + (lrarx arg_y rzero imm0) + (cmpri cr1 arg_y 0) + (addi arg_z arg_y '1) + (bge cr1 @store) + (subi arg_z arg_y '1) + @store + (strcx. arg_z rzero imm0) + (bne @again) +;; (isync) + (blr)) + +;;; Atomically decrement or increment the gc-inhibit-count kernel-global +;;; (It's incremented if it's currently negative, incremented otherwise.) +;;; If it's incremented from -1 to 0, try to GC (maybe just a little.) +(defppclapfunction %unlock-gc-lock () +;; (sync) + (li imm0 (+ (target-nil-value) (target::kernel-global gc-inhibit-count))) + @again + (lrarx arg_y rzero imm0) + (cmpri cr1 arg_y -1) + (subi arg_z arg_y '1) + (bgt cr1 @store) + (addi arg_z arg_y '1) + @store + (strcx. arg_z rzero imm0) + (bne @again) + (bnelr cr1) + ;; The GC tried to run while it was inhibited. Unless something else + ;; has just inhibited it, it should be possible to GC now. + (li imm0 arch::gc-trap-function-immediate-gc) + (trlgei allocptr 0) + (blr)) + + + +(defppclapfunction %atomic-incf-node ((by arg_x) (node arg_y) (disp arg_z)) + (check-nargs 3) + (unbox-fixnum imm1 disp) + @again + (lrarx arg_z node imm1) + (add arg_z arg_z by) + (strcx. arg_z node imm1) + (bne- @again) + (isync) + (blr)) + +(defppclapfunction %atomic-incf-ptr ((ptr arg_z)) + (macptr-ptr imm1 ptr) + @again + (lrarx imm0 0 imm1) + (addi imm0 imm0 1) + (strcx. imm0 0 imm1) + (bne @again) + (isync) + (box-fixnum arg_z imm0) + (blr)) + +(defppclapfunction %atomic-incf-ptr-by ((ptr arg_y) (by arg_z)) + (macptr-ptr imm1 ptr) + (unbox-fixnum imm2 by) + @again + (lrarx imm0 0 imm1) + (add imm0 imm0 imm2) + (strcx. imm0 0 imm1) + (bne @again) + (isync) + (box-fixnum arg_z imm0) + (blr)) + +(defppclapfunction %atomic-decf-ptr ((ptr arg_z)) + (macptr-ptr imm1 ptr) + @again + (lrarx imm0 0 imm1) + (subi imm0 imm0 1) + (strcx. imm0 0 imm1) + (bne @again) + (isync) + (box-fixnum arg_z imm0) + (blr)) + +(defppclapfunction %atomic-decf-ptr-if-positive ((ptr arg_z)) + (macptr-ptr imm1 ptr) + @again + (lrarx imm0 0 imm1) + (cmpri cr1 imm0 0) + (subi imm0 imm0 1) + (beq @done) + (strcx. imm0 0 imm1) + (bne @again) + (isync) + (box-fixnum arg_z imm0) + (blr) + @done + (li imm1 target::reservation-discharge) + (box-fixnum arg_z imm0) + (strcx. rzero rzero imm1) + (blr)) + +(defppclapfunction %atomic-swap-ptr ((ptr arg_y) (newval arg_z)) + (sync) + (macptr-ptr imm1 ptr) + (unbox-fixnum imm2 arg_z) + @again + (lrarx imm0 0 imm1) + (strcx. imm2 0 imm1) + (bne @again) + (isync) + (box-fixnum arg_z imm0) + (blr)) + +;;; Try to store the fixnum NEWVAL at PTR, if and only if the old value +;;; was equal to OLDVAL. Return the old value +(defppclapfunction %ptr-store-conditional ((ptr arg_x) (expected-oldval arg_y) (newval arg_z)) + (macptr-ptr imm0 ptr) + (unbox-fixnum imm1 expected-oldval) + (unbox-fixnum imm2 newval) + @again + (lrarx imm3 0 imm0) + (cmpr imm3 imm1) + (bne- @done) + (strcx. imm2 0 imm0) + (bne- @again) + (isync) + (box-fixnum arg_z imm3) + (blr) + @done + (li imm0 target::reservation-discharge) + (box-fixnum arg_z imm3) + (strcx. rzero 0 imm0) + (blr)) + +(defppclapfunction %ptr-store-fixnum-conditional ((ptr arg_x) (expected-oldval arg_y) (newval arg_z)) + (let ((address imm0) + (actual-oldval imm1)) + (macptr-ptr address ptr) + @again + (lrarx actual-oldval 0 address) + (cmpr actual-oldval expected-oldval) + (bne- @done) + (strcx. newval 0 address) + (bne- @again) + (isync) + (mr arg_z actual-oldval) + (blr) + @done + (li address target::reservation-discharge) + (mr arg_z actual-oldval) + (strcx. rzero 0 address) + (blr))) + + + + +(defppclapfunction %macptr->dead-macptr ((macptr arg_z)) + (check-nargs 1) + (li imm0 target::subtag-dead-macptr) + (stb imm0 target::misc-subtag-offset macptr) + (blr)) + +(defppclapfunction %%apply-in-frame ((catch-count imm0) (srv temp0) (tsp-count imm0) (db-link imm0) + (parent arg_x) (function arg_y) (arglist arg_z)) + (check-nargs 7) + + ; Throw through catch-count catch frames + (lwz imm0 12 vsp) ; catch-count + (vpush parent) + (vpush function) + (vpush arglist) + (bla .SPnthrowvalues) + + ; Pop tsp-count TSP frames + (lwz tsp-count 16 vsp) + (cmpi cr0 tsp-count 0) + (b @test) +@loop + (subi tsp-count tsp-count '1) + (cmpi cr0 tsp-count 0) + (lwz tsp 0 tsp) +@test + (bne cr0 @loop) + + ; Pop dynamic bindings until we get to db-link + (lwz imm0 12 vsp) ; db-link + (lwz imm1 target::tcr.db-link target::rcontext) + (cmp cr0 imm0 imm1) + (beq cr0 @restore-regs) ; .SPunbind-to expects there to be something to do + (bla .SPunbind-to) + +@restore-regs + ; restore the saved registers from srv + (lwz srv 20 vsp) +@get0 + (svref imm0 1 srv) + (cmpwi cr0 imm0 (target-nil-value)) + (beq @get1) + (lwz save0 0 imm0) +@get1 + (svref imm0 2 srv) + (cmpwi cr0 imm0 (target-nil-value)) + (beq @get2) + (lwz save1 0 imm0) +@get2 + (svref imm0 3 srv) + (cmpwi cr0 imm0 (target-nil-value)) + (beq @get3) + (lwz save2 0 imm0) +@get3 + (svref imm0 4 srv) + (cmpwi cr0 imm0 (target-nil-value)) + (beq @get4) + (lwz save3 0 imm0) +@get4 + (svref imm0 5 srv) + (cmpwi cr0 imm0 (target-nil-value)) + (beq @get5) + (lwz save4 0 imm0) +@get5 + (svref imm0 6 srv) + (cmpwi cr0 imm0 (target-nil-value)) + (beq @get6) + (lwz save5 0 imm0) +@get6 + (svref imm0 7 srv) + (cmpwi cr0 imm0 (target-nil-value)) + (beq @get7) + (lwz save6 0 imm0) +@get7 + (svref imm0 8 srv) + (cmpwi cr0 imm0 (target-nil-value)) + (beq @got) + (lwz save7 0 imm0) +@got + + (vpop arg_z) ; arglist + (vpop temp0) ; function + (vpop parent) ; parent + (extract-lisptag imm0 parent) + (cmpi cr0 imm0 target::tag-fixnum) + (if (:cr0 :ne) + ; Parent is a fake-stack-frame. Make it real + (progn + (svref sp %fake-stack-frame.sp parent) + (stwu sp (- target::lisp-frame.size) sp) + (svref fn %fake-stack-frame.fn parent) + (stw fn target::lisp-frame.savefn sp) + (svref temp1 %fake-stack-frame.vsp parent) + (stw temp1 target::lisp-frame.savevsp sp) + (svref temp1 %fake-stack-frame.lr parent) + (extract-lisptag imm0 temp1) + (cmpi cr0 imm0 target::tag-fixnum) + (if (:cr0 :ne) + ;; must be a macptr encoding the actual link register + (macptr-ptr loc-pc temp1) + ;; Fixnum is offset from start of function vector + (progn + (svref temp2 0 fn) ; function vector + (unbox-fixnum temp1 temp1) + (add loc-pc temp2 temp1))) + (stw loc-pc target::lisp-frame.savelr sp)) + ;; Parent is a real stack frame + (mr sp parent)) + (set-nargs 0) + (bla .SPspreadargz) + (ba .SPtfuncallgen)) + +#+ppc32-target +;;; Easiest to do this in lap, to avoid consing bignums and/or +;;; multiple-value hair. +;;; Bang through code-vector until the end or a 0 (traceback table +;;; header) is found. Return high-half, low-half of last instruction +;;; and index where found. +(defppclapfunction %code-vector-last-instruction ((cv arg_z)) + (let ((previ imm0) + (nexti imm1) + (idx imm2) + (offset imm3) + (len imm4)) + (vector-length len cv len) + (li idx 0) + (cmpw cr0 idx len) + (li offset target::misc-data-offset) + (li nexti 0) + (b @test) + @loop + (mr previ nexti) + (lwzx nexti cv offset) + (cmpwi cr1 nexti 0) + (addi idx idx '1) + (cmpw cr0 idx len) + (addi offset offset '1) + (beq cr1 @done) + @test + (bne cr0 @loop) + (mr previ nexti) + @done + (digit-h temp0 previ) + (digit-l temp1 previ) + (subi idx idx '1) + (vpush temp0) + (vpush temp1) + (vpush idx) + (set-nargs 3) + (la temp0 '3 vsp) + (ba .SPvalues))) + +#+ppc64-target +(defun %code-vector-last-instruction (cv) + (do* ((i 1 (1+ i)) + (instr nil) + (n (uvsize cv))) + ((= i n) instr) + (declare (fixnum i n)) + (let* ((next (uvref cv i))) + (declare (type (unsigned-byte 32) next)) + (if (zerop next) + (return instr) + (setq instr next))))) + + + + +(defppclapfunction %%save-application ((flags arg_y) (fd arg_z)) + (unbox-fixnum imm0 flags) + (ori imm0 imm0 arch::gc-trap-function-save-application) + (unbox-fixnum imm1 fd) + (trlgei allocptr 0) + (blr)) + + + +(defppclapfunction %misc-address-fixnum ((misc-object arg_z)) + (check-nargs 1) + (la arg_z target::misc-data-offset misc-object) + (blr)) + + +#+ppc32-target +(defppclapfunction fudge-heap-pointer ((ptr arg_x) (subtype arg_y) (len arg_z)) + (check-nargs 3) + (macptr-ptr imm1 ptr) ; address in macptr + (addi imm0 imm1 9) ; 2 for delta + 7 for alignment + (clrrwi imm0 imm0 3) ; Clear low three bits to align + (subf imm1 imm1 imm0) ; imm1 = delta + (sth imm1 -2 imm0) ; save delta halfword + (unbox-fixnum imm1 subtype) ; subtype at low end of imm1 + (rlwimi imm1 len (- target::num-subtag-bits target::fixnum-shift) 0 (- 31 target::num-subtag-bits)) + (stw imm1 0 imm0) ; store subtype & length + (addi arg_z imm0 target::fulltag-misc) ; tag it, return it + (blr)) + +#+ppc64-target +(defppclapfunction fudge-heap-pointer ((ptr arg_x) (subtype arg_y) (len arg_z)) + (check-nargs 3) + (macptr-ptr imm1 ptr) ; address in macptr + (addi imm0 imm1 17) ; 2 for delta + 15 for alignment + (clrrdi imm0 imm0 4) ; Clear low four bits to align + (subf imm1 imm1 imm0) ; imm1 = delta + (sth imm1 -2 imm0) ; save delta halfword + (unbox-fixnum imm1 subtype) ; subtype at low end of imm1 + (sldi imm2 len (- target::num-subtag-bits target::fixnum-shift)) + (or imm1 imm2 imm1) + (std imm1 0 imm0) ; store subtype & length + (addi arg_z imm0 target::fulltag-misc) ; tag it, return it + (blr)) + +(defppclapfunction %%make-disposable ((ptr arg_y) (vector arg_z)) + (check-nargs 2) + (subi imm0 vector target::fulltag-misc) ; imm0 is addr = vect less tag + (lhz imm1 -2 imm0) ; get delta + (sub imm0 imm0 imm1) ; vector addr (less tag) - delta is orig addr + (str imm0 target::macptr.address ptr) + (blr)) + +#+ppc32-target +(defppclapfunction %vect-data-to-macptr ((vect arg_y) (ptr arg_z)) + ;; put address of vect data in macptr. For all vector types + ;; other than DOUBLE-FLOAT (or vectors thereof), the first byte + ;; of data is at PPC32::MISC-DATA-OFFSET; for the double-float + ;; types, it's at PPC32::MISC-DFLOAT-OFFSET. + (extract-subtag imm0 vect) + (cmpwi cr0 imm0 ppc32::subtag-double-float-vector) + (cmpwi cr1 imm0 ppc32::subtag-double-float) + (addi temp0 vect ppc32::misc-data-offset) + (beq cr0 @dfloat) + (beq cr1 @dfloat) + (stw temp0 ppc32::macptr.address arg_z) + (blr) + @dfloat + (addi temp0 vect ppc32::misc-dfloat-offset) + (stw temp0 ppc32::macptr.address arg_z) + (blr)) + +#+ppc64-target +(defppclapfunction %vect-data-to-macptr ((vect arg_y) (ptr arg_z)) + (la imm0 ppc64::misc-data-offset vect) + (std imm0 ppc64::macptr.address ptr) + (blr)) + +(defppclapfunction get-saved-register-values () + (vpush save0) + (vpush save1) + (vpush save2) + (vpush save3) + (vpush save4) + (vpush save5) + (vpush save6) + (vpush save7) + (la temp0 (* 8 target::node-size) vsp) + (set-nargs 8) + (ba .SPvalues)) + + +(defppclapfunction %current-db-link () + (ldr arg_z target::tcr.db-link target::rcontext) + (blr)) + +(defppclapfunction %no-thread-local-binding-marker () + (li arg_z target::subtag-no-thread-local-binding) + (blr)) + + +(defppclapfunction pending-user-interrupt () + (ref-global arg_z target::intflag) + ;; If another signal happens now, it will get ignored, same as if it happened + ;; before whatever signal is in arg_z. But then these are async signals, so + ;; who can be sure it didn't actually happen just before... + (set-global rzero target::intflag) + (blr)) + + +;;; Should be called with interrupts disabled. +(defppclapfunction %safe-get-ptr ((src arg_y) (dest arg_z)) + (check-nargs 2) + (macptr-ptr imm0 src) + (str imm0 target::tcr.safe-ref-address target::rcontext) + (ldr imm0 0 imm0) ; may fault + (str imm0 target::macptr.address dest) + (blr)) + + + +;;; r13 contains thread context on Linux/Darwin PPC64. +;;; That's maintained in r2 on LinuxPPC32, and not maintained +;;; in a GPR on DarwinPPC32 +(defppclapfunction %get-os-context () + #+ppc64-target (mr arg_z 13) + #+linuxppc32-target (mr arg_z 2) + #+darinppc32-target (mr arg_z 0) + (blr)) + +(defppclapfunction %check-deferred-gc () + (ldr imm0 target::tcr.flags target::rcontext) + (slri. imm0 imm0 (- (1- target::nbits-in-word) (+ arch::tcr-flag-bit-pending-suspend target::fixnumshift))) + (li arg_z nil) + (bgelr) + (uuo_interr arch::error-propagate-suspend rzero) + (li arg_z t) + (blr)) + +(defppclapfunction %%tcr-interrupt ((target arg_z)) + (check-nargs 1) + (uuo_interr arch::error-interrupt rzero) + (box-fixnum arg_z imm0) + (blr)) + +(defppclapfunction %suspend-tcr ((target arg_z)) + (check-nargs 1) + (uuo_interr arch::error-suspend rzero) + (ne0->boolean arg_z imm0 imm1) + (blr)) + +(defppclapfunction %suspend-other-threads () + (check-nargs 0) + (uuo_interr arch::error-suspend-all rzero) + (li arg_z nil) + (blr)) + +(defppclapfunction %resume-tcr ((target arg_z)) + (check-nargs 1) + (uuo_interr arch::error-resume rzero) + (ne0->boolean arg_z imm0 imm1) + (blr)) + +(defppclapfunction %resume-other-threads () + (check-nargs 0) + (uuo_interr arch::error-resume-all rzero) + (li arg_z nil) + (blr)) + +(defppclapfunction %kill-tcr ((target arg_z)) + (check-nargs 1) + (uuo_interr arch::error-kill rzero) + (ne0->boolean arg_z imm0 imm1) + (blr)) + +(defppclapfunction %atomic-pop-static-cons () + (li imm0 (+ (target-nil-value) (target::kernel-global static-conses))) + @again + (lrarx arg_z rzero imm0) + (cmpri arg_z (target-nil-value)) + (beq @lose) + (%cdr arg_y arg_z) + (strcx. arg_y rzero imm0) + (bne @again) + (li imm0 (+ (target-nil-value) (target::kernel-global free-static-conses))) + @decf + (lrarx imm1 rzero imm0) + (subi imm1 imm1 '1) + (strcx. imm1 rzero imm0) + (bne @decf) + (isync) + (blr) + @lose + (li imm0 target::reservation-discharge) + (strcx. rzero rzero imm0) + (blr)) + + + +(defppclapfunction %staticp ((x arg_z)) + (check-nargs 1) + (ref-global temp0 static-cons-area) + (ldr imm1 target::area.low temp0) + (sub imm0 x imm1) + (ldr imm1 target::area.ndnodes temp0) + (srri imm0 imm0 target::dnode-shift) + (li arg_z nil) + (sub imm1 imm1 imm0) + (cmplri imm1 0) + (la imm1 128 imm1) + (blelr) + (box-fixnum arg_z imm1) + (blr)) + +(defppclapfunction %static-inverse-cons ((n arg_z)) + (check-nargs 1) + (ref-global temp0 static-cons-area) + (la n '-128 n) + (ldr imm1 target::area.high temp0) + (sub imm1 imm1 n) + (sub imm1 imm1 n) + (la arg_z target::fulltag-cons imm1) + (blr)) + + +; end of ppc-misc.lisp Index: /branches/new-random/level-0/PPC/ppc-numbers.lisp =================================================================== --- /branches/new-random/level-0/PPC/ppc-numbers.lisp (revision 13309) +++ /branches/new-random/level-0/PPC/ppc-numbers.lisp (revision 13309) @@ -0,0 +1,444 @@ +;-*- Mode: Lisp; Package: CCL -*- +;;; +;;; Copyright (C) 2009 Clozure Associates +;;; Copyright (C) 1994-2001 Digitool, Inc +;;; This file is part of Clozure CL. +;;; +;;; Clozure CL is licensed under the terms of the Lisp Lesser GNU Public +;;; License , known as the LLGPL and distributed with Clozure CL as the +;;; file "LICENSE". The LLGPL consists of a preamble and the LGPL, +;;; which is distributed with Clozure CL as the file "LGPL". Where these +;;; conflict, the preamble takes precedence. +;;; +;;; Clozure CL is referenced in the preamble as the "LIBRARY." +;;; +;;; The LLGPL is also available online at +;;; http://opensource.franz.com/preamble.html + + + +(in-package "CCL") + +;(push (cons 'number-case 1) *fred-special-indent-alist*) do later + + + +(defppclapfunction %fixnum-signum ((number arg_z)) + (cmpri :cr0 number '0) + (li arg_z '0) + (beqlr :cr0) + (li arg_z '1) ; assume positive + (bgtlr :cr0) + (li arg_z '-1) + (blr)) + +; see %logcount (ppc-bignum.lisp) +(defppclapfunction %ilogcount ((number arg_z)) + (let ((arg imm0) + (shift imm1) + (temp imm2)) + (unbox-fixnum arg number) + (mr. shift arg) + (li arg_z 0) + (b @test) + @next + (la temp -1 shift) + (and. shift shift temp) + (la arg_z '1 arg_z) + @test + (bne @next) + (blr))) + +(defppclapfunction %iash ((number arg_y) (count arg_z)) + (unbox-fixnum imm1 count) + (unbox-fixnum imm0 number) + (neg. imm2 imm1) + (blt @left) + (srar imm0 imm0 imm2) + (box-fixnum arg_z imm0) + (blr) + @left + (slr arg_z number imm1) + (blr)) + +(defparameter *double-float-zero* 0.0d0) +(defparameter *short-float-zero* 0.0s0) + + +#+ppc32-target +(defppclapfunction %sfloat-hwords ((sfloat arg_z)) + (lwz imm0 ppc32::single-float.value sfloat) + (digit-h temp0 imm0) + (digit-l temp1 imm0) + (vpush temp0) + (vpush temp1) + (la temp0 8 vsp) + (set-nargs 2) + (ba .SPvalues)) + + +; (integer-length arg) = (- 32 (cntlz (if (>= arg 0) arg (lognot arg)))) +#+ppc32-target +(defppclapfunction %fixnum-intlen ((number arg_z)) + (unbox-fixnum imm0 arg_z) + (cntlzw. imm1 imm0) ; testing result of cntlzw? - ah no zeros if neg + (bne @nonneg) + (not imm1 imm0) + (cntlzw imm1 imm1) + @nonneg + (subfic imm1 imm1 32) + (box-fixnum arg_z imm1) + (blr)) + +#+ppc64-target +(defppclapfunction %fixnum-intlen ((number arg_z)) + (unbox-fixnum imm0 arg_z) + (cntlzd. imm1 imm0) + (bne @nonneg) + (not imm1 imm0) + (cntlzd imm1 imm1) + @nonneg + (subfic imm1 imm1 64) + (box-fixnum arg_z imm1) + (blr)) + + + + +;;; Caller guarantees that result fits in a fixnum. +#+ppc32-target +(defppclapfunction %truncate-double-float->fixnum ((arg arg_z)) + (get-double-float fp0 arg) + (fctiwz fp0 fp0) + (stwu tsp -16 tsp) + (stw tsp 4 tsp) + (stfd fp0 8 tsp) + (lwz imm0 (+ 8 4) tsp) + (lwz tsp 0 tsp) + (box-fixnum arg_z imm0) + (blr)) + +#+ppc64-target +(defppclapfunction %truncate-double-float->fixnum ((arg arg_z)) + (get-double-float fp0 arg) + (fctidz fp0 fp0) + (stdu tsp -32 tsp) + (std tsp 8 tsp) + (stfd fp0 16 tsp) + (ld imm0 16 tsp) + (la tsp 32 tsp) + (box-fixnum arg_z imm0) + (blr)) + +#+ppc32-target +(defppclapfunction %truncate-short-float->fixnum ((arg arg_z)) + (get-single-float fp0 arg) + (fctiwz fp0 fp0) + (stwu tsp -16 tsp) + (stw tsp 4 tsp) + (stfd fp0 8 tsp) + (lwz imm0 (+ 8 4) tsp) + (lwz tsp 0 tsp) + (box-fixnum arg_z imm0) + (blr)) + +#+ppc64-target +(defppclapfunction %truncate-short-float->fixnum ((arg arg_z)) + (get-single-float fp0 arg) + (fctidz fp0 fp0) + (stdu tsp -32 tsp) + (std tsp 8 tsp) + (stfd fp0 16 tsp) + (ld imm0 16 tsp) + (la tsp 32 tsp) + (box-fixnum arg_z imm0) + (blr)) + +;;; DOES round to even +#+ppc32-target +(defppclapfunction %round-nearest-double-float->fixnum ((arg arg_z)) + (get-double-float fp0 arg) + (fctiw fp0 fp0) + (stwu tsp -16 tsp) + (stw tsp 4 tsp) + (stfd fp0 8 tsp) + (lwz imm0 (+ 8 4) tsp) + (lwz tsp 0 tsp) + (box-fixnum arg_z imm0) + (blr)) + +#+ppc64-target +(defppclapfunction %round-nearest-double-float->fixnum ((arg arg_z)) + (get-double-float fp0 arg) + (fctid fp0 fp0) + (stdu tsp -32 tsp) + (std tsp 8 tsp) + (stfd fp0 16 tsp) + (ld imm0 16 tsp) + (la tsp 32 tsp) + (box-fixnum arg_z imm0) + (blr)) + +#+ppc32-target +(defppclapfunction %round-nearest-short-float->fixnum ((arg arg_z)) + (get-single-float fp0 arg) + (fctiw fp0 fp0) + (stwu tsp -16 tsp) + (stw tsp 4 tsp) + (stfd fp0 8 tsp) + (lwz imm0 (+ 8 4) tsp) + (lwz tsp 0 tsp) + (box-fixnum arg_z imm0) + (blr)) + +#+ppc64-target +(defppclapfunction %round-nearest-short-float->fixnum ((arg arg_z)) + (get-single-float fp0 arg) + (fctid fp0 fp0) + (stdu tsp -32 tsp) + (std tsp 8 tsp) + (stfd fp0 16 tsp) + (ld imm0 16 tsp) + (la tsp 32 tsp) + (box-fixnum arg_z imm0) + (blr)) + + + + +;;;; maybe this could be smarter but frankly scarlett I dont give a damn +#+ppc32-target +(defppclapfunction %fixnum-truncate ((dividend arg_y) (divisor arg_z)) + (let ((unboxed-quotient imm0) + (unboxed-dividend imm1) + (unboxed-divisor imm2) + (unboxed-product imm3) + (product temp0) + (boxed-quotient temp1) + (remainder temp2)) + (unbox-fixnum unboxed-dividend dividend) + (unbox-fixnum unboxed-divisor divisor) + (divwo. unboxed-quotient unboxed-dividend unboxed-divisor) ; set OV if divisor = 0 + (box-fixnum boxed-quotient unboxed-quotient) + (mullw unboxed-product unboxed-quotient unboxed-divisor) + (bns+ @ok) + (mtxer rzero) + (save-lisp-context) + (set-nargs 3) + (load-constant arg_x truncate) + (call-symbol divide-by-zero-error) + @not-0 + @ok + (subf imm0 unboxed-product unboxed-dividend) + (vpush boxed-quotient) + (box-fixnum remainder imm0) + (vpush remainder) + (set-nargs 2) + (la temp0 8 vsp) + (ba .SPvalues))) + +#+ppc64-target +(defppclapfunction %fixnum-truncate ((dividend arg_y) (divisor arg_z)) + (let ((unboxed-quotient imm0) + (unboxed-dividend imm1) + (unboxed-divisor imm2) + (unboxed-product imm3) + (product temp0) + (boxed-quotient temp1) + (remainder temp2)) + (unbox-fixnum unboxed-dividend dividend) + (unbox-fixnum unboxed-divisor divisor) + (divdo. unboxed-quotient unboxed-dividend unboxed-divisor) ; set OV if divisor = 0 + (box-fixnum boxed-quotient unboxed-quotient) + (mulld unboxed-product unboxed-quotient unboxed-divisor) + (bns+ @ok) + (mtxer rzero) + (save-lisp-context) + (set-nargs 3) + (load-constant arg_x truncate) + (call-symbol divide-by-zero-error) + @not-0 + @ok + (subf imm0 unboxed-product unboxed-dividend) + (vpush boxed-quotient) + (box-fixnum remainder imm0) + (vpush remainder) + (set-nargs 2) + (la temp0 '2 vsp) + (ba .SPvalues))) + + +(defppclapfunction called-for-mv-p () + (ref-global imm0 ret1valaddr) + (ldr imm1 target::lisp-frame.savelr sp) + (eq->boolean arg_z imm0 imm1 imm0) + (blr)) + + + + + + + + +#| +Date: Mon, 3 Feb 1997 10:04:08 -0500 +To: info-mcl@digitool.com, wineberg@franz.scs.carleton.ca +From: dds@flavors.com (Duncan Smith) +Subject: Re: More info on the random number generator +Sender: owner-info-mcl@digitool.com +Precedence: bulk + +The generator is a Linear Congruential Generator: + + X[n+1] = (aX[n] + c) mod m + +where: a = 16807 (Park&Miller recommend 48271) + c = 0 + m = 2^31 - 1 + +See: Knuth, Seminumerical Algorithms (Volume 2), Chapter 3. + +The period is: 2^31 - 2 (zero is excluded). + +What makes this generator so simple is that multiplication and addition mod +2^n-1 is easy. See Knuth Ch. 4.3.2 (2nd Ed. p 272). + + ab mod m = ... + +If m = 2^n-1 + u = ab mod 2^n + v = floor( ab / 2^n ) + + ab mod m = u + v : u+v < 2^n + ab mod m = ((u + v) mod 2^n) + 1 : u+v >= 2^n + +What we do is use 2b and 2^n so we can do arithemetic mod 2^32 instead of +2^31. This reduces the whole generator to 5 instructions on the 680x0 or +80x86, and 8 on the 60x. + +-Duncan + +|# +; Use the two fixnums in state to generate a random fixnum >= 0 and < 65536 +; Scramble those fixnums up a bit. + +#+ppc32-target +(defppclapfunction %next-random-pair ((high arg_y) (low arg_z)) + (slwi imm0 high (- 16 ppc32::fixnumshift)) + (rlwimi imm0 low (- 32 ppc32::fixnumshift) 16 31) + (lwi imm1 48271) + (clrlwi imm0 imm0 1) + (mullw imm0 imm1 imm0) + (clrrwi arg_y imm0 16 ) + (srwi arg_y arg_y (- 16 ppc32::fixnumshift)) + (clrlslwi arg_z imm0 16 ppc32::fixnumshift) + (mr temp0 vsp) + (vpush arg_y) + (vpush arg_z) + (set-nargs 2) + (ba .SPvalues)) + + + + + + + + + +;;; n1 and n2 must be positive (esp non zero) +#+ppc32-target +(defppclapfunction %fixnum-gcd ((n1 arg_y)(n2 arg_z)) + (let ((temp imm0) + (u imm1) + (v imm2) + (ut0 imm3) + (vt0 imm4)) + (unbox-fixnum u n1) + (unbox-fixnum v n2) + (neg temp u) + (and temp temp u) + (cntlzw ut0 temp) + (subfic ut0 ut0 31) + (neg temp v) + (and temp temp v) + (cntlzw vt0 temp) + (subfic vt0 vt0 31) + (cmpw cr2 ut0 vt0) + (srw u u ut0) + (srw v v vt0) + (addi ut0 ut0 ppc32::fixnum-shift) + (addi vt0 vt0 ppc32::fixnum-shift) + @loop + (cmpw cr0 u v) + (slw arg_z u ut0) + (bgt cr0 @u>v) + (blt cr0 @uv + (sub u u v) + @shiftu + (andi. temp u (ash 1 1)) + (srwi u u 1) + (beq cr0 @shiftu) + (b @loop) + @uv) + (blt cr0 @uv + (sub u u v) + @shiftu + (andi. temp u (ash 1 1)) + (srdi u u 1) + (beq cr0 @shiftu) + (b @loop) + @usymptr ((sym arg_z)) + #+ppc32-target + (progn + (cmpwi cr0 arg_z (target-nil-value)) + (if (:cr0 :eq) + (progn + (li arg_z (+ ppc32::nilsym-offset (target-nil-value))) + (blr)))) + (trap-unless-typecode= arg_z target::subtag-symbol) + (blr)) + +;;; Traps unless symptr is a symbol; on PPC32, returns NIL if symptr +;;; is NILSYM. +(defppclapfunction %symptr->symbol ((symptr arg_z)) + #+ppc32-target + (progn + (li imm1 (+ ppc32::nilsym-offset (target-nil-value))) + (cmpw cr0 imm1 symptr) + (if (:cr0 :eq) + (progn + (li arg_z nil) + (blr)))) + (trap-unless-typecode= symptr target::subtag-symbol imm0) + (blr)) + +(defppclapfunction %symptr-value ((symptr arg_z)) + (ba .SPspecref)) + +(defppclapfunction %set-symptr-value ((symptr arg_y) (val arg_z)) + (ba .SPspecset)) + +(defppclapfunction %symptr-binding-address ((symptr arg_z)) + (ldr imm3 target::symbol.binding-index symptr) + (ldr imm2 target::tcr.tlb-limit target::rcontext) + (ldr imm4 target::tcr.tlb-pointer target::rcontext) + (cmplr imm3 imm2) + (bge @sym) + (ldrx temp0 imm4 imm3) + (cmpdi temp0 target::subtag-no-thread-local-binding) + (slri imm3 imm3 target::fixnumshift) + (beq @sym) + (vpush imm4) + (vpush imm3) + (set-nargs 2) + (la temp0 '2 vsp) + (ba .SPvalues) + @sym + (li arg_y '#.target::symbol.vcell) + (vpush arg_z) + (vpush arg_y) + (set-nargs 2) + (la temp0 '2 vsp) + (ba .SPvalues)) + +(defppclapfunction %tcr-binding-location ((tcr arg_y) (sym arg_z)) + (ldr imm3 target::symbol.binding-index sym) + (ldr imm2 target::tcr.tlb-limit tcr) + (ldr imm4 target::tcr.tlb-pointer tcr) + (li arg_z nil) + (cmplr imm3 imm2) + (bgelr) + (ldrx temp0 imm4 imm3) + (cmpri temp0 target::subtag-no-thread-local-binding) + (beqlr) + (add arg_z imm4 imm3) + (blr)) + + +(defppclapfunction %pname-hash ((str arg_y) (len arg_z)) + (let ((nextw imm1) + (accum imm0) + (offset imm2)) + (cmpwi cr0 len 0) + (li offset target::misc-data-offset) + (li accum 0) + (beqlr- cr0) + @loop + (cmpri cr1 len '1) + (subi len len '1) + (lwzx nextw str offset) + (addi offset offset 4) + (rotlwi accum accum 5) + (xor accum accum nextw) + (bne cr1 @loop) + (slri accum accum 5) + (srri arg_z accum (- 5 target::fixnumshift)) + (blr))) + +(defppclapfunction %string-hash ((start arg_x) (str arg_y) (len arg_z)) + (let ((nextw imm1) + (accum imm0) + (offset imm2)) + (cmpwi cr0 len 0) + #+32-bit-target + (la offset target::misc-data-offset start) + #+64-bit-target + (progn + (srwi offset start 1) + (la offset target::misc-data-offset offset)) + (li accum 0) + (beqlr- cr0) + @loop + (cmpri cr1 len '1) + (subi len len '1) + (lwzx nextw str offset) + (addi offset offset 4) + (rotlwi accum accum 5) + (xor accum accum nextw) + (bne cr1 @loop) + (slri accum accum 5) + (srri arg_z accum (- 5 target::fixnumshift)) + (blr))) Index: /branches/new-random/level-0/PPC/ppc-utils.lisp =================================================================== --- /branches/new-random/level-0/PPC/ppc-utils.lisp (revision 13309) +++ /branches/new-random/level-0/PPC/ppc-utils.lisp (revision 13309) @@ -0,0 +1,692 @@ +;;; -*- Mode: Lisp; Package: CCL; -*- +;;; +;;; Copyright (C) 2009 Clozure Associates +;;; Copyright (C) 1994-2001 Digitool, Inc +;;; This file is part of Clozure CL. +;;; +;;; Clozure CL is licensed under the terms of the Lisp Lesser GNU Public +;;; License , known as the LLGPL and distributed with Clozure CL as the +;;; file "LICENSE". The LLGPL consists of a preamble and the LGPL, +;;; which is distributed with Clozure CL as the file "LGPL". Where these +;;; conflict, the preamble takes precedence. +;;; +;;; Clozure CL is referenced in the preamble as the "LIBRARY." +;;; +;;; The LLGPL is also available online at +;;; http://opensource.franz.com/preamble.html + + +(in-package "CCL") + +#+ppc32-target +(defppclapfunction %address-of ((arg arg_z)) + ;; %address-of a fixnum is a fixnum, just for spite. + ;; %address-of anything else is the address of that thing as an integer. + (clrlwi. imm0 arg (- 32 ppc32::nlisptagbits)) + (beqlr cr0) + (mr imm0 arg_z) + ;; set cr0_eq if result fits in a fixnum + (clrrwi. imm1 imm0 (- ppc32::least-significant-bit ppc32::nfixnumtagbits)) + (box-fixnum arg_z imm0) ; assume it did + (beqlr+ cr0) ; else arg_z tagged ok, but missing bits + (ba .SPmakeu32) ; put all bits in bignum. +) + +#+ppc64-target +(defppclapfunction %address-of ((arg arg_z)) + ;; %address-of a fixnum is a fixnum, just for spite. + ;; %address-of anything else is the address of that thing as an integer. + (clrldi. imm0 arg (- 64 ppc64::nlisptagbits)) + (beqlr cr0) + (mr imm0 arg_z) + ;; set cr0_eq if result fits in a fixnum + (clrrdi. imm1 imm0 (- ppc64::least-significant-bit ppc64::nfixnumtagbits)) + (box-fixnum arg_z imm0) ; assume it did + (beqlr+ cr0) ; else arg_z tagged ok, but missing bits + (ba .SPmakeu64) ; put all bits in bignum. +) + +;;; "areas" are fixnum-tagged and, for the most part, so are their +;;; contents. + +;;; The nilreg-relative global all-areas is a doubly-linked-list header +;;; that describes nothing. Its successor describes the current/active +;;; dynamic heap. Return a fixnum which "points to" that area, after +;;; ensuring that the "active" pointers associated with the current thread's +;;; stacks are correct. + + + +(defppclapfunction %normalize-areas () + (let ((address imm0) + (temp imm2)) + + ; update active pointer for tsp area. + (ldr address target::tcr.ts-area target::rcontext) + (str tsp target::area.active address) + + ;; Update active pointer for vsp area. + (ldr address target::tcr.vs-area target::rcontext) + (str vsp target::area.active address) + + ; Update active pointer for SP area + (ldr arg_z target::tcr.cs-area target::rcontext) + (str sp target::area.active arg_z) + + + (ref-global arg_z all-areas) + (ldr arg_z target::area.succ arg_z) + + (blr))) + +(defppclapfunction %active-dynamic-area () + (ref-global arg_z all-areas) + (ldr arg_z target::area.succ arg_z) + (blr)) + + +(defppclapfunction %object-in-stack-area-p ((object arg_y) (area arg_z)) + (ldr imm0 target::area.active area) + (cmplr cr0 object imm0) + (ldr imm1 target::area.high area) + (cmplr cr1 object imm1) + (li arg_z nil) + (bltlr cr0) + (bgelr cr1) + (la arg_z target::t-offset arg_z) + (blr)) + +(defppclapfunction %object-in-heap-area-p ((object arg_y) (area arg_z)) + (ldr imm0 target::area.low area) + (cmplr cr0 object imm0) + (ldr imm1 target::area.active area) + (cmplr cr1 object imm1) + (li arg_z nil) + (bltlr cr0) + (bgelr cr1) + (la arg_z target::t-offset arg_z) + (blr)) + + +#+ppc32-target +(defppclapfunction walk-static-area ((a arg_y) (f arg_z)) + (let ((fun save0) + (obj save1) + (limit save2) + (header imm0) + (tag imm1) + (subtag imm2) + (bytes imm3) + (elements imm0)) + (save-lisp-context) + (:regsave limit 0) + (vpush fun) + (vpush obj) + (vpush limit) + (mr fun f) + (lwz limit ppc32::area.active a) + (lwz obj ppc32::area.low a) + (b @test) + @loop + (lwz header 0 obj) + (extract-fulltag tag header) + (cmpwi cr0 tag ppc32::fulltag-immheader) + (cmpwi cr1 tag ppc32::fulltag-nodeheader) + (beq cr0 @misc) + (beq cr1 @misc) + (la arg_z ppc32::fulltag-cons obj) + (set-nargs 1) + (mr temp0 fun) + (bla .SPFuncall) + (la obj ppc32::cons.size obj) + (b @test) + @misc + (la arg_z ppc32::fulltag-misc obj) + (set-nargs 1) + (mr temp0 fun) + (bla .SPFuncall) + (lwz header 0 obj) + (extract-fulltag tag header) + (cmpwi cr1 tag ppc32::fulltag-nodeheader) + (clrlwi subtag header (- 32 ppc32::num-subtag-bits)) + (cmpwi cr2 subtag ppc32::max-32-bit-ivector-subtag) + (cmpwi cr3 subtag ppc32::max-8-bit-ivector-subtag) + (cmpwi cr4 subtag ppc32::max-16-bit-ivector-subtag) + (cmpwi cr5 subtag ppc32::subtag-double-float-vector) + (header-size elements header) + (slwi bytes elements 2) + (beq cr1 @bump) + (ble cr2 @bump) + (mr bytes elements) + (ble cr3 @bump) + (slwi bytes elements 1) + (ble cr4 @bump) + (slwi bytes elements 3) + (beq cr5 @bump) + (la elements 7 elements) + (srwi bytes elements 3) + @bump + (la bytes (+ 4 7) bytes) + (clrrwi bytes bytes 3) + (add obj obj bytes) + @test + (cmplw :cr0 obj limit) + (blt cr0 @loop) + (vpop limit) + (vpop obj) + (vpop fun) + (restore-full-lisp-context) + (blr))) + +#+ppc64-target +(defppclapfunction walk-static-area ((a arg_y) (f arg_z)) + (let ((fun save0) + (obj save1) + (limit save2) + (header imm0) + (tag imm1) + (subtag imm2) + (bytes imm3) + (elements imm0)) + (save-lisp-context) + (:regsave limit 0) + (vpush fun) + (vpush obj) + (vpush limit) + (mr fun f) + (ld limit ppc64::area.active a) + (ld obj ppc64::area.low a) + (b @test) + @loop + (ld header 0 obj) + (extract-lowtag tag header) + (cmpri cr0 tag ppc64::lowtag-immheader) + (cmpri cr1 tag ppc64::lowtag-nodeheader) + (beq cr0 @misc) + (beq cr1 @misc) + (la arg_z ppc64::fulltag-cons obj) + (set-nargs 1) + (mr temp0 fun) + (bla .SPFuncall) + (la obj ppc64::cons.size obj) + (b @test) + @misc + (la arg_z ppc64::fulltag-misc obj) + (set-nargs 1) + (mr temp0 fun) + (bla .SPFuncall) + (ldr header 0 obj) + (extract-lowtag tag header) + (extract-fulltag subtag header) + (cmpri cr1 tag ppc64::lowtag-nodeheader) + (extract-lowbyte tag header) + (cmpri cr2 subtag ppc64::ivector-class-64-bit) + (cmpri cr3 subtag ppc64::ivector-class-8-bit) + (cmpri cr4 subtag ppc64::ivector-class-32-bit) + (cmpri cr5 tag ppc64::subtag-bit-vector) + (header-size elements header) + (sldi bytes elements 3) + (beq cr1 @bump) + (beq cr2 @bump) + (mr bytes elements) + (beq cr3 @bump) + (sldi bytes elements 2) + (beq cr4 @bump) + (sldi bytes elements 1) + (bne cr5 @bump) + (la elements 7 elements) + (srdi bytes elements 3) + @bump + (la bytes (+ 8 15) bytes) + (clrrdi bytes bytes 4) + (add obj obj bytes) + @test + (cmpld :cr0 obj limit) + (blt cr0 @loop) + (vpop limit) + (vpop obj) + (vpop fun) + (restore-full-lisp-context) + (blr))) + +;;; This walks the active "dynamic" area. Objects might be moving around +;;; while we're doing this, so we have to be a lot more careful than we +;;; are when walking a static area. +;;; There's the vague notion that we can't take an interrupt when +;;; "initptr" doesn't equal "freeptr", though what kind of hooks into a +;;; preemptive scheduler we'd need to enforce this is unclear. We use +;;; initptr as an untagged pointer here (and set it to freeptr when we've +;;; got a tagged pointer to the current object.) +;;; There are a couple of approaches to termination: +;;; a) Allocate a "sentinel" cons, and terminate when we run into it. +;;; b) Check the area limit (which is changing if we're consing) and +;;; terminate when we hit it. +;;; (b) loses if the function conses. (a) conses. I can't think of anything +;;; better than (a). +;;; This, of course, assumes that any GC we're doing does in-place compaction +;;; (or at least preserves the relative order of objects in the heap.) + +#+ppc32-target +(defppclapfunction %walk-dynamic-area ((a arg_y) (f arg_z)) + (let ((fun save0) + (obj save1) + (sentinel save2) + (header imm0) + (tag imm1) + (subtag imm2) + (bytes imm3) + (elements imm4)) + (save-lisp-context) + (:regsave sentinel 0) + (vpush fun) + (vpush obj) + (vpush sentinel) + (ref-global imm0 tenured-area) + (cmpwi cr0 imm0 0) + (li allocbase #xfff8) + (la allocptr (- ppc32::fulltag-cons ppc32::cons.size) allocptr) + (twllt allocptr allocbase) + (mr sentinel allocptr) + (clrrwi allocptr allocptr ppc32::ntagbits) + (mr fun f) + (if :ne + (mr a imm0)) + (lwz imm5 ppc32::area.low a) + @loop + (lwz header 0 imm5) + (extract-fulltag tag header) + (cmpwi cr0 tag ppc32::fulltag-immheader) + (cmpwi cr1 tag ppc32::fulltag-nodeheader) + (beq cr0 @misc) + (beq cr1 @misc) + (la obj ppc32::fulltag-cons imm5) + (cmpw cr0 obj sentinel) + (mr arg_z obj) + (set-nargs 1) + (mr temp0 fun) + (beq cr0 @done) + (bla .SPfuncall) + (la imm5 (- ppc32::cons.size ppc32::fulltag-cons) obj) + (b @loop) + @misc + (la obj ppc32::fulltag-misc imm5) + (mr arg_z obj) + (set-nargs 1) + (mr temp0 fun) + (bla .SPFuncall) + (getvheader header obj) + (extract-fulltag tag header) + (cmpwi cr1 tag ppc32::fulltag-nodeheader) + (cmpwi cr7 tag ppc32::fulltag-immheader) + (clrlwi subtag header (- 32 ppc32::num-subtag-bits)) + (cmpwi cr2 subtag ppc32::max-32-bit-ivector-subtag) + (cmpwi cr3 subtag ppc32::max-8-bit-ivector-subtag) + (cmpwi cr4 subtag ppc32::max-16-bit-ivector-subtag) + (cmpwi cr5 subtag ppc32::subtag-double-float-vector) + (header-size elements header) + (slwi bytes elements 2) + (beq cr1 @bump) + (if (:cr7 :ne) + (twle 0 0)) + (ble cr2 @bump) + (mr bytes elements) + (ble cr3 @bump) + (slwi bytes elements 1) + (ble cr4 @bump) + (slwi bytes elements 3) + (beq cr5 @bump) + (la elements 7 elements) + (srwi bytes elements 3) + @bump + (la bytes (+ 4 7) bytes) + (clrrwi bytes bytes 3) + (subi imm5 obj ppc32::fulltag-misc) + (add imm5 imm5 bytes) + (cmpw cr0 imm5 sentinel) + (blt cr0 @loop) + (uuo_interr 0 0) + (b @loop) + @done + (li arg_z nil) + (vpop sentinel) + (vpop obj) + (vpop fun) + (restore-full-lisp-context) + (blr))) + +#+ppc64-target +(defppclapfunction %walk-dynamic-area ((a arg_y) (f arg_z)) + (let ((fun save0) + (obj save1) + (sentinel save2) + (header imm0) + (tag imm1) + (subtag imm2) + (bytes imm3) + (elements imm4)) + (save-lisp-context) + (:regsave sentinel 0) + (vpush fun) + (vpush obj) + (vpush sentinel) + (ref-global imm0 tenured-area) + (cmpdi cr0 imm0 0) + (lwi allocbase #x8000) + (sldi allocbase allocbase 32) + (subi allocbase allocbase 16) + (la allocptr (- ppc64::fulltag-cons ppc64::cons.size) allocptr) + (tdlt allocptr allocbase) + (mr sentinel allocptr) + (clrrdi allocptr allocptr ppc64::ntagbits) + (mr fun f) + (if :ne + (mr a imm0)) + (ld imm5 ppc64::area.low a) + @loop + (ld header 0 imm5) + (extract-lowtag tag header) + (cmpdi cr0 tag ppc64::lowtag-immheader) + (cmpdi cr1 tag ppc64::lowtag-nodeheader) + (beq cr0 @misc) + (beq cr1 @misc) + (la obj ppc64::fulltag-cons imm5) + (cmpd cr0 obj sentinel) + (mr arg_z obj) + (set-nargs 1) + (mr temp0 fun) + (beq cr0 @done) + (bla .SPfuncall) + (la imm5 (- ppc64::cons.size ppc64::fulltag-cons) obj) + (b @loop) + @misc + (la obj ppc64::fulltag-misc imm5) + (mr arg_z obj) + (set-nargs 1) + (mr temp0 fun) + (bla .SPFuncall) + (getvheader header obj) + (extract-lowtag tag header) + (extract-fulltag subtag header) + (cmpdi cr1 tag ppc64::lowtag-nodeheader) + (extract-lowbyte tag header) + (cmpri cr2 subtag ppc64::ivector-class-64-bit) + (cmpri cr3 subtag ppc64::ivector-class-8-bit) + (cmpri cr4 subtag ppc64::ivector-class-32-bit) + (cmpri cr5 tag ppc64::subtag-bit-vector) + (header-size elements header) + (sldi bytes elements 3) + (beq cr1 @bump) + (beq cr2 @bump) + (mr bytes elements) + (beq cr3 @bump) + (sldi bytes elements 2) + (beq cr4 @bump) + (sldi bytes elements 1) + (bne cr5 @bump) + (la elements 7 elements) + (srdi bytes elements 3) + @bump + (la bytes (+ 8 15) bytes) + (clrrdi bytes bytes 4) + (subi imm5 obj ppc64::fulltag-misc) + (add imm5 imm5 bytes) + (b @loop) + @done + (li arg_z nil) + (vpop sentinel) + (vpop obj) + (vpop fun) + (restore-full-lisp-context) + (blr))) + +(defun walk-dynamic-area (area func) + (with-other-threads-suspended + (%walk-dynamic-area area func))) + + + +(defppclapfunction %class-of-instance ((i arg_z)) + (svref arg_z instance.class-wrapper i) + (svref arg_z %wrapper-class arg_z) + (blr)) + +(defppclapfunction class-of ((x arg_z)) + (check-nargs 1) + (extract-fulltag imm0 x) + (cmpri imm0 target::fulltag-misc) + (beq @misc) + (extract-lowbyte imm0 x) + (b @done) + @misc + (extract-subtag imm0 x) + @done + (slri imm0 imm0 target::word-shift) + (ldr temp1 '*class-table* nfn) + (addi imm0 imm0 target::misc-data-offset) + (ldr temp1 target::symbol.vcell temp1) + (ldrx temp0 temp1 imm0) ; get entry from table + (cmpri cr0 temp0 nil) + (beq @bad) + ;; functionp? + (extract-typecode imm1 temp0) + (cmpri imm1 target::subtag-function) + (bne @ret) ; not function - return entry + ;; else jump to the fn + (mr nfn temp0) + (ldr temp0 target::misc-data-offset temp0) + (SET-NARGS 1) + (mtctr temp0) + (bctr) + @bad + (ldr fname 'no-class-error nfn) + (ba .spjmpsym) + @ret + (mr arg_z temp0) ; return frob from table + (blr)) + +(defppclapfunction full-gccount () + (ref-global arg_z tenured-area) + (cmpri cr0 arg_z 0) + (if :eq + (ref-global arg_z gc-count) + (ldr arg_z target::area.gc-count arg_z)) + (blr)) + + +(defppclapfunction gc () + (check-nargs 0) + (li imm0 arch::gc-trap-function-gc) + (trlgei allocptr 0) + (li arg_z (target-nil-value)) + (blr)) + + +(defppclapfunction egc ((arg arg_z)) + "Enable the EGC if arg is non-nil, disables the EGC otherwise. Return +the previous enabled status. Although this function is thread-safe (in +the sense that calls to it are serialized), it doesn't make a whole lot +of sense to be turning the EGC on and off from multiple threads ..." + (check-nargs 1) + (subi imm1 arg nil) + (li imm0 arch::gc-trap-function-egc-control) + (trlgei allocptr 0) + (blr)) + + + +(defppclapfunction %configure-egc ((e0size arg_x) + (e1size arg_y) + (e2size arg_z)) + (check-nargs 3) + (li imm0 arch::gc-trap-function-configure-egc) + (trlgei allocptr 0) + (blr)) + +(defppclapfunction purify () + (li imm0 arch::gc-trap-function-purify) + (trlgei allocptr 0) + (li arg_z nil) + (blr)) + + +(defppclapfunction impurify () + (li imm0 arch::gc-trap-function-impurify) + (trlgei allocptr 0) + (li arg_z nil) + (blr)) + +(defppclapfunction lisp-heap-gc-threshold () + "Return the value of the kernel variable that specifies the amount +of free space to leave in the heap after full GC." + (check-nargs 0) + (li imm0 arch::gc-trap-function-get-lisp-heap-threshold) + (trlgei allocptr 0) + #+ppc32-target + (ba .SPmakeu32) + #+ppc64-target + (ba .SPmakeu64)) + +(defppclapfunction set-lisp-heap-gc-threshold ((new arg_z)) + "Set the value of the kernel variable that specifies the amount of free +space to leave in the heap after full GC to new-value, which should be a +non-negative fixnum. Returns the value of that kernel variable (which may +be somewhat larger than what was specified)." + (check-nargs 1) + (mflr loc-pc) + #+ppc32-target + (bla .SPgetu32) + #+ppc64-target + (bla .SPgetu64) + (mtlr loc-pc) + (mr imm1 imm0) + (li imm0 arch::gc-trap-function-set-lisp-heap-threshold) + (trlgei allocptr 0) + #+ppc32-target + (ba .SPmakeu32) + #+ppc64-target + (ba .SPmakeu64)) + + +(defppclapfunction use-lisp-heap-gc-threshold () + "Try to grow or shrink lisp's heap space, so that the free space is(approximately) equal to the current heap threshold. Return NIL" + (check-nargs 0) + (li imm0 arch::gc-trap-function-use-lisp-heap-threshold) + (trlgei allocptr 0) + (li arg_z nil) + (blr)) + + +(defppclapfunction freeze () + "Do a full GC, then consider all heap-allocated objects which survive to be non-relocatable." + (check-nargs 0) + (li imm0 arch::gc-trap-function-freeze) + (trlgei allocptr 0) + #+64-bit-target + (ba .SPmakeu64) + #+32-bit-target + (ba .SPmakeu32)) + +(defppclapfunction flash-freeze () + "Like FREEZE, but don't GC first." + (check-nargs 0) + (li imm0 arch::gc-trap-function-flash-freeze) + (trlgei allocptr 0) + #+64-bit-target + (ba .SPmakeu64) + #+32-bit-target + (ba .SPmakeu32)) + +(defun %watch (uvector) + (declare (ignore uvector)) + (error "watching objects not supported on PPC yet")) + +(defun %unwatch (watched new) + (declare (ignore watched new)) + (error "watching objects not supported on PPC yet")) + +;;; Make a list. This can be faster than doing so by doing CONS +;;; repeatedly, since the latter strategy might triger the GC several +;;; times if N is large. +(defppclapfunction %allocate-list ((initial-element arg_y) (nconses arg_z)) + (check-nargs 2) + (save-lisp-context) + (uuo_interr arch::error-allocate-list rzero) + (vpush arg_z) + (vpush arg_y) + (set-nargs 2) + (ba .SPnvalret)) + +(defppclapfunction %ensure-static-conses () + (check-nargs 0) + (li imm0 arch::gc-trap-function-ensure-static-conses) + (trlgei allocptr 0) + (li arg_z nil) + (blr)) + +;;; offset is a fixnum, one of the target::kernel-import-xxx constants. +;;; Returns that kernel import, a fixnum. +(defppclapfunction %kernel-import ((offset arg_z)) + (ref-global imm0 kernel-imports) + (unbox-fixnum imm1 arg_z) + (ldrx arg_z imm0 imm1) + (blr)) + +(defppclapfunction %get-unboxed-ptr ((macptr arg_z)) + (macptr-ptr imm0 arg_z) + (ldr arg_z 0 imm0) + (blr)) + + +(defppclapfunction %revive-macptr ((p arg_z)) + (li imm0 target::subtag-macptr) + (stb imm0 target::misc-subtag-offset p) + (blr)) + +(defppclapfunction %macptr-type ((p arg_z)) + (check-nargs 1) + (trap-unless-typecode= p target::subtag-macptr) + (svref imm0 target::macptr.type-cell p) + (box-fixnum arg_z imm0) + (blr)) + +(defppclapfunction %macptr-domain ((p arg_z)) + (check-nargs 1) + (trap-unless-typecode= p target::subtag-macptr) + (svref imm0 target::macptr.domain-cell p) + (box-fixnum arg_z imm0) + (blr)) + +(defppclapfunction %set-macptr-type ((p arg_y) (new arg_z)) + (check-nargs 2) + (unbox-fixnum imm1 new) + (trap-unless-typecode= p target::subtag-macptr) + (svset imm1 target::macptr.type-cell p) + (blr)) + +(defppclapfunction %set-macptr-domain ((p arg_y) (new arg_z)) + (check-nargs 2) + (unbox-fixnum imm1 new) + (trap-unless-typecode= p target::subtag-macptr) + (svset imm1 target::macptr.domain-cell p) + (blr)) + +(defppclapfunction true () + (cmplri nargs '3) + (li arg_z t) + (blelr) + (subi imm0 nargs '3) + (add vsp vsp imm0) + (blr)) + +(defppclapfunction false () + (cmplri nargs '3) + (li arg_z nil) + (blelr) + (subi imm0 nargs '3) + (add vsp vsp imm0) + (blr)) + +(lfun-bits #'true #.(encode-lambda-list '(&lap &rest ignore))) +(lfun-bits #'false #.(encode-lambda-list '(&lap &rest ignore))) + +;;; end Index: /branches/new-random/level-0/X86/.cvsignore =================================================================== --- /branches/new-random/level-0/X86/.cvsignore (revision 13309) +++ /branches/new-random/level-0/X86/.cvsignore (revision 13309) @@ -0,0 +1,2 @@ +*fsl +*~.* Index: /branches/new-random/level-0/X86/X8632/x8632-array.lisp =================================================================== --- /branches/new-random/level-0/X86/X8632/x8632-array.lisp (revision 13309) +++ /branches/new-random/level-0/X86/X8632/x8632-array.lisp (revision 13309) @@ -0,0 +1,242 @@ +;;; Copyright 2009 Clozure Associates +;;; This file is part of Clozure CL. +;;; +;;; Clozure CL is licensed under the terms of the Lisp Lesser GNU +;;; Public License , known as the LLGPL and distributed with Clozure +;;; CL as the file "LICENSE". The LLGPL consists of a preamble and +;;; the LGPL, which is distributed with Clozure CL as the file "LGPL". +;;; Where these conflict, the preamble takes precedence. +;;; +;;; Clozure CL is referenced in the preamble as the "LIBRARY." +;;; +;;; The LLGPL is also available online at +;;; http://opensource.franz.com/preamble.html + +(in-package "CCL") + +(eval-when (:compile-toplevel :execute) + (require "X8632-ARCH") + (require "X86-LAPMACROS")) + +;; rewrite in LAP someday (soon). +(defun %init-misc (val uvector) + (dotimes (i (uvsize uvector) uvector) + (setf (uvref uvector i) val))) + +;;; Make a new vector of size newsize whose subtag matches that of oldv-arg. +;;; Blast the contents of the old vector into the new one as quickly as +;;; possible; leave remaining elements of new vector undefined (0). +;;; Return new-vector. +(defun %extend-vector (start oldv newsize) + (declare (fixnum start)) + (let* ((new (%alloc-misc newsize (typecode oldv))) + (oldsize (uvsize oldv))) + (declare (fixnum oldsize)) + (do* ((i 0 (1+ i)) + (j start (1+ j))) + ((= i oldsize) new) + (declare (fixnum i j)) + (setf (uvref new j) (uvref oldv i))))) + +;;; argument is a vector header or an array header. Or else. +(defx8632lapfunction %array-header-data-and-offset ((a arg_z)) + (let ((offset arg_y) + (temp temp1)) + (movl (% esp) (% temp0)) + (movl ($ '0) (%l offset)) + (movl (% a) (% temp)) + @loop + (movl (@ target::arrayH.data-vector (% temp)) (% a)) + (extract-subtag a imm0) + (addl (@ target::arrayH.displacement (% temp)) (% offset)) + (rcmp (% imm0) ($ target::subtag-vectorH)) + (movl (% a) (% temp)) + (jle @loop) + (push (% a)) + (push (% offset)) + (set-nargs 2) + (jmp-subprim .SPvalues))) + +(defx8632lapfunction %boole-clr ((idx 8) (b0 4) #|(ra 0)|# (b1 arg_y) (dest arg_z)) + (movl (@ idx (% esp)) (% temp0)) + (movl ($ 0) (@ x8632::misc-data-offset (% dest) (% temp0))) + (single-value-return 4)) + +(defx8632lapfunction %boole-set ((idx 8) (b0 4) #|(ra 0)|# (b1 arg_y) (dest arg_z)) + (movl (@ idx (% esp)) (% temp0)) + (movl ($ -1) (@ x8632::misc-data-offset (% dest) (% temp0))) + (single-value-return 4)) + +(defx8632lapfunction %boole-1 ((idx 8) (b0 4) #|(ra 0)|# (b1 arg_y) (dest arg_z)) + (movl (@ idx (% esp)) (% temp0)) + (movl (@ b0 (% esp)) (% temp1)) + (movl (@ x8632::misc-data-offset (% temp1) (% temp0)) (% imm0)) + (movl (% imm0) (@ x8632::misc-data-offset (% dest) (% temp0))) + (single-value-return 4)) + +(defx8632lapfunction %boole-2 ((idx 8) (b0 4) #|(ra 0)|# (b1 arg_y) (dest arg_z)) + (movl (@ idx (% esp)) (% temp0)) + (movl (@ x8632::misc-data-offset (% b1) (% temp0)) (% imm0)) + (movl (% imm0) (@ x8632::misc-data-offset (% dest) (% temp0))) + (single-value-return 4)) + +(defx8632lapfunction %boole-c1 ((idx 8) (b0 4) #|(ra 0)|# (b1 arg_y) (dest arg_z)) + (movl (@ idx (% esp)) (% temp0)) + (movl (@ b0 (% esp)) (% temp1)) + (movl (@ x8632::misc-data-offset (% temp1) (% temp0)) (% imm0)) + (notl (% imm0)) + (movl (% imm0) (@ x8632::misc-data-offset (% dest) (% temp0))) + (single-value-return 4)) + +(defx8632lapfunction %boole-c2 ((idx 8) (b0 4) #|(ra 0)|# (b1 arg_y) (dest arg_z)) + (movl (@ idx (% esp)) (% temp0)) + (movl (@ x8632::misc-data-offset (% b1) (% temp0)) (% imm0)) + (notl (% imm0)) + (movl (% imm0) (@ x8632::misc-data-offset (% dest) (% temp0))) + (single-value-return 4)) + +(defx8632lapfunction %boole-and ((idx 8) (b0 4) #|(ra 0)|# (b1 arg_y) (dest arg_z)) + (movl (@ idx (% esp)) (% temp0)) + (movl (@ b0 (% esp)) (% temp1)) + (movl (@ x8632::misc-data-offset (% temp1) (% temp0)) (% imm0)) + (andl (@ x8632::misc-data-offset (% b1) (% temp0)) (% imm0)) + (movl (% imm0) (@ x8632::misc-data-offset (% dest) (% temp0))) + (single-value-return 4)) + +(defx8632lapfunction %boole-ior ((idx 8) (b0 4) #|(ra 0)|# (b1 arg_y) (dest arg_z)) + (movl (@ idx (% esp)) (% temp0)) + (movl (@ b0 (% esp)) (% temp1)) + (movl (@ x8632::misc-data-offset (% temp1) (% temp0)) (% imm0)) + (orl (@ x8632::misc-data-offset (% b1) (% temp0)) (% imm0)) + (movl (% imm0) (@ x8632::misc-data-offset (% dest) (% temp0))) + (single-value-return 4)) + +(defx8632lapfunction %boole-xor ((idx 8) (b0 4) #|(ra 0)|# (b1 arg_y) (dest arg_z)) + (movl (@ idx (% esp)) (% temp0)) + (movl (@ b0 (% esp)) (% temp1)) + (movl (@ x8632::misc-data-offset (% temp1) (% temp0)) (% imm0)) + (xorl (@ x8632::misc-data-offset (% b1) (% temp0)) (% imm0)) + (movl (% imm0) (@ x8632::misc-data-offset (% dest) (% temp0))) + (single-value-return 4)) + +(defx8632lapfunction %boole-eqv ((idx 8) (b0 4) #|(ra 0)|# (b1 arg_y) (dest arg_z)) + (movl (@ idx (% esp)) (% temp0)) + (movl (@ b0 (% esp)) (% temp1)) + (movl (@ x8632::misc-data-offset (% temp1) (% temp0)) (% imm0)) + (xorl (@ x8632::misc-data-offset (% b1) (% temp0)) (% imm0)) + (notl (% imm0)) + (movl (% imm0) (@ x8632::misc-data-offset (% dest) (% temp0))) + (single-value-return 4)) + +(defx8632lapfunction %boole-nand ((idx 8) (b0 4) #|(ra 0)|# (b1 arg_y) (dest arg_z)) + (movl (@ idx (% esp)) (% temp0)) + (movl (@ b0 (% esp)) (% temp1)) + (movl (@ x8632::misc-data-offset (% temp1) (% temp0)) (% imm0)) + (andl (@ x8632::misc-data-offset (% b1) (% temp0)) (% imm0)) + (notl (% imm0)) + (movl (% imm0) (@ x8632::misc-data-offset (% dest) (% temp0))) + (single-value-return 4)) + +(defx8632lapfunction %boole-nor ((idx 8) (b0 4) #|(ra 0)|# (b1 arg_y) (dest arg_z)) + (movl (@ idx (% esp)) (% temp0)) + (movl (@ b0 (% esp)) (% temp1)) + (movl (@ x8632::misc-data-offset (% temp1) (% temp0)) (% imm0)) + (orl (@ x8632::misc-data-offset (% b1) (% temp0)) (% imm0)) + (notl (% imm0)) + (movl (% imm0) (@ x8632::misc-data-offset (% dest) (% temp0))) + (single-value-return 4)) + +(defx8632lapfunction %boole-andc1 ((idx 8) (b0 4) #|(ra 0)|# (b1 arg_y) (dest arg_z)) + (movl (@ idx (% esp)) (% temp0)) + (movl (@ b0 (% esp)) (% temp1)) + (movl (@ x8632::misc-data-offset (% temp1) (% temp0)) (% imm0)) + (notl (% imm0)) + (andl (@ x8632::misc-data-offset (% b1) (% temp0)) (% imm0)) + (movl (% imm0) (@ x8632::misc-data-offset (% dest) (% temp0))) + (single-value-return 4)) + +(defx8632lapfunction %boole-andc2 ((idx 8) (b0 4) #|(ra 0)|# (b1 arg_y) (dest arg_z)) + (movl (@ idx (% esp)) (% temp0)) + (movl (@ b0 (% esp)) (% temp1)) + (movl (@ x8632::misc-data-offset (% b1) (% temp0)) (% imm0)) + (notl (% imm0)) + (andl (@ x8632::misc-data-offset (% temp1) (% temp0)) (% imm0)) + (movl (% imm0) (@ x8632::misc-data-offset (% dest) (% temp0))) + (single-value-return 4)) + +(defx8632lapfunction %boole-orc1 ((idx 8) (b0 4) #|(ra 0)|# (b1 arg_y) (dest arg_z)) + (movl (@ idx (% esp)) (% temp0)) + (movl (@ b0 (% esp)) (% temp1)) + (movl (@ x8632::misc-data-offset (% temp1) (% temp0)) (% imm0)) + (notl (% imm0)) + (orl (@ x8632::misc-data-offset (% b1) (% temp0)) (% imm0)) + (movl (% imm0) (@ x8632::misc-data-offset (% dest) (% temp0))) + (single-value-return 4)) + +(defx8632lapfunction %boole-orc2 ((idx 8) (b0 4) #|(ra 0)|# (b1 arg_y) (dest arg_z)) + (movl (@ idx (% esp)) (% temp0)) + (movl (@ b0 (% esp)) (% temp1)) + (movl (@ x8632::misc-data-offset (% b1) (% temp0)) (% imm0)) + (notl (% imm0)) + (orl (@ x8632::misc-data-offset (% temp1) (% temp0)) (% imm0)) + (movl (% imm0) (@ x8632::misc-data-offset (% dest) (% temp0))) + (single-value-return 4)) + +(defparameter *simple-bit-boole-functions* ()) + +(setq *simple-bit-boole-functions* + (vector + #'%boole-clr + #'%boole-set + #'%boole-1 + #'%boole-2 + #'%boole-c1 + #'%boole-c2 + #'%boole-and + #'%boole-ior + #'%boole-xor + #'%boole-eqv + #'%boole-nand + #'%boole-nor + #'%boole-andc1 + #'%boole-andc2 + #'%boole-orc1 + #'%boole-orc2)) + +(defun %simple-bit-boole (op b1 b2 result) + (let* ((f (svref *simple-bit-boole-functions* op))) + (dotimes (i (ash (the fixnum (+ (length result) 31)) -5) result) + (funcall f i b1 b2 result)))) + +(defx8632lapfunction %aref2 ((array 4) #|(ra 0)|# (i arg_y) (j arg_z)) + (check-nargs 3) + (popl (@ 8 (% esp))) ;ra to first word of reserved frame + (pop (% temp0)) + (addl ($ '1) (% esp)) ;discard other word of reserved frame + (jmp-subprim .SParef2)) + +(defx8632lapfunction %aref3 ((array 8) (i 4) #|(ra 0)|# (j arg_y) (k arg_z)) + (check-nargs 4) + (popl (@ 12 (% esp))) + (pop (% temp0)) + (pop (% temp1)) + (addl ($ '1) (% esp)) + (jmp-subprim .SParef3)) + +(defx8632lapfunction %aset2 ((array 8) (i 4) #|(ra 0)|# (j arg_y) (newval arg_z)) + (check-nargs 4) + (popl (@ 12 (% esp))) + (pop (% temp0)) + (pop (% temp1)) + (addl ($ '1) (% esp)) + (jmp-subprim .SPaset2)) + +;;; We're out of registers. Put i on the stack. +(defx8632lapfunction %aset3 ((array 12) (i 8) (j 4) #|(ra 0)|# (k arg_y) (newval arg_z)) + (check-nargs 5) + (popl (@ 16 (% esp))) + (pop (% temp0)) + (popl (@ 4 (% esp))) + (pop (% temp1)) + (jmp-subprim .SPaset3)) + Index: /branches/new-random/level-0/X86/X8632/x8632-bignum.lisp =================================================================== --- /branches/new-random/level-0/X86/X8632/x8632-bignum.lisp (revision 13309) +++ /branches/new-random/level-0/X86/X8632/x8632-bignum.lisp (revision 13309) @@ -0,0 +1,1170 @@ +;;; Copyright 2009 Clozure Associates +;;; This file is part of Clozure CL. +;;; +;;; Clozure CL is licensed under the terms of the Lisp Lesser GNU +;;; Public License , known as the LLGPL and distributed with Clozure +;;; CL as the file "LICENSE". The LLGPL consists of a preamble and +;;; the LGPL, which is distributed with Clozure CL as the file "LGPL". +;;; Where these conflict, the preamble takes precedence. +;;; +;;; Clozure CL is referenced in the preamble as the "LIBRARY." +;;; +;;; The LLGPL is also available online at +;;; http://opensource.franz.com/preamble.html + +(in-package "CCL") + +;;; %BIGNUM-REF needs to access bignums as obviously as possible, and it needs +;;; to be able to return 32 bits somewhere no one looks for real objects. +;;; +;;; The easiest thing to do is to store the 32 raw bits in two fixnums +;;; and return multiple values. +;;; +(defx8632lapfunction %bignum-ref ((bignum arg_y) (i arg_z)) + (movl (% esp) (% temp0)) ;ptr to return addr on stack in temp0 + (movzwl (@ (+ 2 x8632::misc-data-offset) (% bignum) (% i)) (% imm0)) + (box-fixnum imm0 temp1) + (push (% temp1)) ;high + (movzwl (@ x8632::misc-data-offset (% bignum) (% i)) (% imm0)) + (box-fixnum imm0 temp1) + (push (% temp1)) ;low + (set-nargs 2) + (jmp-subprim .SPvalues)) + +(defx8632lapfunction %bignum-ref-hi ((bignum arg_y) (i arg_z)) + (movzwl (@ (+ 2 x8632::misc-data-offset) (% bignum) (% i)) (% imm0)) + (box-fixnum imm0 arg_z) + (single-value-return)) + +;;; BIGNUM[I] := DIGIT[0] +(defx8632lapfunction %set-digit ((bignum 4) #|(ra 0)|# (i arg_y) (digit arg_z)) + (movl (@ bignum (% esp)) (% temp0)) + (svref digit 0 imm0) + (movl (% imm0) (@ x8632::misc-data-offset (% temp0) (% i))) + (single-value-return 3)) + +;;; Return the sign of bignum (0 or -1) as a fixnum +(defx8632lapfunction %bignum-sign ((bignum arg_z)) + (vector-length bignum imm0) + (movl (@ (- x8632::misc-data-offset 4) (% bignum) (% imm0)) (% imm0)) + (sarl ($ 31) (% imm0)) ;propagate sign bit + (box-fixnum imm0 arg_z) + (single-value-return)) + +;;; Count the sign bits in the most significant digit of bignum; +;;; return fixnum count. +(defx8632lapfunction %bignum-sign-bits ((bignum arg_z)) + (vector-length bignum imm0) + (movl (@ (- x8632::misc-data-offset 4) (% bignum) (% imm0)) (% imm0)) + (mark-as-imm temp0) + (movl (% imm0) (% temp0)) + (notl (% imm0)) + (testl (% temp0) (% temp0)) + (js @wasneg) + (notl (% imm0)) + @wasneg + (bsrl (% imm0) (% imm0)) + (sete (% temp0.b)) + (xorl ($ 31) (% imm0)) + (addb (% temp0.b) (% imm0.b)) + (box-fixnum imm0 arg_z) + (mark-as-node temp0) + (single-value-return)) + +(defx8632lapfunction %digit-0-or-plusp ((bignum arg_y) (idx arg_z)) + (movl (@ x8632::misc-data-offset (% bignum) (% idx)) (% imm0)) + (movl ($ (target-nil-value)) (% temp0)) + (leal (@ x8632::t-offset (% temp0)) (% arg_z)) + (testl (% imm0) (% imm0)) + (cmovll (% temp0) (% arg_z)) + (single-value-return)) + +;;; For oddp, evenp +(defx8632lapfunction %bignum-oddp ((bignum arg_z)) + (movl (@ x8632::misc-data-offset (% bignum)) (% imm0)) + (movl ($ (target-nil-value)) (% temp0)) + (leal (@ x8632::t-offset (% temp0)) (% arg_z)) + (testb ($ 1) (% imm0.b)) + (cmovzl (% temp0) (% arg_z)) + (single-value-return)) + +(defx8632lapfunction bignum-plusp ((bignum arg_z)) + (vector-length bignum imm0) + (movl (@ (- x8632::misc-data-offset 4) (% bignum) (% imm0)) (% imm0)) + (movl ($ (target-nil-value)) (% arg_z)) + (lea (@ x8632::t-offset (% arg_z)) (% temp0)) + (testl (% imm0) (% imm0)) + (cmovnsl (% temp0) (% arg_z)) + (single-value-return)) + +(defx8632lapfunction bignum-minusp ((bignum arg_z)) + (vector-length bignum imm0) + (movl (@ (- x8632::misc-data-offset 4) (% bignum) (% imm0)) (% imm0)) + (movl ($ (target-nil-value)) (% arg_z)) + (lea (@ x8632::t-offset (% arg_z)) (% temp0)) + (testl (% imm0) (% imm0)) + (cmovsl (% temp0) (% arg_z)) + (single-value-return)) + +;;; Add the digits A[I] and B[J], and the incoming carry C (a fixnum, +;;; either 0 or 1). Store the result in R[K], and return the outgoing +;;; carry. If I is NIL, A is a fixnum. If J is NIL, B is a fixnum. +(defx8632lapfunction %add-with-carry ((r 20) (k 16) (c 12) (a 8) (i 4) #|(ra 0)|# (b arg_y) (j arg_z)) + (mark-as-imm temp0) + (unbox-fixnum b imm0) + (cmpl ($ (target-nil-value)) (% j)) + ;; if j not nil, get b[j] + (cmovnel (@ x8632::misc-data-offset (% b) (% j)) (% imm0)) + (movl (@ a (% esp)) (% arg_y)) + (unbox-fixnum arg_y temp0) + (movl (@ i (% esp)) (% arg_z)) + (cmpl ($ (target-nil-value)) (% arg_z)) + ;; if i not nil, get a[i] + (cmovnel (@ x8632::misc-data-offset (% arg_y) (% arg_z)) (% temp0)) + (xorl (% arg_z) (% arg_z)) + ;; I can't think of a better way to set CF at the moment. + ;; NEG would be ideal, but we don't have a free imm reg. + (btl ($ x8632::fixnumshift) (@ c (% esp))) ;CF = lsb of carry fixnum + (adc (% temp0) (% imm0)) + (setc (% arg_z.bh)) + (sarl ($ (- 8 x8632::fixnumshift)) (% arg_z)) ;outgoing carry + (mark-as-node temp0) + (movl (@ r (% esp)) (% temp0)) + (movl (@ k (% esp)) (% temp1)) + (movl (% imm0) (@ x8632::misc-data-offset (% temp0) (% temp1))) + (single-value-return 7)) + +;;; Add the digits A[I] and B[J], and the incoming carry C (a fixnum). +;;; Store the result in R[K], and return the outgoing carry. If I is +;;; NIL, A is a fixnum. If J is NIL, B is a fixnum. +#+sse2 +(defx8632lapfunction %add-with-carry ((r 20) (k 16) (c 12) (a 8) (i 4) #|(ra 0)|# (b arg_y) (j arg_z)) + (let ((aa mm2) + (bb mm3) + (cc mm4)) + (unbox-fixnum b imm0) ;assume j will be nil + (cmpl ($ (target-nil-value)) (% j)) + ;; if j not nil, get b[j] + (cmovnel (@ x8632::misc-data-offset (% b) (% j)) (% imm0)) + (movd (% imm0) (% bb)) + (movl (@ a (% esp)) (% arg_y)) + (movl (@ i (% esp)) (% arg_z)) + (movl (@ c (% esp)) (% temp0)) + (unbox-fixnum arg_y imm0) ;assume i will be nil + (cmpl ($ (target-nil-value)) (% arg_z)) + ;; if i not nil, get a[i] + (cmovnel (@ x8632::misc-data-offset (% arg_y) (% arg_z)) (% imm0)) + (movd (% imm0) (% aa)) + (unbox-fixnum temp0 imm0) + (movd (% imm0) (% cc)) + (paddq (% xx) (% yy)) + (paddq (% cc) (% yy)) + (movl (@ r (% esp)) (% temp0)) + (movl (@ k (% esp)) (% temp1)) + (movd (% yy) (@ x8632::misc-data-offset (% temp0) (% temp1))) + (psrlq ($ 32) (% yy)) ;carry bit + (movd (% yy) (% imm0)) + (box-fixnum imm0 arg_z) + (single-value-return 7))) + +;;; Store the result of A[I] - B[J] - borrow into R[K], returning the borrow. +;;; If I is NIL, A is a fixnum; likewise for J and B. +;;; +;;; (a - b) - (1 - borrow), or equivalently, (a - b) + borrow - 1 +;;; +;;; Note: borrow is 1 for no borrow and 0 for a borrow. +(defx8632lapfunction %subtract-with-borrow ((r 20) (k 16) (borrow 12) (a 8) (i 4) #|(ra 0)|# (b arg_y) (j arg_z)) + (mark-as-imm temp0) + (unbox-fixnum b imm0) + (cmpl ($ (target-nil-value)) (% j)) + (cmovnel (@ x8632::misc-data-offset (% b) (% j)) (% imm0)) + (movl (@ a (% esp)) (% arg_y)) + (unbox-fixnum arg_y temp0) + (movl (@ i (% esp)) (% arg_z)) + (cmpl ($ (target-nil-value)) (% arg_z)) + (cmovnel (@ x8632::misc-data-offset (% arg_y) (% arg_z)) (% temp0)) + ;; unboxed a or a[i] in temp0, unboxed b or b[j] in imm0 + (cmpl ($ '1) (@ borrow (% esp))) ;CF = 1 if borrow is 0 else CF = 0 + (sbb (% imm0) (% temp0)) + (movl ($ 1) (% imm0)) + (sbb ($ 0) (% imm0)) + (box-fixnum imm0 arg_z) + (movl (% temp0) (% imm0)) + (mark-as-node temp0) + (movl (@ r (% esp)) (% temp0)) + (movl (@ k (% esp)) (% temp1)) + (movl (% imm0) (@ x8632::misc-data-offset (% temp0) (% temp1))) + (single-value-return 7)) + +#+sse2 +(defx8632lapfunction %subtract-with-borrow ((r 20) (k 16) (borrow 12) (a 8) (i 4) #|(ra 0)|# (b arg_y) (j arg_z)) + (let ((aa mm2) + (bb mm3) + (ww mm4)) + (unbox-fixnum b imm0) + (cmpl ($ (target-nil-value)) (% j)) + ;; if j not nil, get b[j] + (cmovnel (@ x8632::misc-data-offset (% b) (% j)) (% imm0)) + (movd (% imm0) (% bb)) + (movl (@ a (% esp)) (% arg_y)) + (movl (@ i (% esp)) (% arg_z)) + (movl (@ borrow (% esp)) (% temp0)) + (unbox-fixnum arg_y imm0) + (cmpl ($ (target-nil-value)) (% arg_z)) + ;; if i not nil, get a[i] + (cmovnel (@ x8632::misc-data-offset (% arg_y) (% arg_z)) (% imm0)) + (movd (% imm0) (% aa)) + (unbox-fixnum temp0 imm0) + (subl ($ 1) (% imm0)) + (movd (% imm0) (% ww)) + (psubq (% bb) (% aa)) + (paddq (% ww) (% aa)) + (movl (@ r (% esp)) (% temp0)) + (movl (@ k (% esp)) (% temp1)) + (movd (% aa) (@ x8632::misc-data-offset (% temp0) (% temp1))) + (psrlq ($ 32) (% aa)) ;carry digit + (movd (% aa) (% imm0)) + (xorl (% arg_z) (% arg_z)) + (test ($ 1) (% imm0)) + (cmovzl ($ '1) (% arg_z)) + (single-value-return 7))) + +(defx8632lapfunction %subtract-one ((high arg_y) (low arg_z)) + (shll ($ (- 16 x8632::fixnumshift)) (% arg_y)) + (unbox-fixnum low imm0) + ;; high half should always be clear... + ;;(movzwl (% imm0.w) (% imm0)) + (orl (% arg_y) (% imm0)) + (decl (% imm0)) + (movl (% esp) (% temp0)) + ;; extract and push high half + (movl ($ (- #x10000)) (% arg_y)) + (andl (% imm0) (% arg_y)) + (shrl ($ (- 16 x8632::fixnumshift)) (% arg_y)) + (push (% arg_y)) + ;; low half + (andl ($ #xffff) (% imm0)) + (shll ($ x8632::fixnumshift) (% imm0)) + (push (% imm0)) + (set-nargs 2) + (jmp-subprim .SPvalues)) + +;;; %SUBTRACT-WITH-BORROW -- Internal. +;;; +;;; This should be in assembler, and should not cons intermediate results. It +;;; returns a 32bit digit and a borrow resulting from subtracting b from a, and +;;; subtracting a possible incoming borrow. +;;; +;;; We really do: a - b - 1 + borrow, where borrow is either 0 or 1. +;;; + +(defx8632lapfunction %subtract-with-borrow-1 ((a-h 12) (a-l 8) (b-h 4) #|(ra 0)|# (b-l arg_y) (borrow arg_z)) + (mark-as-imm temp0) + (mark-as-imm temp1) + (unbox-fixnum b-l temp0) + (movl (@ b-h (% esp)) (% imm0)) + (sarl ($ x8632::fixnumshift) (% imm0)) + (shll ($ 16) (% imm0)) + (orl (% imm0) (% temp0)) ;b in temp0 + (movl (@ a-l (% esp)) (% temp1)) + (sarl ($ x8632::fixnumshift) (% temp1)) + (movl (@ a-h (% esp)) (% imm0)) + (sarl ($ x8632::fixnumshift) (% imm0)) + (shll ($ 16) (% imm0)) + (orl (% imm0) (% temp1)) ;a in temp1 + + (unbox-fixnum borrow imm0) + (subl ($ 1) (% imm0)) ;sets carry appropriately + (sbbl (% temp0) (% temp1)) + (setae (%b imm0)) ;resulting borrow (1 for no, 0 for yes) + (movzbl (%b imm0) (% imm0)) + (box-fixnum imm0 arg_z) + (movl (% temp1) (% imm0)) + (andl ($ (- #x10000)) (% imm0)) + (shrl ($ (- 16 x8632::fixnumshift)) (% imm0)) + (popl (% arg_y)) ;return address + (addl ($ '5) (% esp)) ;discard reserved frame & stack args + (pushl (% arg_y)) + (push (% imm0)) ;high + (andl ($ #xffff) (% temp1)) + (box-fixnum temp1 imm0) + (mark-as-node temp0) + (mark-as-node temp1) + (push (% imm0)) ;low + (push (% arg_z)) ;borrow + (set-nargs 3) + (leal (@ '3 (% esp)) (% temp0)) + (jmp-subprim .SPvalues)) + + +;;; To normalize a bignum is to drop "trailing" digits which are +;;; redundant sign information. When return-fixnum-p is non-nil, make +;;; the resultant bignum into a fixnum if it fits. +(defx8632lapfunction %normalize-bignum-2 ((return-fixnum-p arg_y) (bignum arg_z)) + (push (% return-fixnum-p)) + (mark-as-imm temp0) + (mark-as-imm temp1) + (let ((len arg_y) + (sign temp0) + (next temp1)) + (vector-length bignum len) + (cmpl ($ '1) (% len)) + (jle @maybe-return-fixnum) + ;; Zero trailing sign digits. + (push (% len)) + ;; next-to-last digit + (movl (@ (- x8632::misc-data-offset 8) (% bignum) (% len)) (% next)) + ;; last digit + (movl (@ (- x8632::misc-data-offset 4) (% bignum) (% len)) (% sign)) + (jmp @test) + @loop + (subl ($ '1) (% len)) + (movl ($ 0) (@ x8632::misc-data-offset (% bignum) (% len))) + (cmpl ($ '1) (% len)) ;any more digits? + (je @adjust-length) + (movl (% next) (% sign)) + ;; (bignum-ref bignum (- len 2)) + (movl (@ (- x8632::misc-data-offset 8) (% bignum) (% len)) (% next)) + @test + (movl (% next) (% imm0)) + (sarl ($ 31) (% imm0)) ;propagate sign bit + (xorl (% sign) (% imm0)) ;whole digit only sign? + (jz @loop) + ;; New length now in len. + @adjust-length + (pop (% imm0)) ;original length + (cmpl (% len) (% imm0)) + ;; If the new length is the same as the original length, we know + ;; that the bignum is at least two digits long (because if it was + ;; shorter, we would have branched directly to + ;; @maybe-return-fixnum), and thus won't fit in a fixnum. + ;; Therefore, there's no need to do either of the tests at + ;; @maybe-return-fixnum. + (je @done) + (movl (% len) (% imm0)) + (shll ($ (- x8632::num-subtag-bits x8632::fixnumshift)) (% imm0)) + (movb ($ x8632::subtag-bignum) (% imm0.b)) + (movl (% imm0) (@ x8632::misc-header-offset (% bignum))) + @maybe-return-fixnum + ;; could use SETcc here to avoid one branch + (cmpl ($ (target-nil-value)) (@ 0 (% esp))) ;return-fixnum-p + (je @done) + (cmpl ($ x8632::one-digit-bignum-header) + (@ x8632::misc-header-offset (% bignum))) + (jne @done) + ;; Bignum has one digit. If it fits in a fixnum, return a fixnum. + (movl (@ x8632::misc-data-offset (% bignum)) (% imm0)) + (box-fixnum imm0 arg_y) + (unbox-fixnum arg_y temp0) + (cmpl (% temp0) (% imm0)) + (cmovel (% arg_y) (% arg_z)) + @done + (pop (% imm0)) ;discard saved return-fixnum-p + (mark-as-node temp0) + (mark-as-node temp1) + (single-value-return))) + +;;; Multiply X[I] by the unboxed value of the (non-negative) fixnum Y; +;;; add the incoming carry from CARRY[0] to the 64-bit product. Store +;;; the low word of the 64-bit sum in R[0] and the high word in +;;; CARRY[0]. +(defx8632lapfunction %multiply-and-add ((r 12) (carry 8) (x 4) #|(ra 0)|# (i arg_y) (y arg_z)) + (let ((xx mm2) + (yy mm3) + (cc mm4)) + (movl (@ x (% esp)) (% imm0)) + (movd (@ x8632::misc-data-offset (% imm0) (% i)) (% xx)) + (unbox-fixnum y imm0) + (movd (% imm0) (% yy)) + (pmuludq (% xx) (% yy)) ;64 bit product + (movl (@ carry (% esp)) (% arg_y)) + (movd (@ x8632::misc-data-offset (% arg_y)) (% cc)) + (paddq (% cc) (% yy)) ;add in 32 bit carry digit + (movl (@ r (% esp)) (% arg_z)) + (movd (% yy) (@ x8632::misc-data-offset (% arg_z))) + (psrlq ($ 32) (% yy)) + (movd (% yy) (@ x8632::misc-data-offset (% arg_y))) + (single-value-return 5))) + +;; multiply x[i] by y and add to result starting at digit i +(defx8632lapfunction %multiply-and-add-harder-loop-2 + ((x 12) (y 8) (r 4) #|(ra 0)|# (i arg_y) (ylen arg_z)) + (let ((cc mm2) + (xx mm3) + (yy mm4) + (rr mm5) + (j imm0)) + (movl (@ x (% esp)) (% temp0)) + (movd (@ x8632::misc-data-offset (% temp0) (% i)) (% xx)) ;x[i] + (movl (@ y (% esp)) (% temp0)) + (movl (@ r (% esp)) (% temp1)) + (pxor (% cc) (% cc)) + (xorl (% j) (% j)) + @loop + (movd (@ x8632::misc-data-offset (% temp0) (% j)) (% yy)) ;y[j] + (pmuludq (% xx) (% yy)) + ;; 64-bit product now in %yy + (movd (@ x8632::misc-data-offset (% temp1) (% i)) (% rr)) + ;; add in digit from r[i] + (paddq (% yy) (% rr)) + ;; add in carry + (paddq (% cc) (% rr)) + (movd (% rr) (@ x8632::misc-data-offset (% temp1) (% i))) ;update r[i] + (movq (% rr) (% cc)) + (psrlq ($ 32) (% cc)) ;get carry digit into low word + (addl ($ '1) (% i)) + (addl ($ '1) (% j)) + (subl ($ '1) (% ylen)) + (jg @loop) + (movd (% cc) (@ x8632::misc-data-offset (% temp1) (% i))) + (single-value-return 5))) + +;; this is silly +(defx8632lapfunction %add-the-carry ((high 4) #|(ra 0)|# (low arg_y) (c arg_z)) + (mark-as-imm temp0) + (let ((imm1 temp0) + (imm1.w temp0.w)) + (pop (% temp1)) + (popl (% imm1)) ;high + (discard-reserved-frame) + (push (% temp1)) + (shll ($ (- 16 x8632::fixnumshift)) (% temp0)) + (unbox-fixnum low imm0) + (orl (% imm0) (% imm1)) + (unbox-fixnum c imm0) + (addl (% imm0) (% imm1)) + (movzwl (% imm1.w) (% imm0)) + (box-fixnum imm0 temp1) + (sarl ($ 16) (% imm1)) + (shll ($ x8632::fixnumshift) (% imm1)) + (push (% imm1)) ;high + (push (% temp1))) ;low + (mark-as-node temp0) + (set-nargs 2) + (leal (@ '2 (% esp)) (% temp0)) + (jmp-subprim .SPvalues)) + +(defx8632lapfunction %bignum-count-trailing-zero-bits ((bignum arg_z)) + (let ((i arg_y) + (len temp0) + (zeros temp1)) + (vector-length bignum temp0) + (xorl (% i) (% i)) + (xorl (% zeros) (% zeros)) + @loop + (movl (@ x8632::misc-data-offset (% bignum) (% i)) (% imm0)) + (testl (% imm0) (% imm0)) + (jnz @last) + (addl ($ '32) (% zeros)) + (addl ($ '1) (% i)) + (cmpl (% len) (% i)) + (jb @loop) + @last + ;; now count zero bits in digit + (bsfl (% imm0) (% imm0)) + (shll ($ x8632::fixnumshift) (% imm0)) + (addl (% imm0) (% zeros)) + (movl (% zeros) (% arg_z)) + (single-value-return))) + +;;; dest[i] = (logand x[i] y[i]) +(defx8632lapfunction %bignum-logand ((idx 8) (x 4) #|(ra 0)|# (y arg_y) (dest arg_z)) + (let ((i temp0) + (xx temp1) + (yy arg_y)) + (movl (@ idx (% esp)) (% i)) + (movl (@ x (% esp)) (% xx)) + (movl (@ x8632::misc-data-offset (% xx) (% i)) (% imm0)) + (andl (@ x8632::misc-data-offset (% yy) (% i)) (% imm0)) + (movl (% imm0) (@ x8632::misc-data-offset (% dest) (% i))) + (single-value-return 4))) + +;;; dest[i] = (logandc1 x[i] y[i]) +(defx8632lapfunction %bignum-logandc1 ((idx 8) (x 4) #|(ra 0)|# (y arg_y) (dest arg_z)) + (let ((i temp0) + (xx temp1) + (yy arg_y)) + (movl (@ idx (% esp)) (% i)) + (movl (@ x (% esp)) (% xx)) + (movl (@ x8632::misc-data-offset (% xx) (% i)) (% imm0)) + (not (% imm0)) + (andl (@ x8632::misc-data-offset (% yy) (% i)) (% imm0)) + (movl (% imm0) (@ x8632::misc-data-offset (% dest) (% i))) + (single-value-return 4))) + +;;; dest[i] = (logandc2 x[i] y[i]) +(defx8632lapfunction %bignum-logandc2 ((idx 8) (x 4) #|(ra 0)|# (y arg_y) (dest arg_z)) + (let ((i temp0) + (xx temp1) + (yy arg_y)) + (movl (@ idx (% esp)) (% i)) + (movl (@ x (% esp)) (% xx)) + (movl (@ x8632::misc-data-offset (% yy) (% i)) (% imm0)) + (not (% imm0)) + (andl (@ x8632::misc-data-offset (% xx) (% i)) (% imm0)) + (movl (% imm0) (@ x8632::misc-data-offset (% dest) (% i))) + (single-value-return 4))) + +;;; dest[i] = (logior x[i] y[i]) +(defx8632lapfunction %bignum-logior ((idx 8) (x 4) #|(ra 0)|# (y arg_y) (dest arg_z)) + (let ((i temp0) + (xx temp1) + (yy arg_y)) + (movl (@ idx (% esp)) (% i)) + (movl (@ x (% esp)) (% xx)) + (movl (@ x8632::misc-data-offset (% xx) (% i)) (% imm0)) + (orl (@ x8632::misc-data-offset (% yy) (% i)) (% imm0)) + (movl (% imm0) (@ x8632::misc-data-offset (% dest) (% i))) + (single-value-return 4))) + +;;; dest[i] = (lognot x[i]) +(defx8632lapfunction %bignum-lognot ((idx 4) #|(ra 0)|# (x arg_y) (dest arg_z)) + (let ((i temp0)) + (movl (@ idx (% esp)) (% i)) + (movl (@ x8632::misc-data-offset (% x) (% i)) (% imm0)) + (not (% imm0)) + (movl (% imm0) (@ x8632::misc-data-offset (% dest) (% i))) + (single-value-return 3))) + +;;; dest[i] = (logxor x[i] y[i]) +(defx8632lapfunction %bignum-logxor ((idx 8) (x 4) #|(ra 0)|# (y arg_y) (dest arg_z)) + (let ((i temp0) + (xx temp1) + (yy arg_y)) + (movl (@ idx (% esp)) (% i)) + (movl (@ x (% esp)) (% xx)) + (movl (@ x8632::misc-data-offset (% xx) (% i)) (% imm0)) + (xorl (@ x8632::misc-data-offset (% yy) (% i)) (% imm0)) + (movl (% imm0) (@ x8632::misc-data-offset (% dest) (% i))) + (single-value-return 4))) + +;;; 0 if a[i] = b[i]; 1 if a[i] > b[i]; -1 if a[i] < b[i] +(defx8632lapfunction %compare-digits ((a 4) #|(ra 0)|# (b arg_y) (i arg_z)) + (movl (@ a (% esp)) (% temp0)) + (movl (@ x8632::misc-data-offset (% temp0) (% i)) (% imm0)) + (movl ($ '1) (% temp0)) + (movl ($ '-1) (% temp1)) + (subl (@ x8632::misc-data-offset (% b) (% i)) (% imm0)) + (cmoval (% temp0) (% imm0)) + (cmovbl (% temp1) (% imm0)) + (movl (% imm0) (% arg_z)) + (single-value-return 3)) + +;; returns number of bits in digit-hi,digit-lo that are sign bits +;; 32 - digits-sign-bits is integer-length +(defx8632lapfunction %digits-sign-bits ((hi arg_y) (lo arg_z)) + (mark-as-imm temp0) + (shll ($ (- 16 x8632::fixnumshift)) (% hi)) + (unbox-fixnum lo imm0) + (orl (% hi) (% imm0)) + (movl (% imm0) (% temp0)) + (not (% imm0)) + (testl (% temp0) (% temp0)) + (js @wasneg) + (not (% imm0)) + @wasneg + (bsrl (% imm0) (% imm0)) + (sete (% temp0.b)) + (xorl ($ 31) (% imm0)) + (addb (% temp0.b) (% imm0.b)) + (box-fixnum imm0 arg_z) + (mark-as-node temp0) + (single-value-return)) + +(defx8632lapfunction macptr->fixnum ((ptr arg_z)) + (macptr-ptr arg_z ptr) + (single-value-return)) + +; if dest not nil store unboxed result in dest(0), else return a fixnum +(defx8632lapfunction fix-digit-logandc2 ((fix 4) #|(ra 0)|# (big arg_y) (dest arg_z)) ; index 0 + (mark-as-imm temp0) + (movl (@ fix (% esp)) (% temp0)) + (unbox-fixnum temp0 temp0) + (movl (@ x8632::misc-data-offset (% big)) (% imm0)) + (not (% imm0)) + (andl (% temp0) (% imm0)) + (mark-as-node temp0) + (cmpl ($ (target-nil-value)) (% dest)) + (jne @store) + (box-fixnum imm0 arg_z) + (single-value-return 3) + @store + (movl (% imm0) (@ x8632::misc-data-offset (% dest))) + (single-value-return 3)) + +(defx8632lapfunction fix-digit-logandc1 ((fix 4) #|(ra 0)|# (big arg_y) (dest arg_z)) ; index 0 + (mark-as-imm temp0) + (movl (@ fix (% esp)) (% temp0)) + (unbox-fixnum temp0 temp0) + (movl (@ x8632::misc-data-offset (% big)) (% imm0)) + (not (% temp0)) + (andl (% temp0) (% imm0)) + (mark-as-node temp0) + (cmpl ($ (target-nil-value)) (% dest)) + (jne @store) + (box-fixnum imm0 arg_z) + (single-value-return 3) + @store + (movl (% imm0) (@ x8632::misc-data-offset (% dest))) + (single-value-return 3)) + +(defx8632lapfunction fix-digit-logand ((fix 4) #|(ra 0)|# (big arg_y) (dest arg_z)) ; index 0 + (mark-as-imm temp0) + (movl (@ fix (% esp)) (% temp0)) + (sarl ($ x8632::fixnumshift) (% temp0)) + (movl (@ x8632::misc-data-offset (% big)) (% imm0)) + (andl (% temp0) (% imm0)) + (mark-as-node temp0) + (cmpl ($ (target-nil-value)) (% dest)) + (jne @store) + (box-fixnum imm0 arg_z) + (single-value-return 3) + @store + (movl (% imm0) (@ x8632::misc-data-offset (% dest))) + (single-value-return 3)) + + +(defx8632lapfunction digit-lognot-move ((index 4) #|(ra 0)|# (source arg_y) (dest arg_z)) + (movl (@ index (% esp)) (% temp0)) + (movl (@ x8632::misc-data-offset (% source) (% temp0)) (% imm0)) + (not (% imm0)) + (movl (% imm0) (@ x8632::misc-data-offset (% dest) (% temp0))) + (single-value-return 3)) + +;; Add b to a starting at a[i] +;; might want not to use SSE2 for this. use lea to update loop counter +;; variables so that the flags don't get set. +(defx8632lapfunction bignum-add-loop-+ ((i 8) (a 4) #|(ra 0)|# (b arg_y) (blen arg_z)) + (let ((aa mm2) + (bb mm3) + (cc mm4)) + (movl (@ a (% esp)) (% temp0)) + (movl (@ i (% esp)) (% temp1)) + (xorl (% imm0) (% imm0)) + (pxor (% cc) (% cc)) + @loop + (movd (@ x8632::misc-data-offset (% temp0) (% temp1)) (% aa)) + (movd (@ x8632::misc-data-offset (% b) (% imm0)) (% bb)) + (paddq (% bb) (% aa)) + (paddq (% cc) (% aa)) + (movd (% aa) (@ x8632::misc-data-offset (% temp0) (% temp1))) + (psrlq ($ 32) (% aa)) + (movq (% aa) (% cc)) + (addl ($ '1) (% temp1)) + (addl ($ '1) (% imm0)) + (subl ($ '1) (% blen)) + (jg @loop) + ;; add in final carry + (movd (% cc) (% imm0)) + (addl (% imm0) (@ x8632::misc-data-offset (% temp0) (% temp1))) + (single-value-return 4))) + +(defx8632lapfunction bignum-logtest-loop ((count 4) #|(ra 0)|# (s1 arg_y) (s2 arg_z)) + (let ((i temp1) + (c temp0)) + (movl (@ count (% esp)) (% c)) + (xorl (% i) (% i)) + @loop + (movl (@ x8632::misc-data-offset (% s1) (% i)) (% imm0)) + (test (@ x8632::misc-data-offset (% s2) (% i)) (% imm0)) + (jnz @true) + (addl ($ '1) (% i)) + (cmpl (% i) (% c)) + (jg @loop) + (movl ($ (target-nil-value)) (% arg_z)) + (single-value-return 3) + @true + (movl ($ (target-t-value)) (% arg_z)) + (single-value-return 3))) + +;;; shift bignum left by nbits bits (1 <= nbits < 32) +;;; start storing into result at digit j +(defx8632lapfunction bignum-shift-left-loop ((nbits 12) (result 8) + (bignum 4) #|(ra 0)|# + (res-len-1 arg_y) (j arg_z)) + (movl (% ebp) (@ 16 (% esp))) + (leal (@ 16 (% esp)) (% ebp)) + (popl (@ 4 (% ebp))) + (push (% arg_y)) ;ebp - 16 + (push (% arg_z)) ;ebp - 20 + + (movl (@ -4 (% ebp)) (% imm0)) + (sarl ($ x8632::fixnumshift) (% imm0)) + (movd (% imm0) (% mm7)) ;shift count + (negl (% imm0)) + (addl ($ 32) (% imm0)) + (movd (% imm0) (% mm6)) ;remaining bits + + (let ((rl-1 -16) + (r temp0) + (b temp1) + (i arg_y) + (i+1 imm0)) + (movl (@ -8 (% ebp)) (% r)) + (movl (@ -12 (% ebp)) (% b)) + (xorl (% i) (% i)) + (movl ($ '1) (% i+1)) + ;; j (in arg_z) is already (1+ digits) + (jmp @test) + @loop + (movd (@ x8632::misc-data-offset (% b) (% i)) (% mm0)) + (psrlq (% mm6) (% mm0)) + (movd (@ x8632::misc-data-offset (% b) (% i+1)) (% mm1)) + (psllq (% mm7) (% mm1)) + (por (% mm1) (% mm0)) + (movd (% mm0) (@ x8632::misc-data-offset (% r) (% j))) + (movl (% i+1) (% i)) + (addl ($ '1) (% i+1)) + (addl ($ '1) (% j)) + @test + (cmpl (@ rl-1 (% ebp)) (% j)) + (jne @loop) + (movd (@ x8632::misc-data-offset (% b)) (% mm0)) + (psllq (% mm7) (% mm0)) + (movl (@ -20 (% ebp)) (% imm0)) ;digits + 1 (that is, the original j) + (subl ($ '1) (% imm0)) ;digits + (movd (% mm0) (@ x8632::misc-data-offset (% r) (% imm0))) + (movd (@ x8632::misc-data-offset (% b) (% i)) (% mm0)) + (psrad (% mm6) (% mm0)) + (movd (% mm0) (@ x8632::misc-data-offset (% r) (% j)))) + (leave) + (ret)) + +;;; shift bignum right by i words plus nbits bits. +(defx8632lapfunction bignum-shift-right-loop-1 ((nbits 12) (result 8) + (bignum 4) #|(ra 0)|# + (res-len-1 arg_y) + (i arg_z)) + (movl (@ nbits (% esp)) (% imm0)) + (sarl ($ x8632::fixnumshift) (% imm0)) + (movd (% imm0) (% mm7)) ;shift count + + (movl (@ result (% esp)) (% temp0)) + (movl (@ bignum (% esp)) (% temp1)) + (push (% res-len-1)) + (xorl (% arg_y) (% arg_y)) ;index into result + (jmp @test) + @loop + (movq (@ x8632::misc-data-offset (% temp1) (% i)) (% mm0)) ;b[i+1] || b[i] + (psrlq (% mm7) (% mm0)) + (movd (% mm0) (@ x8632::misc-data-offset (% temp0) (% arg_y))) + (addl ($ '1) (% i)) + (addl ($ '1) (% arg_y)) + @test + (cmpl (@ (% esp)) (% arg_y)) ;compare to res-len-1 + (jne @loop) + (addl ($ x8632::node-size) (% esp)) + @finish + (movd (@ x8632::misc-data-offset (% temp1) (% i)) (% mm0)) ;last digit of b + (psrad (% mm7) (% mm0)) + (movd (% mm0) (@ x8632::misc-data-offset (% temp0) (% arg_y))) + (single-value-return 5)) + +(defx8632lapfunction %logcount-complement ((bignum arg_y) (i arg_z)) + (mark-as-imm temp0) + (let ((rshift imm0) + (temp temp0)) + (movl (@ x8632::misc-data-offset (% bignum) (% i)) (% rshift)) + (notl (% rshift)) + (xorl (% arg_z) (% arg_z)) + (testl (% rshift) (% rshift)) + (jmp @test) + @next + (lea (@ -1 (% rshift)) (% temp)) + (and (% temp) (% rshift)) ;sets flags + (lea (@ '1 (% arg_z)) (% arg_z)) ;doesn't set flags + @test + (jne @next) + (mark-as-node temp0) + (single-value-return))) + +(defx8632lapfunction %logcount ((bignum arg_y) (i arg_z)) + (mark-as-imm temp0) + (let ((rshift imm0) + (temp temp0)) + (movl (@ x8632::misc-data-offset (% bignum) (% i)) (% rshift)) + (xorl (% arg_z) (% arg_z)) + (testl (% rshift) (% rshift)) + (jmp @test) + @next + (lea (@ -1 (% rshift)) (% temp)) + (and (% temp) (% rshift)) ;sets flags + (lea (@ '1 (% arg_z)) (% arg_z)) ;doesn't set flags + @test + (jne @next) + (mark-as-node temp0) + (single-value-return))) + + +;;; Divide bignum x by single digit y (passed as two halves). +;;; The quotient in stored in q, and the remainder is returned +;;; in two halves. (cf. Knuth, 4.3.1, exercise 16) +(defx8632lapfunction %floor-loop-quo ((x 8) (res 4) #|(ra 0)|# (yhi arg_y) (ylo arg_z)) + (compose-digit yhi ylo imm0) + (movl (% imm0) (:rcontext x8632::tcr.unboxed0)) + (pop (% temp0)) + (pop (% arg_z)) ;res + (pop (% arg_y)) ;x + (discard-reserved-frame) + (push (% temp0)) + (mark-as-imm edx) ;aka temp1 + (let ((bignum arg_y) ;bignum dividend + (result arg_z)) ;bignum result (quotient) + (xorl (% edx) (% edx)) + (vector-length bignum temp0) + (jmp @next) + @loop + (movl (@ x8632::misc-data-offset (% bignum) (% temp0)) (% eax)) + (divl (:rcontext x8632::tcr.unboxed0)) + (movl (% eax) (@ x8632::misc-data-offset (% result) (% temp0))) + @next + (subl ($ '1) (% temp0)) + (jge @loop)) + (movl (% esp) (% temp0)) + ;; extract and push high half of remainder + (movl ($ (- #x10000)) (% arg_y)) + (andl (% edx) (% arg_y)) + (shrl ($ (- 16 x8632::fixnumshift)) (% arg_y)) + (push (% arg_y)) + ;; extract and push low half + (andl ($ #xffff) (% edx)) + (shll ($ x8632::fixnumshift) (% edx)) + (push (% edx)) + (mark-as-node edx) + (set-nargs 2) + (jmp-subprim .SPvalues)) + +;;; For TRUNCATE-BY-FIXNUM et al. +;;; Doesn't store quotient: just returns rem in 2 halves. +;;; Could avoid using tcr.unboxed0 if it matters... +(defx8632lapfunction %floor-loop-no-quo ((x 4) #|(ra 0)|# (yhi arg_y) (ylo arg_z)) + (compose-digit yhi ylo imm0) + (movl (% imm0) (:rcontext x8632::tcr.unboxed0)) + (pop (% temp0)) + (pop (% arg_y)) + (discard-reserved-frame) + (push (% temp0)) + (mark-as-imm edx) ;aka temp1 + (let ((bignum arg_y) ;bignum dividend + (result arg_z)) ;bignum result (quotient) + (xorl (% edx) (% edx)) + (vector-length bignum temp0) + (jmp @next) + @loop + (movl (@ x8632::misc-data-offset (% bignum) (% temp0)) (% eax)) + (divl (:rcontext x8632::tcr.unboxed0)) + ;;(movl (% eax) (@ x8632::misc-data-offset (% result) (% temp0))) + @next + (subl ($ '1) (% temp0)) + (jge @loop)) + (movl (% esp) (% temp0)) + ;; extract and push high half of remainder + (movl ($ (- #x10000)) (% arg_y)) + (andl (% edx) (% arg_y)) + (shrl ($ (- 16 x8632::fixnumshift)) (% arg_y)) + (push (% arg_y)) + ;; extract and push low half + (andl ($ #xffff) (% edx)) + (shll ($ x8632::fixnumshift) (% edx)) + (push (% edx)) + (mark-as-node edx) + (set-nargs 2) + (jmp-subprim .SPvalues)) + +;;; transliterated from bignum-truncate-guess in l0-bignum64.lisp +;;; this is not beautiful... +(defx8632lapfunction truncate-guess-loop ((guess-h 16) (guess-l 12) (x 8) + (xidx 4) #|(ra 0)|# + (yptr arg_y) (yidx arg_z)) + (save-stackargs-frame 4) + (push (% arg_y)) + (push (% arg_z)) + + (movl (@ -4 (% ebp)) (% temp0)) ;guess-h + (movl (@ -8 (% ebp)) (% temp1)) ;guess-l + (compose-digit temp0 temp1 imm0) + (movd (% imm0) (% mm0)) ;save guess + + @loop + (movl (@ (% esp)) (% yidx)) + (movl (@ 4 (% esp)) (% yptr)) + (movd (@ (- x8632::misc-data-offset 0) (% yptr) (% yidx)) (% mm1)) ;y1 (high) + ;; (%multiply guess y1) + (pmuludq (% mm0) (% mm1)) + ;; (%multiply guess y2) + (movd (@ (- x8632::misc-data-offset 4) (% yptr) (% yidx)) (% mm2)) ;y2 (low) + (pmuludq (% mm0) (% mm2)) + + (movl (@ -12 (% ebp)) (% temp0)) ;x + (movl (@ -16 (% ebp)) (% arg_y)) ;xidx + (mark-as-imm temp1) ;edx now unboxed + + ;; (%subtract-with-borrow x-i-1 low-guess*y1 1) + (movl (@ (- x8632::misc-data-offset 4) (% temp0) (% arg_y)) (% edx)) ;x-i-1 + (movd (% mm1) (% eax)) ;low part of y1*guess + (subl (% eax) (% edx)) + (movd (% edx) (% mm6)) ;save middle digit + ;; (%subtract-with-borrow x-i high-guess*y1 borrow) + (movl (@ (- x8632::misc-data-offset 0) (% temp0) (% arg_y)) (% edx)) ;x-i + (movq (% mm1) (% mm3)) + (psrlq ($ 32) (% mm3)) ;get high part into low half + (movd (% mm3) (% eax)) ;high part of y1*guess + (sbbl (% eax) (% edx)) + (movd (% edx) (% mm7)) ;save high digit + ;; see if guess is suitable + ;; if (and (= high-digit 0) + (test (% edx) (% edx)) + (jne @return) + ;; (or (> high-guess*y2 middle-digit) + (movq (% mm2) (% mm3)) + (psrlq ($ 32) (% mm3)) + (movd (% mm3) (% eax)) ;high part of y2*guess + (movd (% mm6) (% edx)) ;middle-digit + (cmpl (% edx) (% eax)) + (ja @decrement) + ;; (and (= middle-digit high-guess*y2) + (jne @return) + ;; (> low-guess*y2 x-i-2) + (movd (% mm2) (% eax)) ;low part of y2*guess + (movl (@ (- x8632::misc-data-offset 8) (% temp0) (% arg_y)) (% edx)) ;x-i-2 + (cmpl (% edx) (% eax)) + (ja @decrement) + @return + (mark-as-node edx) + (leave) + (movl (% esp) (% temp0)) + (movd (% mm0) (% imm0)) + (shrl ($ 16) (% imm0)) + (shll ($ x8632::fixnumshift) (% imm0)) ;high half + (push (% imm0)) + (movd (% mm0) (% imm0)) + (andl ($ #xffff) (% imm0)) + (shll ($ x8632::fixnumshift) (% imm0)) + (push (% imm0)) ;low half + (set-nargs 2) + (jmp-subprim .SPvalues) + @decrement + (movd (% mm0) (% imm0)) ;guess + (subl ($ 1) (% imm0)) + (movd (% imm0) (% mm0)) + (jmp @loop)) + +;;; If x[i] = y[j], return the all ones digit (as two halves). +;;; Otherwise, compute floor x[i]x[i-1] / y[j]. +(defx8632lapfunction %floor-99 ((x-stk 8) (xidx 4) #|(ra 0)|# + (yptr arg_y) (yidx arg_z)) + (pop (% temp1)) + (pop (% imm0)) + (pop (% temp0)) + (discard-reserved-frame) + (push (% temp1)) + (movl (% imm0) (% temp1)) + (movl (@ x8632::misc-data-offset (% temp0) (% temp1)) (% imm0)) ;x[i] + (cmpl (% imm0) (@ x8632::misc-data-offset (% yptr) (% yidx))) ;y[j] + (jne @more) + (pushl ($ '#xffff)) + (pushl ($ '#xffff)) + (lea (@ '2 (% esp)) (% temp0)) + (set-nargs 2) + (jmp-subprim .SPvalues) + @more + (mark-as-imm edx) ;aka temp1 (contains a fixnum) + (movl (@ (- x8632::misc-data-offset 4) (% temp0) (% temp1)) (% eax)) ;low + (movl (@ x8632::misc-data-offset (% temp0) (% temp1)) (% edx)) ;high digit + (divl (@ x8632::misc-data-offset (% yptr) (% yidx))) + (mark-as-node edx) + ;; extract and push high half of quotient + (movl ($ (- #x10000)) (% arg_y)) + (andl (% eax) (% arg_y)) + (shrl ($ (- 16 x8632::fixnumshift)) (% arg_y)) + (push (% arg_y)) + ;; extract and push low half + (andl ($ #xffff) (% eax)) + (shll ($ x8632::fixnumshift) (% eax)) + (push (% eax)) + (set-nargs 2) + (lea (@ '2 (% esp)) (% temp0)) + (jmp-subprim .SPvalues)) + +;;; x * y + carry +(defx8632lapfunction %multiply-and-add-1 ((x-high 16) + (x-low 12) + (y-high 8) + (y-low 4) + #|(ra 0)|# + (carry-in-high arg_y) + (carry-in-low arg_z)) + (movl (@ x-high (% esp)) (% temp0)) + (movl (@ x-low (% esp)) (% temp1)) + (compose-digit temp0 temp1 imm0) + (movd (% imm0) (% mm0)) + (movl (@ y-high (% esp)) (% temp0)) + (movl (@ y-low (% esp)) (% temp1)) + (compose-digit temp0 temp1 imm0) + (movd (% imm0) (% mm1)) + (pmuludq (% mm1) (% mm0)) ;x * y + (compose-digit arg_y arg_z imm0) + (movd (% imm0) (% mm1)) + (paddq (% mm1) (% mm0)) ;add in carry digit + (movq (% mm0) (% mm1)) + (psrlq ($ 32) (% mm1)) ;resultant carry digit + ;; clean up stack + (pop (% temp0)) + (addl ($ '6) (% esp)) + (push (% temp0)) + ;; return (values carry-h carry-l result-h result-l) + (movl (% esp) (% temp0)) + (movd (% mm1) (% imm0)) + (shrl ($ 16) (% imm0)) + (shll ($ x8632::fixnumshift) (% imm0)) ;carry-h + (push (% imm0)) + (movd (% mm1) (% imm0)) + (shll ($ 16) (% imm0)) + (shrl ($ (- 16 x8632::fixnumshift)) (% imm0)) ;carry-l + (push (% imm0)) + (movd (% mm0) (% imm0)) + (shrl ($ 16) (% imm0)) + (shll ($ x8632::fixnumshift) (% imm0)) ;result-h + (push (% imm0)) + (movd (% mm0) (% imm0)) + (shll ($ 16) (% imm0)) + (shrl ($ (- 16 x8632::fixnumshift)) (% imm0)) ;result-l + (push (% imm0)) + (set-nargs 4) + (jmp-subprim .SPvalues)) + +;;; Copy the limb SRC points to to where DEST points. +(defx8632lapfunction copy-limb ((src arg_y) (dest arg_z)) + (int ($ 3))) + +;;; Return T iff LIMB contains 0. +(defx8632lapfunction limb-zerop ((limb arg_z)) + (int ($ 3))) + +;;; Return -1,0,1 according to whether the contents of Y are +;;; <,=,> the contents of Z. +(defx8632lapfunction compare-limbs ((y arg_y) (z arg_z)) + (int ($ 3))) + +;;; Add a fixnum to the limb LIMB points to. Ignore overflow. +(defx8632lapfunction add-fixnum-to-limb ((fixnum arg_y) (limb arg_z)) + (int ($ 3))) + +;;; Store a fixnum value where LIMB points. +(defx8632lapfunction copy-fixnum-to-limb ((fixnum arg_y) (limb arg_z)) + (int ($ 3))) + +;;; Increment a "LIMB VECTOR" (bignum) by a small amount. The caller +;;; knows that carries will only propagate for a word or two. +(defx8632lapfunction mpn-incr-u ((limb arg_y) (fixby arg_z)) + (int ($ 3))) + +;;; Store XP-YP at WP; return carry (0 or 1). +;;; wp, xp, yp: word-aligned, unboxed ptrs (fixnums) +;;; size: boxed fixnum +;;; returns boxed carry +(defx8632lapfunction mpn-sub-n ((wp 8) (xp 4) #|(ra 0)|# + (yp arg_y) (size arg_z)) + (int ($ 3))) + +;;; Store XP+YP at WP; return carry (0 or 1). +;;; wp, xp, yp = word-aligned, unboxed macptrs (fixnums). +;;; size = boxed fixnum +;;; result = boxed carry +(defx8632lapfunction mpn-add-n ((wp 8) (xp 4) #|(ra 0)|# + (yp arg_y) (size arg_z)) + (int ($ 3))) + +;;; Add the single limb LIMB to S1P (propagating carry.) Store the +;;; result at RP. RP and S1P may be the same place, so check for +;;; that and do nothing after carry stops propagating. Return carry. +(defx8632lapfunction mpn-add-1 ((rp-offset 8) (s1p 4) #|(ra 0)|# + (size arg_y) (limb arg_z)) + (int ($ 3))) + +;;; Multiply the limb vector S1 by the single limb at LIMBPTR, storing +;;; the result at RES. Store the "carry out" (high word of last 64-bit +;;; partial product) at the limb RESULT. +;;; res, s1, limbptr, result: +;;; unboxed, word-aligned ptrs (fixnums). size: boxed fixnum +;;; It'd be hard to transliterate the GMP code here; the GMP version +;;; uses lots more immediate registers than we can easily use in LAP +;;; (and is much more aggressively pipelined). +(defx8632lapfunction mpn-mul-1 ((res-offset 12) + (s1-offset 8) + (size 4) + #|(ra 0)|# + (limbptr arg_y) + (result arg_z)) + (int ($ 3))) + +;;; multiply s1*limb and add result to res +;;; res, s1, limbptr, result: +;;; unboxed, word-aligned ptrs (fixnums). +;;; size: boxed fixnum +;;; limbptr: source "limb". +;;; result: carry out (high word of product). +(defx8632lapfunction mpn-addmul-1 ((res-offset 12) + (s1-offset 8) + (size 4) + #|(ra 0)|# + (limbptr arg_y) + (result arg_z)) + (int ($ 3))) + +;;; Multiply the UN-word limb vector at UP and the VN-word limb vector +;;; at VP, store the result at RP. +(defx8632lapfunction mpn-mul-basecase ((rp-offset 12) + (up-offset 8) + (un 4) + #|(ra 0)|# + (vp arg_y) + (vn arg_z)) + (int ($ 3))) + +;;; left-shift src by 1 bit, storing result at res. Return +;;; the bit that was shifted out. +(defx8632lapfunction mpn-lshift-1 ((resptr 4) #|(ra 0)|# + (s1ptr arg_y) (size-arg arg_z)) + (int ($ 3))) + +;;; Do a 32x32=64 unsigned multiply of the words at X and Y. Store +;;; result (low word first) at RESULT. +(defx8632lapfunction umulppm ((x 4) #|(ra 0)|# (y arg_y) (result arg_z)) + (int ($ 3))) + +(defx8632lapfunction %fixnum-to-bignum-set ((bignum arg_y) (fixnum arg_z)) + (unbox-fixnum fixnum imm0) + (movl (% imm0) (@ x8632::misc-data-offset (% bignum))) + (single-value-return)) + +(defx8632lapfunction bignum-negate-loop-really ((bignum 4) #|(ra 0)|# + (len arg_y) (result arg_z)) + (mark-as-imm edx) ;aka %temp1 + (unbox-fixnum arg_y edx) + (movl (@ bignum (% esp)) (% arg_y)) + (xorl (% temp0) (% temp0)) + (stc) + @loop + (movl (@ x8632::misc-data-offset (% arg_y) (% temp0)) (% imm0)) + (not (% imm0)) + (adc ($ 0) (% imm0)) + (movl (% imm0) (@ x8632::misc-data-offset (% arg_z) (% temp0))) + (lea (@ x8632::node-size (% temp0)) (% temp0)) + (decl (% edx)) ;preserves carry flag + (jg @loop) + ;; return carry + (setc (% imm0.b)) + (movzbl (% imm0.b) (% imm0)) + (box-fixnum imm0 arg_z) + (mark-as-node edx) + (single-value-return 3)) + +(defx8632lapfunction %bignum-set ((bignum 8) (i 4) #|(ra 0)|# + (high arg_y) (low arg_z)) + (compose-digit high low imm0) + (movl (@ bignum (% esp)) (% arg_z)) + (movl (@ i (% esp)) (% arg_y)) + (movl (% imm0) (@ x8632::misc-data-offset (% arg_z) (% arg_y))) + (single-value-return 4)) + Index: /branches/new-random/level-0/X86/X8632/x8632-clos.lisp =================================================================== --- /branches/new-random/level-0/X86/X8632/x8632-clos.lisp (revision 13309) +++ /branches/new-random/level-0/X86/X8632/x8632-clos.lisp (revision 13309) @@ -0,0 +1,258 @@ +;;; Copyright 2009 Clozure Associates +;;; This file is part of Clozure CL. +;;; +;;; Clozure CL is licensed under the terms of the Lisp Lesser GNU +;;; Public License , known as the LLGPL and distributed with Clozure +;;; CL as the file "LICENSE". The LLGPL consists of a preamble and +;;; the LGPL, which is distributed with Clozure CL as the file "LGPL". +;;; Where these conflict, the preamble takes precedence. +;;; +;;; Clozure CL is referenced in the preamble as the "LIBRARY." +;;; +;;; The LLGPL is also available online at +;;; http://opensource.franz.com/preamble.html + +(in-package "CCL") + +;;; This just maps a SLOT-ID to a SLOT-DEFINITION or NIL. +;;; The map is a vector of (UNSIGNED-BYTE 8); this should +;;; be used when there are fewer than 255 slots in the class. +(defx8632lapfunction %small-map-slot-id-lookup ((slot-id arg_z)) + (movl (@ 'map (% fn)) (% temp1)) + (svref slot-id slot-id.index arg_y) + (vector-length temp1 temp0) + (xorl (%l imm0) (%l imm0)) + (rcmpl (% arg_y) (% temp0)) + (ja @have-table-index) + (movl (% arg_y) (% imm0)) + (shrl ($ x8632::word-shift) (% imm0)) + (movzbl (@ x8632::misc-data-offset (% temp1) (% imm0)) (%l imm0)) + ;(shll ($ x8632::word-shift) (% imm0)) + @have-table-index + (movl (@ 'table (% fn)) (% temp0)) + (movl (@ x8632::misc-data-offset (% temp0) (% imm0) 4) (% arg_z)) + (single-value-return)) + +;;; The same idea, only the map is a vector of (UNSIGNED-BYTE 32). +(defx8632lapfunction %large-map-slot-id-lookup ((slot-id arg_z)) + (movl (@ 'map (% fn)) (% temp1)) + (svref slot-id slot-id.index arg_y) + (vector-length temp1 temp0) + (xorl (%l imm0) (%l imm0)) + (rcmpl (% arg_y) (% temp0)) + (ja @have-table-index) + (movl (% arg_y) (% imm0)) + (movl (@ x8632::misc-data-offset (% temp1) (% imm0)) (%l imm0)) + @have-table-index + (movl (@ 'table (% fn)) (% temp0)) + (movl (@ x8632::misc-data-offset (% temp0) (% imm0) 4) (% arg_z)) + (single-value-return)) + +(defx8632lapfunction %small-slot-id-value ((instance arg_y) (slot-id arg_z)) + (movl (@ 'map (% fn)) (% temp1)) + (svref slot-id slot-id.index temp0) + (vector-length temp1 imm0) + (rcmpl (% temp0) (% imm0)) + (movl ($ 0) (% imm0)) ;don't disturb flags + (ja @missing) + (movl (% temp0) (% imm0)) + (shrl ($ x8632::word-shift) (% imm0)) + (movzbl (@ x8632::misc-data-offset (% temp1) (% imm0)) (% imm0)) + (testl (% imm0) (% imm0)) + (je @missing) + (movl (@ 'table (% fn)) (% temp0)) + (movl (@ x8632::misc-data-offset (% temp0) (% imm0) 4) (% arg_z)) + (popl (% ra0)) + (pushl ($ x8632::reserved-frame-marker)) + (pushl ($ x8632::reserved-frame-marker)) + (pushl (@ 'class (% fn))) + (set-nargs 3) + (pushl (% ra0)) + (jmp (@ '%maybe-std-slot-value-using-class (% fn))) + @missing ; (%slot-id-ref-missing instance id) + (set-nargs 2) + (jmp (@'%slot-id-ref-missing (% fn)))) + +(defx8632lapfunction %large-slot-id-value ((instance arg_y) (slot-id arg_z)) + (movl (@ 'map (% fn)) (% temp1)) + (svref slot-id slot-id.index temp0) + (vector-length temp1 imm0) + (rcmp (% temp0) (% imm0)) + (movl ($ 0) (% imm0)) + (ja @missing) + (movl (% temp0) (% imm0)) + (movl (@ x8632::misc-data-offset (% temp1) (% imm0)) (% imm0)) + (test (% imm0) (% imm0)) + (je @missing) + (movl (@ 'table (% fn)) (% temp0)) + (movl (@ x8632::misc-data-offset (% temp0) (% imm0) 4) (% arg_z)) + (popl (% ra0)) + (pushl ($ x8632::reserved-frame-marker)) + (pushl ($ x8632::reserved-frame-marker)) + (pushl (@ 'class (% fn))) + (set-nargs 3) + (pushl (% ra0)) + (jmp (@ '%maybe-std-slot-value-using-class (% fn))) + @missing ; (%slot-id-ref-missing instance id) + (set-nargs 2) + (jmp (@'%slot-id-ref-missing (% fn)))) + +(defx86lapfunction %small-set-slot-id-value ((instance 4) + #|(ra 0)|# + (slot-id arg_y) + (new-value arg_z)) + (movl (@ 'map (% fn)) (% temp1)) + (svref slot-id slot-id.index imm0) + (vector-length temp1 temp0) + (rcmpl (% imm0) (% temp0)) + (ja @missing) + (shrl ($ x8632::word-shift) (% imm0)) + (movzbl (@ x8632::misc-data-offset (% temp1) (% imm0)) (% imm0)) + (testl (% imm0) (% imm0)) + (je @missing) + (movl (@ 'table (% fn)) (% temp0)) + (movl (@ x8632::misc-data-offset (% temp0) (% imm0) 4) (% arg_y)) + (popl (% temp0)) ;return address + (popl (% temp1)) ;instance + ;; use existing frame + (pushl (@ 'class (% fn))) + (pushl (% temp1)) + (pushl (% temp0)) + (set-nargs 4) + ;; (%maybe-std-setf-slot-value-using-class class instance slotd new) + (jmp (@ '%maybe-std-setf-slot-value-using-class (% fn))) + @missing + (set-nargs 3) + ;; (%slot-id-set-missing instance id new) + (jmp (@ '%slot-id-set-missing (% fn)))) + +(defx8632lapfunction %large-set-slot-id-value ((instance 4) + #|(ra 0)|# + (slot-id arg_y) + (new-value arg_z)) + (movl (@ 'map (% fn)) (% temp1)) + (svref slot-id slot-id.index imm0) + (vector-length temp1 temp0) + (rcmpl (% imm0) (% temp0)) + (ja @missing) + (movl (@ x8632::misc-data-offset (% temp1) (% imm0)) (%l imm0)) + (testl (%l imm0) (%l imm0)) + (je @missing) + (movl (@ 'table (% fn)) (% temp0)) + (movl (@ x8632::misc-data-offset (% temp0) (% imm0) 4) (% arg_y)) + (popl (% temp0)) ;return addr + (popl (% temp1)) ;instance + (pushl (@ 'class (% fn))) + (pushl (% temp1)) + (pushl (% temp0)) + (set-nargs 4) + (jmp (@ '%maybe-std-setf-slot-value-using-class (% fn))) + @missing ; (%slot-id-set-missing instance id new-value) + (set-nargs 3) + (jmp (@'%slot-id-ref-missing (% fn)))) + +;;; All of the generic function trampoline functions have to be +;;; exactly the same size (x8632::gf-code-size) in words. The largest +;;; of these - the general-case *GF-PROTO* - is currently about 27 +;;; words, so X8632::GF-CODE-SIZE is just a little bigger than that. +;;; (Note that x8632::gf-code-size has to include space for the +;;; self-reference table, which takes up another couple of words in +;;; addition to the machine instructions.) +(defparameter *gf-proto* + (nfunction + gag + (lambda (&lap &lexpr args) + (x86-lap-function + gag + () + (:fixed-constants (class-wrapper slots dispatch-table dcode hash)) + (:code-size x8632::gf-code-size) + (movl (@ (% esp)) (% ra0)) + (save-frame-variable-arg-count) + (push-argregs) + (pushl (%l nargs)) + (movl (% esp) (% arg_z)) + (ref-global.l ret1valaddr imm0) + (cmpl (% ra0) (% imm0)) + (je @multiple) + (ref-global.l lexpr-return1v ra0) + (jmp @call) + @multiple + (pushl (@ (+ (target-nil-value) (x8632::%kernel-global 'lexpr-return)))) + (movl (% imm0) (% ra0)) + @call + (push (% ra0)) + (movl (@ 'dispatch-table (% fn)) (% arg_y)) + (set-nargs 2) + (jmp (@ 'dcode (% fn))) ; dcode function + )))) + +(defx8632lapfunction gag-one-arg ((arg arg_z)) + (:fixed-constants (class-wrapper slots dispatch-table dcode hash)) + (:code-size x8632::gf-code-size) + (check-nargs 1) + (movl (@ 'dispatch-table (% fn)) (% arg_y)) + (set-nargs 2) + (jmp (@ 'dcode (% fn)))) + +(defx8632lapfunction gag-two-arg ((arg0 arg_y) (arg1 arg_z)) + (:fixed-constants (class-wrapper slots dispatch-table dcode hash)) + (:code-size x8632::gf-code-size) + (check-nargs 2) + (pop (% ra0)) + (pushl ($ x8632::reserved-frame-marker)) + (pushl ($ x8632::reserved-frame-marker)) + (pushl (@ 'dispatch-table (% fn))) + (push (% ra0)) + (set-nargs 3) + (jmp (@ 'dcode (% fn)))) + +(defx8632lapfunction funcallable-trampoline () + (:fixed-constants (class-wrapper slots dispatch-table dcode hash)) + (:code-size x8632::gf-code-size) + (jmp (@ 'dcode (% fn)))) + +;;; This is in LAP so that it can reference itself in the error message. +;;; (It needs to be cloned, so %fn will be unique to each copy.) +;;; It can't work for this to reference any of its own constants. +(defx8632lapfunction unset-fin-trampoline () + (:code-size x8632::gf-code-size) + (save-frame-variable-arg-count) + (call-subprim .SPheap-rest-arg) + (pop (% arg_z)) + (pushl ($ x8632::reserved-frame-marker)) + (pushl ($ x8632::reserved-frame-marker)) + (pushl ($ '#.$XNOFINFUNCTION)) + (movl (% fn) (% arg_y)) + (set-nargs 3) + (call-subprim .SPksignalerr) + ;(movl ($ (target-nil-value)) (% arg_z)) + (leave) + (single-value-return)) + +(defparameter *cm-proto* + (nfunction + gag + (lambda (&lap &lexpr args) + (x86-lap-function + gag + () + (:fixed-constants (thing dcode gf bits)) + (movl (@ (% esp)) (% ra0)) + (save-frame-variable-arg-count) + (push-argregs) + (pushl (% nargs)) + (movl (% esp) (% arg_z)) + (ref-global ret1valaddr imm0) + (cmpl (% ra0) (% imm0)) + (je @multiple) + (ref-global lexpr-return1v ra0) + (jmp @call) + @multiple + (pushl (@ (+ (target-nil-value) (x8632::%kernel-global 'lexpr-return)))) + (movl (% imm0) (% ra0)) + @call + (push (% ra0)) + (movl (@ 'thing (% fn)) (% arg_y)) + (set-nargs 2) + (jmp (@ 'dcode (% fn))))))) Index: /branches/new-random/level-0/X86/X8632/x8632-def.lisp =================================================================== --- /branches/new-random/level-0/X86/X8632/x8632-def.lisp (revision 13309) +++ /branches/new-random/level-0/X86/X8632/x8632-def.lisp (revision 13309) @@ -0,0 +1,691 @@ +;;; -*- Mode: Lisp; Package: CCL -*- +;;; +;;; Copyright (C) 2006-2009 Clozure Associates and contributors +;;; This file is part of Clozure CL. +;;; +;;; Clozure CL is licensed under the terms of the Lisp Lesser GNU Public +;;; License , known as the LLGPL and distributed with Clozure CL as the +;;; file "LICENSE". The LLGPL consists of a preamble and the LGPL, +;;; which is distributed with Clozure CL as the file "LGPL". Where these +;;; conflict, the preamble takes precedence. +;;; +;;; Clozure CL is referenced in the preamble as the "LIBRARY." +;;; +;;; The LLGPL is also available online at +;;; http://opensource.franz.com/preamble.html + +(in-package "CCL") + +;;; Use the offsets in a function's self-reference table to replace +;;; the :self in (movl ($ :self) (% fn)) wih the function's actual +;;; address. +(defx8632lapfunction %update-self-references ((fun arg_z)) + (movzwl (@ x8632::misc-data-offset (% fun)) (% imm0)) ;imm word count + (btr ($ 15) (% imm0)) + (jnc @proceed) + (imm-word-count fun imm0 temp0) + (subl ($ '2) (% temp0)) + (jmp @load-offset) + @proceed + (subl ($ 2) (% imm0)) + (box-fixnum imm0 temp0) ;byte offset of first self-ref offset + (jmp @load-offset) + @loop + (movl (% fun) (@ x8632::misc-header-offset (% fun) (% imm0))) + (subl ($ '1) (% temp0)) + @load-offset + (movl (@ x8632::misc-data-offset (% fun) (% temp0)) (% imm0)) + (test (% imm0) (% imm0)) + (jne @loop) + (single-value-return)) + +(defx8632lapfunction %function-code-words ((fun arg_z)) + (trap-unless-typecode= fun x8632::subtag-function) + (movzwl (@ x8632::misc-data-offset (% fun)) (% imm0)) + (btr ($ 15) (% imm0)) + (jnc @proceed) + (imm-word-count fun imm0 temp0) + (movl (% temp0) (% arg_z)) + (single-value-return) + @proceed + (box-fixnum imm0 arg_z) + (single-value-return)) + +(defx8632lapfunction %nth-immediate ((fun arg_y) (n arg_z)) + (trap-unless-typecode= fun x8632::subtag-function) + (movzwl (@ x8632::misc-data-offset (% fun)) (% imm0)) + (btr ($ 15) (% imm0)) + (jnc @proceed) + (imm-word-count fun imm0 temp0) + (unbox-fixnum temp0 imm0) + @proceed + (lea (@ (% n) (% imm0) 4) (% imm0)) + (movl (@ x8632::misc-data-offset (% fun) (% imm0)) (% arg_z)) + (single-value-return)) + +(defx8632lapfunction %set-nth-immediate ((fun 4) #|(ra 0)|# (n arg_y) (new arg_z)) + (popl (@ 8 (% esp))) + (popl (% temp0)) + (addl ($ 4) (% esp)) + (trap-unless-typecode= temp0 x8632::subtag-function) + (movzwl (@ x8632::misc-data-offset (% temp0)) (% imm0)) + (lea (@ (% n) (% imm0) 4) (% arg_y)) + ;; expects gvector in temp0 + (jmp-subprim .SPgvset)) + +(defx8632lapfunction %function-code-byte ((fun arg_y) (pc arg_z)) + (unbox-fixnum pc imm0) + (movzbl (@ (% fun) (% imm0)) (% imm0)) + (box-fixnum imm0 arg_z) + (single-value-return)) + +(defx8632lapfunction %function-register-usage ((f arg_z)) + (check-nargs 1) + (trap-unless-typecode= f x8632::subtag-function) + (movl (% esp) (% temp0)) + (pushl ($ nil)) + (pushl ($ nil)) + (jmp-subprim .SPvalues)) + +;;; XXX probably should unify these next two with the x8664 versions. + +;;; Make a new function, with PROTO's code and the specified immediates. +;;; IMMEDIATES should contain lfun-bits as the last element. +(defun %clone-x86-function (proto &rest immediates) + (declare (dynamic-extent immediates)) + (let* ((protov (function-to-function-vector proto)) + (code-words (%function-code-words proto)) + (numimms (length immediates)) + (newv (allocate-typed-vector :function (the fixnum (+ code-words numimms))))) + (declare (fixnum code-words numimms)) + (%copy-ivector-to-ivector protov 0 newv 0 (the fixnum (ash code-words target::word-shift))) + #|| + ;; XXX bootstrapping + (setf (ldb (byte 16 0) (uvref newv 0)) (logior #x8000 numimms)) + ||# + (%update-self-references newv) + (do* ((k code-words (1+ k)) + (imms immediates (cdr imms))) + ((null imms) (function-vector-to-function newv)) + (declare (fixnum k) (list imms)) + (setf (%svref newv k) (car imms))))) + +(defun %copy-function (proto &optional target) + (let* ((protov (function-to-function-vector proto)) + (code-words (%function-code-words proto)) + (total-words (uvsize protov)) + (newv (if target + (function-to-function-vector target) + (allocate-typed-vector :function total-words)))) + (declare (fixnum code-words total-words)) + (when target + (unless (and (eql code-words (%function-code-words target)) + (eql total-words (uvsize newv))) + (error "Wrong size target ~s" target))) + (%copy-ivector-to-ivector protov 0 newv 0 (the fixnum (ash code-words target::word-shift))) + (loop for k fixnum from code-words below total-words + do (setf (%svref newv k) (%svref protov k))) + #|| + (setf (ldb (byte 16 0) (uvref newv 0)) + (logior #x8000 (- total-words code-words))) + ||# + (%update-self-references (function-vector-to-function newv)))) + +(defun replace-function-code (target proto) + (let* ((target-words (%function-code-words target)) + (proto-words (%function-code-words proto))) + (declare (fixnum target-words proto-words)) + (if (= target-words proto-words) + (progn + (%copy-ivector-to-ivector (function-to-function-vector proto) + 0 + (function-to-function-vector target) + 0 + (the fixnum (ash target-words + target::word-shift))) + (%update-self-references target) + target) + (error "Code size mismatch: target = ~s, proto = ~s" + target-words proto-words)))) + +(defx8632lapfunction %get-kernel-global-from-offset ((offset arg_z)) + (check-nargs 1) + (unbox-fixnum offset imm0) + (movl (@ (target-nil-value) (% imm0)) (% arg_z)) + (single-value-return)) + +(defx8632lapfunction %set-kernel-global-from-offset ((offset arg_y) + (new-value arg_z)) + (check-nargs 2) + (unbox-fixnum offset imm0) + (movl (% arg_z) (@ (target-nil-value) (% imm0))) + (single-value-return)) + +(defx8632lapfunction %get-kernel-global-ptr-from-offset ((offset arg_y) + (ptr arg_z)) + (check-nargs 2) + (unbox-fixnum offset imm0) + (movl (@ (target-nil-value) (% imm0)) (% imm0)) + (movl (% imm0) (@ x8632::macptr.address (% ptr))) + (single-value-return)) + +(defx8632lapfunction %fixnum-ref ((fixnum arg_y) #| &optional |# (offset arg_z)) + (:arglist (fixnum &optional offset)) + (check-nargs 1 2) + (cmpl ($ x8632::fixnumone) (% nargs)) + (jne @2-args) + (movl (% offset) (% fixnum)) + (xorl (%l offset) (%l offset)) + @2-args + (unbox-fixnum offset imm0) + (movl (@ (% fixnum) (% imm0)) (% arg_z)) + (single-value-return)) + +(defx8632lapfunction %fixnum-ref-natural ((fixnum arg_y) #| &optional |# (offset arg_z)) + (:arglist (fixnum &optional offset)) + (check-nargs 1 2) + (cmpl ($ x8632::fixnumone) (% nargs)) + (jne @2-args) + (movl (% offset) (% fixnum)) + (xorl (%l offset) (%l offset)) + @2-args + (unbox-fixnum offset imm0) + (movl (@ (% fixnum) (% imm0)) (% imm0)) + (jmp-subprim .SPmakeu32)) + +(defx8632lapfunction %fixnum-set ((fixnum 4) #|(ra 0)|# (offset arg_y) #| &optional |# (new-value arg_z)) + (:arglist (fixnum offset &optional newval)) + (check-nargs 2 3) + (cmpl ($ '2) (% nargs)) + (jne @3-args) + (movl (% new-value) (% offset)) + (single-value-return) + @3-args + (movl (@ fixnum (% esp)) (% temp0)) + (unbox-fixnum offset imm0) + (movl (% new-value) (@ (% temp0) (% imm0))) + (single-value-return 3)) + + +(defx8632lapfunction %fixnum-set-natural ((fixnum 4) #|(ra 0)|# (offset arg_y) #| &optional |# (new-value arg_z)) + (:arglist (fixnum offsnet &optional newval)) + (check-nargs 2 3) + (cmpl ($ '2) (% nargs)) + (jne @3-args) + (save-simple-frame) + (movl (% offset) (% temp0)) + (xorl (% offset) (% offset)) + (jmp @common) + @3-args + (movl (% ebp) (@ 8 (% esp))) + (lea (@ 8 (% esp)) (% ebp)) + (popl (@ 4 (% ebp))) + (popl (% temp0)) + @common + (call-subprim .SPgetu32) ;puts u32 in imm0 + (mark-as-imm temp1) + (unbox-fixnum offset temp1) + (movl (% imm0) (@ (% temp0) (% temp1))) + (mark-as-node temp1) + (restore-simple-frame) + (single-value-return)) + + +(defx8632lapfunction %current-frame-ptr () + (check-nargs 0) + (movl (% ebp) (% arg_z)) + (single-value-return)) + + +(defx8632lapfunction %current-tsp () + (check-nargs 0) + (movl (:rcontext x8632::tcr.save-tsp) (% arg_z)) + (single-value-return)) + + +(defx8632lapfunction %%frame-backlink ((p arg_z)) + (check-nargs 1) + (movl (@ (% arg_z)) (% arg_z)) + (single-value-return)) + +;;; Look for "movl $imm32,%fn at the tra; if present, then $imm32 is +;;; the address of the function. +;;; +;;; That is: #b10111111 +;;; ^^^^ +;;; operand size || register number (%fn/%edi) + +(defx8632lapfunction %return-address-function ((r arg_z)) + (extract-fulltag r imm0) + (cmpb ($ x8632::fulltag-tra) (% imm0.b)) + (jne @fail) + (cmpb ($ x8632::recover-fn-opcode-byte) (@ (% r))) + (jne @fail) + (movl (@ x8632::recover-fn-address-offset (% r)) (% arg_z)) + (single-value-return) + @fail + (movl ($ (target-nil-value)) (% arg_z)) + (single-value-return)) + +(defx8632lapfunction %return-address-offset ((r arg_z)) + (extract-fulltag r imm0) + (cmpb ($ x8632::fulltag-tra) (% imm0.b)) + (jne @fail) + (cmpb ($ x8632::recover-fn-opcode-byte) (@ (% r))) + (jne @fail) + (movl (@ x8632::recover-fn-address-offset (% r)) (% imm0)) + (subl (% arg_z) (% imm0)) + (negl (% imm0)) + (box-fixnum imm0 arg_z) + (single-value-return) + @fail + (movl ($ (target-nil-value)) (% arg_z)) + (single-value-return)) + +;;; It's always been the case that the function associated with a +;;; frame pointer is the caller of the function that "uses" that frame. +(defun %cfp-lfun (p) + (let* ((ra (%fixnum-ref p x8632::lisp-frame.return-address))) + (if (eq ra (%get-kernel-global ret1valaddr)) + (setq ra (%fixnum-ref p x8632::lisp-frame.xtra))) + (values (%return-address-function ra) (%return-address-offset ra)))) + +(defx8632lapfunction %uvector-data-fixnum ((uv arg_z)) + (check-nargs 1) + (trap-unless-fulltag= arg_z x8632::fulltag-misc) + (addl ($ x8632::misc-data-offset) (% arg_z)) + (single-value-return)) + +(defx8632lapfunction %catch-top ((tcr arg_z)) + (check-nargs 1) + (movl ($ (target-nil-value)) (% arg_y)) + (movl (:rcontext x8632::tcr.catch-top) (% arg_z)) + (testb (%b arg_z) (%b arg_z)) + (cmovel (% arg_y) (% arg_z)) + (single-value-return)) + +(defx8632lapfunction %catch-tsp ((catch arg_z)) + (check-nargs 1) + (lea (@ (- (+ x8632::fulltag-misc + (ash 1 (1+ x8632::word-shift)))) (% arg_z)) + (% arg_z)) + (single-value-return)) + +;;; Same as %address-of, but doesn't cons any bignums +;;; It also left shift fixnums just like everything else. +(defx8632lapfunction %fixnum-address-of ((x arg_z)) + (check-nargs 1) + (box-fixnum x arg_z) + (single-value-return)) + +(defx8632lapfunction %save-standard-binding-list ((bindings arg_z)) + (mark-as-imm temp0) + (movl (:rcontext x8632::tcr.vs-area) (% imm0)) + (movl (@ x8632::area.high (% imm0)) (% temp0)) + (subl ($ x8632::node-size) (% temp0)) + (movl (% bindings) (@ (% temp0))) + (mark-as-node temp0) + (single-value-return)) + +(defx8632lapfunction %saved-bindings-address () + (mark-as-imm temp0) + (movl (:rcontext x8632::tcr.vs-area) (% imm0)) + (movl (@ x8632::area.high (% imm0)) (% temp0)) + (leal (@ (- x8632::node-size) (% temp0)) (% arg_z)) + (mark-as-node temp0) + (single-value-return)) + +(defx8632lapfunction %get-object ((macptr arg_y) (offset arg_z)) + (check-nargs 2) + (trap-unless-typecode= macptr x8632::subtag-macptr) + (trap-unless-lisptag= offset x8632::tag-fixnum) + (macptr-ptr macptr imm0) + (mark-as-imm temp0) + (unbox-fixnum offset temp0) + (movl (@ (% imm0) (% temp0)) (% arg_z)) + (mark-as-node temp0) + (single-value-return)) + +(defx8632lapfunction %set-object ((macptr 4) #|(ra 0)|# (offset arg_y) (value arg_z)) + (check-nargs 3) + (movl (@ macptr (% esp)) (% temp1)) + (trap-unless-typecode= temp1 x8632::subtag-macptr) + (trap-unless-lisptag= offset x8632::tag-fixnum) + (macptr-ptr temp1 imm0) + (mark-as-imm temp0) + (unbox-fixnum offset temp0) + (movl (% arg_z) (@ (% imm0) (% temp0))) + (mark-as-node temp0) + (single-value-return 3)) + +(defx8632lapfunction %apply-lexpr-with-method-context ((magic 4) + #|(ra 0)|# + (function arg_y) + (args arg_z)) + ;; Somebody's called (or tail-called) us. + ;; * Put magic arg in %rcontext:tcr.next-method-context + ;; * Put function somewhere safe until we're ready to jump to it + ;; * Set nargs to 0, then spread "args" on stack (clobbers regs) + ;; * Jump to function (saved previously) + (popl (:rcontext x8632::tcr.save0)) ;return address + (popl (:rcontext x8632::tcr.next-method-context)) ;magic arg + (discard-reserved-frame) + (movl (% function) (:rcontext x8632::tcr.save1)) + (set-nargs 0) + (movl (@ (% args)) (% temp0)) ;lexpr-count + (movl (% temp0) (% nargs)) + (leal (@ x8632::node-size (% arg_z) (% temp0)) (% imm0)) + (subl ($ '2) (% temp0)) + (jbe @reg-only) + ;; Some args will be pushed; reserve a frame. + (pushl ($ x8632::reserved-frame-marker)) + (pushl ($ x8632::reserved-frame-marker)) + @pushloop + (pushl (@ (- x8632::node-size) (% imm0))) + (subl ($ x8632::node-size) (% imm0)) + (subl ($ x8632::node-size) (% temp0)) + (jne @pushloop) + @two + (movl (@ (* x8632::node-size 2) (% arg_z)) (% arg_y)) + @one + (movl (@ (* x8632::node-size 1) (% arg_z)) (% arg_z)) + (jmp @go) + @reg-only + (rcmp (% nargs) ($ '1)) + (je @one) + (jb @go) + (jmp @two) + @go + (pushl (:rcontext x8632::tcr.save0)) ;return address + (movl (:rcontext x8632::tcr.save1) (% temp0)) ;function + (movapd (% fpzero) (:rcontext x8632::tcr.save0)) ;clear spill area + (jmp (% temp0))) + +(defx8632lapfunction %apply-with-method-context ((magic 4) + #|(ra 0)|# + (function arg_y) + (args arg_z)) + ;; Similar to above. + (popl (:rcontext x8632::tcr.save0)) ;save return address + (popl (:rcontext x8632::tcr.next-method-context)) ; + (discard-reserved-frame) + (movl (% args) (:rcontext x8632::tcr.save2)) ;in case of error + (set-nargs 0) + (pushl ($ target::reserved-frame-marker)) ;reserve frame (might discard it + (pushl ($ target::reserved-frame-marker)) ;if nothing is passed on stack) + (cmp-reg-to-nil arg_z) + (je @done) + @loop + (extract-fulltag arg_z imm0) + (cmpb ($ x8632::fulltag-cons) (% imm0.b)) ;nil is a cons on x8632, but we + (jne @bad) ; checked for it already. + (add ($ '1) (% nargs)) ;shorter than lea (imm0 is eax) + (pushl (@ target::cons.car (% arg_z))) + (%cdr arg_z arg_z) + (cmp-reg-to-nil arg_z) + (jne @loop) + @done + ;; arg_y about to get clobbered; put function into temp0 + (movl (% function) (% temp0)) + ;; temp1 (aka nargs) contains number of args just pushed + (test (% nargs) (% nargs)) + (jne @pop) + @discard-and-go + (discard-reserved-frame) + (jmp @go) + @pop + (cmpl ($ '1) (% nargs)) + (pop (% arg_z)) + (je @discard-and-go) + (cmpl ($ '2) (% nargs)) + (pop (% arg_y)) + (je @discard-and-go) + @go + (pushl (:rcontext x8632::tcr.save0)) ;return address + (movapd (% fpzero) (:rcontext x8632::tcr.save0)) ;clear out spill area + (jmp (% temp0)) + @bad + (addl (% nargs) (% esp)) + (movl (:rcontext x8632::tcr.save1) (% arg_z)) ;saved args + (movapd (% fpzero) (:rcontext x8632::tcr.save0)) ;clear out spill area + (movl ($ '#.$XNOSPREAD) (% arg_y)) + (set-nargs 2) + (jmp-subprim .SPksignalerr)) + +;;; The idea here is to call METHOD in the same stack frame in +;;; which the lexpr was originally called. The lexpr can't +;;; have had any required arguments, %APPLY-LEXPR-TAIL-WISE +;;; must have been tail-called, and the frame built on lexpr +;;; entry must be in %rbp. +(defx8632lapfunction %apply-lexpr-tail-wise ((method arg_y) (args arg_z)) + (addl ($ x8632::node-size) (% esp)) ; discard extra return address + (movl (% method) (% xfn)) ;temp1 + (movl (% args) (% esp)) + (popl (% imm0)) ;nargs + (movl (@ x8632::lisp-frame.return-address (% ebp)) (% temp0)) + (movl (@ 0 (% ebp)) (% ebp)) + (rcmpl (% imm0) ($ '2)) + (jbe @pop-regs) + ;; More than 2 args; some must have been pushed by caller, + ;; so retain the reserved frame. + (pop (% arg_z)) + (pop (% arg_y)) + (jmp @popped) + @pop-regs + (rcmpl (% imm0) ($ '1)) + (jb @discard) + (ja @pop2) + (pop (% arg_z)) + (jmp @discard) + @pop2 + (pop (% arg_z)) + (pop (% arg_y)) + @discard + (discard-reserved-frame) + @popped + (push (% temp0)) ;return address + (movl (% xfn) (% temp0)) ;temp1 is also nargs + (movl (% imm0) (% nargs)) + (jmp (% temp0))) + +(defun closure-function (fun) + (while (and (functionp fun) (not (compiled-function-p fun))) + (setq fun (%nth-immediate fun 0)) + (when (vectorp fun) + (setq fun (svref fun 0)))) + fun) + +;;; For use by (setf (apply ...) ...) +;;; (apply+ f butlast last) = (apply f (append butlast (list last))) + +(defun apply+ (&lap function arg1 arg2 &rest other-args) + (x86-lap-function apply+ () + (:arglist (function arg1 arg2 &rest other-args)) + (check-nargs 3 nil) + (popl (:rcontext x8632::tcr.save0)) ;save return address + ;; only two arg regs on x8632, so the caller will always push a frame + (movl (% arg_z) (% temp0)) ; last + (movl (% arg_y) (% arg_z)) ; butlast + (subl ($ '2) (% nargs)) ; remove count for butlast & last + (movd (% temp1) (% mm0)) ;save nargs (aka temp1) for later + ;; Do .SPspreadargz inline here + (xorl (%l temp1) (%l temp1)) + (movl (% arg_z) (:rcontext x8632::tcr.save1)) ; save in case of error + (cmp-reg-to-nil arg_z) + (je @done) + ;;(mark-as-imm temp1) + @loop + (extract-fulltag arg_z imm0) + (cmpb ($ x8632::fulltag-cons) (%b imm0)) + (jne @bad) + (%car arg_z arg_y) + (%cdr arg_z arg_z) + (addl ($ '1) (%l temp1)) + (cmp-reg-to-nil arg_z) + (push (% arg_y)) + (jne @loop) + @done + ;; nargs was at least 1 when we started spreading, and can't have gotten + ;; any smaller. + (movd (% mm0) (% arg_y)) ;nargs from before loop + (addl (% arg_y) (% temp1)) ;did I mention nargs is temp1? + (movl (% temp0) (% arg_z)) + (pop (% arg_y)) + (addl ($ '1) (% nargs)) + (load-constant funcall temp0) + (pushl (:rcontext x8632::tcr.save0)) ;return address + (movapd (% fpzero) (:rcontext x8632::tcr.save0)) ;clear out spill area + (jmp-subprim .SPfuncall) + @bad ;error spreading list. + (add (% temp1) (% esp)) ;discard whatever's been pushed + (movl (:rcontext x8632::tcr.save1) (% arg_z)) + (movapd (% fpzero) (:rcontext x8632::tcr.save0)) ;clear out spill area + (movl ($ '#.$XNOSPREAD) (% arg_y)) + (set-nargs 2) + (jmp-subprim .SPksignalerr) )) + + + +;;; This needs to: +;;; (a) call the .SPffcall subprimitive, which will discard the foreign +;;; stack frame allocated by WITH-VARIABLE-C-FRAME in %FF-CALL +;;; (b) re-establish the same foreign stack frame and store the results +;;; there. +;;; +;;; The flags argument tells us what/where the result is: +;;; +;;;; flags meaning +;;; 0 32-bit value in EAX +;;; 1 single-float value on x87 stack +;;; 2 double-float value on x87 stack +;;; 3 64-bit value with low half in EAX, high half in tcr.unboxed1 + +(defx8632lapfunction %do-ff-call ((flags 4) #|(ra 0)|# (frame arg_y) (entry arg_z)) + (save-stackargs-frame 1) + (push (% arg_y)) + (push (% arg_z)) + (call-subprim .SPffcall) + ;; there might be an fp result on x87 stack, so don't use + ;; any mmx instructions until the result has been read. + (movd (:rcontext x8632::tcr.foreign-sp) (% xmm0)) + (movd (% xmm0) (@ (% frame))) + (movl (% frame) (:rcontext x8632::tcr.foreign-sp)) + (cmpl ($ 0) (@ -4 (% ebp))) + (jne @fp-or-doubleword) + (movl (% eax) (@ 4 (% frame))) + @done + (movl ($ nil) (% arg_z)) + (restore-simple-frame) + (single-value-return) + @fp-or-doubleword + (cmpl ($ '2) (@ -4 (% ebp))) + (jl @single) + (je @double) + ;; high 32 bits in tcr.unboxed1 (see .SPffcall) + (movl (% eax) (@ 4 (% frame))) + (movl (:rcontext x8632::tcr.unboxed1) (% eax)) + (movl (% eax) (@ 8 (% frame))) + (jmp @done) + @single + (fstps (@ 4 (% frame))) + (jmp @done) + @double + (fstpl (@ 4 (% frame))) + (jmp @done)) + +(defun %ff-call (entry &rest specs-and-vals) + (declare (dynamic-extent specs-and-vals)) + (let* ((len (length specs-and-vals)) + (total-words 0)) + (declare (fixnum len total-words)) + (let* ((result-spec (or (car (last specs-and-vals)) :void)) + (nargs (ash (the fixnum (1- len)) -1))) + (declare (fixnum nargs)) + (ecase result-spec + ((:address :unsigned-doubleword :signed-doubleword + :single-float :double-float + :signed-fullword :unsigned-fullword + :signed-halfword :unsigned-halfword + :signed-byte :unsigned-byte + :void) + (do* ((i 0 (1+ i)) + (specs specs-and-vals (cddr specs)) + (spec (car specs) (car specs))) + ((= i nargs)) + (declare (fixnum i)) + (case spec + (:registers + (error "don't know what to do with argspec ~s" spec)) + ((:double-float :unsigned-doubleword :signed-doubleword) + (incf total-words 2)) + ((:address :single-float + :signed-fullword :unsigned-fullword + :signed-halfword :unsigned-halfword + :signed-byte :unsigned-byte) + (incf total-words)) + (t (if (typep spec 'unsigned-byte) + (incf total-words spec) + (error "Invalid argument spec ~s" spec))))) + ;; It's necessary to ensure that the C frame is the youngest thing on + ;; the foreign stack here. + (with-macptrs ((argptr)) + (with-variable-c-frame + total-words frame + (%setf-macptr-to-object argptr frame) + (let* ((offset 8)) + (do* ((i 0 (1+ i)) + (specs specs-and-vals (cddr specs)) + (spec (car specs) (car specs)) + (val (cadr specs) (cadr specs))) + ((= i nargs)) + (declare (fixnum i)) + (case spec + (:double-float + (setf (%get-double-float argptr offset) val) + (incf offset 8)) + (:single-float + (setf (%get-single-float argptr offset) val) + (incf offset 4)) + (:signed-doubleword + (setf (%%get-signed-longlong argptr offset) val) + (incf offset 8)) + (:unsigned-doubleword + (setf (%%get-unsigned-longlong argptr offset) val) + (incf offset 8)) + (:address + (setf (%get-ptr argptr offset) val) + (incf offset 4)) + ((:signed-fullword :signed-halfword :signed-byte) + (setf (%get-signed-natural argptr offset) val) + (incf offset 4)) + ((:unsigned-fullword :unsigned-halfword :unsigned-byte) + (setf (%get-natural argptr offset) val) + (incf offset 4)) + (t + (let* ((p 0)) + (declare (fixnum p)) + (dotimes (i (the fixnum spec)) + (setf (%get-ptr argptr offset) (%get-ptr val p)) + (incf p 4) + (incf offset 4)))))) + (let ((flags (case result-spec + (:single-float 1) + (:double-float 2) + ((:signed-doubleword :unsigned-doubleword) 3) + (t 0)))) + (%do-ff-call flags frame entry)) + (ecase result-spec + (:void nil) + (:address (%get-ptr argptr 4)) + (:unsigned-byte (%get-unsigned-byte argptr 4)) + (:signed-byte (%get-signed-byte argptr 4)) + (:unsigned-halfword (%get-unsigned-word argptr 4)) + (:signed-halfword (%get-signed-word argptr 4)) + (:unsigned-fullword (%get-natural argptr 4)) + (:signed-fullword (%get-signed-natural argptr 4)) + (:unsigned-doubleword (%%get-unsigned-longlong argptr 4)) + (:signed-doubleword (%%get-signed-longlong argptr 4)) + (:single-float (%get-single-float argptr 4)) + (:double-float (%get-double-float argptr 4))))))))))) + +;;; end of x86-def.lisp Index: /branches/new-random/level-0/X86/X8632/x8632-float.lisp =================================================================== --- /branches/new-random/level-0/X86/X8632/x8632-float.lisp (revision 13309) +++ /branches/new-random/level-0/X86/X8632/x8632-float.lisp (revision 13309) @@ -0,0 +1,584 @@ +;;; Copyright 2009 Clozure Associates +;;; This file is part of Clozure CL. +;;; +;;; Clozure CL is licensed under the terms of the Lisp Lesser GNU +;;; Public License , known as the LLGPL and distributed with Clozure +;;; CL as the file "LICENSE". The LLGPL consists of a preamble and +;;; the LGPL, which is distributed with Clozure CL as the file "LGPL". +;;; Where these conflict, the preamble takes precedence. +;;; +;;; Clozure CL is referenced in the preamble as the "LIBRARY." +;;; +;;; The LLGPL is also available online at +;;; http://opensource.franz.com/preamble.html + +(in-package "CCL") + +(eval-when (:compile-toplevel :execute) + (require "NUMBER-MACROS") + (require "NUMBER-CASE-MACRO")) + +;;; make a float from hi - high 24 bits mantissa (ignore implied higher bit) +;;; lo - low 28 bits mantissa +;;; exp - take low 11 bits +;;; sign - sign(sign) => result +;;; hi result - 1 bit sign: 11 bits exp: 20 hi bits of hi arg +;;; lo result - 4 lo bits of hi arg: 28 lo bits of lo arg +;;; no error checks, no tweaks, no nuthin + +;;; sign is -1, 1, maybe zero + +(defx8632lapfunction %make-float-from-fixnums ((dfloat 12) (hi 8) (lo 4) #|(ra 0)|# (exp arg_y) (sign arg_z)) + (mov (% sign) (% imm0)) + (movl (@ dfloat (% esp)) (% arg_z)) + (sar ($ 31) (% imm0)) + (shl ($ 31) (% imm0)) ;insert sign + (shl ($ (- 20 x8632::fixnumshift)) (% exp)) + (orl (% exp) (% imm0)) ;insert biased exponent + (movl (% imm0) (@ x8632::double-float.val-high (% arg_z))) + (movl (@ hi (% esp)) (% arg_y)) + (andl ($ (ash (1- (ash 1 24)) x8632::fixnumshift)) (% arg_y)) + (movl (% arg_y) (% imm0)) + (shrl ($ (+ 4 x8632::fixnumshift)) (% imm0)) ;top 20 bits of hi + (orl (% imm0) (@ x8632::double-float.val-high (% arg_z))) ; into high word + ;; do low half + (movl (@ lo (% esp)) (% imm0)) + (sar ($ x8632::fixnumshift) (% imm0)) + (andl ($ (1- (ash 1 28))) (% imm0)) + (shl ($ (- 28 x8632::fixnumshift)) (% arg_y)) ;position low 4 bits of hi + (orl (% arg_y) (% imm0)) + (movl (% imm0) (@ x8632::double-float.value (% arg_z))) + (single-value-return 5)) + +(defx8632lapfunction %make-short-float-from-fixnums ((sfloat 8) (significand 4) #|(ra 0)|# (biased-exp arg_y) (sign arg_z)) + (movl (% sign) (% imm0)) + (movl (@ sfloat (% esp)) (% arg_z)) + (sarl ($ 31) (% imm0)) + (shll ($ 31) (% imm0)) ;insert sign + (shll ($ (- ieee-single-float-exponent-offset x8632::fixnumshift)) (% biased-exp)) + (or (% biased-exp) (% imm0)) ;insert biased exponent + (movl (% imm0) (@ x8632::single-float.value (% arg_z))) + (movl (@ significand (% esp)) (% imm0)) + (sar ($ x8632::fixnumshift) (% imm0)) + (andl ($ (1- (ash 1 ieee-single-float-hidden-bit))) (% imm0)) + (or (% imm0) (@ x8632::single-float.value (% arg_z))) + (single-value-return 4)) + +;;; Maybe we should trap - or something - on NaNs. +(defx8632lapfunction %%double-float-abs! ((n arg_y) (val arg_z)) + (get-double-float n fp1) + (put-double-float fp1 val) + (btrl ($ 31) (@ x8632::double-float.val-high (% val))) + (single-value-return)) + +(defx8632lapfunction %%short-float-abs! ((n arg_y) (val arg_z)) + (movl (@ x8632::single-float.value (% n)) (% imm0)) + (btr ($ 31) (% imm0)) + (movl (% imm0) (@ x8632::single-float.value (% val))) + (single-value-return)) + +(defx8632lapfunction %double-float-negate! ((src arg_y) (res arg_z)) + (get-double-float src fp1) + (put-double-float fp1 res) + (btcl ($ 31) (@ x8632::double-float.val-high (% res))) + (single-value-return)) + +(defx8632lapfunction %short-float-negate! ((src arg_y) (res arg_z)) + (movl (@ x8632::single-float.value (% src)) (% imm0)) + (btcl ($ 31) (% imm0)) + (movl (% imm0) (@ x8632::single-float.value (% res))) + (single-value-return)) + +;;; return hi (25 bits) lo (28 bits) exp sign +(defx8632lapfunction %integer-decode-double-float ((n arg_z)) + (mark-as-imm temp0) + (let ((imm1 temp0) + (sign 0) + (exp 4) + (lo 8) + (hi 12)) + (pushl ($ 0)) ;hi + (pushl ($ 0)) ;lo + (pushl ($ 0)) ;exp + (pushl ($ 0)) ;sign + + (movl (@ x8632::double-float.val-high (% n)) (% imm1)) + (movl ($ '1) (% arg_y)) + (movl ($ '-1) (% imm0)) + (btl ($ 31) (% imm1)) + (cmovcl (% imm0) (% arg_y)) + (movl (% arg_y) (@ sign (% esp))) + + (movl (% imm1) (% imm0)) + (andl ($ #x7ff00000) (% imm0)) ;exponent + (shrl ($ (- 20 x8632::fixnumshift)) (% imm0)) + (movl (% imm0) (@ exp (% esp))) + + (movl (@ x8632::double-float.value (% n)) (% imm0)) + (andl ($ #x000fffff) (% imm1)) ;high 20 bits of fraction + (shldl ($ 4) (% imm0) (% imm1)) ;shift in 4 bits from low word + (cmpl ($ 0) (@ exp (% esp))) + (je @denorm) + (or ($ (ash 1 (- ieee-double-float-hidden-bit 28))) (% imm1)) + @denorm + (box-fixnum imm1 arg_y) + (movl (% arg_y) (@ hi (% esp))) + + (shll ($ 4) (% imm0)) ;shift out bits included in hi + (shrl ($ x8632::fixnumshift) (% imm0)) ;and box 28 low bits + (movl (% imm0) (@ lo (% esp)))) + (mark-as-node temp0) + (set-nargs 4) + (leal (@ '4 (% esp)) (% temp0)) + (jmp-subprim .SPvalues)) + +;;; hi is 25 bits lo is 28 bits +;;; big is 32 lo, 21 hi right justified +(defx8632lapfunction make-big-53 ((hi 4) #|(ra 0)|# (lo arg_y) (big arg_z)) + (mark-as-imm temp0) + (let ((imm1 temp0)) + (movl (@ hi (% esp)) (% temp1)) + (movl (% temp1) (% imm0)) + (shll ($ (- 28 x8632::fixnumshift)) (% imm0)) + (unbox-fixnum lo imm1) + (orl (% imm0) (% imm1)) + (movl (% imm1) (@ x8632::misc-data-offset (% big))) ;low 32 bits + (movl (% temp1) (% imm0)) + (sarl ($ (+ 4 x8632::fixnumshift)) (% imm0)) + (movl (% imm0) (@ (+ 4 x8632::misc-data-offset) (% big)))) ;high 21 bits + (mark-as-node temp0) + (single-value-return 3)) + +;;; dfloat must be non-zero +(defx8632lapfunction dfloat-significand-zeros ((dfloat arg_z)) + (mark-as-imm temp0) + (let ((imm1 temp0)) + (movl (@ x8632::double-float.value (% dfloat)) (% imm0)) + (movl (@ x8632::double-float.val-high (% dfloat)) (% imm1)) + ;; shift imm1 left by count, shifting bits from imm0 in from the right + (shldl ($ (1+ ieee-double-float-exponent-width)) (% imm0) (% imm1)) + (testl (% imm1) (% imm1)) + (jz @low) + (bsrl (% imm1) (% imm0)) + (xorl ($ (1- x8632::nbits-in-word)) (% imm0)) + (jmp @done) + @low + (bsrl (% imm0) (% imm0)) + (xorl ($ (1- x8632::nbits-in-word)) (% imm0)) + ;; if we're here, the upper part of the fraction was all zeros, + ;; so add the count for those in. + (add ($ (- ieee-double-float-mantissa-width 32)) (% imm0)) + @done + (box-fixnum imm0 arg_z)) + (mark-as-node temp0) + (single-value-return)) + +;;; sfloat must be non-zero +(defx8632lapfunction sfloat-significand-zeros ((sfloat arg_z)) + (movl (@ x8632::single-float.value (% sfloat)) (% imm0)) + (shl ($ (1+ IEEE-single-float-exponent-width)) (% imm0)) + (bsrl (% imm0) (% imm0)) + (xorl ($ (1- x8632::nbits-in-word)) (% imm0)) + (box-fixnum imm0 arg_z) + (single-value-return)) + +(defx8632lapfunction %%scale-dfloat! ((dfloat 4) #|(ra 0)|# (int arg_y) (result arg_z)) + (unbox-fixnum int imm0) + (movl (@ dfloat (% esp)) (% temp0)) + (get-double-float temp0 fp1) + (shl ($ (- ieee-double-float-exponent-offset 32)) (% imm0)) + (movl ($ 0) (@ x8632::double-float.value (% result))) + (movl (% imm0) (@ x8632::double-float.val-high (% result))) + (get-double-float result fp2) + (mulsd (% fp2) (% fp1)) + (put-double-float fp1 result) + (single-value-return 3)) + +(defx8632lapfunction %%scale-sfloat! ((sfloat 4) #|(ra 0)|# (int arg_y) (result arg_z)) + (unbox-fixnum int imm0) + (movl (@ sfloat (% esp)) (% temp0)) + (get-single-float temp0 fp1) + (shl ($ ieee-single-float-exponent-offset) (% imm0)) + (movd (% imm0) (% fp2)) + (mulss (% fp2) (% fp1)) + (put-single-float fp1 arg_z) + (single-value-return 3)) + +(defx8632lapfunction %copy-double-float ((f1 arg_y) (f2 arg_z)) + (get-double-float f1 fp1) + (put-double-float fp1 f2) + (single-value-return)) + +(defx8632lapfunction %copy-short-float ((f1 arg_y) (f2 arg_z)) + (get-single-float f1 fp1) + (put-single-float fp1 f2) + (single-value-return)) + +(defx8632lapfunction %double-float-exp ((n arg_z)) + (movl (@ x8632::double-float.val-high (% n)) (% imm0)) + (shll ($ 1) (% imm0)) + (shrl ($ (1+ (- ieee-double-float-exponent-offset 32))) (% imm0)) + (box-fixnum imm0 arg_z) + (single-value-return)) + +(defx8632lapfunction set-%double-float-exp ((dfloat arg_y) (exp arg_z)) + (movl (% exp) (% temp0)) + (shll ($ (1+ (- 20 x8632::fixnumshift))) (% temp0)) + (shrl ($ 1) (% temp0)) + (movl (@ x8632::double-float.val-high (% dfloat)) (% imm0)) + (andl ($ #x800fffff) (% imm0)) + (orl (% temp0) (% imm0)) + (movl (% imm0) (@ x8632::double-float.val-high (% dfloat))) + (single-value-return)) + +(defx8632lapfunction %short-float-exp ((n arg_z)) + (movl (@ x8632::single-float.value (% n)) (% imm0)) + (shll ($ 1) (% imm0)) + (shrl ($ (1+ ieee-single-float-exponent-offset)) (% imm0)) + (box-fixnum imm0 arg_z) + (single-value-return)) + +(defx8632lapfunction set-%short-float-exp ((sfloat arg_y) (exp arg_z)) + (movl (% exp) (% temp0)) + (shll ($ (1+ (- ieee-single-float-exponent-offset x8632::fixnumshift))) (% temp0)) + (shrl ($ 1) (% temp0)) + (movl (@ x8632::single-float.value (% sfloat)) (% imm0)) + (andl ($ #x807fffff) (% imm0)) + (orl (% temp0) (% imm0)) + (movl (% imm0) (@ x8632::single-float.value (% sfloat))) + (single-value-return)) + +(defx8632lapfunction %short-float->double-float ((src arg_y) (result arg_z)) + (get-single-float src fp1) + (cvtss2sd (% fp1) (% fp1)) + (put-double-float fp1 result) + (single-value-return)) + +(defx8632lapfunction %double-float->short-float ((src arg_y) (result arg_z)) + (get-double-float src fp1) + (cvtsd2ss (% fp1) (% fp1)) + (put-single-float fp1 result) + (single-value-return)) + +(defx8632lapfunction %int-to-sfloat! ((int arg_y) (sfloat arg_z)) + (int-to-single int imm0 fp1) + (put-single-float fp1 arg_z) + (single-value-return)) + +(defx8632lapfunction %int-to-dfloat ((int arg_y) (dfloat arg_z)) + (int-to-double int imm0 fp1) + (put-double-float fp1 arg_z) + (single-value-return)) + + + + +;;; Manipulate the MXCSR. It'll fit in a fixnum, but we have to +;;; load and store it through memory. On x8664, we can hide the +;;; 32-bit MXCSR value in a fixnum on the stack; on a 32-bit x86, +;;; we might need to use a scratch location in the TCR or something. + +;;; Return the MXCSR as a fixnum +(defx8632lapfunction %get-mxcsr () + (stmxcsr (:rcontext x8632::tcr.scratch-mxcsr)) + (movl (:rcontext x8632::tcr.scratch-mxcsr) (% imm0)) + (box-fixnum imm0 arg_z) + (single-value-return)) + +;;; Store the fixnum in arg_z in the MXCSR. Just to be +;;; on the safe side, mask the arg with X86::MXCSR-WRITE-MASK, +;;; so that only known control and status bits are written to. +(defx8632lapfunction %set-mxcsr ((val arg_z)) + (unbox-fixnum val imm0) + (andl ($ x86::mxcsr-write-mask) (% imm0)) + (movl (% imm0) (:rcontext x8632::tcr.scratch-mxcsr)) + (ldmxcsr (:rcontext x8632::tcr.scratch-mxcsr)) + (single-value-return)) + + +;;; Get the bits that contain exception masks and rounding mode. + +(defun %get-mxcsr-control () + (logand x86::mxcsr-control-and-rounding-mask (the fixnum (%get-mxcsr)))) + +;;; Get the bits that describe current exceptions. +(defun %get-mxcsr-status () + (logand x86::mxcsr-status-mask (the fixnum (%get-mxcsr)))) + +;;; Set the bits that describe current exceptions, presumably to clear them. +(defun %set-mxcsr-status (arg) + (%set-mxcsr + (logior (logand x86::mxcsr-status-mask arg) + (logandc2 (%get-mxcsr) x86::mxcsr-status-mask))) + arg) + +;;; Set the bits that mask/unmask exceptions and control rounding. +;;; Clear the bits which describe current exceptions. +(defun %set-mxcsr-control (arg) + (%set-mxcsr (logand x86::mxcsr-control-and-rounding-mask arg))) + +;;; Return the MXCSR value in effect after the last ff-call. +(defx8632lapfunction %get-post-ffi-mxcsr () + (xor (% arg_z) (% arg_z)) + (movl (:rcontext x8632::tcr.ffi-exception) (%l imm0)) + (movl (%l arg_z) (:rcontext x8632::tcr.ffi-exception)) + (box-fixnum imm0 arg_z) + (single-value-return)) + +;;; The next several defuns are copied verbatim from x8664-float.lisp. +;;; It will probably be desirable to factor this code out into a new +;;; x86-float.lisp, perhaps conditionalized via #+sse2 or something. +;;; (Some day we may want to support x87 fp and we'll need +;;; x87-specific versions of these functions.) + +;;; start duplicated code + +;;; Return the status bits from the last ff-call that represent +;;; unmasked exceptions +(defun %ffi-exception-status () + (logior (%get-mxcsr-control) + (logand x86::mxcsr-status-mask (the fixnum (%get-post-ffi-mxcsr))))) + +;;; See if the binary double-float operation OP set any enabled +;;; exception bits in the mxcsr +(defun %df-check-exception-2 (operation op0 op1 fp-status) + (declare (type (unsigned-byte 6) fp-status)) + (unless (zerop fp-status) + (%set-mxcsr-status 0) + ;; Ensure that operands are heap-consed + (%fp-error-from-status fp-status + operation + (%copy-double-float op0 (%make-dfloat)) + (%copy-double-float op1 (%make-dfloat))))) + +(defun %sf-check-exception-2 (operation op0 op1 fp-status) + (declare (type (unsigned-byte 6) fp-status)) + (unless (zerop fp-status) + (%set-mxcsr-status 0) + ;; Ensure that operands are heap-consed + (%fp-error-from-status fp-status + operation + #+32-bit-target + (%copy-short-float op0 (%make-sfloat)) + #+64-bit-target op0 + #+32-bit-target + (%copy-short-float op1 (%make-sfloat)) + #+64-bit-target op1))) + +(defun %df-check-exception-1 (operation op0 fp-status) + (declare (fixnum fp-status)) + (unless (zerop fp-status) + (%set-mxcsr-status 0) + ;; Ensure that operands are heap-consed + (%fp-error-from-status fp-status + operation + (%copy-double-float op0 (%make-dfloat))))) + +(defun %sf-check-exception-1 (operation op0 fp-status) + (declare (type (unsigned-byte 6) fp-status)) + (unless (zerop fp-status) + (%set-mxcsr-status 0) + ;; Ensure that operands are heap-consed + (%fp-error-from-status fp-status + operation + #+32-bit-target + (%copy-short-float op0 (%make-sfloat)) + #+64-bit-target op0))) + + +(defun fp-condition-from-mxcsr (status-bits control-bits) + (declare (fixnum status-bits control-bits)) + (cond + ((and (logbitp x86::mxcsr-ie-bit status-bits) + (not (logbitp x86::mxcsr-im-bit control-bits))) + 'floating-point-invalid-operation) + ((and (logbitp x86::mxcsr-oe-bit status-bits) + (not (logbitp x86::mxcsr-om-bit control-bits))) + 'floating-point-overflow) + ((and (logbitp x86::mxcsr-ue-bit status-bits) + (not (logbitp x86::mxcsr-um-bit control-bits))) + 'floating-point-underflow) + ((and (logbitp x86::mxcsr-ze-bit status-bits) + (not (logbitp x86::mxcsr-zm-bit control-bits))) + 'division-by-zero) + ((and (logbitp x86::mxcsr-pe-bit status-bits) + (not (logbitp x86::mxcsr-pm-bit control-bits))) + 'floating-point-inexact))) + +(defun %fp-error-from-status (status-bits operation op0 &optional op1) + (declare (type (unsigned-byte 6) status-bits)) + (let* ((condition-class (fp-condition-from-mxcsr status-bits (%get-mxcsr-control)))) + (if condition-class + (let* ((operands (if op1 (list op0 op1) (list op0)))) + (error (make-instance condition-class + :operation operation + :operands operands)))))) + +(defvar *rounding-mode-alist* + '((:nearest . 0) (:zero . 1) (:positive . 2) (:negative . 3))) + +(defun get-fpu-mode (&optional (mode nil mode-p)) + (let* ((flags (%get-mxcsr-control))) + (declare (fixnum flags)) + (let* ((rounding-mode + (car (nth (+ (if (logbitp x86::mxcsr-rc0-bit flags) 1 0) + (if (logbitp x86::mxcsr-rc1-bit flags) 2 0)) + *rounding-mode-alist*))) + (overflow (not (logbitp x86::mxcsr-om-bit flags))) + (underflow (not (logbitp x86::mxcsr-um-bit flags))) + (division-by-zero (not (logbitp x86::mxcsr-zm-bit flags))) + (invalid (not (logbitp x86::mxcsr-im-bit flags))) + (inexact (not (logbitp x86::mxcsr-pm-bit flags)))) + (if mode-p + (ecase mode + (:rounding-mode rounding-mode) + (:overflow overflow) + (:underflow underflow) + (:division-by-zero division-by-zero) + (:invalid invalid) + (:inexact inexact)) + `(:rounding-mode ,rounding-mode + :overflow ,overflow + :underflow ,underflow + :division-by-zero ,division-by-zero + :invalid ,invalid + :inexact ,inexact))))) + +;;; did we document this? +(defun set-fpu-mode (&key (rounding-mode :nearest rounding-p) + (overflow t overflow-p) + (underflow t underflow-p) + (division-by-zero t zero-p) + (invalid t invalid-p) + (inexact t inexact-p)) + (let* ((current (%get-mxcsr-control)) + (new current)) + (declare (fixnum current new)) + (when rounding-p + (let* ((rc-bits (or + (cdr (assoc rounding-mode *rounding-mode-alist*)) + (error "Unknown rounding mode: ~s" rounding-mode)))) + (declare (fixnum rc-bits)) + (if (logbitp 0 rc-bits) + (bitsetf x86::mxcsr-rc0-bit new) + (bitclrf x86::mxcsr-rc0-bit new)) + (if (logbitp 1 rc-bits) + (bitsetf x86::mxcsr-rc1-bit new) + (bitclrf x86::mxcsr-rc1-bit new)))) + (when invalid-p + (if invalid + (bitclrf x86::mxcsr-im-bit new) + (bitsetf x86::mxcsr-im-bit new))) + (when overflow-p + (if overflow + (bitclrf x86::mxcsr-om-bit new) + (bitsetf x86::mxcsr-om-bit new))) + (when underflow-p + (if underflow + (bitclrf x86::mxcsr-um-bit new) + (bitsetf x86::mxcsr-um-bit new))) + (when zero-p + (if division-by-zero + (bitclrf x86::mxcsr-zm-bit new) + (bitsetf x86::mxcsr-zm-bit new))) + (when inexact-p + (if inexact + (bitclrf x86::mxcsr-pm-bit new) + (bitsetf x86::mxcsr-pm-bit new))) + (unless (= current new) + (%set-mxcsr-control new)) + (%get-mxcsr))) + +;;; end duplicated code + +;;; Don't we already have about 20 versions of this ? +(defx8632lapfunction %double-float-from-macptr! ((ptr 4) #|(ra 0)|# (byte-offset arg_y) (dest arg_z)) + (mark-as-imm temp0) + (let ((imm1 temp0)) + (movl (@ ptr (% esp)) (% temp1)) + (macptr-ptr temp1 imm0) + (unbox-fixnum byte-offset imm1) + (movsd (@ (% imm0) (% imm1)) (% fp1)) + (put-double-float fp1 dest)) + (mark-as-node temp0) + (single-value-return 3)) + +;;; Copy a single float pointed at by the macptr in single +;;; to a double float pointed at by the macptr in double +(defx8632lapfunction %single-float-ptr->double-float-ptr ((single arg_y) (double arg_z)) + (check-nargs 2) + (macptr-ptr single imm0) + (movss (@ (% imm0)) (% fp1)) + (cvtss2sd (% fp1) (% fp1)) + (macptr-ptr double imm0) + (movsd (% fp1) (@ (% imm0))) + (single-value-return)) + +;;; Copy a double float pointed at by the macptr in double +;;; to a single float pointed at by the macptr in single. +(defx8632lapfunction %double-float-ptr->single-float-ptr ((double arg_y) (single arg_z)) + (check-nargs 2) + (macptr-ptr double imm0) + (movsd (@ (% imm0)) (% fp1)) + (cvtsd2ss (% fp1) (% fp1)) + (macptr-ptr single imm0) + (movss (% fp1) (@ (% imm0))) + (single-value-return)) + +(defx8632lapfunction %set-ieee-single-float-from-double ((src arg_y) (macptr arg_z)) + (check-nargs 2) + (macptr-ptr macptr imm0) + (get-double-float src fp1) + (cvtsd2ss (% fp1) (% fp1)) + (movss (% fp1) (@ (% imm0))) + (single-value-return)) + +(defun host-single-float-from-unsigned-byte-32 (u32) + (let* ((f (%make-sfloat))) + (setf (uvref f x8632::single-float.value-cell) u32) + f)) + +(defun single-float-bits (f) + (uvref f x8632::single-float.value-cell)) + +(defun double-float-bits (f) + (values (uvref f target::double-float.val-high-cell) + (uvref f target::double-float.value-cell))) + +(defun double-float-from-bits (high low) + (let* ((f (%make-dfloat))) + (setf (uvref f target::double-float.val-high-cell) high + (uvref f target::double-float.value-cell) low) + f)) + +;;; Return T if n is negative, else NIL. +(defx8632lapfunction %double-float-sign ((n arg_z)) + (movl (@ x8632::double-float.val-high (% n)) (% imm0)) + (testl (% imm0) (% imm0)) + (movl ($ (target-t-value)) (% imm0)) + (movl ($ (target-nil-value)) (% arg_z)) + (cmovll (% imm0) (% arg_z)) + (single-value-return)) + +(defx8632lapfunction %short-float-sign ((n arg_z)) + (movl (@ x8632::single-float.value (% n)) (% imm0)) + (testl (% imm0) (% imm0)) + (movl ($ (target-t-value)) (% imm0)) + (movl ($ (target-nil-value)) (% arg_z)) + (cmovll (% imm0) (% arg_z)) + (single-value-return)) + +(defx8632lapfunction %double-float-sqrt! ((n arg_y) (result arg_z)) + (get-double-float n fp0) + (sqrtsd (% fp0) (% fp0)) + (put-double-float fp0 result) + (single-value-return)) + +(defx8632lapfunction %single-float-sqrt! ((n arg_y) (result arg_z)) + (get-single-float n fp0) + (sqrtss (% fp0) (% fp0)) + (put-single-float fp0 arg_z) + (single-value-return)) + + + Index: /branches/new-random/level-0/X86/X8632/x8632-hash.lisp =================================================================== --- /branches/new-random/level-0/X86/X8632/x8632-hash.lisp (revision 13309) +++ /branches/new-random/level-0/X86/X8632/x8632-hash.lisp (revision 13309) @@ -0,0 +1,127 @@ +;;; Copyright 2009 Clozure Associates +;;; This file is part of Clozure CL. +;;; +;;; Clozure CL is licensed under the terms of the Lisp Lesser GNU +;;; Public License , known as the LLGPL and distributed with Clozure +;;; CL as the file "LICENSE". The LLGPL consists of a preamble and +;;; the LGPL, which is distributed with Clozure CL as the file "LGPL". +;;; Where these conflict, the preamble takes precedence. +;;; +;;; Clozure CL is referenced in the preamble as the "LIBRARY." +;;; +;;; The LLGPL is also available online at +;;; http://opensource.franz.com/preamble.html + +(in-package "CCL") + +(eval-when (:compile-toplevel :execute) + (require "HASHENV" "ccl:xdump;hashenv")) + +;;; This should stay in LAP so that it's fast +;;; Equivalent to cl:mod when both args are positive fixnums +(defx8632lapfunction fast-mod ((number arg_y) (divisor arg_z)) + (xorl (% edx) (% edx)) ;aka temp1 + (mov (% number) (% imm0)) + (div (% divisor)) ;boxed remainder goes into edx/temp1 + (mov (% edx) (% arg_z)) + (single-value-return)) + +;; Faster mod based on Bruce Hoult's Dylan version, modified to use a +;; branch-free max. +(defx8632lapfunction fast-mod-3 ((number 4) #|(ra 0)|# (divisor arg_y) (recip arg_z)) + (std) ;temp1 now unboxed + (let ((imm1 temp1) + (n temp0)) + (movl (@ number (% esp)) (% n)) + (movl (% n) (% imm0)) + (shrl ($ target::fixnumshift) (% imm0)) ;logical shift is intentional + (mov (% recip) (% imm1)) + (mul (% imm1)) ;; -> hi word in imm1 (unboxed) + (mov (% divisor) (% imm0)) + (mul (% imm1)) ;; -> lo word in imm0 (boxed) + (subl (% imm0) (% n)) + (subl (% divisor) (% n)) + (mov (% n) (% arg_z)) + (mov (% n) (% imm0)) + (sar ($ (1- target::nbits-in-word)) (% imm0)) + (andl (% imm0) (% divisor)) + (addl (% divisor) (% arg_z))) + (xorl (% temp1) (% temp1)) + (cld) ;temp1 now boxed + (single-value-return 3)) + +(defx8632lapfunction %dfloat-hash ((key arg_z)) + (movl (@ x8632::double-float.value (% key)) (% imm0)) + (addl (@ x8632::double-float.val-high (% key)) (% imm0)) + (box-fixnum imm0 arg_z) + (single-value-return)) + +(defx8632lapfunction %sfloat-hash ((key arg_z)) + (movl (@ x8632::single-float.value (% key)) (% imm0)) + (box-fixnum imm0 arg_z) + (single-value-return)) + +(defx8632lapfunction %macptr-hash ((key arg_z)) + (movl (@ x8632::macptr.address (% key)) (% imm0)) + (box-fixnum imm0 temp0) + (shll ($ (- 24 x8632::fixnumshift)) (% temp0)) + (addl (% temp0) (% imm0)) + (movl ($ (lognot x8632::fixnummask)) (% arg_z)) + (andl (% imm0) (% arg_z)) + (single-value-return)) + +(defx8632lapfunction %bignum-hash ((key arg_z)) + (mark-as-imm temp1) + (let ((header imm0) + (offset temp1) + (ndigits temp0)) + (getvheader key header) + (header-length header ndigits) + (xorl (% offset) (% offset)) + (let ((immhash header)) + @loop + (roll ($ 13) (% immhash)) + (addl (@ x8632::misc-data-offset (% key) (% offset)) (% immhash)) + (addl ($ 4) (% offset)) + (subl ($ '1) (% ndigits)) + (jne @loop) + (box-fixnum immhash arg_z))) + (mark-as-node temp1) + (single-value-return)) + +(defx8632lapfunction %get-fwdnum () + (ref-global target::fwdnum arg_z) + (single-value-return)) + +(defx8632lapfunction %get-gc-count () + (ref-global target::gc-count arg_z) + (single-value-return)) + +;;; Setting a key in a hash-table vector needs to +;;; ensure that the vector header gets memoized as well +(defx8632lapfunction %set-hash-table-vector-key ((vector 4) #|(ra 0)|# (index arg_y) (value arg_z)) + (pop (% temp1)) ;return address + (pop (% temp0)) ;.SPset-hash-key wants arg in temp0 + (discard-reserved-frame) + (push (% temp1)) + (jmp-subprim .SPset-hash-key)) + +;;; This needs to be done out-of-line, to handle EGC memoization. +(defx8632lapfunction %set-hash-table-vector-key-conditional ((offset 8) + (vector 4) + #|(ra 0)|# + (old arg_y) + (new arg_z)) + (movl (@ offset (% esp)) (% temp0)) + (movl (@ vector (% esp)) (% temp1)) + (save-simple-frame) + (call-subprim .SPset-hash-key-conditional) + (restore-simple-frame) + (single-value-return 4)) + + +;;; Strip the tag bits to turn x into a fixnum +(defx8632lapfunction strip-tag-to-fixnum ((x arg_z)) + (andb ($ (lognot x8632::fixnummask)) (%b x)) + (single-value-return)) + Index: /branches/new-random/level-0/X86/X8632/x8632-misc.lisp =================================================================== --- /branches/new-random/level-0/X86/X8632/x8632-misc.lisp (revision 13309) +++ /branches/new-random/level-0/X86/X8632/x8632-misc.lisp (revision 13309) @@ -0,0 +1,852 @@ +;;; Copyright 2009 Clozure Associates +;;; This file is part of Clozure CL. +;;; +;;; Clozure CL is licensed under the terms of the Lisp Lesser GNU +;;; Public License , known as the LLGPL and distributed with Clozure +;;; CL as the file "LICENSE". The LLGPL consists of a preamble and +;;; the LGPL, which is distributed with Clozure CL as the file "LGPL". +;;; Where these conflict, the preamble takes precedence. +;;; +;;; Clozure CL is referenced in the preamble as the "LIBRARY." +;;; +;;; The LLGPL is also available online at +;;; http://opensource.franz.com/preamble.html + +(in-package "CCL") + +;;; Copy N bytes from pointer src, starting at byte offset src-offset, +;;; to ivector dest, starting at offset dest-offset. +;;; It's fine to leave this in lap. +;;; Depending on alignment, it might make sense to move more than +;;; a byte at a time. +;;; Does no arg checking of any kind. Really. + +;;; I went ahead and used the INC and DEC instructions here, since +;;; they're shorter than the equivalent ADD/SUB. Intel's optimization +;;; manual advises avoiding INC and DEC because they might cause +;;; dependencies on earlier instructions that set the flags. So, if +;;; these functions end up being hot, replacing the inc/dec insns +;;; might be worth a try. + +(defx8632lapfunction %copy-ptr-to-ivector ((src 12) + (src-byte-offset 8) + (dest 4) + #|(ra 0)|# + (dest-byte-offset arg_y) + (nbytes arg_z)) + (mark-as-imm temp0) + (mark-as-imm arg_y) + (let ((foreign-ptr temp0) ;raw foreign pointer + (ivector temp1) ;destination ivector + (j arg_y)) ;unboxed index into ivector + (movl (@ src (% esp)) (% temp1)) + (macptr-ptr temp1 foreign-ptr) + (movl (@ src-byte-offset (% esp)) (% temp1)) + (unbox-fixnum temp1 imm0) + (addl (% imm0) (% foreign-ptr)) ;point to starting byte in src + (movl (@ dest (% esp)) (% ivector)) + (sarl ($ x8632::fixnumshift) (% j)) ;unbox dest-byte-offset + (testl (% nbytes) (% nbytes)) + (jmp @test) + @loop + (movb (@ (% foreign-ptr)) (%b imm0)) + (incl (% foreign-ptr)) + (movb (%b imm0) (@ x8632::misc-data-offset (% ivector) (% j))) + (incl (% j)) + (subl ($ '1) (% nbytes)) + @test + (jne @loop) + (movl (% ivector) (% arg_z))) + (mark-as-node temp0) + (mark-as-node arg_y) + (single-value-return 5)) + +(defx8632lapfunction %copy-ivector-to-ptr ((src 12) + (src-byte-offset 8) + (dest 4) + #|(ra 0)|# + (dest-byte-offset arg_y) + (nbytes arg_z)) + (mark-as-imm temp0) + (mark-as-imm arg_y) + (let ((foreign-ptr temp0) ;raw foreign pointer + (ivector temp1) ;source ivector + (j arg_y)) ;unboxed index into ivector + (movl (@ dest (% esp)) (% temp1)) + (macptr-ptr temp1 foreign-ptr) + (unbox-fixnum dest-byte-offset imm0) + (addl (% imm0) (% foreign-ptr)) ;point to starting byte in dest + (movl (@ src (% esp)) (% ivector)) + (movl (@ src-byte-offset (% esp)) (% j)) + (sarl ($ x8632::fixnumshift) (% j)) ;unbox src-byte-offset + (test (% nbytes) (% nbytes)) + (jmp @test) + @loop + (movb (@ x8632::misc-data-offset (% ivector) (% j)) (%b imm0)) + (incl (% j)) + (movb (%b imm0) (@ (% foreign-ptr))) + (incl (% foreign-ptr)) + (subl ($ '1) (% nbytes)) + @test + (jne @loop) + (movl (@ dest (% esp)) (% arg_z))) + (mark-as-node temp0) + (mark-as-node arg_y) + (single-value-return 5)) + +(defx8632lapfunction %copy-ivector-to-ivector ((src 12) + (src-byte-offset 8) + (dest 4) + #|(ra 0)|# + (dest-byte-offset arg_y) + (nbytes arg_z)) + (movl (@ src (% esp)) (% temp0)) + (movl (@ src-byte-offset (% esp)) (% temp1)) + (unbox-fixnum nbytes imm0) ;will be used below + (push (% nbytes)) ;put loop counter on stack + (movl (@ (+ 4 dest) (% esp)) (% arg_z)) + (mark-as-imm temp1) + (mark-as-imm arg_y) + (sarl ($ x8632::fixnumshift) (% temp1)) ;unboxed src index + (sarl ($ x8632::fixnumshift) (% arg_y)) ;unboxed dest index + (let ((a temp0) + (i temp1) + (b arg_z) + (j arg_y)) + ;; copy nbytes starting at a[i] to b[j] + (cmpl (% b) (% a)) + (jne @front) + (cmpl (% i) (% j)) + (jg @back) + @front + (testl (% imm0) (% imm0)) ;test nbytes + (jmp @front-test) + @front-loop + (movb (@ x8632::misc-data-offset (% a) (% i)) (%b imm0)) + (movb (%b imm0) (@ x8632::misc-data-offset (% b) (% j))) + (incl (% i)) + (incl (% j)) + (subl ($ '1) (@ (% esp))) + @front-test + (jne @front-loop) + (jmp @done) + @back + ;; unboxed nbytes in imm0 + (addl (% imm0) (% i)) + (addl (% imm0) (% j)) + (testl (% imm0) (% imm0)) + (jmp @back-test) + @back-loop + (decl (% i)) + (decl (% j)) + (movb (@ x8632::misc-data-offset (% a) (% i)) (%b imm0)) + (movb (%b imm0) (@ x8632::misc-data-offset (% b) (% j))) + (subl ($ '1) (@ (% esp))) + @back-test + (jne @back-loop) + @done + ;; dest already in arg_z + (addl ($ 4) (% esp)) ;pop nbytes + (mark-as-node temp1) + (mark-as-node arg_y) + (single-value-return 5))) + +(defx8632lapfunction %copy-gvector-to-gvector ((src 12) + (src-element 8) + (dest 4) + #|(ra 0)|# + (dest-element arg_y) + (nelements arg_z)) + (let ((a temp0) + (i imm0) + (b arg_z) + (j arg_y) + (val temp1)) + (movl (% nelements) (% val)) ;will be used below + (push (% nelements)) ;loop counter on stack (use ebp?) + (movl (@ (+ 4 src) (% esp)) (% a)) + (movl (@ (+ 4 src-element) (% esp)) (% i)) + (movl (@ (+ 4 dest) (% esp)) (% b)) + ;; j/arg_y already set + (cmpl (% a) (% b)) + (jne @front) + (rcmp (% i) (% j)) + (jl @back) + @front + (testl (% val) (% val)) ;test nelements + (jmp @front-test) + @front-loop + (movl (@ x8632::misc-data-offset (% a) (% i)) (% val)) + (movl (% val) (@ x8632::misc-data-offset (% b) (% j))) + (addl ($ '1) (% i)) + (addl ($ '1) (% j)) + (subl ($ '1) (@ (% esp))) + @front-test + (jne @front-loop) + (jmp @done) + @back + ;; nelements in val (from above) + (addl (% val) (% i)) + (addl (% val) (% j)) + (testl (% val) (% val)) + (jmp @back-test) + @back-loop + (subl ($ '1) (% i)) + (subl ($ '1) (% j)) + (movl (@ x8632::misc-data-offset (% a) (% i)) (% val)) + (movl (% val) (@ x8632::misc-data-offset (% b) (% j))) + (subl ($ '1) (@ (% esp))) + @back-test + (jne @back-loop) + @done + ;; dest already in arg_z + (addl ($ 4) (% esp)) ;pop loop counter + (single-value-return 5))) + +(defx8632lapfunction %heap-bytes-allocated () + (movl (@ (% :rcontext) x8632::tcr.save-allocptr) (% temp1)) + (movl (@ (% :rcontext) x8632::tcr.last-allocptr) (% temp0)) + (cmpl ($ -8) (% temp1)) ;void_allocptr + (movq (@ (% :rcontext) x8632::tcr.total-bytes-allocated-low) (% mm0)) + (jz @go) + (movl (% temp0) (% arg_y)) + (subl (% temp1) (% temp0)) + (testl (% arg_y) (% arg_y)) + (jz @go) + (movd (% temp0) (% mm1)) + (paddq (% mm1) (% mm0)) + @go + (jmp-subprim .SPmakeu64)) + +(defx8632lapfunction values () + (:arglist (&rest values)) + (save-frame-variable-arg-count) + (push-argregs) + (jmp-subprim .SPnvalret)) + +(defx8632lapfunction rdtsc () + (mark-as-imm temp1) ;aka edx + (:byte #x0f) ;two-byte rdtsc opcode + (:byte #x31) ;is #x0f #x31 + (box-fixnum imm0 arg_z) + (mark-as-node temp1) + (single-value-return)) + +;;; Return all 64 bits of the time-stamp counter as an unsigned integer. +(defx8632lapfunction rdtsc64 () + (mark-as-imm temp1) ;aka edx + (:byte #x0f) ;two-byte rdtsc opcode + (:byte #x31) ;is #x0f #x31 + (movd (% eax) (% mm0)) + (movd (% edx) (% mm1)) + (psllq ($ 32) (% mm1)) + (por (% mm1) (% mm0)) + (mark-as-node temp1) + (jmp-subprim .SPmakeu64)) + +;;; It would be nice if (%setf-macptr macptr (ash (the fixnum value) +;;; ash::fixnumshift)) would do this inline. + +(defx8632lapfunction %setf-macptr-to-object ((macptr arg_y) (object arg_z)) + (check-nargs 2) + (trap-unless-typecode= macptr x8632::subtag-macptr) + (movl (% object) (@ x8632::macptr.address (% macptr))) + (single-value-return)) + +(defx8632lapfunction %fixnum-from-macptr ((macptr arg_z)) + (check-nargs 1) + (trap-unless-typecode= arg_z x8632::subtag-macptr) + (movl (@ x8632::macptr.address (% arg_z)) (% imm0)) + (mark-as-imm temp0) + (let ((imm1 temp0)) + (trap-unless-lisptag= imm0 x8632::tag-fixnum imm1)) + (mark-as-node temp0) + (movl (% imm0) (% arg_z)) + (single-value-return)) + +(defx8632lapfunction %%get-unsigned-longlong ((ptr arg_y) (offset arg_z)) + (trap-unless-typecode= ptr x8632::subtag-macptr) + (mark-as-imm temp0) + (let ((imm1 temp0)) + (macptr-ptr ptr imm1) + (unbox-fixnum offset imm0) + (movq (@ (% imm1) (% imm0)) (% mm0))) + (mark-as-node temp0) + (jmp-subprim .SPmakeu64)) + +(defx8632lapfunction %%get-signed-longlong ((ptr arg_y) (offset arg_z)) + (trap-unless-typecode= ptr x8632::subtag-macptr) + (mark-as-imm temp0) + (let ((imm1 temp0)) + (macptr-ptr ptr imm1) + (unbox-fixnum offset imm0) + (movq (@ (% imm1) (% imm0)) (% mm0))) + (mark-as-node temp0) + (jmp-subprim .SPmakes64)) + +(defx8632lapfunction %%set-unsigned-longlong ((ptr 4) + #|(ra 0)|# + (offset arg_y) + (val arg_z)) + (let ((rptr temp0) + (imm1 temp1) + (ptr-in-frame -4)) + (save-stackargs-frame 1) + (movl (@ ptr-in-frame (% ebp)) (% rptr)) + (trap-unless-typecode= rptr x8632::subtag-macptr) + (call-subprim .SPgetu64) + (macptr-ptr rptr imm0) + (mark-as-imm temp1) + (unbox-fixnum offset imm1) + (movq (% mm0) (@ (% imm0) (% imm1))) + (mark-as-node temp1) + (restore-simple-frame) + (single-value-return))) + +(defx8632lapfunction %%set-signed-longlong ((ptr 4) + #|(ra 0)|# + (offset arg_y) + (val arg_z)) + (let ((rptr temp0) + (imm1 temp1) + (ptr-in-frame -4)) + (save-stackargs-frame 1) + (movl (@ ptr-in-frame (% ebp)) (% rptr)) + (trap-unless-typecode= rptr x8632::subtag-macptr) + (call-subprim .SPgets64) + (macptr-ptr rptr imm0) + (mark-as-imm temp1) + (unbox-fixnum offset imm1) + (movq (% mm0) (@ (% imm0) (% imm1))) + (mark-as-node temp1) + (restore-simple-frame) + (single-value-return))) + +(defx8632lapfunction interrupt-level () + (movl (@ (% :rcontext) x8632::tcr.tlb-pointer) (% imm0)) + (movl (@ x8632::interrupt-level-binding-index (% imm0)) (% arg_z)) + (single-value-return)) + +(defx8632lapfunction set-interrupt-level ((new arg_z)) + (movl (@ (% :rcontext) x8632::tcr.tlb-pointer) (% imm0)) + (trap-unless-fixnum new) + (movl (% new) (@ x8632::interrupt-level-binding-index (% imm0))) + (single-value-return)) + +(defx8632lapfunction %current-tcr () + (movl (@ (% :rcontext) x8632::tcr.linear) (% arg_z)) + (single-value-return)) + +(defx8632lapfunction %tcr-toplevel-function ((tcr arg_z)) + (check-nargs 1) + (movl (@ x8632::tcr.vs-area (% tcr)) (% temp0)) + (movl (@ x8632::area.high (% temp0)) (% imm0)) ;bottom of vstack + (cmpl (% tcr) (@ (% :rcontext) x8632::tcr.linear)) + (jz @myself) + (cmpl (% imm0) (@ x8632::area.active (% temp0))) + (jmp @finish) + @myself + (cmpl (% imm0) (% esp)) + @finish + (movl ($ (target-nil-value)) (% arg_z)) + (cmovnel (@ (- x8632::node-size) (% imm0)) (% arg_z)) + (single-value-return)) + +(defx8632lapfunction %set-tcr-toplevel-function ((tcr arg_y) (fun arg_z)) + (check-nargs 2) + (movl (@ x8632::tcr.vs-area (% tcr)) (% temp0)) + (movl (@ x8632::area.high (% temp0)) (% imm0)) + (cmpl (% tcr) (@ (% :rcontext) x8632::tcr.linear)) + (jz @myself) + (cmpl (% imm0) (@ x8632::area.active (% temp0))) ;vstack empty? + (jmp @room) + @myself + (cmpl (% imm0) (% esp)) + @room + (leal (@ (- x8632::node-size) (% imm0)) (% imm0)) + (movl ($ 0) (@ (% imm0))) + (jne @have-room) + (movl (% imm0) (@ x8632::area.active (% temp0))) + (movl (% imm0) (@ x8632::tcr.save-vsp (% tcr))) + (jmp @have-room) + @have-room + (movl (% fun) (@ (% imm0))) + (single-value-return)) + +;;; This needs to be done out-of-line, to handle EGC memoization. +(defx8632lapfunction %store-node-conditional ((offset 8) + (object 4) + #|(ra 0)|# + (old arg_y) + (new arg_z)) + (movl (@ offset (% esp)) (% temp0)) + (movl (@ object (% esp)) (% temp1)) + (save-simple-frame) + (call-subprim .SPstore-node-conditional) + (restore-simple-frame) + (single-value-return 4)) + +(defx8632lapfunction %store-immediate-conditional ((offset 8) + (object 4) + #|(ra 0)|# + (old arg_y) + (new arg_z)) + (mark-as-imm temp0) + (let ((imm1 temp0) + (robject temp1)) + (movl (@ offset (% esp)) (% imm1)) + (sarl ($ x8632::fixnumshift) (% imm1)) + (movl (@ object (% esp)) (% robject)) + @again + (movl (@ (% robject) (% imm1)) (% eax)) + (cmpl (% eax) (% old)) + (jne @lose) + (lock) + (cmpxchgl (% new) (@ (% robject) (% imm1))) + (jne @again) + (movl ($ (target-t-value)) (% arg_z)) + (mark-as-node temp0) + (single-value-return 4) + @lose + (movl ($ (target-nil-value)) (% arg_z)) + (mark-as-node temp0) + (single-value-return 4))) + +(defx8632lapfunction set-%gcable-macptrs% ((ptr arg_z)) + @again + (movl (@ (+ (target-nil-value) (x8632::kernel-global gcable-pointers))) (% eax)) + (movl (% eax) (@ x8632::xmacptr.link (% ptr))) + (lock) + (cmpxchgl (% ptr) (@ (+ (target-nil-value) (x8632::kernel-global gcable-pointers)))) + (jne @again) + (single-value-return)) + +;;; Atomically increment or decrement the gc-inhibit-count kernel-global +;;; (It's decremented if it's currently negative, incremented otherwise.) +(defx8632lapfunction %lock-gc-lock () + @again + (movl (@ (+ (target-nil-value) (x8632::kernel-global gc-inhibit-count))) (% eax)) + (lea (@ '-1 (% eax)) (% temp0)) + (lea (@ '1 (% eax)) (% arg_z)) + (test (% eax) (% eax)) + (cmovsl (% temp0) (% arg_z)) + (lock) + (cmpxchgl (% arg_z) (@ (+ (target-nil-value) (x8632::kernel-global gc-inhibit-count)))) + (jnz @again) + (single-value-return)) + +;;; Atomically decrement or increment the gc-inhibit-count kernel-global +;;; (It's incremented if it's currently negative, incremented otherwise.) +;;; If it's incremented from -1 to 0, try to GC (maybe just a little.) +(defx8632lapfunction %unlock-gc-lock () + @again + (movl (@ (+ (target-nil-value) (x8632::kernel-global gc-inhibit-count))) + (% eax)) + (lea (@ '1 (% eax)) (% temp0)) + (cmpl ($ -1) (% eax)) + (lea (@ '-1 (% eax)) (% arg_z)) + (cmovlel (% temp0) (% arg_z)) + (lock) + (cmpxchgl (% arg_z) (@ (+ (target-nil-value) (x8632::kernel-global gc-inhibit-count)))) + (jne @again) + (cmpl ($ '-1) (% eax)) + (jne @done) + ;; The GC tried to run while it was inhibited. Unless something else + ;; has just inhibited it, it should be possible to GC now. + (mov ($ arch::gc-trap-function-immediate-gc) (% imm0)) + (uuo-gc-trap) + @done + (single-value-return)) + +(defx8632lapfunction %atomic-incf-node ((by 4) #|(ra 0)|# (node arg_y) (disp arg_z)) + (check-nargs 3) + (mark-as-imm temp0) + (let ((imm1 temp0) + (rby temp1)) + (movl (@ by (% esp)) (% rby)) + (unbox-fixnum disp imm1) + @again + (movl (@ (% node) (% imm1)) (% eax)) + (lea (@ (% eax) (% rby)) (% arg_z)) + (lock) + (cmpxchgl (% arg_z) (@ (% node) (% imm1))) + (jne @again)) + (mark-as-node temp0) + (single-value-return 3)) + +(defx8632lapfunction %atomic-incf-ptr ((ptr arg_z)) + (mark-as-imm temp0) + (mark-as-imm temp1) + (let ((imm1 temp0) + (imm2 temp1)) + (macptr-ptr ptr imm2) + @again + (movl (@ (% imm2)) (% eax)) + (lea (@ 1 (% eax)) (% imm1)) + (lock) + (cmpxchgl (% imm1) (@ (% imm2))) + (jne @again) + (box-fixnum imm1 arg_z)) + (mark-as-node temp0) + (mark-as-node temp1) + (single-value-return)) + +(defx8632lapfunction %atomic-incf-ptr-by ((ptr arg_y) (by arg_z)) + (mark-as-imm temp0) + (mark-as-imm temp1) + (let ((imm1 temp0) + (imm2 temp1)) + (macptr-ptr ptr imm2) + @again + (movl (@ (% imm2)) (% eax)) + (unbox-fixnum by imm1) + (add (% eax) (% imm1)) + (lock) + (cmpxchgl (% imm1) (@ (% imm2))) + (jnz @again) + (box-fixnum imm1 arg_z)) + (mark-as-node temp0) + (mark-as-node temp1) + (single-value-return)) + +(defx8632lapfunction %atomic-decf-ptr ((ptr arg_z)) + (mark-as-imm temp0) + (mark-as-imm temp1) + (let ((imm1 temp0) + (imm2 temp1)) + (macptr-ptr ptr imm2) + @again + (movl (@ (% imm2)) (% eax)) + (lea (@ -1 (% eax)) (% imm1)) + (lock) + (cmpxchgl (% imm1) (@ (% imm2))) + (jne @again) + (box-fixnum imm1 arg_z)) + (mark-as-node temp0) + (mark-as-node temp1) + (single-value-return)) + +(defx8632lapfunction %atomic-decf-ptr-if-positive ((ptr arg_z)) + (mark-as-imm temp0) + (mark-as-imm temp1) + (let ((imm1 temp0) + (imm2 temp1)) + (macptr-ptr ptr imm2) + @again + (movl (@ (% imm2)) (% eax)) + (testl (% eax) (% eax)) + (lea (@ -1 (% eax)) (% imm1)) + (jz @done) + (lock) + (cmpxchgl (% imm1) (@ (% imm2))) + (jnz @again) + @done + (box-fixnum imm1 arg_z)) + (mark-as-node temp0) + (mark-as-node temp1) + (single-value-return)) + +(defx8632lapfunction %atomic-swap-ptr ((ptr arg_y) (newval arg_z)) + (mark-as-imm temp0) + (let ((imm1 temp0)) + (macptr-ptr arg_y imm1) + (unbox-fixnum newval imm0) + (lock) + (xchgl (% imm0) (@ (% imm1))) + (box-fixnum imm0 arg_z)) + (mark-as-node temp0) + (single-value-return)) + +;;; Try to store the fixnum NEWVAL at PTR, if and only if the old value +;;; was equal to OLDVAL. Return the old value +(defx8632lapfunction %ptr-store-conditional ((ptr 4) #|(ra 0)|# (expected-oldval arg_y) (newval arg_z)) + (mark-as-imm temp1) + (let ((imm2 temp1)) + (movl (@ ptr (% esp)) (% temp0)) + (macptr-ptr temp0 imm2) + (mark-as-imm temp0) + (let ((imm1 temp0)) + @again + (movl (@ (% imm2)) (% imm0)) + (box-fixnum imm0 imm0) + (cmpl (% imm0) (% expected-oldval)) + (jne @done) + (unbox-fixnum newval imm1) + (lock) + (cmpxchgl (% imm1) (@ (% imm2))) + (jne @again) + @done + (movl (% imm0) (% arg_z))) + (mark-as-node temp0)) + (mark-as-node temp1) + (single-value-return 3)) + +(defx8632lapfunction %ptr-store-fixnum-conditional ((ptr 4) #|(ra 0)|# (expected-oldval arg_y) (newval arg_z)) + (mark-as-imm temp0) + (let ((address temp0)) + (movl (@ ptr (% esp)) (% temp1)) + (macptr-ptr temp1 address) + @again + (movl (@ (% address)) (% imm0)) + (cmpl (% imm0) (% expected-oldval)) + (jne @done) + (lock) + (cmpxchgl (% newval) (@ (% address))) + (jne @again) + @done + (movl (% imm0) (% arg_z))) + (mark-as-node temp0) + (single-value-return 3)) + +(defx8632lapfunction xchgl ((newval arg_y) (ptr arg_z)) + (unbox-fixnum newval imm0) + (macptr-ptr ptr arg_y) ;better be aligned + (xchgl (% imm0) (@ (% arg_y))) + (box-fixnum imm0 arg_z) + (single-value-return)) + +(defx8632lapfunction %macptr->dead-macptr ((macptr arg_z)) + (check-nargs 1) + (movb ($ x8632::subtag-dead-macptr) (@ x8632::misc-subtag-offset (% macptr))) + (single-value-return)) + +;;; %%apply-in-frame + +(defx8632lapfunction %%save-application ((flags arg_y) (fd arg_z)) + (unbox-fixnum fd imm0) + (movd (% imm0) (% mm0)) + (unbox-fixnum flags imm0) + (orl ($ arch::gc-trap-function-save-application) (% imm0)) + (uuo-gc-trap) + (single-value-return)) + +(defx8632lapfunction %misc-address-fixnum ((misc-object arg_z)) + (check-nargs 1) + (lea (@ x8632::misc-data-offset (% misc-object)) (% arg_z)) + (single-value-return)) + +(defx8632lapfunction fudge-heap-pointer ((ptr 4) #|(ra 0)|# (subtype arg_y) (len arg_z)) + (check-nargs 3) + (mark-as-imm temp0) + (let ((imm1 temp0)) + (movl (@ ptr (% esp)) (% temp1)) + (macptr-ptr temp1 imm1) ; address in macptr + (lea (@ 9 (% imm1)) (% imm0)) ; 2 for delta + 7 for alignment + (andb ($ -8) (%b imm0)) ; Clear low three bits to align + (subl (% imm0) (% imm1)) ; imm1 = -delta + (negw (%w imm1)) + (movw (%w imm1) (@ -2 (% imm0))) ; save delta halfword + (unbox-fixnum subtype imm1) ; subtype at low end of imm1 + (shll ($ (- x8632::num-subtag-bits x8632::fixnum-shift)) (% len)) + (orl (% len) (% imm1)) + (movl (% imm1) (@ (% imm0))) ; store subtype & length + (lea (@ x8632::fulltag-misc (% imm0)) (% arg_z))) ; tag it, return it + (mark-as-node temp0) + (single-value-return 3)) + +(defx8632lapfunction %%make-disposable ((ptr arg_y) (vector arg_z)) + (check-nargs 2) + (mark-as-imm temp0) + (let ((imm1 temp0)) + (lea (@ (- x8632::fulltag-misc) (% vector)) (% imm0)) ; imm0 is addr = vect less tag + (movzwl (@ -2 (% imm0)) (% imm1)) ; get delta + (subl (% imm1) (% imm0)) ; vector addr (less tag) - delta is orig addr + (movl (% imm0) (@ x8632::macptr.address (% ptr)))) + (mark-as-node temp0) + (single-value-return)) + +(defx8632lapfunction %vect-data-to-macptr ((vect arg_y) (ptr arg_z)) + (lea (@ x8632::misc-data-offset (% vect)) (% imm0)) + (movl (% imm0) (@ x8632::macptr.address (% ptr))) + (single-value-return)) + +;;; Sadly, we have no NVRs on x8632. +(defun get-saved-register-values () + (values)) + +(defx8632lapfunction %current-db-link () + (movl (@ (% :rcontext) x8632::tcr.db-link) (% arg_z)) + (single-value-return)) + +(defx8632lapfunction %no-thread-local-binding-marker () + (movl ($ x8632::subtag-no-thread-local-binding) (% arg_z)) + (single-value-return)) + +(defx8632lapfunction pending-user-interrupt () + (xorl (% temp0) (% temp0)) + (ref-global x8632::intflag arg_z) + ;; If another signal happens now, it will get ignored, same as if it happened + ;; before whatever signal is in arg_z. But then these are async signals, so + ;; who can be sure it didn't actually happen just before... + (set-global temp0 x8632::intflag) + (single-value-return)) + +(defx8632lapfunction debug-trap-with-string ((arg arg_z)) + (check-nargs 1) + (uuo-error-debug-trap-with-string) + (single-value-return)) + +(defx8632lapfunction %safe-get-ptr ((src arg_y) (dest arg_z)) + (check-nargs 2) + (save-simple-frame) + (macptr-ptr src imm0) + (leal (@ (:^ done) (% fn)) (% ra0)) + (movl (% imm0) (@ (% :rcontext) x8632::tcr.safe-ref-address)) + (movl (@ (% imm0)) (% imm0)) + (jmp done) + (:tra done) + (recover-fn) + (movl ($ 0) (@ (% :rcontext) x8632::tcr.safe-ref-address)) + (movl (% imm0) (@ x8632::macptr.address (% dest))) + (restore-simple-frame) + (single-value-return)) + +(defx8632lapfunction %%tcr-interrupt ((target arg_z)) + (check-nargs 1) + (ud2a) + (:byte 4) + (box-fixnum imm0 arg_z) + (single-value-return)) + +(defx8632lapfunction %suspend-tcr ((target arg_z)) + (check-nargs 1) + (ud2a) + (:byte 5) + (movzbl (%b imm0) (%l imm0)) + (testl (%l imm0) (%l imm0)) + (movl ($ (target-nil-value)) (%l arg_z)) + (cmovnel (@ (+ target::t-offset target::symbol.vcell) (% arg_z)) (%l arg_z)) + (single-value-return)) + +(defx8632lapfunction %suspend-other-threads () + (check-nargs 0) + (ud2a) + (:byte 6) + (movl ($ (target-nil-value)) (%l arg_z)) + (single-value-return)) + +(defx8632lapfunction %resume-tcr ((target arg_z)) + (check-nargs 1) + (ud2a) + (:byte 7) + (movzbl (%b imm0) (%l imm0)) + (testl (%l imm0) (%l imm0)) + (movl ($ (target-nil-value)) (%l arg_z)) + (cmovnel (@ (+ target::t-offset target::symbol.vcell) (% arg_z)) (%l arg_z)) + (single-value-return)) + +(defx8632lapfunction %resume-other-threads () + (check-nargs 0) + (ud2a) + (:byte 8) + (movl ($ (target-nil-value)) (%l arg_z)) + (single-value-return)) + + +(defx8632lapfunction %kill-tcr ((target arg_z)) + (check-nargs 1) + (ud2a) + (:byte 9) + (testb (%b imm0) (%b imm0)) + (movl ($ (target-nil-value)) (%l arg_z)) + (cmovnel (@ (+ target::t-offset target::symbol.vcell) (% arg_z)) (%l arg_z)) + (single-value-return)) + +(defx8632lapfunction %get-spin-lock ((p arg_z)) + (check-nargs 1) + (save-simple-frame) + (push (% arg_z)) + @again + (mark-as-imm temp1) + (movl (@ -4 (% ebp)) (% arg_z)) + (macptr-ptr arg_z temp1) + (movl (@ '*spin-lock-tries* (% fn)) (% arg_y)) + (movl (@ '*spin-lock-timeouts* (% fn)) (% arg_z)) + (movl (@ target::symbol.vcell (% arg_y)) (% arg_y)) + (movl (@ (% :rcontext) x8632::tcr.linear) (% temp0)) + @try-swap + (xorl (% eax) (% eax)) + (lock) + (cmpxchgl (% temp0) (@ (% temp1))) + (je @done) + @spin + (pause) + (cmpl ($ 0) (@ (% temp1))) + (je @try-swap) + (subl ($ '1) (% arg_y)) + (jne @spin) + @wait + (addl ($ x8632::fixnumone) (@ x8632::symbol.vcell (% arg_z))) + (mark-as-node temp1) + (call-symbol yield 0) + (jmp @again) + @done + (mark-as-node temp1) + (movl (@ -4 (% ebp)) (% arg_z)) + (restore-simple-frame) + (single-value-return)) + +;; tbd +(defx8632lapfunction %%apply-in-frame-proto () + (hlt)) + +(defx8632lapfunction %atomic-pop-static-cons () + @again + (movl (@ (+ (target-nil-value) (x8632::kernel-global static-conses))) (% eax)) + (cmpl ($ (target-nil-value)) (% eax)) + (jz @lose) + (%cdr eax temp0) + (lock) + (cmpxchgl (% temp0) (@ (+ (target-nil-value) (x8632::kernel-global static-conses)))) + (jnz @again) + (lock) + (subl ($ '1) (@ (+ (target-nil-value) (x8632::kernel-global free-static-conses)))) + @lose + (movl (% eax) (% arg_z)) + (single-value-return)) + + + +(defx8632lapfunction %staticp ((x arg_z)) + (check-nargs 1) + (ref-global static-cons-area temp0) + (movl (% x) (% imm0)) + (movl ($ (target-nil-value)) (% arg_z)) + (subl (@ target::area.low (% temp0)) (% imm0)) + (shrl ($ target::dnode-shift) (% imm0)) + (mark-as-imm temp1) + (movl (@ target::area.ndnodes (% temp0)) (% temp1)) + (subl (% imm0) (% temp1)) + (lea (@ 128 (% temp1)) (% temp1)) + (leal (@ (% temp1) target::fixnumone) (% temp1)) + (cmoval (% temp1) (% arg_z)) + (mark-as-node temp1) + (single-value-return)) + +(defx8632lapfunction %static-inverse-cons ((n arg_z)) + (check-nargs 1) + (subl ($ '128) (% arg_z)) + (ref-global static-cons-area temp0) + (movl (@ target::area.high (% temp0)) (% imm0)) + (subl (% arg_z) (% imm0)) + (subl (% arg_z) (% imm0)) + (lea (@ x8632::fulltag-cons (% imm0)) (% arg_z)) + (single-value-return)) + +;;; Get the thread-specific value of %fs. +(defx8632lapfunction %get-fs-register () + (xorl (% imm0) (% imm0)) + (:byte #x66) ;movw %fs,%ax + (:byte #x8c) + (:byte #xe0) + (box-fixnum imm0 arg_z) + (single-value-return)) + +(defx8632lapfunction %get-gs-register () + (xorl (% imm0) (% imm0)) + (:byte #x66) ;movw %gs,%ax + (:byte #x8c) + (:byte #xe8) + (box-fixnum imm0 arg_z) + (single-value-return)) + Index: /branches/new-random/level-0/X86/X8632/x8632-numbers.lisp =================================================================== --- /branches/new-random/level-0/X86/X8632/x8632-numbers.lisp (revision 13309) +++ /branches/new-random/level-0/X86/X8632/x8632-numbers.lisp (revision 13309) @@ -0,0 +1,220 @@ +;;; Copyright 2009 Clozure Associates +;;; This file is part of Clozure CL. +;;; +;;; Clozure CL is licensed under the terms of the Lisp Lesser GNU +;;; Public License , known as the LLGPL and distributed with Clozure +;;; CL as the file "LICENSE". The LLGPL consists of a preamble and +;;; the LGPL, which is distributed with Clozure CL as the file "LGPL". +;;; Where these conflict, the preamble takes precedence. +;;; +;;; Clozure CL is referenced in the preamble as the "LIBRARY." +;;; +;;; The LLGPL is also available online at +;;; http://opensource.franz.com/preamble.html + +(in-package "CCL") + +(defx8632lapfunction %fixnum-signum ((number arg_z)) + (mov ($ '-1) (% temp0)) + (mov ($ '1) (% temp1)) + (test (% number) (% number)) + (cmovs (% temp0) (% arg_z)) + (cmovns (% temp1) (% arg_z)) + (single-value-return)) + +;;; see %logcount. +(defx86lapfunction %ilogcount ((number arg_z)) + (mark-as-imm temp0) + (let ((rshift imm0) + (temp temp0)) + (unbox-fixnum number rshift) + (xor (% arg_z) (% arg_z)) + (test (% rshift) (% rshift)) + (jmp @test) + @next + (lea (@ -1 (% rshift)) (% temp)) + (and (% temp) (% rshift)) ;sets flags + (lea (@ '1 (% arg_z)) (% arg_z)) ;doesn't set flags + @test + (jne @next)) + (mark-as-node temp0) + (single-value-return)) + +;;; might be able to get away with not marking ecx as imm. +(defx8632lapfunction %iash ((number arg_y) (count arg_z)) + (mark-as-imm ecx) ;aka temp0 + (unbox-fixnum count ecx) + (test (% count) (% count)) + (jge @left) + (negb (% cl)) + (unbox-fixnum number imm0) + (sar (% cl) (% imm0)) + (box-fixnum imm0 arg_z) + (mark-as-node ecx) + (single-value-return) + @left + (shl (% cl) (% number)) + (movl (% number) (% arg_z)) + (mark-as-node ecx) + (single-value-return)) + +(defparameter *double-float-zero* 0.0d0) +(defparameter *short-float-zero* 0.0s0) + +(defx8632lapfunction %sfloat-hwords ((sfloat arg_z)) + (movl (% esp) (% temp0)) + (movzwl (@ (+ 2 x8632::misc-data-offset) (% sfloat)) (% imm0)) + (box-fixnum imm0 temp1) + (pushl (% temp1)) ;high + (movzwl (@ x8632::misc-data-offset (% sfloat)) (% imm0)) + (box-fixnum imm0 temp1) + (pushl (% temp1)) ;low + (set-nargs 2) + (jmp-subprim .SPvalues)) + +(defx8632lapfunction %fixnum-intlen ((number arg_z)) + (mark-as-imm temp0) + (let ((imm1 temp0)) + (unbox-fixnum arg_z imm0) + (mov (% imm0) (% imm1)) + (not (% imm1)) + (test (% imm0) (% imm0)) + (cmovs (% imm1) (% imm0)) + (bsrl (% imm0) (% imm0)) + (setne (%b imm1)) + (addb (%b imm1) (%b imm0)) + (box-fixnum imm0 arg_z)) + (mark-as-node temp0) + (single-value-return)) + +;;; Caller guarantees that result fits in a fixnum. +(defx8632lapfunction %truncate-double-float->fixnum ((arg arg_z)) + (get-double-float arg fp1) + (cvttsd2si (% fp1) (% imm0)) + (box-fixnum imm0 arg_z) + (single-value-return)) + +(defx8632lapfunction %truncate-short-float->fixnum ((arg arg_z)) + (get-single-float arg fp1) + (cvttss2si (% fp1) (% imm0)) + (box-fixnum imm0 arg_z) + (single-value-return)) + +;;; DOES round to even +(defx8632lapfunction %round-nearest-double-float->fixnum ((arg arg_z)) + (get-double-float arg fp1) + (cvtsd2si (% fp1) (% imm0)) + (box-fixnum imm0 arg_z) + (single-value-return)) + +(defx8632lapfunction %round-nearest-short-float->fixnum ((arg arg_z)) + (get-single-float arg fp1) + (cvtss2si (% fp1) (% imm0)) + (box-fixnum imm0 arg_z) + (single-value-return)) + +;;; We'll get a SIGFPE if divisor is 0. +(defx8632lapfunction %fixnum-truncate ((dividend arg_y) (divisor arg_z)) + (mark-as-imm temp0) + (mark-as-imm temp1) + (let ((imm2 temp0) + (imm1 temp1)) ;edx + (unbox-fixnum dividend imm0) + (unbox-fixnum divisor imm2) + (cltd) ;edx:eax = sign_extend(eax) + (idivl (% imm2)) + (box-fixnum imm0 arg_z) ;quotient + (box-fixnum imm1 arg_y)) ;remainder + (mark-as-node temp0) + (mark-as-node temp1) + (movl (% esp) (% temp0)) + (push (% arg_z)) + (push (% arg_y)) + (set-nargs 2) + (jmp-subprim .SPvalues)) + +(defx8632lapfunction called-for-mv-p () + (movl (@ x8632::lisp-frame.return-address (% ebp)) (% imm0)) + (cmpl (% imm0) (@ (+ (target-nil-value) (x8632::kernel-global ret1valaddr)))) + (movl ($ (target-t-value)) (% imm0)) + (movl ($ (target-nil-value)) (% arg_z)) + (cmove (% imm0) (% arg_z)) + (single-value-return)) + +(defx8632lapfunction %next-random-pair ((high arg_y) (low arg_z)) + ;; high: (unsigned-byte 15) + ;; low: (unsigned-byte 16) + (unbox-fixnum low imm0) + ;; clear most significant bit + (shll ($ (1+ (- 16 x8632::fixnumshift))) (% high)) + (shrl ($ 1) (% high)) + (orl (% high) (% imm0)) + (mark-as-imm edx) + (movl ($ 48271) (% edx)) + (mul (% edx)) + (mark-as-node edx) + (movl ($ (- #x10000)) (% high)) ;#xffff0000 + (andl (% imm0) (% high)) + (shrl ($ (- 16 x8632::fixnumshift)) (% high)) + (shll ($ 16) (% imm0)) + (shrl ($ (- 16 x8632::fixnumshift)) (% imm0)) + (movl (% imm0) (% low)) + (movl (% esp) (% temp0)) + (push (% high)) + (push (% low)) + (set-nargs 2) + (jmp-subprim .SPvalues)) + +;;; n1 and n2 must be positive (esp non zero) +(defx86lapfunction %fixnum-gcd ((boxed-u arg_y) (boxed-v arg_z)) + (mark-as-imm temp0) + (mark-as-imm temp1) + (let ((u imm0) + (v temp1) + (k temp0)) ;temp0 = ecx + (xorl (% k) (% k)) + (bsfl (% boxed-u) (% u)) + (bsfl (% boxed-v) (% v)) + (rcmp (% u) (% v)) + (cmovlel (%l u) (%l k)) + (cmovgl (%l v) (%l k)) + (unbox-fixnum boxed-u u) + (unbox-fixnum boxed-v v) + (subb ($ x8632::fixnumshift) (%b k)) + (jz @start) + (shrl (% cl) (% u)) + (shrl (% cl) (% v)) + @start + ;; At least one of u or v is odd at this point + @loop + ;; if u is even, shift it right one bit + (testb ($ 1) (%b u)) + (jne @u-odd) + (shrl ($ 1) (% u)) + (jmp @test) + @u-odd + ;; if v is even, shift it right one bit + (testb ($ 1) (%b v)) + (jne @both-odd) + (shrl ($ 1) (% v)) + (jmp @test-u) + @both-odd + (cmpl (% v) (% u)) + (jb @v>u) + (subl (% v) (% u)) + (shrl ($ 1) (% u)) + (jmp @test) + @v>u + (subl (% u) (% v)) + (shrl ($ 1) (% v)) + @test-u + (testl (% u) (% u)) + @test + (ja @loop) + (shll (% cl) (% v)) + (movb ($ 0) (% cl)) + (box-fixnum v arg_z)) + (mark-as-node temp0) + (mark-as-node temp1) + (single-value-return)) + Index: /branches/new-random/level-0/X86/X8632/x8632-pred.lisp =================================================================== --- /branches/new-random/level-0/X86/X8632/x8632-pred.lisp (revision 13309) +++ /branches/new-random/level-0/X86/X8632/x8632-pred.lisp (revision 13309) @@ -0,0 +1,199 @@ +;;; Copyright 2009 Clozure Associates +;;; This file is part of Clozure CL. +;;; +;;; Clozure CL is licensed under the terms of the Lisp Lesser GNU +;;; Public License , known as the LLGPL and distributed with Clozure +;;; CL as the file "LICENSE". The LLGPL consists of a preamble and +;;; the LGPL, which is distributed with Clozure CL as the file "LGPL". +;;; Where these conflict, the preamble takes precedence. +;;; +;;; Clozure CL is referenced in the preamble as the "LIBRARY." +;;; +;;; The LLGPL is also available online at +;;; http://opensource.franz.com/preamble.html + +(in-package "CCL") + +(eval-when (:compile-toplevel :execute) + (require "X86-LAPMACROS")) + +(defx8632lapfunction eql ((x arg_y) (y arg_z)) + "Return T if OBJ1 and OBJ2 represent either the same object or +numbers with the same type and value." + (check-nargs 2) + @top + @tail + (cmpl (% x) (% y)) + (je @win) + (movl (% x) (% imm0)) + (andb ($ x8632::fulltagmask) (% al)) + (movb (% arg_z.b) (% ah)) + (andb ($ x8632::fulltagmask) (% ah)) + (cmpb (% al) (% ah)) + (jnz @lose) + (cmpb ($ x8632::fulltag-misc) (% al)) + (jnz @lose) + (cmpb ($ x8632::fulltag-misc) (% ah)) + (jnz @lose) + ;; Objects are both of tag-misc. Headers must match exactly; + ;; dispatch on subtag. + (getvheader x imm0) + ;;(getvheader y imm1) + (cmpb ($ x8632::subtag-macptr) (% imm0.b)) + (je @macptr) ; will need to check subtag of %y + (cmp (% imm0) (@ x8632::misc-header-offset (% y))) + (jne @lose) + (cmpb ($ x8632::subtag-bignum) (% imm0.b)) + (je @bignum) + (cmpb ($ x8632::subtag-single-float) (% imm0.b)) + (je @one-unboxed-word) + (cmpb ($ x8632::subtag-double-float) (% imm0.b)) + (je @double-float) + (cmpb ($ x8632::subtag-complex) (% imm0.b)) + (je @complex) + (cmpb ($ x8632::subtag-ratio) (% imm0.b)) + (je @ratio) + @lose + (movl ($ (target-nil-value)) (% arg_z)) + (single-value-return) + @double-float + ;; use UCOMISD here, maybe? + (movl (@ x8632::double-float.val-high (% x)) (% imm0)) + (cmpl (% imm0) (@ x8632::double-float.val-high (% y))) + (jne @lose) + (movl (@ x8632::double-float.value (% x)) (% imm0)) + (cmpl (% imm0) (@ x8632::double-float.value (% y))) + (jne @lose) + (movl ($ (target-t-value)) (% arg_z)) + (single-value-return) + @macptr + (cmpb ($ x8632::subtag-macptr) (@ x8632::misc-subtag-offset (% y))) + (jne @lose) + @one-unboxed-word + (movl (@ x8632::misc-data-offset (% x)) (% imm0)) + @test + (cmpl (% imm0) (@ x8632::misc-data-offset (% y))) + (movl ($ (target-t-value)) (%l imm0)) + (lea (@ (- x8632::t-offset) (% imm0)) (% arg_z)) + (cmovel (%l imm0) (%l arg_z)) + (single-value-return) + @win + (movl ($ (target-t-value)) (% arg_z)) + (single-value-return) + @ratio + @complex + ;; Have either a ratio or a complex. In either case, corresponding + ;; elements of both objects must be EQL. Recurse on the first + ;; elements. If true, tail-call on the second, else fail. + (save-simple-frame) + (pushl (@ x8632::ratio.denom (% x))) ; aka complex.imagpart + (pushl (@ x8632::ratio.denom (% y))) + (movl (@ x8632::ratio.numer (% x)) (% x)) ; aka complex.realpart + (movl (@ x8632::ratio.numer (% y)) (% y)) ; aka complex.realpart + (:talign 5) + (call @top) + (recover-fn) + (cmp-reg-to-nil arg_z) + (pop (% y)) + (pop (% x)) + (restore-simple-frame) + (jnz @tail) + ;; lose, again + (movl ($ (target-nil-value)) (% arg_z)) + (single-value-return) + @bignum + ;; Way back when, we got x's header into imm0. We know that y's + ;; header is identical. Use the element-count from imm0 to control + ;; the loop. There's no such thing as a 0-element bignum, so the + ;; loop must always execute at least once. + (header-length imm0 temp0) + (xor (% temp1) (% temp1)) + @bignum-next + (movl (@ x8632::misc-data-offset (% x) (% temp1)) (% imm0)) + (cmpl (@ x8632::misc-data-offset (% y) (% temp1)) (% imm0)) + (jne @lose) + (addl ($ '1) (% temp1)) + (sub ($ '1) (% temp0)) + (jnz @bignum-next) + (movl ($ (target-t-value)) (% arg_z)) + (single-value-return)) + +(defx8632lapfunction equal ((x arg_y) (y arg_z)) + "Return T if X and Y are EQL or if they are structured components + whose elements are EQUAL. Strings and bit-vectors are EQUAL if they + are the same length and have identical components. Other arrays must be + EQ to be EQUAL. Pathnames are EQUAL if their components are." + (check-nargs 2) + @top + @tail + (cmp (% x) (% y)) + (je @win) + (movl (% x) (% imm0)) + (andb ($ x8632::fulltagmask) (% al)) + (movb (% arg_z.b) (% ah)) + (andb ($ x8632::fulltagmask) (% ah)) + (cmpb (% al) (% ah)) + (jnz @lose) + (cmpb ($ x8632::fulltag-cons) (% imm0.b)) + (je @cons) + (cmpb ($ x8632::fulltag-misc) (% imm0.b)) + (je @misc) + @lose + (movl ($ (target-nil-value)) (% arg_z)) + (single-value-return) + @win + (movl ($ (target-t-value)) (% arg_z)) + (single-value-return) + @cons + ;; If either X or Y is NIL, lose. + (cmp-reg-to-nil x) + (je @lose) + (cmp-reg-to-nil y) + (je @lose) + ;; Check to see if the CARs are EQ. If so, we can avoid saving + ;; context, and can just tail call ourselves on the CDRs. + (%car x temp0) + (%car y temp1) + (cmpl (% temp0) (% temp1)) + (jne @recurse) + (%cdr x x) + (%cdr y y) + (jmp @tail) + @recurse + (save-simple-frame) + (pushl (@ x8632::cons.cdr (% x))) + (pushl (@ x8632::cons.cdr (% y))) + (movl (% temp0) (% x)) + (movl (% temp1) (% y)) + (:talign 5) + (call @top) + (recover-fn) + (cmp-reg-to-nil arg_z) + (pop (% y)) + (pop (% x)) + (restore-simple-frame) + (jnz @top) + (movl ($ (target-nil-value)) (% arg_z)) + (single-value-return) + @misc + ;; Both objects are uvectors of some sort. Try EQL; if that fails, + ;; call HAIRY-EQUAL. + (save-simple-frame) + (pushl (% x)) + (pushl (% y)) + (call-symbol eql 2) + (cmp-reg-to-nil arg_z) + (jne @won-with-eql) + (popl (% y)) + (popl (% x)) + (restore-simple-frame) + (jump-symbol hairy-equal 2) + @won-with-eql + (restore-simple-frame) ; discards pushed args + (movl ($ (target-t-value)) (% arg_z)) + (single-value-return)) + +(defx8632lapfunction %lisp-lowbyte-ref ((thing arg_z)) + (box-fixnum thing arg_z) + (andl ($ '#xff) (%l arg_z)) + (single-value-return)) Index: /branches/new-random/level-0/X86/X8632/x8632-symbol.lisp =================================================================== --- /branches/new-random/level-0/X86/X8632/x8632-symbol.lisp (revision 13309) +++ /branches/new-random/level-0/X86/X8632/x8632-symbol.lisp (revision 13309) @@ -0,0 +1,142 @@ +;;; Copyright 2009 Clozure Associates +;;; This file is part of Clozure CL. +;;; +;;; Clozure CL is licensed under the terms of the Lisp Lesser GNU +;;; Public License , known as the LLGPL and distributed with Clozure +;;; CL as the file "LICENSE". The LLGPL consists of a preamble and +;;; the LGPL, which is distributed with Clozure CL as the file "LGPL". +;;; Where these conflict, the preamble takes precedence. +;;; +;;; Clozure CL is referenced in the preamble as the "LIBRARY." +;;; +;;; The LLGPL is also available online at +;;; http://opensource.franz.com/preamble.html + +(in-package "CCL") + +(eval-when (:compile-toplevel :execute) + (require "X8632-ARCH") + (require "X86-LAPMACROS")) + +;;; This assumes that macros & special-operators +;;; have something that's not FUNCTIONP in their +;;; function-cells. It also assumes that NIL +;;; isn't a true symbol, but that NILSYM is. +(defx8632lapfunction %function ((sym arg_z)) + (check-nargs 1) + (let ((symaddr temp0)) + (movl ($ (+ (target-nil-value) x8632::nilsym-offset)) (% symaddr)) + (cmp-reg-to-nil sym) + (cmovne (% sym) (% symaddr)) + (trap-unless-typecode= symaddr x8632::subtag-symbol) + (movl (% sym) (% arg_y)) + (movl (@ x8632::symbol.fcell (% symaddr)) (% arg_z)) + (extract-typecode arg_z imm0) + (cmpb ($ x8632::subtag-function) (%b imm0)) + (je.pt @ok) + (uuo-error-udf (% arg_y)) + @ok + (single-value-return))) + +;;; Traps unless sym is NIL or some other symbol. If NIL, return +;;; nilsym +(defx8632lapfunction %symbol->symptr ((sym arg_z)) + (let ((tag imm0)) + (movl ($ (+ (target-nil-value) x8632::nilsym-offset)) (% tag)) + (cmp-reg-to-nil sym) + (cmove (% tag) (% sym)) + (je :done) + (trap-unless-typecode= sym x8632::subtag-symbol) + :done + (single-value-return))) + +;;; If symptr is NILSYM, return NIL; else typecheck and return symptr +(defx8632lapfunction %symptr->symbol ((symptr arg_z)) + (cmpl ($ (+ (target-nil-value) x8632::nilsym-offset)) (% symptr)) + (jne @typecheck) + (movl ($ (target-nil-value)) (% arg_z)) + (single-value-return) + @typecheck + (trap-unless-typecode= symptr x8632::subtag-symbol) + (single-value-return)) + +(defx8632lapfunction %symptr-value ((symptr arg_z)) + (jmp-subprim .SPspecref)) + +(defx8632lapfunction %set-symptr-value ((symptr arg_y) (val arg_z)) + (jmp-subprim .SPspecset)) + +;;; This gets a tagged symbol as an argument. +;;; If there's no thread-local binding, it should return +;;; the underlying symbol vector as a first return value. +(defx8632lapfunction %symptr-binding-address ((symptr arg_z)) + (movl (@ x8632::symbol.binding-index (% symptr)) (% arg_y)) + (rcmp (% arg_y) (:rcontext x8632::tcr.tlb-limit)) + (movl (:rcontext x8632::tcr.tlb-pointer) (% temp0)) + (jae @sym) + (cmpb ($ x8632::subtag-no-thread-local-binding) (@ (% temp0) (% arg_y))) + (je @sym) + (shl ($ x8632::word-shift) (% arg_y)) + (push (% temp0)) + (push (% arg_y)) + (set-nargs 2) + (lea (@ '2 (% esp)) (% temp0)) + (jmp-subprim .SPvalues) + @sym + (push (% arg_z)) + (pushl ($ '#.x8632::symbol.vcell)) + (set-nargs 2) + (lea (@ '2 (% esp)) (% temp0)) + (jmp-subprim .SPvalues)) + +(defx8632lapfunction %tcr-binding-location ((tcr arg_y) (sym arg_z)) + (movl (@ x8632::symbol.binding-index (% sym)) (% temp0)) + (movl ($ (target-nil-value)) (% arg_z)) + (rcmp (% temp0) (@ x8632::tcr.tlb-limit (% tcr))) + (movl (@ x8632::tcr.tlb-pointer (% tcr)) (% arg_y)) + (jae @done) + (lea (@ (% arg_y) (% temp0)) (% arg_y)) + ;; We're little-endian, so the tag is at the EA with no + ;; displacement + (cmpb ($ x8632::subtag-no-thread-local-binding) (@ (% arg_y))) + (cmovnel (% arg_y) (% arg_z)) + @done + (single-value-return)) + +(defx86lapfunction %pname-hash ((str arg_y) (len arg_z)) + (let ((accum imm0) + (offset temp0)) + (xor (% offset) (% offset)) + (xor (% accum) (% accum)) + (testl (% len) (% len)) + (jz.pn @done) + @loop8 + (roll ($ 5) (%l accum)) + (xorl (@ x8632::misc-data-offset (% str) (% offset)) (%l accum)) + (addl ($ '1) (% offset)) + (subl ($ '1) (% len)) + (jnz @loop8) + (shll ($ 5) (% accum)) + (shrl ($ (- 5 x8632::fixnumshift)) (% accum)) + (movl (% accum) (% arg_z)) + @done + (single-value-return))) + +(defx8632lapfunction %string-hash ((start 4) #|(ra 0)|# (str arg_y) (len arg_z)) + (let ((accum imm0) + (offset temp0)) + (movl (@ start (% esp)) (% offset)) + (xorl (% accum) (% accum)) + (testl (% len) (% len)) + (jz @done) + @loop8 + (roll ($ 5) (%l accum)) + (xorl (@ x8632::misc-data-offset (% str) (% offset)) (%l accum)) + (addl ($ '1) (% offset)) + (subl ($ '1) (% len)) + (jnz @loop8) + (shll ($ 5) (% accum)) + (shrl ($ (- 5 x8632::fixnumshift)) (% accum)) + (movl (% accum) (% arg_z)) + @done + (single-value-return 3))) Index: /branches/new-random/level-0/X86/X8632/x8632-utils.lisp =================================================================== --- /branches/new-random/level-0/X86/X8632/x8632-utils.lisp (revision 13309) +++ /branches/new-random/level-0/X86/X8632/x8632-utils.lisp (revision 13309) @@ -0,0 +1,503 @@ +;;; Copyright 2009 Clozure Associates +;;; This file is part of Clozure CL. +;;; +;;; Clozure CL is licensed under the terms of the Lisp Lesser GNU +;;; Public License , known as the LLGPL and distributed with Clozure +;;; CL as the file "LICENSE". The LLGPL consists of a preamble and +;;; the LGPL, which is distributed with Clozure CL as the file "LGPL". +;;; Where these conflict, the preamble takes precedence. +;;; +;;; Clozure CL is referenced in the preamble as the "LIBRARY." +;;; +;;; The LLGPL is also available online at +;;; http://opensource.franz.com/preamble.html + +(in-package "CCL") + +(defx8632lapfunction %address-of ((arg arg_z)) + ;; %address-of a fixnum is a fixnum, just for spite. + ;; %address-of anything else is the address of that thing as an integer. + (testb ($ x8632::fixnummask) (%b arg)) + (je @done) + (movl (% arg) (% imm0)) + (jmp-subprim .SPmakeu32) + @done + (single-value-return)) + +;;; "areas" are fixnum-tagged and, for the most part, so are their +;;; contents. + +;;; The nilreg-relative global all-areas is a doubly-linked-list header +;;; that describes nothing. Its successor describes the current/active +;;; dynamic heap. Return a fixnum which "points to" that area, after +;;; ensuring that the "active" pointers associated with the current thread's +;;; stacks are correct. + +(defx8632lapfunction %normalize-areas () + (let ((address temp0) + (temp temp1)) + + ; update active pointer for tsp area. + (movl (:rcontext x8632::tcr.ts-area) (% address)) + (movl (:rcontext x8632::tcr.save-tsp) (% temp)) + (movl (% temp) (@ x8632::area.active (% address))) + + ;; Update active pointer for vsp area. + (movl (:rcontext x8632::tcr.vs-area) (% address)) + (movl (% esp) (@ x8632::area.active (% address))) + + (ref-global all-areas arg_z) + (movl (@ x8632::area.succ (% arg_z)) (% arg_z)) + + (single-value-return))) + +(defx8632lapfunction %active-dynamic-area () + (ref-global all-areas arg_z) + (movl (@ x8632::area.succ (% arg_z)) (% arg_z)) + (single-value-return)) + +(defx8632lapfunction %object-in-stack-area-p ((object arg_y) (area arg_z)) + (rcmp (% object) (@ x8632::area.active (% area))) + (movl ($ nil) (% temp0)) + (movl ($ t) (% imm0)) + (jb @done) + (rcmp (% object) (@ x8632::area.high (% area))) + (cmovbl (% imm0) (% temp0)) + @done + (movl (% temp0) (% arg_z)) + (single-value-return)) + +(defx8632lapfunction %object-in-heap-area-p ((object arg_y) (area arg_z)) + (rcmp (% object) (@ x8632::area.low (% area))) + (movl ($ nil) (% temp0)) + (movl ($ t) (% imm0)) + (jb @done) + (rcmp (% object) (@ x8632::area.active (% area))) + (cmovbl (% imm0) (% temp0)) + @done + (movl (% temp0) (% arg_z)) + (single-value-return)) + +;;; In these heap-walking functions, all other threads should be +;;; suspended; the only consing that should happen is any consing +;;; that the function (the "f" argument) does when we call it. +;;; +;;; We can therefore basically walk dnode-aligned addresses (but we +;;; have to be careful, especially in the %WALK-DYNAMIC-AREA case, +;;; to hold onto only tagged pointers when we call the funtion, since +;;; consing by the called function could cause a gc). + +(defx8632lapfunction walk-static-area ((a arg_y) (f arg_z)) + (let ((obj temp0) + (fun -4) + (limit -8)) + (save-simple-frame) + (push (% f)) + (pushl (@ x8632::area.active (% a))) + (movl (@ x8632::area.low (% a)) (% obj)) + (jmp @test) + @loop + (movb (@ (% obj)) (% imm0.b)) + (andb ($ x8632::fulltagmask) (% imm0.b)) + (cmpb ($ x8632::fulltag-immheader) (% imm0.b)) + (je @misc) + (cmpb ($ x8632::fulltag-nodeheader) (% imm0.b)) + (je @misc) + ;; not a header, so must be a cons + (add ($ x8632::fulltag-cons) (% obj)) + (mov (% obj) (% arg_z)) + (set-nargs 1) + (push (% obj)) + (:talign 5) + (call (@ fun (% ebp))) + (recover-fn) + (pop (% obj)) + (add ($ (- x8632::cons.size x8632::fulltag-cons)) (% obj)) + (jmp @test) + @misc + (lea (@ x8632::fulltag-misc (% obj)) (% arg_z)) + (set-nargs 1) + (push (% obj)) + (:talign 5) + (call (@ fun (% ebp))) + (recover-fn) + (pop (% obj)) + (mov (@ (% obj)) (% imm0)) + (andb ($ x8632::fulltagmask) (% imm0.b)) + (cmpb ($ x8632::fulltag-nodeheader) (% imm0.b)) + (mov (@ (% obj)) (% imm0)) + (je @32) + (cmpb ($ x8632::max-32-bit-ivector-subtag) (% imm0.b)) + (jbe @32) + (cmpb ($ x8632::max-8-bit-ivector-subtag) (% imm0.b)) + (jbe @8) + (cmpb ($ x8632::max-16-bit-ivector-subtag) (% imm0.b)) + (jbe @16) + (cmpb ($ x8632::subtag-double-float-vector) (% imm0.b)) + (je @double-float) + ;; if we get here, it's a bit vector + (shrl ($ x8632::num-subtag-bits) (% imm0)) + (add ($ 7) (% imm0)) + (shrl ($ 3) (% imm0)) + (jmp @uvector-next) + @double-float + (shrl ($ x8632::num-subtag-bits) (% imm0)) + (shll ($ 3) (% imm0)) + (jmp @uvector-next) + @8 + (shrl ($ x8632::num-subtag-bits) (% imm0)) + (jmp @uvector-next) + @16 + (shrl ($ x8632::num-subtag-bits) (% imm0)) + (shll ($ 1) (% imm0)) + (jmp @uvector-next) + @32 + (shrl ($ x8632::num-subtag-bits) (% imm0)) + (shll ($ 2) (% imm0)) + ;; size of obj in bytes (without header or alignment padding) + ;; is in imm0 + @uvector-next + (add ($ (+ x8632::node-size (1- x8632::dnode-size))) (% imm0)) + (andb ($ (lognot (1- x8632::dnode-size))) (% imm0.b)) + (add (% imm0) (% obj)) + @test + (cmpl (@ limit (% ebp)) (% obj)) + (jb @loop) + (movl ($ (target-nil-value)) (% arg_z)) + (restore-simple-frame) + (single-value-return))) + +;;; This walks the active "dynamic" area. Objects might be moving around +;;; while we're doing this, so we have to be a lot more careful than we +;;; are when walking a static area. +;;; There are a couple of approaches to termination: +;;; a) Allocate a "sentinel" cons, and terminate when we run into it. +;;; b) Check the area limit (which is changing if we're consing) and +;;; terminate when we hit it. +;;; (b) loses if the function conses. (a) conses. I can't think of anything +;;; better than (a). +;;; This, of course, assumes that any GC we're doing does in-place compaction +;;; (or at least preserves the relative order of objects in the heap.) + +(defx8632lapfunction %walk-dynamic-area ((a arg_y) (f arg_z)) + (let ((obj temp0) + (fun -4) + (sentinel -8)) + (save-simple-frame) + (push (% f)) + (subl ($ (- x8632::cons.size x8632::fulltag-cons)) + (:rcontext x8632::tcr.save-allocptr)) + (movl (:rcontext x8632::tcr.save-allocptr) (% allocptr)) ;aka temp0 + (cmpl (:rcontext x8632::tcr.save-allocbase) (% allocptr)) + (ja @ok) + (uuo-alloc) + @ok + (andb ($ (lognot x8632::fulltagmask)) + (:rcontext x8632::tcr.save-allocptr)) + (push (% allocptr)) ;sentinel + (ref-global tenured-area a) + (movl (@ x8632::area.low (% a)) (% obj)) + (jmp @test) + @loop + (movb (@ (% obj)) (% imm0.b)) + (andb ($ x8632::fulltagmask) (% imm0.b)) + (cmpb ($ x8632::fulltag-immheader) (% imm0.b)) + (je @misc) + (cmpb ($ x8632::fulltag-nodeheader) (% imm0.b)) + (je @misc) + ;; not a header, so must be a cons + (add ($ x8632::fulltag-cons) (% obj)) + (mov (% obj) (% arg_z)) + (set-nargs 1) + (push (% obj)) + (:talign 5) + (call (@ fun (% ebp))) + (recover-fn) + (pop (% obj)) + (add ($ (- x8632::cons.size x8632::fulltag-cons)) (% obj)) + (jmp @test) + @misc + (add ($ x8632::fulltag-misc) (% obj)) + (mov (% obj) (% arg_z)) + (set-nargs 1) + (push (% obj)) + (:talign 5) + (call (@ fun (% ebp))) + (recover-fn) + (pop (% obj)) + (sub ($ x8632::fulltag-misc) (% obj)) + (mov (@ (% obj)) (% imm0)) + (andb ($ x8632::fulltagmask) (% imm0.b)) + (cmpb ($ x8632::fulltag-nodeheader) (% imm0.b)) + (mov (@ (% obj)) (% imm0)) + (je @32) + (cmpb ($ x8632::max-32-bit-ivector-subtag) (% imm0.b)) + (jbe @32) + (cmpb ($ x8632::max-8-bit-ivector-subtag) (% imm0.b)) + (jbe @8) + (cmpb ($ x8632::max-16-bit-ivector-subtag) (% imm0.b)) + (jbe @16) + (cmpb ($ x8632::subtag-double-float-vector) (% imm0.b)) + (je @double-float) + ;; if we get here, it's a bit vector + (shrl ($ x8632::num-subtag-bits) (% imm0)) + (add ($ 7) (% imm0)) + (shrl ($ 3) (% imm0)) + (jmp @uvector-next) + @double-float + (shrl ($ x8632::num-subtag-bits) (% imm0)) + (shll ($ 3) (% imm0)) + (jmp @uvector-next) + @8 + (shrl ($ x8632::num-subtag-bits) (% imm0)) + (jmp @uvector-next) + @16 + (shrl ($ x8632::num-subtag-bits) (% imm0)) + (shll ($ 1) (% imm0)) + (jmp @uvector-next) + @32 + (shrl ($ x8632::num-subtag-bits) (% imm0)) + (shll ($ 2) (% imm0)) + ;; size of obj in bytes (without header or alignment padding) + ;; is in imm0 + @uvector-next + (add ($ (+ x8632::node-size (1- x8632::dnode-size))) (% imm0)) + (andb ($ (lognot (1- x8632::dnode-size))) (% imm0.b)) + (add (% imm0) (% obj)) + @test + (cmpl (@ sentinel (% ebp)) (% obj)) + (jb @loop) + @done + (movl ($ (target-nil-value)) (% arg_z)) + (restore-simple-frame) + (single-value-return))) + +;;; xxx duplicated in level-0/x86-utils.lisp +(defun walk-dynamic-area (area func) + (with-other-threads-suspended + (%walk-dynamic-area area func))) + +(defx8632lapfunction %class-of-instance ((i arg_z)) + (svref i instance.class-wrapper arg_z) + (svref arg_z %wrapper-class arg_z) + (single-value-return)) + +(defx8632lapfunction class-of ((x arg_z)) + (check-nargs 1) + (extract-fulltag x imm0) + (cmpb ($ x8632::fulltag-misc) (% imm0.b)) + (movl (% arg_z) (% imm0)) + (jne @have-tag) + (extract-subtag x imm0) + @have-tag + (movl (@ '*class-table* (% fn)) (% temp1)) + (movl (@ x8632::symbol.vcell (% temp1)) (% temp1)) + (movzbl (% imm0.b) (% imm0)) + (movl (@ x8632::misc-data-offset (% temp1) (% imm0) 4) (% temp0)) + (cmpl ($ (target-nil-value)) (% temp0)) + (je @bad) + ;; functionp? + (extract-typecode temp0 imm0) + (cmpb ($ x8632::subtag-function) (% imm0.b)) + (jne @ret) + ;; jump to the function + (set-nargs 1) + (jmp (% temp0)) + @bad + (load-constant no-class-error fname) + (set-nargs 1) + (jmp (@ x8632::symbol.fcell (% fname))) + @ret + (movl (% temp0) (% arg_z)) ;return frob from table + (single-value-return)) + +(defx8632lapfunction gc () + (check-nargs 0) + (movl ($ arch::gc-trap-function-gc) (% imm0)) + (uuo-gc-trap) + (movl ($ nil) (% arg_z)) + (single-value-return)) + +(defx8632lapfunction full-gccount () + (ref-global tenured-area arg_z) + (test (% arg_z) (% arg_z)) + (cmovel (@ (+ (target-nil-value) (x8632::%kernel-global 'gc-count))) (% arg_z)) + (cmovnel (@ x8632::area.gc-count (% arg_z)) (% arg_z)) + (single-value-return)) + +(defx8632lapfunction egc ((arg arg_z)) + "Enable the EGC if arg is non-nil, disables the EGC otherwise. Return +the previous enabled status. Although this function is thread-safe (in +the sense that calls to it are serialized), it doesn't make a whole lot +of sense to be turning the EGC on and off from multiple threads ..." + (check-nargs 1) + (clrl imm0) + (cmp-reg-to-nil arg) + (setne (% imm0.b)) + (movd (% imm0) (% mm0)) + (movl ($ arch::gc-trap-function-egc-control) (% imm0)) + (uuo-gc-trap) + (single-value-return)) + +(defx8632lapfunction %configure-egc ((e0size 4) + #|(ra 0)|# + (e1size arg_y) + (e2size arg_z)) + (check-nargs 3) + (movl (@ e0size (% esp)) (% temp0)) + (movl ($ arch::gc-trap-function-configure-egc) (% imm0)) + (uuo-gc-trap) + (single-value-return 3)) + +(defx8632lapfunction purify () + (check-nargs 0) + (movl ($ arch::gc-trap-function-purify) (% imm0)) + (uuo-gc-trap) + (movl ($ nil) (% arg_z)) + (single-value-return)) + +(defx8632lapfunction impurify () + (check-nargs 0) + (movl ($ arch::gc-trap-function-impurify) (% imm0)) + (uuo-gc-trap) + (movl ($ nil) (% arg_z)) + (single-value-return)) + +(defx8632lapfunction lisp-heap-gc-threshold () + "Return the value of the kernel variable that specifies the amount +of free space to leave in the heap after full GC." + (check-nargs 0) + (movl ($ arch::gc-trap-function-get-lisp-heap-threshold) (% imm0)) + (uuo-gc-trap) + (jmp-subprim .SPmakeu32)) + +(defx8632lapfunction set-lisp-heap-gc-threshold ((new arg_z)) + "Set the value of the kernel variable that specifies the amount of free +space to leave in the heap after full GC to new-value, which should be a +non-negative fixnum. Returns the value of that kernel variable (which may +be somewhat larger than what was specified)." + (check-nargs 1) + (save-simple-frame) + (call-subprim .SPgetu32) + (movd (% imm0) (% mm0)) + (movl ($ arch::gc-trap-function-set-lisp-heap-threshold) (% imm0)) + (uuo-gc-trap) + (restore-simple-frame) + (jmp-subprim .SPmakeu32)) + +(defx8632lapfunction use-lisp-heap-gc-threshold () + "Try to grow or shrink lisp's heap space, so that the free space is (approximately) equal to the current heap threshold. Return NIL" + (check-nargs 0) + (movl ($ arch::gc-trap-function-use-lisp-heap-threshold) (% imm0)) + (uuo-gc-trap) + (movl ($ (target-nil-value)) (%l arg_z)) + (single-value-return)) + +(defx8632lapfunction freeze () + "Do a full GC, then consider all heap-allocated objects which survive to be non-relocatable." + (movl ($ arch::gc-trap-function-freeze) (% imm0)) + (uuo-gc-trap) + (jmp-subprim .SPmakeu32)) + +(defx8632lapfunction flash-freeze () + "Like FREEZE, without the GC." + (movl ($ arch::gc-trap-function-flash-freeze) (% imm0)) + (uuo-gc-trap) + (jmp-subprim .SPmakeu32)) + +(defx8632lapfunction %watch ((uvector arg_z)) + (check-nargs 1) + (movl ($ arch::watch-trap-function-watch) (%l imm0)) + (uuo-watch-trap) + (single-value-return)) + +(defx8632lapfunction %unwatch ((watched arg_y) (new arg_z)) + (check-nargs 2) + (movl ($ arch::watch-trap-function-unwatch) (%l imm0)) + (uuo-watch-trap) + (single-value-return)) + +(defx8632lapfunction %allocate-list ((initial-element arg_y) (nconses arg_z)) + (check-nargs 2) + (save-simple-frame) + (ud2a) + (:byte 10) + (push (% arg_z)) + (push (% allocptr)) + (set-nargs 2) + (jmp-subprim .SPnvalret)) + +(defx8632lapfunction %ensure-static-conses () + (check-nargs 0) + (movl ($ arch::gc-trap-function-ensure-static-conses) (% imm0)) + (uuo-gc-trap) + (movl ($ (target-nil-value)) (% arg_z)) + (single-value-return)) + +;;; offset is a fixnum, one of the x8632::kernel-import-xxx constants. +;;; Returns that kernel import, a fixnum. +(defx8632lapfunction %kernel-import ((offset arg_z)) + (unbox-fixnum arg_z imm0) + (addl (@ (+ (target-nil-value) (x8632::%kernel-global 'kernel-imports))) (% imm0)) + (movl (@ (% imm0)) (% imm0)) + (box-fixnum imm0 arg_z) + (single-value-return)) + +(defx8632lapfunction %get-unboxed-ptr ((macptr arg_z)) + (macptr-ptr arg_z imm0) + (movl (@ (% imm0)) (% arg_z)) + (single-value-return)) + +(defx8632lapfunction %revive-macptr ((p arg_z)) + (movb ($ x8632::subtag-macptr) (@ x8632::misc-subtag-offset (% p))) + (single-value-return)) + +(defx86lapfunction %macptr-type ((p arg_z)) + (check-nargs 1) + (trap-unless-typecode= p x8632::subtag-macptr) + (svref p x8632::macptr.type-cell imm0) + (box-fixnum imm0 arg_z) + (single-value-return)) + +(defx86lapfunction %macptr-domain ((p arg_z)) + (check-nargs 1) + (trap-unless-typecode= p x8632::subtag-macptr) + (svref p x8632::macptr.domain-cell imm0) + (box-fixnum imm0 arg_z) + (single-value-return)) + +(defx8632lapfunction %set-macptr-type ((p arg_y) (new arg_z)) + (check-nargs 2) + (trap-unless-typecode= p x8632::subtag-macptr) + (unbox-fixnum new imm0) + (svset p x8632::macptr.type-cell imm0) + (single-value-return)) + +(defx8632lapfunction %set-macptr-domain ((p arg_y) (new arg_z)) + (check-nargs 2) + (trap-unless-typecode= p x8632::subtag-macptr) + (unbox-fixnum new imm0) + (svset p x8632::macptr.domain-cell imm0) + (single-value-return)) + +(defx8632lapfunction true () + (pop (% temp0)) + (subl ($ '2) (% nargs)) + (leal (@ '2 (% esp) (% nargs)) (% imm0)) + (cmoval (% imm0) (% esp)) + (movl ($ (target-t-value)) (% arg_z)) + (push (% temp0)) + (single-value-return)) + +(defx8632lapfunction false () + (pop (% temp0)) + (subl ($ '2) (% nargs)) + (leal (@ '2 (% esp) (% nargs)) (% imm0)) + (cmoval (% imm0) (% esp)) + (movl ($ (target-nil-value)) (% arg_z)) + (push (% temp0)) + (single-value-return)) + +(defx8632lapfunction int3 () + (int ($ 3)) + (single-value-return)) Index: /branches/new-random/level-0/X86/X8664/.cvsignore =================================================================== --- /branches/new-random/level-0/X86/X8664/.cvsignore (revision 13309) +++ /branches/new-random/level-0/X86/X8664/.cvsignore (revision 13309) @@ -0,0 +1,2 @@ +*fsl +*~.* Index: /branches/new-random/level-0/X86/X8664/x8664-bignum.lisp =================================================================== --- /branches/new-random/level-0/X86/X8664/x8664-bignum.lisp (revision 13309) +++ /branches/new-random/level-0/X86/X8664/x8664-bignum.lisp (revision 13309) @@ -0,0 +1,335 @@ +;;-*- Mode: Lisp; Package: CCL -*- +;;; +;;; Copyright (C) 2006-2009 Clozure Associates +;;; This file is part of Clozure CL. +;;; +;;; Clozure CL is licensed under the terms of the Lisp Lesser GNU Public +;;; License , known as the LLGPL and distributed with Clozure CL as the +;;; file "LICENSE". The LLGPL consists of a preamble and the LGPL, +;;; which is distributed with Clozure CL as the file "LGPL". Where these +;;; conflict, the preamble takes precedence. +;;; +;;; Clozure CL is referenced in the preamble as the "LIBRARY." +;;; +;;; The LLGPL is also available online at +;;; http://opensource.franz.com/preamble.html + + +(in-package "CCL") + +;;; The caller has allocated a two-digit bignum (quite likely on the stack). +;;; If we can fit in a single digit (if the high word is just a sign +;;; extension of the low word), truncate the bignum in place (the +;;; trailing words should already be zeroed. +(defx86lapfunction %fixnum-to-bignum-set ((bignum arg_y) (fixnum arg_z)) + (movq (% fixnum) (% arg_x)) + (shl ($ (- 32 x8664::fixnumshift)) (% arg_x)) + (sar ($ (- 32 x8664::fixnumshift)) (% arg_x)) + (unbox-fixnum fixnum imm0) + (cmp (% arg_x) (% fixnum)) + (je @chop) + (movq (% imm0) (@ x8664::misc-data-offset (% bignum))) + (single-value-return) + @chop + (movq ($ x8664::one-digit-bignum-header) (@ x8664::misc-header-offset (% bignum))) + (movl (% imm0.l) (@ x8664::misc-data-offset (% bignum))) + (single-value-return)) + +;; multiply x[i] by y and add to result starting at digit idx +(defx86lapfunction %multiply-and-add-loop + ((x 16) (y 8) #|(ra 0)|# (r arg_x) (idx arg_y) (ylen arg_z)) + (let ((cc mm2) + (xx mm3) + (yy mm4) + (rr mm5) + (i imm0) + (j imm1)) + (unbox-fixnum idx i) + (movq (@ x (% rsp)) (% temp0)) + (movd (@ x8664::misc-data-offset (% temp0) (% i) 4) (% xx)) ;x[i] + (movq (@ y (% rsp)) (% temp0)) + (movq (% r) (% temp1)) + (pxor (% cc) (% cc)) + (xorq (% j) (% j)) + @loop + (movd (@ x8664::misc-data-offset (% temp0) (% j) 4) (% yy)) ;y[j] + (pmuludq (% xx) (% yy)) + ;; 64-bit product now in %yy + (movd (@ x8664::misc-data-offset (% temp1) (% i) 4) (% rr)) + ;; add in digit from r[i] + (paddq (% yy) (% rr)) + ;; add in carry + (paddq (% cc) (% rr)) + (movd (% rr) (@ x8664::misc-data-offset (% temp1) (% i) 4)) ;update r[i] + (movq (% rr) (% cc)) + (psrlq ($ 32) (% cc)) ;get carry digit into low word + (addq ($ 1) (% i)) + (addq ($ 1) (% j)) + (subq ($ '1) (% ylen)) + (jg @loop) + (movd (% cc) (@ x8664::misc-data-offset (% temp1) (% i) 4)) + (single-value-return 4))) + +(defx86lapfunction %multiply-and-add-loop64 + ((xs 16) (ys 8) #|(ra 0)|# (r arg_x) (i arg_y) (ylen arg_z)) + (let ((y temp2) + (j temp0) + (c imm2)) + (movq (@ xs (% rsp)) (% temp0)) + (movq (@ x8664::misc-data-offset (% temp0) (% i)) (% mm0)) ;x[i] + (movq (@ ys (% rsp)) (% y)) + (xorl (%l j) (%l j)) + (xorl (%l c) (%l c)) + @loop + ;; It's a pity to have to reload this every time, but there's no + ;; imm3. (Give him 16 registers, and he still complains...) + (movd (% mm0) (% rax)) + (mulq (@ x8664::misc-data-offset (% y) (% j))) ;128-bit x * y[j] in rdx:rax + (addq (@ x8664::misc-data-offset (% r) (% i)) (% rax)) ;add in r[i] + (adcq ($ 0) (% rdx)) + ;; add in carry digit + (addq (% c) (% rax)) + (movl ($ 0) (%l c)) + (adcq (% rdx) (% c)) ;new carry digit + (movq (% rax) (@ x8664::misc-data-offset (% r) (% i))) ;update r[i] + (addq ($ '1) (% i)) + (addq ($ '1) (% j)) + (subq ($ '1) (% ylen)) + (ja @loop) + (movq (% c) (@ x8664::misc-data-offset (% r) (% i))) + (single-value-return 4))) + +;;; Multiply the (32-bit) digits X and Y, producing a 64-bit result. +;;; Add the 32-bit "prev" digit and the 32-bit carry-in digit to that 64-bit +;;; result; return the halves as (VALUES high low). +(defx86lapfunction %multiply-and-add4 ((x 8) #|(ra 0)|# (y arg_x) (prev arg_y) (carry-in arg_z)) + (let ((unboxed-x imm0) + (unboxed-y imm1) + (unboxed-prev imm0) + (unboxed-carry-in imm0) + (unboxed-low imm0) + (high arg_y) + (low arg_z)) + (pop (% ra0)) + (popq (% temp0)) + (discard-reserved-frame) + (push (% ra0)) + (unbox-fixnum temp0 unboxed-x) + (unbox-fixnum y unboxed-y) + (mull (%l unboxed-y)) + (shlq ($ 32) (% unboxed-y)) + (orq (% unboxed-x) (% unboxed-y)) ; I got yer 64-bit product right here + (unbox-fixnum prev unboxed-prev) + (addq (% unboxed-prev) (% unboxed-y)) + (unbox-fixnum carry-in unboxed-carry-in) + (addq (% unboxed-carry-in) (% unboxed-y)) + (movl (%l unboxed-y) (%l unboxed-low)) + (box-fixnum unboxed-low low) + (shr ($ 32) (% unboxed-y)) + (box-fixnum unboxed-y high) + (movq (% rsp) (% temp0)) + (pushq (% high)) + (pushq (% low)) + (set-nargs 2) + (jmp-subprim .SPvalues))) + +(defx86lapfunction %multiply-and-add3 ((x arg_x) (y arg_y) (carry-in arg_z)) + (let ((unboxed-x imm0) + (unboxed-y imm1) + (unboxed-carry-in imm0) + (unboxed-low imm0) + (high arg_y) + (low arg_z)) + (unbox-fixnum arg_x unboxed-x) + (unbox-fixnum y unboxed-y) + (mull (%l unboxed-y)) + (shlq ($ 32) (% unboxed-y)) + (orq (% unboxed-x) (% unboxed-y)) + (unbox-fixnum carry-in unboxed-carry-in) + (addq (% unboxed-carry-in) (% unboxed-y)) + (movl (%l unboxed-y) (%l unboxed-low)) + (box-fixnum unboxed-low low) + (shr ($ 32) (% unboxed-y)) + (box-fixnum unboxed-y high) + (movq (% rsp) (% temp0)) + (pushq (% high)) + (pushq (% low)) + (set-nargs 2) + (jmp-subprim .SPvalues))) + +;;; Return the (possibly truncated) 32-bit quotient and remainder +;;; resulting from dividing hi:low by divisor. +(defx86lapfunction %floor ((num-high arg_x) (num-low arg_y) (divisor arg_z)) + (let ((unboxed-high imm1) + (unboxed-low imm0) + (unboxed-quo imm0) + (unboxed-rem imm1) + (unboxed-divisor imm2)) + (unbox-fixnum divisor unboxed-divisor) + (unbox-fixnum num-high unboxed-high) + (unbox-fixnum num-low unboxed-low) + (divl (%l unboxed-divisor)) + (box-fixnum unboxed-quo arg_y) + (box-fixnum unboxed-rem arg_z) + (movq (% rsp) (% temp0)) + (pushq (% arg_y)) + (pushq (% arg_z)) + (set-nargs 2) + (jmp-subprim .SPvalues))) + +;;; Multiply two (UNSIGNED-BYTE 32) arguments, return the high and +;;; low halves of the 64-bit result +(defx86lapfunction %multiply ((x arg_y) (y arg_z)) + (let ((unboxed-x imm0) + (unboxed-y imm1) + (unboxed-high imm1) + (unboxed-low imm0)) + (unbox-fixnum x unboxed-x) + (unbox-fixnum y unboxed-y) + (mull (%l unboxed-y)) + (box-fixnum unboxed-high arg_y) + (box-fixnum unboxed-low arg_z) + (movq (% rsp) (% temp0)) + (pushq (% arg_y)) + (pushq (% arg_z)) + (set-nargs 2) + (jmp-subprim .SPvalues))) + +;;; Any words in the "tail" of the bignum should have been +;;; zeroed by the caller. +(defx86lapfunction %set-bignum-length ((newlen arg_y) (bignum arg_z)) + (movq (% newlen) (% imm0)) + (shl ($ (- x8664::num-subtag-bits x8664::fixnumshift)) (% imm0)) + (movb ($ x8664::subtag-bignum) (%b imm0)) + (movq (% imm0) (@ x8664::misc-header-offset (% bignum))) + (single-value-return)) + +;;; Count the sign bits in the most significant digit of bignum; +;;; return fixnum count. +(defx86lapfunction %bignum-sign-bits ((bignum arg_z)) + (vector-size bignum imm0 imm0) + (movl (@ (- x8664::misc-data-offset 4) (% bignum) (% imm0) 4) (%l imm0)) + (movl (% imm0.l) (% imm1.l)) + (notl (% imm0.l)) + (testl (% imm1.l) (% imm1.l)) + (js @wasneg) + (notl (% imm0.l)) + @wasneg + (bsrl (% imm0.l) (% imm0.l)) + (sete (% imm1.b)) + (xorl ($ 31) (% imm0)) + (addb (% imm1.b) (% imm0.b)) + (box-fixnum imm0 arg_z) + (single-value-return)) + +(defx86lapfunction %signed-bignum-ref ((bignum arg_y) (index arg_z)) + (uuo-error-debug-trap) + (unbox-fixnum index imm0) + (movslq (@ x8664::misc-data-offset (% bignum) (% imm0) 4) (% imm0)) + (box-fixnum imm0 arg_z) + (single-value-return)) + + +;;; If the bignum is a one-digit bignum, return the value of the +;;; single digit as a fixnum. Otherwise, if it's a two-digit-bignum +;;; and the two words of the bignum can be represented in a fixnum, +;;; return that fixnum; else return nil. +(defx86lapfunction %maybe-fixnum-from-one-or-two-digit-bignum ((bignum arg_z)) + (getvheader bignum imm1) + (cmpq ($ x8664::one-digit-bignum-header) (% imm1)) + (je @one) + (cmpq ($ x8664::two-digit-bignum-header) (% imm1)) + (jne @no) + (movq (@ x8664::misc-data-offset (% bignum)) (% imm0)) + (box-fixnum imm0 arg_z) + (unbox-fixnum arg_z imm1) + (cmpq (% imm0) (% imm1)) + (je @done) + @no + (movq ($ nil) (% arg_z)) + (single-value-return) + @one + (movslq (@ x8664::misc-data-offset (% bignum)) (% imm0)) + (box-fixnum imm0 arg_z) + @done + (single-value-return)) + +;;; Again, we're out of imm regs: a variable shift count has to go in %cl. +;;; Make sure that the rest of %rcx is 0, to keep the GC happy. +;;; %rcx == temp2 +(defx86lapfunction %digit-logical-shift-right ((digit arg_y) (count arg_z)) + (unbox-fixnum digit imm0) + (unbox-fixnum count imm2) + (shrq (% imm2.b) (% imm0)) + (box-fixnum imm0 arg_z) + (single-value-return)) + + + +(defx86lapfunction %ashr ((digit arg_y) (count arg_z)) + (unbox-fixnum digit imm0) + (unbox-fixnum count imm2) + (movslq (%l imm0) (% imm0)) + (sarq (% imm2.b) (% imm0)) + (box-fixnum imm0 arg_z) + (single-value-return)) + +(defx86lapfunction %ashl ((digit arg_y) (count arg_z)) + (unbox-fixnum digit imm0) + (unbox-fixnum count imm2) + (shlq (% imm2.b) (% imm0)) + (movl (%l imm0) (%l imm0)) ;zero-extend + (box-fixnum imm0 arg_z) + (single-value-return)) + +(defx86lapfunction macptr->fixnum ((ptr arg_z)) + (macptr-ptr arg_z ptr) + (single-value-return)) + +(defx86lapfunction fix-digit-logand ((fix arg_x) (big arg_y) (dest arg_z)) ; index 0 + (let ((w1 imm0) + (w2 imm1)) + (movq (@ x8664::misc-data-offset (% big)) (% w2)) + (unbox-fixnum fix w1) + (andq (% w2) (% w1)) + (cmp-reg-to-nil dest) + (jne @store) + (box-fixnum w1 arg_z) + (single-value-return) + @store + (movq (% w1) (@ x8664::misc-data-offset (% dest))) + (single-value-return))) + +(defx86lapfunction fix-digit-logandc2 ((fix arg_x) (big arg_y) (dest arg_z)) + (let ((w1 imm0) + (w2 imm1)) + (movq (@ x8664::misc-data-offset (% big)) (% w2)) + (unbox-fixnum fix w1) + (notq (% w2)) + (andq (% w2) (% w1)) + (cmp-reg-to-nil dest) + (jne @store) + (box-fixnum w1 arg_z) + (single-value-return) + @store + (movq (% w1) (@ x8664::misc-data-offset (% dest))) + (single-value-return))) + + +(defx86lapfunction fix-digit-logandc1 ((fix arg_x) (big arg_y) (dest arg_z)) + (let ((w1 imm0) + (w2 imm1)) + (movq (@ x8664::misc-data-offset (% big)) (% w2)) + (unbox-fixnum fix w1) + (notq (% w1)) + (andq (% w2) (% w1)) + (cmp-reg-to-nil dest) + (jne @store) + (box-fixnum w1 arg_z) + (single-value-return) + @store + (movq (% w1) (@ x8664::misc-data-offset (% dest))) + (single-value-return))) + + + Index: /branches/new-random/level-0/X86/x86-array.lisp =================================================================== --- /branches/new-random/level-0/X86/x86-array.lisp (revision 13309) +++ /branches/new-random/level-0/X86/x86-array.lisp (revision 13309) @@ -0,0 +1,403 @@ +;;;-*- Mode: Lisp; Package: CCL -*- +;;; +;;; Copyright (C) 2009 Clozure Associates +;;; Copyright (C) 1994-2001 Digitool, Inc +;;; This file is part of Clozure CL. +;;; +;;; Clozure CL is licensed under the terms of the Lisp Lesser GNU Public +;;; License , known as the LLGPL and distributed with Clozure CL as the +;;; file "LICENSE". The LLGPL consists of a preamble and the LGPL, +;;; which is distributed with Clozure CL as the file "LGPL". Where these +;;; conflict, the preamble takes precedence. +;;; +;;; Clozure CL is referenced in the preamble as the "LIBRARY." +;;; +;;; The LLGPL is also available online at +;;; http://opensource.franz.com/preamble.html + +(in-package "CCL") + +#+x8664-target +(progn + +(eval-when (:compile-toplevel :execute) + #+x8632-target + (require "X8632-ARCH") + #+x8664-target + (require "X8664-ARCH") + (require "X86-LAPMACROS")) + + + +#+x8664-target +(progn +;;; None of the stores in here can be intergenerational; the vector +;;; is known to be younger than the initial value +(defx86lapfunction %init-gvector ((len arg_x) (value arg_y) (vector arg_z)) + (jmp @test) + @loop + (movq (% value) (@ x8664::misc-data-offset (% vector) (% len))) + @test + (subq ($ x8664::fixnumone) (% len)) + (jns @loop) + (single-value-return)) + +;;; "val" is either a fixnum or a uvector with 64-bits of data +;;; (small bignum, DOUBLE-FLOAT). +(defx86lapfunction %%init-ivector64 ((len arg_x) (value arg_y) (vector arg_z)) + (unbox-fixnum value imm0) + (testb ($ x8664::fixnummask) (%b value)) + (je @test) + (movq (@ x8664::misc-data-offset (% value)) (% imm0)) + (jmp @test) + @loop + (movq (% imm0) (@ x8664::misc-data-offset (% vector) (% len))) + @test + (subq ($ x8664::fixnumone) (% len)) + (jns @loop) + (single-value-return)) + +(defun %init-ivector64 (typecode len val uvector) + (declare (type (mod 256) typecode)) + (%%init-ivector64 len + (case typecode + (#.x8664::subtag-fixnum-vector + (require-type val 'fixnum)) + (#.x8664::subtag-double-float-vector + (if (typep val 'double-float) + val + (require-type val 'double-float))) + (#.x8664::subtag-s64-vector + (require-type val '(signed-byte 64))) + (#.x8664::subtag-u64-vector + (require-type val '(unsigned-byte 64))) + (t (report-bad-arg uvector + '(or (simple-array fixnum (*)) + (simple-array double-float (*)) + (simple-array (signed-byte 64) (*)) + (simple-array (unsigned-byte 64) (*)))))) + uvector)) + + +(eval-when (:compile-toplevel :execute) + (declaim (inline %init-ivector-u32))) + +(defun %init-ivector-u32 (len u32val uvector) + (declare (type index len) + (type (unsigned-byte 32) u32val) + (type (simple-array (unsigned-byte 32) (*)) uvector) + (optimize (speed 3) (safety 0))) + (dotimes (i len uvector) + (setf (aref uvector i) u32val))) + +(eval-when (:compile-toplevel :execute) + (declaim (inline %init-ivector-u16))) + +(defun %init-ivector-u16 (len val uvector) + (declare (type index len) + (type (unsigned-byte 16) val) + (type (simple-array (unsigned-byte 16) (*)) uvector) + (optimize (speed 3) (safety 0))) + (dotimes (i len uvector) + (setf (aref uvector i) val))) + + + +(defun %init-ivector32 (typecode len val uvector) + (declare (type (unsigned-byte 32) typecode) + (type index len)) + (let* ((u32val (case typecode + (#.x8664::subtag-s32-vector + (logand (the (signed-byte 32) + (require-type val '(signed-byte 32))) + #xffffffff)) + (#.x8664::subtag-single-float-vector + (single-float-bits (require-type val 'single-float))) + (#.x8664::subtag-simple-base-string + (char-code val)) + (t + (require-type val '(unsigned-byte 32)))))) + (declare (type (unsigned-byte 32) u32val)) + (%init-ivector-u32 len u32val uvector))) + +(defun %init-misc (val uvector) + (let* ((len (uvsize uvector)) + (typecode (typecode uvector)) + (fulltag (logand x8664::fulltagmask typecode))) + (declare (type index len) + (type (unsigned-byte 8) typecode) + (type (mod 16) fulltag)) + (if (or (= fulltag x8664::fulltag-nodeheader-0) + (= fulltag x8664::fulltag-nodeheader-1)) + (%init-gvector len val uvector) + (if (= fulltag x8664::ivector-class-64-bit) + (%init-ivector64 typecode len val uvector) + (if (= fulltag x8664::ivector-class-32-bit) + (%init-ivector32 typecode len val uvector) + ;; Value must be a fixnum, 1, 8, 16 bits + (case typecode + (#.x8664::subtag-u16-vector + (%init-ivector-u16 len + (require-type val '(unsigned-byte 16)) + uvector)) + (#.x8664::subtag-s16-vector + (%init-ivector-u16 len + (logand (the (signed-byte 16) + (require-type val '(signed-byte 16))) + #xffff) + uvector)) + (#.x8664::subtag-u8-vector + (let* ((v0 (require-type val '(unsigned-byte 8))) + (l0 (ash (the fixnum (1+ len)) -1))) + (declare (type (unsigned-byte 8) v0) + (type index l0)) + (%init-ivector-u16 l0 + (logior (the (unsigned-byte 16) (ash v0 8)) + v0) + uvector))) + (#.x8664::subtag-s8-vector + (let* ((v0 (logand #xff + (the (signed-byte 8) + (require-type val '(signed-byte 8))))) + (l0 (ash (the fixnum (1+ len)) -1))) + (declare (type (unsigned-byte 8) v0) + (type index l0)) + (%init-ivector-u16 l0 + (logior (the (unsigned-byte 16) (ash v0 8)) + v0) + uvector))) + (#.x8664::subtag-bit-vector + (let* ((v0 (case val + (1 -1) + (0 0) + (t (report-bad-arg val 'bit)))) + (l0 (ash (the fixnum (+ len 63)) -6))) + (declare (type (unsigned-byte 8) v0) + (type index l0)) + (%%init-ivector64 l0 v0 uvector))) + (t (report-bad-arg uvector + '(or simple-bit-vector + (simple-array (signed-byte 8) (*)) + (simple-array (unsigned-byte 8) (*)) + (simple-array (signed-byte 16) (*)) + (simple-array (unsigned-byte 16) (*))))))))))) + + +) + +#-x8664-target +(defun %init-misc (val uvector) + (dotimes (i (uvsize uvector) uvector) + (setf (uvref uvector i) val))) + + +;;; Make a new vector of size newsize whose subtag matches that of oldv-arg. +;;; Blast the contents of the old vector into the new one as quickly as +;;; possible; leave remaining elements of new vector undefined (0). +;;; Return new-vector. +(defun %extend-vector (start oldv newsize) + (declare (fixnum start)) + (let* ((new (%alloc-misc newsize (typecode oldv))) + (oldsize (uvsize oldv))) + (declare (fixnum oldsize)) + (do* ((i 0 (1+ i)) + (j start (1+ j))) + ((= i oldsize) new) + (declare (fixnum i j)) + (setf (uvref new j) (uvref oldv i))))) + + + + + +;;; argument is a vector header or an array header. Or else. +(defx86lapfunction %array-header-data-and-offset ((a arg_z)) + (let ((offset arg_y) + (temp temp1)) + (movq (% rsp) (% temp0)) + (movl ($ '0) (%l offset)) + (movq (% a) (% temp)) + @loop + (movq (@ target::arrayH.data-vector (% temp)) (% a)) + (extract-subtag a imm0) + (addq (@ target::arrayH.displacement (% temp)) (% offset)) + (rcmp (% imm0) ($ target::subtag-vectorH)) + (movq (% a) (% temp)) + (jle @loop) + (push (% a)) + (push (% offset)) + (set-nargs 2) + (jmp-subprim .SPvalues))) + + + +(defx86lapfunction %boole-clr ((idx 8) #|(ra 0)|# (b0 arg_x) (b1 arg_y) (dest arg_z)) + (movq (@ idx (% rsp)) (% temp0)) + (movq ($ 0) (@ x8664::misc-data-offset (% dest) (% temp0))) + (single-value-return 3)) + +(defx86lapfunction %boole-set ((idx 8) #|(ra 0)|# (b0 arg_x) (b1 arg_y) (dest arg_z)) + (movq (@ idx (% rsp)) (% temp0)) + (movq ($ -1) (@ x8664::misc-data-offset (% dest) (% temp0))) + (single-value-return 3)) + +(defx86lapfunction %boole-1 ((idx 8) #|(ra 0)|# (b0 arg_x) (b1 arg_y) (dest arg_z)) + (movq (@ idx (% rsp)) (% temp0)) + (movq (@ x8664::misc-data-offset (% b0) (% temp0)) (% imm0)) + (movq (% imm0) (@ x8664::misc-data-offset (% dest) (% temp0))) + (single-value-return 3)) + +(defx86lapfunction %boole-2 ((idx 8) #|(ra 0)|# (b0 arg_x) (b1 arg_y) (dest arg_z)) + (movq (@ idx (% rsp)) (% temp0)) + (movq (@ x8664::misc-data-offset (% b1) (% temp0)) (% imm0)) + (movq (% imm0) (@ x8664::misc-data-offset (% dest) (% temp0))) + (single-value-return 3)) + +(defx86lapfunction %boole-c1 ((idx 8) #|(ra 0)|# (b0 arg_x) (b1 arg_y) (dest arg_z)) + (movq (@ idx (% rsp)) (% temp0)) + (movq (@ x8664::misc-data-offset (% b0) (% temp0)) (% imm0)) + (notq (% imm0)) + (movq (% imm0) (@ x8664::misc-data-offset (% dest) (% temp0))) + (single-value-return 3)) + +(defx86lapfunction %boole-c2 ((idx 8) #|(ra 0)|# (b0 arg_x) (b1 arg_y) (dest arg_z)) + (movq (@ idx (% rsp)) (% temp0)) + (movq (@ x8664::misc-data-offset (% b1) (% temp0)) (% imm0)) + (notq (% imm0)) + (movq (% imm0) (@ x8664::misc-data-offset (% dest) (% temp0))) + (single-value-return 3)) + +(defx86lapfunction %boole-and ((idx 8) #|(ra 0)|# (b0 arg_x) (b1 arg_y) (dest arg_z)) + (movq (@ idx (% rsp)) (% temp0)) + (movq (@ x8664::misc-data-offset (% b0) (% temp0)) (% imm0)) + (andq (@ x8664::misc-data-offset (% b1) (% temp0)) (% imm0)) + (movq (% imm0) (@ x8664::misc-data-offset (% dest) (% temp0))) + (single-value-return 3)) + +(defx86lapfunction %boole-ior ((idx 8) #|(ra 0)|# (b0 arg_x) (b1 arg_y) (dest arg_z)) + (movq (@ idx (% rsp)) (% temp0)) + (movq (@ x8664::misc-data-offset (% b0) (% temp0)) (% imm0)) + (orq (@ x8664::misc-data-offset (% b1) (% temp0)) (% imm0)) + (movq (% imm0) (@ x8664::misc-data-offset (% dest) (% temp0))) + (single-value-return 3)) + +(defx86lapfunction %boole-xor ((idx 8) #|(ra 0)|# (b0 arg_x) (b1 arg_y) (dest arg_z)) + (movq (@ idx (% rsp)) (% temp0)) + (movq (@ x8664::misc-data-offset (% b0) (% temp0)) (% imm0)) + (xorq (@ x8664::misc-data-offset (% b1) (% temp0)) (% imm0)) + (movq (% imm0) (@ x8664::misc-data-offset (% dest) (% temp0))) + (single-value-return 3)) + +(defx86lapfunction %boole-eqv ((idx 8) #|(ra 0)|# (b0 arg_x) (b1 arg_y) (dest arg_z)) + (movq (@ idx (% rsp)) (% temp0)) + (movq (@ x8664::misc-data-offset (% b0) (% temp0)) (% imm0)) + (xorq (@ x8664::misc-data-offset (% b1) (% temp0)) (% imm0)) + (notq (% imm0)) + (movq (% imm0) (@ x8664::misc-data-offset (% dest) (% temp0))) + (single-value-return 3)) + +(defx86lapfunction %boole-nand ((idx 8) #|(ra 0)|# (b0 arg_x) (b1 arg_y) (dest arg_z)) + (movq (@ idx (% rsp)) (% temp0)) + (movq (@ x8664::misc-data-offset (% b0) (% temp0)) (% imm0)) + (andq (@ x8664::misc-data-offset (% b1) (% temp0)) (% imm0)) + (notq (% imm0)) + (movq (% imm0) (@ x8664::misc-data-offset (% dest) (% temp0))) + (single-value-return 3)) + +(defx86lapfunction %boole-nor ((idx 8) #|(ra 0)|# (b0 arg_x) (b1 arg_y) (dest arg_z)) + (movq (@ idx (% rsp)) (% temp0)) + (movq (@ x8664::misc-data-offset (% b0) (% temp0)) (% imm0)) + (orq (@ x8664::misc-data-offset (% b1) (% temp0)) (% imm0)) + (notq (% imm0)) + (movq (% imm0) (@ x8664::misc-data-offset (% dest) (% temp0))) + (single-value-return 3)) + +(defx86lapfunction %boole-andc1 ((idx 8) #|(ra 0)|# (b0 arg_x) (b1 arg_y) (dest arg_z)) + (movq (@ idx (% rsp)) (% temp0)) + (movq (@ x8664::misc-data-offset (% b0) (% temp0)) (% imm0)) + (notq (% imm0)) + (andq (@ x8664::misc-data-offset (% b1) (% temp0)) (% imm0)) + (movq (% imm0) (@ x8664::misc-data-offset (% dest) (% temp0))) + (single-value-return 3)) + +(defx86lapfunction %boole-andc2 ((idx 8) #|(ra 0)|# (b0 arg_x) (b1 arg_y) (dest arg_z)) + (movq (@ idx (% rsp)) (% temp0)) + (movq (@ x8664::misc-data-offset (% b1) (% temp0)) (% imm0)) + (notq (% imm0)) + (andq (@ x8664::misc-data-offset (% b0) (% temp0)) (% imm0)) + (movq (% imm0) (@ x8664::misc-data-offset (% dest) (% temp0))) + (single-value-return 3)) + +(defx86lapfunction %boole-orc1 ((idx 8) #|(ra 0)|# (b0 arg_x) (b1 arg_y) (dest arg_z)) + (movq (@ idx (% rsp)) (% temp0)) + (movq (@ x8664::misc-data-offset (% b0) (% temp0)) (% imm0)) + (notq (% imm0)) + (orq (@ x8664::misc-data-offset (% b1) (% temp0)) (% imm0)) + (movq (% imm0) (@ x8664::misc-data-offset (% dest) (% temp0))) + (single-value-return 3)) + +(defx86lapfunction %boole-orc2 ((idx 8) #|(ra 0)|# (b0 arg_x) (b1 arg_y) (dest arg_z)) + (movq (@ idx (% rsp)) (% temp0)) + (movq (@ x8664::misc-data-offset (% b1) (% temp0)) (% imm0)) + (notq (% imm0)) + (orq (@ x8664::misc-data-offset (% b0) (% temp0)) (% imm0)) + (movq (% imm0) (@ x8664::misc-data-offset (% dest) (% temp0))) + (single-value-return 3)) + +(defparameter *simple-bit-boole-functions* ()) + +(setq *simple-bit-boole-functions* + (vector + #'%boole-clr + #'%boole-set + #'%boole-1 + #'%boole-2 + #'%boole-c1 + #'%boole-c2 + #'%boole-and + #'%boole-ior + #'%boole-xor + #'%boole-eqv + #'%boole-nand + #'%boole-nor + #'%boole-andc1 + #'%boole-andc2 + #'%boole-orc1 + #'%boole-orc2)) + +(defun %simple-bit-boole (op b1 b2 result) + (let* ((f (svref *simple-bit-boole-functions* op))) + (dotimes (i (ash (the fixnum (+ (length result) 63)) -6) result) + (funcall f i b1 b2 result)))) + +(defx86lapfunction %aref2 ((array arg_x) (i arg_y) (j arg_z)) + (check-nargs 3) + (jmp-subprim .SParef2)) + +(defx86lapfunction %aref3 ((array 8) #|(ra 0)|# (i arg_x) (j arg_y) (k arg_z)) + (check-nargs 4) + (pop (% ra0)) + (pop (% temp0)) + (discard-reserved-frame) + (push (% ra0)) + (jmp-subprim .SParef3)) + +(defx86lapfunction %aset2 ((array 8) #|(ra 0)|# (i arg_x) (j arg_y) (newval arg_z)) + (check-nargs 4) + (pop (% ra0)) + (pop (% temp0)) + (discard-reserved-frame) + (push (% ra0)) + (jmp-subprim .SPaset2)) + +(defx86lapfunction %aset3 ((array 16) (i 8) #|(ra 0)|# (j arg_x) (k arg_y) (newval arg_z)) + (check-nargs 5) + (pop (% ra0)) + (pop (% temp0)) + (pop (% temp1)) + (discard-reserved-frame) + (push (% ra0)) + (jmp-subprim .SPaset3)) + +) ; #+x8664-target + Index: /branches/new-random/level-0/X86/x86-clos.lisp =================================================================== --- /branches/new-random/level-0/X86/x86-clos.lisp (revision 13309) +++ /branches/new-random/level-0/X86/x86-clos.lisp (revision 13309) @@ -0,0 +1,274 @@ +;;;-*- Mode: Lisp; Package: CCL -*- +;;; +;;; Copyright (C) 2006-2009 Clozure Associates and contributors +;;; This file is part of Clozure CL. +;;; +;;; Clozure CL is licensed under the terms of the Lisp Lesser GNU Public +;;; License , known as the LLGPL and distributed with Clozure CL as the +;;; file "LICENSE". The LLGPL consists of a preamble and the LGPL, +;;; which is distributed with Clozure CL as the file "LGPL". Where these +;;; conflict, the preamble takes precedence. +;;; +;;; Clozure CL is referenced in the preamble as the "LIBRARY." +;;; +;;; The LLGPL is also available online at +;;; http://opensource.franz.com/preamble.html + +(in-package "CCL") + +#+x8664-target +(progn + +;;; It's easier to keep this is LAP; we want to play around with its +;;; constants. + + +;;; This just maps a SLOT-ID to a SLOT-DEFINITION or NIL. +;;; The map is a vector of (UNSIGNED-BYTE 8); this should +;;; be used when there are fewer than 255 slots in the class. +(defx86lapfunction %small-map-slot-id-lookup ((slot-id arg_z)) + (movq (@ 'map (% fn)) (% temp1)) + (svref slot-id slot-id.index arg_x) + (vector-length temp1 imm0) + (xorl (%l imm1) (%l imm1)) + (rcmpq (% arg_x) (% imm0)) + (movq (@ 'table (% fn)) (% temp0)) + (ja @have-table-index) + (movq (% arg_x) (% imm1)) + (shrq ($ x8664::word-shift) (% imm1)) + (movzbl (@ x8664::misc-data-offset (% temp1) (% imm1)) (%l imm1)) + @have-table-index + (movq (@ x8664::misc-data-offset (% temp0) (% imm1) 8) (% arg_z)) + (single-value-return)) + +;;; The same idea, only the map is a vector of (UNSIGNED-BYTE 32). +(defx86lapfunction %large-map-slot-id-lookup ((slot-id arg_z)) + (movq (@ 'map (% fn)) (% temp1)) + (svref slot-id slot-id.index arg_x) + (vector-length temp1 imm0) + (xorl (%l imm1) (%l imm1)) + (rcmpq (% arg_x) (% imm0)) + (movq (@ 'table (% fn)) (% temp0)) + (ja @have-table-index) + (movq (% arg_x) (% imm1)) + (shrq ($ 1) (% imm1)) + (movl (@ x8664::misc-data-offset (% temp1) (% imm1)) (%l imm1)) + @have-table-index + (movq (@ x8664::misc-data-offset (% temp0) (% imm1) 8) (% arg_z)) + (single-value-return)) + + +(defx86lapfunction %small-slot-id-value ((instance arg_y) (slot-id arg_z)) + (movq (@ 'map (% fn)) (% temp1)) + (svref slot-id slot-id.index arg_x) + (vector-length temp1 imm0) + (xorl (%l imm1) (%l imm1)) + (rcmpq (% arg_x) (% imm0)) + (movq (@ 'table (% fn)) (% temp0)) + (ja @missing) + (movq (% arg_x) (% imm1)) + (shrq ($ x8664::word-shift) (% imm1)) + (movzbl (@ x8664::misc-data-offset (% temp1) (% imm1)) (%l imm1)) + (testl (%l imm1) (%l imm1)) + (je @missing) + (movq (@ x8664::misc-data-offset (% temp0) (% imm1) 8) (% arg_z)) + (movq (@ 'class (% fn)) (% arg_x)) + (set-nargs 3) + (jmp (@ '%maybe-std-slot-value-using-class (% fn))) + @missing ; (%slot-id-ref-missing instance id) + (set-nargs 2) + (jmp (@'%slot-id-ref-missing (% fn)))) + +(defx86lapfunction %large-slot-id-value ((instance arg_y) (slot-id arg_z)) + (movq (@ 'map (% fn)) (% temp1)) + (svref slot-id slot-id.index arg_x) + (vector-length temp1 imm0) + (xorl (%l imm1) (%l imm1)) + (rcmpq (% arg_x) (% imm0)) + (movq (@ 'table (% fn)) (% temp0)) + (ja @missing) + (movq (% arg_x) (% imm1)) + (shrq ($ 1) (% imm1)) + (movl (@ x8664::misc-data-offset (% temp1) (% imm1)) (%l imm1)) + (testl (%l imm1) (%l imm1)) + (je @missing) + (movq (@ x8664::misc-data-offset (% temp0) (% imm1) 8) (% arg_z)) + (movq (@ 'class (% fn)) (% arg_x)) + (set-nargs 3) + (jmp (@ '%maybe-std-slot-value-using-class (% fn))) + @missing ; (%slot-id-ref-missing instance id) + (set-nargs 2) + (jmp (@'%slot-id-ref-missing (% fn)))) + + +(defx86lapfunction %small-set-slot-id-value ((instance arg_x) + (slot-id arg_y) + (new-value arg_z)) + (movq (@ 'map (% fn)) (% temp1)) + (svref slot-id slot-id.index imm1) + (vector-length temp1 imm0) + (rcmpq (% imm1) (% imm0)) + (movq (@ 'table (% fn)) (% temp0)) + (ja @missing) + (shrq ($ x8664::word-shift) (% rdx)) + (movzbl (@ x8664::misc-data-offset (% temp1) (% imm1)) (%l imm1)) + (testl (%l imm1) (%l imm1)) + (je @missing) + (popq (% ra0)) + (pushq ($ 0)) ; reserve frame + (pushq ($ 0)) + (pushq (@ 'class (% fn))) + (movq (@ x8664::misc-data-offset (% temp0) (% imm1) 8) (% arg_y)) + (set-nargs 4) + (pushq (% ra0)) + (jmp (@ '%maybe-std-setf-slot-value-using-class (% fn))) + @missing ; (%slot-id-set-missing instance id new-value) + (set-nargs 3) + (jmp (@ '%slot-id-set-missing (% fn)))) + + +(defx86lapfunction %large-set-slot-id-value ((instance arg_x) + (slot-id arg_y) + (new-value arg_z)) + (movq (@ 'map (% fn)) (% temp1)) + (svref slot-id slot-id.index imm1) + (vector-length temp1 imm0) + (rcmpq (% imm1) (% imm0)) + (movq (@ 'table (% fn)) (% temp0)) + (ja @missing) + (shrq ($ 1) (% rdx)) + (movl (@ x8664::misc-data-offset (% temp1) (% imm1)) (%l imm1)) + (testl (%l imm1) (%l imm1)) + (je @missing) + (popq (% ra0)) + (pushq ($ 0)) ; reserve frame + (pushq ($ 0)) + (pushq (@ 'class (% fn))) + (pushq (% ra0)) + (movq (@ x8664::misc-data-offset (% temp0) (% imm1) 8) (% arg_y)) + (set-nargs 4) + (jmp (@ '%maybe-std-setf-slot-value-using-class (% fn))) + @missing ; (%slot-id-set-missing instance id new-value) + (set-nargs 3) + (jmp (@'%slot-id-ref-missing (% fn)))) + + +;;; All of the generic function trampoline functions have to be +;;; exactly the same size (x8664::gf-code-size) in words. The +;;; largest of these - the general-case *GF-PROTO* - is currently +;;; "really" a little under 15 words, so X8664::GF-CODE-SIZE is +;;; just a little bigger than that. +(defparameter *gf-proto* + (nfunction + gag + (lambda (&lap &lexpr args) + (x86-lap-function + gag + () + (:fixed-constants (class-wrapper slots dispatch-table dcode hash)) + (:code-size x8664::gf-code-size) + #+count-gf-calls + (progn + (lock) + (addq ($ x8664::fixnumone) (@ 'hash (% fn)))) + (movq (@ (% rsp)) (% ra0)) + (save-frame-variable-arg-count) + (push-argregs) + (pushq (%q nargs)) + (movq (% rsp) (% arg_z)) + (ref-global.l ret1valaddr imm0) + (cmpq (% ra0) (% imm0)) + (je @multiple) + (ref-global.l lexpr-return1v ra0) + (jmp @call) + @multiple + (pushq (@ (+ (target-nil-value) (x8664::%kernel-global 'lexpr-return)))) + (movq (% imm0) (% ra0)) + @call + (push (% ra0)) + (movq (@ 'dispatch-table (% fn)) (% arg_y)) + (set-nargs 2) + (jmp (@ 'dcode (% fn))) ; dcode function + )))) + +;;; is a winner - saves ~15% +(defx86lapfunction gag-one-arg ((arg arg_z)) + (:fixed-constants (class-wrapper slots dispatch-table dcode hash)) + (:code-size x8664::gf-code-size) + #+count-gf-calls + (progn + (lock) + (addq ($ x8664::fixnumone) (@ 'hash (% fn)))) + (check-nargs 1) + (movq (@ 'dispatch-table (% fn)) (% arg_y)) + (set-nargs 2) + (jmp (@ 'dcode (% fn)))) + +(defx86lapfunction gag-two-arg ((arg0 arg_y) (arg1 arg_z)) + (:fixed-constants (class-wrapper slots dispatch-table dcode hash)) + (:code-size x8664::gf-code-size) + #+count-gf-calls + (progn + (lock) + (addq ($ x8664::fixnumone) (@ 'hash (% fn)))) + (check-nargs 2) + (movq (@ 'dispatch-table (% fn)) (% arg_x)) + (set-nargs 3) + (jmp (@ 'dcode (% fn)))) + + +(defx86lapfunction funcallable-trampoline () + (:fixed-constants (class-wrapper slots dispatch-table dcode hash)) + (:code-size x8664::gf-code-size) + (jmp (@ 'dcode (% fn)))) + + +;;; This is in LAP so that it can reference itself in the error message. +;;; (It needs to be cloned, so %fn will be unique to each copy.) +;;; It can't work for this to reference any of its own constants. +(defx86lapfunction unset-fin-trampoline () + (:code-size x8664::gf-code-size) + (save-frame-variable-arg-count) + (call-subprim .SPheap-rest-arg) + (pop (% arg_z)) + (movq ($ '#.$XNOFINFUNCTION) (% arg_x)) + (movq (% fn) (% arg_y)) + (set-nargs 3) + (call-subprim .SPksignalerr) + ;(movq ($ (target-nil-value)) (% arg_z)) + (leave) + (single-value-return)) + + + +(defparameter *cm-proto* + (nfunction + gag + (lambda (&lap &lexpr args) + (x86-lap-function + gag + () + (:fixed-constants (thing dcode gf bits)) + (movq (@ (% rsp)) (% ra0)) + (save-frame-variable-arg-count) + (push-argregs) + (pushq (%q nargs)) + (movq (% rsp) (% arg_z)) + (ref-global ret1valaddr imm0) + (cmpq (% ra0) (% imm0)) + (je @multiple) + (ref-global lexpr-return1v ra0) + (jmp @call) + @multiple + (pushq (@ (+ (target-nil-value) (x8664::%kernel-global 'lexpr-return)))) + (movq (% imm0) (% ra0)) + @call + (push (% ra0)) + (movq (@ 'thing (% fn)) (% arg_y)) + (set-nargs 2) + (jmp (@ 'dcode (% fn))))))) + + + + +) ; #+x8664-target Index: /branches/new-random/level-0/X86/x86-def.lisp =================================================================== --- /branches/new-random/level-0/X86/x86-def.lisp (revision 13309) +++ /branches/new-random/level-0/X86/x86-def.lisp (revision 13309) @@ -0,0 +1,736 @@ +;;; -*- Mode: Lisp; Package: CCL -*- +;;; +;;; Copyright (C) 2006-2009 Clozure Associates and contributors +;;; This file is part of Clozure CL. +;;; +;;; Clozure CL is licensed under the terms of the Lisp Lesser GNU Public +;;; License , known as the LLGPL and distributed with Clozure CL as the +;;; file "LICENSE". The LLGPL consists of a preamble and the LGPL, +;;; which is distributed with Clozure CL as the file "LGPL". Where these +;;; conflict, the preamble takes precedence. +;;; +;;; Clozure CL is referenced in the preamble as the "LIBRARY." +;;; +;;; The LLGPL is also available online at +;;; http://opensource.franz.com/preamble.html + +(in-package "CCL") +#+x8664-target +(progn + +(defx86lapfunction %function-vector-to-function ((arg arg_z)) + (trap-unless-typecode= arg x8664::subtag-function) + (addb ($ (- x8664::fulltag-function x8664::fulltag-misc)) (% arg_z.b)) + (single-value-return)) + +(defx86lapfunction %function-to-function-vector ((arg arg_z)) + (trap-unless-fulltag= arg x8664::fulltag-function) + (subb ($ (- x8664::fulltag-function x8664::fulltag-misc)) (% arg_z.b)) + (single-value-return)) + +(defx86lapfunction %function-code-words ((fun arg_z)) + (trap-unless-fulltag= fun x8664::fulltag-function) + (movl (@ (- x8664::node-size x8664::fulltag-function) (% fun)) (% imm0.l)) + (box-fixnum imm0 arg_z) + (single-value-return)) + +(defx86lapfunction %nth-immediate ((fun arg_y) (n arg_z)) + (trap-unless-fulltag= fun x8664::fulltag-function) + (movl (@ (- x8664::node-size x8664::fulltag-function) (% fun)) (% imm0.l)) + (lea (@ (% n) (% imm0) 8) (% imm0)) + (movq (@ (- x8664::node-size x8664::fulltag-function) (% fun) (% imm0)) + (% arg_z)) + (single-value-return)) + +(defx86lapfunction %set-nth-immediate ((fun arg_x) (n arg_y) (new arg_z)) + (trap-unless-fulltag= fun x8664::fulltag-function) + (movl (@ (- x8664::node-size x8664::fulltag-function) (% fun)) (% imm0.l)) + (lea (@ (% n) (% imm0) 8) (% arg_y)) + (subb ($ (- x8664::fulltag-function x8664::fulltag-misc)) (%b arg_x)) + (jmp-subprim .SPgvset)) + +(defx86lapfunction %function-code-byte ((fun arg_y) (pc arg_z)) + (unbox-fixnum pc imm0) + (movzbl (@ (% fun) (% imm0)) (% imm0.l)) + (box-fixnum imm0 arg_z) + (single-value-return)) + + +;;; Returns 3 values: mask of registers used in the function, stack location +;;; from which they'd be restored, relative PC at which they're saved. If +;;; the mask is 0, the values NIL NIL NIL are returned. If either the stack +;;; location or relative PC is #xff, both of those values will be returned +;;; as NIL. +(defx86lapfunction %function-register-usage ((f arg_z)) + (check-nargs 1) + (trap-unless-fulltag= f x8664::fulltag-function) + (movzbl (@ -1 (% f)) (% imm0.l)) + (shll ($ 8) (% imm0.l)) + (box-fixnum imm0 arg_x) + (movq (% rsp) (% temp0)) + (set-nargs 3) + (je @no-regs) + (movzbl (@ -2 (% f)) (% imm0.l)) + (movzbl (@ -3 (% f)) (% imm1.l)) + (cmpb ($ #xff) (% imm0.b)) + (je @unencodable) + (cmpb ($ #xff) (% imm1.b)) + (je @unencodable) + (box-fixnum imm0 arg_y) + (box-fixnum imm1 arg_z) + (push (% arg_x)) + (push (% arg_y)) + (push (% arg_z)) + (jmp-subprim .SPvalues) + @unencodable + (push (% arg_x)) + (pushq ($ nil)) + (pushq ($ nil)) + (jmp-subprim .SPvalues) + @no-regs + (pushq ($ nil)) + (pushq ($ nil)) + (pushq ($ nil)) + (jmp-subprim .SPvalues)) + + + +(defx86lapfunction %make-code-executable ((codev arg_z)) + (single-value-return)) + +;;; Make a new function, with PROTO's code and the specified immediates. +;;; IMMEDIATES should contain lfun-bits as the last element. +(defun %clone-x86-function (proto &rest immediates) + (declare (dynamic-extent immediates)) + (let* ((protov (%function-to-function-vector proto)) + (code-words (%function-code-words proto)) + (numimms (length immediates)) + (newv (allocate-typed-vector :function (the fixnum (+ code-words numimms))))) + (declare (fixnum code-words numimms)) + (%copy-ivector-to-ivector protov 0 newv 0 (the fixnum (ash code-words target::word-shift))) + (do* ((k code-words (1+ k)) + (imms immediates (cdr imms))) + ((null imms) (%function-vector-to-function newv)) + (declare (fixnum k) (list imms)) + (setf (%svref newv k) (car imms))))) + +(defun %copy-function (proto &optional target) + (let* ((protov (%function-to-function-vector proto)) + (code-words (%function-code-words proto)) + (total-words (uvsize protov)) + (newv (if target + (%function-to-function-vector target) + (allocate-typed-vector :function total-words)))) + (declare (fixnum code-words total-words)) + (when target + (unless (and (eql code-words (%function-code-words target)) + (eql total-words (uvsize newv))) + (error "Wrong size target ~s" target))) + (%copy-ivector-to-ivector protov 0 newv 0 (the fixnum (ash code-words target::word-shift))) + (loop for k fixnum from code-words below total-words + do (setf (%svref newv k) (%svref protov k))) + (%function-vector-to-function newv))) + +(defun replace-function-code (target proto) + (let* ((target-words (%function-code-words target)) + (proto-words (%function-code-words proto))) + (declare (fixnum target-words proto-words)) + (if (= target-words proto-words) + (progn + (%copy-ivector-to-ivector (%function-to-function-vector proto) + 0 + (%function-to-function-vector target) + 0 + (the fixnum (ash target-words + target::word-shift))) + target) + (error "Code size mismatch: target = ~s, proto = ~s" + target-words proto-words)))) + + +(defx86lapfunction %get-kernel-global-from-offset ((offset arg_z)) + (check-nargs 1) + (unbox-fixnum offset imm0) + (movq (@ (target-nil-value) (% imm0)) (% arg_z)) + (single-value-return)) + +(defx86lapfunction %set-kernel-global-from-offset ((offset arg_y) (new-value arg_z)) + (check-nargs 2) + (unbox-fixnum offset imm0) + (movq (% arg_z) (@ (target-nil-value) (% imm0))) + (single-value-return)) + + +(defx86lapfunction %get-kernel-global-ptr-from-offset ((offset arg_y) + (ptr arg_z)) + (check-nargs 2) + (unbox-fixnum offset imm0) + (movq (@ (target-nil-value) (% imm0)) (% imm0)) + (movq (% imm0) (@ x8664::macptr.address (% ptr))) + (single-value-return)) + + + + +(defx86lapfunction %fixnum-ref ((fixnum arg_y) #| &optional |# (offset arg_z)) + (:arglist (fixnum &optional offset)) + (check-nargs 1 2) + (cmpl ($ x8664::fixnumone) (% nargs)) + (jne @2-args) + (movq (% offset) (% fixnum)) + (xorl (%l offset) (%l offset)) + @2-args + (unbox-fixnum offset imm0) + (movq (@ (% fixnum) (% imm0)) (% arg_z)) + (single-value-return)) + +(defx86lapfunction %fixnum-ref-natural ((fixnum arg_y) #| &optional |# (offset arg_z)) + (:arglist (fixnum &optional offset)) + (check-nargs 1 2) + (cmpl ($ x8664::fixnumone) (% nargs)) + (jne @2-args) + (movq (% offset) (% fixnum)) + (xorl (%l offset) (%l offset)) + @2-args + (unbox-fixnum offset imm0) + (movq (@ (% fixnum) (% imm0)) (% imm0)) + (jmp-subprim .SPmakeu64)) + +(defx86lapfunction %fixnum-set ((fixnum arg_x) (offset arg_y) #| &optional |# (new-value arg_z)) + (:arglist (fixnum offset &optional newval)) + (check-nargs 2 3) + (cmpl ($ '2) (% nargs)) + (jne @3-args) + (movq (% offset) (% fixnum)) + (xorl (%l offset) (%l offset)) + @3-args + (unbox-fixnum offset imm0) + (movq (% new-value) (@ (% fixnum) (% imm0))) + (movq (% new-value) (% arg_z)) + (single-value-return)) + + +(defx86lapfunction %fixnum-set-natural ((fixnum arg_x) (offset arg_y) #| &optional |# (new-value arg_z)) + (:arglist (fixnum offset &optional newval)) + (check-nargs 2 3) + (save-simple-frame) + (cmpl ($ '2) (% nargs)) + (jne @3-args) + (movq (% offset) (% fixnum)) + (xorl (%l offset) (%l offset)) + @3-args + (call-subprim .SPgetu64) + (unbox-fixnum offset imm1) + (movq (% imm0) (@ (% fixnum) (% imm1))) + (restore-simple-frame) + (single-value-return)) + + +(defx86lapfunction %current-frame-ptr () + (check-nargs 0) + (movq (% rbp) (% arg_z)) + (single-value-return)) + + +(defx86lapfunction %current-tsp () + (check-nargs 0) + (movq (:rcontext x8664::tcr.save-tsp) (% arg_z)) + (single-value-return)) + + +(defx86lapfunction %%frame-backlink ((p arg_z)) + (check-nargs 1) + (movq (@ (% arg_z)) (% arg_z)) + (single-value-return)) + +;;; Look for "lea -nnnn(%rip),%fn" AT the tra; if that's present, use +;;; the dispacement -nnnn to find the function. The end of the +;;; encoded displacement is +;;; x8664::recover-fn-from-rip-disp-offset (= 7) bytes from the tra. +(defx86lapfunction %return-address-function ((r arg_z)) + (extract-lisptag r imm0) + (cmpb ($ x8664::tag-tra) (% imm0.b)) + (jne @fail) + (cmpw ($ x8664::recover-fn-from-rip-word0) (@ (% r))) + (jne @fail) + (cmpb ($ x8664::recover-fn-from-rip-byte2) (@ 2 (% r))) + (movslq (@ x8664::recover-fn-from-rip-disp-offset (% r)) (% imm0)) + (jne @fail) + (lea (@ x8664::recover-fn-from-rip-length (% imm0) (% r)) (% arg_z)) + (single-value-return) + @fail + (movl ($ (target-nil-value)) (% arg_z.l)) + (single-value-return)) + +(defx86lapfunction %return-address-offset ((r arg_z)) + (extract-lisptag r imm0) + (cmpb ($ x8664::tag-tra) (% imm0.b)) + (jne @fail) + (cmpw ($ x8664::recover-fn-from-rip-word0) (@ (% r))) + (jne @fail) + (cmpb ($ x8664::recover-fn-from-rip-byte2) (@ 2 (% r))) + (movslq (@ x8664::recover-fn-from-rip-disp-offset (% r)) (% imm0)) + (jne @fail) + (negq (% imm0)) + (leaq (@ (- (ash x8664::recover-fn-from-rip-length x8664::fixnumshift)) (% imm0) 8) (% arg_z)) + (single-value-return) + @fail + (movl ($ (target-nil-value)) (% arg_z.l)) + (single-value-return)) + +;;; It's always been the case that the function associated with a +;;; frame pointer is the caller of the function that "uses" that frame. +(defun %cfp-lfun (p) + (let* ((ra (%fixnum-ref p x8664::lisp-frame.return-address))) + (if (eq ra (%get-kernel-global ret1valaddr)) + (setq ra (%fixnum-ref p x8664::lisp-frame.xtra))) + (values (%return-address-function ra) (%return-address-offset ra)))) + + + +(defx86lapfunction %uvector-data-fixnum ((uv arg_z)) + (check-nargs 1) + (trap-unless-fulltag= arg_z x8664::fulltag-misc) + (addq ($ x8664::misc-data-offset) (% arg_z)) + (single-value-return)) + +(defx86lapfunction %catch-top ((tcr arg_z)) + (check-nargs 1) + (movl ($ (target-nil-value)) (%l arg_y)) + (movq (:rcontext x8664::tcr.catch-top) (% arg_z)) + (testb (%b arg_z) (%b arg_z)) + (cmoveq (% arg_y) (% arg_z)) + (single-value-return)) + +(defx86lapfunction %catch-tsp ((catch arg_z)) + (check-nargs 1) + (lea (@ (- (+ target::fulltag-misc + (ash 1 (1+ target::word-shift)))) (% arg_z)) + (% arg_z)) + (single-value-return)) + + + +;;; Same as %address-of, but doesn't cons any bignums +;;; It also left shift fixnums just like everything else. +(defx86lapfunction %fixnum-address-of ((x arg_z)) + (check-nargs 1) + (box-fixnum x arg_z) + (single-value-return)) + +(defx86lapfunction %save-standard-binding-list ((bindings arg_z)) + (movq (:rcontext x8664::tcr.vs-area) (% imm0)) + (movq (@ x8664::area.high (% imm0)) (% imm1)) + (subq ($ x8664::node-size) (% imm1)) + (movq (% bindings) (@ (% imm1))) + (single-value-return)) + +(defx86lapfunction %saved-bindings-address () + (movq (:rcontext x8664::tcr.vs-area) (% imm0)) + (movq (@ x8664::area.high (% imm0)) (% imm1)) + (lea (@ (- x8664::node-size) (% imm1)) (% arg_z)) + (single-value-return)) + +(defx86lapfunction %get-object ((macptr arg_y) (offset arg_z)) + (check-nargs 2) + (trap-unless-typecode= macptr x8664::subtag-macptr) + (macptr-ptr macptr imm0) + (trap-unless-lisptag= offset target::tag-fixnum imm1) + (unbox-fixnum offset imm1) + (movq (@ (% imm0) (% imm1)) (% arg_z)) + (single-value-return)) + + +(defx86lapfunction %set-object ((macptr arg_x) (offset arg_y) (value arg_z)) + (check-nargs 3) + (trap-unless-typecode= macptr target::subtag-macptr) + (macptr-ptr macptr imm0) + (trap-unless-lisptag= offset target::tag-fixnum imm1) + (unbox-fixnum offset imm1) + (movq (% arg_z) (@ (% imm0) (% imm1))) + (single-value-return)) + +(defx86lapfunction %apply-lexpr-with-method-context ((magic arg_x) + (function arg_y) + (args arg_z)) + ;; Somebody's called (or tail-called) us. + ;; Put magic arg in x8664::next-method-context (= x8664::temp0). + ;; Put function in x8664::xfn until we're ready to jump to it. + ;; Set nargs to 0, then spread "args" on stack (clobbers arg_x, arg_y, arg_z, + ;; but preserves x866::xfn/x8664::next-method-context. + ;; Jump to the function in x8664::xfn. + (popq (% ra0)) + (movq (% magic) (% next-method-context)) + (movq (% function) (% xfn)) + (set-nargs 0) + (movq (@ (% args)) (% imm0)) ;lexpr-count + (movl (%l imm0) (% nargs)) + (leaq (@ x8664::node-size (% arg_z) (% imm0)) (% imm1)) + (subl ($ '3) (% imm0)) + (jbe @reg-only) + ;; Some args will be pushed; reserve a frame + (pushq ($ x8664::reserved-frame-marker)) + (pushq ($ x8664::reserved-frame-marker)) + @pushloop + (pushq (@ (- x8664::node-size) (% imm1))) + (subq ($ x8664::node-size) (% imm1)) + (subq ($ x8664::node-size) (% imm0)) + (jne @pushloop) + @three + (movq (@ (* x8664::node-size 3) (% arg_z)) (% arg_x)) + @two + (movq (@ (* x8664::node-size 2) (% arg_z)) (% arg_y)) + @one + (movq (@ (* x8664::node-size 1) (% arg_z)) (% arg_z)) + (jmp @go) + @reg-only + (testl (% nargs) (% nargs)) + (je @go) + (rcmpl (% nargs) ($ '2)) + (je @two) + (jb @one) + (jmp @three) + @go + (push (% ra0)) + (jmp (% xfn))) + +(defx86lapfunction %apply-with-method-context ((magic arg_x) + (function arg_y) + (args arg_z)) + ;; Somebody's called (or tail-called) us. + ;; Put magic arg in x8664::next-method-context (= x8664::temp0). + ;; Put function in x8664::xfn (= x8664::temp1). + ;; Set nargs to 0, then spread "args" on stack (clobbers arg_x, arg_y, arg_z, + ;; but preserves x8664::xfn/x8664::next-method-context. + ;; Jump to the function in x8664::xfn. + (pop (% ra0)) + (movq (% magic) (% x8664::next-method-context)) + (movq (% function) (% x8664::xfn)) + (movq (% args) (% arg_y)) ; in case of error + (set-nargs 0) + (xorl (% imm0.l) (% imm0.l)) + (push (% imm0)) ; reserve frame (might discard + (push (% imm0)) ; it if nothing is passed on stack.) + (cmp-reg-to-nil arg_z) + (je @done) + @loop + (extract-fulltag arg_z imm1) + (cmpb ($ x8664::fulltag-cons) (%b imm1)) + (jne @bad) + (%car arg_z arg_x) + (%cdr arg_z arg_z) + (lea (@ x8664::node-size (% imm0)) (% imm0)) + (cmp-reg-to-nil arg_z) + (push (% arg_x)) + (jne @loop) + @done + (addl (%l imm0) (% nargs)) + (jne @pop) + @discard-and-go + (discard-reserved-frame) + (jmp @go) + @pop + (cmpl($ '1) (% nargs)) + (pop (% arg_z)) + (je @discard-and-go) + (cmpl ($ '2) (% nargs)) + (pop (% arg_y)) + (je @discard-and-go) + (cmpl ($ '3) (% nargs)) + (pop (% arg_x)) + (je @discard-and-go) + @go + (push (% ra0)) + (jmp (% xfn)) + @bad + (addq (% imm0) (% rsp)) + (movq (% arg_y) (% arg_z)) + (movq ($ (ash $XNOSPREAD x8664::fixnumshift)) (% arg_y)) + (set-nargs 2) + (jmp-subprim .SPksignalerr)) + + +;;; The idea here is to call METHOD in the same stack frame in +;;; which the lexpr was originally called. The lexpr can't +;;; have had any required arguments, %APPLY-LEXPR-TAIL-WISE +;;; must have been tail-called, and the frame built on lexpr +;;; entry must be in %rbp. +(defx86lapfunction %apply-lexpr-tail-wise ((method arg_y) (args arg_z)) + (addq ($ x8664::node-size) (% rsp)) ; discard extra return address + (movq (% method) (% xfn)) + (movq (% args) (% rsp)) + (pop (%q nargs)) + (movq (@ x8664::lisp-frame.return-address (% rbp)) (% ra0)) + (movq (@ 0 (% rbp)) (% rbp)) + (rcmpl (% nargs) ($ '3)) + (jbe @pop-regs) + ;; More than 3 args; some must have been pushed by caller, + ;; so retain the reserved frame. + (pop (% arg_z)) + (pop (% arg_y)) + (pop (% arg_x)) + (jmp @popped) + @pop-regs + (je @pop3) + (rcmpl (% nargs) ($ '1)) + (jb @discard) + (ja @pop2) + (pop (% arg_z)) + (jmp @discard) + @pop3 + (pop (% arg_z)) + (pop (% arg_y)) + (pop (% arg_x)) + (jmp @discard) + @pop2 + (pop (% arg_z)) + (pop (% arg_y)) + @discard + (discard-reserved-frame) + @popped + (push (% ra0)) + (jmp (% xfn))) + + + +(defun closure-function (fun) + (while (and (functionp fun) (not (compiled-function-p fun))) + (setq fun (%nth-immediate fun 0)) + (when (vectorp fun) + (setq fun (svref fun 0)))) + fun) + +;;; For use by (setf (apply ...) ...) +;;; (apply+ f butlast last) = (apply f (append butlast (list last))) + +(defun apply+ (&lap function arg1 arg2 &rest other-args) + (x86-lap-function apply+ () + (:arglist (function arg1 arg2 &rest other-args)) + (check-nargs 3 nil) + (cmpl ($ '3) (% nargs)) + (pop (% ra0)) + (ja @no-frame) + (pushq ($ x8664::reserved-frame-marker)) + (pushq ($ x8664::reserved-frame-marker)) +@no-frame + (push (% arg_x)) + (movq (% arg_z) (% temp0)) ; last + (movq (% arg_y) (% arg_z)) ; butlast + (subl ($ '2) (% nargs)) ; remove count for butlast & last + ;; Do .SPspreadargz inline here + (xorl (%l imm0) (%l imm0)) + (movq (% arg_z) (% arg_y)) ; save in case of error + (cmp-reg-to-nil arg_z) + (je @done) + @loop + (extract-fulltag arg_z imm1) + (cmpb ($ x8664::fulltag-cons) (%b imm1)) + (jne @bad) + (%car arg_z arg_x) + (%cdr arg_z arg_z) + (addl ($ '1) (%l imm0)) + (cmp-reg-to-nil arg_z) + (push (% arg_x)) + (jne @loop) + @done + ;; nargs was at least 1 when we started spreading, and can't have gotten + ;; any smaller. + (addl (%l imm0) (% nargs)) + (movq (% temp0) (% arg_z)) + (pop (% arg_y)) + (pop (% arg_x)) + (addl ($ '1) (% nargs)) + (cmpl ($ '3) (% nargs)) + (jne @no-discard) + (discard-reserved-frame) + @no-discard + (load-constant funcall temp0) + (push (% ra0)) + (jmp-subprim .SPfuncall) + @bad ; error spreading list. + (add (% imm0) (% rsp)) ; discard whatever's been pushed + (movq (% arg_y) (% arg_z)) + (movl ($ '#.$XNOSPREAD) (%l arg_y)) + (set-nargs 2) + (jmp-subprim .SPksignalerr) )) + + + +;;; This needs to: +;;; (a) load FP arg regs from the FP-REGS argument +;;; (b) call the .SPffcall subprimitive, which will discard the foreign stack frame +;;; allocated by WITH-VARIABLE-C-FRAME in %FF-CALL +;;; (c) re-establish the same foreign stack frame and store the result regs +;;; (%rax/%xmm0) there +(defx86lapfunction %do-ff-call ((nfp 0) (frame arg_x) (fp-regs arg_y) (entry arg_z)) + (popq (% ra0)) + (popq (% rax)) + (movq (% rbp) (@ (% rsp))) + (movq (% rsp) (% rbp)) + (movq (% ra0) (@ 8 (% rbp))) + (macptr-ptr fp-regs temp0) + (sarq ($ x8664::fixnumshift) (% rax)) + (movq (@ (% temp0)) (% fp0)) + (movq (@ 8 (% temp0)) (% fp1)) + (movq (@ 16 (% temp0)) (% fp2)) + (movq (@ 24 (% temp0)) (% fp3)) + (movq (@ 32 (% temp0)) (% fp4)) + (movq (@ 40 (% temp0)) (% fp5)) + (movq (@ 48 (% temp0)) (% fp6)) + (movq (@ 56 (% temp0)) (% fp7)) + (call-subprim .SPffcall) + (movq (:rcontext x8664::tcr.foreign-sp) (% mm5)) + (movq (% mm5) (@ (% frame))) + (movq (% frame) (:rcontext x8664::tcr.foreign-sp)) + (movq (% rax) (@ 8 (% frame))) + (movq (% fp0) (@ 16 (% frame))) + (movl ($ nil) (%l arg_z)) + (restore-simple-frame) + (single-value-return)) + +(defx86lapfunction %do-ff-call-return-registers ((fp-regs 8)(nfp 0) (frame arg_x) (regbuf arg_y) (entry arg_z)) + (popq (% ra0)) + (popq (% rax)) + (popq (% temp0)) + (movq (% rbp) (@ (% rsp))) + (movq (% rsp) (% rbp)) + (movq (% ra0) (@ 8 (% rbp))) + (macptr-ptr temp0 temp0) + (sarq ($ x8664::fixnumshift) (% rax)) + (movq (@ (% temp0)) (% fp0)) + (movq (@ 8 (% temp0)) (% fp1)) + (movq (@ 16 (% temp0)) (% fp2)) + (movq (@ 24 (% temp0)) (% fp3)) + (movq (@ 32 (% temp0)) (% fp4)) + (movq (@ 40 (% temp0)) (% fp5)) + (movq (@ 48 (% temp0)) (% fp6)) + (movq (@ 56 (% temp0)) (% fp7)) + (call-subprim .SPffcall-return-registers) + (movq (:rcontext x8664::tcr.foreign-sp) (% mm5)) + (movq (% mm5) (@ (% frame))) + (movq (% frame) (:rcontext x8664::tcr.foreign-sp)) + (movl ($ nil) (%l arg_z)) + (restore-simple-frame) + (single-value-return)) + + +(defun %ff-call (entry &rest specs-and-vals) + (declare (dynamic-extent specs-and-vals)) + (let* ((len (length specs-and-vals)) + (total-words 0) + (regbuf nil)) + (declare (fixnum len total-words)) + (let* ((result-spec (or (car (last specs-and-vals)) :void)) + (nargs (ash (the fixnum (1- len)) -1)) + (n-fp-args 0)) + (declare (fixnum nargs n-fp-args)) + (ecase result-spec + ((:address :unsigned-doubleword :signed-doubleword + :single-float :double-float + :signed-fullword :unsigned-fullword + :signed-halfword :unsigned-halfword + :signed-byte :unsigned-byte + :void) + (do* ((i 0 (1+ i)) + (specs specs-and-vals (cddr specs)) + (spec (car specs) (car specs))) + ((= i nargs)) + (declare (fixnum i)) + (case spec + ((:address :unsigned-doubleword :signed-doubleword + :single-float :double-float + :signed-fullword :unsigned-fullword + :signed-halfword :unsigned-halfword + :signed-byte :unsigned-byte) + (incf total-words)) + (:registers ) + (t (if (typep spec 'unsigned-byte) + (incf total-words spec) + (error "unknown arg spec ~s" spec))))) + ;; It's necessary to ensure that the C frame is the youngest thing on + ;; the foreign stack here. + (%stack-block ((fp-args (* 8 8))) + (with-macptrs ((argptr)) + (with-variable-c-frame + total-words frame + (%setf-macptr-to-object argptr frame) + (let* ((gpr-offset 16) + (other-offset (+ gpr-offset (* 6 8)))) + (declare (fixnum gpr-offset other-offset)) + (do* ((i 0 (1+ i)) + (ngpr-args 0) + (specs specs-and-vals (cddr specs)) + (spec (car specs) (car specs)) + (val (cadr specs) (cadr specs))) + ((= i nargs)) + (declare (fixnum i)) + (case spec + (:address + (incf ngpr-args) + (cond ((<= ngpr-args 6) + (setf (%get-ptr argptr gpr-offset) val) + (incf gpr-offset 8)) + (t + (setf (%get-ptr argptr other-offset) val) + (incf other-offset 8)))) + ((:signed-doubleword :signed-fullword :signed-halfword + :signed-byte) + (incf ngpr-args) + (cond ((<= ngpr-args 6) + (setf (%%get-signed-longlong argptr gpr-offset) val) + (incf gpr-offset 8)) + (t + (setf (%%get-signed-longlong argptr other-offset) val) + (incf other-offset 8)))) + ((:unsigned-doubleword :unsigned-fullword :unsigned-halfword + :unsigned-byte) + (incf ngpr-args) + (cond ((<= ngpr-args 6) + (setf (%%get-unsigned-longlong argptr gpr-offset) val) + (incf gpr-offset 8)) + (t + (setf (%%get-unsigned-longlong argptr other-offset) val) + (incf other-offset 8)))) + (:double-float + (cond ((< n-fp-args 8) + (setf (%get-double-float fp-args (* n-fp-args 8)) val) + (incf n-fp-args)) + (t + (setf (%get-double-float argptr other-offset) val) + (incf other-offset 8)))) + (:single-float + (cond ((< n-fp-args 8) + (setf (%get-single-float fp-args (* n-fp-args 8)) + val) + (incf n-fp-args)) + (t + (setf (%get-single-float argptr other-offset) val) + (incf other-offset 8)))) + (:registers (setq regbuf val)) + (t + (let* ((p 0)) + (declare (fixnum p)) + (dotimes (i (the fixnum spec)) + (setf (%get-ptr argptr other-offset) (%get-ptr val p)) + (incf p 8) + (incf other-offset 8))))))) + (if regbuf + (%do-ff-call-return-registers fp-args (min n-fp-args 8) frame regbuf entry) + (%do-ff-call (min n-fp-args 8) frame fp-args entry)) + (ecase result-spec + (:void nil) + (:address (%get-ptr argptr 8)) + (:unsigned-byte (%get-unsigned-byte argptr 8)) + (:signed-byte (%get-signed-byte argptr 8)) + (:unsigned-halfword (%get-unsigned-word argptr 8)) + (:signed-halfword (%get-signed-word argptr 8)) + (:unsigned-fullword (%get-unsigned-long argptr 8)) + (:signed-fullword (%get-signed-long argptr 8)) + (:unsigned-doubleword (%get-natural argptr 8)) + (:signed-doubleword (%get-signed-natural argptr 8)) + (:single-float (%get-single-float argptr 16)) + (:double-float (%get-double-float argptr 16))))))))))) + + +;;; end of x86-def.lisp +) ; #+x8664-target Index: /branches/new-random/level-0/X86/x86-float.lisp =================================================================== --- /branches/new-random/level-0/X86/x86-float.lisp (revision 13309) +++ /branches/new-random/level-0/X86/x86-float.lisp (revision 13309) @@ -0,0 +1,460 @@ +;;;-*- Mode: Lisp; Package: CCL -*- +;;; +;;; Copyright (C) 2005-2009 Clozure Associates +;;; This file is part of Clozure CL. +;;; +;;; Clozure CL is licensed under the terms of the Lisp Lesser GNU Public +;;; License , known as the LLGPL and distributed with Clozure CL as the +;;; file "LICENSE". The LLGPL consists of a preamble and the LGPL, +;;; which is distributed with Clozure CL as the file "LGPL". Where these +;;; conflict, the preamble takes precedence. +;;; +;;; Clozure CL is referenced in the preamble as the "LIBRARY." +;;; +;;; The LLGPL is also available online at +;;; http://opensource.franz.com/preamble.html + +(in-package "CCL") +#+x8664-target +(progn + +(eval-when (:compile-toplevel :execute) + (require "NUMBER-MACROS") + (require :number-case-macro)) + + +;;; make a float from hi - high 24 bits mantissa (ignore implied higher bit) +;;; lo - low 28 bits mantissa +;;; exp - take low 11 bits +;;; sign - sign(sign) => result +;;; hi result - 1 bit sign: 11 bits exp: 20 hi bits of hi arg +;;; lo result - 4 lo bits of hi arg: 28 lo bits of lo arg +;;; no error checks, no tweaks, no nuthin + +;;; sign is -1, 1, maybe zero + + + +(defx86lapfunction %make-float-from-fixnums ((float 16 )(hi 8) #|(ra 0)|#(lo arg_x) (exp arg_y) (sign arg_z)) + (mov (% sign) (% imm1)) + (sar ($ 63) (% imm1)) + (shl ($ 63) (% imm1)) + (movq (@ hi (% rsp)) (% imm0)) ;hi + (andl ($ (ash (1- (ash 1 24)) x8664::fixnumshift)) (%l imm0)) + (shl ($ (- 28 x8664::fixnumshift)) (% imm0)) + (or (% imm0) (% imm1)) + (unbox-fixnum lo imm0) + (andl ($ (1- (ash 1 28))) (%l imm0)) + (or (% imm0) (% imm1)) + (mov (% exp) (% imm0)) + (shl ($ (- ieee-double-float-exponent-offset x8664::fixnumshift)) (% imm0)) + (or (% imm0) (% imm1)) + (movq (@ float (% rsp)) (% arg_z)) + (mov (% imm1) (@ x8664::double-float.value (% arg_z))) + (single-value-return 4)) + + +;;; Maybe we should trap - or something - on NaNs. +(defx86lapfunction %%double-float-abs! ((n arg_y)(val arg_z)) + (mov (@ x8664::double-float.value (% n)) (% imm0)) + (btr ($ 63) (% imm0)) + (mov (% imm0) (@ x8664::double-float.value (% val))) + (single-value-return)) + + +(defx86lapfunction %short-float-abs ((n arg_z)) + (btr ($ 63) (% n)) + (single-value-return)) + + +(defx86lapfunction %double-float-negate! ((src arg_y) (res arg_z)) + (movq (@ x8664::double-float.value (% src)) (% imm0)) + (btcq ($ 63) (% imm0)) + (movq (% imm0) (@ x8664::double-float.value (% res))) + (single-value-return)) + + +(defx86lapfunction %short-float-negate ((src arg_z)) + (btcq ($ 63) (% arg_z)) + (single-value-return)) + + + +(defx86lapfunction dfloat-significand-zeros ((dfloat arg_z)) + (movq (@ target::double-float.value (% dfloat)) (% imm1)) + (shl ($ (1+ IEEE-double-float-exponent-width)) (% imm1)) + (bsrq (% imm1) (% imm0)) + (xorq ($ (1- target::nbits-in-word)) (% imm0)) + (box-fixnum imm0 arg_z) + (single-value-return)) + +;;; This exploits the fact that the single float is already +;;; shifted left 32 bits. We don't want to count the tag +;;; bit as significant, so bash the argument into a fixnum +;;; first. +(defx86lapfunction sfloat-significand-zeros ((sfloat arg_z)) + (xorb (%b sfloat) (%b sfloat)) + (shl ($ (1+ IEEE-single-float-exponent-width)) (% sfloat)) + (bsrq (% sfloat) (% imm0)) + (xorq ($ (1- target::nbits-in-word)) (% imm0)) + (box-fixnum imm0 arg_z) + (single-value-return)) + +(defx86lapfunction %%scale-dfloat! ((float arg_x)(int arg_y)(result arg_z)) + (unbox-fixnum int imm0) + (get-double-float float fp1) + (shl ($ IEEE-double-float-exponent-offset) (% imm0)) + (movd (% imm0) (% fp2)) + (mulsd (% fp2) (% fp1)) + (put-double-float fp1 result) + (single-value-return)) + +(defx86lapfunction %%scale-sfloat! ((float arg_y)(int arg_z)) + (unbox-fixnum int imm0) + (shl ($ IEEE-double-float-exponent-offset) (% imm0)) + (movd (% imm0) (% fp2)) + (get-single-float float fp1) + (mulss (% fp2) (% fp1)) + (put-single-float fp1 arg_z) + (single-value-return)) + +(defx86lapfunction %copy-double-float ((f1 arg_y) (f2 arg_z)) + (get-double-float f1 fp1) + (put-double-float fp1 f2) + (single-value-return)) + +(defx86lapfunction %short-float->double-float ((src arg_y) (result arg_z)) + (get-single-float src fp1) + (cvtss2sd (% fp1) (% fp1)) + (put-double-float fp1 result) + (single-value-return)) + +(defx86lapfunction %double-float->short-float ((src arg_z)) + (get-double-float src fp1) + (cvtsd2ss (% fp1) (% fp1)) + (put-single-float fp1 arg_z) + (single-value-return)) + +(defx86lapfunction %int-to-sfloat ((int arg_z)) + (int-to-single int imm0 fp1) + (put-single-float fp1 arg_z) + (single-value-return)) + + +(defx86lapfunction %int-to-dfloat ((int arg_y) (dfloat arg_z)) + (int-to-double int imm0 fp1) + (put-double-float fp1 arg_z) + (single-value-return)) + + + + +;;; Manipulate the MXCSR. It'll fit in a fixnum, but we have to +;;; load and store it through memory. On x8664, we can hide the +;;; 32-bit MXCSR value in a fixnum on the stack; on a 32-bit x86, +;;; we might need to use a scratch location in the TCR or something. + +;;; Return the MXCSR as a fixnum +(defx86lapfunction %get-mxcsr () + (pushq ($ '0)) + (stmxcsr (@ 4 (% rsp))) + (pop (% arg_z)) + (shr ($ (- 32 x8664::fixnumshift)) (% arg_z)) + (single-value-return)) + +;;; Store the fixnum in arg_z in the MXCSR. Just to be +;;; on the safe side, mask the arg with X86::MXCSR-WRITE-MASK, +;;; so that only known control and status bits are written to. +(defx86lapfunction %set-mxcsr ((val arg_z)) + (mov (% val) (% temp0)) + (andl ($ '#.x86::mxcsr-write-mask) (%l temp0)) + (shl ($ (- 32 x8664::fixnumshift)) (% temp0)) + (push (% temp0)) + (ldmxcsr (@ 4 (% rsp))) + (add ($ '1) (% rsp)) + (single-value-return)) + + +;;; Get the bits that contain exception masks and rounding mode. + +(defun %get-mxcsr-control () + (logand x86::mxcsr-control-and-rounding-mask (the fixnum (%get-mxcsr)))) + +;;; Get the bits that describe current exceptions. +(defun %get-mxcsr-status () + (logand x86::mxcsr-status-mask (the fixnum (%get-mxcsr)))) + +;;; Set the bits that describe current exceptions, presumably to clear them. +(defun %set-mxcsr-status (arg) + (%set-mxcsr + (logior (logand x86::mxcsr-status-mask arg) + (logandc2 (%get-mxcsr) x86::mxcsr-status-mask))) + arg) + +;;; Set the bits that mask/unmask exceptions and control rounding. +;;; Clear the bits which describe current exceptions. +(defun %set-mxcsr-control (arg) + (%set-mxcsr (logand x86::mxcsr-control-and-rounding-mask arg))) + +;;; Return the MXCSR value in effect after the last ff-call. +(defx86lapfunction %get-post-ffi-mxcsr () + (xor (% arg_z) (% arg_z)) + (movl (:rcontext x8664::tcr.ffi-exception) (%l imm0)) + (movl (%l arg_z) (:rcontext x8664::tcr.ffi-exception)) + (box-fixnum imm0 arg_z) + (single-value-return)) + +;;; Return the status bits from the last ff-call that represent +;;; unmasked exceptions +(defun %ffi-exception-status () + (logior (%get-mxcsr-control) + (logand x86::mxcsr-status-mask (the fixnum (%get-post-ffi-mxcsr))))) + + + + +;;; See if the binary double-float operation OP set any enabled +;;; exception bits in the mxcsr +(defun %df-check-exception-2 (operation op0 op1 fp-status) + (declare (type (unsigned-byte 6) fp-status)) + (unless (zerop fp-status) + (%set-mxcsr-status 0) + ;; Ensure that operands are heap-consed + (%fp-error-from-status fp-status + operation + (%copy-double-float op0 (%make-dfloat)) + (%copy-double-float op1 (%make-dfloat))))) + +(defun %sf-check-exception-2 (operation op0 op1 fp-status) + (declare (type (unsigned-byte 6) fp-status)) + (unless (zerop fp-status) + (%set-mxcsr-status 0) + ;; Ensure that operands are heap-consed + (%fp-error-from-status fp-status + operation + #+32-bit-target + (%copy-short-float op0 (%make-sfloat)) + #+64-bit-target op0 + #+32-bit-target + (%copy-short-float op1 (%make-sfloat)) + #+64-bit-target op1))) + +(defun %df-check-exception-1 (operation op0 fp-status) + (declare (fixnum fp-status)) + (unless (zerop fp-status) + (%set-mxcsr-status 0) + ;; Ensure that operands are heap-consed + (%fp-error-from-status fp-status + operation + (%copy-double-float op0 (%make-dfloat))))) + +(defun %sf-check-exception-1 (operation op0 fp-status) + (declare (type (unsigned-byte 6) fp-status)) + (unless (zerop fp-status) + (%set-mxcsr-status 0) + ;; Ensure that operands are heap-consed + (%fp-error-from-status fp-status + operation + #+32-bit-target + (%copy-short-float op0 (%make-sfloat)) + #+64-bit-target op0))) + + +(defun fp-condition-from-mxcsr (status-bits control-bits) + (declare (fixnum status-bits control-bits)) + (cond + ((and (logbitp x86::mxcsr-ie-bit status-bits) + (not (logbitp x86::mxcsr-im-bit control-bits))) + 'floating-point-invalid-operation) + ((and (logbitp x86::mxcsr-oe-bit status-bits) + (not (logbitp x86::mxcsr-om-bit control-bits))) + 'floating-point-overflow) + ((and (logbitp x86::mxcsr-ue-bit status-bits) + (not (logbitp x86::mxcsr-um-bit control-bits))) + 'floating-point-underflow) + ((and (logbitp x86::mxcsr-ze-bit status-bits) + (not (logbitp x86::mxcsr-zm-bit control-bits))) + 'division-by-zero) + ((and (logbitp x86::mxcsr-pe-bit status-bits) + (not (logbitp x86::mxcsr-pm-bit control-bits))) + 'floating-point-inexact))) + +(defun %fp-error-from-status (status-bits operation op0 &optional op1) + (declare (type (unsigned-byte 6) status-bits)) + (let* ((condition-class (fp-condition-from-mxcsr status-bits (%get-mxcsr-control)))) + (if condition-class + (let* ((operands (if op1 (list op0 op1) (list op0)))) + (error (make-instance condition-class + :operation operation + :operands operands)))))) + + + +;;; Don't we already have about 20 versions of this ? +(defx86lapfunction %double-float-from-macptr! ((ptr arg_x) (byte-offset arg_y) (dest arg_z)) + (macptr-ptr ptr imm0) + (unbox-fixnum byte-offset imm1) + (movsd (@ (% imm0) (% imm1)) (% fp1)) + (put-double-float fp1 dest) + (single-value-return)) + + +(defvar *rounding-mode-alist* + '((:nearest . 0) (:zero . 1) (:positive . 2) (:negative . 3))) + +(defun get-fpu-mode (&optional (mode nil mode-p)) + (let* ((flags (%get-mxcsr-control))) + (declare (fixnum flags)) + (let* ((rounding-mode + (car (nth (+ (if (logbitp x86::mxcsr-rc0-bit flags) 1 0) + (if (logbitp x86::mxcsr-rc1-bit flags) 2 0)) + *rounding-mode-alist*))) + (overflow (not (logbitp x86::mxcsr-om-bit flags))) + (underflow (not (logbitp x86::mxcsr-um-bit flags))) + (division-by-zero (not (logbitp x86::mxcsr-zm-bit flags))) + (invalid (not (logbitp x86::mxcsr-im-bit flags))) + (inexact (not (logbitp x86::mxcsr-pm-bit flags)))) + (if mode-p + (ecase mode + (:rounding-mode rounding-mode) + (:overflow overflow) + (:underflow underflow) + (:division-by-zero division-by-zero) + (:invalid invalid) + (:inexact inexact)) + `(:rounding-mode ,rounding-mode + :overflow ,overflow + :underflow ,underflow + :division-by-zero ,division-by-zero + :invalid ,invalid + :inexact ,inexact))))) + +;;; did we document this? +(defun set-fpu-mode (&key (rounding-mode :nearest rounding-p) + (overflow t overflow-p) + (underflow t underflow-p) + (division-by-zero t zero-p) + (invalid t invalid-p) + (inexact t inexact-p)) + (let* ((current (%get-mxcsr-control)) + (new current)) + (declare (fixnum current new)) + (when rounding-p + (let* ((rc-bits (or + (cdr (assoc rounding-mode *rounding-mode-alist*)) + (error "Unknown rounding mode: ~s" rounding-mode)))) + (declare (fixnum rc-bits)) + (if (logbitp 0 rc-bits) + (bitsetf x86::mxcsr-rc0-bit new) + (bitclrf x86::mxcsr-rc0-bit new)) + (if (logbitp 1 rc-bits) + (bitsetf x86::mxcsr-rc1-bit new) + (bitclrf x86::mxcsr-rc1-bit new)))) + (when invalid-p + (if invalid + (bitclrf x86::mxcsr-im-bit new) + (bitsetf x86::mxcsr-im-bit new))) + (when overflow-p + (if overflow + (bitclrf x86::mxcsr-om-bit new) + (bitsetf x86::mxcsr-om-bit new))) + (when underflow-p + (if underflow + (bitclrf x86::mxcsr-um-bit new) + (bitsetf x86::mxcsr-um-bit new))) + (when zero-p + (if division-by-zero + (bitclrf x86::mxcsr-zm-bit new) + (bitsetf x86::mxcsr-zm-bit new))) + (when inexact-p + (if inexact + (bitclrf x86::mxcsr-pm-bit new) + (bitsetf x86::mxcsr-pm-bit new))) + (unless (= current new) + (%set-mxcsr-control new)) + (%get-mxcsr))) + + + +;;; Copy a single float pointed at by the macptr in single +;;; to a double float pointed at by the macptr in double + +(defx86lapfunction %single-float-ptr->double-float-ptr ((single arg_y) (double arg_z)) + (check-nargs 2) + (macptr-ptr single imm0) + (movss (@ (% imm0)) (% fp1)) + (cvtss2sd (% fp1) (% fp1)) + (macptr-ptr double imm0) + (movsd (% fp1) (@ (% imm0))) + (single-value-return)) + +;;; Copy a double float pointed at by the macptr in double +;;; to a single float pointed at by the macptr in single. +(defx86lapfunction %double-float-ptr->single-float-ptr ((double arg_y) (single arg_z)) + (check-nargs 2) + (macptr-ptr double imm0) + (movsd (@ (% imm0)) (% fp1)) + (cvtsd2ss (% fp1) (% fp1)) + (macptr-ptr single imm0) + (movss (% fp1) (@ (% imm0))) + (single-value-return)) + + +(defx86lapfunction %set-ieee-single-float-from-double ((src arg_y) (macptr arg_z)) + (check-nargs 2) + (macptr-ptr macptr imm0) + (get-double-float src fp1) + (cvtsd2ss (% fp1) (% fp1)) + (movss (% fp1) (@ (% imm0))) + (single-value-return)) + +(defx86lapfunction host-single-float-from-unsigned-byte-32 ((u32 arg_z)) + (shl ($ (- 32 x8664::fixnumshift)) (% arg_z)) + (movb ($ x8664::subtag-single-float) (% arg_z.b)) + (single-value-return)) + +(defx86lapfunction single-float-bits ((f arg_z)) + (shr ($ (- 32 x8664::fixnumshift)) (% f)) + (single-value-return)) + +(defun double-float-bits (f) + (values (uvref f target::double-float.val-high-cell) + (uvref f target::double-float.val-low-cell))) + +(defun double-float-from-bits (high low) + (let* ((f (%make-dfloat))) + (setf (uvref f target::double-float.val-high-cell) high + (uvref f target::double-float.val-low-cell) low) + f)) + +;;; Return T if n is negative, else NIL. +(defx86lapfunction %double-float-sign ((n arg_z)) + (movl (@ x8664::double-float.val-high (% n)) (% imm0.l)) + (testl (% imm0.l) (% imm0.l)) + (movl ($ (target-t-value)) (% imm0.l)) + (movl ($ (target-nil-value)) (% arg_z.l)) + (cmovlq (% imm0) (% arg_z)) + (single-value-return)) + + +(defx86lapfunction %short-float-sign ((n arg_z)) + (testq (% n) (% n)) + (movl ($ (target-t-value)) (% imm0.l)) + (movl ($ (target-nil-value)) (% arg_z.l)) + (cmovlq (% imm0) (% arg_z)) + (single-value-return)) + +(defx86lapfunction %double-float-sqrt! ((n arg_y) (result arg_z)) + (get-double-float n fp0) + (sqrtsd (% fp0) (% fp0)) + (put-double-float fp0 result) + (single-value-return)) + +(defx86lapfunction %single-float-sqrt ((n arg_z)) + (get-single-float n fp0) + (sqrtss (% fp0) (% fp0)) + (put-single-float fp0 arg_z) + (single-value-return)) + +;;; end of x86-float.lisp +) ; #+x8664-target Index: /branches/new-random/level-0/X86/x86-hash.lisp =================================================================== --- /branches/new-random/level-0/X86/x86-hash.lisp (revision 13309) +++ /branches/new-random/level-0/X86/x86-hash.lisp (revision 13309) @@ -0,0 +1,131 @@ +;;; -*- Mode: Lisp; Package: CCL -*- +;;; +;;; Copyright (C) 2006-2009 Clozure Associates and contributors +;;; This file is part of Clozure CL. +;;; +;;; Clozure CL is licensed under the terms of the Lisp Lesser GNU Public +;;; License , known as the LLGPL and distributed with Clozure CL as the +;;; file "LICENSE". The LLGPL consists of a preamble and the LGPL, +;;; which is distributed with Clozure CL as the file "LGPL". Where these +;;; conflict, the preamble takes precedence. +;;; +;;; Clozure CL is referenced in the preamble as the "LIBRARY." +;;; +;;; The LLGPL is also available online at +;;; http://opensource.franz.com/preamble.html + +;;; level-0;ppc;ppc-hash.lisp + + +(in-package "CCL") +#+x8664-target +(progn + +(eval-when (:compile-toplevel :execute) + (require "HASHENV" "ccl:xdump;hashenv")) + + + + +;;; This should stay in LAP so that it's fast +;;; Equivalent to cl:mod when both args are positive fixnums + + +(defx86lapfunction fast-mod ((number arg_y) (divisor arg_z)) + (xorq (% imm1) (% imm1)) + (mov (% number) (% imm0)) + (div (% divisor)) + (mov (% imm1) (% arg_z)) + (single-value-return)) + + +;; Faster mod based on Bruce Hoult's Dylan version, modified to use a branch-free max. +(defx86lapfunction fast-mod-3 ((number arg_x) (divisor arg_y) (recip arg_z)) + (mov (% number) (% imm0)) + (shrq ($ target::fixnumshift) (% imm0)) + (mov (% recip) (% imm1)) + (mul (% imm1)) ;; -> hi word in imm1 (unboxed) + (mov (% divisor) (% imm0)) + (mul (% imm1)) ;; -> lo word in imm0 (boxed) + (subq (% imm0) (% number)) + (subq (% divisor) (% number)) + (mov (% number) (% arg_z)) + (mov (% number) (% imm0)) + (sar ($ (1- target::nbits-in-word)) (% imm0)) + (andq (% imm0) (% divisor)) + (addq (% divisor) (% arg_z)) + (single-value-return)) + +(defx86lapfunction %dfloat-hash ((key arg_z)) + (movq (@ x8664::double-float.value (% key)) (% imm0)) + (box-fixnum imm0 arg_z) + (single-value-return)) + +(defx86lapfunction %sfloat-hash ((key arg_z)) + (mov (% key) (% imm1)) + (movl ($ #x-80000000) (%l imm0)) + (shr ($ 32) (% imm1)) + (xorq (% arg_y) (% arg_y)) + (shr ($ (- 32 x8664::fixnumshift)) (% key)) + (rcmp (%l imm0) (%l imm1)) + (cmoveq (% arg_y) (% arg_z)) + (single-value-return)) + +(defx86lapfunction %macptr-hash ((key arg_z)) + (movq (@ target::macptr.address (% key)) (% imm0)) + (movq (% imm0) (% imm1)) + (shlq ($ 24) (% imm1)) + (addq (% imm1) (% imm0)) + (movq ($ (lognot target::fixnummask)) (% arg_z)) + (andq (% imm0) (% arg_z)) + (single-value-return)) + + +(defx86lapfunction %bignum-hash ((key arg_z)) + (let ((header imm0) + (offset imm1) + (ndigits temp0)) + (getvheader key header) + (header-length header ndigits) + (xorq (% offset) (% offset)) + (let ((immhash header)) + @loop + (rolq ($ 13) (% immhash)) + (addl (@ x8664::misc-data-offset (% key) (% offset)) (%l immhash)) + (addq ($ 4) (% offset)) + (subq ($ '1) (% ndigits)) + (jne @loop) + (box-fixnum immhash arg_z)) + (single-value-return))) + + +(defx86lapfunction %get-fwdnum () + (ref-global target::fwdnum arg_z) + (single-value-return)) + + +(defx86lapfunction %get-gc-count () + (ref-global target::gc-count arg_z) + (single-value-return)) + + +;;; Setting a key in a hash-table vector needs to +;;; ensure that the vector header gets memoized as well +(defx86lapfunction %set-hash-table-vector-key ((vector arg_x) (index arg_y) (value arg_z)) + (jmp-subprim .SPset-hash-key)) + +;;; This needs to be done out-of-line, to handle EGC memoization. +(defx86lapfunction %set-hash-table-vector-key-conditional ((offset 8) #|(ra 0)|# (vector arg_x) (old arg_y) (new arg_z)) + (movq (@ offset (% rsp)) (% temp0)) + (save-simple-frame) + (call-subprim .SPset-hash-key-conditional) + (restore-simple-frame) + (single-value-return 3)) + +;;; Strip the tag bits to turn x into a fixnum +(defx86lapfunction strip-tag-to-fixnum ((x arg_z)) + (andb ($ (lognot x8664::fixnummask)) (%b x)) + (single-value-return)) + +;;; end of x86-hash.lisp +) ; #+x8664-target Index: /branches/new-random/level-0/X86/x86-io.lisp =================================================================== --- /branches/new-random/level-0/X86/x86-io.lisp (revision 13309) +++ /branches/new-random/level-0/X86/x86-io.lisp (revision 13309) @@ -0,0 +1,42 @@ +;;; -*- Mode: Lisp; Package: CCL; -*- +;;; +;;; Copyright (C) 2009 Clozure Associates +;;; Copyright (C) 1994-2001 Digitool, Inc +;;; This file is part of Clozure CL. +;;; +;;; Clozure CL is licensed under the terms of the Lisp Lesser GNU Public +;;; License , known as the LLGPL and distributed with Clozure CL as the +;;; file "LICENSE". The LLGPL consists of a preamble and the LGPL, +;;; which is distributed with Clozure CL as the file "LGPL". Where these +;;; conflict, the preamble takes precedence. +;;; +;;; Clozure CL is referenced in the preamble as the "LIBRARY." +;;; +;;; The LLGPL is also available online at +;;; http://opensource.franz.com/preamble.html + + + +(in-package "CCL") + +;;; not very smart yet + +#+x8664-target +(defx86lapfunction %get-errno () + (movq (:rcontext x8664::tcr.errno-loc) (% imm1)) + (movslq (@ (% imm1)) (% imm0)) + (movss (% fpzero) (@ (% imm1))) + (negq (% imm0)) + (box-fixnum imm0 arg_z) + (single-value-return)) + +#+x8632-target +(defx8632lapfunction %get-errno () + (movl (:rcontext x8632::tcr.errno-loc) (% imm0)) + (movl (@ (% imm0)) (% imm0)) + (neg (% imm0)) + (box-fixnum imm0 arg_z) + (movl (:rcontext x8632::tcr.errno-loc) (% imm0)) + (movss (% fpzero) (@ (% imm0))) + (single-value-return)) + Index: /branches/new-random/level-0/X86/x86-misc.lisp =================================================================== --- /branches/new-random/level-0/X86/x86-misc.lisp (revision 13309) +++ /branches/new-random/level-0/X86/x86-misc.lisp (revision 13309) @@ -0,0 +1,924 @@ +;;; -*- Mode: Lisp; Package: CCL -*- +;;; +;;; Copyright (C) 2009 Clozure Associates +;;; Copyright (C) 1994-2001 Digitool, Inc +;;; This file is part of Clozure CL. +;;; +;;; Clozure CL is licensed under the terms of the Lisp Lesser GNU Public +;;; License , known as the LLGPL and distributed with Clozure CL as the +;;; file "LICENSE". The LLGPL consists of a preamble and the LGPL, +;;; which is distributed with Clozure CL as the file "LGPL". Where these +;;; conflict, the preamble takes precedence. +;;; +;;; Clozure CL is referenced in the preamble as the "LIBRARY." +;;; +;;; The LLGPL is also available online at +;;; http://opensource.franz.com/preamble.html + +;;; level-0;x86;x86-misc.lisp + + +(in-package "CCL") +#+x8664-target +(progn + +;;; Copy N bytes from pointer src, starting at byte offset src-offset, +;;; to ivector dest, starting at offset dest-offset. +;;; It's fine to leave this in lap. +;;; Depending on alignment, it might make sense to move more than +;;; a byte at a time. +;;; Does no arg checking of any kind. Really. + +(defx86lapfunction %copy-ptr-to-ivector ((src (* 2 x8664::node-size) ) + (src-byte-offset (* 1 x8664::node-size)) + #|(ra 0)|# + (dest arg_x) + (dest-byte-offset arg_y) + (nbytes arg_z)) + (let ((rsrc temp0) + (rsrc-byte-offset temp1)) + (testq (% nbytes) (% nbytes)) + (movq (@ src-byte-offset (% rsp)) (% rsrc-byte-offset)) ; boxed src-byte-offset + (movq (@ src (% rsp)) (% rsrc)) ; src macptr + (jmp @test) + @loop + (unbox-fixnum rsrc-byte-offset imm0) + (addq ($ '1) (% rsrc-byte-offset)) + (addq (@ x8664::macptr.address (% rsrc)) (% imm0)) + (movb (@ (% imm0)) (%b imm0)) + (unbox-fixnum dest-byte-offset imm1) + (addq ($ '1) (% dest-byte-offset)) + (movb (%b imm0) (@ x8664::misc-data-offset (% dest) (% imm1))) + (subq ($ '1) (% nbytes)) + @test + (jne @loop) + (movq (% dest) (% arg_z)) + (single-value-return 4))) + +(defx86lapfunction %copy-ivector-to-ptr ((src (* 2 x8664::node-size)) + (src-byte-offset (* 1 x8664::node-size)) + #|(ra 0)|# + (dest arg_x) + (dest-byte-offset arg_y) + (nbytes arg_z)) + (let ((rsrc temp0) + (rsrc-byte-offset temp1)) + (testq (% nbytes) (% nbytes)) + (movq (@ src-byte-offset (% rsp)) (% rsrc-byte-offset)) + (movq (@ src (% rsp)) (% rsrc)) + (jmp @test) + @loop + (unbox-fixnum rsrc-byte-offset imm0) + (addq ($ '1) (% rsrc-byte-offset)) + (movb (@ x8664::misc-data-offset (% rsrc) (% imm0)) (%b imm0)) + (unbox-fixnum dest-byte-offset imm1) + (addq ($ '1) (% dest-byte-offset)) + (addq (@ x8664::macptr.address (%q dest)) (% imm1)) + (movb (%b imm0) (@ (% imm1))) + (subq ($ '1) (% nbytes)) + @test + (jne @loop) + (movq (% dest) (% arg_z)) + (single-value-return 4))) + + +(defun %copy-ivector-to-ivector (src src-byte-offset dest dest-byte-offset nbytes) + (declare (fixnum src-byte-offset dest-byte-offset nbytes)) + (if (or (eq src dest) + (not (eql 0 src-byte-offset)) + (not (eql 0 dest-byte-offset)) + (< nbytes 8)) + (%copy-ivector-to-ivector-bytes src src-byte-offset dest dest-byte-offset nbytes) + (%copy-ivector-to-ivector-words src dest (ash nbytes -3) (logand nbytes 7)))) + +(defx86lapfunction %copy-ivector-to-ivector-words ((src 8) + #|(ra 0)|# + (dest arg_x) + (nwords arg_y) + (nbytes arg_z)) + (let ((rsrc temp0) + (ridx imm1) + (rval imm0)) + (xorl (%l ridx) (%l ridx)) + (movq (@ src (% rsp)) (% rsrc)) + (jmp @word-test) + @word-loop + (movq (@ x8664::misc-data-offset (% rsrc) (% ridx)) (% rval)) + (movq (% rval) (@ x8664::misc-data-offset (% dest) (% ridx))) + (addq ($ 8) (% ridx)) + @word-test + (cmpq (% ridx) (% nwords)) + (jne @word-loop) + (jmp @byte-test) + @byte-loop + (movb (@ x8664::misc-data-offset (% rsrc) (% ridx)) (%b rval)) + (movb (%b rval) (@ x8664::misc-data-offset (% dest) (% ridx))) + (addq ($ 1) (% ridx)) + @byte-test + (subq ($ '1) (% nbytes)) + (jns @byte-loop) + (movq (% dest) (% arg_z)) + (single-value-return 3))) + + + + +(defx86lapfunction %copy-ivector-to-ivector-bytes ((src-offset 16) + (src-byte-offset 8) + #|(ra 0)|# + (dest arg_x) + (dest-byte-offset arg_y) + (nbytes arg_z)) + (let ((rsrc temp0) + (rsrc-byte-offset temp1)) + (movq (@ src-byte-offset (% rsp)) (% rsrc-byte-offset)) + (movq (@ src-offset (% rsp)) (% rsrc)) + (cmpq (% dest) (% rsrc)) + (jne @front) + (cmpq (% src-byte-offset) (% dest-byte-offset)) + (jg @back) + @front + (testq (% nbytes) (% nbytes)) + (jmp @front-test) + @front-loop + (unbox-fixnum rsrc-byte-offset imm0) + (addq ($ '1) (% rsrc-byte-offset)) + (movb (@ x8664::misc-data-offset (% rsrc) (% imm0)) (%b imm0)) + (unbox-fixnum dest-byte-offset imm1) + (addq ($ '1) (% dest-byte-offset)) + (movb (%b imm0) (@ x8664::misc-data-offset (% dest) (% imm1))) + (subq ($ '1) (% nbytes)) + @front-test + (jne @front-loop) + (movq (% dest) (% arg_z)) + (single-value-return 4) + @back + (addq (% nbytes) (% rsrc-byte-offset)) + (addq (% nbytes) (% dest-byte-offset)) + (testq (% nbytes) (% nbytes)) + (jmp @back-test) + @back-loop + (subq ($ '1) (% rsrc-byte-offset)) + (unbox-fixnum rsrc-byte-offset imm0) + (movb (@ x8664::misc-data-offset (% rsrc) (% imm0)) (%b imm0)) + (subq ($ '1) (% dest-byte-offset)) + (unbox-fixnum dest-byte-offset imm1) + (subq ($ '1) (% nbytes)) + (movb (%b imm0) (@ x8664::misc-data-offset (% dest) (% imm1))) + @back-test + (jne @back-loop) + (movq (% dest) (% arg_z)) + (single-value-return 4))) + + +(defx86lapfunction %copy-gvector-to-gvector ((src (* 2 x8664::node-size)) + (src-element (* 1 x8664::node-size)) + #|(ra 0)|# + (dest arg_x) + (dest-element arg_y) + (nelements arg_z)) + (let ((rsrc temp0) + (rsrc-element imm1) + (val temp1)) + (movq (@ src-element (% rsp)) (% rsrc-element)) + (movq (@ src (% rsp)) (% rsrc)) + (cmpq (% rsrc) (% dest)) + (jne @front) + (rcmp (% rsrc-element) (% dest-element)) + (jl @back) + @front + (testq (% nelements) (% nelements)) + (jmp @front-test) + @front-loop + (movq (@ x8664::misc-data-offset (% rsrc) (% rsrc-element)) (% val)) + (addq ($ '1) (% rsrc-element)) + (movq (% val) (@ x8664::misc-data-offset (% dest) (% dest-element))) + (addq ($ '1) (% dest-element)) + (subq ($ '1) (% nelements)) + @front-test + (jne @front-loop) + (movq (% dest) (% arg_z)) + (single-value-return 4) + @back + (addq (% nelements) (% rsrc-element)) + (addq (% nelements) (% dest-element)) + (testq (% nelements) (% nelements)) + (jmp @back-test) + @back-loop + (subq ($ '1) (% rsrc-element)) + (movq (@ x8664::misc-data-offset (% rsrc) (% rsrc-element)) (% val)) + (subq ($ '1) (% dest-element)) + (movq (% val) (@ x8664::misc-data-offset (% dest) (% dest-element))) + (subq ($ '1) (% nelements)) + @back-test + (jne @back-loop) + (movq (% dest) (% arg_z)) + (single-value-return 4))) + +(defx86lapfunction %heap-bytes-allocated () + (movq (:rcontext x8664::tcr.save-allocptr) (% temp1)) + (movq (:rcontext x8664::tcr.last-allocptr) (% temp0)) + (cmpq ($ -16) (% temp1)) + (movq (:rcontext x8664::tcr.total-bytes-allocated) (% imm0)) + (jz @go) + (movq (% temp0) (% temp2)) + (subq (% temp1) (% temp0)) + (testq (% temp2) (% temp2)) + (jz @go) + (add (% temp0) (% imm0)) + @go + (jmp-subprim .SPmakeu64)) + + +(defx86lapfunction values () + (:arglist (&rest values)) + (save-frame-variable-arg-count) + (push-argregs) + (jmp-subprim .SPnvalret)) + +(defx86lapfunction rdtsc () + (:byte #x0f) ;two-byte rdtsc opcode + (:byte #x31) ;is #x0f #x31 + (shlq ($ 32) (% rdx)) + (orq (% rdx) (% rax)) + (imul ($ (* 2 target::node-size)) (% rax) (% arg_z)) + (shrq ($ 1) (% arg_z)) + (single-value-return)) + +;;; Return all 64 bits of the time-stamp counter as an unsigned integer. +(defx86lapfunction rdtsc64 () + (:byte #x0f) ;two-byte rdtsc opcode + (:byte #x31) ;is #x0f #x31 + (shlq ($ 32) (% rdx)) + (orq (% rdx) (% rax)) + (jmp-subprim .SPmakeu64)) + +;;; It would be nice if (%setf-macptr macptr (ash (the fixnum value) +;;; ash::fixnumshift)) would do this inline. + +(defx86lapfunction %setf-macptr-to-object ((macptr arg_y) (object arg_z)) + (check-nargs 2) + (trap-unless-typecode= macptr x8664::subtag-macptr) + (movq (% object) (@ x8664::macptr.address (% macptr))) + (single-value-return)) + +(defx86lapfunction %fixnum-from-macptr ((macptr arg_z)) + (check-nargs 1) + (trap-unless-typecode= arg_z x8664::subtag-macptr) + (movq (@ x8664::macptr.address (% arg_z)) (% imm0)) + (trap-unless-lisptag= imm0 x8664::tag-fixnum imm1) + (movq (% imm0) (% arg_z)) + (single-value-return)) + + +(defx86lapfunction %%get-unsigned-longlong ((ptr arg_y) (offset arg_z)) + (trap-unless-typecode= ptr x8664::subtag-macptr) + (macptr-ptr ptr imm1) + (unbox-fixnum offset imm0) + (movq (@ (% imm1) (% imm0)) (% imm0)) + (jmp-subprim .SPmakeu64)) + + +(defx86lapfunction %%get-signed-longlong ((ptr arg_y) (offset arg_z)) + (trap-unless-typecode= ptr x8664::subtag-macptr) + (macptr-ptr ptr imm1) + (unbox-fixnum offset imm0) + (movq (@ (% imm1) (% imm0)) (% imm0)) + (jmp-subprim .SPmakes64)) + + + + +(defx86lapfunction %%set-unsigned-longlong ((ptr arg_x) + (offset arg_y) + (val arg_z)) + (save-simple-frame) + (trap-unless-typecode= ptr x8664::subtag-macptr) + (call-subprim .SPgetu64) + (macptr-ptr ptr imm2) + (unbox-fixnum offset imm1) + (movq (% imm0) (@ (% imm2) (% imm1))) + (restore-simple-frame) + (single-value-return)) + + +(defx86lapfunction %%set-signed-longlong ((ptr arg_x) + (offset arg_y) + (val arg_z)) + (save-simple-frame) + (trap-unless-typecode= ptr x8664::subtag-macptr) + (call-subprim .SPgets64) + (macptr-ptr ptr imm2) + (unbox-fixnum offset imm1) + (movq (% imm0) (@ (% imm2) (% imm1))) + (restore-simple-frame) + (single-value-return)) + +(defx86lapfunction interrupt-level () + (movq (:rcontext x8664::tcr.tlb-pointer) (% imm1)) + (movq (@ x8664::interrupt-level-binding-index (% imm1)) (% arg_z)) + (single-value-return)) + +(defx86lapfunction set-interrupt-level ((new arg_z)) + (movq (:rcontext x8664::tcr.tlb-pointer) (% imm1)) + (trap-unless-fixnum new) + (movq (% new) (@ x8664::interrupt-level-binding-index (% imm1))) + (single-value-return)) + +(defx86lapfunction %current-tcr () + (movq (:rcontext x8664::tcr.linear) (% arg_z)) + (single-value-return)) + +(defx86lapfunction %tcr-toplevel-function ((tcr arg_z)) + (check-nargs 1) + (cmpq (% tcr) (:rcontext x8664::tcr.linear)) + (movq (% rsp) (% imm0)) + (movq (@ x8664::tcr.vs-area (% tcr)) (% temp0)) + (movq (@ x8664::area.high (% temp0)) (% imm1)) + (jz @room) + (movq (@ x8664::area.active (% temp0)) (% imm0)) + @room + (cmpq (% imm1) (% imm0)) + (movl ($ (target-nil-value)) (%l arg_z)) + (cmovneq (@ (- x8664::node-size) (% imm1)) (% arg_z)) + (single-value-return)) + +(defx86lapfunction %set-tcr-toplevel-function ((tcr arg_y) (fun arg_z)) + (check-nargs 2) + (cmpq (% tcr) (:rcontext x8664::tcr.linear)) + (movq (% rsp) (% imm0)) + (movq (@ x8664::tcr.vs-area (% tcr)) (% temp0)) + (movq (@ x8664::area.high (% temp0)) (% imm1)) + (jz @room) + (movq (@ x8664::area.active (% temp0)) (% imm0)) + @room + (cmpq (% imm1) (% imm0)) + (leaq (@ (- x8664::node-size) (% imm1)) (% imm1)) + (movq ($ 0) (@ (% imm1))) + (jne @have-room) + (movq (% imm1) (@ x8664::area.active (% temp0))) + (movq (% imm1) (@ x8664::tcr.save-vsp (% tcr))) + @have-room + (movq (% fun) (@ (% imm1))) + (single-value-return)) + +;;; This needs to be done out-of-line, to handle EGC memoization. +(defx86lapfunction %store-node-conditional ((offset 8) #|(ra 0)|# (object arg_x) (old arg_y) (new arg_z)) + (movq (@ offset (% rsp)) (% temp0)) + (save-simple-frame) + (call-subprim .SPstore-node-conditional) + (restore-simple-frame) + (single-value-return 3)) + +(defx86lapfunction %store-immediate-conditional ((offset 8) #|(ra 0)|# (object arg_x) (old arg_y) (new arg_z)) + (movq (@ offset (% rsp)) (% temp0)) + (unbox-fixnum temp0 imm1) + @again + (movq (@ (% object) (% imm1)) (% rax)) + (cmpq (% rax) (% old)) + (jne @lose) + (lock) + (cmpxchgq (% new) (@ (% object) (% imm1))) + (jne @again) + (movl ($ (target-t-value)) (%l arg_z)) + (single-value-return 3) + @lose + (movl ($ (target-nil-value)) (%l arg_z)) + (single-value-return 3)) + +(defx86lapfunction set-%gcable-macptrs% ((ptr x8664::arg_z)) + @again + (movq (@ (+ (target-nil-value) (x8664::kernel-global gcable-pointers))) + (% rax)) + (movq (% rax) (@ x8664::xmacptr.link (% ptr))) + (lock) + (cmpxchgq (% ptr) (@ (+ (target-nil-value) (x8664::kernel-global gcable-pointers)))) + (jne @again) + (single-value-return)) + +;;; Atomically increment or decrement the gc-inhibit-count kernel-global +;;; (It's decremented if it's currently negative, incremented otherwise.) +(defx86lapfunction %lock-gc-lock () + @again + (movq (@ (+ (target-nil-value) (x8664::kernel-global gc-inhibit-count))) (% rax)) + (lea (@ '-1 (% rax)) (% temp0)) + (lea (@ '1 (% rax)) (% arg_z)) + (testq (% rax) (% rax)) + (cmovsq (% temp0) (% arg_z)) + (lock) + (cmpxchgq (% arg_z) (@ (+ (target-nil-value) (x8664::kernel-global gc-inhibit-count)))) + (jnz @again) + (single-value-return)) + +;;; Atomically decrement or increment the gc-inhibit-count kernel-global +;;; (It's incremented if it's currently negative, incremented otherwise.) +;;; If it's incremented from -1 to 0, try to GC (maybe just a little.) +(defx86lapfunction %unlock-gc-lock () + @again + (movq (@ (+ (target-nil-value) (x8664::kernel-global gc-inhibit-count))) + (% rax)) + (lea (@ '1 (% rax)) (% arg_x)) + (cmpq ($ -1) (% rax)) + (lea (@ '-1 (% rax)) (% arg_z)) + (cmovleq (% arg_x) (% arg_z)) + (lock) + (cmpxchgq (% arg_z) (@ (+ (target-nil-value) (x8664::kernel-global gc-inhibit-count)))) + (jne @again) + (cmpq ($ '-1) (% rax)) + (jne @done) + ;; The GC tried to run while it was inhibited. Unless something else + ;; has just inhibited it, it should be possible to GC now. + (mov ($ arch::gc-trap-function-immediate-gc) (% imm0)) + (uuo-gc-trap) + @done + (single-value-return)) + +;;; Return true iff we were able to increment a non-negative +;;; lock._value + + + + +(defx86lapfunction %atomic-incf-node ((by arg_x) (node arg_y) (disp arg_z)) + (check-nargs 3) + (unbox-fixnum disp imm1) + @again + (movq (@ (% node) (% imm1)) (% rax)) + (lea (@ (% rax) (% by)) (% arg_z)) + (lock) + (cmpxchgq (% arg_z) (@ (% node) (% imm1))) + (jne @again) + (single-value-return)) + +(defx86lapfunction %atomic-incf-ptr ((ptr arg_z)) + (macptr-ptr ptr imm2) + @again + (movq (@ (% imm2)) (% rax)) + (lea (@ 1 (% rax)) (% imm1)) + (lock) + (cmpxchgq (% imm1) (@ (% imm2))) + (jne @again) + (box-fixnum imm1 arg_z) + (single-value-return)) + +(defx86lapfunction %atomic-incf-ptr-by ((ptr arg_y) (by arg_z)) + (macptr-ptr ptr imm2) + @again + (movq (@ (% imm2)) (% rax)) + (unbox-fixnum by imm1) + (add (% rax) (% imm1)) + (lock) + (cmpxchgq (% imm1) (@ (% imm2))) + (jnz @again) + (box-fixnum imm1 arg_z) + (single-value-return)) + + +(defx86lapfunction %atomic-decf-ptr ((ptr arg_z)) + (macptr-ptr ptr imm2) + @again + (movq (@ (% imm2)) (% rax)) + (lea (@ -1 (% rax)) (% imm1)) + (lock) + (cmpxchgq (% imm1) (@ (% imm2))) + (jnz @again) + (box-fixnum imm1 arg_z) + (single-value-return)) + +(defx86lapfunction %atomic-decf-ptr-if-positive ((ptr arg_z)) + (macptr-ptr ptr imm2) + @again + (movq (@ (% imm2)) (% rax)) + (testq (% rax) (% rax)) + (lea (@ -1 (% rax)) (% imm1)) + (jz @done) + (lock) + (cmpxchgq (% imm1) (@ (% imm2))) + (jnz @again) + @done + (box-fixnum imm1 arg_z) + (single-value-return)) + + +(defx86lapfunction %atomic-swap-ptr ((ptr arg_y) (newval arg_z)) + (macptr-ptr arg_y imm1) + (unbox-fixnum newval imm0) + (lock) + (xchgq (% imm0) (@ (% imm1))) + (box-fixnum imm0 arg_z) + (single-value-return)) + +;;; Try to store the fixnum NEWVAL at PTR, if and only if the old value +;;; was equal to OLDVAL. Return the old value +(defx86lapfunction %ptr-store-conditional ((ptr arg_x) (expected-oldval arg_y) (newval arg_z)) + (macptr-ptr ptr imm2) + @again + (movq (@ (% imm2)) (% imm0)) + (box-fixnum imm0 temp0) + (cmpq (% temp0) (% expected-oldval)) + (jne @done) + (unbox-fixnum newval imm1) + (lock) + (cmpxchgq (% imm1) (@ (% imm2))) + (jne @again) + @done + (movq (% temp0) (% arg_z)) + (single-value-return)) + +(defx86lapfunction %ptr-store-fixnum-conditional ((ptr arg_x) (expected-oldval arg_y) (newval arg_z)) + (let ((address imm1)) + (macptr-ptr ptr address) + @again + (movq (@ (% address)) (% imm0)) + (cmpq (% imm0) (% expected-oldval)) + (jne @done) + (lock) + (cmpxchgq (% newval) (@ (% address))) + (jne @again) + @done + (movq (% imm0) (% arg_z)) + (single-value-return))) + +(defx86lapfunction xchgl ((newval arg_y) (ptr arg_z)) + (unbox-fixnum newval imm0) + (macptr-ptr ptr imm1) + (lock) ; implicit ? + (xchgl (% imm0.l) (@ (% imm1))) + (box-fixnum imm0 arg_z) + (single-value-return)) + + + + +(defx86lapfunction %macptr->dead-macptr ((macptr arg_z)) + (check-nargs 1) + (movb ($ x8664::subtag-dead-macptr) (@ x8664::misc-subtag-offset (% macptr))) + (single-value-return)) + + + + + +(defx86lapfunction %%save-application ((flags arg_y) (fd arg_z)) + (unbox-fixnum flags imm0) + (orq ($ arch::gc-trap-function-save-application) (% imm0)) + (unbox-fixnum fd imm1) + (uuo-gc-trap) + (single-value-return)) + + + +(defx86lapfunction %misc-address-fixnum ((misc-object arg_z)) + (check-nargs 1) + (lea (@ x8664::misc-data-offset (% misc-object)) (% arg_z)) + (single-value-return)) + + +(defx86lapfunction fudge-heap-pointer ((ptr arg_x) (subtype arg_y) (len arg_z)) + (check-nargs 3) + (macptr-ptr ptr imm1) ; address in macptr + (lea (@ 17 (% imm1)) (% imm0)) ; 2 for delta + 15 for alignment + (andb ($ -16) (%b imm0)) ; Clear low four bits to align + (subq (% imm0) (% imm1)) ; imm1 = -delta + (negw (%w imm1)) + (movw (%w imm1) (@ -2 (% imm0))) ; save delta halfword + (unbox-fixnum subtype imm1) ; subtype at low end of imm1 + (shlq ($ (- x8664::num-subtag-bits x8664::fixnum-shift)) (% len )) + (orq (% len) (% imm1)) + (movq (% imm1) (@ (% imm0))) ; store subtype & length + (lea (@ x8664::fulltag-misc (% imm0)) (% arg_z)) ; tag it, return it + (single-value-return)) + +(defx86lapfunction %%make-disposable ((ptr arg_y) (vector arg_z)) + (check-nargs 2) + (lea (@ (- x8664::fulltag-misc) (% vector)) (% imm0)) ; imm0 is addr = vect less tag + (movzwq (@ -2 (% imm0)) (% imm1)) ; get delta + (subq (% imm1) (% imm0)) ; vector addr (less tag) - delta is orig addr + (movq (% imm0) (@ x8664::macptr.address (% ptr))) + (single-value-return)) + + +(defx86lapfunction %vect-data-to-macptr ((vect arg_y) (ptr arg_z)) + (lea (@ x8664::misc-data-offset (% vect)) (% imm0)) + (movq (% imm0) (@ x8664::macptr.address (% ptr))) + (single-value-return)) + +(defx86lapfunction get-saved-register-values () + (movq (% rsp) (% temp0)) + (push (% save0)) + (push (% save1)) + (push (% save2)) + (push (% save3)) ; this'd be the TCR on Win64. + (set-nargs 4) + (jmp-subprim .SPvalues)) + + +(defx86lapfunction %current-db-link () + (movq (:rcontext x8664::tcr.db-link) (% arg_z)) + (single-value-return)) + +(defx86lapfunction %no-thread-local-binding-marker () + (movq ($ x8664::subtag-no-thread-local-binding) (% arg_z)) + (single-value-return)) + + +(defx86lapfunction pending-user-interrupt () + (xorq (% imm0) (% imm0)) + (ref-global x8664::intflag arg_z) + ;; If another signal happens now, it will get ignored, same as if it happened + ;; before whatever signal is in arg_z. But then these are async signals, so + ;; who can be sure it didn't actually happen just before... + (set-global imm0 x8664::intflag) + (single-value-return)) + + +(defx86lapfunction debug-trap-with-string ((arg arg_z)) + (check-nargs 1) + (uuo-error-debug-trap-with-string) + (single-value-return)) + +(defx86lapfunction %safe-get-ptr ((src arg_y) (dest arg_z)) + (check-nargs 2) + (save-simple-frame) + (macptr-ptr src imm0) + (leaq (@ (:^ done) (% fn)) (% ra0)) + (movq (% imm0) (:rcontext x8664::tcr.safe-ref-address)) + (movq (@ (% imm0)) (% imm0)) + (jmp done) + (:tra done) + (recover-fn-from-rip) + (movq ($ 0) (:rcontext x8664::tcr.safe-ref-address)) + (movq (% imm0) (@ x8664::macptr.address (% dest))) + (restore-simple-frame) + (single-value-return)) + +;;; This was intentded to work around a bug in #_nanosleep in early +;;; Leopard test releases. It's probably not necessary any more; is +;;; it still called ? + +(defx86lapfunction %check-deferred-gc () + (btq ($ (+ arch::tcr-flag-bit-pending-suspend target::fixnumshift)) (:rcontext x8664::tcr.flags)) + (movl ($ (target-nil-value)) (% arg_z.l)) + (jae @done) + (ud2a) + (:byte 3) + (movl ($ (target-t-value)) (% arg_z.l)) + @done + (single-value-return)) + +(defx86lapfunction %%tcr-interrupt ((target arg_z)) + (check-nargs 1) + (ud2a) + (:byte 4) + (box-fixnum imm0 arg_z) + (single-value-return)) + +(defx86lapfunction %suspend-tcr ((target arg_z)) + (check-nargs 1) + (ud2a) + (:byte 5) + (movzbl (%b imm0) (%l imm0)) + (testl (%l imm0) (%l imm0)) + (movl ($ (target-nil-value)) (%l arg_z)) + (cmovnel (@ (+ target::t-offset target::symbol.vcell) (% arg_z)) (%l arg_z)) + (single-value-return)) + +(defx86lapfunction %suspend-other-threads () + (check-nargs 0) + (ud2a) + (:byte 6) + (movl ($ (target-nil-value)) (%l arg_z)) + (single-value-return)) + +(defx86lapfunction %resume-tcr ((target arg_z)) + (check-nargs 1) + (ud2a) + (:byte 7) + (movzbl (%b imm0) (%l imm0)) + (testl (%l imm0) (%l imm0)) + (movl ($ (target-nil-value)) (%l arg_z)) + (cmovnel (@ (+ target::t-offset target::symbol.vcell) (% arg_z)) (%l arg_z)) + (single-value-return)) + +(defx86lapfunction %resume-other-threads () + (check-nargs 0) + (ud2a) + (:byte 8) + (movl ($ (target-nil-value)) (%l arg_z)) + (single-value-return)) + +(defx86lapfunction %kill-tcr ((target arg_z)) + (check-nargs 1) + (ud2a) + (:byte 9) + (testb (%b imm0) (%b imm0)) + (movl ($ (target-nil-value)) (%l arg_z)) + (cmovnel (@ (+ target::t-offset target::symbol.vcell) (% arg_z)) (%l arg_z)) + (single-value-return)) + + +(defx86lapfunction %get-spin-lock ((p arg_z)) + (check-nargs 1) + (save-simple-frame) + @again + (macptr-ptr arg_z imm1) + (movq (@ '*spin-lock-tries* (% fn)) (% temp0)) + (movq (@ '*spin-lock-timeouts* (% fn)) (% temp1)) + (movq (@ target::symbol.vcell (% temp0)) (% temp0)) + (movq (:rcontext x8664::tcr.linear) (% arg_y)) + @try-swap + (xorq (% rax) (% rax)) + (lock) + (cmpxchgq (% arg_y) (@ (% imm1))) + (je @done) + @spin + (pause) + (cmpq ($ 0) (@ (% imm1))) + (je @try-swap) + (subq ($ '1) (% temp0)) + (jne @spin) + @wait + (addq ($ x8664::fixnumone) (@ x8664::symbol.vcell (% temp1))) + (pushq (% arg_z)) + (call-symbol yield 0) + (popq (% arg_z)) + (jmp @again) + @done + (restore-simple-frame) + (single-value-return)) + +;;; This is a prototype; it can't easily keep its arguments on the stack, +;;; or in registers, because its job involves unwinding the stack and +;;; restoring registers. Its parameters are thus kept in constants, +;;; and this protoype is cloned (with the right parameters). + +;;; For win64 (which doesn't really have a "save3" register), the code +;;; which instantiates this should always set save3-offset to 0. +(defx86lapfunction %%apply-in-frame-proto () + (:fixed-constants (target-frame target-catch target-db-link target-xcf target-tsp target-foreign-sp save0-offset save1-offset save2-offset save3-offset function args)) + (check-nargs 0) + ;;(uuo-error-debug-trap) + (movq (@ 'target-catch (% fn)) (% temp0)) + (xorl (%l imm0) (%l imm0)) + (cmpb ($ x8664::fulltag-nil) (%b temp0)) + (movq (:rcontext target::tcr.catch-top) (% arg_z)) + (jz @did-catch) + @find-catch + (testq (% arg_z) (% arg_z)) + (jz @did-catch) ; never found target catch + (addq ($ '1) (% imm0)) + (cmpq (% temp0) (% arg_z)) + (je @found-catch) + (movq (@ target::catch-frame.link (% arg_z)) (% arg_z)) + (jmp @find-catch) + @found-catch + (set-nargs 0) ; redundant, but ... + (lea (@ (:^ @back-from-nthrow) (% fn)) (% ra0)) + (:talign 4) + (jmp-subprim .SPnthrowvalues) + @back-from-nthrow + (recover-fn-from-rip) + @did-catch + ;; Restore special bindings + (movq (@ 'target-db-link (% fn)) (% imm0)) + (cmpb ($ x8664::fulltag-nil) (%b imm0)) + (jz @no-unbind) + (call-subprim .SPunbind-to) + @no-unbind + ;; If there's at least one exception frame between the target + ;; frame and the last catch (or the point of departure), restore + ;; the NVRs and foreign sp from the oldest such frame + (movq (@ 'target-xcf (% fn)) (% arg_z)) + (cmpb ($ x8664::fulltag-nil) (%b arg_z)) + (jz @no-xcf) + (movq (@ target::xcf.xp (% arg_z)) (% arg_y)) + ;; arg_y points to a "portable" ucontext. Find the platform-specifc + ;; "gpr vector" in the uc_mcontext, load the NVRs and stack/frame + ;; pointer from there. + #+linuxx8664-target + (progn + (addq ($ gp-regs-offset) (% arg_y)) + (movq (@ (* #$REG_R15 8) (% arg_y)) (% r15)) + (movq (@ (* #$REG_R14 8) (% arg_y)) (% r14)) + (movq (@ (* #$REG_R12 8) (% arg_y)) (% r12)) + (movq (@ (* #$REG_R11 8) (% arg_y)) (% r11)) + (movq (@ (* #$REG_RBP 8) (% arg_y)) (% rbp)) + (movq (@ (* #$REG_RSP 8) (% arg_y)) (% rsp))) + #+freebsdx8664-target + (progn + ;; If you think that this is ugly, just wait until you see the Darwin + ;; version. + (addq ($ gp-regs-offset) (% arg_y)) + (movq (@ (ash (foreign-record-field-offset (%find-foreign-record-type-field (parse-foreign-type '(:struct :__mcontext)) :mc_r15)) -3) (% arg_y)) (% r15)) + (movq (@ (ash (foreign-record-field-offset (%find-foreign-record-type-field (parse-foreign-type '(:struct :__mcontext)) :mc_r14)) -3) (% arg_y)) (% r14)) + (movq (@ (ash (foreign-record-field-offset (%find-foreign-record-type-field (parse-foreign-type '(:struct :__mcontext)) :mc_r12)) -3) (% arg_y)) (% r12)) + (movq (@ (ash (foreign-record-field-offset (%find-foreign-record-type-field (parse-foreign-type '(:struct :__mcontext)) :mc_r11)) -3) (% arg_y)) (% r11)) + (movq (@ (ash (foreign-record-field-offset (%find-foreign-record-type-field (parse-foreign-type '(:struct :__mcontext)) :mc_rbp)) -3) (% arg_y)) (% rbp)) + (movq (@ (ash (foreign-record-field-offset (%find-foreign-record-type-field (parse-foreign-type '(:struct :__mcontext)) :mc_rsp)) -3) (% arg_y)) (% rsp))) + #+darwinx8664-target + (progn + ;; Yes, this is ugly. + (movq (@ (ash (foreign-record-field-offset (%find-foreign-record-type-field (parse-foreign-type '(:struct :__darwin_ucontext)) :uc_mcontext)) -3) (% arg_y)) (% arg_y)) + (addq (@ (ash (foreign-record-field-offset (%find-foreign-record-type-field (parse-foreign-type '(:struct :__darwin_mcontext64)) :__ss)) -3)) (% arg_y)) + (movq (@ (ash (foreign-record-field-offset (%find-foreign-record-type-field (parse-foreign-type '(:struct :__darwin_x86_thread_state64)) :__r15)) -3) (% arg_y)) (% r15)) + (movq (@ (ash (foreign-record-field-offset (%find-foreign-record-type-field (parse-foreign-type '(:struct :__darwin_x86_thread_state64)) :__r14)) -3) (% arg_y)) (% r14)) + (movq (@ (ash (foreign-record-field-offset (%find-foreign-record-type-field (parse-foreign-type '(:struct :__darwin_x86_thread_state64)) :__r12)) -3) (% arg_y)) (% r12)) + (movq (@ (ash (foreign-record-field-offset (%find-foreign-record-type-field (parse-foreign-type '(:struct :__darwin_x86_thread_state64)) :__r11)) -3) (% arg_y)) (% r11)) + (movq (@ (ash (foreign-record-field-offset (%find-foreign-record-type-field (parse-foreign-type '(:struct :__darwin_x86_thread_state64)) :__rbp)) -3) (% arg_y)) (% rbp)) + (movq (@ (ash (foreign-record-field-offset (%find-foreign-record-type-field (parse-foreign-type '(:struct :__darwin_x86_thread_state64)) :__rsp)) -3) (% arg_y)) (% rsp))) + ;; This is our best (possibly only) chance to get + ;; the foreign sp right. + (movq (@ target::xcf.prev-xframe (% arg_z)) (% temp0)) + (movq (@ target::xcf.foreign-sp (% arg_z)) (% imm0)) + (movq (% temp0) (:rcontext target::tcr.xframe)) + (movq (% imm0) (:rcontext target::tcr.foreign-sp)) + ;; All done processing the xcf. NVRs may have been + ;; saved between the last catch/last xcf and the + ;; target frame. The save-n-offset parameter/constants + ;; are either 0 or negative offsets from the target frame + ;; of the stack location where the corresponding GPR + ;; was saved. + @no-xcf + (movq (@ 'target-tsp (% fn)) (% imm0)) + (cmpb ($ x8664::fulltag-nil) (%b imm0)) + (movq (@ 'target-foreign-sp (% fn)) (% temp0)) + (je @no-tsp) + (movq (% imm0) (:rcontext target::tcr.save-tsp)) + (movq (% imm0) (:rcontext target::tcr.next-tsp)) + @no-tsp + (cmpb ($ x8664::fulltag-nil) (%b temp0)) + (je @no-sp) + (movq (% temp0) (:rcontext target::tcr.foreign-sp)) + @no-sp + (movq (@ 'target-frame (% fn)) (% rbp)) + (movq (@ 'save0-offset (% fn)) (% arg_x)) + (movq (@ 'save1-offset (% fn)) (% arg_y)) + (movq (@ 'save2-offset (% fn)) (% arg_z)) + (movq (@ 'save3-offset (% fn)) (% temp0)) + (testq (% arg_x) (% arg_x)) + (cmovneq (@ (% rbp) (% arg_x)) (% save0)) + (testq (% arg_y) (% arg_y)) + (cmovneq (@ (% rbp) (% arg_x)) (% save1)) + (testq (% arg_z) (% arg_z)) + (cmovneq (@ (% rbp) (% arg_x)) (% save2)) + (testq (% temp0) (% temp0)) + (cmovneq (@ (% rbp) (% arg_x)) (% save3)) + (leave) + (pop (% temp0)) ; return address, not used by subprim + (set-nargs 0) + (movq (@ 'args (% fn)) (% arg_z)) + (lea (@ (:^ @back-from-spread) (% fn)) (% ra0)) + (:talign 4) + (jmp-subprim .SPspreadargz) + @back-from-spread + (recover-fn-from-rip) ; .SPspreadargz preserves %fn, but ... + (push (% temp0)) ; return address + (jmp (@ 'function (% fn)))) + + +(defx86lapfunction %atomic-pop-static-cons () + @again + (movq (@ (+ (target-nil-value) (x8664::kernel-global static-conses))) (% rax)) + (cmpq ($ (target-nil-value)) (% rax)) + (jz @lose) + (%cdr rax temp0) + (lock) + (cmpxchgq (% temp0) (@ (+ (target-nil-value) (x8664::kernel-global static-conses)))) + (jnz @again) + (lock) + (subq ($ x8664::fixnumone) (@ (+ (target-nil-value) (x8664::kernel-global free-static-conses)))) + @lose + (movq (% rax) (% arg_z)) + (single-value-return)) + + + +(defx86lapfunction %staticp ((x arg_z)) + (check-nargs 1) + (ref-global static-cons-area temp0) + (movq (% x) (% imm0)) + (movl ($ (target-nil-value)) (% arg_z.l)) + (subq (@ target::area.low (% temp0)) (% imm0)) + (shrq ($ target::dnode-shift) (% imm0)) + (movq (@ target::area.ndnodes (% temp0)) (% imm1)) + (subq (% imm0) (% imm1)) + (lea (@ 128 (% imm1)) (% imm1)) + (leaq (@ (% imm1) target::fixnumone) (% imm1)) + (cmovaq (% imm1) (% arg_z)) + (single-value-return)) + +(defx86lapfunction %static-inverse-cons ((n arg_z)) + (check-nargs 1) + (subq ($ '128) (% arg_z)) + (ref-global static-cons-area temp0) + (movq (@ target::area.high (% temp0)) (% imm0)) + (subq (% arg_z) (% imm0)) + (subq (% arg_z) (% imm0)) + (lea (@ x8664::fulltag-cons (% imm0)) (% arg_z)) + (single-value-return)) + + + + +;;; end of x86-misc.lisp +) ; #+x8664-target Index: /branches/new-random/level-0/X86/x86-numbers.lisp =================================================================== --- /branches/new-random/level-0/X86/x86-numbers.lisp (revision 13309) +++ /branches/new-random/level-0/X86/x86-numbers.lisp (revision 13309) @@ -0,0 +1,195 @@ +;-*- Mode: Lisp; Package: CCL -*- +;;; +;;; Copyright (C) 2009 Clozure Associates +;;; Copyright (C) 1994-2001 Digitool, Inc +;;; This file is part of Clozure CL. +;;; +;;; Clozure CL is licensed under the terms of the Lisp Lesser GNU Public +;;; License , known as the LLGPL and distributed with Clozure CL as the +;;; file "LICENSE". The LLGPL consists of a preamble and the LGPL, +;;; which is distributed with Clozure CL as the file "LGPL". Where these +;;; conflict, the preamble takes precedence. +;;; +;;; Clozure CL is referenced in the preamble as the "LIBRARY." +;;; +;;; The LLGPL is also available online at +;;; http://opensource.franz.com/preamble.html + + + +(in-package "CCL") +#+x8664-target +(progn + + + +(defx86lapfunction %fixnum-signum ((number arg_z)) + (movq ($ '-1) (% arg_x)) + (movq ($ '1) (% arg_y)) + (testq (% number) (% number)) + (cmovsq (% arg_x) (% arg_z)) + (cmovnsq (% arg_y) (% arg_z)) + (single-value-return)) + +;;; see %logcount. +(defx86lapfunction %ilogcount ((number arg_z)) + (let ((rshift imm0) + (temp imm1)) + (unbox-fixnum number rshift) + (xorq (% arg_z) (% arg_z)) + (testq (% rshift) (% rshift)) + (jmp @test) + @next + (lea (@ -1 (% rshift)) (% temp)) + (and (% temp) (% rshift)) ; sets flags + (lea (@ '1 (% arg_z)) (% arg_z)) ; doesn't set flags + @test + (jne @next) + (single-value-return))) + +(defx86lapfunction %iash ((number arg_y) (count arg_z)) + (unbox-fixnum count imm1) + (unbox-fixnum number imm0) + (xorq (% rcx) (% rcx)) ;rcx = imm2 + (testq (% count) (% count)) + (jge @left) + (subb (% imm1.b) (% cl)) + (sar (% cl) (% imm0)) + (box-fixnum imm0 arg_z) + (single-value-return) + @left + (movb (% imm1.b) (% cl)) + (shl (% cl) (% number)) + (movq (% number) (% arg_z)) + (single-value-return)) + +(defparameter *double-float-zero* 0.0d0) +(defparameter *short-float-zero* 0.0s0) + + +(defx86lapfunction %fixnum-intlen ((number arg_z)) + (unbox-fixnum arg_z imm0) + (movq (% imm0) (% imm1)) + (notq (% imm1)) + (testq (% imm0) (% imm0)) + (cmovsq (% imm1) (% imm0)) + (bsrq (% imm0) (% imm0)) + (setne (% imm1.b)) + (addb (% imm1.b) (% imm0.b)) + (box-fixnum imm0 arg_z) + (single-value-return)) + + +;;; Caller guarantees that result fits in a fixnum. + +(defx86lapfunction %truncate-double-float->fixnum ((arg arg_z)) + (get-double-float arg fp1) + (cvttsd2si (% fp1) (% imm0)) + (box-fixnum imm0 arg_z) + (single-value-return)) + + +(defx86lapfunction %truncate-short-float->fixnum ((arg arg_z)) + (get-single-float arg fp1) + (cvttss2si (% fp1) (% imm0)) + (box-fixnum imm0 arg_z) + (single-value-return)) + +;;; DOES round to even + +(defx86lapfunction %round-nearest-double-float->fixnum ((arg arg_z)) + (get-double-float arg fp1) + (cvtsd2si (% fp1) (% imm0)) + (box-fixnum imm0 arg_z) + (single-value-return)) + + +(defx86lapfunction %round-nearest-short-float->fixnum ((arg arg_z)) + (get-single-float arg fp1) + (cvtss2si (% fp1) (% imm0)) + (box-fixnum imm0 arg_z) + (single-value-return)) + + +;;; We'll get a SIGFPE if divisor is 0. +;;; Don't use %rbp. Trust callback_for_interrupt() to preserve +;;; the word below the stack pointer +(defx86lapfunction %fixnum-truncate ((dividend arg_y) (divisor arg_z)) + (save-simple-frame) + (unbox-fixnum divisor imm0) + (movq (% imm0) (% imm2)) + (unbox-fixnum dividend imm0) + (cqto) ; imm1 := sign_extend(imm0) + (idivq (% imm2)) + (pop (% rbp)) + (movq (% rsp) (% temp0)) + (box-fixnum imm1 arg_y) + (box-fixnum imm0 arg_z) + (pushq (% arg_z)) + (pushq (% arg_y)) + (set-nargs 2) + (jmp-subprim .SPvalues)) + +(defx86lapfunction called-for-mv-p () + (ref-global ret1valaddr imm0) + (movq (@ x8664::lisp-frame.return-address (% rbp)) (% imm1)) + (cmpq (% imm0) (% imm1)) + (movq ($ t) (% imm0)) + (movq ($ nil) (% arg_z)) + (cmoveq (% imm0) (% arg_z)) + (single-value-return)) + + +;;; n1 and n2 must be positive (esp non zero) +(defx86lapfunction %fixnum-gcd ((boxed-u arg_y) (boxed-v arg_z)) + (let ((u imm0) + (v imm1) + (k imm2)) + (xorl (% imm2.l) (% imm2.l)) + (bsfq (% boxed-u) (% u)) + (bsfq (% boxed-v) (% v)) + (rcmp (% u) (% v)) + (cmovlel (%l u) (%l k)) + (cmovgl (%l v) (%l k)) + (unbox-fixnum boxed-u u) + (unbox-fixnum boxed-v v) + (subb ($ x8664::fixnumshift) (%b k)) + (jz @start) + (shrq (% cl) (% u)) + (shrq (% cl) (% v)) + @start + ;; At least one of u or v is odd at this point + @loop + ;; if u is even, shift it right one bit + (testb ($ 1) (%b u)) + (jne @u-odd) + (shrq ($ 1) (% u)) + (jmp @test) + @u-odd + ;; if v is even, shift it right one bit + (testb ($ 1) (%b v)) + (jne @both-odd) + (shrq ($ 1) (% v)) + (jmp @test-u) + @both-odd + (cmpq (% v) (% u)) + (jb @v>u) + (subq (% v) (% u)) + (shrq ($ 1) (% u)) + (jmp @test) + @v>u + (subq (% u) (% v)) + (shrq ($ 1) (% v)) + @test-u + (testq (% u) (% u)) + @test + (ja @loop) + (shlq (% cl) (% v)) + (movb ($ 0) (% cl)) + (box-fixnum v arg_z) + (single-value-return))) + + + +;;; End of x86-numbers.lisp +) ; #+x8664-target Index: /branches/new-random/level-0/X86/x86-pred.lisp =================================================================== --- /branches/new-random/level-0/X86/x86-pred.lisp (revision 13309) +++ /branches/new-random/level-0/X86/x86-pred.lisp (revision 13309) @@ -0,0 +1,191 @@ +;;;-*- Mode: Lisp; Package: CCL -*- +;;; +;;; Copyright (C) 2009 Clozure Associates +;;; Copyright (C) 1994-2001 Digitool, Inc +;;; This file is part of Clozure CL. +;;; +;;; Clozure CL is licensed under the terms of the Lisp Lesser GNU Public +;;; License , known as the LLGPL and distributed with Clozure CL as the +;;; file "LICENSE". The LLGPL consists of a preamble and the LGPL, +;;; which is distributed with Clozure CL as the file "LGPL". Where these +;;; conflict, the preamble takes precedence. +;;; +;;; Clozure CL is referenced in the preamble as the "LIBRARY." +;;; +;;; The LLGPL is also available online at +;;; http://opensource.franz.com/preamble.html + +(in-package "CCL") +#+x8664-target +(progn + +(eval-when (:compile-toplevel :execute) + (require "X86-LAPMACROS")) + + +(defx86lapfunction eql ((x arg_y) (y arg_z)) + "Return T if OBJ1 and OBJ2 represent either the same object or +numbers with the same type and value." + (check-nargs 2) + @top + @tail + (cmpq (% x) (% y)) + (je @win) + (extract-fulltag x imm0) + (extract-fulltag y imm1) + (cmpb (% imm0.b) (% imm1.b)) + (jnz @lose) + (cmpb ($ x8664::fulltag-misc) (% imm0.b)) + (jnz @lose) + (getvheader x imm0) + (getvheader y imm1) + (cmpb ($ x8664::subtag-macptr) (% imm0.b)) + (je @macptr) ; will need to check %imm1.b + (cmpq (% imm0) (% imm1)) + (jne @lose) + (cmpb ($ x8664::subtag-bignum) (% imm0.b)) + (je @bignum) + (cmpb ($ x8664::subtag-double-float) (% imm0.b)) + (je @double-float) + (cmpb ($ x8664::subtag-complex) (% imm0.b)) + (je @complex) + (cmpb ($ x8664::subtag-ratio) (% imm0.b)) + (je @ratio) + @lose + (movq ($ nil) (% arg_z)) + (single-value-return) + @macptr + (cmpb ($ x8664::subtag-macptr) (% imm1.b)) + (jne @lose) + @double-float + (movq (@ x8664::misc-data-offset (% x)) (% imm0)) + (movq (@ x8664::misc-data-offset (% y)) (% imm1)) + @test + (cmpq (% imm0) (% imm1)) + (movl ($ (target-t-value)) (%l imm0)) + (lea (@ (- x8664::t-offset) (% imm0)) (% arg_z)) + (cmovel (%l imm0) (%l arg_z)) + (single-value-return) + @win + (movq ($ t) (% arg_z)) + (single-value-return) + @ratio + @complex + (save-simple-frame) + (pushq (@ x8664::ratio.denom (% x))) ; aka complex.imagpart + (pushq (@ x8664::ratio.denom (% y))) + (movq (@ x8664::ratio.numer (% x)) (% x)) ; aka complex.realpart + (movq (@ x8664::ratio.numer (% y)) (% y)) ; aka complex.realpart + (:talign 3) + (call @top) + (recover-fn-from-rip) + (cmp-reg-to-nil arg_z) + (pop (% y)) + (pop (% x)) + (restore-simple-frame) + (jnz @tail) + ;; lose, again + (movq ($ nil) (% arg_z)) + (single-value-return) + @bignum + ;; Way back when, we got x's header into imm0. We know that y's + ;; header is identical. Use the element-count from imm0 to control + ;; the loop. There's no such thing as a 0-element bignum, so the + ;; loop must always execute at least once. + (header-length imm0 temp0) + (xorq (% imm1) (% imm1)) + @bignum-next + (movl (@ x8664::misc-data-offset (% x) (% imm1)) (% imm0.l)) + (cmpl (@ x8664::misc-data-offset (% y) (% imm1)) (% imm0.l)) + (jne @lose) + (addq ($ 4) (% imm1)) + (sub ($ '1) (% temp0)) + (jnz @bignum-next) + (movq ($ t) (% arg_z)) + (single-value-return)) + + + +(defx86lapfunction equal ((x arg_y) (y arg_z)) + "Return T if X and Y are EQL or if they are structured components + whose elements are EQUAL. Strings and bit-vectors are EQUAL if they + are the same length and have identical components. Other arrays must be + EQ to be EQUAL. Pathnames are EQUAL if their components are." + (check-nargs 2) + @top + @tail + (cmpq (% x) (% y)) + (je @win) + (extract-fulltag x imm0) + (extract-fulltag y imm1) + (cmpb (% imm0.b) (% imm1.b)) + (jne @lose) + (cmpb ($ x8664::fulltag-cons) (% imm0.b)) + (je @cons) + (cmpb ($ x8664::fulltag-misc) (% imm0.b)) + (je @misc) + @lose + (movq ($ nil) (% arg_z)) + (single-value-return) + @win + (movq ($ t) (% arg_z)) + (single-value-return) + @cons + ;; Check to see if the CARs are EQ. If so, we can avoid saving + ;; context, and can just tail call ourselves on the CDRs. + (%car x temp0) + (%car y temp1) + (cmpq (% temp0) (% temp1)) + (jne @recurse) + (%cdr x x) + (%cdr y y) + (jmp @tail) + @recurse + (save-simple-frame) + (pushq (@ x8664::cons.cdr (% x))) + (pushq (@ x8664::cons.cdr (% y))) + (movq (% temp0) (% x)) + (movq (% temp1) (% y)) + (:talign 4) + (call @top) + (recover-fn-from-rip) + (cmp-reg-to-nil arg_z) + (pop (% y)) + (pop (% x)) + (restore-simple-frame) + (jnz @top) + (movl ($ nil) (% arg_z.l)) + (single-value-return) + @misc + ;; Both objects are uvectors of some sort. Try EQL; if that fails, + ;; call HAIRY-EQUAL. + (save-simple-frame) + (pushq (% x)) + (pushq (% y)) + (call-symbol eql 2) + (cmp-reg-to-nil arg_z) + (jne @won-with-eql) + (popq (% y)) + (popq (% x)) + (restore-simple-frame) + (jump-symbol hairy-equal 2) + @won-with-eql + (restore-simple-frame) ; discards pushed args + (movl ($ t) (% arg_z.l)) + (single-value-return)) + +(defx86lapfunction %lisp-lowbyte-ref ((thing arg_z)) + (box-fixnum thing arg_z) + (andl ($ '#xff) (%l arg_z)) + (single-value-return)) + + + + + + + + + + +) ; #+x8664-target Index: /branches/new-random/level-0/X86/x86-symbol.lisp =================================================================== --- /branches/new-random/level-0/X86/x86-symbol.lisp (revision 13309) +++ /branches/new-random/level-0/X86/x86-symbol.lisp (revision 13309) @@ -0,0 +1,166 @@ +;;;-*- Mode: Lisp; Package: CCL -*- +;;; +;;; Copyright (C) 2009 Clozure Associates +;;; Copyright (C) 1994-2001 Digitool, Inc +;;; This file is part of Clozure CL. +;;; +;;; Clozure CL is licensed under the terms of the Lisp Lesser GNU Public +;;; License , known as the LLGPL and distributed with Clozure CL as the +;;; file "LICENSE". The LLGPL consists of a preamble and the LGPL, +;;; which is distributed with Clozure CL as the file "LGPL". Where these +;;; conflict, the preamble takes precedence. +;;; +;;; Clozure CL is referenced in the preamble as the "LIBRARY." +;;; +;;; The LLGPL is also available online at +;;; http://opensource.franz.com/preamble.html + +(in-package "CCL") +#+x8664-target +(progn + +(eval-when (:compile-toplevel :execute) + (require "X8664-ARCH") + (require "X86-LAPMACROS")) + +;;; This assumes that macros & special-operators +;;; have something that's not FUNCTIONP in their +;;; function-cells. It also assumes that NIL +;;; isn't a true symbol, but that NILSYM is. +(defx86lapfunction %function ((sym arg_z)) + (check-nargs 1) + (let ((symaddr temp0)) + (movq ($ (+ (target-nil-value) x8664::nilsym-offset)) (% symaddr)) + (cmp-reg-to-nil sym) + (cmovneq (% sym) (% symaddr)) + (trap-unless-fulltag= symaddr x8664::fulltag-symbol) + (movq (% sym) (% arg_y)) + (movq (@ x8664::symbol.fcell (% symaddr)) (% arg_z)) + (extract-fulltag arg_z imm0) + (cmpb ($ x8664::fulltag-function) (%b imm0)) + (je.pt @ok) + (uuo-error-udf (% arg_y)) + @ok + (single-value-return))) + +;;; Traps unless sym is NIL or some other symbol. If NIL, return +;;; nilsym +(defx86lapfunction %symbol->symptr ((sym arg_z)) + (let ((tag imm0)) + (movq ($ (+ (target-nil-value) x8664::nilsym-offset)) (% tag)) + (cmp-reg-to-nil sym) + (cmoveq (% tag) (% sym)) + (je :done) + (trap-unless-fulltag= sym x8664::fulltag-symbol) + :done + (single-value-return))) + +;;; If symptr is NILSYM, return NIL; else typecheck and return symptr +(defx86lapfunction %symptr->symbol ((symptr arg_z)) + (movw ($ (ash 1 x8664::fulltag-symbol)) (% imm0.w)) + (btw (%w symptr) (% imm0.w)) + (jb.pt @ok) + (uuo-error-reg-not-tag (% symptr) ($ x8664::fulltag-symbol)) + @ok + (cmpq ($ (+ (target-nil-value) x8664::nilsym-offset)) (% symptr)) + (sete (% imm0.b)) + (negb (% imm0.b)) + (andl ($ x8664::nilsym-offset) (% imm0.l)) + (subq (% imm0) (% symptr)) + (single-value-return)) + + +;;; Given something whose fulltag is FULLTAG-SYMBOL, return the +;;; underlying uvector. This function and its inverse would +;;; be good candidates for inlining. +(defx86lapfunction %symptr->symvector ((symptr arg_z)) + (subb ($ (- x8664::fulltag-symbol x8664::fulltag-misc)) (% arg_z.b)) + (single-value-return)) + +(defx86lapfunction %symvector->symptr ((symbol-vector arg_z)) + (addb ($ (- x8664::fulltag-symbol x8664::fulltag-misc)) (% arg_z.b)) + (single-value-return)) + +(defx86lapfunction %symptr-value ((symptr arg_z)) + (jmp-subprim .SPspecref)) + +(defx86lapfunction %set-symptr-value ((symptr arg_y) (val arg_z)) + (jmp-subprim .SPspecset)) + +;;; This gets a tagged symbol as an argument. +;;; If there's no thread-local binding, it should return +;;; the underlying symbol vector as a first return value. +(defx86lapfunction %symptr-binding-address ((symptr arg_z)) + (movq (@ x8664::symbol.binding-index (% symptr)) (% arg_y)) + (rcmp (% arg_y) (:rcontext x8664::tcr.tlb-limit)) + (movq (:rcontext x8664::tcr.tlb-pointer) (% arg_x)) + (jae @sym) + (cmpb ($ x8664::no-thread-local-binding-marker) (@ (% arg_x) (% arg_y))) + (je @sym) + (shl ($ x8664::word-shift) (% arg_y)) + (push (% arg_x)) + (push (% arg_y)) + (set-nargs 2) + (lea (@ '2 (% rsp)) (% temp0)) + (jmp-subprim .SPvalues) + @sym + (subb ($ (- x8664::fulltag-symbol x8664::fulltag-misc)) (% arg_z.b)) + (push (% arg_z)) + (pushq ($ '#.x8664::symptr.vcell)) + (set-nargs 2) + (lea (@ '2 (% rsp)) (% temp0)) + (jmp-subprim .SPvalues)) + +(defx86lapfunction %tcr-binding-location ((tcr arg_y) (sym arg_z)) + (movq (@ x8664::symbol.binding-index (% sym)) (% arg_x)) + (movl ($ nil) (% arg_z.l)) + (rcmp (% arg_x) (@ x8664::tcr.tlb-limit (% tcr))) + (movq (@ x8664::tcr.tlb-pointer (% tcr)) (% arg_y)) + (jae @done) + (lea (@ (% arg_y) (% arg_x)) (% arg_y)) + ;; We're little-endian, so the tag is at the EA with no + ;; displacement + (cmpb ($ x8664::subtag-no-thread-local-binding) (@ (% arg_y))) + (cmovneq (% arg_y) (% arg_z)) + @done + (single-value-return)) + + +(defx86lapfunction %pname-hash ((str arg_y) (len arg_z)) + (let ((accum imm0) + (offset imm1)) + (xorq (% offset) (% offset)) + (xorq (% accum) (% accum)) + (testq (% len) (% len)) + (jz @done) + @loop8 + (roll ($ 5) (%l accum)) + (xorl (@ x8664::misc-data-offset (% str) (% offset) 4) (%l accum)) + (addq ($ 1) (% offset)) + (subq ($ '1) (% len)) + (jnz @loop8) + (shlq ($ 5) (% accum)) + (shrq ($ (- 5 x8664::fixnumshift)) (% accum)) + (movq (% accum) (% arg_z)) + @done + (single-value-return))) + +(defx86lapfunction %string-hash ((start arg_x) (str arg_y) (len arg_z)) + (let ((accum imm0) + (offset imm1)) + (unbox-fixnum start offset) + (xorq (% accum) (% accum)) + (testq (% len) (% len)) + (jz @done) + @loop8 + (roll ($ 5) (%l accum)) + (xorl (@ x8664::misc-data-offset (% str) (% offset) 4) (%l accum)) + (addq ($ 1) (% offset)) + (subq ($ '1) (% len)) + (jnz @loop8) + (shlq ($ 5) (% accum)) + (shrq ($ (- 5 x8664::fixnumshift)) (% accum)) + (movq (% accum) (% arg_z)) + @done + (single-value-return))) +) ; #+x8664-target Index: /branches/new-random/level-0/X86/x86-utils.lisp =================================================================== --- /branches/new-random/level-0/X86/x86-utils.lisp (revision 13309) +++ /branches/new-random/level-0/X86/x86-utils.lisp (revision 13309) @@ -0,0 +1,548 @@ +; -*- Mode: Lisp; Package: CCL; -*- +;;; +;;; Copyright (C) 2009 Clozure Associates +;;; Copyright (C) 1994-2001 Digitool, Inc +;;; This file is part of Clozure CL. +;;; +;;; Clozure CL is licensed under the terms of the Lisp Lesser GNU Public +;;; License , known as the LLGPL and distributed with Clozure CL as the +;;; file "LICENSE". The LLGPL consists of a preamble and the LGPL, +;;; which is distributed with Clozure CL as the file "LGPL". Where these +;;; conflict, the preamble takes precedence. +;;; +;;; Clozure CL is referenced in the preamble as the "LIBRARY." +;;; +;;; The LLGPL is also available online at +;;; http://opensource.franz.com/preamble.html + + +(in-package "CCL") +#+x8664-target +(progn + +(defx86lapfunction %address-of ((arg arg_z)) + ;; %address-of a fixnum is a fixnum, just for spite. + ;; %address-of anything else is the address of that thing as an integer. + (testb ($ x8664::fixnummask) (%b arg)) + (je @done) + (movq (% arg) (% imm0)) + (jmp-subprim .SPmakeu64) + @done + (single-value-return)) + +;;; "areas" are fixnum-tagged and, for the most part, so are their +;;; contents. + +;;; The nilreg-relative global all-areas is a doubly-linked-list header +;;; that describes nothing. Its successor describes the current/active +;;; dynamic heap. Return a fixnum which "points to" that area, after +;;; ensuring that the "active" pointers associated with the current thread's +;;; stacks are correct. + + + +(defx86lapfunction %normalize-areas () + (let ((address temp0) + (temp temp1)) + + ; update active pointer for tsp area. + (movq (:rcontext x8664::tcr.ts-area) (% address)) + (movq (:rcontext x8664::tcr.save-tsp) (% temp)) + (movq (% temp) (@ x8664::area.active (% address))) + + ;; Update active pointer for vsp area. + (movq (:rcontext x8664::tcr.vs-area) (% address)) + (movq (% rsp) (@ x8664::area.active (% address))) + + (ref-global all-areas arg_z) + (movq (@ x8664::area.succ (% arg_z)) (% arg_z)) + + (single-value-return))) + +(defx86lapfunction %active-dynamic-area () + (ref-global all-areas arg_z) + (movq (@ x8664::area.succ (% arg_z)) (% arg_z)) + (single-value-return)) + + +(defx86lapfunction %object-in-stack-area-p ((object arg_y) (area arg_z)) + (movq (@ x8664::area.active (% area)) (% imm0)) + (movq (@ x8664::area.high (% area)) (% imm1)) + (rcmp (% object) (% imm0)) + (movq ($ nil) (% arg_z)) + (movq ($ t) (% imm0)) + (jb @done) + (rcmp (% object) (% imm1)) + (cmovbq (% imm0) (% arg_z)) + @done + (single-value-return)) + +(defx86lapfunction %object-in-heap-area-p ((object arg_y) (area arg_z)) + (rcmp (% object) (@ x8664::area.low (% area))) + (setae (%b imm0)) + (rcmp (% object) (@ x8664::area.low (% area))) + (setb (%b imm1)) + (andb (% imm1.b) (% imm0.b)) + (andl ($ x8664::t-offset) (%l imm0)) + (lea (@ (target-nil-value) (% imm0)) (% arg_z)) + (single-value-return)) + + + + +(defx86lapfunction walk-static-area ((a arg_y) (f arg_z)) + (let ((fun save0) + (obj save1) + (limit save2)) + (save-simple-frame) + (push (% fun)) + (push (% obj)) + (push (% limit)) + (movq (% f) (% fun)) + (movq (@ x8664::area.active (% a)) (% limit)) + (movq (@ x8664::area.low (% a)) (% obj)) + (jmp @test) + @loop + (movb (@ (% obj)) (% imm0.b)) + (andb ($ x8664::fulltagmask) (% imm0.b)) + (cmpb ($ x8664::fulltag-nodeheader-0) (% imm0.b)) + (je @misc) + (cmpb ($ x8664::fulltag-nodeheader-1) (% imm0.b)) + (je @misc) + (cmpb ($ x8664::fulltag-immheader-0) (% imm0.b)) + (je @misc) + (cmpb ($ x8664::fulltag-immheader-2) (% imm0.b)) + (je @misc) + (cmpb ($ x8664::fulltag-immheader-1) (% imm0.b)) + (jne @cons) + @misc + (lea (@ x8664::fulltag-misc (% obj)) (% obj)) + (movq (% obj) (% arg_z)) + (set-nargs 1) + (:talign 4) + (call (% fun)) + (recover-fn-from-rip) + (getvheader obj imm1) + (movb (% imm1.b) (% imm0.b)) + (andb ($ x8664::fulltagmask) (% imm0.b)) + (cmpb ($ x8664::fulltag-nodeheader-0) (% imm0.b)) + (je @64) + (cmpb ($ x8664::fulltag-nodeheader-1) (% imm0.b)) + (je @64) + (cmpb ($ x8664::ivector-class-64-bit) (% imm0.b)) + (jne @not64) + @64 + (shrq ($ x8664::num-subtag-bits) (% imm1)) + (shlq ($ x8664::word-shift) (% imm1)) + (jmp @uvector-next) + @not64 + (cmpb ($ x8664::ivector-class-32-bit) (% imm0.b)) + (jne @not32) + (shrq ($ x8664::num-subtag-bits) (% imm1)) + (shlq ($ 2) (% imm1)) + (jmp @uvector-next) + @not32 + (cmpb ($ (- x8664::subtag-bit-vector 256)) (% imm1.b)) + (jne @not-bit) + (shrq ($ x8664::num-subtag-bits) (% imm1)) + (addq ($ 7) (% imm1)) + (shrq ($ 3) (% imm1)) + (jmp @uvector-next) + @not-bit + (rcmpb (% imm1.b) ($ (- x8664::min-8-bit-ivector-subtag 256))) + (jb @16) + (shrq ($ x8664::num-subtag-bits) (% imm1)) + (jmp @uvector-next) + @16 + (shrq ($ x8664::num-subtag-bits) (% imm1)) + (shlq ($ 1) (% imm1)) + (jmp @uvector-next) + @cons + (addq ($ x8664::fulltag-cons) (% obj)) + (movq (% obj) (% arg_z)) + (set-nargs 1) + (:talign 4) + (call (% fun)) + (recover-fn-from-rip) + (addq ($ (- x8664::cons.size x8664::fulltag-cons)) (% obj)) + (jmp @test) + ;; size of OBJ in bytes (without header or alignment padding) + ;; in imm1. + @uvector-next + (addq ($ (+ x8664::node-size (1- x8664::dnode-size))) (% imm1)) + (andb ($ (lognot (1- x8664::dnode-size))) (% imm1.b)) + (lea (@ (- x8664::fulltag-misc) (% obj) (% imm1)) (% obj)) + @test + (cmpq (% limit) (% obj)) + (jb @loop) + (pop (% limit)) + (pop (% obj)) + (pop (% fun)) + (movl ($ (target-nil-value)) (% arg_z.l)) + (restore-simple-frame) + (single-value-return))) + + + +;;; This walks the active "dynamic" area. Objects might be moving around +;;; while we're doing this, so we have to be a lot more careful than we +;;; are when walking a static area. +;;; There are a couple of approaches to termination: +;;; a) Allocate a "sentinel" cons, and terminate when we run into it. +;;; b) Check the area limit (which is changing if we're consing) and +;;; terminate when we hit it. +;;; (b) loses if the function conses. (a) conses. I can't think of anything +;;; better than (a). +;;; This, of course, assumes that any GC we're doing does in-place compaction +;;; (or at least preserves the relative order of objects in the heap.) + +(defx86lapfunction %walk-dynamic-area ((a arg_y) (f arg_z)) + (let ((fun save0) + (obj save1) + (limit save2)) + (save-simple-frame) + (push (% fun)) + (push (% obj)) + (push (% limit)) + (movq (% f) (% fun)) + (ref-global tenured-area a) + (movq (@ x8664::area.low (% a)) (% obj)) + (subq ($ (- x8664::cons.size x8664::fulltag-cons)) + (:rcontext x8664::tcr.save-allocptr)) + (movq (:rcontext x8664::tcr.save-allocptr) (% allocptr)) + (cmpq (:rcontext x8664::tcr.save-allocbase) (% allocptr)) + (ja @ok) + (uuo-alloc) + @ok + (andb ($ (lognot x8664::fulltagmask)) + (:rcontext x8664::tcr.save-allocptr)) + (movq (% allocptr) (% limit)) + (jmp @test) + @loop + (movb (@ (% obj)) (% imm0.b)) + (andb ($ x8664::fulltagmask) (% imm0.b)) + (cmpb ($ x8664::fulltag-nodeheader-0) (% imm0.b)) + (je @misc) + (cmpb ($ x8664::fulltag-nodeheader-1) (% imm0.b)) + (je @misc) + (cmpb ($ x8664::fulltag-immheader-0) (% imm0.b)) + (je @misc) + (cmpb ($ x8664::fulltag-immheader-2) (% imm0.b)) + (je @misc) + (cmpb ($ x8664::fulltag-immheader-1) (% imm0.b)) + (jne @cons) + @misc + (lea (@ x8664::fulltag-misc (% obj)) (% obj)) + (movq (% obj) (% arg_z)) + (set-nargs 1) + (:talign 4) + (call (% fun)) + (recover-fn-from-rip) + (getvheader obj imm1) + (movb (% imm1.b) (% imm0.b)) + (andb ($ x8664::fulltagmask) (% imm0.b)) + (cmpb ($ x8664::fulltag-nodeheader-0) (% imm0.b)) + (je @64) + (cmpb ($ x8664::fulltag-nodeheader-1) (% imm0.b)) + (je @64) + (cmpb ($ x8664::ivector-class-64-bit) (% imm0.b)) + (jne @not64) + @64 + (shrq ($ x8664::num-subtag-bits) (% imm1)) + (shlq ($ x8664::word-shift) (% imm1)) + (jmp @uvector-next) + @not64 + (cmpb ($ x8664::ivector-class-32-bit) (% imm0.b)) + (jne @not32) + (shrq ($ x8664::num-subtag-bits) (% imm1)) + (shlq ($ 2) (% imm1)) + (jmp @uvector-next) + @not32 + (cmpb ($ (- x8664::subtag-bit-vector 256)) (% imm1.b)) + (jne @not-bit) + (shrq ($ x8664::num-subtag-bits) (% imm1)) + (addq ($ 7) (% imm1)) + (shrq ($ 3) (% imm1)) + (jmp @uvector-next) + @not-bit + (rcmpb (% imm1.b) ($ (- x8664::min-8-bit-ivector-subtag 256))) + (jb @16) + (shrq ($ x8664::num-subtag-bits) (% imm1)) + (jmp @uvector-next) + @16 + (shrq ($ x8664::num-subtag-bits) (% imm1)) + (shlq ($ 1) (% imm1)) + (jmp @uvector-next) + @cons + (addq ($ x8664::fulltag-cons) (% obj)) + (cmpq (% obj) (% limit)) + (movq (% obj) (% arg_z)) + (je @done) + (set-nargs 1) + (:talign 4) + (call (% fun)) + (recover-fn-from-rip) + (addq ($ (- x8664::cons.size x8664::fulltag-cons)) (% obj)) + (jmp @test) + ;; size of OBJ in bytes (without header or alignment padding) + ;; in imm1. + @uvector-next + (addq ($ (+ x8664::node-size (1- x8664::dnode-size))) (% imm1)) + (andb ($ (lognot (1- x8664::dnode-size))) (% imm1.b)) + (lea (@ (- x8664::fulltag-misc) (% obj) (% imm1)) (% obj)) + @test + (cmpq (% limit) (% obj)) + (jb @loop) + @done + (pop (% limit)) + (pop (% obj)) + (pop (% fun)) + (movl ($ (target-nil-value)) (% arg_z.l)) + (restore-simple-frame) + (single-value-return))) + +(defun walk-dynamic-area (area func) + (with-other-threads-suspended + (%walk-dynamic-area area func))) + + + +(defx86lapfunction %class-of-instance ((i arg_z)) + (svref i instance.class-wrapper arg_z) + (svref arg_z %wrapper-class arg_z) + (single-value-return)) + +(defx86lapfunction class-of ((x arg_z)) + (check-nargs 1) + (movw ($ (logior (ash 1 x8664::tag-list) + (ash 1 x8664::tag-imm-1))) + (%w imm1)) + (extract-lisptag x imm0) + (btw (% imm0.w) (% imm1.w)) + (cmovbl (% arg_z.l) (% imm0.l)) + (movq (@ '*class-table* (% fn)) (% temp1)) + (cmpb ($ x8664::tag-misc) (% imm0.b)) + (jne @have-tag) + (extract-subtag x imm0) + @have-tag + (movq (@ x8664::symbol.vcell (% temp1)) (% temp1)) + (movzbl (% imm0.b) (% imm0.l)) + (movq (@ x8664::misc-data-offset (% temp1) (% imm0) 8) (% temp0)) + (cmpb ($ x8664::fulltag-nil) (%b temp0)) + (je @bad) + (extract-fulltag temp0 imm0) + (cmpb ($ x8664::fulltag-function) (%b imm0)) + (jne @ret) + (set-nargs 1) + (jmp (% temp0)) + @bad + (load-constant no-class-error fname) + (set-nargs 1) + (jmp (@ x8664::symbol.fcell (% fname))) + @ret + (movq (% temp0) (% arg_z)) ; return frob from table + (single-value-return)) + +(defx86lapfunction full-gccount () + (ref-global tenured-area arg_z) + (testq (% arg_z) (% arg_z)) + (cmoveq (@ (+ (target-nil-value) (x8664::%kernel-global 'gc-count))) (% arg_z)) + (cmovneq (@ x8664::area.gc-count (% arg_z)) (% arg_z)) + (single-value-return)) + + +(defx86lapfunction gc () + (check-nargs 0) + (movq ($ arch::gc-trap-function-gc) (% imm0)) + (uuo-gc-trap) + (movq ($ nil) (% arg_z)) + (single-value-return)) + + +(defx86lapfunction egc ((arg arg_z)) + "Enable the EGC if arg is non-nil, disables the EGC otherwise. Return +the previous enabled status. Although this function is thread-safe (in +the sense that calls to it are serialized), it doesn't make a whole lot +of sense to be turning the EGC on and off from multiple threads ..." + (check-nargs 1) + (clrq imm1) + (cmp-reg-to-nil arg) + (setne (% imm1.b)) + (movq ($ arch::gc-trap-function-egc-control) (% imm0)) + (uuo-gc-trap) + (single-value-return)) + + + + +(defx86lapfunction %configure-egc ((e0size arg_x) + (e1size arg_y) + (e2size arg_z)) + (check-nargs 3) + (movq ($ arch::gc-trap-function-configure-egc) (% imm0)) + (uuo-gc-trap) + (single-value-return)) + +(defx86lapfunction purify () + (check-nargs 0) + (movq ($ arch::gc-trap-function-purify) (% imm0)) + (uuo-gc-trap) + (movq ($ nil) (% arg_z)) + (single-value-return)) + + +(defx86lapfunction impurify () + (check-nargs 0) + (movq ($ arch::gc-trap-function-impurify) (% imm0)) + (uuo-gc-trap) + (movq ($ nil) (% arg_z)) + (single-value-return)) + + +(defx86lapfunction lisp-heap-gc-threshold () + "Return the value of the kernel variable that specifies the amount +of free space to leave in the heap after full GC." + (check-nargs 0) + (movq ($ arch::gc-trap-function-get-lisp-heap-threshold) (% imm0)) + (uuo-gc-trap) + #+x8632-target + (jmp-subprim .SPmakeu32) + #+x8664-target + (jmp-subprim .SPmakeu64)) + +(defx86lapfunction set-lisp-heap-gc-threshold ((new arg_z)) + "Set the value of the kernel variable that specifies the amount of free +space to leave in the heap after full GC to new-value, which should be a +non-negative fixnum. Returns the value of that kernel variable (which may +be somewhat larger than what was specified)." + (check-nargs 1) + (save-simple-frame) + (call-subprim .SPgetu64) + (movq (% imm0) (% imm1)) + (movq ($ arch::gc-trap-function-set-lisp-heap-threshold) (% imm0)) + (uuo-gc-trap) + (restore-simple-frame) + (jmp-subprim .SPmakeu64)) + + +(defx86lapfunction use-lisp-heap-gc-threshold () + "Try to grow or shrink lisp's heap space, so that the free space is (approximately) equal to the current heap threshold. Return NIL" + (check-nargs 0) + (movq ($ arch::gc-trap-function-use-lisp-heap-threshold) (% imm0)) + (uuo-gc-trap) + (movl ($ (target-nil-value)) (%l arg_z)) + (single-value-return)) + +(defx86lapfunction freeze () + "Do a full GC, then consider all heap-allocated objects which survive to be non-relocatable." + (movl ($ arch::gc-trap-function-freeze) (% imm0.l)) + (uuo-gc-trap) + (jmp-subprim .SPmakeu64)) + +(defx86lapfunction flash-freeze () + "Like FREEZE, without the GC." + (movl ($ arch::gc-trap-function-flash-freeze) (% imm0.l)) + (uuo-gc-trap) + (jmp-subprim .SPmakeu64)) + +(defx86lapfunction %watch ((thing arg_z)) + (check-nargs 1) + (movl ($ arch::watch-trap-function-watch) (%l imm0)) + (uuo-watch-trap) + (single-value-return)) + +(defx86lapfunction %unwatch ((watched arg_y) (new arg_z)) + (check-nargs 2) + (movl ($ arch::watch-trap-function-unwatch) (%l imm0)) + (uuo-watch-trap) + (single-value-return)) + +(defx86lapfunction %allocate-list ((initial-element arg_y) (nconses arg_z)) + (check-nargs 2) + (save-simple-frame) + (ud2a) + (:byte 10) + (push (% arg_z)) + (push (% allocptr)) + (set-nargs 2) + (jmp-subprim .SPnvalret)) + + +(defx86lapfunction %ensure-static-conses () + (check-nargs 0) + (movl ($ arch::gc-trap-function-ensure-static-conses) (% imm0.l)) + (uuo-gc-trap) + (movl ($ (target-nil-value)) (% arg_z.l)) + (single-value-return)) + + + +;;; offset is a fixnum, one of the x8664::kernel-import-xxx constants. +;;; Returns that kernel import, a fixnum. +(defx86lapfunction %kernel-import ((offset arg_z)) + (ref-global kernel-imports imm0) + (unbox-fixnum arg_z imm1) + (movq (@ (% imm0) (% imm1)) (% imm0)) + (box-fixnum imm0 arg_z) + (single-value-return)) + +(defx86lapfunction %get-unboxed-ptr ((macptr arg_z)) + (macptr-ptr arg_z imm0) + (movq (@ (% imm0)) (% arg_z)) + (single-value-return)) + + +(defx86lapfunction %revive-macptr ((p arg_z)) + (movb ($ x8664::subtag-macptr) (@ x8664::misc-subtag-offset (% p))) + (single-value-return)) + +(defx86lapfunction %macptr-type ((p arg_z)) + (check-nargs 1) + (trap-unless-typecode= p x8664::subtag-macptr) + (svref p x8664::macptr.type-cell imm0) + (box-fixnum imm0 arg_z) + (single-value-return)) + +(defx86lapfunction %macptr-domain ((p arg_z)) + (check-nargs 1) + (trap-unless-typecode= p x8664::subtag-macptr) + (svref p x8664::macptr.domain-cell imm0) + (box-fixnum imm0 arg_z) + (single-value-return)) + +(defx86lapfunction %set-macptr-type ((p arg_y) (new arg_z)) + (check-nargs 2) + (unbox-fixnum new imm1) + (trap-unless-typecode= p x8664::subtag-macptr) + (svset p x8664::macptr.type-cell imm1) + (single-value-return)) + +(defx86lapfunction %set-macptr-domain ((p arg_y) (new arg_z)) + (check-nargs 2) + (unbox-fixnum new imm1) + (trap-unless-typecode= p x8664::subtag-macptr) + (svset p x8664::macptr.domain-cell imm1) + (single-value-return)) + +(defx86lapfunction true () + (pop (% ra0)) + (subq ($ '3) (% nargs.q)) + (leaq (@ '2 (% rsp) (% nargs.q)) (% imm0)) + (cmovaq (% imm0) (% rsp)) + (movl ($ (target-t-value)) (%l arg_z)) + (push (% ra0)) + (single-value-return)) + +(defx86lapfunction false () + (pop (% ra0)) + (subq ($ '3) (% nargs.q)) + (leaq (@ '2 (% rsp) (% nargs.q)) (% imm0)) + (cmovaq (% imm0) (% rsp)) + (movl ($ (target-nil-value)) (%l arg_z)) + (push (% ra0)) + (single-value-return)) + + + +;;; end +) ; #+x8664-target Index: /branches/new-random/level-0/l0-aprims.lisp =================================================================== --- /branches/new-random/level-0/l0-aprims.lisp (revision 13309) +++ /branches/new-random/level-0/l0-aprims.lisp (revision 13309) @@ -0,0 +1,223 @@ +;;;-*- Mode: Lisp; Package: CCL -*- +;;; +;;; Copyright (C) 2009 Clozure Associates +;;; Copyright (C) 1994-2001 Digitool, Inc +;;; This file is part of Clozure CL. +;;; +;;; Clozure CL is licensed under the terms of the Lisp Lesser GNU Public +;;; License , known as the LLGPL and distributed with Clozure CL as the +;;; file "LICENSE". The LLGPL consists of a preamble and the LGPL, +;;; which is distributed with Clozure CL as the file "LGPL". Where these +;;; conflict, the preamble takes precedence. +;;; +;;; Clozure CL is referenced in the preamble as the "LIBRARY." +;;; +;;; The LLGPL is also available online at +;;; http://opensource.franz.com/preamble.html + + +(in-package "CCL") + +; l0-aprims.lisp + +;;; This weak list is used to track semaphores as well as locks. +(defvar %system-locks% nil) + + +(defun record-system-lock (l) + (atomic-push-uvector-cell %system-locks% population.data l) + l) + +;;; This has to run very early in the initial thread. +(defun %revive-system-locks () + (dolist (s (population-data %system-locks%)) + (%revive-macptr s) + (%setf-macptr s + (case (uvref s target::xmacptr.flags-cell) + (#.$flags_DisposeRecursiveLock + (ff-call + (%kernel-import target::kernel-import-new-recursive-lock) + :address)) + (#.$flags_DisposeRwlock + (ff-call + (%kernel-import target::kernel-import-rwlock-new) + :address)) + (#.$flags_DisposeSemaphore + (ff-call + (%kernel-import target::kernel-import-new-semaphore) + :signed-fullword 0 + :address)))) + (set-%gcable-macptrs% s))) + +(dolist (p %all-packages%) + (setf (pkg.lock p) (make-read-write-lock))) + +(defparameter %all-packages-lock% nil) + + + +(defun %cstr-pointer (string pointer &optional (nul-terminated t)) + (if (typep string 'simple-base-string) + (locally (declare (simple-base-string string) + (optimize (speed 3) (safety 0))) + (let* ((n (length string))) + (declare (fixnum n)) + (dotimes (i n) + (setf (%get-unsigned-byte pointer i) + (let* ((code (%scharcode string i))) + (declare (type (mod #x110000) code)) + (if (< code 256) + code + (char-code #\Sub))))) + (when nul-terminated + (setf (%get-byte pointer n) 0))) + nil) + (%cstr-segment-pointer string pointer 0 (length string) nul-terminated))) + +(defun %cstr-segment-pointer (string pointer start end &optional (nul-terminated t)) + (declare (fixnum start end)) + (let* ((n (- end start))) + (multiple-value-bind (s o) (dereference-base-string string) + (declare (fixnum o)) + (do* ((i 0 (1+ i)) + (o (the fixnum (+ o start)) (1+ o))) + ((= i n)) + (declare (fixnum i o)) + (setf (%get-unsigned-byte pointer i) + (let* ((code (char-code (schar s o)))) + (declare (type (mod #x110000) code)) + (if (< code 256) + code + (char-code #\Sub)))))) + (when nul-terminated + (setf (%get-byte pointer n) 0)) + nil)) + +(defun string (thing) + "Coerces X into a string. If X is a string, X is returned. If X is a + symbol, X's pname is returned. If X is a character then a one element + string containing that character is returned. If X cannot be coerced + into a string, an error occurs." + (etypecase thing + (string thing) + (symbol (symbol-name thing)) + (character (make-string 1 :initial-element thing)))) + + +(defun dereference-base-string (s) + (multiple-value-bind (vector offset) (array-data-and-offset s) + (unless (typep vector 'simple-base-string) (report-bad-arg s 'base-string)) + (values vector offset (length s)))) + +(defun make-gcable-macptr (flags) + (let ((v (%alloc-misc target::xmacptr.element-count target::subtag-macptr))) + (setf (uvref v target::xmacptr.address-cell) 0) ; ?? yup. + (setf (uvref v target::xmacptr.flags-cell) flags) + (set-%gcable-macptrs% v) + v)) + +(defun %make-recursive-lock-ptr () + (record-system-lock + (%setf-macptr + (make-gcable-macptr $flags_DisposeRecursiveLock) + (ff-call (%kernel-import target::kernel-import-new-recursive-lock) + :address)))) + +(defun %make-rwlock-ptr () + (record-system-lock + (%setf-macptr + (make-gcable-macptr $flags_DisposeRwLock) + (ff-call (%kernel-import target::kernel-import-rwlock-new) + :address)))) + +(defun make-recursive-lock () + (make-lock nil)) + +(defun %make-lock (pointer name) + (gvector :lock pointer 'recursive-lock 0 name nil nil)) + +(defun make-lock (&optional name) + "Create and return a lock object, which can be used for synchronization +between threads." + (%make-lock (%make-recursive-lock-ptr) name)) + +(defun lock-name (lock) + (uvref (require-type lock 'lock) target::lock.name-cell)) + +(defun recursive-lock-ptr (r) + (if (and (eq target::subtag-lock (typecode r)) + (eq (%svref r target::lock.kind-cell) 'recursive-lock)) + (%svref r target::lock._value-cell) + (report-bad-arg r 'recursive-lock))) + +(defun recursive-lock-whostate (r) + (if (and (eq target::subtag-lock (typecode r)) + (eq (%svref r target::lock.kind-cell) 'recursive-lock)) + (or (%svref r target::lock.whostate-cell) + (setf (%svref r target::lock.whostate-cell) + (%lock-whostate-string "Lock wait" r))) + (report-bad-arg r 'recursive-lock))) + + +(defun read-write-lock-ptr (rw) + (if (and (eq target::subtag-lock (typecode rw)) + (eq (%svref rw target::lock.kind-cell) 'read-write-lock)) + (%svref rw target::lock._value-cell) + (report-bad-arg rw 'read-write-lock))) + +(defun make-read-write-lock () + "Create and return a read-write lock, which can be used for +synchronization between threads." + (gvector :lock (%make-rwlock-ptr) 'read-write-lock 0 nil nil nil)) + +(defun rwlock-read-whostate (rw) + (if (and (eq target::subtag-lock (typecode rw)) + (eq (%svref rw target::lock.kind-cell) 'read-write-lock)) + (or (%svref rw target::lock.whostate-cell) + (setf (%svref rw target::lock.whostate-cell) + (%lock-whostate-string "Read lock wait" rw))) + (report-bad-arg rw 'read-write-lock))) + +(defun rwlock-write-whostate (rw) + (if (and (eq target::subtag-lock (typecode rw)) + (eq (%svref rw target::lock.kind-cell) 'read-write-lock)) + (or (%svref rw target::lock.whostate-2-cell) + (setf (%svref rw target::lock.whostate-2-cell) + (%lock-whostate-string "Write lock wait" rw))) + (report-bad-arg rw 'read-write-lock))) + + +(defun %make-semaphore-ptr () + (let* ((p (ff-call (%kernel-import target::kernel-import-new-semaphore) + :signed-fullword 0 + :address))) + (if (%null-ptr-p p) + (error "Can't create semaphore.") + (record-system-lock + (%setf-macptr + (make-gcable-macptr $flags_DisposeSemaphore) + p))))) + +(defun make-semaphore () + "Create and return a semaphore, which can be used for synchronization +between threads." + (%istruct 'semaphore (%make-semaphore-ptr))) + +(defun semaphorep (x) + (istruct-typep x 'semaphore)) + +(setf (type-predicate 'semaphore) 'semaphorep) + +(defun make-list (size &key initial-element) + "Constructs a list with size elements each set to value" + (unless (and (typep size 'fixnum) + (>= (the fixnum size) 0)) + (report-bad-arg size '(and fixnum unsigned-byte))) + (locally (declare (fixnum size)) + (if (>= size (ash 1 16)) + (values (%allocate-list initial-element size)) + (do* ((result '() (cons initial-element result))) + ((zerop size) result) + (decf size))))) + +; end Index: /branches/new-random/level-0/l0-array.lisp =================================================================== --- /branches/new-random/level-0/l0-array.lisp (revision 13309) +++ /branches/new-random/level-0/l0-array.lisp (revision 13309) @@ -0,0 +1,852 @@ +;;; -*- Mode: Lisp; Package: CCL -*- +;;; +;;; Copyright (C) 2009 Clozure Associates +;;; Copyright (C) 1994-2001 Digitool, Inc +;;; This file is part of Clozure CL. +;;; +;;; Clozure CL is licensed under the terms of the Lisp Lesser GNU Public +;;; License , known as the LLGPL and distributed with Clozure CL as the +;;; file "LICENSE". The LLGPL consists of a preamble and the LGPL, +;;; which is distributed with Clozure CL as the file "LGPL". Where these +;;; conflict, the preamble takes precedence. +;;; +;;; Clozure CL is referenced in the preamble as the "LIBRARY." +;;; +;;; The LLGPL is also available online at +;;; http://opensource.franz.com/preamble.html + +(in-package "CCL") + + + + +; Return T if array or vector header, NIL if (simple-array * *), else +; error. + +(defun %array-is-header (array) + (let* ((typecode (typecode array))) + (declare (fixnum typecode)) + (if (< typecode target::min-array-subtag) + (report-bad-arg array 'array) + (or (= typecode target::subtag-arrayH) + (= typecode target::subtag-vectorH))))) + +(defun %set-fill-pointer (vectorh new) + (setf (%svref vectorh target::vectorh.logsize-cell) new)) + +(defun %array-header-subtype (header) + (the fixnum + (ldb target::arrayH.flags-cell-subtag-byte (the fixnum (%svref header target::arrayH.flags-cell))))) + +(defun array-element-subtype (array) + (if (%array-is-header array) + (%array-header-subtype array) + (typecode array))) + +#+ppc32-target +(defconstant ppc32::*immheader-array-types* + '#(short-float + (unsigned-byte 32) + (signed-byte 32) + fixnum + character + (unsigned-byte 8) + (signed-byte 8) + unused + (unsigned-byte 16) + (signed-byte 16) + double-float + bit)) + +#+ppc64-target +(defconstant ppc64::*immheader-array-types* + '#(unused + unused + unused + unused + (signed-byte 8) + (signed-byte 16) + (signed-byte 32) + (signed-byte 64) + (unsigned-byte 8) + (unsigned-byte 16) + (unsigned-byte 32) + (unsigned-byte 64) + unused + unused + short-float + fixnum + unused + unused + unused + double-float + unused + unused + character + unused + unused + unused + unused + unused + unused + bit + unused + unused)) + +#+x8632-target +(defconstant x8632::*immheader-array-types* + '#(short-float + (unsigned-byte 32) + (signed-byte 32) + fixnum + character + (unsigned-byte 8) + (signed-byte 8) + unused + (unsigned-byte 16) + (signed-byte 16) + double-float + bit)) + +#+x8664-target +(progn +(defconstant x8664::*immheader-0-array-types* + ;; ivector-class-other-bit + #(unused + unused + unused + unused + unused + unused + unused + unused + unused + unused + (signed-byte 16) + (unsigned-byte 16) + character + (signed-byte 8) + (unsigned-byte 8) + bit + )) + +(defconstant x8664::*immheader-1-array-types* + ;; ivector-class-32-bit + #( + unused + unused + unused + unused + unused + unused + unused + unused + unused + unused + unused + unused + character + (signed-byte 32) + (unsigned-byte 32) + single-float)) + +(defconstant x8664::*immheader-2-array-types* + ;; ivector-class-64-bit + #( + unused + unused + unused + unused + unused + unused + unused + unused + unused + unused + unused + unused + fixnum + (signed-byte 64) + (unsigned-byte 64) + double-float)) + +) + + +(defun array-element-type (array) + "Return the type of the elements of the array" + (let* ((subtag (if (%array-is-header array) + (%array-header-subtype array) + (typecode array)))) + (declare (fixnum subtag)) + (if (= subtag target::subtag-simple-vector) + t ; only node CL array type + #+ppc-target + (svref target::*immheader-array-types* + #+ppc32-target + (ash (the fixnum (- subtag ppc32::min-cl-ivector-subtag)) -3) + #+ppc64-target + (ash (the fixnum (logand subtag #x7f)) (- ppc64::nlowtagbits))) + #+x8632-target + (svref x8632::*immheader-array-types* + (ash (the fixnum (- subtag x8632::min-cl-ivector-subtag)) + (- x8632::ntagbits))) + #+x8664-target + (let* ((class (logand subtag x8664::fulltagmask)) + (idx (ash subtag (- x8664::ntagbits)))) + (declare (fixnum class idx)) + (cond ((= class x8664::ivector-class-64-bit) + (%svref x8664::*immheader-2-array-types* idx)) + ((= class x8664::ivector-class-32-bit) + (%svref x8664::*immheader-1-array-types* idx)) + (t + (%svref x8664::*immheader-0-array-types* idx)))) + ))) + + + +(defun adjustable-array-p (array) + "Return T if (ADJUST-ARRAY ARRAY...) would return an array identical + to the argument, this happens for complex arrays." + (let* ((typecode (typecode array))) + (declare (fixnum typecode)) + (if (< typecode target::min-array-subtag) + (report-bad-arg array 'array) + (if (or (= typecode target::subtag-arrayH) + (= typecode target::subtag-vectorH)) + (logbitp $arh_adjp_bit (the fixnum (%svref array target::arrayH.flags-cell))))))) + +(defun array-displacement (array) + "Return the values of :DISPLACED-TO and :DISPLACED-INDEX-offset + options to MAKE-ARRAY, or NIL and 0 if not a displaced array." + (let* ((typecode (typecode array))) + (declare (fixnum typecode)) + (if (< typecode target::min-array-subtag) + (report-bad-arg array 'array) + (if (and (<= typecode target::subtag-vectorH) + (logbitp $arh_exp_disp_bit + (the fixnum (%svref array target::arrayH.flags-cell)))) + (values (%svref array target::arrayH.data-vector-cell) + (%svref array target::arrayH.displacement-cell)) + (values nil 0))))) + +(defun array-data-and-offset (array) + (let* ((typecode (typecode array))) + (declare (fixnum typecode)) + (if (< typecode target::min-array-subtag) + (report-bad-arg array 'array) + (if (<= typecode target::subtag-vectorH) + (%array-header-data-and-offset array) + (values array 0))))) + +(defun array-data-offset-subtype (array) + (let* ((typecode (typecode array))) + (declare (fixnum typecode)) + (if (< typecode target::min-array-subtag) + (report-bad-arg array 'array) + (if (<= typecode target::subtag-vectorH) + (do* ((header array data) + (offset (%svref header target::arrayH.displacement-cell) + (+ offset + (the fixnum + (%svref header target::arrayH.displacement-cell)))) + (data (%svref header target::arrayH.data-vector-cell) + (%svref header target::arrayH.data-vector-cell))) + ((> (the fixnum (typecode data)) target::subtag-vectorH) + (values data offset (typecode data))) + (declare (fixnum offset))) + (values array 0 typecode))))) + + +(defun array-has-fill-pointer-p (array) + "Return T if the given ARRAY has a fill pointer, or NIL otherwise." + (let* ((typecode (typecode array))) + (declare (fixnum typecode)) + (if (>= typecode target::min-array-subtag) + (and (= typecode target::subtag-vectorH) + (logbitp $arh_fill_bit (the fixnum (%svref array target::vectorH.flags-cell)))) + (report-bad-arg array 'array)))) + + +(defun fill-pointer (array) + "Return the FILL-POINTER of the given VECTOR." + (let* ((typecode (typecode array))) + (declare (fixnum typecode)) + (if (and (= typecode target::subtag-vectorH) + (logbitp $arh_fill_bit (the fixnum (%svref array target::vectorH.flags-cell)))) + (%svref array target::vectorH.logsize-cell) + (report-bad-arg array '(and array (satisfies array-has-fill-pointer-p)))))) + +(defun set-fill-pointer (array value) + (let* ((typecode (typecode array))) + (declare (fixnum typecode)) + (if (and (= typecode target::subtag-vectorH) + (logbitp $arh_fill_bit (the fixnum (%svref array target::vectorH.flags-cell)))) + (let* ((vlen (%svref array target::vectorH.physsize-cell))) + (declare (fixnum vlen)) + (if (eq value t) + (setq value vlen) + (unless (and (fixnump value) + (>= (the fixnum value) 0) + (<= (the fixnum value) vlen)) + (%err-disp $XARROOB value array))) + (setf (%svref array target::vectorH.logsize-cell) value)) + (%err-disp $XNOFILLPTR array)))) + +(eval-when (:compile-toplevel) + (assert (eql target::vectorH.physsize-cell target::arrayH.physsize-cell))) + +(defun array-total-size (array) + "Return the total number of elements in the Array." + (let* ((typecode (typecode array))) + (declare (fixnum typecode)) + (if (< typecode target::min-array-subtag) + (report-bad-arg array 'array) + (if (or (= typecode target::subtag-arrayH) + (= typecode target::subtag-vectorH)) + (%svref array target::vectorH.physsize-cell) + (uvsize array))))) + + + +(defun array-dimension (array axis-number) + "Return the length of dimension AXIS-NUMBER of ARRAY." + (unless (typep axis-number 'fixnum) (report-bad-arg axis-number 'fixnum)) + (locally + (declare (fixnum axis-number)) + (let* ((typecode (typecode array))) + (declare (fixnum typecode)) + (if (< typecode target::min-array-subtag) + (report-bad-arg array 'array) + (if (= typecode target::subtag-arrayH) + (let* ((rank (%svref array target::arrayH.rank-cell))) + (declare (fixnum rank)) + (unless (and (>= axis-number 0) + (< axis-number rank)) + (%err-disp $XNDIMS array axis-number)) + (%svref array (the fixnum (+ target::arrayH.dim0-cell axis-number)))) + (if (neq axis-number 0) + (%err-disp $XNDIMS array axis-number) + (if (= typecode target::subtag-vectorH) + (%svref array target::vectorH.physsize-cell) + (uvsize array)))))))) + +(defun array-dimensions (array) + "Return a list whose elements are the dimensions of the array" + (let* ((typecode (typecode array))) + (declare (fixnum typecode)) + (if (< typecode target::min-array-subtag) + (report-bad-arg array 'array) + (if (= typecode target::subtag-arrayH) + (let* ((rank (%svref array target::arrayH.rank-cell)) + (dims ())) + (declare (fixnum rank)) + (do* ((i (1- rank) (1- i))) + ((< i 0) dims) + (declare (fixnum i)) + (push (%svref array (the fixnum (+ target::arrayH.dim0-cell i))) dims))) + (list (if (= typecode target::subtag-vectorH) + (%svref array target::vectorH.physsize-cell) + (uvsize array))))))) + + +(defun array-rank (array) + "Return the number of dimensions of ARRAY." + (let* ((typecode (typecode array))) + (declare (fixnum typecode)) + (if (< typecode target::min-array-subtag) + (report-bad-arg array 'array) + (if (= typecode target::subtag-arrayH) + (%svref array target::arrayH.rank-cell) + 1)))) + +(defun vector-push (elt vector) + "Attempt to set the element of ARRAY designated by its fill pointer + to NEW-EL, and increment the fill pointer by one. If the fill pointer is + too large, NIL is returned, otherwise the index of the pushed element is + returned." + (let* ((fill (fill-pointer vector)) + (len (%svref vector target::vectorH.physsize-cell))) + (declare (fixnum fill len)) + (when (< fill len) + (multiple-value-bind (data offset) (%array-header-data-and-offset vector) + (declare (fixnum offset)) + (setf (%svref vector target::vectorH.logsize-cell) (the fixnum (1+ fill)) + (uvref data (the fixnum (+ fill offset))) elt) + fill)))) + +;;; Implement some of the guts of REPLACE, where the source and target +;;; sequence have the same type (and we might be able to BLT things +;;; around more quickly because of that.) +;;; Both TARGET and SOURCE are (SIMPLE-ARRAY (*) *), and all of the +;;; indices are fixnums and in bounds. +(defun %uvector-replace (target target-start source source-start n typecode) + (declare (fixnum target-start n source-start n typecode) + (optimize (speed 3) (safety 0))) + (ecase typecode + (#.target::subtag-simple-vector + (if (and (eq source target) + (> target-start source-start)) + (do* ((i 0 (1+ i)) + (source-pos (1- (the fixnum (+ source-start n))) + (1- source-pos)) + (target-pos (1- (the fixnum (+ target-start n))) + (1- target-pos))) + ((= i n)) + (declare (fixnum i source-pos target-pos)) + (setf (svref target target-pos) (svref source source-pos))) + (dotimes (i n) + (setf (svref target target-start) (svref source source-start)) + (incf target-start) + (incf source-start)))) + (#.target::subtag-bit-vector + (if (and (eq source target) + (> target-start source-start)) + (do* ((i 0 (1+ i)) + (source-pos (1- (the fixnum (+ source-start n))) + (1- source-pos)) + (target-pos (1- (the fixnum (+ target-start n))) + (1- target-pos))) + ((= i n)) + (declare (fixnum i source-pos target-pos)) + (setf (sbit target target-pos) (sbit source source-pos))) + (dotimes (i n) + (setf (sbit target target-start) (sbit source source-start)) + (incf target-start) + (incf source-start)))) + ;; All other cases can be handled with %COPY-IVECTOR-TO-IVECTOR, + ;; which knows how to handle overlap + ((#.target::subtag-s8-vector + #.target::subtag-u8-vector) + (%copy-ivector-to-ivector source + source-start + target + target-start + n)) + ((#.target::subtag-s16-vector + #.target::subtag-u16-vector) + (%copy-ivector-to-ivector source + (the fixnum (* source-start 2)) + target + (the fixnum (* target-start 2)) + (the fixnum (* n 2)))) + ((#.target::subtag-s32-vector + #.target::subtag-u32-vector + #.target::subtag-single-float-vector + #.target::subtag-simple-base-string + #+32-bit-target #.target::subtag-fixnum-vector) + (%copy-ivector-to-ivector source + (the fixnum (* source-start 4)) + target + (the fixnum (* target-start 4)) + (the fixnum (* n 4)))) + ((#.target::subtag-double-float-vector + #+64-bit-target #.target::subtag-s64-vector + #+64-bit-target #.target::subtag-u64-vector + #+64-bit-target #.target::subtag-fixnum-vector) + (%copy-ivector-to-ivector source + (the fixnum + (+ (the fixnum (- target::misc-dfloat-offset + target::misc-data-offset)) + (the fixnum (* source-start 8)))) + target + (the fixnum + (+ (the fixnum (- target::misc-dfloat-offset + target::misc-data-offset)) + (the fixnum (* target-start 8)))) + (the fixnum (* n 8))))) + target) + +(defun vector-push-extend (elt vector &optional (extension nil extp)) + "Attempt to set the element of VECTOR designated by its fill pointer +to ELT, and increment the fill pointer by one. If the fill pointer is +too large, VECTOR is extended using adjust-array. EXTENSION is the +minimum number of elements to add if it must be extended." + (when extp + (unless (and (typep extension 'fixnum) + (> (the fixnum extension) 0)) + (setq extension (require-type extension 'unsigned-byte)))) + (let* ((fill (fill-pointer vector)) + (len (%svref vector target::vectorH.physsize-cell))) + (declare (fixnum fill len)) + (multiple-value-bind (data offset) (%array-header-data-and-offset vector) + (declare (fixnum offset)) + (if (= fill len) + (let* ((flags (%svref vector target::arrayH.flags-cell))) + (declare (fixnum flags)) + (unless (logbitp $arh_adjp_bit flags) + (%err-disp $XMALADJUST vector)) + (let* ((new-size (max + (+ len (the fixnum (or extension + len))) + 4)) + (typecode (typecode data)) + (new-vector (%alloc-misc new-size typecode))) + (%uvector-replace new-vector 0 data offset fill typecode) + (setf (%svref vector target::vectorH.data-vector-cell) new-vector + (%svref vector target::vectorH.displacement-cell) 0 + (%svref vector target::vectorH.physsize-cell) new-size + (%svref vector target::vectorH.flags-cell) (bitclr $arh_exp_disp_bit flags) + (uvref new-vector fill) elt))) + (setf (uvref data (the fixnum (+ offset fill))) elt)) + (setf (%svref vector target::vectorH.logsize-cell) (the fixnum (1+ fill)))) + fill)) + +;;; Could avoid potential memoization somehow +(defun vector (&lexpr vals) + "Construct a SIMPLE-VECTOR from the given objects." + (let* ((n (%lexpr-count vals)) + (v (allocate-typed-vector :simple-vector n))) + (declare (fixnum n)) + (dotimes (i n v) (setf (%svref v i) (%lexpr-ref vals n i))))) + +;;; CALL-ARGUMENTS-LIMIT. +(defun list-to-vector (elts) + (let* ((n (length elts))) + (declare (fixnum n)) + (if (< n (floor #x8000 target::node-size)) + (apply #'vector elts) + (make-array n :initial-contents elts)))) + + + +(defun %gvector (subtag &lexpr vals) + (let* ((n (%lexpr-count vals)) + (v (%alloc-misc n subtag))) + (declare (fixnum n)) + (dotimes (i n v) (setf (%svref v i) (%lexpr-ref vals n i))))) + +(defun %aref1 (v i) + (let* ((typecode (typecode v))) + (declare (fixnum typecode)) + (if (> typecode target::subtag-vectorH) + (uvref v i) + (if (= typecode target::subtag-vectorH) + (multiple-value-bind (data offset) + (%array-header-data-and-offset v) + (unless (typep i 'fixnum) + (report-bad-arg i 'fixnum)) + (unless (and (typep i 'fixnum) + (>= (the fixnum i) 0) + (< (the fixnum i) (the fixnum (%svref v target::vectorH.physsize-cell)))) + (if (not (typep i 'fixnum)) + (report-bad-arg i 'fixnum) + (%err-disp $XARROOB i v))) + (uvref data (+ offset i))) + (if (= typecode target::subtag-arrayH) + (%err-disp $XNDIMS v 1) + (report-bad-arg v 'array)))))) + +(defun %aset1 (v i new) + (let* ((typecode (typecode v))) + (declare (fixnum typecode)) + (if (> typecode target::subtag-vectorH) + (setf (uvref v i) new) + (if (= typecode target::subtag-vectorH) + (multiple-value-bind (data offset) + (%array-header-data-and-offset v) + (unless (and (typep i 'fixnum) + (>= (the fixnum i) 0) + (< (the fixnum i) (the fixnum (%svref v target::vectorH.physsize-cell)))) + (if (not (typep i 'fixnum)) + (report-bad-arg i 'fixnum) + (%err-disp $XARROOB i v))) + (setf (uvref data (+ offset i)) new)) + (if (= typecode target::subtag-arrayH) + (%err-disp $XNDIMS v 1) + (report-bad-arg v 'array)))))) + +;;; Validate the N indices in the lexpr L against the +;;; array-dimensions of L. If anything's out-of-bounds, +;;; error out (unless NO-ERROR is true, in which case +;;; return NIL.) +;;; If everything's OK, return the "row-major-index" of the array. +;;; We know that A's an array-header of rank N. + +(defun %array-index (a l n &optional no-error) + (declare (fixnum n)) + (let* ((count (%lexpr-count l))) + (declare (fixnum count)) + (do* ((axis (1- n) (1- axis)) + (chunk-size 1) + (result 0)) + ((< axis 0) result) + (declare (fixnum result axis chunk-size)) + (let* ((index (%lexpr-ref l count axis)) + (dim (%svref a (the fixnum (+ target::arrayH.dim0-cell axis))))) + (declare (fixnum dim)) + (unless (and (typep index 'fixnum) + (>= (the fixnum index) 0) + (< (the fixnum index) dim)) + (if no-error + (return-from %array-index nil) + (%err-disp $XARROOB index a))) + (incf result (the fixnum (* chunk-size (the fixnum index)))) + (setq chunk-size (* chunk-size dim)))))) + +(defun aref (a &lexpr subs) + "Return the element of the ARRAY specified by the SUBSCRIPTS." + (let* ((n (%lexpr-count subs))) + (declare (fixnum n)) + (if (= n 1) + (%aref1 a (%lexpr-ref subs n 0)) + (if (= n 2) + (%aref2 a (%lexpr-ref subs n 0) (%lexpr-ref subs n 1)) + (if (= n 3) + (%aref3 a (%lexpr-ref subs n 0) (%lexpr-ref subs n 1) (%lexpr-ref subs n 2)) + (let* ((typecode (typecode a))) + (declare (fixnum typecode)) + (if (>= typecode target::min-vector-subtag) + (%err-disp $XNDIMS a n) + (if (< typecode target::min-array-subtag) + (report-bad-arg a 'array) + ;; This typecode is Just Right ... + (progn + (unless (= (the fixnum (%svref a target::arrayH.rank-cell)) n) + (%err-disp $XNDIMS a n)) + (let* ((rmi (%array-index a subs n))) + (declare (fixnum rmi)) + (multiple-value-bind (data offset) (%array-header-data-and-offset a) + (declare (fixnum offset)) + (uvref data (the fixnum (+ offset rmi)))))))))))))) + + + + + +(defun aset (a &lexpr subs&val) + (let* ((count (%lexpr-count subs&val)) + (nsubs (1- count))) + (declare (fixnum nsubs count)) + (if (eql count 0) + (%err-disp $xneinps) + (let* ((val (%lexpr-ref subs&val count nsubs))) + (if (= nsubs 1) + (%aset1 a (%lexpr-ref subs&val count 0) val) + (if (= nsubs 2) + (%aset2 a (%lexpr-ref subs&val count 0) (%lexpr-ref subs&val count 1) val) + (if (= nsubs 3) + (%aset3 a (%lexpr-ref subs&val count 0) (%lexpr-ref subs&val count 1) (%lexpr-ref subs&val count 2) val) + (let* ((typecode (typecode a))) + (declare (fixnum typecode)) + (if (>= typecode target::min-vector-subtag) + (%err-disp $XNDIMS a nsubs) + (if (< typecode target::min-array-subtag) + (report-bad-arg a 'array) + ; This typecode is Just Right ... + (progn + (unless (= (the fixnum (%svref a target::arrayH.rank-cell)) nsubs) + (%err-disp $XNDIMS a nsubs)) + (let* ((rmi (%array-index a subs&val nsubs))) + (declare (fixnum rmi)) + (multiple-value-bind (data offset) (%array-header-data-and-offset a) + (setf (uvref data (the fixnum (+ offset rmi))) val)))))))))))))) + + + +(defun schar (s i) + "SCHAR returns the character object at an indexed position in a string + just as CHAR does, except the string must be a simple-string." + (let* ((typecode (typecode s))) + (declare (fixnum typecode)) + (if (= typecode target::subtag-simple-base-string) + (aref (the simple-string s) i) + (report-bad-arg s 'simple-string)))) + + +(defun %scharcode (s i) + (let* ((typecode (typecode s))) + (declare (fixnum typecode)) + (if (= typecode target::subtag-simple-base-string) + (locally + (declare (optimize (speed 3) (safety 0))) + (aref (the (simple-array (unsigned-byte 32) (*)) s) i)) + (report-bad-arg s 'simple-string)))) + + +(defun set-schar (s i v) + (let* ((typecode (typecode s))) + (declare (fixnum typecode)) + (if (= typecode target::subtag-simple-base-string) + (setf (aref (the simple-string s) i) v) + (report-bad-arg s 'simple-string)))) + + +(defun %set-scharcode (s i v) + (let* ((typecode (typecode s))) + (declare (fixnum typecode)) + (if (= typecode target::subtag-simple-base-string) + (locally + (declare (optimize (speed 3) (safety 0))) + (setf (aref (the simple-string s) i) v)) + (report-bad-arg s 'simple-string)))) + + +; Strings are simple-strings, start & end values are sane. +(defun %simple-string= (str1 str2 start1 start2 end1 end2) + (declare (fixnum start1 start2 end1 end2)) + (when (= (the fixnum (- end1 start1)) + (the fixnum (- end2 start2))) + (locally (declare (type simple-base-string str1 str2)) + (do* ((i1 start1 (1+ i1)) + (i2 start2 (1+ i2))) + ((= i1 end1) t) + (declare (fixnum i1 i2)) + (unless (eq (schar str1 i1) (schar str2 i2)) + (return)))))) + +(defun copy-uvector (src) + (%extend-vector 0 src (uvsize src))) + +#+ppc32-target +(defun subtag-bytes (subtag element-count) + (declare (fixnum subtag element-count)) + (unless (= #.ppc32::fulltag-immheader (logand subtag #.ppc32::fulltagmask)) + (error "Not an ivector subtag: ~s" subtag)) + (let* ((element-bit-shift + (if (<= subtag ppc32::max-32-bit-ivector-subtag) + 5 + (if (<= subtag ppc32::max-8-bit-ivector-subtag) + 3 + (if (<= subtag ppc32::max-16-bit-ivector-subtag) + 4 + (if (= subtag ppc32::subtag-double-float-vector) + 6 + 0))))) + (total-bits (ash element-count element-bit-shift))) + (ash (+ 7 total-bits) -3))) + +#+ppc64-target +(defun subtag-bytes (subtag element-count) + (declare (fixnum subtag element-count)) + (unless (= ppc64::lowtag-immheader (logand subtag ppc64::lowtagmask)) + (error "Not an ivector subtag: ~s" subtag)) + (let* ((ivector-class (logand subtag ppc64::fulltagmask)) + (element-bit-shift + (if (= ivector-class ppc64::ivector-class-32-bit) + 5 + (if (= ivector-class ppc64::ivector-class-8-bit) + 3 + (if (= ivector-class ppc64::ivector-class-64-bit) + 6 + (if (= subtag ppc64::subtag-bit-vector) + 0 + 4))))) + (total-bits (ash element-count element-bit-shift))) + (declare (fixnum ivector-class element-bit-shift total-bits)) + (ash (the fixnum (+ 7 total-bits)) -3))) + +#+x8632-target +(defun subtag-bytes (subtag element-count) + (declare (fixnum subtag element-count)) + (unless (= #.x8632::fulltag-immheader (logand subtag #.x8632::fulltagmask)) + (error "Not an ivector subtag: ~s" subtag)) + (let* ((element-bit-shift + (if (<= subtag x8632::max-32-bit-ivector-subtag) + 5 + (if (<= subtag x8632::max-8-bit-ivector-subtag) + 3 + (if (<= subtag x8632::max-16-bit-ivector-subtag) + 4 + (if (= subtag x8632::subtag-double-float-vector) + 6 + 0))))) + (total-bits (ash element-count element-bit-shift))) + (ash (+ 7 total-bits) -3))) + +#+x8664-target +(defun subtag-bytes (subtag element-count) + (declare (fixnum subtag element-count)) + (unless (logbitp (the (mod 16) (logand subtag x8664::fulltagmask)) + (logior (ash 1 x8664::fulltag-immheader-0) + (ash 1 x8664::fulltag-immheader-1) + (ash 1 x8664::fulltag-immheader-2))) + (error "Not an ivector subtag: ~s" subtag)) + (let* ((ivector-class (logand subtag x8664::fulltagmask)) + (element-bit-shift + (if (= ivector-class x8664::ivector-class-32-bit) + 5 + (if (= ivector-class x8664::ivector-class-64-bit) + 6 + (if (= subtag x8664::subtag-bit-vector) + 0 + (if (>= subtag x8664::min-8-bit-ivector-subtag) + 3 + 4))))) + (total-bits (ash element-count element-bit-shift))) + (declare (fixnum ivector-class element-bit-shift total-bits)) + (ash (the fixnum (+ 7 total-bits)) -3))) + +(defun element-type-subtype (type) + "Convert element type specifier to internal array subtype code" + (ctype-subtype (specifier-type type))) + +(defun ctype-subtype (ctype) + (typecase ctype + (class-ctype + (if (or (eq (class-ctype-class ctype) *character-class*) + (eq (class-ctype-class ctype) *base-char-class*) + (eq (class-ctype-class ctype) *standard-char-class*)) + target::subtag-simple-base-string + target::subtag-simple-vector)) + (numeric-ctype + (if (eq (numeric-ctype-complexp ctype) :complex) + target::subtag-simple-vector + (case (numeric-ctype-class ctype) + (integer + (let* ((low (numeric-ctype-low ctype)) + (high (numeric-ctype-high ctype))) + (cond ((or (null low) (null high)) target::subtag-simple-vector) + ((and (>= low 0) (<= high 1)) target::subtag-bit-vector) + ((and (>= low 0) (<= high 255)) + target::subtag-u8-vector) + ((and (>= low 0) (<= high 65535)) + target::subtag-u16-vector) + ((and (>= low 0) (<= high #xffffffff)) + target::subtag-u32-vector) + #+64-bit-target + ((and (>= low 0) (<= high (1- (ash 1 64)))) + target::subtag-u64-vector) + ((and (>= low -128) (<= high 127)) target::subtag-s8-vector) + ((and (>= low -32768) (<= high 32767)) target::subtag-s16-vector) + #+32-bit-target + ((and (>= low target::target-most-negative-fixnum) + (<= high target::target-most-positive-fixnum)) + target::subtag-fixnum-vector) + ((and (>= low (ash -1 31)) (<= high (1- (ash 1 31)))) + target::subtag-s32-vector) + #+64-bit-target + ((and (>= low target::target-most-negative-fixnum) + (<= high target::target-most-positive-fixnum)) + target::subtag-fixnum-vector) + #+64-bit-target + ((and (>= low (ash -1 63)) (<= high (1- (ash 1 63)))) + target::subtag-s64-vector) + (t target::subtag-simple-vector)))) + (float + (case (numeric-ctype-format ctype) + ((double-float long-float) target::subtag-double-float-vector) + ((single-float short-float) target::subtag-single-float-vector) + (t target::subtag-simple-vector))) + (t target::subtag-simple-vector)))) + (named-ctype ; *, T, etc. + target::subtag-simple-vector) + (t + (harder-ctype-subtype ctype)))) + +(defun %set-simple-array-p (array) + (setf (%svref array target::arrayh.flags-cell) + (bitset $arh_simple_bit (%svref array target::arrayh.flags-cell)))) + +(defun %array-header-simple-p (array) + (logbitp $arh_simple_bit (%svref array target::arrayh.flags-cell))) + +(defun %misc-ref (v i) + (%misc-ref v i)) + +(defun %misc-set (v i new) + (%misc-set v i new)) + + + +; end of l0-array.lisp Index: /branches/new-random/level-0/l0-bignum32.lisp =================================================================== --- /branches/new-random/level-0/l0-bignum32.lisp (revision 13309) +++ /branches/new-random/level-0/l0-bignum32.lisp (revision 13309) @@ -0,0 +1,2141 @@ +;;-*- Mode: Lisp; Package: CCL -*- +;;; +;;; Copyright (C) 2009 Clozure Associates +;;; Copyright (C) 1994-2001 Digitool, Inc +;;; This file is part of Clozure CL. +;;; +;;; Clozure CL is licensed under the terms of the Lisp Lesser GNU Public +;;; License , known as the LLGPL and distributed with Clozure CL as the +;;; file "LICENSE". The LLGPL consists of a preamble and the LGPL, +;;; which is distributed with Clozure CL as the file "LGPL". Where these +;;; conflict, the preamble takes precedence. +;;; +;;; Clozure CL is referenced in the preamble as the "LIBRARY." +;;; +;;; The LLGPL is also available online at +;;; http://opensource.franz.com/preamble.html + +(in-package "CCL") + + +#+32-bit-target ; the whole shebang +(eval-when (:compile-toplevel :execute) + (require "ARCH") + (require "NUMBER-MACROS") + (require "NUMBER-CASE-MACRO") + + (defconstant digit-size 32) + (defconstant half-digit-size (/ digit-size 2)) + + (defconstant maximum-bignum-length (1- (ash 1 24))) + + (deftype bignum-index () `(integer 0 (,maximum-bignum-length))) + (deftype bignum-element-type () `(unsigned-byte ,digit-size)) + (deftype bignum-half-element-type () `(unsigned-byte ,half-digit-size)) + (deftype bignum-type () 'bignum) + (defmacro %bignum-digits (bignum)`(uvsize ,bignum)) + + (defmacro digit-bind ((&rest digits) form &body body) + `(multiple-value-bind ,digits + ,form + (declare (type bignum-half-element-type ,@digits)) + ,@body)) + + (defmacro digit-set ((&rest digits) form) + `(multiple-value-setq ,digits + ,form)) + + (defmacro digit-zerop (h l) + `(and (zerop ,h) (zerop ,l))) + + + + ;;;; BIGNUM-REPLACE and WITH-BIGNUM-BUFFERS. + + ;;; BIGNUM-REPLACE -- Internal. + ;;; + (defmacro bignum-replace (dest src &key (start1 '0) end1 (start2 '0) end2 + from-end) + (once-only ((n-dest dest) + (n-src src)) + (if (and (eq start1 0)(eq start2 0)(null end1)(null end2)(null from-end)) + ; this is all true for some uses today << + `(%copy-ivector-to-ivector ,n-src 0 ,n-dest 0 (%ilsl 2 (min (the fixnum (%bignum-length ,n-src)) + (the fixnum (%bignum-length ,n-dest))))) + (let* ((n-start1 (gensym)) + (n-end1 (gensym)) + (n-start2 (gensym)) + (n-end2 (gensym))) + `(let ((,n-start1 ,start1) + (,n-start2 ,start2) + (,n-end1 ,(or end1 `(%bignum-length ,n-dest))) + (,n-end2 ,(or end2 `(%bignum-length ,n-src)))) + ,(if (null from-end) + `(%copy-ivector-to-ivector + ,n-src (%i* 4 ,n-start2) + ,n-dest (%i* 4 ,n-start1) + (%i* 4 (min (%i- ,n-end2 ,n-start2) + (%i- ,n-end1 ,n-start1)))) + `(let ((nwds (min (%i- ,n-end2 ,n-start2) + (%i- ,n-end1 ,n-start1)))) + (%copy-ivector-to-ivector + ,n-src (%ilsl 2 (%i- ,n-end2 nwds)) + ,n-dest (%ilsl 2 (%i- ,n-end1 nwds)) + (%i* 4 nwds))))))))) + + + ;;;; Shifting. + + (defconstant all-ones-half-digit #xFFFF) + + + + + + (defmacro %logxor (h1 l1 h2 l2) + (once-only ((h1v h1)(l1v l1)(h2v h2)(l2v l2)) + `(values (%ilogxor ,h1v ,h2v)(%ilogxor ,l1v ,l2v)))) + + + (defmacro %lognot (h l) + (once-only ((h1v h)(l1v l)) + `(values (%ilognot ,h1v)(%ilognot ,l1v)))) + + (defmacro %allocate-bignum (ndigits) + `(%alloc-misc ,ndigits target::subtag-bignum)) + + (defmacro %normalize-bignum-macro (big) + `(%normalize-bignum-2 t ,big)) + + (defmacro %mostly-normalize-bignum-macro (big) + `(%normalize-bignum-2 nil ,big)) + + +;;; %ALLOCATE-BIGNUM must zero all elements. +;;; + (declaim (inline %bignum-length)) + +;;; Temp space needed to (Karatsuba)-square N-digit argument + (defmacro mpn-kara-mul-n-tsize (n) + `(* 8 (+ ,n 32))) +;;; Need the same amount of space to do Karatsuba multiply. + (defmacro mpn-kara-sqr-n-tsize (n) + `(mpn-kara-mul-n-tsize ,n)) + +) + + + + +#+32-bit-target +(progn +;;; Extract the length of the bignum. +;;; +(defun %bignum-length (bignum) + (uvsize bignum)) + + + + + + +;;;; Addition. +(defun add-bignums (a b) + (let* ((len-a (%bignum-length a)) + (len-b (%bignum-length b))) + (declare (bignum-index len-a len-b)) + (when (> len-b len-a) + (rotatef a b) + (rotatef len-a len-b)) + (let* ((len-res (1+ len-a)) + (res (%allocate-bignum len-res)) + (carry 0) + (sign-b (%bignum-sign b))) + (dotimes (i len-b) + (setq carry (%add-with-carry res i carry a i b i))) + (if (/= len-a len-b) + (finish-bignum-add res carry a sign-b len-b len-a) + (%add-with-carry res len-a carry (%bignum-sign a) nil sign-b nil)) + (%normalize-bignum-macro res)))) + +;;; Could do better than this, surely. +(defun add-bignum-and-fixnum (bignum fixnum) + (with-small-bignum-buffers ((bigfix fixnum)) + (add-bignums bignum bigfix))) + + + +;;; B was shorter than A; keep adding B's sign digit to each remaining +;;; digit of A, propagating the carry. +(defun finish-bignum-add (result carry a sign-b start end) + (declare (type bignum-index start end)) + (do* ((i start (1+ i))) + ((= i end) + (%add-with-carry result end carry (%bignum-sign a) nil sign-b nil)) + (setq carry (%add-with-carry result i carry a i sign-b nil)))) + + + + + + + +;;;; Subtraction. +(defun subtract-bignum (a b) + (let* ((len-a (%bignum-length a)) + (len-b (%bignum-length b)) + (len-res (1+ (max len-a len-b))) + (res (%allocate-bignum len-res))) + (declare (bignum-index len-a len-b len-res)) + (bignum-subtract-loop a len-a b len-b res) + (%normalize-bignum-macro res))) + +(defun bignum-subtract-loop (a len-a b len-b res) + (declare (bignum-index len-a len-b )) + (let* ((len-res (%bignum-length res))) + (declare (bignum-index len-res)) + (let* ((borrow 1) + (sign-a (%bignum-sign a)) + (sign-b (%bignum-sign b))) + (dotimes (i (the bignum-index (min len-a len-b))) + (setq borrow (%subtract-with-borrow res i borrow a i b i))) + (if (< len-a len-b) + (do* ((i len-a (1+ i))) + ((= i len-b) + (if (< i len-res) + (%subtract-with-borrow res i borrow sign-a nil sign-b nil))) + (setq borrow (%subtract-with-borrow res i borrow sign-a nil b i))) + (do* ((i len-b (1+ i))) + ((= i len-a) + (if (< i len-res) + (%subtract-with-borrow res i borrow sign-a nil sign-b nil))) + (setq borrow (%subtract-with-borrow res i borrow a i sign-b nil))))))) + + + +;;;; Multiplication. + +;;; These parameters match GMP's. +(defvar *sqr-basecase-threshold* 5) +(defvar *sqr-karatsuba-threshold* 22) +(defvar *mul-karatsuba-threshold* 10) + +;;; Squaring is often simpler than multiplication. This should never +;;; be called with (>= N *sqr-karatsuba-threshold*). +(defun mpn-sqr-basecase (prodp up n) + (declare (fixnum prodp up n)) + (declare (optimize (speed 3) (safety 0) (space 0))) + (umulppm up up prodp) + (when (> n 1) + (%stack-block ((tarr (* 4 (* 2 *sqr-karatsuba-threshold*)))) + (let* ((tp (macptr->fixnum tarr))) + (mpn-mul-1 tp + (the fixnum (1+ up)) + (the fixnum (1- n)) + up + (the fixnum (+ tp (the fixnum (1- n))))) + (do* ((i 2 (1+ i))) + ((= i n)) + (declare (fixnum i)) + (mpn-addmul-1 (the fixnum (- (the fixnum (+ tp (the fixnum (+ i i)))) + 2)) + (the fixnum (+ up i)) + (the fixnum (- n i)) + (the fixnum (+ up (the fixnum (1- i)))) + (the fixnum (+ tp (the fixnum (+ n (the fixnum (- i 2)))))))) + (do* ((i 1 (1+ i)) + (ul (1+ up) (1+ ul))) + ((= i n)) + (declare (fixnum i ul)) + (umulppm ul ul (the fixnum (+ prodp (the fixnum (+ i i)))))) + (let* ((2n-2 (- (the fixnum (+ n n)) 2)) + (carry (mpn-lshift-1 tp tp 2n-2))) + (declare (fixnum 2n-2 carry)) + (setq carry + (+ carry + (the fixnum (mpn-add-n (the fixnum (1+ prodp)) + (the fixnum (1+ prodp)) + tp + 2n-2)))) + (add-fixnum-to-limb carry (the fixnum (+ prodp + (the fixnum (1- + (the fixnum + (+ n n)))))))))))) + +;;; For large enough values of N, squaring via Karatsuba-style +;;; divide&conquer is faster than in the base case. +(defun mpn-kara-sqr-n (p a n ws) + (declare (fixnum p a n ws)) + (declare (optimize (speed 3) (safety 0) (space 0))) + (%stack-block ((limbs 16)) + (let* ((w (macptr->fixnum limbs)) + (w0 (1+ w)) + (w1 (1+ w0)) + (xx (1+ w1)) + (n2 (ash n -1)) + (x 0) + (y 0) + (i 0)) + (declare (fixnum w w0 w1 xx n2 x y i)) + (cond ((logbitp 0 n) + ;; Odd length + (let* ((n3 (- n n2)) + (n1 0) + (nm1 0)) + (declare (fixnum n3 n1 nm1)) + (copy-limb (the fixnum (+ a n2)) w) + (if (not (limb-zerop w)) + (add-fixnum-to-limb + (the fixnum + (- (the fixnum (mpn-sub-n p a (the fixnum (+ a n3)) n2)))) + w) + (progn + (setq i n2) + (loop + (decf i) + (copy-limb (the fixnum (+ a i)) w0) + (copy-limb (the fixnum (+ a (the fixnum (+ n3 i)))) w1) + (if (or (not (zerop (the fixnum (compare-limbs w0 w1)))) + (= i 0)) + (return))) + (if (< (the fixnum (compare-limbs w0 w1)) 0) + (setq x (+ a n3) + y a) + (setq y (+ a n3) + x a)) + (mpn-sub-n p x y n2))) + (copy-limb w (the fixnum (+ p n2))) + (setq n1 (1+ n)) + (cond ((< n3 *sqr-basecase-threshold*) + (mpn-mul-basecase ws p n3 p n3) + (mpn-mul-basecase p a n3 a n3)) + ((< n3 *sqr-karatsuba-threshold*) + (mpn-sqr-basecase ws p n3) + (mpn-sqr-basecase p a n3)) + (t + (mpn-kara-sqr-n ws p n3 (the fixnum (+ ws n1))) + (mpn-kara-sqr-n p a n3 (the fixnum (+ ws n1))))) + (cond ((< n2 *sqr-basecase-threshold*) + (mpn-mul-basecase (the fixnum (+ p n1)) + (the fixnum (+ a n3)) + n2 + (the fixnum (+ a n3)) + n2)) + ((< n2 *sqr-karatsuba-threshold*) + (mpn-sqr-basecase (the fixnum (+ p n1)) + (the fixnum (+ a n3)) + n2)) + (t + (mpn-kara-sqr-n (the fixnum (+ p n1)) + (the fixnum (+ a n3)) + n2 + (the fixnum (+ ws n1))))) + (mpn-sub-n ws p ws n1) + (setq nm1 (1- n)) + (unless (zerop (the fixnum + (mpn-add-n ws + (the fixnum (+ p n1)) + ws + nm1))) + (copy-limb (the fixnum (+ ws nm1)) xx) + (add-fixnum-to-limb 1 xx) + (copy-limb xx (the fixnum (+ ws nm1))) + (if (limb-zerop xx) + (add-fixnum-to-limb 1 (the fixnum (+ ws n))))) + (unless (zerop + (the fixnum + (mpn-add-n (the fixnum (+ p n3)) + (the fixnum (+ p n3)) + ws + n1))) + (mpn-incr-u (the fixnum (+ p (the fixnum (+ n1 n3)))) + 1)))) + (t ; N is even + (setq i n2) + (loop + (decf i) + (copy-limb (the fixnum (+ a i)) w0) + (copy-limb (the fixnum (+ a (the fixnum (+ n2 i)))) w1) + (if (or (not (zerop (the fixnum (compare-limbs w0 w1)))) + (= i 0)) + (return))) + (if (< (the fixnum (compare-limbs w0 w1)) 0) + (setq x (+ a n2) + y a) + (setq y (+ a n2) + x a)) + (mpn-sub-n p x y n2) + (cond ((< n2 *sqr-basecase-threshold*) + (mpn-mul-basecase ws p n2 p n2) + (mpn-mul-basecase p a n2 a n2) + (mpn-mul-basecase (the fixnum (+ p n)) + (the fixnum (+ a n2)) + n2 + (the fixnum (+ a n2)) + n2)) + ((< n2 *sqr-karatsuba-threshold*) + (mpn-sqr-basecase ws p n2) + (mpn-sqr-basecase p a n2) + (mpn-sqr-basecase (the fixnum (+ p n)) + (the fixnum (+ a n2)) + n2)) + (t + (mpn-kara-sqr-n ws p n2 (the fixnum (+ ws n))) + (mpn-kara-sqr-n p a n2 (the fixnum (+ ws n))) + (mpn-kara-sqr-n (the fixnum (+ p n)) + (the fixnum (+ a n2)) + n2 + (the fixnum (+ ws n))))) + (let* ((ww (- (the fixnum (mpn-sub-n ws p ws n))))) + (declare (fixnum ww)) + (setq ww (+ ww (mpn-add-n ws (the fixnum (+ p n)) ws n))) + (setq ww (+ ww (mpn-add-n (the fixnum (+ p n2)) + (the fixnum (+ p n2)) + ws + n))) + (mpn-incr-u (the fixnum (+ p (the fixnum (+ n2 n)))) ww))))))) + +;;; Karatsuba subroutine: multiply A and B, store result at P, use WS +;;; as scrach space. Treats A and B as if they were both of size N; +;;; if that's not true, caller must fuss around the edges. +(defun mpn-kara-mul-n (p a b n ws) + (declare (fixnum p a b n ws)) + (declare (optimize (speed 3) (safety 0) (space 0))) + (%stack-block ((limbs 16)) + (let* ((w (macptr->fixnum limbs)) + (w0 (1+ w)) + (w1 (1+ w0)) + (xx (1+ w1)) + (x 0) + (y 0) + (i 0) + (n2 (ash n -1)) + (sign 0)) + (declare (fixnum w w0 w1 xx x y i n2 sign)) + (cond ((logbitp 0 n) + (let* ((n1 0) + (n3 (- n n2)) + (nm1 0)) + (declare (fixnum n1 n3 nm1)) + (copy-limb (the fixnum (+ a n2)) w) + (if (not (limb-zerop w)) + (add-fixnum-to-limb + (the fixnum (- (mpn-sub-n p a (the fixnum (+ a n3)) n2))) w) + (progn + (setq i n2) + (loop + (decf i) + (copy-limb (the fixnum (+ a i)) w0) + (copy-limb (the fixnum (+ a (the fixnum (+ n3 i)))) w1) + (if (or (not (zerop (the fixnum (compare-limbs w0 w1)))) + (zerop i)) + (return))) + (if (< (the fixnum (compare-limbs w0 w1)) 0) + (setq x (+ a n3) + y a + sign -1) + (setq x a + y (+ a n3))) + (mpn-sub-n p x y n2))) + (copy-limb w (the fixnum (+ p n2))) + (copy-limb (the fixnum (+ b n2)) w) + (if (not (limb-zerop w)) + (add-fixnum-to-limb + (the fixnum (- (the fixnum (mpn-sub-n (the fixnum (+ p n3)) + b + (the fixnum (+ b n3)) + n2)))) + w) + (progn + (setq i n2) + (loop + (decf i) + (copy-limb (the fixnum (+ b i)) w0) + (copy-limb (the fixnum (+ b (the fixnum (+ n3 i)))) w1) + (if (or (not (zerop (the fixnum (compare-limbs w0 w1)))) + (zerop i)) + (return))) + (if (< (the fixnum (compare-limbs w0 w1)) 0) + (setq x (+ b n3) + y b + sign (lognot sign)) + (setq x b + y (+ b n3))) + (mpn-sub-n (the fixnum (+ p n3)) x y n2))) + (copy-limb w (the fixnum (+ p n))) + (setq n1 (1+ n)) + (cond + ((< n2 *mul-karatsuba-threshold*) + (cond + ((< n3 *mul-karatsuba-threshold*) + (mpn-mul-basecase ws p n3 (the fixnum (+ p n3)) n3) + (mpn-mul-basecase p a n3 b n3)) + (t + (mpn-kara-mul-n ws p (the fixnum (+ p n3)) n3 (the fixnum (+ ws n1))) + (mpn-kara-mul-n p a b n3 (the fixnum (+ ws n1))))) + (mpn-mul-basecase (the fixnum (+ p n1)) + (the fixnum (+ a n3)) + n2 + (the fixnum (+ b n3)) + n2)) + (t + (mpn-kara-mul-n ws p (the fixnum (+ p n3)) n3 (the fixnum (+ ws n1))) + (mpn-kara-mul-n p a b n3 (the fixnum (+ ws n1))) + (mpn-kara-mul-n (the fixnum (+ p n1)) + (the fixnum (+ a n3)) + (the fixnum (+ b n3)) + n2 + (the fixnum (+ ws n1))))) + (if (not (zerop sign)) + (mpn-add-n ws p ws n1) + (mpn-sub-n ws p ws n1)) + (setq nm1 (1- n)) + (unless (zerop (the fixnum (mpn-add-n ws + (the fixnum (+ p n1)) + ws + nm1))) + (copy-limb (the fixnum (+ ws nm1)) xx) + (add-fixnum-to-limb 1 xx) + (copy-limb xx (the fixnum (+ ws nm1))) + (if (limb-zerop xx) + (add-fixnum-to-limb 1 (the fixnum (+ ws n))))) + (unless (zerop (the fixnum + (mpn-add-n (the fixnum (+ p n3)) + (the fixnum (+ p n3)) + ws + n1))) + (mpn-incr-u (the fixnum + (+ p (the fixnum (+ n1 n3)))) 1)))) + (t ; even length + (setq i n2) + (loop + (decf i) + (copy-limb (the fixnum (+ a i)) w0) + (copy-limb (the fixnum (+ a (the fixnum (+ n2 i)))) w1) + (if (or (not (zerop (the fixnum (compare-limbs w0 w1)))) + (zerop i)) + (return))) + (setq sign 0) + (if (< (the fixnum (compare-limbs w0 w1)) 0) + (setq x (+ a n2) + y a + sign -1) + (setq x a + y (+ a n2))) + (mpn-sub-n p x y n2) + (setq i n2) + (loop + (decf i) + (copy-limb (the fixnum (+ b i)) w0) + (copy-limb (the fixnum (+ b (the fixnum (+ n2 i)))) w1) + (if (or (not (zerop (the fixnum (compare-limbs w0 w1)))) + (zerop i)) + (return))) + (if (< (the fixnum (compare-limbs w0 w1)) 0) + (setq x (+ b n2) + y b + sign (lognot sign)) + (setq x b + y (+ b n2))) + (mpn-sub-n (the fixnum (+ p n2)) x y n2) + (cond + ((< n2 *mul-karatsuba-threshold*) + (mpn-mul-basecase ws p n2 (the fixnum (+ p n2)) n2) + (mpn-mul-basecase p a n2 b n2) + (mpn-mul-basecase (the fixnum (+ p n)) + (the fixnum (+ a n2)) + n2 + (the fixnum (+ b n2)) + n2)) + (t + (mpn-kara-mul-n ws p (the fixnum (+ p n2)) n2 + (the fixnum (+ ws n))) + (mpn-kara-mul-n p a b n2 (the fixnum (+ ws n))) + (mpn-kara-mul-n (the fixnum (+ p n)) + (the fixnum (+ a n2)) + (the fixnum (+ b n2)) + n2 + (the fixnum (+ ws n))))) + (let* ((ww (if (not (zerop sign)) + (mpn-add-n ws p ws n) + (- (the fixnum (mpn-sub-n ws p ws n)))))) + (declare (fixnum ww)) + (setq ww (+ ww (mpn-add-n ws (the fixnum (+ p n)) ws n))) + (setq ww (+ ww (mpn-add-n (the fixnum (+ p n2)) + (the fixnum (+ p n2)) + ws + n))) + (mpn-incr-u (the fixnum (+ p (the fixnum (+ n2 n)))) ww))))))) + +;;; Square UP, of length UN. I wonder if a Karatsuba multiply might be +;;; faster than a basecase square. +(defun mpn-sqr-n (prodp up un) + (declare (fixnum prodp up un)) + (declare (optimize (speed 3) (safety 0) (space 0))) + (if (< un *sqr-basecase-threshold*) + (mpn-mul-basecase prodp up un up un) + (if (< un *sqr-karatsuba-threshold*) + (mpn-sqr-basecase prodp up un) + (%stack-block ((wsptr (mpn-kara-sqr-n-tsize un))) + (mpn-kara-sqr-n prodp up un (macptr->fixnum wsptr)))))) + +;;; Subroutine: store AxB at P. Assumes A & B to be of length N +(defun mpn-mul-n (p a b n) + (declare (fixnum p a b n)) + (declare (optimize (speed 3) (safety 0) (space 0))) + (if (< n *mul-karatsuba-threshold*) + (mpn-mul-basecase p a n b n) + (%stack-block ((wsptr (mpn-kara-mul-n-tsize n))) + (mpn-kara-mul-n p a b n (macptr->fixnum wsptr))))) + + +;;; Multiply [UP,UN] by [VP,VN]. UN must not be less than VN. +;;; This does Karatsuba if operands are big enough; if they are +;;; and they differ in size, this computes the product of the +;;; smaller-size slices, then fixes up the resut. +(defun mpn-mul (prodp up un vp vn) + (declare (fixnum prodp up un vp vn)) + (declare (optimize (speed 3) (safety 0) (space 0))) + ;(assert (>= un vn 1)) + (if (and (= up vp) (= un vn)) + (mpn-sqr-n prodp up un) + (if (< vn *mul-karatsuba-threshold*) + (mpn-mul-basecase prodp up un vp vn) + (let* ((l vn)) + (declare (fixnum l)) + (mpn-mul-n prodp up vp vn) + (unless (= un vn) + (incf prodp vn) + (incf up vn) + (decf un vn) + (if (< un vn) + (psetq un vn vn un up vp vp up)) + (%stack-block ((wsptr + (the fixnum + (+ 8 + (the fixnum + (* 4 + (the fixnum + (+ vn + (if (>= vn *mul-karatsuba-threshold*) + vn + un))))))))) + (setf (%get-unsigned-long wsptr 0) 0 + (%get-unsigned-long wsptr 4) 0) + (let* ((tt (macptr->fixnum wsptr)) + (c (1+ tt)) + (ws (1+ c))) + (declare (fixnum tt c ws )) + (do* () + ((< vn *mul-karatsuba-threshold*)) + (mpn-mul-n ws up vp vn) + (cond ((<= l (the fixnum (+ vn vn))) + (add-fixnum-to-limb (mpn-add-n prodp prodp ws l) tt) + (unless (= l (the fixnum (+ vn vn))) + (copy-fixnum-to-limb + (mpn-add-1 (the fixnum (+ prodp l)) + (the fixnum (+ ws l)) + (the fixnum (- (the fixnum (+ vn vn)) l)) + tt) + tt) + (setq l (the fixnum (+ vn vn))))) + (t + (copy-fixnum-to-limb + (mpn-add-n prodp prodp ws (the fixnum (+ vn vn))) c) + (add-fixnum-to-limb + (mpn-add-1 (the fixnum (+ prodp (the fixnum (+ vn vn)))) + (the fixnum (+ prodp (the fixnum (+ vn vn)))) + (the fixnum (- l (the fixnum (+ vn vn)))) + c) + tt))) + (incf prodp vn) + (decf l vn) + (incf up vn) + (decf un vn) + (if (< un vn) + (psetq up vp vp up un vn vn un))) + (unless (zerop vn) + (mpn-mul-basecase ws up un vp vn) + (cond ((<= l (the fixnum (+ un vn))) + (add-fixnum-to-limb + (mpn-add-n prodp prodp ws l) + tt) + (unless (= l (the fixnum (+ un vn))) + (copy-fixnum-to-limb + (mpn-add-1 (the fixnum (+ prodp l)) + (the fixnum (+ ws l)) + (the fixnum (- (the fixnum (+ un vn)) l)) + tt) + tt))) + (t + (copy-fixnum-to-limb + (mpn-add-n prodp prodp ws (the fixnum (+ un vn))) + c) + (add-fixnum-to-limb + (mpn-add-1 + (the fixnum (+ prodp (the fixnum (+ un vn)))) + (the fixnum (+ prodp (the fixnum (+ un vn)))) + (the fixnum (- (the fixnum (- l un)) vn)) + c) + tt))))))))))) + +(defun multiply-bignums (a b) + (let* ((signs-differ (not (eq (bignum-minusp a) (bignum-minusp b))))) + (flet ((multiply-unsigned-bignums (a b) + (let* ((len-a (%bignum-length a)) + (len-b (%bignum-length b)) + (len-res (+ len-a len-b)) + (res (%allocate-bignum len-res)) ) + (declare (bignum-index len-a len-b len-res)) + (if (and (>= len-a 16) + (>= len-b 16) + #+x8632-target + nil) + (let* ((ubytes (* len-a 4)) + (vbytes (* len-b 4)) + (rbytes (* len-res 4))) + (declare (fixnum ubytes vbytes rbytes)) + (%stack-block ((uptr ubytes) + (vptr vbytes) + (rptr rbytes)) + (let* ((up (macptr->fixnum uptr)) + (vp (macptr->fixnum vptr)) + (rp (macptr->fixnum rptr))) + (declare (fixnum up vp rp)) + (%copy-ivector-to-ptr a 0 uptr 0 ubytes) + (if (eq a b) ; maybe try eql .. + (mpn-mul rp up len-a up len-a) + (progn + (%copy-ivector-to-ptr b 0 vptr 0 vbytes) + (if (< len-a len-b) + (mpn-mul rp vp len-b up len-a) + (mpn-mul rp up len-a vp len-b))))) + (%copy-ptr-to-ivector rptr 0 res 0 rbytes))) + (dotimes (i len-a) + (declare (type bignum-index i)) + (%multiply-and-add-harder-loop-2 a b res i len-b))) + res))) + (let* ((res (with-negated-bignum-buffers a b multiply-unsigned-bignums))) + (if signs-differ (negate-bignum-in-place res)) + (%normalize-bignum-macro res))))) + + +(defun multiply-bignum-and-fixnum (bignum fixnum) + (declare (type bignum-type bignum) (fixnum fixnum)) + (let* ((bignum-len (%bignum-length bignum)) + (bignum-plus-p (bignum-plusp bignum)) + (fixnum-plus-p (not (minusp fixnum))) + (negate-res (neq bignum-plus-p fixnum-plus-p))) + (declare (type bignum-type bignum) + (type bignum-index bignum-len)) + (flet ((do-it (bignum fixnum negate-res) + (let* ((bignum-len (%bignum-length bignum)) + (result (%allocate-bignum (the fixnum (1+ bignum-len))))) + (declare (type bignum-type bignum) + (type bignum-index bignum-len)) + (with-small-bignum-buffers ((carry-digit) + (result-digit)) + (dotimes (i bignum-len (%set-digit result bignum-len carry-digit)) + (%set-digit result i + (%multiply-and-add result-digit carry-digit bignum i fixnum)))) + (when negate-res + (negate-bignum-in-place result)) + (%normalize-bignum-macro result )))) + (declare (dynamic-extent #'do-it)) + (if bignum-plus-p + (do-it bignum (if fixnum-plus-p fixnum (- fixnum)) negate-res) + (with-bignum-buffers ((b1 (the fixnum (1+ bignum-len)))) + (negate-bignum bignum nil b1) + (do-it b1 (if fixnum-plus-p fixnum (- fixnum)) negate-res)))))) + +;; assume we already know result won't fit in a fixnum +;; only caller is fixnum-*-2 +;; + +(defun multiply-fixnums (a b) + (declare (fixnum a b)) + (* a b)) + + +;;;; GCD. + + +;;; Both args are > 0. +(defun bignum-fixnum-gcd (bignum fixnum) + (let* ((rem (bignum-truncate-by-fixnum-no-quo bignum fixnum))) + (declare (fixnum rem)) + (if (zerop rem) + fixnum + (%fixnum-gcd rem fixnum)))) + + + + +;;; NEGATE-BIGNUM -- Public. +;;; +;;; Fully-normalize is an internal optional. It cause this to always return +;;; a bignum, without any extraneous digits, and it never returns a fixnum. +;;; +(defun negate-bignum (x &optional (fully-normalize t) res) + (declare (type bignum-type x)) + (let* ((len-x (%bignum-length x)) + (len-res (1+ len-x)) + (minusp (bignum-minusp x))) + (declare (type bignum-index len-x len-res)) + (if (not res) (setq res (%allocate-bignum len-res))) ;Test len-res for range? + (let ((carry (bignum-negate-loop-really x len-x res))) ; i think carry is always 0 + (if (eq carry 0) + (if minusp (%bignum-set res len-x 0 0)(%bignum-set res len-x #xffff #xffff)) + (digit-bind (h l) + (if minusp + (%add-the-carry 0 0 carry) + (%add-the-carry #xffff #xffff carry)) + + (%bignum-set res len-x h l)))) + (if fully-normalize + (%normalize-bignum-macro res) + (%mostly-normalize-bignum-macro res)))) + +;;; NEGATE-BIGNUM-IN-PLACE -- Internal. +;;; +;;; This assumes bignum is positive; that is, the result of negating it will +;;; stay in the provided allocated bignum. +;;; +(defun negate-bignum-in-place (bignum) + (bignum-negate-loop-really bignum (%bignum-length bignum) bignum) + bignum) + + + + +(defun copy-bignum (bignum) + (let ((res (%allocate-bignum (%bignum-length bignum)))) + (bignum-replace res bignum) + res)) + + + + +;;; BIGNUM-ASHIFT-RIGHT -- Public. +;;; +;;; First compute the number of whole digits to shift, shifting them by +;;; skipping them when we start to pick up bits, and the number of bits to +;;; shift the remaining digits into place. If the number of digits is greater +;;; than the length of the bignum, then the result is either 0 or -1. If we +;;; shift on a digit boundary (that is, n-bits is zero), then we just copy +;;; digits. The last branch handles the general case which uses a macro that a +;;; couple other routines use. The fifth argument to the macro references +;;; locals established by the macro. +;;; + + +(defun bignum-ashift-right (bignum x) + (declare (type bignum-type bignum) + (fixnum x)) + (let ((bignum-len (%bignum-length bignum))) + (declare (type bignum-index bignum-len)) + (multiple-value-bind (digits n-bits) (truncate x digit-size) + (declare (type bignum-index digits)(fixnum n-bits)) + (cond + ((>= digits bignum-len) + (if (bignum-plusp bignum) 0 -1)) + ((eql 0 n-bits) + (bignum-ashift-right-digits bignum digits)) + (t + (let* ((res-len (- bignum-len digits)) + (res (%allocate-bignum res-len)) + (len-1 (1- res-len))) + (declare (fixnum res-len len-1)) + (bignum-shift-right-loop-1 n-bits res bignum len-1 digits) + (%normalize-bignum-macro res ))))))) + + + + + +;;; BIGNUM-ASHIFT-RIGHT-DIGITS -- Internal. +;;; +(defun bignum-ashift-right-digits (bignum digits) + (declare (type bignum-type bignum) + (type bignum-index digits)) + (let* ((res-len (- (%bignum-length bignum) digits)) + (res (%allocate-bignum res-len))) + (declare (type bignum-index res-len) + (type bignum-type res)) + (bignum-replace res bignum :start2 digits) + (%normalize-bignum-macro res))) + + +;;; BIGNUM-BUFFER-ASHIFT-RIGHT -- Internal. +;;; +;;; GCD uses this for an in-place shifting operation. This is different enough +;;; from BIGNUM-ASHIFT-RIGHT that it isn't worth folding the bodies into a +;;; macro, but they share the basic algorithm. This routine foregoes a first +;;; test for digits being greater than or equal to bignum-len since that will +;;; never happen for its uses in GCD. We did fold the last branch into a macro +;;; since it was duplicated a few times, and the fifth argument to it +;;; references locals established by the macro. +;;; +#| +(defun bignum-buffer-ashift-right (bignum bignum-len x) + (declare (type bignum-index bignum-len) (fixnum x)) + (multiple-value-bind (digits n-bits) + (truncate x digit-size) + (declare (type bignum-index digits)) + (cond + ((zerop n-bits) + (let ((new-end (- bignum-len digits))) + (bignum-replace bignum bignum :end1 new-end :start2 digits + :end2 bignum-len) + (%normalize-bignum-buffer bignum new-end))) + (t + (shift-right-unaligned bignum digits n-bits (- bignum-len digits) + ((= j res-len-1) + (digit-bind (h l) (%bignum-ref bignum i) + (digit-set (h l) (%ashr h l n-bits)) + (%bignum-set bignum j h l)) + (%normalize-bignum-buffer bignum res-len))))))) +|# +#| +(defun bignum-buffer-ashift-right (bignum bignum-len x) + (declare (type bignum-index bignum-len) (fixnum x)) + (multiple-value-bind (digits n-bits) (truncate x digit-size) + (declare (type bignum-index digits)(fixnum n-bits)) + (macrolet ((clear-high-digits () + `(do* ((i (1- (the fixnum (%bignum-length bignum))) (1- i)) + (j digits (1- j))) + ((= 0 j)) + (declare (fixnum i j)) + (%bignum-set bignum i 0 0)))) + (cond + ((zerop n-bits) + (let* ((new-end (- bignum-len digits))) + (declare (fixnum new-end)) + (bignum-replace bignum bignum :end1 new-end :start2 digits + :end2 bignum-len) + (clear-high-digits) + (%normalize-bignum-buffer bignum new-end))) + (t + (let* ((res-len (- bignum-len digits)) + (len-1 (1- res-len))) + (declare (fixnum res-len len-1)) + (bignum-shift-right-loop-1 n-bits bignum bignum len-1 digits) + ; clear the old high order digits - assume always positive + ; (when (neq 0 digits)(push digits poof)) + (clear-high-digits) + (%normalize-bignum-buffer bignum res-len))))))) +|# + + + +;;; BIGNUM-ASHIFT-LEFT -- Public. +;;; +;;; This handles shifting a bignum buffer to provide fresh bignum data for some +;;; internal routines. We know bignum is safe when called with bignum-len. +;;; First we compute the number of whole digits to shift, shifting them +;;; starting to store farther along the result bignum. If we shift on a digit +;;; boundary (that is, n-bits is zero), then we just copy digits. The last +;;; branch handles the general case. +;;; +(defun bignum-ashift-left (bignum x &optional bignum-len) + (declare (type bignum-type bignum) + (fixnum x) + (type (or null bignum-index) bignum-len)) + (multiple-value-bind (digits n-bits) + (truncate x digit-size) + (declare (fixnum digits n-bits)) + (let* ((bignum-len (or bignum-len (%bignum-length bignum))) + (res-len (+ digits bignum-len 1))) + (declare (fixnum bignum-len res-len)) + (when (> res-len maximum-bignum-length) + (error "Can't represent result of left shift.")) + (if (zerop n-bits) + (bignum-ashift-left-digits bignum bignum-len digits) + (bignum-ashift-left-unaligned bignum digits n-bits res-len))))) + +;;; BIGNUM-ASHIFT-LEFT-DIGITS -- Internal. +;;; +(defun bignum-ashift-left-digits (bignum bignum-len digits) + (declare (type bignum-index bignum-len digits)) + (let* ((res-len (+ bignum-len digits)) + (res (%allocate-bignum res-len))) + (declare (type bignum-index res-len)) + (bignum-replace res bignum :start1 digits :end1 res-len :end2 bignum-len + :from-end t) + res)) + +;;; BIGNUM-ASHIFT-LEFT-UNALIGNED -- Internal. +;;; +;;; BIGNUM-TRUNCATE uses this to store into a bignum buffer by supplying res. +;;; When res comes in non-nil, then this foregoes allocating a result, and it +;;; normalizes the buffer instead of the would-be allocated result. +;;; +;;; We start storing into one digit higher than digits, storing a whole result +;;; digit from parts of two contiguous digits from bignum. When the loop +;;; finishes, we store the remaining bits from bignum's first digit in the +;;; first non-zero result digit, digits. We also grab some left over high +;;; bits from the last digit of bignum. +;;; + +(defun bignum-ashift-left-unaligned (bignum digits n-bits res-len + &optional (res nil resp)) + (declare (type bignum-index digits res-len) + (type (mod #.digit-size) n-bits)) + (let* (;(remaining-bits (- digit-size n-bits)) + (res-len-1 (1- res-len)) + (res (or res (%allocate-bignum res-len)))) + (declare (type bignum-index res-len res-len-1)) + (bignum-shift-left-loop n-bits res bignum res-len-1 (the fixnum (1+ digits))) + ; if resp provided we don't care about returned value + (if (not resp) (%normalize-bignum-macro res)))) + + + + + +;;;; Relational operators. + + + +;;; BIGNUM-COMPARE -- Public. +;;; +;;; This compares two bignums returning -1, 0, or 1, depending on whether a +;;; is less than, equal to, or greater than b. +;;; +;(proclaim '(function bignum-compare (bignum bignum) (integer -1 1))) +(defun bignum-compare (a b) + (declare (type bignum-type a b)) + (let* ((a-plusp (bignum-plusp a)) + (b-plusp (bignum-plusp b))) + (if (eq a-plusp b-plusp) + (let* ((len-a (%bignum-length a)) + (len-b (%bignum-length b))) + (declare (type bignum-index len-a len-b)) + (cond ((= len-a len-b) + (do* ((i (1- len-a) (1- i))) + ((zerop i) (%compare-digits a b 0)) + (declare (fixnum i)) + (let* ((signum (%compare-digits a b i))) + (declare (fixnum signum)) + (unless (zerop signum) + (return signum))))) + ((> len-a len-b) + (if a-plusp 1 -1)) + (t (if a-plusp -1 1)))) + (if a-plusp 1 -1)))) + + + + + + + +;;;; Integer length and logcount + + +(defun bignum-integer-length (big) + (the fixnum (- (the fixnum (ash (the fixnum (%bignum-length big)) 5)) + (the fixnum (%bignum-sign-bits big))))) + +; (not (zerop (logand integer1 integer2) + +(defun bignum-logtest (num1 num2) + (let* ((length1 (%bignum-length num1)) + (length2 (%bignum-length num2)) + (n1-minusp (bignum-minusp num1)) + (n2-minusp (bignum-minusp num2))) + (declare (fixnum length1 length2)) + (if (and n1-minusp n2-minusp) ; both neg, get out quick + T + (let ((val (bignum-logtest-loop (min length1 length2) num1 num2))) + #|(do* ((index 0 (1+ index))) + ((= index (min length1 length2)) nil) + ; maybe better to start from high end of shorter? + (multiple-value-bind (hi1 lo1)(%bignum-ref num1 index) + (multiple-value-bind (hi2 lo2)(%bignum-ref num2 index) + (when (or (not (zerop (%ilogand hi1 hi2))) + (not (zerop (%ilogand lo1 lo2)))) + (return t)))))))|# + (or val + (when (not (eql length1 length2)) ; lengths same => value nil + (if (< length1 length2) + n1-minusp + n2-minusp))))))) + + + +(defun logtest-fix-big (fix big) + (declare (fixnum fix)) + (if (eql 0 (the fixnum fix)) + nil + (if (> (the fixnum fix) 0) + (let () + (multiple-value-bind (hi lo)(%bignum-ref big 0) + (declare (fixnum hi lo)) + (or (not (zerop (logand fix lo))) + (not (zerop (logand (ash fix (- 16)) hi)))))) + t))) + + +(defun bignum-logcount (bignum) + (declare (type bignum-type bignum)) + (let* ((length (%bignum-length bignum)) + (plusp (bignum-plusp bignum)) + (result 0)) + (declare (type bignum-index length) + (fixnum result)) + (if plusp + (dotimes (index length result) + (incf result (the fixnum (%logcount bignum index)))) + (dotimes (index length result) + (incf result (the fixnum (%logcount-complement bignum index))))))) + + + +;;;; Logical operations. + +;;; NOT. +;;; + +;;; BIGNUM-LOGICAL-NOT -- Public. +;;; +(defun bignum-logical-not (a) + (declare (type bignum-type a)) + (let* ((len (%bignum-length a)) + (res (%allocate-bignum len))) + (declare (type bignum-index len)) + (dotimes (i len res) + (%bignum-lognot i a res)))) + + + + +;;; AND. +;;; + +;;; BIGNUM-LOGICAL-AND -- Public. +;;; +(defun bignum-logical-and (a b) + (declare (type bignum-type a b)) + (let* ((len-a (%bignum-length a)) + (len-b (%bignum-length b)) + (a-plusp (bignum-plusp a)) + (b-plusp (bignum-plusp b))) + (declare (type bignum-index len-a len-b)) + (cond + ((< len-a len-b) + (if a-plusp + (logand-shorter-positive a len-a b (%allocate-bignum len-a)) + (logand-shorter-negative a len-a b len-b (%allocate-bignum len-b)))) + ((< len-b len-a) + (if b-plusp + (logand-shorter-positive b len-b a (%allocate-bignum len-b)) + (logand-shorter-negative b len-b a len-a (%allocate-bignum len-a)))) + (t (logand-shorter-positive a len-a b (%allocate-bignum len-a)))))) + +;;; LOGAND-SHORTER-POSITIVE -- Internal. +;;; +;;; This takes a shorter bignum, a and len-a, that is positive. Because this +;;; is AND, we don't care about any bits longer than a's since its infinite 0 +;;; sign bits will mask the other bits out of b. The result is len-a big. +;;; +(defun logand-shorter-positive (a len-a b res) + (declare (type bignum-type a b res) + (type bignum-index len-a)) + (dotimes (i len-a) + (%bignum-logand i a b res)) + (%normalize-bignum-macro res)) + +;;; LOGAND-SHORTER-NEGATIVE -- Internal. +;;; +;;; This takes a shorter bignum, a and len-a, that is negative. Because this +;;; is AND, we just copy any bits longer than a's since its infinite 1 sign +;;; bits will include any bits from b. The result is len-b big. +;;; +(defun logand-shorter-negative (a len-a b len-b res) + (declare (type bignum-type a b res) + (type bignum-index len-a len-b)) + (dotimes (i len-a) + (%bignum-logand i a b res)) + (bignum-replace res b :start1 len-a :start2 len-a :end1 len-b :end2 len-b) + (%normalize-bignum-macro res)) + + + +;;; +;;; +;;; bignum-logandc2 + +(defun bignum-logandc2 (a b) + (declare (type bignum-type a b)) + (let* ((len-a (%bignum-length a)) + (len-b (%bignum-length b)) + (a-plusp (bignum-plusp a)) + (b-plusp (bignum-plusp b))) + (declare (type bignum-index len-a len-b)) + (cond + ((< len-a len-b) + (logandc2-shorter-any a len-a b len-b (if a-plusp (%allocate-bignum len-a) (%allocate-bignum len-b)))) + ((< len-b len-a) ; b shorter + (logandc1-shorter-any b len-b a len-a (if b-plusp (%allocate-bignum len-a)(%allocate-bignum len-b)))) + (t (logandc2-shorter-any a len-a b len-b (%allocate-bignum len-a)))))) + +(defun logandc2-shorter-any (a len-a b len-b res) + (declare (type bignum-type a b res) + (type bignum-index len-a len-b)) + (dotimes (i len-a) + (%bignum-logandc2 i a b res)) + (if (bignum-minusp a) + (do ((i len-a (1+ i))) + ((= i len-b)) + (declare (type bignum-index i)) + (digit-bind (h l) (%bignum-ref b i) + (%bignum-set res i (%ilognot h) (%ilognot l))))) + (%normalize-bignum-macro res)) + + + +(defun logandc1-shorter-any (a len-a b len-b res) + (declare (type bignum-type a b res) + (type bignum-index len-a len-b)) + (dotimes (i len-a) + (%bignum-logandc1 i a b res)) + (if (bignum-plusp a) + (if (neq len-a len-b) + (bignum-replace res b :start1 len-a :start2 len-a :end1 len-b :end2 len-b))) + (%normalize-bignum-macro res)) + + + +(defun fix-big-logand (fix big) + (let* ((len-b (%bignum-length big)) + (res (if (< fix 0)(%allocate-bignum len-b)))) + (declare (fixnum fix len-b)) + (let ((val (fix-digit-logand fix big res))) + (if res + (progn + (bignum-replace res big :start1 1 :start2 1 :end1 len-b :end2 len-b) + (%normalize-bignum-macro res)) + val)))) + + +(defun fix-big-logandc2 (fix big) + (let* ((len-b (%bignum-length big)) + (res (if (< fix 0)(%allocate-bignum len-b)))) + (declare (fixnum fix len-b)) + (let ((val (fix-digit-logandc2 fix big res))) + (if res + (progn + (do ((i 1 (1+ i))) + ((= i len-b)) + (declare (type bignum-index i)) + (digit-lognot-move i big res)) + (%normalize-bignum-macro res)) + val)))) + +(defun fix-big-logandc1 (fix big) + (let* ((len-b (%bignum-length big)) + (res (if (>= fix 0)(%allocate-bignum len-b)))) + (declare (fixnum fix len-b)) + (let ((val (fix-digit-logandc1 fix big res))) + (if res + (progn + (bignum-replace res big :start1 1 :start2 1 :end1 len-b :end2 len-b) + (%normalize-bignum-macro res)) + val)))) + + + + + + + +;;; IOR. +;;; + +;;; BIGNUM-LOGICAL-IOR -- Public. +;;; +(defun bignum-logical-ior (a b) + (declare (type bignum-type a b)) + (let* ((len-a (%bignum-length a)) + (len-b (%bignum-length b)) + (a-plusp (bignum-plusp a)) + (b-plusp (bignum-plusp b))) + (declare (type bignum-index len-a len-b)) + (cond + ((< len-a len-b) + (if a-plusp + (logior-shorter-positive a len-a b len-b (%allocate-bignum len-b)) + (logior-shorter-negative a len-a b len-b (%allocate-bignum len-b)))) + ((< len-b len-a) + (if b-plusp + (logior-shorter-positive b len-b a len-a (%allocate-bignum len-a)) + (logior-shorter-negative b len-b a len-a (%allocate-bignum len-a)))) + (t (logior-shorter-positive a len-a b len-b (%allocate-bignum len-a)))))) + +;;; LOGIOR-SHORTER-POSITIVE -- Internal. +;;; +;;; This takes a shorter bignum, a and len-a, that is positive. Because this +;;; is IOR, we don't care about any bits longer than a's since its infinite +;;; 0 sign bits will mask the other bits out of b out to len-b. The result +;;; is len-b long. +;;; +(defun logior-shorter-positive (a len-a b len-b res) + (declare (type bignum-type a b res) + (type bignum-index len-a len-b)) + (dotimes (i len-a) + (%bignum-logior i a b res)) + (if (not (eql len-a len-b)) + (bignum-replace res b :start1 len-a :start2 len-a :end1 len-b :end2 len-b)) + (%normalize-bignum-macro res)) + +;;; LOGIOR-SHORTER-NEGATIVE -- Internal. +;;; +;;; This takes a shorter bignum, a and len-a, that is negative. Because this +;;; is IOR, we just copy any bits longer than a's since its infinite 1 sign +;;; bits will include any bits from b. The result is len-b long. +;;; +(defun logior-shorter-negative (a len-a b len-b res) + (declare (type bignum-type a b res) + (type bignum-index len-a len-b)) + (dotimes (i len-a) + (%bignum-logior i a b res)) + ; silly to propagate sign and then normalize it away + ; but may need to do at least once - but we are only normalizing from len-a? + ; ah but the sign needs to be correct + (do ((i len-a (1+ i))) + ((= i len-b)) + (declare (type bignum-index i)) + (%bignum-set res i #xffff #xffff)) + (%normalize-bignum-macro res)) + + + + +;;; XOR. +;;; + +;;; BIGNUM-LOGICAL-XOR -- Public. +;;; +(defun bignum-logical-xor (a b) + (declare (type bignum-type a b)) + (let ((len-a (%bignum-length a)) + (len-b (%bignum-length b))) + (declare (type bignum-index len-a len-b)) + (if (< len-a len-b) + (bignum-logical-xor-aux a len-a b len-b (%allocate-bignum len-b)) + (bignum-logical-xor-aux b len-b a len-a (%allocate-bignum len-a))))) + +;;; BIGNUM-LOGICAL-XOR-AUX -- Internal. +;;; +;;; This takes the the shorter of two bignums in a and len-a. Res is len-b +;;; long. Do the XOR. +;;; +(defun bignum-logical-xor-aux (a len-a b len-b res) + (declare (type bignum-type a b res) + (type bignum-index len-a len-b)) + (dotimes (i len-a) + (%bignum-logxor i a b res)) + (unless (= len-a len-b) + (let ((sign (if (bignum-minusp a) #xffff 0))) + (do ((i len-a (1+ i))) + ((= i len-b)) + (declare (type bignum-index i)) + (digit-bind (h l) (%bignum-ref b i) + (%bignum-set res i (%ilogxor sign h)(%ilogxor sign l)))))) + (%normalize-bignum-macro res)) + + + + + + +;;;; LDB (load byte) + +; [slh] 'twas all commented out - thank gawd + + + +;;;; TRUNCATE. + +;;; This is the original sketch of the algorithm from which I implemented this +;;; TRUNCATE, assuming both operands are bignums. I should modify this to work +;;; with the documentation on my functions, as a general introduction. I've +;;; left this here just in case someone needs it in the future. Don't look +;;; at this unless reading the functions' comments leaves you at a loss. +;;; Remember this comes from Knuth, so the book might give you the right general +;;; overview. +;;; +;;; +;;; (truncate x y): +;;; +;;; If X's magnitude is less than Y's, then result is 0 with remainder X. +;;; +;;; Make x and y positive, copying x if it is already positive. +;;; +;;; Shift y left until there's a 1 in the 30'th bit (most significant, non-sign +;;; digit) +;;; Just do most sig digit to determine how much to shift whole number. +;;; Shift x this much too. +;;; Remember this initial shift count. +;;; +;;; Allocate q to be len-x minus len-y quantity plus 1. +;;; +;;; i = last digit of x. +;;; k = last digit of q. +;;; +;;; LOOP +;;; +;;; j = last digit of y. +;;; +;;; compute guess. +;;; if x[i] = y[j] then g = #xFFFFFFFF +;;; else g = x[i]x[i-1]/y[j]. +;;; +;;; check guess. +;;; %UNSIGNED-MULTIPLY returns b and c defined below. +;;; a = x[i-1] - (logand (* g y[j]) #xFFFFFFFF). +;;; Use %UNSIGNED-MULTIPLY taking low-order result. +;;; b = (logand (ash (* g y[j-1]) -32) #xFFFFFFFF). +;;; c = (logand (* g y[j-1]) #xFFFFFFFF). +;;; if a < b, okay. +;;; if a > b, guess is too high +;;; g = g - 1; go back to "check guess". +;;; if a = b and c > x[i-2], guess is too high +;;; g = g - 1; go back to "check guess". +;;; GUESS IS 32-BIT NUMBER, SO USE THING TO KEEP IN SPECIAL REGISTER +;;; SAME FOR A, B, AND C. +;;; +;;; Subtract g * y from x[i - len-y+1]..x[i]. See paper for doing this in step. +;;; If x[i] < 0, guess is fucked. +;;; negative g, then add 1 +;;; zero or positive g, then subtract 1 +;;; AND add y back into x[len-y+1..i]. +;;; +;;; q[k] = g. +;;; i = i - 1. +;;; k = k - 1. +;;; +;;; If k>=0, goto LOOP. +;;; +;;; +;;; Now quotient is good, but remainder is not. +;;; Shift x right by saved initial left shifting count. +;;; +;;; Check quotient and remainder signs. +;;; x pos y pos --> q pos r pos +;;; x pos y neg --> q neg r pos +;;; x neg y pos --> q neg r neg +;;; x neg y neg --> q pos r neg +;;; +;;; Normalize quotient and remainder. Cons result if necessary. +;;; + + + +;;; These are used by BIGNUM-TRUNCATE and friends in the general case. +;;; +(defvar *truncate-x* nil) +(defvar *truncate-y* nil) + +;;; BIGNUM-TRUNCATE -- Public. +;;; +;;; This divides x by y returning the quotient and remainder. In the general +;;; case, we shift y to setup for the algorithm, and we use two buffers to save +;;; consing intermediate values. X gets destructively modified to become the +;;; remainder, and we have to shift it to account for the initial Y shift. +;;; After we multiple bind q and r, we first fix up the signs and then return +;;; the normalized results. +;;; + + +(defun bignum-truncate (x1 y1 &optional no-rem) + (declare (type bignum-type x1 y1)) + (let* ((x-plusp (bignum-plusp x1)) + (y-plusp (bignum-plusp y1))) + (flet + ((do-it (x y) + (let* ((len-x (%bignum-length x)) + (len-y (%bignum-length y))) + (declare (fixnum len-x len-y)) + + (let ((c (bignum-compare y x))) + (cond + ((eql c 1) ; > + (return-from bignum-truncate (values 0 x1))) + ((eql c 0)(values 1 0)) ; = might as well since did compare anyway + ((< len-y 2) + (multiple-value-bind (q r) + (bignum-truncate-single-digit x len-x y no-rem) + (values q + (unless no-rem + (cond (x-plusp r) + ((typep r 'fixnum) (the fixnum (- (the fixnum r)))) + (t (negate-bignum-in-place r) + (%normalize-bignum-macro r ))))))) + (t + (let* ((len-x+1 (1+ len-x))) + (declare (fixnum len-x+1)) + (with-bignum-buffers ((*truncate-x* len-x+1) + (*truncate-y* (the fixnum (1+ len-y)))) + (let ((y-shift (shift-y-for-truncate y))) + (shift-and-store-truncate-buffers x len-x y len-y y-shift) + (values (do-truncate len-x+1 len-y) + ;; DO-TRUNCATE must execute first. + (when (not no-rem) + (when (not (eql 0 y-shift)) + (let* ((res-len-1 (1- len-y))) + (declare (fixnum res-len-1)) + (bignum-shift-right-loop-1 y-shift *truncate-x* *truncate-x* res-len-1 0))) + (let ((the-res (%normalize-bignum-macro *truncate-x* ))) + (if (not (fixnump the-res)) + (if x-plusp (copy-bignum the-res) (negate-bignum the-res)) + (if x-plusp the-res (the fixnum (- (the fixnum the-res))))) + )))))))))))) + (multiple-value-bind (q r)(with-negated-bignum-buffers x1 y1 do-it) + (let ((quotient (cond ((eq x-plusp y-plusp) q) + ((typep q 'fixnum) (the fixnum (- (the fixnum q)))) + (t (negate-bignum-in-place q) + (%normalize-bignum-macro q ))))) + (if no-rem + quotient + (values quotient r))))))) + +(defun bignum-rem (x1 y1) + (declare (type bignum-type x1 y1)) + (let* ((x-plusp (bignum-plusp x1))) + (flet + ((do-it (x y) + (let* ((len-x (%bignum-length x)) + (len-y (%bignum-length y))) + (declare (fixnum len-x len-y)) + (let ((c (bignum-compare y x))) + (cond + ((eql c 1) (return-from bignum-rem x1)) + ((eql c 0) 0) ; = might as well since did compare anyway + ((< len-y 2) + (let ((r (bignum-truncate-single-digit-no-quo x len-x y))) ; phooey + (cond (x-plusp r) + ((typep r 'fixnum) (the fixnum (- (the fixnum r)))) + (t (negate-bignum-in-place r) + (%normalize-bignum-macro r ))))) + (t + (let* ((len-x+1 (1+ len-x))) + (declare (fixnum len-x+1)) + (with-bignum-buffers ((*truncate-x* len-x+1) + (*truncate-y* (the fixnum (1+ len-y)))) + (let ((y-shift (shift-y-for-truncate y))) + (shift-and-store-truncate-buffers x len-x y len-y y-shift) + (do-truncate-no-quo len-x+1 len-y) + (when (not (eql 0 y-shift)) + (let* ((res-len-1 (1- len-y))) + (declare (fixnum res-len-1)) + (bignum-shift-right-loop-1 y-shift *truncate-x* *truncate-x* res-len-1 0))) + (let ((the-res (%normalize-bignum-macro *truncate-x*))) + (if (not (fixnump the-res)) + (if x-plusp (copy-bignum the-res) (negate-bignum the-res)) + (if x-plusp the-res (the fixnum (- (the fixnum the-res))))))))))))))) + (declare (dynamic-extent #'do-it)) + (with-negated-bignum-buffers x1 y1 do-it)))) + + + +;;; BIGNUM-TRUNCATE-SINGLE-DIGIT -- Internal. +;;; +;;; This divides x by y when y is a single bignum digit. BIGNUM-TRUNCATE fixes +;;; up the quotient and remainder with respect to sign and normalization. +;;; +;;; We don't have to worry about shifting y to make its most significant digit +;;; sufficiently large for %FLOOR to return 32-bit quantities for the q-digit +;;; and r-digit. If y is a single digit bignum, it is already large enough +;;; for %FLOOR. That is, it has some bits on pretty high in the digit. +;;; +;;; x is positive +(defun bignum-truncate-single-digit (x len-x y &optional no-rem) + (declare (type bignum-index len-x)) + (let* ((maybe-q (%allocate-bignum 2)) + (q (if (<= len-x 2) maybe-q (%allocate-bignum len-x))) + (r-h 0) + (r-l 0)) + (declare (dynamic-extent maybe-q)) + (digit-bind (y-h y-l) (%bignum-ref y 0) + (multiple-value-setq (r-h r-l)(%floor-loop-quo x q y-h y-l)) + (if (eq q maybe-q) + (progn + (setq q (%normalize-bignum-macro q)) + (if (not (fixnump q)) (setq q (copy-bignum q)))) + (setq q (%normalize-bignum-macro q ))) + ;; might as well make a fixnum if possible + (if no-rem + q + (if (> (%digits-sign-bits r-h r-l) target::fixnumshift) + (values q (%ilogior (%ilsl 16 r-h) r-l)) + (let ((rem (%allocate-bignum 1))) + (%bignum-set rem 0 r-h r-l) + (values q rem))))))) + +;;; aka rem +(defun bignum-truncate-single-digit-no-quo (x len-x y) + (declare (type bignum-index len-x)) + (declare (ignore len-x)) + (let (;(q (%allocate-bignum len-x)) + (r-h 0) + (r-l 0)) + (progn + (digit-bind (y-h y-l) (%bignum-ref y 0) + (multiple-value-setq (r-h r-l)(%floor-loop-no-quo x y-h y-l)) + ; might as well make a fixnum if possible + (if (> (%digits-sign-bits r-h r-l) target::fixnumshift) + (%ilogior (%ilsl 16 r-h) r-l) + (let ((rem (%allocate-bignum 1))) + (%bignum-set rem 0 r-h r-l) + rem)))))) + +;; so big deal - we save a one digit bignum for y +;; and bigger deal if x is negative - we copy or negate x, computing result destructively +;; - thus avoiding making a negated x in addition to result +;; +(defun bignum-truncate-by-fixnum (x y) + (declare (fixnum y)) + (when (eql y 0)(error (make-condition 'division-by-zero :operation 'truncate :operands (list x y)))) + (let* ((len-x (%bignum-length x)) + (x-minus (bignum-minusp x)) + (maybe-q (%allocate-bignum 3)) + (q (if x-minus + (if (<= len-x 2) + (dotimes (i 3 (negate-bignum-in-place maybe-q)) + (if (< i len-x) + (multiple-value-bind (hi lo) (%bignum-ref x i) + (%bignum-set maybe-q i hi lo)) + (%bignum-set maybe-q i 65535 65535))) + (negate-bignum x)) + (if (<= len-x 2) ; this was broken if negative because bignum-replace just copies min len-a len-b digits + (progn + (bignum-replace maybe-q x) + maybe-q) + (%allocate-bignum len-x)))) ; q is new big or -x + ;(len-q (%bignum-length q)) + (y-minus (minusp y)) + (y (if y-minus (- y) y))) + (declare (fixnum y)) + (declare (type bignum-index len-x)) + (declare (dynamic-extent maybe-q)) + (let* ((r-h 0) + (r-l 0) + (y-h (%ilogand #xffff (%iasr 16 y))) + (y-l (%ilogand #xffff y))) + (multiple-value-setq (r-h r-l)(%floor-loop-quo (if x-minus q x) q y-h y-l)) + (let* ((r (%ilogior (%ilsl 16 r-h) r-l))) + (declare (fixnum r)) + (when (neq x-minus y-minus)(negate-bignum-in-place q)) + (setq q (%normalize-bignum-macro q )) + (values (if (eq q maybe-q) (copy-bignum q) q) + (if x-minus (the fixnum (- r)) r)))))) + +(defun bignum-truncate-by-fixnum-no-quo (x y) + (declare (fixnum y)) + (when (eql y 0)(error (make-condition 'division-by-zero :operation 'truncate :operands (list x Y)))) + (let* ((len-x (%bignum-length x)) + (x-minus (bignum-minusp x)) + (y-minus (minusp y)) + (y (if y-minus (- y) y))) + (declare (fixnum y)) + (declare (type bignum-index len-x)) + (let* (;(LEN-Q (%BIGNUM-LENGTH Q)) + (r-h 0) + (r-l 0) + (y-h (%ilogand #xffff (%iasr 16 y))) + (y-l (%ilogand #xffff y))) + (if x-minus + (with-bignum-buffers ((q (the fixnum (1+ len-x)))) + (negate-bignum x nil q) + (multiple-value-setq (r-h r-l)(%floor-loop-no-quo q y-h y-l))) + (multiple-value-setq (r-h r-l)(%floor-loop-no-quo x y-h y-l))) + (let* ((r (%ilogior (%ilsl 16 r-h) r-l))) + (declare (fixnum r)) + (if x-minus (the fixnum (- r)) r))))) + + +;;; DO-TRUNCATE -- Internal. +;;; +;;; This divides *truncate-x* by *truncate-y*, and len-x and len-y tell us how +;;; much of the buffers we care about. TRY-BIGNUM-TRUNCATE-GUESS modifies +;;; *truncate-x* on each interation, and this buffer becomes our remainder. +;;; +;;; *truncate-x* definitely has at least three digits, and it has one more than +;;; *truncate-y*. This keeps i, i-1, i-2, and low-x-digit happy. Thanks to +;;; SHIFT-AND-STORE-TRUNCATE-BUFFERS. +;;; + + +(defun do-truncate (len-x len-y) + (declare (type bignum-index len-x len-y)) + (let* ((len-q (- len-x len-y)) + ;; Add one for extra sign digit in case high bit is on. + (len-res (1+ len-q)) + (maybe-q (%allocate-bignum 2)) + (q (if (<= len-res 2) maybe-q (%allocate-bignum len-res))) + (k (1- len-q)) + (i (1- len-x)) + (low-x-digit (- i len-y))) + (declare (type bignum-index len-q len-res k i low-x-digit)) + (declare (dynamic-extent maybe-q)) + (loop + (digit-bind (h l) + (digit-bind (guess-h guess-l) + (bignum-truncate-guess-2 *truncate-x* i *truncate-y* (the fixnum (1- len-y))) + (try-bignum-truncate-guess guess-h guess-l len-y low-x-digit)) + (%bignum-set q k h l)) + (cond ((zerop k) (return)) + (t (decf k) + (decf low-x-digit) + (setq i (1- i))))) + (if (eq q maybe-q) + (progn + (setq q (%normalize-bignum-macro q)) + (if (fixnump q) q (copy-bignum q))) + (%normalize-bignum-macro q)))) + +(defun do-truncate-no-quo (len-x len-y) + (declare (type bignum-index len-x len-y)) + (let* ((len-q (- len-x len-y)) + (k (1- len-q)) + (i (1- len-x)) + (low-x-digit (- i len-y))) + (declare (type bignum-index len-q k i low-x-digit)) + (loop + (digit-bind (guess-h guess-l) (bignum-truncate-guess-2 *truncate-x* i *truncate-y* (the fixnum (1- len-y))) + (try-bignum-truncate-guess guess-h guess-l len-y low-x-digit) + (cond ((zerop k) (return)) + (t (decf k) + (decf low-x-digit) + (setq i (1- i)))))) + nil)) + +;;; TRY-BIGNUM-TRUNCATE-GUESS -- Internal. +;;; +;;; This takes a digit guess, multiplies it by *truncate-y* for a result one +;;; greater in length than len-y, and subtracts this result from *truncate-x*. +;;; Low-x-digit is the first digit of x to start the subtraction, and we know x +;;; is long enough to subtract a len-y plus one length bignum from it. Next we +;;; check the result of the subtraction, and if the high digit in x became +;;; negative, then our guess was one too big. In this case, return one less +;;; than guess passed in, and add one value of y back into x to account for +;;; subtracting one too many. Knuth shows that the guess is wrong on the order +;;; of 3/b, where b is the base (2 to the digit-size power) -- pretty rarely. +;;; + +(defun try-bignum-truncate-guess (guess-h guess-l len-y low-x-digit) + (declare (type bignum-index low-x-digit len-y)) + + (let ((carry-digit-h 0) + (carry-digit-l 0) + (borrow 1) + (i low-x-digit)) + (declare (type bignum-index i) + (fixnum borrow carry-digit-h carry-digit-l)) + ;; Multiply guess and divisor, subtracting from dividend simultaneously. + (dotimes (j len-y) + (multiple-value-bind (y-h y-l) (%bignum-ref *truncate-y* j) + (multiple-value-bind (high-h high-l low-h low-l) + (%multiply-and-add-1 guess-h + guess-l + y-h + y-l + carry-digit-h + carry-digit-l) + (setq carry-digit-h high-h + carry-digit-l high-l) + (multiple-value-bind (tx-h tx-l) (%bignum-ref *truncate-x* i) + (multiple-value-bind (x-h x-l temp-borrow) + (%subtract-with-borrow-1 tx-h tx-l low-h low-l borrow) + (%bignum-set *truncate-x* i x-h x-l) + (setq borrow temp-borrow))))) + (incf i)) + (multiple-value-bind (tx-h tx-l) (%bignum-ref *truncate-x* i) + (multiple-value-bind (x-h x-l) + (%subtract-with-borrow-1 tx-h tx-l carry-digit-h carry-digit-l borrow) + (%bignum-set *truncate-x* i x-h x-l))) + ;; See if guess is off by one, adding one Y back in if necessary. + + + (cond ((%digit-0-or-plusp *truncate-x* i) + (values guess-h guess-l)) + (t + ;; If subtraction has negative result, add one divisor value back + ;; in. The guess was one too large in magnitude. + ;; hmm - happens about 1.6% of the time + (bignum-add-loop-+ low-x-digit *truncate-x* *truncate-y* len-y) + (%subtract-one guess-h guess-l) + ;(%subtract-with-borrow guess-h guess-l 0 1 1) + )))) + + + +;;; BIGNUM-TRUNCATE-GUESS -- Internal. +;;; +;;; This returns a guess for the next division step. Y1 is the highest y +;;; digit, and y2 is the second to highest y digit. The x... variables are +;;; the three highest x digits for the next division step. +;;; +;;; From Knuth, our guess is either all ones or x-i and x-i-1 divided by y1, +;;; depending on whether x-i and y1 are the same. We test this guess by +;;; determining whether guess*y2 is greater than the three high digits of x +;;; minus guess*y1 shifted left one digit: +;;; ------------------------------ +;;; | x-i | x-i-1 | x-i-2 | +;;; ------------------------------ +;;; ------------------------------ +;;; - | g*y1 high | g*y1 low | 0 | +;;; ------------------------------ +;;; ... < guess*y2 ??? +;;; If guess*y2 is greater, then we decrement our guess by one and try again. +;;; This returns a guess that is either correct or one too large. +;;; +;;; the y's come from *truncate-y*, x's from *truncate-x* +;;; doing this in lap is not screamingly difficult - x's at i, i-1, i-2 + + + + + +(defun bignum-truncate-guess-2 (x xidx y yidx) + (digit-bind (guess-h guess-l) + (%floor-99 x xidx y yidx) + (truncate-guess-loop guess-h guess-l x xidx y yidx))) + + + + + +;;; SHIFT-Y-FOR-TRUNCATE -- Internal. +;;; +;;; This returns the amount to shift y to place a one in the second highest +;;; bit. Y must be positive. If the last digit of y is zero, then y has a +;;; one in the previous digit's sign bit, so we know it will take one less +;;; than digit-size to get a one where we want. Otherwise, we count how many +;;; right shifts it takes to get zero; subtracting this value from digit-size +;;; tells us how many high zeros there are which is one more than the shift +;;; amount sought. +;;; +;;; Note: This is exactly the same as one less than the integer-length of the +;;; last digit subtracted from the digit-size. +;;; +;;; We shift y to make it sufficiently large that doing the 64-bit by 32-bit +;;; %FLOOR calls ensures the quotient and remainder fit in 32-bits. +;;; +(defun shift-y-for-truncate (y) + (the fixnum (1- (the fixnum (%bignum-sign-bits y))))) + +;;; SHIFT-AND-STORE-TRUNCATE-BUFFERS -- Internal. +;;; +;;; Stores two bignums into the truncation bignum buffers, shifting them on the +;;; way in. This assumes x and y are positive and at least two in length, and +;;; it assumes *truncate-x* and *truncate-y* are one digit longer than x and y. +;;; +(defun shift-and-store-truncate-buffers (x len-x y len-y shift) + (declare (type bignum-index len-x len-y) + (type (integer 0 (#.digit-size)) shift)) + (cond ((eql 0 shift) + (bignum-replace *truncate-x* x :end1 len-x) + (bignum-replace *truncate-y* y :end1 len-y)) + (t + (bignum-ashift-left-unaligned x 0 shift (the fixnum (1+ len-x)) *truncate-x*) + (bignum-ashift-left-unaligned y 0 shift (the fixnum (1+ len-y)) *truncate-y*)))) + + + + + +;;;; General utilities. + + +;;; %NORMALIZE-BIGNUM-BUFFER -- Internal. +;;; +;;; Internal in-place operations use this to fixup remaining digits in the +;;; incoming data, such as in-place shifting. This is basically the same as +;;; the first form in %NORMALIZE-BIGNUM, but we return the length of the buffer +;;; instead of shrinking the bignum. +;;; + + + + + + + + +;;; %NORMALIZE-BIGNUM -- Internal. +;;; +;;; This drops the last digit if it is unnecessary sign information. It +;;; repeats this as needed, possibly ending with a fixnum. If the resulting +;;; length from shrinking is one, see if our one word is a fixnum. Shift the +;;; possible fixnum bits completely out of the word, and compare this with +;;; shifting the sign bit all the way through. If the bits are all 1's or 0's +;;; in both words, then there are just sign bits between the fixnum bits and +;;; the sign bit. If we do have a fixnum, shift it over for the two low-tag +;;; bits. +;;; + +(defun %normalize-bignum (res) + ;(declare (optimize (speed 3)(safety 0))) + (%normalize-bignum-2 t res)) + +;;; %MOSTLY-NORMALIZE-BIGNUM -- Internal. +;;; +;;; This drops the last digit if it is unnecessary sign information. It +;;; repeats this as needed, possibly ending with a fixnum magnitude but never +;;; returning a fixnum. +;;; + +(defun %mostly-normalize-bignum (res &optional len) + (declare (ignore len)) + (%normalize-bignum-2 nil res)) + + + + +; think its ok +(defun ldb32 (hi-data lo-data size pos) + (declare (fixnum hi-data lo-data size pos)) + (let* ((hi-bit (+ pos size)) + (mask (%i- (%ilsl size 1) 1))) + (declare (fixnum hi-bit mask)) + (%ilogand mask (if (< hi-bit 16) + (%iasr pos lo-data) + (if (>= pos 16) + (%ilsr (the fixnum (- pos 16)) hi-data) + (%ilogior + (%iasr pos lo-data) + (%ilsl (the fixnum (- 16 pos)) hi-data))))))) + + + + + +; this was wrong for negative bigs when byte includes or exceeds sign +(defun %ldb-fixnum-from-bignum (bignum size position) + (declare (fixnum size position)) + (let* ((low-idx (ash position -5)) + (low-bit (logand position 31)) + (hi-bit (+ low-bit size)) + (len (%bignum-length bignum)) + (minusp (bignum-minusp bignum))) + (declare (fixnum size position low-bit hi-bit low-idx len)) + (if (>= low-idx len) + (if minusp (1- (ash 1 size)) 0) + (multiple-value-bind (hi lo)(%bignum-ref bignum low-idx) + (let ((chunk-lo (ldb32 hi lo (min size (%i- 32 low-bit)) low-bit))) + (let ((val + (if (< hi-bit 32) + chunk-lo + (progn + (setq low-idx (1+ low-idx)) + (multiple-value-setq (hi lo) + (if (>= low-idx len) + (if minusp (values #xffff #xffff)(values 0 0)) + (%bignum-ref bignum low-idx))) + (let ((chunk-hi (ldb32 hi lo (%i- size (%i- 32 low-bit)) 0))) + (%ilogior (ash chunk-hi (%i- 32 low-bit)) chunk-lo)))))) + val)))))) + +(defun load-byte (size position integer) + (if (and (bignump integer) + (<= size (- 31 target::fixnumshift)) + (fixnump position)) + (%ldb-fixnum-from-bignum integer size position) + (let ((mask (byte-mask size))) + (if (and (fixnump mask) (fixnump integer)(fixnump position)) + (%ilogand mask (%iasr position integer)) + (logand mask (ash integer (- position))))))) + + +#+safe-but-slow +(defun %bignum-bignum-gcd (u v) + (setq u (abs u) v (abs v)) + (do* ((g 1 (ash g 1))) + ((or (oddp u) (oddp v)) + (do* () + ((zerop u) (* g v)) + (cond ((evenp u) (setq u (ash u -1))) + ((evenp v) (setq v (ash v -1))) + (t (let* ((temp (ash (abs (- u v)) -1))) + (if (< u v) + (setq v temp) + (setq u temp))))))) + (setq u (ash u -1) v (ash v -1)))) + + +(defun %positive-bignum-bignum-gcd (u0 v0) + (let* ((u-len (%bignum-length u0)) + (v-len (%bignum-length v0))) + (declare (fixnum u-len v-len)) + (if (or (< u-len v-len) + (and (= u-len v-len) + (< (bignum-compare u0 v0) 0))) + (psetq u0 v0 v0 u0 u-len v-len v-len u-len)) + (with-bignum-buffers ((u u-len) + (u2 u-len) + (v v-len) + (v2 v-len)) + (bignum-replace u u0) + (bignum-replace v v0) + (let* ((u-trailing-0-bits (%bignum-count-trailing-zero-bits u)) + (u-trailing-0-digits (ash u-trailing-0-bits -5)) + (v-trailing-0-bits (%bignum-count-trailing-zero-bits v)) + (v-trailing-0-digits (ash v-trailing-0-bits -5))) + (declare (fixnum u-trailing-0-bits v-trailing-0-bits)) + (unless (zerop u-trailing-0-bits) + (bignum-shift-right-loop-1 + (logand u-trailing-0-bits 31) + u2 + u + (the fixnum (1- (the fixnum (- u-len u-trailing-0-digits )))) + u-trailing-0-digits) + (rotatef u u2) + (%mostly-normalize-bignum-macro u) + (setq u-len (%bignum-length u))) + (unless (zerop v-trailing-0-bits) + (bignum-shift-right-loop-1 + (logand v-trailing-0-bits 31) + v2 + v + (the fixnum (1- (the fixnum (- v-len v-trailing-0-digits)))) + v-trailing-0-digits) + (rotatef v v2) + (%mostly-normalize-bignum-macro v) + (setq v-len (%bignum-length v))) + (let* ((shift (min u-trailing-0-bits + v-trailing-0-bits))) + (loop + (let* ((fix-u (and (= u-len 1) + (let* ((hi-u (%bignum-ref-hi u 0))) + (declare (fixnum hi-u)) + (= hi-u (the fixnum + (logand hi-u (ash target::target-most-positive-fixnum -16))))) + (uvref u 0))) + (fix-v (and (= v-len 1) + (let* ((hi-v (%bignum-ref-hi v 0))) + (declare (fixnum hi-v)) + (= hi-v (the fixnum + (logand hi-v (ash target::target-most-positive-fixnum -16))))) + (uvref v 0)))) + (if fix-v + (if fix-u + (return (ash (%fixnum-gcd fix-u fix-v) shift)) + (return (ash (bignum-fixnum-gcd u fix-v) shift))) + (if fix-u + (return (ash (bignum-fixnum-gcd v fix-u) shift))))) + + (let* ((signum (if (> u-len v-len) + 1 + (if (< u-len v-len) + -1 + (bignum-compare u v))))) + (declare (fixnum signum)) + (case signum + (0 ; (= u v) + (if (zerop shift) + (let* ((copy (%allocate-bignum u-len))) + (bignum-replace copy u) + (return copy)) + (return (ash u shift)))) + (1 ; (> u v) + (bignum-subtract-loop u u-len v v-len u) + (%mostly-normalize-bignum-macro u) + (setq u-len (%bignum-length u)) + (setq u-trailing-0-bits + (%bignum-count-trailing-zero-bits u) + u-trailing-0-digits + (ash u-trailing-0-bits -5)) + (unless (zerop u-trailing-0-bits) + (%init-misc 0 u2) + (bignum-shift-right-loop-1 + (logand u-trailing-0-bits 31) + u2 + u + (the fixnum (1- (the fixnum (- u-len + u-trailing-0-digits)))) + u-trailing-0-digits) + (rotatef u u2) + (%mostly-normalize-bignum-macro u) + (setq u-len (%bignum-length u)))) + (t ; (> v u) + (bignum-subtract-loop v v-len u u-len v) + (%mostly-normalize-bignum-macro v) + (setq v-len (%bignum-length v)) + (setq v-trailing-0-bits + (%bignum-count-trailing-zero-bits v) + v-trailing-0-digits + (ash v-trailing-0-bits -5)) + (unless (zerop v-trailing-0-bits) + (%init-misc 0 v2) + (bignum-shift-right-loop-1 + (logand v-trailing-0-bits 31) + v2 + v + (the fixnum (1- (the fixnum (- v-len v-trailing-0-digits)))) + v-trailing-0-digits) + (rotatef v v2) + (%mostly-normalize-bignum-macro v) + (setq v-len (%bignum-length v)))))))))))) + +(defun %bignum-bignum-gcd (u v) + (with-negated-bignum-buffers u v %positive-bignum-bignum-gcd)) + +(defun unsignedwide->integer (uwidep) + (with-bignum-buffers ((b 3)) + (setf (uvref b 0) (%get-unsigned-long uwidep 4) + (uvref b 1) (%get-unsigned-long uwidep 0)) + (let* ((n (%normalize-bignum b))) + (if (typep n 'bignum) + (copy-bignum n) + n)))) + +(defun one-bignum-factor-of-two (a) + (declare (type bignum-type a)) + (let ((len (%bignum-length a))) + (declare (fixnum len)) + (dotimes (i len) + (multiple-value-bind (a-h a-l) (%bignum-ref a i) + (declare (fixnum a-h a-l)) + (unless (and (= a-h 0)(= a-l 0)) + (return (+ (%ilsl 5 i) + (let* ((j 0) + (a a-l)) + (declare (fixnum a j)) + (if (= a-l 0) (setq j 16 a a-h)) + (dotimes (i 16) + (if (oddp a) + (return (%i+ j i)) + (setq a (%iasr 1 a)))))))))))) + +(defun logbitp (index integer) + "Predicate returns T if bit index of integer is a 1." + (number-case index + (fixnum + (if (minusp (the fixnum index))(report-bad-arg index '(integer 0)))) + (bignum + ;; assuming bignum cant have more than most-positive-fixnum bits + ;; (2 expt 24 longs) + (if (bignum-minusp index)(report-bad-arg index '(integer 0))) + ;; should error if integer isn't + (return-from logbitp (minusp (require-type integer 'integer))))) + (number-case integer + (fixnum + (if (%i< index (- target::nbits-in-word target::fixnumshift)) + (%ilogbitp index integer) + (minusp (the fixnum integer)))) + (bignum + (let ((bidx (%iasr 5 index)) + (bbit (%ilogand index 31))) + (declare (fixnum bidx bbit)) + (if (>= bidx (%bignum-length integer)) + (bignum-minusp integer) + (multiple-value-bind (hi lo) (%bignum-ref integer bidx) + (declare (fixnum hi lo)) + (if (> bbit 15) + (%ilogbitp (%i- bbit 16) hi) + (%ilogbitp bbit lo)))))))) + +) ; #+32-bit-target Index: /branches/new-random/level-0/l0-bignum64.lisp =================================================================== --- /branches/new-random/level-0/l0-bignum64.lisp (revision 13309) +++ /branches/new-random/level-0/l0-bignum64.lisp (revision 13309) @@ -0,0 +1,2264 @@ +;;;-*- Mode: Lisp; Package: CCL -*- +;;; +;;; Copyright (C) 2009 Clozure Associates +;;; Copyright (C) 1994-2001 Digitool, Inc +;;; This file is part of Clozure CL. +;;; +;;; Clozure CL is licensed under the terms of the Lisp Lesser GNU Public +;;; License , known as the LLGPL and distributed with Clozure CL as the +;;; file "LICENSE". The LLGPL consists of a preamble and the LGPL, +;;; which is distributed with Clozure CL as the file "LGPL". Where these +;;; conflict, the preamble takes precedence. +;;; +;;; Clozure CL is referenced in the preamble as the "LIBRARY." +;;; +;;; The LLGPL is also available online at +;;; http://opensource.franz.com/preamble.html + +(in-package "CCL") + +#+64-bit-target +(eval-when (:compile-toplevel :execute) + (require "ARCH") + (require "NUMBER-MACROS") + (require "NUMBER-CASE-MACRO") + + (defsetf bignum-ref bignum-set) + + (defconstant digit-size 32) + (defconstant half-digit-size (/ digit-size 2)) + + (defconstant maximum-bignum-length (1- (ash 1 56))) + (defconstant all-ones-digit #xffffffff) + (deftype bignum-index () `(integer 0 (,maximum-bignum-length))) + (deftype bignum-element-type () `(unsigned-byte ,digit-size)) + (deftype bignum-half-element-type () `(unsigned-byte ,half-digit-size)) + (deftype bignum-type () 'bignum) + (defmacro %normalize-bignum-macro (big) + `(%normalize-bignum-2 t ,big)) + + (defmacro %mostly-normalize-bignum-macro (big) + `(%normalize-bignum-2 nil ,big)) + (defmacro %lognot (x) + `(logand #xffffffff (lognot (the fixnum ,x)))) + (defmacro %logior (x y) + `(logior (the fixnum ,x) (the fixnum ,y))) + (defmacro %logxor (x y) + `(logand #xffffffff (logxor (the fixnum ,x) (the fixnum ,y)))) + + ;;; BIGNUM-REPLACE -- Internal. + ;;; + (defmacro bignum-replace (dest src &key (start1 '0) end1 (start2 '0) end2 + from-end) + (once-only ((n-dest dest) + (n-src src)) + (if (and (eq start1 0)(eq start2 0)(null end1)(null end2)(null from-end)) + ;; this is all true for some uses today << + `(%copy-ivector-to-ivector ,n-src 0 ,n-dest 0 (%ilsl 2 (min (the fixnum (%bignum-length ,n-src)) + (the fixnum (%bignum-length ,n-dest))))) + (let* ((n-start1 (gensym)) + (n-end1 (gensym)) + (n-start2 (gensym)) + (n-end2 (gensym))) + `(let ((,n-start1 ,start1) + (,n-start2 ,start2) + (,n-end1 ,(or end1 `(%bignum-length ,n-dest))) + (,n-end2 ,(or end2 `(%bignum-length ,n-src)))) + ,(if (null from-end) + `(%copy-ivector-to-ivector + ,n-src (%i* 4 ,n-start2) + ,n-dest (%i* 4 ,n-start1) + (%i* 4 (min (%i- ,n-end2 ,n-start2) + (%i- ,n-end1 ,n-start1)))) + `(let ((nwds (min (%i- ,n-end2 ,n-start2) + (%i- ,n-end1 ,n-start1)))) + (%copy-ivector-to-ivector + ,n-src (%ilsl 2 (%i- ,n-end2 nwds)) + ,n-dest (%ilsl 2 (%i- ,n-end1 nwds)) + (%i* 4 nwds))))))))) + + + ;;;; Shifting. + + (defconstant all-ones-half-digit #xFFFF) + + +;;; %ALLOCATE-BIGNUM must zero all elements. +;;; + (defmacro %allocate-bignum (ndigits) + `(%alloc-misc ,ndigits target::subtag-bignum)) + + (declaim (inline %bignum-length)) + +;;; This macro is used by BIGNUM-ASHIFT-RIGHT, +;;; BIGNUM-BUFFER-ASHIFT-RIGHT, and BIGNUM-LDB-BIGNUM-RES. They supply +;;; a termination form that references locals established by this +;;; form. Source is the source bignum. Start-digit is the first digit +;;; in source from which we pull bits. Start-pos is the first bit we +;;; want. Res-len-form is the form that computes the length of the +;;; resulting bignum. Termination is a DO termination form with a test +;;; and body. When result is supplied, it is the variable to which +;;; this binds a newly allocated bignum. +;;; +;;; Given start-pos, 1-31 inclusively, of shift, we form the j'th resulting +;;; digit from high bits of the i'th source digit and the start-pos number of +;;; bits from the i+1'th source digit. + (defmacro shift-right-unaligned (source + start-digit + start-pos + res-len-form + termination + &optional result) + `(let* ((high-bits-in-first-digit (- digit-size ,start-pos)) + (res-len ,res-len-form) + (res-len-1 (1- res-len)) + ,@(if result `((,result (%allocate-bignum res-len))))) + (declare (type bignum-index res-len res-len-1)) + (do ((i ,start-digit i+1) + (i+1 (1+ ,start-digit) (1+ i+1)) + (j 0 (1+ j))) + ,termination + (declare (type bignum-index i i+1 j)) + (setf (bignum-ref ,(if result result source) j) + (%logior (%digit-logical-shift-right (bignum-ref ,source i) + ,start-pos) + (%ashl (bignum-ref ,source i+1) + high-bits-in-first-digit)))))) + + + ) + + +#+64-bit-target +(progn + +;;; Extract the length of the bignum. +;;; +(defun %bignum-length (bignum) + (uvsize bignum)) + + + +;;; We can probably do better than UVREF here, but +;;; a) it's not -that- bad +;;; b) it does some bounds/sanity checking, which isn't a bad idea. + +(defmacro bignum-ref (b i) + `(%typed-miscref :bignum ,b ,i)) + +(defmacro bignum-set (b i val) + `(%typed-miscset :bignum ,b ,i ,val)) + + +(defun bignum-plusp (b) + (not (logbitp (1- digit-size) (the bignum-element-type (bignum-ref b (1- (%bignum-length b))))))) + +;;; Return T if digit is positive, or NIL if negative. +(defun %digit-0-or-plusp (digit) + (declare (type bignum-element-type digit)) + (not (logbitp (1- digit-size) digit))) + +(defun %bignum-0-or-plusp (bignum len) + (declare (type bignum-type bignum) + (type bignum-index len)) + (%digit-0-or-plusp (bignum-ref bignum (1- len)))) + +(defun bignum-minusp (b) + (logbitp 31 (the fixnum (bignum-ref b (1- (%bignum-length b)))))) + +(defun %sign-digit (b i) + (%ashr (bignum-ref b (1- i)) (1- digit-size))) + +;;; Return the sign of bignum (0 or -1) as a fixnum +(defun %bignum-sign (b) + (if (logbitp 31 (the fixnum (bignum-ref b (1- (%bignum-length b))))) + -1 + 0)) + + +(defun %add-with-carry (a-digit b-digit carry-in) + (declare (fixnum a-digit b-digit carry-in)) + (setq a-digit (logand all-ones-digit a-digit) + b-digit (logand all-ones-digit b-digit)) + (let* ((sum (+ carry-in (the fixnum (+ a-digit b-digit))))) + (declare (fixnum sum)) + (values (logand all-ones-digit sum) (logand 1 (the fixnum (ash sum -32)))))) + +(defun %subtract-with-borrow (a-digit b-digit borrow-in) + (declare (fixnum a-digit b-digit borrow-in)) + (setq a-digit (logand all-ones-digit a-digit) + b-digit (logand all-ones-digit b-digit)) + (let* ((diff (- (the fixnum (- a-digit b-digit)) + (the fixnum (- 1 borrow-in))))) + (declare (fixnum diff)) + (values (logand all-ones-digit diff) + (- 1 (logand (the fixnum (ash diff -32)) 1))))) + + + +(defun %compare-digits (bignum-a bignum-b idx) + (let* ((a (bignum-ref bignum-a idx)) + (b (bignum-ref bignum-b idx))) + (declare (fixnum a b)) + (if (= a b) + 0 + (if (> a b) + 1 + -1)))) + + + +;;;; Addition. +(defun add-bignums (a b) + (let* ((len-a (%bignum-length a)) + (len-b (%bignum-length b))) + (declare (bignum-index len-a len-b) + (optimize (speed 3) (safety 0))) + (when (> len-b len-a) + (rotatef a b) + (rotatef len-a len-b)) + (let* ((len-res (1+ len-a)) + (res (%allocate-bignum len-res)) + (carry 0) + (sign-b (%bignum-sign b))) + (dotimes (i len-b) + (let* ((sum (+ + (the fixnum (+ (the bignum-element-type (bignum-ref a i)) + (the bignum-element-type (bignum-ref b i)))) + carry))) + (declare (fixnum sum)) + (setf (bignum-ref res i) sum) + (setq carry (logand 1 (the fixnum (ash sum -32)))))) + (if (/= len-a len-b) + (finish-bignum-add res carry a sign-b len-b len-a) + (setf (bignum-ref res len-a) + (+ (the fixnum carry) + (the fixnum (+ (the bignum-element-type (%bignum-sign a)) + sign-b))))) + (%normalize-bignum-macro res)))) + +(defun add-bignum-and-fixnum (bignum fixnum) + (declare (bignum-type bignum) + (fixnum fixnum) + (optimize (speed 3) (safety 0))) + (let* ((len-bignum (%bignum-length bignum)) + (len-res (1+ len-bignum)) + (res (%allocate-bignum len-res)) + (low (logand all-ones-digit fixnum)) + (high (logand all-ones-digit (the fixnum (ash fixnum -32))))) + (declare (bignum-index len-bignum) + (bignum-type res) + (bignum-element-type low high)) + (let* ((sum0 (+ (the bignum-element-type (bignum-ref bignum 0)) low)) + (sum1 (+ (the fixnum (+ (the bignum-element-type (bignum-ref bignum 1)) + high)) + (the fixnum (logand 1 (ash sum0 -32))))) + (carry (logand 1 (ash sum1 -32)))) + (declare (fixnum sum0 sum1) (bignum-element-type carry)) + (setf (bignum-ref res 0) sum0 + (bignum-ref res 1) sum1) + (if (> len-bignum 2) + (finish-bignum-add res carry bignum (ash fixnum (- (- target::nbits-in-word target::fixnumshift))) 2 len-bignum) + (setf (bignum-ref res 2) + (+ (the fixnum carry) + (the fixnum (+ (the bignum-element-type (%bignum-sign bignum)) + (the fixnum (ash fixnum (- (- target::nbits-in-word target::fixnumshift))))))))) + (%normalize-bignum-macro res)))) + + + + + +;;; B was shorter than A; keep adding B's sign digit to each remaining +;;; digit of A, propagating the carry. +(defun finish-bignum-add (result carry a sign-b start end) + (declare (type bignum-index start end) + (bignum-element-type sign-b carry) + (optimize (speed 3) (safety 0))) + (do* ((i start (1+ i)) + (sign-b (logand all-ones-digit sign-b))) + ((= i end) + (setf (bignum-ref result end) + (the fixnum (+ + (the fixnum (+ (the fixnum + (logand all-ones-digit + (the fixnum + (%sign-digit a end)))) + sign-b)) + carry)))) + (declare (fixnum i) (bignum-element-type sign-b)) + (let* ((sum (the fixnum (+ (the fixnum (+ (bignum-ref a i) + sign-b)) + carry)))) + (declare (fixnum sum)) + (setf (bignum-ref result i) sum) + (setq carry (logand 1 (the fixnum (ash sum -32))))))) + + + + + +;;;; Subtraction. +(defun subtract-bignum (a b) + (let* ((len-a (%bignum-length a)) + (len-b (%bignum-length b)) + (len-res (1+ (max len-a len-b))) + (res (%allocate-bignum len-res))) + (declare (bignum-index len-a len-b len-res)) + (bignum-subtract-loop a len-a b len-b res) + (%normalize-bignum-macro res))) + +(defun bignum-subtract-loop (a len-a b len-b res) + (declare (bignum-index len-a len-b ) + (optimize (speed 3) (safety 0))) + (let* ((len-res (%bignum-length res))) + (declare (bignum-index len-res)) + (let* ((borrow 1) + (sign-a (%bignum-sign a)) + (sign-b (%bignum-sign b))) + (declare (bignum-element-type borrow sign-a sign-b)) + (dotimes (i (the bignum-index len-res)) + (multiple-value-bind (result-digit borrow-out) + (%subtract-with-borrow + (if (< i len-a) + (bignum-ref a i) + sign-a) + (if (< i len-b) + (bignum-ref b i) + sign-b) + borrow) + (setf (bignum-ref res i) result-digit + borrow borrow-out)))))) + + + +;;;; Multiplication. + +#|| +;;; These parameters match GMP's. +(defvar *sqr-basecase-threshold* 5) +(defvar *sqr-karatsuba-threshold* 22) +(defvar *mul-karatsuba-threshold* 10) + +;;; Squaring is often simpler than multiplication. This should never +;;; be called with (>= N *sqr-karatsuba-threshold*). +(defun mpn-sqr-basecase (prodp up n) + (declare (fixnum prodp up n)) + (declare (optimize (speed 3) (safety 0) (space 0))) + (umulppm up up prodp) + (when (> n 1) + (%stack-block ((tarr (* 4 (* 2 *sqr-karatsuba-threshold*)))) + (let* ((tp (macptr->fixnum tarr))) + (mpn-mul-1 tp + (the fixnum (1+ up)) + (the fixnum (1- n)) + up + (the fixnum (+ tp (the fixnum (1- n))))) + (do* ((i 2 (1+ i))) + ((= i n)) + (declare (fixnum i)) + (mpn-addmul-1 (the fixnum (- (the fixnum (+ tp (the fixnum (+ i i)))) + 2)) + (the fixnum (+ up i)) + (the fixnum (- n i)) + (the fixnum (+ up (the fixnum (1- i)))) + (the fixnum (+ tp (the fixnum (+ n (the fixnum (- i 2)))))))) + (do* ((i 1 (1+ i)) + (ul (1+ up) (1+ ul))) + ((= i n)) + (declare (fixnum i ul)) + (umulppm ul ul (the fixnum (+ prodp (the fixnum (+ i i)))))) + (let* ((2n-2 (- (the fixnum (+ n n)) 2)) + (carry (mpn-lshift-1 tp tp 2n-2))) + (declare (fixnum 2n-2 carry)) + (incf carry (the fixnum (mpn-add-n (the fixnum (1+ prodp)) + (the fixnum (1+ prodp)) + tp + 2n-2))) + (add-fixnum-to-limb carry (the fixnum (+ prodp + (the fixnum (1- + (the fixnum + (+ n n)))))))))))) + +;;; For large enough values of N, squaring via Karatsuba-style +;;; divide&conquer is faster than in the base case. +(defun mpn-kara-sqr-n (p a n ws) + (declare (fixnum p a n ws)) + (declare (optimize (speed 3) (safety 0) (space 0))) + (%stack-block ((limbs 16)) + (let* ((w (macptr->fixnum limbs)) + (w0 (1+ w)) + (w1 (1+ w0)) + (xx (1+ w1)) + (n2 (ash n -1)) + (x 0) + (y 0) + (i 0)) + (declare (fixnum w w0 w1 xx n2 x y i)) + (cond ((logbitp 0 n) + ;; Odd length + (let* ((n3 (- n n2)) + (n1 0) + (nm1 0)) + (declare (fixnum n3 n1 nm1)) + (copy-limb (the fixnum (+ a n2)) w) + (if (not (limb-zerop w)) + (add-fixnum-to-limb + (the fixnum + (- (the fixnum (mpn-sub-n p a (the fixnum (+ a n3)) n2)))) + w) + (progn + (setq i n2) + (loop + (decf i) + (copy-limb (the fixnum (+ a i)) w0) + (copy-limb (the fixnum (+ a (the fixnum (+ n3 i)))) w1) + (if (or (not (zerop (the fixnum (compare-limbs w0 w1)))) + (= i 0)) + (return))) + (if (< (the fixnum (compare-limbs w0 w1)) 0) + (setq x (+ a n3) + y a) + (setq y (+ a n3) + x a)) + (mpn-sub-n p x y n2))) + (copy-limb w (the fixnum (+ p n2))) + (setq n1 (1+ n)) + (cond ((< n3 *sqr-basecase-threshold*) + (mpn-mul-basecase ws p n3 p n3) + (mpn-mul-basecase p a n3 a n3)) + ((< n3 *sqr-karatsuba-threshold*) + (mpn-sqr-basecase ws p n3) + (mpn-sqr-basecase p a n3)) + (t + (mpn-kara-sqr-n ws p n3 (the fixnum (+ ws n1))) + (mpn-kara-sqr-n p a n3 (the fixnum (+ ws n1))))) + (cond ((< n2 *sqr-basecase-threshold*) + (mpn-mul-basecase (the fixnum (+ p n1)) + (the fixnum (+ a n3)) + n2 + (the fixnum (+ a n3)) + n2)) + ((< n2 *sqr-karatsuba-threshold*) + (mpn-sqr-basecase (the fixnum (+ p n1)) + (the fixnum (+ a n3)) + n2)) + (t + (mpn-kara-sqr-n (the fixnum (+ p n1)) + (the fixnum (+ a n3)) + n2 + (the fixnum (+ ws n1))))) + (mpn-sub-n ws p ws n1) + (setq nm1 (1- n)) + (unless (zerop (the fixnum + (mpn-add-n ws + (the fixnum (+ p n1)) + ws + nm1))) + (copy-limb (the fixnum (+ ws nm1)) xx) + (add-fixnum-to-limb 1 xx) + (copy-limb xx (the fixnum (+ ws nm1))) + (if (limb-zerop xx) + (add-fixnum-to-limb 1 (the fixnum (+ ws n))))) + (unless (zerop + (the fixnum + (mpn-add-n (the fixnum (+ p n3)) + (the fixnum (+ p n3)) + ws + n1))) + (mpn-incr-u (the fixnum (+ p (the fixnum (+ n1 n3)))) + 1)))) + (t ; N is even + (setq i n2) + (loop + (decf i) + (copy-limb (the fixnum (+ a i)) w0) + (copy-limb (the fixnum (+ a (the fixnum (+ n2 i)))) w1) + (if (or (not (zerop (the fixnum (compare-limbs w0 w1)))) + (= i 0)) + (return))) + (if (< (the fixnum (compare-limbs w0 w1)) 0) + (setq x (+ a n2) + y a) + (setq y (+ a n2) + x a)) + (mpn-sub-n p x y n2) + (cond ((< n2 *sqr-basecase-threshold*) + (mpn-mul-basecase ws p n2 p n2) + (mpn-mul-basecase p a n2 a n2) + (mpn-mul-basecase (the fixnum (+ p n)) + (the fixnum (+ a n2)) + n2 + (the fixnum (+ a n2)) + n2)) + ((< n2 *sqr-karatsuba-threshold*) + (mpn-sqr-basecase ws p n2) + (mpn-sqr-basecase p a n2) + (mpn-sqr-basecase (the fixnum (+ p n)) + (the fixnum (+ a n2)) + n2)) + (t + (mpn-kara-sqr-n ws p n2 (the fixnum (+ ws n))) + (mpn-kara-sqr-n p a n2 (the fixnum (+ ws n))) + (mpn-kara-sqr-n (the fixnum (+ p n)) + (the fixnum (+ a n2)) + n2 + (the fixnum (+ ws n))))) + (let* ((ww (- (the fixnum (mpn-sub-n ws p ws n))))) + (declare (fixnum ww)) + (setq ww (+ ww (mpn-add-n ws (the fixnum (+ p n)) ws n))) + (setq ww (+ ww (mpn-add-n (the fixnum (+ p n2)) + (the fixnum (+ p n2)) + ws + n))) + (mpn-incr-u (the fixnum (+ p (the fixnum (+ n2 n)))) ww))))))) + +;;; Karatsuba subroutine: multiply A and B, store result at P, use WS +;;; as scrach space. Treats A and B as if they were both of size N; +;;; if that's not true, caller must fuss around the edges. +(defun mpn-kara-mul-n (p a b n ws) + (declare (fixnum p a b n ws)) + (declare (optimize (speed 3) (safety 0) (space 0))) + (%stack-block ((limbs 16)) + (let* ((w (macptr->fixnum limbs)) + (w0 (1+ w)) + (w1 (1+ w0)) + (xx (1+ w1)) + (x 0) + (y 0) + (i 0) + (n2 (ash n -1)) + (sign 0)) + (declare (fixnum w w0 w1 xx x y i n2 sign)) + (cond ((logbitp 0 n) + (let* ((n1 0) + (n3 (- n n2)) + (nm1 0)) + (declare (fixnum n1 n3 nm1)) + (copy-limb (the fixnum (+ a n2)) w) + (if (not (limb-zerop w)) + (add-fixnum-to-limb + (the fixnum (- (mpn-sub-n p a (the fixnum (+ a n3)) n2))) w) + (progn + (setq i n2) + (loop + (decf i) + (copy-limb (the fixnum (+ a i)) w0) + (copy-limb (the fixnum (+ a (the fixnum (+ n3 i)))) w1) + (if (or (not (zerop (the fixnum (compare-limbs w0 w1)))) + (zerop i)) + (return))) + (if (< (the fixnum (compare-limbs w0 w1)) 0) + (setq x (+ a n3) + y a + sign -1) + (setq x a + y (+ a n3))) + (mpn-sub-n p x y n2))) + (copy-limb w (the fixnum (+ p n2))) + (copy-limb (the fixnum (+ b n2)) w) + (if (not (limb-zerop w)) + (add-fixnum-to-limb + (the fixnum (- (the fixnum (mpn-sub-n (the fixnum (+ p n3)) + b + (the fixnum (+ b n3)) + n2)))) + w) + (progn + (setq i n2) + (loop + (decf i) + (copy-limb (the fixnum (+ b i)) w0) + (copy-limb (the fixnum (+ b (the fixnum (+ n3 i)))) w1) + (if (or (not (zerop (the fixnum (compare-limbs w0 w1)))) + (zerop i)) + (return))) + (if (< (the fixnum (compare-limbs w0 w1)) 0) + (setq x (+ b n3) + y b + sign (lognot sign)) + (setq x b + y (+ b n3))) + (mpn-sub-n (the fixnum (+ p n3)) x y n2))) + (copy-limb w (the fixnum (+ p n))) + (setq n1 (1+ n)) + (cond + ((< n2 *mul-karatsuba-threshold*) + (cond + ((< n3 *mul-karatsuba-threshold*) + (mpn-mul-basecase ws p n3 (the fixnum (+ p n3)) n3) + (mpn-mul-basecase p a n3 b n3)) + (t + (mpn-kara-mul-n ws p (the fixnum (+ p n3)) n3 (the fixnum (+ ws n1))) + (mpn-kara-mul-n p a b n3 (the fixnum (+ ws n1))))) + (mpn-mul-basecase (the fixnum (+ p n1)) + (the fixnum (+ a n3)) + n2 + (the fixnum (+ b n3)) + n2)) + (t + (mpn-kara-mul-n ws p (the fixnum (+ p n3)) n3 (the fixnum (+ ws n1))) + (mpn-kara-mul-n p a b n3 (the fixnum (+ ws n1))) + (mpn-kara-mul-n (the fixnum (+ p n1)) + (the fixnum (+ a n3)) + (the fixnum (+ b n3)) + n2 + (the fixnum (+ ws n1))))) + (if (not (zerop sign)) + (mpn-add-n ws p ws n1) + (mpn-sub-n ws p ws n1)) + (setq nm1 (1- n)) + (unless (zerop (the fixnum (mpn-add-n ws + (the fixnum (+ p n1)) + ws + nm1))) + (copy-limb (the fixnum (+ ws nm1)) xx) + (add-fixnum-to-limb 1 xx) + (copy-limb xx (the fixnum (+ ws nm1))) + (if (limb-zerop xx) + (add-fixnum-to-limb 1 (the fixnum (+ ws n))))) + (unless (zerop (the fixnum + (mpn-add-n (the fixnum (+ p n3)) + (the fixnum (+ p n3)) + ws + n1))) + (mpn-incr-u (the fixnum + (+ p (the fixnum (+ n1 n3)))) 1)))) + (t ; even length + (setq i n2) + (loop + (decf i) + (copy-limb (the fixnum (+ a i)) w0) + (copy-limb (the fixnum (+ a (the fixnum (+ n2 i)))) w1) + (if (or (not (zerop (the fixnum (compare-limbs w0 w1)))) + (zerop i)) + (return))) + (setq sign 0) + (if (< (the fixnum (compare-limbs w0 w1)) 0) + (setq x (+ a n2) + y a + sign -1) + (setq x a + y (+ a n2))) + (mpn-sub-n p x y n2) + (setq i n2) + (loop + (decf i) + (copy-limb (the fixnum (+ b i)) w0) + (copy-limb (the fixnum (+ b (the fixnum (+ n2 i)))) w1) + (if (or (not (zerop (the fixnum (compare-limbs w0 w1)))) + (zerop i)) + (return))) + (if (< (the fixnum (compare-limbs w0 w1)) 0) + (setq x (+ b n2) + y b + sign (lognot sign)) + (setq x b + y (+ b n2))) + (mpn-sub-n (the fixnum (+ p n2)) x y n2) + (cond + ((< n2 *mul-karatsuba-threshold*) + (mpn-mul-basecase ws p n2 (the fixnum (+ p n2)) n2) + (mpn-mul-basecase p a n2 b n2) + (mpn-mul-basecase (the fixnum (+ p n)) + (the fixnum (+ a n2)) + n2 + (the fixnum (+ b n2)) + n2)) + (t + (mpn-kara-mul-n ws p (the fixnum (+ p n2)) n2 + (the fixnum (+ ws n))) + (mpn-kara-mul-n p a b n2 (the fixnum (+ ws n))) + (mpn-kara-mul-n (the fixnum (+ p n)) + (the fixnum (+ a n2)) + (the fixnum (+ b n2)) + n2 + (the fixnum (+ ws n))))) + (let* ((ww (if (not (zerop sign)) + (mpn-add-n ws p ws n) + (- (the fixnum (mpn-sub-n ws p ws n)))))) + (declare (fixnum ww)) + (setq ww (+ ww (mpn-add-n ws (the fixnum (+ p n)) ws n))) + (setq ww (+ ww (mpn-add-n (the fixnum (+ p n2)) + (the fixnum (+ p n2)) + ws + n))) + (mpn-incr-u (the fixnum (+ p (the fixnum (+ n2 n)))) ww))))))) + +;;; Square UP, of length UN. I wonder if a Karatsuba multiply might be +;;; faster than a basecase square. +(defun mpn-sqr-n (prodp up un) + (declare (fixnum prodp up un)) + (declare (optimize (speed 3) (safety 0) (space 0))) + (if (< un *sqr-basecase-threshold*) + (mpn-mul-basecase prodp up un up un) + (if (< un *sqr-karatsuba-threshold*) + (mpn-sqr-basecase prodp up un) + (%stack-block ((wsptr (mpn-kara-sqr-n-tsize un))) + (mpn-kara-sqr-n prodp up un (macptr->fixnum wsptr)))))) + +;;; Subroutine: store AxB at P. Assumes A & B to be of length N +(defun mpn-mul-n (p a b n) + (declare (fixnum p a b n)) + (declare (optimize (speed 3) (safety 0) (space 0))) + (if (< n *mul-karatsuba-threshold*) + (mpn-mul-basecase p a n b n) + (%stack-block ((wsptr (mpn-kara-mul-n-tsize n))) + (mpn-kara-mul-n p a b n (macptr->fixnum wsptr))))) + + +;;; Multiply [UP,UN] by [VP,VN]. UN must not be less than VN. +;;; This does Karatsuba if operands are big enough; if they are +;;; and they differ in size, this computes the product of the +;;; smaller-size slices, then fixes up the resut. +(defun mpn-mul (prodp up un vp vn) + (declare (fixnum prodp up un vp vn)) + (declare (optimize (speed 3) (safety 0) (space 0))) + ;(assert (>= un vn 1)) + (if (and (= up vp) (= un vn)) + (mpn-sqr-n prodp up un) + (if (< vn *mul-karatsuba-threshold*) + (mpn-mul-basecase prodp up un vp vn) + (let* ((l vn)) + (declare (fixnum l)) + (mpn-mul-n prodp up vp vn) + (unless (= un vn) + (incf prodp vn) + (incf up vn) + (decf un vn) + (if (< un vn) + (psetq un vn vn un up vp vp up)) + (%stack-block ((wsptr + (the fixnum + (+ 8 + (the fixnum + (* 4 + (the fixnum + (+ vn + (if (>= vn *mul-karatsuba-threshold*) + vn + un))))))))) + (setf (%get-unsigned-long wsptr 0) 0 + (%get-unsigned-long wsptr 4) 0) + (let* ((tt (macptr->fixnum wsptr)) + (c (1+ tt)) + (ws (1+ c))) + (declare (fixnum tt c ws )) + (do* () + ((< vn *mul-karatsuba-threshold*)) + (mpn-mul-n ws up vp vn) + (cond ((<= l (the fixnum (+ vn vn))) + (add-fixnum-to-limb (mpn-add-n prodp prodp ws l) tt) + (unless (= l (the fixnum (+ vn vn))) + (copy-fixnum-to-limb + (mpn-add-1 (the fixnum (+ prodp l)) + (the fixnum (+ ws l)) + (the fixnum (- (the fixnum (+ vn vn)) l)) + tt) + tt) + (setq l (the fixnum (+ vn vn))))) + (t + (copy-fixnum-to-limb + (mpn-add-n prodp prodp ws (the fixnum (+ vn vn))) c) + (add-fixnum-to-limb + (mpn-add-1 (the fixnum (+ prodp (the fixnum (+ vn vn)))) + (the fixnum (+ prodp (the fixnum (+ vn vn)))) + (the fixnum (- l (the fixnum (+ vn vn)))) + c) + tt))) + (incf prodp vn) + (decf l vn) + (incf up vn) + (decf un vn) + (if (< un vn) + (psetq up vp vp up un vn vn un))) + (unless (zerop vn) + (mpn-mul-basecase ws up un vp vn) + (cond ((<= l (the fixnum (+ un vn))) + (add-fixnum-to-limb + (mpn-add-n prodp prodp ws l) + tt) + (unless (= l (the fixnum (+ un vn))) + (copy-fixnum-to-limb + (mpn-add-1 (the fixnum (+ prodp l)) + (the fixnum (+ ws l)) + (the fixnum (- (the fixnum (+ un vn)) l)) + tt) + tt))) + (t + (copy-fixnum-to-limb + (mpn-add-n prodp prodp ws (the fixnum (+ un vn))) + c) + (add-fixnum-to-limb + (mpn-add-1 + (the fixnum (+ prodp (the fixnum (+ un vn)))) + (the fixnum (+ prodp (the fixnum (+ un vn)))) + (the fixnum (- (the fixnum (- l un)) vn)) + c) + tt))))))))))) +||# + +(defun multiply-bignums (a b) + (let* ((signs-differ (not (eq (bignum-minusp a) (bignum-minusp b))))) + (flet ((multiply-unsigned-bignums (a b) + (let* ((len-a (%bignum-length a)) + (len-b (%bignum-length b)) + (len-res (+ len-a len-b)) + (res (%allocate-bignum len-res))) + (declare (bignum-index len-a len-b len-res)) + (dotimes (i len-a) + (declare (type bignum-index i)) + (%multiply-and-add-loop a b res i len-b)) + res)) + (multiply-unsigned-bignums64 (a b) + (let* ((len-a (ceiling (%bignum-length a) 2)) + (len-b (ceiling (%bignum-length b) 2)) + (len-res (+ len-a len-b)) + (res (%allocate-bignum (+ len-res len-res)))) + (declare (bignum-index len-a len-b len-res)) + (dotimes (i len-a) + (declare (type bignum-index i)) + (%multiply-and-add-loop64 a b res i len-b)) + res))) + (let* ((res (with-negated-bignum-buffers a b + multiply-unsigned-bignums64))) + (if signs-differ (negate-bignum-in-place res)) + (%normalize-bignum-macro res))))) + +(defun multiply-bignum-and-fixnum (bignum fixnum) + (declare (type bignum-type bignum) (fixnum fixnum)) + (if (eql fixnum 1) + bignum + (with-small-bignum-buffers ((big-fix fixnum)) + (multiply-bignums bignum big-fix)))) + +#+slower +(defun multiply-bignum-and-fixnum (bignum fixnum) + (declare (type bignum-type bignum) (fixnum fixnum)) + (if (eql fixnum 1) + bignum + (if (eql fixnum target::target-most-negative-fixnum) + (with-small-bignum-buffers ((big-fix fixnum)) + (multiply-bignums bignum big-fix)) + (let* ((big-len (%bignum-length bignum)) + (big-neg (bignum-minusp bignum)) + (signs-differ (not (eq big-neg (minusp fixnum))))) + (flet ((multiply-unsigned-bignum-and-2-digit-fixnum (a len-a high low) + (declare (bignum-type a) + (bignum-element-type high low) + (bignum-index len-a) + (optimize (speed 3) (safety 0))) + (let* ((len-res (+ len-a 2)) + (res (%allocate-bignum len-res)) ) + (declare (bignum-index len-a len-res)) + (dotimes (i len-a) + (declare (type bignum-index i)) + (let* ((carry-digit 0) + (x (bignum-ref a i)) + (k i)) + (declare (fixnum k)) + (multiple-value-bind (big-carry res-digit) + (%multiply-and-add4 x + low + (bignum-ref res k) + carry-digit) + (setf (bignum-ref res k) res-digit + carry-digit big-carry + k (1+ k))) + (multiple-value-bind (big-carry res-digit) + (%multiply-and-add4 x + high + (bignum-ref res k) + carry-digit) + (setf (bignum-ref res k) res-digit + carry-digit big-carry + k (1+ k))) + (setf (bignum-ref res k) carry-digit))) + res)) + (multiply-unsigned-bignum-and-1-digit-fixnum (a len-a fix) + (declare (bignum-type a) + (bignum-element-type fix) + (bignum-index len-a) + (optimize (speed 3) (safety 0))) + (let* ((len-res (+ len-a 1)) + (res (%allocate-bignum len-res)) ) + (declare (bignum-index len-a len-res)) + (dotimes (i len-a) + (declare (type bignum-index i)) + (let* ((carry-digit 0) + (x (bignum-ref a i)) + (k i)) + (declare (fixnum k)) + (multiple-value-bind (big-carry res-digit) + (%multiply-and-add4 x + fix + (bignum-ref res k) + carry-digit) + (setf (bignum-ref res k) res-digit + carry-digit big-carry + k (1+ k))) + (setf (bignum-ref res k) carry-digit))) + res))) + (let* ((fixnum (if (< fixnum 0) (- fixnum) fixnum)) + (low (logand (1- (ash 1 32)) fixnum)) + (high (unless (<= (%fixnum-intlen fixnum) 32) + (ldb (byte 32 32) fixnum))) + (res (if big-neg + (let* ((neg-len (1+ big-len))) + (declare (type bignum-index neg-len)) + (with-bignum-buffers ((neg neg-len)) + (negate-bignum bignum nil neg) + (setq neg-len (%bignum-length bignum)) + (if high + (multiply-unsigned-bignum-and-2-digit-fixnum + neg + neg-len + high + low) + (multiply-unsigned-bignum-and-1-digit-fixnum + neg + neg-len + low)))) + (if high + (multiply-unsigned-bignum-and-2-digit-fixnum + bignum + big-len + high + low) + (multiply-unsigned-bignum-and-1-digit-fixnum + bignum + big-len + low))))) + (if signs-differ (negate-bignum-in-place res)) + (%normalize-bignum-macro res))))))) + + +;; assume we already know result won't fit in a fixnum +;; only caller is fixnum-*-2 +;; + +(defun multiply-fixnums (a b) + (declare (fixnum a b)) + (* a b)) + + +;;;; GCD. + + +;;; Both args are > 0. +(defun bignum-fixnum-gcd (bignum fixnum) + (let* ((rem (bignum-truncate-by-fixnum-no-quo bignum fixnum))) + (declare (fixnum rem)) + (if (zerop rem) + fixnum + (%fixnum-gcd rem fixnum)))) + + + + +;;; NEGATE-BIGNUM -- Public. +;;; +;;; Fully-normalize is an internal optional. It cause this to always return +;;; a bignum, without any extraneous digits, and it never returns a fixnum. +;;; +(defun negate-bignum (x &optional (fully-normalize t) res) + (declare (type bignum-type x)) + (let* ((len-x (%bignum-length x)) + (len-res (1+ len-x)) + (minusp (bignum-minusp x)) + (res (or res (%allocate-bignum len-res)))) + (declare (type bignum-index len-x len-res)) ;Test len-res for range? + (let ((carry (bignum-negate-loop-really x len-x res))) + (declare (fixnum carry)) + (if (zerop carry) + (setf (bignum-ref res len-x) (if minusp 0 all-ones-digit)) + (setf (bignum-ref res len-x) (if minusp 1 0)))) + (if fully-normalize + (%normalize-bignum-macro res) + (%mostly-normalize-bignum-macro res)))) + +;;; NEGATE-BIGNUM-IN-PLACE -- Internal. +;;; +;;; This assumes bignum is positive; that is, the result of negating it will +;;; stay in the provided allocated bignum. +;;; +(defun negate-bignum-in-place (bignum) + (bignum-negate-loop-really bignum (%bignum-length bignum) bignum) + bignum) + + + + +(defun copy-bignum (bignum) + (let ((res (%allocate-bignum (%bignum-length bignum)))) + (bignum-replace res bignum) + res)) + + + + +;;; BIGNUM-ASHIFT-RIGHT -- Public. +;;; +;;; First compute the number of whole digits to shift, shifting them by +;;; skipping them when we start to pick up bits, and the number of bits to +;;; shift the remaining digits into place. If the number of digits is greater +;;; than the length of the bignum, then the result is either 0 or -1. If we +;;; shift on a digit boundary (that is, n-bits is zero), then we just copy +;;; digits. The last branch handles the general case which uses a macro that a +;;; couple other routines use. The fifth argument to the macro references +;;; locals established by the macro. +;;; + + +(defun bignum-ashift-right (bignum x) + (declare (type bignum-type bignum) + (fixnum x) + (optimize (speed 3) (safety 0))) + (let ((bignum-len (%bignum-length bignum))) + (declare (type bignum-index bignum-len)) + (multiple-value-bind (digits n-bits) (truncate x digit-size) + (declare (type bignum-index digits)(fixnum n-bits)) + (cond + ((>= digits bignum-len) + (if (bignum-plusp bignum) 0 -1)) + ((eql 0 n-bits) + (bignum-ashift-right-digits bignum digits)) + (t + (shift-right-unaligned bignum digits n-bits (- bignum-len digits) + ((= j res-len-1) + (setf (bignum-ref res j) + (%ashr (bignum-ref bignum i) n-bits)) + (%normalize-bignum-macro res)) + res)))))) + + + + + +;;; BIGNUM-ASHIFT-RIGHT-DIGITS -- Internal. +;;; +(defun bignum-ashift-right-digits (bignum digits) + (declare (type bignum-type bignum) + (type bignum-index digits)) + (let* ((res-len (- (%bignum-length bignum) digits)) + (res (%allocate-bignum res-len))) + (declare (type bignum-index res-len) + (type bignum-type res)) + (bignum-replace res bignum :start2 digits) + (%normalize-bignum-macro res))) + + +;;; BIGNUM-BUFFER-ASHIFT-RIGHT -- Internal. +;;; +;;; GCD uses this for an in-place shifting operation. This is different enough +;;; from BIGNUM-ASHIFT-RIGHT that it isn't worth folding the bodies into a +;;; macro, but they share the basic algorithm. This routine foregoes a first +;;; test for digits being greater than or equal to bignum-len since that will +;;; never happen for its uses in GCD. We did fold the last branch into a macro +;;; since it was duplicated a few times, and the fifth argument to it +;;; references locals established by the macro. +;;; + + +;;; BIGNUM-ASHIFT-LEFT -- Public. +;;; +;;; This handles shifting a bignum buffer to provide fresh bignum data for some +;;; internal routines. We know bignum is safe when called with bignum-len. +;;; First we compute the number of whole digits to shift, shifting them +;;; starting to store farther along the result bignum. If we shift on a digit +;;; boundary (that is, n-bits is zero), then we just copy digits. The last +;;; branch handles the general case. +;;; +(defun bignum-ashift-left (bignum x &optional bignum-len) + (declare (type bignum-type bignum) + (fixnum x) + (type (or null bignum-index) bignum-len)) + (multiple-value-bind (digits n-bits) + (truncate x digit-size) + (declare (fixnum digits n-bits)) + (let* ((bignum-len (or bignum-len (%bignum-length bignum))) + (res-len (+ digits bignum-len 1))) + (declare (fixnum bignum-len res-len)) + (when (> res-len maximum-bignum-length) + (error "Can't represent result of left shift.")) + (if (zerop n-bits) + (bignum-ashift-left-digits bignum bignum-len digits) + (bignum-ashift-left-unaligned bignum digits n-bits res-len))))) + +;;; BIGNUM-ASHIFT-LEFT-DIGITS -- Internal. +;;; +(defun bignum-ashift-left-digits (bignum bignum-len digits) + (declare (type bignum-index bignum-len digits)) + (let* ((res-len (+ bignum-len digits)) + (res (%allocate-bignum res-len))) + (declare (type bignum-index res-len)) + (bignum-replace res bignum :start1 digits :end1 res-len :end2 bignum-len + :from-end t) + res)) + + + +;;; BIGNUM-ASHIFT-LEFT-UNALIGNED -- Internal. +;;; +;;; BIGNUM-TRUNCATE uses this to store into a bignum buffer by supplying res. +;;; When res comes in non-nil, then this foregoes allocating a result, and it +;;; normalizes the buffer instead of the would-be allocated result. +;;; +;;; We start storing into one digit higher than digits, storing a whole result +;;; digit from parts of two contiguous digits from bignum. When the loop +;;; finishes, we store the remaining bits from bignum's first digit in the +;;; first non-zero result digit, digits. We also grab some left over high +;;; bits from the last digit of bignum. +;;; + +(defun bignum-ashift-left-unaligned (bignum digits n-bits res-len + &optional (res nil resp)) + (declare (type bignum-index digits res-len) + (type (mod #.digit-size) n-bits)) + (let* ((remaining-bits (- digit-size n-bits)) + (res-len-1 (1- res-len)) + (res (or res (%allocate-bignum res-len)))) + (declare (type bignum-index res-len res-len-1) + (optimize (speed 3) (safety 0))) + (do ((i 0 i+1) + (i+1 1 (1+ i+1)) + (j (1+ digits) (1+ j))) + ((= j res-len-1) + (setf (bignum-ref res digits) + (%ashl (bignum-ref bignum 0) n-bits)) + (setf (bignum-ref res j) + (%ashr (bignum-ref bignum i) remaining-bits)) + (if resp + (%zero-trailing-sign-digits res res-len) + (%mostly-normalize-bignum-macro res))) + (declare (type bignum-index i i+1 j)) + (setf (bignum-ref res j) + (%logior (%digit-logical-shift-right (bignum-ref bignum i) + remaining-bits) + (%ashl (bignum-ref bignum i+1) n-bits)))))) + + + + + + + + +;;;; Relational operators. + + + +;;; BIGNUM-COMPARE -- Public. +;;; +;;; This compares two bignums returning -1, 0, or 1, depending on whether a +;;; is less than, equal to, or greater than b. +;;; +;(proclaim '(function bignum-compare (bignum bignum) (integer -1 1))) +(defun bignum-compare (a b) + (declare (type bignum-type a b)) + (let* ((a-plusp (bignum-plusp a)) + (b-plusp (bignum-plusp b))) + (if (eq a-plusp b-plusp) + (let* ((len-a (%bignum-length a)) + (len-b (%bignum-length b))) + (declare (type bignum-index len-a len-b)) + (cond ((= len-a len-b) + (do* ((i (1- len-a) (1- i))) + ((zerop i) (%compare-digits a b 0)) + (declare (fixnum i)) + (let* ((signum (%compare-digits a b i))) + (declare (fixnum signum)) + (unless (zerop signum) + (return signum))))) + ((> len-a len-b) + (if a-plusp 1 -1)) + (t (if a-plusp -1 1)))) + (if a-plusp 1 -1)))) + + + + + + + +;;;; Integer length and logcount + + +(defun bignum-integer-length (big) + (the fixnum (- (the fixnum (ash (the fixnum (%bignum-length big)) 5)) + (the fixnum (%bignum-sign-bits big))))) + +; (not (zerop (logand integer1 integer2) + +(defun bignum-logtest (num1 num2) + (let* ((length1 (%bignum-length num1)) + (length2 (%bignum-length num2)) + (n1-minusp (bignum-minusp num1)) + (n2-minusp (bignum-minusp num2))) + (declare (fixnum length1 length2)) + (if (and n1-minusp n2-minusp) ; both neg, get out quick + T + (or (dotimes (i (min length1 length2)) + (unless (zerop (the fixnum + (logand (the fixnum (bignum-ref num1 i)) + (the fixnum (bignum-ref num2 i))))) + (return t))) + (if (< length1 length2) + n1-minusp + (if (< length1 length2) + n2-minusp)))))) + +(defun logtest-fix-big (fix big) + (declare (fixnum fix)) + (unless (zerop fix) + (if (plusp fix) + (or + (not (eql 0 (the fixnum (logand (the fixnum (bignum-ref big 0)) fix)))) + (and (> (%bignum-length big) 1) + (not (eql 0 (the fixnum (logand (the fixnum (bignum-ref big 1)) + (the fixnum (ash fix -32)))))))) + t))) + + +(defun bignum-logcount (bignum) + (declare (type bignum-type bignum)) + (let* ((length (%bignum-length bignum)) + (plusp (bignum-plusp bignum)) + (result 0)) + (declare (type bignum-index length) + (fixnum result)) + (if plusp + (dotimes (index length result) + (incf result (the fixnum (%logcount bignum index)))) + (dotimes (index length result) + (incf result (the fixnum (%logcount-complement bignum index))))))) + + + +;;;; Logical operations. + +;;; NOT. +;;; + +;;; BIGNUM-LOGICAL-NOT -- Public. +;;; +(defun bignum-logical-not (a) + (declare (type bignum-type a)) + (let* ((len (%bignum-length a)) + (res (%allocate-bignum len))) + (declare (type bignum-index len)) + (dotimes (i len res) + (bignum-set res i (%lognot (the fixnum (bignum-ref a i))))))) + + + + +;;; AND. +;;; + +;;; BIGNUM-LOGICAL-AND -- Public. +;;; +(defun bignum-logical-and (a b) + (declare (type bignum-type a b)) + (let* ((len-a (%bignum-length a)) + (len-b (%bignum-length b)) + (a-plusp (bignum-plusp a)) + (b-plusp (bignum-plusp b))) + (declare (type bignum-index len-a len-b)) + (cond + ((< len-a len-b) + (if a-plusp + (logand-shorter-positive a len-a b (%allocate-bignum len-a)) + (logand-shorter-negative a len-a b len-b (%allocate-bignum len-b)))) + ((< len-b len-a) + (if b-plusp + (logand-shorter-positive b len-b a (%allocate-bignum len-b)) + (logand-shorter-negative b len-b a len-a (%allocate-bignum len-a)))) + (t (logand-shorter-positive a len-a b (%allocate-bignum len-a)))))) + +;;; LOGAND-SHORTER-POSITIVE -- Internal. +;;; +;;; This takes a shorter bignum, a and len-a, that is positive. Because this +;;; is AND, we don't care about any bits longer than a's since its infinite 0 +;;; sign bits will mask the other bits out of b. The result is len-a big. +;;; +(defun logand-shorter-positive (a len-a b res) + (declare (type bignum-type a b res) + (type bignum-index len-a)) + (dotimes (i len-a) + (setf (bignum-ref res i) + (logand (the fixnum (bignum-ref a i)) + (the fixnum (bignum-ref b i))))) + (%normalize-bignum-macro res)) + +;;; LOGAND-SHORTER-NEGATIVE -- Internal. +;;; +;;; This takes a shorter bignum, a and len-a, that is negative. Because this +;;; is AND, we just copy any bits longer than a's since its infinite 1 sign +;;; bits will include any bits from b. The result is len-b big. +;;; +(defun logand-shorter-negative (a len-a b len-b res) + (declare (type bignum-type a b res) + (type bignum-index len-a len-b)) + (dotimes (i len-a) + (setf (bignum-ref res i) + (logand (the fixnum (bignum-ref a i)) + (the fixnum (bignum-ref b i))))) + (bignum-replace res b :start1 len-a :start2 len-a :end1 len-b :end2 len-b) + (%normalize-bignum-macro res)) + + + +;;; +;;; +;;; bignum-logandc2 + +(defun bignum-logandc2 (a b) + (declare (type bignum-type a b)) + (let* ((len-a (%bignum-length a)) + (len-b (%bignum-length b)) + (a-plusp (bignum-plusp a)) + (b-plusp (bignum-plusp b))) + (declare (type bignum-index len-a len-b)) + (cond + ((< len-a len-b) + (logandc2-shorter-any a len-a b len-b (if a-plusp (%allocate-bignum len-a) (%allocate-bignum len-b)))) + ((< len-b len-a) ; b shorter + (logandc1-shorter-any b len-b a len-a (if b-plusp (%allocate-bignum len-a)(%allocate-bignum len-b)))) + (t (logandc2-shorter-any a len-a b len-b (%allocate-bignum len-a)))))) + +(defun logandc2-shorter-any (a len-a b len-b res) + (declare (type bignum-type a b res) + (type bignum-index len-a len-b)) + (dotimes (i len-a) + (setf (bignum-ref res i) + (logand (the fixnum (bignum-ref a i)) + (the fixnum (%lognot (the fixnum (bignum-ref b i))))))) + (if (bignum-minusp a) + (do ((i len-a (1+ i))) + ((= i len-b)) + (declare (type bignum-index i)) + (setf (bignum-ref res i) + (%lognot (the fixnum (bignum-ref b i)))))) + (%normalize-bignum-macro res)) + + + +(defun logandc1-shorter-any (a len-a b len-b res) + (declare (type bignum-type a b res) + (type bignum-index len-a len-b)) + (dotimes (i len-a) + (setf (bignum-ref res i) + (logand + (the fixnum (%lognot (the fixnum (bignum-ref a i)))) + (the fixnum (bignum-ref b i))))) + (when (bignum-plusp a) + (unless (= len-a len-b) + (bignum-replace res b :start1 len-a :start2 len-a :end1 len-b :end2 len-b))) + (%normalize-bignum-macro res)) + + + +(defun fix-big-logand (fix big) + (let* ((len-b (%bignum-length big)) + (res (if (< fix 0)(%allocate-bignum len-b)))) + (declare (fixnum fix len-b)) + (let ((val (fix-digit-logand fix big res))) + (if res + (progn + (bignum-replace res big :start1 2 :start2 2 :end1 len-b :end2 len-b) + (%normalize-bignum-macro res)) + val)))) + + +(defun fix-big-logandc2 (fix big) + (let* ((len-b (%bignum-length big)) + (res (if (< fix 0)(%allocate-bignum len-b)))) + (declare (fixnum fix len-b)) + (let ((val (fix-digit-logandc2 fix big res))) + (if res + (progn + (do ((i 2 (1+ i))) + ((= i len-b)) + (declare (type bignum-index i)) + (setf (bignum-ref res i) + (%lognot (bignum-ref big i)))) + (%normalize-bignum-macro res)) + val)))) + +(defun fix-big-logandc1 (fix big) + (let* ((len-b (%bignum-length big)) + (res (if (>= fix 0)(%allocate-bignum len-b)))) + (declare (fixnum fix len-b)) + (let ((val (fix-digit-logandc1 fix big res))) + (if res + (progn + (bignum-replace res big :start1 2 :start2 2 :end1 len-b :end2 len-b) + (%normalize-bignum-macro res)) + val)))) + + +;;; IOR. +;;; + +;;; BIGNUM-LOGICAL-IOR -- Public. +;;; +(defun bignum-logical-ior (a b) + (declare (type bignum-type a b)) + (let* ((len-a (%bignum-length a)) + (len-b (%bignum-length b)) + (a-plusp (bignum-plusp a)) + (b-plusp (bignum-plusp b))) + (declare (type bignum-index len-a len-b)) + (cond + ((< len-a len-b) + (if a-plusp + (logior-shorter-positive a len-a b len-b (%allocate-bignum len-b)) + (logior-shorter-negative a len-a b len-b (%allocate-bignum len-b)))) + ((< len-b len-a) + (if b-plusp + (logior-shorter-positive b len-b a len-a (%allocate-bignum len-a)) + (logior-shorter-negative b len-b a len-a (%allocate-bignum len-a)))) + (t (logior-shorter-positive a len-a b len-b (%allocate-bignum len-a)))))) + +;;; LOGIOR-SHORTER-POSITIVE -- Internal. +;;; +;;; This takes a shorter bignum, a and len-a, that is positive. Because this +;;; is IOR, we don't care about any bits longer than a's since its infinite +;;; 0 sign bits will mask the other bits out of b out to len-b. The result +;;; is len-b long. +;;; +(defun logior-shorter-positive (a len-a b len-b res) + (declare (type bignum-type a b res) + (type bignum-index len-a len-b)) + (dotimes (i len-a) + (setf (bignum-ref res i) + (logior (the fixnum (bignum-ref a i)) + (the fixnum (bignum-ref b i))))) + (if (not (eql len-a len-b)) + (bignum-replace res b :start1 len-a :start2 len-a :end1 len-b :end2 len-b)) + (%normalize-bignum-macro res)) + +;;; LOGIOR-SHORTER-NEGATIVE -- Internal. +;;; +;;; This takes a shorter bignum, a and len-a, that is negative. Because this +;;; is IOR, we just copy any bits longer than a's since its infinite 1 sign +;;; bits will include any bits from b. The result is len-b long. +;;; +(defun logior-shorter-negative (a len-a b len-b res) + (declare (type bignum-type a b res) + (type bignum-index len-a len-b)) + (dotimes (i len-a) + (setf (bignum-ref res i) + (logior (the fixnum (bignum-ref a i)) + (the fixnum (bignum-ref b i))))) + (do ((i len-a (1+ i))) + ((= i len-b)) + (declare (type bignum-index i)) + (setf (bignum-ref res i) #xffffffff)) + (%normalize-bignum-macro res)) + + + + +;;; XOR. +;;; + +;;; BIGNUM-LOGICAL-XOR -- Public. +;;; +(defun bignum-logical-xor (a b) + (declare (type bignum-type a b)) + (let ((len-a (%bignum-length a)) + (len-b (%bignum-length b))) + (declare (type bignum-index len-a len-b)) + (if (< len-a len-b) + (bignum-logical-xor-aux a len-a b len-b (%allocate-bignum len-b)) + (bignum-logical-xor-aux b len-b a len-a (%allocate-bignum len-a))))) + +;;; BIGNUM-LOGICAL-XOR-AUX -- Internal. +;;; +;;; This takes the the shorter of two bignums in a and len-a. Res is len-b +;;; long. Do the XOR. +;;; +(defun bignum-logical-xor-aux (a len-a b len-b res) + (declare (type bignum-type a b res) + (type bignum-index len-a len-b)) + (dotimes (i len-a) + (setf (bignum-ref res i) + (%logxor (the fixnum (bignum-ref a i)) + (the fixnum (bignum-ref b i))))) + (unless (= len-a len-b) + (let ((sign (if (bignum-minusp a) all-ones-digit 0))) + (declare (fixnum sign)) + (do ((i len-a (1+ i))) + ((= i len-b)) + (declare (type bignum-index i)) + (setf (bignum-ref res i) + (%logxor (bignum-ref b i) sign))))) + (%normalize-bignum-macro res)) + + + +;;;; TRUNCATE + +;;; Divide X by Y when Y is a single bignum digit. BIGNUM-TRUNCATE +;;; fixes up the quotient and remainder with respect to sign and +;;; normalization. +;;; +;;; We don't have to worry about shifting Y to make its most +;;; significant digit sufficiently large for %FLOOR to return +;;; digit-size quantities for the q-digit and r-digit. If Y is +;;; a single digit bignum, it is already large enough for +;;; %FLOOR. That is, it has some bits on pretty high in the +;;; digit. + +(defun bignum-truncate-single-digit (x len-x y) + (declare (type bignum-index len-x)) + (let ((q (%allocate-bignum len-x)) + (r 0) + (y (bignum-ref y 0))) + (declare (type bignum-element-type r y)) + (do ((i (1- len-x) (1- i))) + ((minusp i)) + (multiple-value-bind (q-digit r-digit) + (%floor r (bignum-ref x i) y) + (declare (type bignum-element-type q-digit r-digit)) + (setf (bignum-ref q i) q-digit) + (setf r r-digit))) + (let ((rem (%allocate-bignum 1))) + (setf (bignum-ref rem 0) r) + (values q rem)))) + +;;; This returns a guess for the next division step. Y1 is the +;;; highest y digit, and y2 is the second to highest y +;;; digit. The x... variables are the three highest x digits +;;; for the next division step. +;;; +;;; From Knuth, our guess is either all ones or x-i and x-i-1 +;;; divided by y1, depending on whether x-i and y1 are the +;;; same. We test this guess by determining whether guess*y2 +;;; is greater than the three high digits of x minus guess*y1 +;;; shifted left one digit: +;;; ------------------------------ +;;; | x-i | x-i-1 | x-i-2 | +;;; ------------------------------ +;;; ------------------------------ +;;; - | g*y1 high | g*y1 low | 0 | +;;; ------------------------------ +;;; ... < guess*y2 ??? +;;; If guess*y2 is greater, then we decrement our guess by one +;;; and try again. This returns a guess that is either +;;; correct or one too large. +(defun bignum-truncate-guess (y1 y2 x-i x-i-1 x-i-2) + (declare (type bignum-element-type y1 y2 x-i x-i-1 x-i-2)) + (let ((guess (if (= x-i y1) + all-ones-digit + (%floor x-i x-i-1 y1)))) + (declare (type bignum-element-type guess)) + (loop + (multiple-value-bind (high-guess*y1 low-guess*y1) + (%multiply guess y1) + (declare (type bignum-element-type low-guess*y1 + high-guess*y1)) + (multiple-value-bind (high-guess*y2 low-guess*y2) + (%multiply guess y2) + (declare (type bignum-element-type high-guess*y2 + low-guess*y2)) + (multiple-value-bind (middle-digit borrow) + (%subtract-with-borrow x-i-1 low-guess*y1 1) + (declare (type bignum-element-type middle-digit) + (fixnum borrow)) + ;; Supplying borrow of 1 means there was no + ;; borrow, and we know x-i-2 minus 0 requires + ;; no borrow. + (let ((high-digit (%subtract-with-borrow x-i + high-guess*y1 + borrow))) + (declare (type bignum-element-type high-digit)) + (if (and (= high-digit 0) + (or (> high-guess*y2 + middle-digit) + (and (= middle-digit + high-guess*y2) + (> low-guess*y2 + x-i-2)))) + (setf guess (%subtract-with-borrow guess 1 1)) + (return guess))))))))) + + +;;; This returns the amount to shift y to place a one in the +;;; second highest bit. Y must be positive. If the last digit +;;; of y is zero, then y has a one in the previous digit's +;;; sign bit, so we know it will take one less than digit-size +;;; to get a one where we want. Otherwise, we count how many +;;; right shifts it takes to get zero; subtracting this value +;;; from digit-size tells us how many high zeros there are +;;; which is one more than the shift amount sought. +;;; +;;; Note: This is exactly the same as one less than the +;;; integer-length of the last digit subtracted from the +;;; digit-size. +;;; +;;; We shift y to make it sufficiently large that doing the +;;; 2*digit-size by digit-size %FLOOR calls ensures the quotient and +;;; remainder fit in digit-size. +(defun shift-y-for-truncate (y) + (the fixnum (1- (the fixnum (%bignum-sign-bits y))))) + +;;; Stores two bignums into the truncation bignum buffers, +;;; shifting them on the way in. This assumes x and y are +;;; positive and at least two in length, and it assumes +;;; truncate-x and truncate-y are one digit longer than x and +;;; y. +(defun shift-and-store-truncate-buffers (truncate-x truncate-y x len-x y len-y shift) + (declare (type bignum-index len-x len-y) + (type (integer 0 (#.digit-size)) shift)) + (cond ((zerop shift) + (bignum-replace truncate-x x :end1 len-x) + (bignum-replace truncate-y y :end1 len-y)) + (t + (bignum-ashift-left-unaligned x 0 shift (1+ len-x) + truncate-x) + (bignum-ashift-left-unaligned y 0 shift (1+ len-y) + truncate-y)))) + +;;; Divide TRUNCATE-X by TRUNCATE-Y, returning the quotient +;;; and destructively modifying TRUNCATE-X so that it holds +;;; the remainder. +;;; +;;; LEN-X and LEN-Y tell us how much of the buffers we care about. +;;; +;;; TRUNCATE-X definitely has at least three digits, and it has one +;;; more than TRUNCATE-Y. This keeps i, i-1, i-2, and low-x-digit +;;; happy. Thanks to SHIFT-AND-STORE-TRUNCATE-BUFFERS. + +(defun do-truncate (truncate-x truncate-y len-x len-y) + (declare (type bignum-index len-x len-y)) + (let* ((len-q (- len-x len-y)) + ;; Add one for extra sign digit in case high bit is on. + (q (%allocate-bignum (1+ len-q))) + (k (1- len-q)) + (y1 (bignum-ref truncate-y (1- len-y))) + (y2 (bignum-ref truncate-y (- len-y 2))) + (i (1- len-x)) + (i-1 (1- i)) + (i-2 (1- i-1)) + (low-x-digit (- i len-y))) + (declare (type bignum-index len-q k i i-1 i-2 low-x-digit) + (type bignum-element-type y1 y2)) + (loop + (setf (bignum-ref q k) + (try-bignum-truncate-guess + truncate-x truncate-y + ;; This modifies TRUNCATE-X. Must access + ;; elements each pass. + (bignum-truncate-guess y1 y2 + (bignum-ref truncate-x i) + (bignum-ref truncate-x i-1) + (bignum-ref truncate-x i-2)) + len-y low-x-digit)) + (cond ((zerop k) (return)) + (t (decf k) + (decf low-x-digit) + (shiftf i i-1 i-2 (1- i-2))))) + q)) + +#+notyet +(defun do-truncate-no-quo (truncate-x truncate-y len-x len-y) + (declare (type bignum-index len-x len-y)) + (let* ((len-q (- len-x len-y)) + (k (1- len-q)) + (i (1- len-x)) + (low-x-digit (- i len-y))) + (declare (type bignum-index len-q k i low-x-digit)) + (loop + (let* ((guess (bignum-truncate-guess truncate-x i truncate-y (the fixnum (1- len-y))) + (try-bignum-truncate-guess guess len-y low-x-digit) + (cond ((zerop k) (return)) + (t (decf k) + (decf low-x-digit) + (setq i (1- i)))))) + nil)))) + +;;; This takes a digit guess, multiplies it by TRUNCATE-Y for a +;;; result one greater in length than LEN-Y, and subtracts this result +;;; from TRUNCATE-X. LOW-X-DIGIT is the first digit of X to start +;;; the subtraction, and we know X is long enough to subtract a LEN-Y +;;; plus one length bignum from it. Next we check the result of the +;;; subtraction, and if the high digit in X became negative, then our +;;; guess was one too big. In this case, return one less than GUESS +;;; passed in, and add one value of Y back into X to account for +;;; subtracting one too many. Knuth shows that the guess is wrong on +;;; the order of 3/b, where b is the base (2 to the digit-size power) +;;; -- pretty rarely. + +(defun try-bignum-truncate-guess (truncate-x truncate-y guess len-y low-x-digit) + (declare (type bignum-index low-x-digit len-y) + (type bignum-element-type guess)) + (let ((carry-digit 0) + (borrow 1) + (i low-x-digit)) + (declare (type bignum-element-type carry-digit) + (type bignum-index i) + (fixnum borrow)) + ;; Multiply guess and divisor, subtracting from dividend + ;; simultaneously. + (dotimes (j len-y) + (multiple-value-bind (high-digit low-digit) + (%multiply-and-add3 guess + (bignum-ref truncate-y j) + carry-digit) + (declare (type bignum-element-type high-digit low-digit)) + (setf carry-digit high-digit) + (multiple-value-bind (x temp-borrow) + (%subtract-with-borrow (bignum-ref truncate-x i) + low-digit + borrow) + (declare (type bignum-element-type x) + (fixnum temp-borrow)) + (setf (bignum-ref truncate-x i) x) + (setf borrow temp-borrow))) + (incf i)) + (setf (bignum-ref truncate-x i) + (%subtract-with-borrow (bignum-ref truncate-x i) + carry-digit borrow)) + ;; See whether guess is off by one, adding one + ;; Y back in if necessary. + (cond ((%digit-0-or-plusp (bignum-ref truncate-x i)) + guess) + (t + ;; If subtraction has negative result, add one + ;; divisor value back in. The guess was one too + ;; large in magnitude. + (let ((i low-x-digit) + (carry 0)) + (dotimes (j len-y) + (multiple-value-bind (v k) + (%add-with-carry (bignum-ref truncate-y j) + (bignum-ref truncate-x i) + carry) + (declare (type bignum-element-type v)) + (setf (bignum-ref truncate-x i) v) + (setf carry k)) + (incf i)) + (setf (bignum-ref truncate-x i) + (%add-with-carry (bignum-ref truncate-x i) + 0 carry))) + (%subtract-with-borrow guess 1 1))))) + +;;; Someone (from the original CMUCL or SPICE Lisp project, perhaps) +;;; is the "I" who implemented the original version of this. + +;;; This is the original sketch of the algorithm from which I implemented this +;;; TRUNCATE, assuming both operands are bignums. I should modify this to work +;;; with the documentation on my functions, as a general introduction. I've +;;; left this here just in case someone needs it in the future. Don't look at +;;; this unless reading the functions' comments leaves you at a loss. Remember +;;; this comes from Knuth, so the book might give you the right general +;;; overview. +;;; +;;; (truncate x y): +;;; +;;; If X's magnitude is less than Y's, then result is 0 with remainder X. +;;; +;;; Make x and y positive, copying x if it is already positive. +;;; +;;; Shift y left until there's a 1 in the 30'th bit (most significant, non-sign +;;; digit) +;;; Just do most sig digit to determine how much to shift whole number. +;;; Shift x this much too. +;;; Remember this initial shift count. +;;; +;;; Allocate q to be len-x minus len-y quantity plus 1. +;;; +;;; i = last digit of x. +;;; k = last digit of q. +;;; +;;; LOOP +;;; +;;; j = last digit of y. +;;; +;;; compute guess. +;;; if x[i] = y[j] then g = (1- (ash 1 digit-size)) +;;; else g = x[i]x[i-1]/y[j]. +;;; +;;; check guess. +;;; %UNSIGNED-MULTIPLY returns b and c defined below. +;;; a = x[i-1] - (logand (* g y[j]) #xFFFFFFFF). +;;; Use %UNSIGNED-MULTIPLY taking low-order result. +;;; b = (logand (ash (* g y[j-1]) (- digit-size)) (1- (ash 1 digit-size))). +;;; c = (logand (* g y[j-1]) (1- (ash 1 digit-size))). +;;; if a < b, okay. +;;; if a > b, guess is too high +;;; g = g - 1; go back to "check guess". +;;; if a = b and c > x[i-2], guess is too high +;;; g = g - 1; go back to "check guess". +;;; GUESS IS 32-BIT NUMBER, SO USE THING TO KEEP IN SPECIAL REGISTER +;;; SAME FOR A, B, AND C. +;;; +;;; Subtract g * y from x[i - len-y+1]..x[i]. See paper for doing this in step. +;;; If x[i] < 0, guess is screwed up. +;;; negative g, then add 1 +;;; zero or positive g, then subtract 1 +;;; AND add y back into x[len-y+1..i]. +;;; +;;; q[k] = g. +;;; i = i - 1. +;;; k = k - 1. +;;; +;;; If k>=0, goto LOOP. +;;; +;;; Now quotient is good, but remainder is not. +;;; Shift x right by saved initial left shifting count. +;;; +;;; Check quotient and remainder signs. +;;; x pos y pos --> q pos r pos +;;; x pos y neg --> q neg r pos +;;; x neg y pos --> q neg r neg +;;; x neg y neg --> q pos r neg +;;; +;;; Normalize quotient and remainder. Cons result if necessary. + + +(defun bignum-truncate (x y &optional no-rem) + (declare (type bignum-type x y)) + (DECLARE (IGNORE NO-REM)) + ;; Divide X by Y returning the quotient and remainder. In the + ;; general case, we shift Y to set up for the algorithm, and we + ;; use two buffers to save consing intermediate values. X gets + ;; destructively modified to become the remainder, and we have + ;; to shift it to account for the initial Y shift. After we + ;; multiple bind q and r, we first fix up the signs and then + ;; return the normalized results. + (let* ((x-plusp (%bignum-0-or-plusp x (%bignum-length x))) + (y-plusp (%bignum-0-or-plusp y (%bignum-length y))) + (x (if x-plusp x (negate-bignum x nil))) + (y (if y-plusp y (negate-bignum y nil))) + (len-x (%bignum-length x)) + (len-y (%bignum-length y))) + (multiple-value-bind (q r) + (cond ((< len-y 2) + (bignum-truncate-single-digit x len-x y)) + ((plusp (bignum-compare y x)) + (let ((res (%allocate-bignum len-x))) + (dotimes (i len-x) + (setf (bignum-ref res i) (bignum-ref x i))) + (values 0 res))) + (t + (let ((len-x+1 (1+ len-x))) + (with-bignum-buffers ((truncate-x len-x+1) + (truncate-y (1+ len-y))) + (let ((y-shift (shift-y-for-truncate y))) + (shift-and-store-truncate-buffers truncate-x + truncate-y + x len-x + y len-y + y-shift) + (values + (do-truncate truncate-x + truncate-y + len-x+1 + len-y) + ;; Now DO-TRUNCATE has executed, we just + ;; tidy up the remainder (in TRUNCATE-X) + ;; and return it. + (cond + ((zerop y-shift) + (let ((res (%allocate-bignum len-y))) + (declare (type bignum-type res)) + (bignum-replace res truncate-x :end2 len-y) + (%normalize-bignum-macro res))) + (t + (shift-right-unaligned + truncate-x 0 y-shift len-y + ((= j res-len-1) + (setf (bignum-ref res j) + (%ashr (bignum-ref truncate-x i) + y-shift)) + (%normalize-bignum-macro res)) + res))))))))) + (let ((quotient (cond ((eq x-plusp y-plusp) q) + ((typep q 'fixnum) (the fixnum (- q))) + (t (negate-bignum-in-place q)))) + (rem (cond (x-plusp r) + ((typep r 'fixnum) (the fixnum (- r))) + (t (negate-bignum-in-place r))))) + (values (if (typep quotient 'fixnum) + quotient + (%normalize-bignum-macro quotient)) + (if (typep rem 'fixnum) + rem + (%normalize-bignum-macro rem))))))) + +(defun bignum-truncate-by-fixnum (bignum fixnum) + (with-small-bignum-buffers ((y fixnum)) + (bignum-truncate bignum y))) + +(defun bignum-truncate-by-fixnum-no-quo (bignum fixnum) + (nth-value 1 (bignum-truncate-by-fixnum bignum fixnum))) + +;;; This may do unnecessary computation in some cases. +(defun bignum-rem (x y) + (nth-value 1 (bignum-truncate x y))) + + + + +;;;; General utilities. + +(defun %zero-trailing-sign-digits (bignum len) + (declare (fixnum len)) + (unless (<= len 1) + (do ((next (bignum-ref bignum (the fixnum (- len 2))) + (bignum-ref bignum (the fixnum (- len 2)))) + (sign (bignum-ref bignum (the fixnum (- len 1))) + next)) + ((not (zerop (the fixnum (%logxor sign (%ashr next 31)))))) + (decf len) + (setf (bignum-ref bignum len) 0) + ;; Return, unless we've already done so (having found significant + ;; digits earlier.) + (when (= len 1) + (return)))) + len) + + +(defun %normalize-bignum-2 (return-fixnum-p bignum) + (let* ((len (%bignum-length bignum)) + (newlen (%zero-trailing-sign-digits bignum len))) + (declare (fixnum len newlen)) + (unless (= len newlen) + (%set-bignum-length newlen bignum)) + (or (and return-fixnum-p + (%maybe-fixnum-from-one-or-two-digit-bignum bignum)) + bignum))) + + +;;; %MOSTLY-NORMALIZE-BIGNUM -- Internal. +;;; +;;; This drops the last digit if it is unnecessary sign information. It +;;; repeats this as needed, possibly ending with a fixnum magnitude but never +;;; returning a fixnum. +;;; + +(defun %mostly-normalize-bignum (res &optional len) + (declare (ignore len)) + (%normalize-bignum-2 nil res)) + + + + + +(defun load-byte (size position integer) + (if (and (bignump integer) + (<= size (- 63 target::fixnumshift)) + (fixnump position)) + (%ldb-fixnum-from-bignum integer size position) + (let ((mask (byte-mask size))) + (if (and (fixnump mask) (fixnump integer)(fixnump position)) + (%ilogand mask (%iasr position integer)) + (logand mask (ash integer (- position))))))) + + +#+safe-but-slow +;;; This is basically the same algorithm as the "destructive" +;;; version below; while it may be more readable, it's often +;;; slower and conses too much to be at all viable. +(defun %bignum-bignum-gcd (u v) + (setq u (abs u) v (abs v)) + (do* ((g 1 (ash g 1))) + ((or (oddp u) (oddp v)) + (do* () + ((zerop u) (* g v)) + (cond ((evenp u) (setq u (ash u -1))) + ((evenp v) (setq v (ash v -1))) + (t (let* ((temp (ash (abs (- u v)) -1))) + (if (< u v) + (setq v temp) + (setq u temp))))))) + (setq u (ash u -1) v (ash v -1)))) + + + + +#-safe-but-slow +(progn +(defun %positive-bignum-bignum-gcd (u0 v0) + (let* ((u-len (%bignum-length u0)) + (v-len (%bignum-length v0))) + (declare (fixnum u-len v-len)) + (if (or (< u-len v-len) + (and (= u-len v-len) + (< (bignum-compare u0 v0) 0))) + (psetq u0 v0 v0 u0 u-len v-len v-len u-len)) + (with-bignum-buffers ((u u-len) + (u2 u-len) + (v v-len) + (v2 v-len)) + (bignum-replace u u0) + (bignum-replace v v0) + (let* ((u-trailing-0-bits (%bignum-count-trailing-zero-bits u)) + (u-trailing-0-digits (ash u-trailing-0-bits -5)) + (v-trailing-0-bits (%bignum-count-trailing-zero-bits v)) + (v-trailing-0-digits (ash v-trailing-0-bits -5))) + (declare (fixnum u-trailing-0-bits v-trailing-0-bits)) + (unless (zerop u-trailing-0-bits) + (bignum-shift-right-loop-1 + (logand u-trailing-0-bits 31) + u2 + u + (the fixnum (1- (the fixnum (- u-len u-trailing-0-digits )))) + u-trailing-0-digits) + (rotatef u u2) + (%mostly-normalize-bignum-macro u) + (setq u-len (%bignum-length u))) + (unless (zerop v-trailing-0-bits) + (bignum-shift-right-loop-1 + (logand v-trailing-0-bits 31) + v2 + v + (the fixnum (1- (the fixnum (- v-len v-trailing-0-digits)))) + v-trailing-0-digits) + (rotatef v v2) + (%mostly-normalize-bignum-macro v) + (setq v-len (%bignum-length v))) + (let* ((shift (min u-trailing-0-bits + v-trailing-0-bits))) + (loop + (let* ((fix-u (and (<= u-len 2) + (%maybe-fixnum-from-one-or-two-digit-bignum u))) + (fix-v (and (<= v-len 2) + (%maybe-fixnum-from-one-or-two-digit-bignum v)))) + (if fix-v + (if fix-u + (return (ash (%fixnum-gcd fix-u fix-v) shift)) + (return (ash (bignum-fixnum-gcd u fix-v) shift))) + (if fix-u + (return (ash (bignum-fixnum-gcd v fix-u) shift))))) + (let* ((signum (if (> u-len v-len) + 1 + (if (< u-len v-len) + -1 + (bignum-compare u v))))) + (declare (fixnum signum)) + (case signum + (0 ; (= u v) + (if (zerop shift) + (let* ((copy (%allocate-bignum u-len))) + (bignum-replace copy u) + (return copy)) + (return (ash u shift)))) + (1 ; (> u v) + (bignum-subtract-loop u u-len v v-len u) + (%mostly-normalize-bignum-macro u) + (setq u-len (%bignum-length u)) + (setq u-trailing-0-bits + (%bignum-count-trailing-zero-bits u) + u-trailing-0-digits + (ash u-trailing-0-bits -5)) + (unless (zerop u-trailing-0-bits) + (%init-misc 0 u2) + (bignum-shift-right-loop-1 + (logand u-trailing-0-bits 31) + u2 + u + (the fixnum (1- (the fixnum (- u-len + u-trailing-0-digits)))) + u-trailing-0-digits) + (rotatef u u2) + (%mostly-normalize-bignum-macro u) + (setq u-len (%bignum-length u)))) + (t ; (> v u) + (bignum-subtract-loop v v-len u u-len v) + (%mostly-normalize-bignum-macro v) + (setq v-len (%bignum-length v)) + (setq v-trailing-0-bits + (%bignum-count-trailing-zero-bits v) + v-trailing-0-digits + (ash v-trailing-0-bits -5)) + (unless (zerop v-trailing-0-bits) + (%init-misc 0 v2) + (bignum-shift-right-loop-1 + (logand v-trailing-0-bits 31) + v2 + v + (the fixnum (1- (the fixnum (- v-len v-trailing-0-digits)))) + v-trailing-0-digits) + (rotatef v v2) + (%mostly-normalize-bignum-macro v) + (setq v-len (%bignum-length v)))))))))))) + +(defun %bignum-bignum-gcd (u v) + (with-negated-bignum-buffers u v %positive-bignum-bignum-gcd)) +) + + +(defun bignum-shift-right-loop-1 (nbits result source len idx) + (declare (type bignum-type result source) + (type (mod 32) nbits) + (type bignum-index idx len)) + (let* ((rbits (- 32 nbits))) + (declare (type (mod 33) rbits)) + (dotimes (j len) + (let* ((x (bignum-ref source idx))) + (declare (type bignum-element-type x)) + (setq x (%ilsr nbits x)) + (incf idx) + (let* ((y (bignum-ref source idx))) + (declare (type bignum-element-type y)) + (setq y (%ashl y rbits)) + (setf (bignum-ref result j) + (%logior x y))))) + (setf (bignum-ref result len) + (%ilsr nbits (bignum-ref source idx))) + idx)) + + +(defun %logcount (bignum idx) + (%ilogcount (bignum-ref bignum idx))) + +(defun %logcount-complement (bignum idx) + (- 32 (the fixnum (%ilogcount (bignum-ref bignum idx))))) + +(defun %bignum-evenp (bignum) + (not (logbitp 0 (the fixnum (bignum-ref bignum 0))))) + +(defun %bignum-oddp (bignum) + (logbitp 0 (the fixnum (bignum-ref bignum 0)))) + +(defun %ldb-fixnum-from-bignum (bignum size position) + (declare (fixnum size position)) + (let* ((low-idx (ash position -5)) + (low-bit (logand position 31)) + (hi-bit (+ low-bit size)) + (len (%bignum-length bignum)) + (minusp (bignum-minusp bignum))) + (declare (fixnum size position low-bit hi-bit low-idx len)) + (if (>= low-idx len) + (if minusp (1- (ash 1 size)) 0) + (flet ((ldb32 (digit size pos) + (declare (fixnum digit size pos)) + (logand (the fixnum (1- (ash 1 size))) + (the fixnum (ash digit (the fixnum (- pos))))))) + (let* ((low-digit (bignum-ref bignum low-idx)) + (chunk-lo (ldb32 low-digit (min size (%i- 32 low-bit)) low-bit))) + (if (< hi-bit 32) + chunk-lo + (let* ((have (- 32 low-bit)) + (remain (- size have))) + (declare (fixnum have remain)) + (setq low-idx (1+ low-idx)) + (when (> remain 32) + (setq chunk-lo + (logior (ash (if (< low-idx len) + (bignum-ref bignum low-idx) + (if minusp all-ones-digit 0)) + have) + chunk-lo)) + (incf have 32) + (decf remain 32) + (incf low-idx)) + (let* ((high-digit + (if (>= low-idx len) + (if minusp all-ones-digit 0) + (bignum-ref bignum low-idx))) + (chunk-hi (ldb32 high-digit remain 0))) + (%ilogior (ash chunk-hi have) chunk-lo))))))))) + + + +(defun bignum-negate-loop-really (big len res) + (declare (fixnum len)) + (let* ((carry 1)) + (dotimes (i len carry) + (multiple-value-bind (result-digit carry-out) + (%add-with-carry (%lognot (bignum-ref big i)) 0 carry) + (setf (bignum-ref res i) result-digit + carry carry-out))))) + +(defun bignum-negate-to-pointer (big len res) + (declare (fixnum len)) + (let* ((carry 1)) + (do* ((i 0 (1+ i)) + (j 0 (+ j 4))) + ((= i len) carry) + (declare (fixnum i)) + (multiple-value-bind (result-digit carry-out) + (%add-with-carry (%lognot (bignum-ref big i)) 0 carry) + (setf (%get-unsigned-long res j) result-digit + carry carry-out))))) + + +(defun %bignum-count-trailing-zero-bits (bignum) + (let* ((count 0)) + (dotimes (i (%bignum-length bignum)) + (let* ((digit (bignum-ref bignum i))) + (declare (type bignum-element-type digit)) + (if (zerop digit) + (incf count 32) + (progn + (dotimes (bit 32) + (declare (type (mod 32) bit)) + (if (logbitp bit digit) + (return) + (incf count))) + (return))))) + count)) + + +(defun one-bignum-factor-of-two (a) + (declare (type bignum-type a)) + (let ((len (%bignum-length a))) + (declare (fixnum len)) + (dotimes (i len) + (let* ((x (bignum-ref a i))) + (declare (fixnum x)) + (unless (zerop x) + (return (+ (ash i 5) + (dotimes (j 32) + (if (logbitp j x) + (return j)))))))))) + + +(defun %bignum-random (number state) + (let* ((ndigits (%bignum-length number)) + (sign-index (1- ndigits))) + (declare (fixnum ndigits sign-index)) + (with-bignum-buffers ((bignum ndigits)) + (dotimes (i sign-index) + (setf (bignum-ref bignum i) (%next-random-seed state))) + (setf (bignum-ref bignum sign-index) + (logand #x7fffffff (the (unsigned-byte 32) + (%next-random-seed state)))) + (let* ((result (mod bignum number))) + (if (eq result bignum) + (copy-uvector bignum) + result))))) + + + +(defun logbitp (index integer) + "Predicate returns T if bit index of integer is a 1." + (number-case index + (fixnum + (if (minusp (the fixnum index))(report-bad-arg index '(integer 0)))) + (bignum + ;; assuming bignum cant have more than most-positive-fixnum bits + ;; (2 expt 24 longs) + (if (bignum-minusp index)(report-bad-arg index '(integer 0))) + ;; should error if integer isn't + (return-from logbitp (minusp (require-type integer 'integer))))) + (number-case integer + (fixnum + (if (%i< index (- target::nbits-in-word target::fixnumshift)) + (%ilogbitp index integer) + (minusp (the fixnum integer)))) + (bignum + (let ((bidx (%iasr 5 index)) + (bbit (%ilogand index 31))) + (declare (fixnum bidx bbit)) + (if (>= bidx (%bignum-length integer)) + (bignum-minusp integer) + (logbitp bbit (bignum-ref integer bidx))))))) + +) ; #+64-bit-target Index: /branches/new-random/level-0/l0-cfm-support.lisp =================================================================== --- /branches/new-random/level-0/l0-cfm-support.lisp (revision 13309) +++ /branches/new-random/level-0/l0-cfm-support.lisp (revision 13309) @@ -0,0 +1,992 @@ +;;;-*- Mode: Lisp; Package: CCL -*- +;;; +;;; Copyright (C) 2009 Clozure Associates +;;; Copyright (C) 1994-2001 Digitool, Inc +;;; This file is part of Clozure CL. +;;; +;;; Clozure CL is licensed under the terms of the Lisp Lesser GNU Public +;;; License , known as the LLGPL and distributed with Clozure CL as the +;;; file "LICENSE". The LLGPL consists of a preamble and the LGPL, +;;; which is distributed with Clozure CL as the file "LGPL". Where these +;;; conflict, the preamble takes precedence. +;;; +;;; Clozure CL is referenced in the preamble as the "LIBRARY." +;;; +;;; The LLGPL is also available online at +;;; http://opensource.franz.com/preamble.html + + +; l0-cfm-support.lisp + +(in-package "CCL") + +#+windows-target +(progn + (defvar *windows-invalid-handle* nil) + (setq *windows-invalid-handle* (%int-to-ptr #+64-bit-target #xffffffffffffffff #+32-bit-target #xffffffff))) + + +;;; We have several different conventions for representing an +;;; "entry" (a foreign symbol address, possibly represented as +;;; something cheaper than a MACPTR.) Destructively modify +;;; ADDR so that it points to where ENTRY points. +(defun entry->addr (entry addr) + #+ppc32-target + ;; On PPC32, all function addresses have their low 2 bits clear; + ;; so do fixnums. + (%setf-macptr-to-object addr entry) + #+ppc64-target + ;; On PPC64, some addresses can use the fixnum trick. In other + ;; cases, an "entry" is just a MACPTR. + (if (typep entry 'fixnum) + (%setf-macptr-to-object addr entry) + (%setf-macptr addr entry)) + ;; On x86, an "entry" is just an integer. There might elswehere be + ;; some advantage in treating those integers as signed (they might + ;; be more likely to be fixnums, for instance), so ensure that they + ;; aren't. + #+x86-target + (%setf-macptr addr (%int-to-ptr + (if (< entry 0) + (logand entry (1- (ash 1 target::nbits-in-word))) + entry))) + #-(or ppc-target x86-target) (dbg "Fix entry->addr")) + + + + +;;; Bootstrapping. Real version is in l1-aprims. +;;; Called by expansion of with-pstrs + +(defun byte-length (string &optional script start end) + (declare (ignore script)) + (when (or start end) + (error "Don't support start or end args yet")) + (if (base-string-p string) + (length string) + (error "Don't support non base-string yet."))) + + + + +(defun external-entry-point-p (x) + (istruct-typep x 'external-entry-point)) + +;;; On both Linux and FreeBSD, RTLD_NEXT and RTLD_DEFAULT behave +;;; the same way wrt symbols defined somewhere other than the lisp +;;; kernel. On Solaris, RTLD_DEFAULT will return the address of +;;; an imported symbol's procedure linkage table entry if the symbol +;;; has a plt entry (e.g., if it happens to be referenced by the +;;; lisp kernel.) *RTLD-NEXT* is therefore a slightly better +;;; default; we've traditionaly used *RTLD-DEFAULT*. +(defvar *rtld-next*) +(defvar *rtld-default*) +(defvar *rtld-use*) +(setq *rtld-next* (%incf-ptr (%null-ptr) -1) + *rtld-default* (%int-to-ptr #+(or linux-target darwin-target windows-target) 0 + #-(or linux-target darwin-target windows-target) -2) + *rtld-use* #+solaris-target *rtld-next* #-solaris-target *rtld-default*) + +#+(or linux-target freebsd-target solaris-target) +(progn + +(defvar *dladdr-entry*) + +;;; I can't think of a reason to change this. +(defvar *dlopen-flags* nil) +(setq *dlopen-flags* (logior #$RTLD_GLOBAL #$RTLD_NOW)) +) + +(defvar *eeps* nil) + +(defvar *fvs* nil) + +(defun eeps () + (or *eeps* + (setq *eeps* (make-hash-table :test #'equal)))) + +(defun fvs () + (or *fvs* + (setq *fvs* (make-hash-table :test #'equal)))) + +(defun unload-foreign-variables (lib) + (let* ((fvs (fvs))) + (when fvs + (maphash #'(lambda (k fv) + (declare (ignore k)) + (when (eq (fv.container fv) lib) + (setf (fv.addr fv) nil))) + fvs)))) + +(defun generate-external-functions (path) + (let* ((names ())) + (maphash #'(lambda (k ignore) + (declare (ignore ignore)) + (push k names)) (eeps)) + (with-open-file (stream path + :direction :output + :if-exists :supersede + :if-does-not-exist :create) + (dolist (k names) (format stream "~&extern void * ~a();" k)) + + (format stream "~&external_function external_functions[] = {") + (dolist (k names) (format stream "~&~t{~s,~a}," k k)) + (format stream "~&~t{0,0}~&};")))) + + +(defvar *shared-libraries* nil) + +#+(or linux-target freebsd-target solaris-target) +(progn + +(defun soname-ptr-from-link-map (map) + (let* ((path (pref map :link_map.l_name))) + (if (%null-ptr-p path) + (let* ((p (malloc 1))) + (setf (%get-unsigned-byte p 0) 0) + p) + (if (eql (%get-unsigned-byte path 0) 0) + path + (with-macptrs ((dyn-strings) + (dynamic-entries (pref map :link_map.l_ld))) + (let* ((soname-offset nil)) + ;; Walk over the entries in the file's dynamic segment; the + ;; last such entry will have a tag of #$DT_NULL. Note the + ;; (loaded,on Linux; relative to link_map.l_addr on FreeBSD) + ;; address of the dynamic string table and the offset of the + ;; #$DT_SONAME string in that string table. + ;; Actually, the above isn't quite right; there seem to + ;; be cases (involving vDSO) where the address of a library's + ;; dynamic string table is expressed as an offset relative + ;; to link_map.l_addr as well. + (loop + (case #+32-bit-target (pref dynamic-entries :lf32_yn.d_tag) + #+64-bit-target (pref dynamic-entries :lf64_yn.d_tag) + (#. #$DT_NULL (return)) + (#. #$DT_SONAME + (setq soname-offset + #+32-bit-target (pref dynamic-entries + :lf32_yn.d_un.d_val) + #+64-bit-target (pref dynamic-entries + :lf64_yn.d_un.d_val))) + (#. #$DT_STRTAB + (%setf-macptr dyn-strings + ;; Try to guess whether we're dealing + ;; with a displacement or with an + ;; absolute address. There may be + ;; a better way to determine this, + ;; but for now we assume that absolute + ;; addresses aren't negative and that + ;; displacements are. + (let* ((disp (%get-signed-natural + dynamic-entries + target::node-size))) + #+(or freebsd-target solaris-target) + (%inc-ptr (pref map :link_map.l_addr) disp) + #-(or freebsd-target solaris-target) + (let* ((udisp #+32-bit-target (pref dynamic-entries + :lf32_yn.d_un.d_val) + #+64-bit-target (pref dynamic-entries + :lf64_yn.d_un.d_val))) + (if (and (> udisp (pref map :link_map.l_addr)) + (< udisp (%ptr-to-int dynamic-entries))) + (%int-to-ptr udisp) + (%int-to-ptr + (if (< disp 0) + (+ disp (pref map :link_map.l_addr)) + disp)))))))) + (%setf-macptr dynamic-entries + (%inc-ptr dynamic-entries + #+32-bit-target + (record-length :lf32_yn) + #+64-bit-target + (record-length :lf64_yn)))) + (if (and soname-offset + (not (%null-ptr-p dyn-strings))) + (%inc-ptr dyn-strings soname-offset) + ;; Use the full pathname of the library. + (pref map :link_map.l_name)))))))) + +(defun shared-library-at (base) + (dolist (lib *shared-libraries*) + (when (eql (shlib.base lib) base) + (return lib)))) + +(defun shared-library-with-name (name) + (let* ((namelen (length name))) + (dolist (lib *shared-libraries*) + (let* ((libname (shlib.soname lib))) + (when (%simple-string= name libname 0 0 namelen (length libname)) + (return lib)))))) + +(defun shlib-from-map-entry (m) + (let* ((base (%int-to-ptr (pref m :link_map.l_addr)))) + ;; On relatively modern Linux systems, this is often NULL. + ;; I'm not sure what (SELinux ? Pre-binding ? Something else ?) + ;; counts as being "relatively modern" in this case. + ;; The link-map's l_ld field is a pointer to the .so's dynamic + ;; section, and #_dladdr seems to recognize that as being an + ;; address within the library and returns a reasonable "base address". + (when (%null-ptr-p base) + (let* ((addr (%library-base-containing-address (pref m :link_map.l_ld)))) + (if addr (setq base addr)))) + (or (let* ((existing-lib (shared-library-at base))) + (when (and existing-lib (null (shlib.map existing-lib))) + (setf (shlib.map existing-lib) m + (shlib.pathname existing-lib) + (%get-cstring (pref m :link_map.l_name)) + (shlib.base existing-lib) base)) + existing-lib) + (let* ((soname-ptr (soname-ptr-from-link-map m)) + (soname (unless (%null-ptr-p soname-ptr) (%get-cstring soname-ptr))) + (pathname (%get-cstring (pref m :link_map.l_name))) + (shlib (shared-library-with-name soname))) + (if shlib + (setf (shlib.map shlib) m + (shlib.base shlib) base + (shlib.pathname shlib) pathname) + (push (setq shlib (%cons-shlib soname pathname m base)) + *shared-libraries*)) + shlib)))) + + +(defun %get-r-debug () + (let* ((addr (ff-call (%kernel-import target::kernel-import-get-r-debug) + address))) + (unless (%null-ptr-p addr) + addr))) + +(defun %link-map-address () + (let* ((r_debug (%get-r-debug))) + (if r_debug + (pref r_debug :r_debug.r_map) + (let* ((p (or (foreign-symbol-address "_dl_loaded") + (foreign-symbol-address "_rtld_global")))) + (if p + (%get-ptr p)))))) + +(defun %walk-shared-libraries (f) + (let* ((loaded (%link-map-address))) + (do* ((map (pref loaded :link_map.l_next) (pref map :link_map.l_next))) + ((%null-ptr-p map)) + (funcall f map)))) + + +(defun %dlopen-shlib (l) + (with-cstrs ((n (shlib.soname l))) + (ff-call (%kernel-import target::kernel-import-GetSharedLibrary) + :address n + :unsigned-fullword *dlopen-flags* + :void))) + +(defun init-shared-libraries () + (setq *dladdr-entry* (foreign-symbol-entry "dladdr")) + (when (null *shared-libraries*) + (%walk-shared-libraries #'shlib-from-map-entry) + ;;; On Linux, it seems to be necessary to open each of these + ;;; libraries yet again, specifying the RTLD_GLOBAL flag. + ;;; On FreeBSD, it seems desirable -not- to do that. + #+linux-target + (dolist (l *shared-libraries*) + (%dlopen-shlib l)))) + +(init-shared-libraries) + +;;; Walk over all registered entrypoints, invalidating any whose container +;;; is the specified library. Return true if any such entrypoints were +;;; found. +(defun unload-library-entrypoints (lib) + (let* ((count 0)) + (declare (fixnum count)) + (maphash #'(lambda (k eep) + (declare (ignore k)) + (when (eq (eep.container eep) lib) + (setf (eep.address eep) nil) + (incf count))) + (eeps)) + (not (zerop count)))) + + + + + +(defun open-shared-library (name) + "If the library denoted by name can be loaded by the operating system, +return an object of type SHLIB that describes the library; if the library +is already open, increment a reference count. If the library can't be +loaded, signal a SIMPLE-ERROR which contains an often-cryptic message from +the operating system." + (let* ((handle (with-cstrs ((name name)) + (ff-call + (%kernel-import target::kernel-import-GetSharedLibrary) + :address name + :unsigned-fullword *dlopen-flags* + :address))) + (link-map #-(or freebsd-target solaris-target) handle + #+(or freebsd-target solaris-target) + (if (%null-ptr-p handle) + handle + (rlet ((p :address)) + (if (eql 0 (ff-call + (foreign-symbol-entry "dlinfo") + :address handle + :int #$RTLD_DI_LINKMAP + :address p + :int)) + (pref p :address) + (%null-ptr)))))) + (if (%null-ptr-p link-map) + (error "Error opening shared library ~s: ~a" name (dlerror)) + (prog1 (let* ((lib (shlib-from-map-entry link-map))) + (incf (shlib.opencount lib)) + (setf (shlib.handle lib) handle) + lib) + (%walk-shared-libraries + #'(lambda (map) + (unless (shared-library-at + (%int-to-ptr (pref map :link_map.l_addr))) + (let* ((new (shlib-from-map-entry map))) + (%dlopen-shlib new))))))))) + +) + + +#+darwin-target +(progn + +(defun shared-library-with-header (header) + (dolist (lib *shared-libraries*) + (when (eql (shlib.map lib) header) + (return lib)))) + +(defun shared-library-with-module (module) + (dolist (lib *shared-libraries*) + (when (eql (shlib.base lib) module) + (return lib)))) + +(defun shared-library-with-name (name &optional (is-unloaded nil)) + (let* ((namelen (length name))) + (dolist (lib *shared-libraries*) + (let* ((libname (shlib.soname lib))) + (when (and (%simple-string= name libname 0 0 namelen (length libname)) + (or (not is-unloaded) (and (null (shlib.map lib)) + (null (shlib.base lib))))) + (return lib)))))) + +;;; +;;; maybe we could fix this up name to get the "real name" +;;; this is might be possible for dylibs but probably not for modules +;;; for now soname and pathname are just the name that the user passed in +;;; if the library is "discovered" later, it is the name the system gave +;;; to it -- usually a full pathname +;;; +;;; header and module are ptr types +;;; +(defun shared-library-from-header-module-or-name (header module name) + ;; first try to find the library based on its address + (let ((found-lib (if (%null-ptr-p module) + (shared-library-with-header header) + (shared-library-with-module module)))) + + (unless found-lib + ;; check if the library name is still on our list but has been unloaded + (setq found-lib (shared-library-with-name name t)) + (if found-lib + (setf (shlib.map found-lib) header + (shlib.base found-lib) module) + ;; otherwise add it to the list + (push (setq found-lib (%cons-shlib name name header module)) + *shared-libraries*))) + found-lib)) + + +(defun open-shared-library (name) + "If the library denoted by name can be loaded by the operating system, +return an object of type SHLIB that describes the library; if the library +is already open, increment a reference count. If the library can't be +loaded, signal a SIMPLE-ERROR which contains an often-cryptic message from +the operating system." + (rlet ((type :signed)) + (let ((result (with-cstrs ((cname name)) + (ff-call (%kernel-import target::kernel-import-GetSharedLibrary) + :address cname + :address type + :address)))) + (cond + ((= 1 (pref type :signed)) + ;; dylib + (shared-library-from-header-module-or-name result (%null-ptr) name)) + ((= 2 (pref type :signed)) + ;; bundle + (shared-library-from-header-module-or-name (%null-ptr) result name)) + ((= 0 (pref type :signed)) + ;; neither a dylib nor bundle was found + (error "Error opening shared library ~s: ~a" name + (%get-cstring result))) + (t (error "Unknown error opening shared library ~s." name)))))) + +;;; Walk over all registered entrypoints, invalidating any whose container +;;; is the specified library. Return true if any such entrypoints were +;;; found. +;;; +;;; SAME AS LINUX VERSION +;;; +(defun unload-library-entrypoints (lib) + (let* ((count 0)) + (declare (fixnum count)) + (maphash #'(lambda (k eep) + (declare (ignore k)) + (when (eq (eep.container eep) lib) + (setf (eep.address eep) nil) + (incf count))) + (eeps)) + (not (zerop count)))) + +;;; +;;; When restarting from a saved image +;;; +(defun reopen-user-libraries () + (dolist (lib *shared-libraries*) + (setf (shlib.map lib) nil + (shlib.base lib) nil)) + (loop + (let* ((win nil) + (lose nil)) + (dolist (lib *shared-libraries*) + (let* ((header (shlib.map lib)) + (module (shlib.base lib))) + (unless (and header module) + (rlet ((type :signed)) + (let ((result (with-cstrs ((cname (shlib.soname lib))) + (ff-call (%kernel-import target::kernel-import-GetSharedLibrary) + :address cname + :address type + :address)))) + (cond + ((= 1 (pref type :signed)) + ;; dylib + (setf (shlib.map lib) result + (shlib.base lib) (%null-ptr) + win t)) + ((= 2 (pref type :signed)) + ;; bundle + (setf (shlib.map lib) (%null-ptr) + (shlib.base lib) result + win t)) + (t + ;; neither a dylib nor bundle was found + (setq lose t)))))))) + (when (or (not lose) (not win)) (return))))) + +;;; end darwin-target + ) + +#+windows-target +(progn + (defvar *current-process-handle*) + (defvar *enum-process-modules-addr*) + (defvar *get-module-file-name-addr*) + (defvar *get-module-base-name-addr*) + (defvar *get-module-handle-ex-addr*) + + + (defun init-windows-ffi () + (%revive-macptr *windows-invalid-handle*) + (setq *current-process-handle* (ff-call (foreign-symbol-entry "GetCurrentProcess") :address)) + (setq *enum-process-modules-addr* (foreign-symbol-entry "EnumProcessModules")) + (setq *get-module-file-name-addr* (foreign-symbol-entry "GetModuleFileNameA")) + (setq *get-module-base-name-addr* (foreign-symbol-entry "GetModuleBaseNameA")) + (setq *get-module-handle-ex-addr* (foreign-symbol-entry "GetModuleHandleExA"))) + + (init-windows-ffi) + + (defun hmodule-pathname (hmodule) + (do* ((bufsize 64)) + () + (%stack-block ((name bufsize)) + (let* ((needed (ff-call *get-module-file-name-addr* + :address *current-process-handle* + :address hmodule + :address name + :signed-fullword bufsize + :signed-fullword))) + (if (eql 0 needed) + (return nil) + (if (< bufsize needed) + (setq bufsize needed) + (return (%str-from-ptr name needed)))))))) + + (defun hmodule-basename (hmodule) + (do* ((bufsize 64)) + () + (%stack-block ((name bufsize)) + (let* ((needed (ff-call *get-module-base-name-addr* + :address *current-process-handle* + :address hmodule + :address name + :signed-fullword bufsize + :signed-fullword))) + (if (eql 0 needed) + (return nil) + (if (< bufsize needed) + (setq bufsize needed) + (return (%str-from-ptr name needed)))))))) + + (defun existing-shlib-for-hmodule (hmodule) + (dolist (shlib *shared-libraries*) + (when (eql hmodule (shlib.map shlib)) (return shlib)))) + + + (defun shared-library-from-hmodule (hmodule) + (or (existing-shlib-for-hmodule hmodule) + (let* ((shlib (%cons-shlib (hmodule-basename hmodule) + (hmodule-pathname hmodule) + hmodule + hmodule))) + (push shlib *shared-libraries*) + shlib))) + + (defun for-each-loaded-module (f) + (let* ((have (* 16 (record-length #>HMODULE)))) + (rlet ((pneed #>DWORD)) + (loop + (%stack-block ((modules have)) + (ff-call *enum-process-modules-addr* + :address *current-process-handle* + :address modules + #>DWORD have + :address pneed) + (let* ((need (pref pneed #>DWORD))) + (if (> need have) + (setq have need) + (return + (do* ((i 0 (+ i (record-length #>HMODULE)))) + ((= i need)) + (funcall f (%get-ptr modules i))))))))))) + + (defun init-shared-libraries () + (for-each-loaded-module #'shared-library-from-hmodule)) + + (defun shlib-containing-entry (addr &optional name) + (with-macptrs ((p (%int-to-ptr addr))) + (shlib-containing-address p name))) + + (defun shlib-containing-address (addr &optional name) + (declare (ignore name)) + (rlet ((phmodule :address (%null-ptr))) + (let* ((found (ff-call *get-module-handle-ex-addr* + #>DWORD (logior + #$GET_MODULE_HANDLE_EX_FLAG_FROM_ADDRESS + #$GET_MODULE_HANDLE_EX_FLAG_UNCHANGED_REFCOUNT) + :address addr + :address phmodule + #>BOOL))) + (unless (eql 0 found) + (let* ((hmodule (pref phmodule :address))) + (dolist (lib *shared-libraries*) + (when (eql (shlib.map lib) hmodule) + (return lib)))))))) + + + (defun open-shared-library (name) + "If the library denoted by name can be loaded by the operating system, +return an object of type SHLIB that describes the library; if the library +is already open, increment a reference count. If the library can't be +loaded, signal a SIMPLE-ERROR which contains an often-cryptic message from +the operating system." + (let* ((hmodule (with-cstrs ((name name)) + (ff-call + (%kernel-import target::kernel-import-GetSharedLibrary) + :address name + :unsigned-fullword 0 + :address))) + (shlib (unless (%null-ptr-p hmodule) + (shared-library-from-hmodule hmodule)))) + (if shlib + (progn + (incf (shlib.opencount shlib)) + (setf (shlib.handle shlib) hmodule) + shlib) + (error "Can't open shared library ~s" name)))) + +(init-shared-libraries) + +;;; end windows-target +) + + +(defun ensure-open-shlib (c force) + (if (or (shlib.map c) (not force)) + *rtld-use* + (error "Shared library not open: ~s" (shlib.soname c)))) + +(defun resolve-container (c force) + (if c + (ensure-open-shlib c force) + *rtld-use* + )) + + + + +;;; An "entry" can be fixnum (the low 2 bits are clear) which represents +;;; a (32-bit word)-aligned address. That convention covers all +;;; function addresses on ppc32 and works for addresses that are +;;; 0 mod 8 on PPC64, but can't work for things that're byte-aligned +;;; (x8664 and other non-RISC platforms.) +;;; For PPC64, we may have to cons up a macptr if people use broken +;;; linkers. (There are usually cache advantages to aligning ppc +;;; function addresses on at least a 16-byte boundary, but some +;;; linkers don't quite get the concept ...) + +(defun foreign-symbol-entry (name &optional (handle *rtld-use*)) + "Try to resolve the address of the foreign symbol name. If successful, +return a fixnum representation of that address, else return NIL." + (with-cstrs ((n name)) + #+ppc-target + (with-macptrs (addr) + (%setf-macptr addr + (ff-call (%kernel-import target::kernel-import-FindSymbol) + :address handle + :address n + :address)) + (unless (%null-ptr-p addr) ; No function can have address 0 + (or (macptr->fixnum addr) (%inc-ptr addr 0)))) + #+x8632-target + (let* ((addr (ff-call (%kernel-import target::kernel-import-FindSymbol) + :address handle + :address n + :unsigned-fullword))) + (unless (eql 0 addr) addr)) + #+x8664-target + (let* ((addr (ff-call (%kernel-import target::kernel-import-FindSymbol) + :address handle + :address n + :unsigned-doubleword))) + (unless (eql 0 addr) addr)))) + +(defvar *statically-linked* nil) + +#+(or linux-target freebsd-target solaris-target) +(progn + +(defun %library-base-containing-address (address) + (rletZ ((info :l_info)) + (let* ((status (ff-call *dladdr-entry* + :address address + :address info :signed-fullword))) + (declare (integer status)) + (unless (zerop status) + (pref info :l_info.dli_fbase))))) + +(defun shlib-containing-address (address &optional name) + (declare (ignore name)) + (let* ((base (%library-base-containing-address address))) + (if base + (shared-library-at base)))) + + +(defun shlib-containing-entry (entry &optional name) + (unless *statically-linked* + (with-macptrs (p) + (entry->addr entry p) + (shlib-containing-address p name)))) +) + +#+darwin-target +(progn +(defvar *dyld-image-count*) +(defvar *dyld-get-image-header*) +(defvar *dyld-get-image-name*) +(defvar *nslookup-symbol-in-image*) +(defvar *nsaddress-of-symbol*) +(defvar *nsmodule-for-symbol*) +(defvar *ns-is-symbol-name-defined-in-image*) +(defvar *dladdr-entry* 0) + +(defun setup-lookup-calls () + #+notyet + (setq *dladdr-entry* (foreign-symbol-entry "_dladdr")) + (setq *dyld-image-count* (foreign-symbol-entry "__dyld_image_count")) + (setq *dyld-get-image-header* (foreign-symbol-entry "__dyld_get_image_header")) + (setq *dyld-get-image-name* (foreign-symbol-entry "__dyld_get_image_name")) + (setq *nslookup-symbol-in-image* (foreign-symbol-entry "_NSLookupSymbolInImage")) + (setq *nsaddress-of-symbol* (foreign-symbol-entry "_NSAddressOfSymbol")) + (setq *nsmodule-for-symbol* (foreign-symbol-entry "_NSModuleForSymbol")) + (setq *ns-is-symbol-name-defined-in-image* (foreign-symbol-entry "_NSIsSymbolNameDefinedInImage"))) + +(setup-lookup-calls) + +;;; +;;; given an entry address (a number) and a symbol name (lisp string) +;;; find the associated dylib or module +;;; if the dylib or module is not found in *shared-libraries* list it is added +;;; if not found in the OS list it returns nil +;;; +;;; got this error before putting in the call to +;;; NSIsObjectNameDefinedInImage dyld: /usr/local/lisp/ccl/dppccl dead +;;; lock (dyld operation attempted in a thread already doing a dyld +;;; operation) +;;; + +(defun legacy-shlib-containing-address (addr name) + (dotimes (i (ff-call *dyld-image-count* :unsigned-fullword)) + (let ((header (ff-call *dyld-get-image-header* :unsigned-fullword i :address))) + (when (and (not (%null-ptr-p header)) + (or (eql (pref header :mach_header.filetype) #$MH_DYLIB) + (eql (pref header :mach_header.filetype) #$MH_BUNDLE))) + ;; make sure the image is either a bundle or a dylib + ;; (otherwise we will crash, likely OS bug, tested OS X 10.1.5) + (with-cstrs ((cname name)) + ;; also we must check is symbol name is defined in the + ;; image otherwise in certain cases there is a crash, + ;; another likely OS bug happens in the case where a + ;; bundle imports a dylib and then we call + ;; nslookupsymbolinimage on the bundle image + (when (/= 0 + (ff-call *ns-is-symbol-name-defined-in-image* :address header + :address cname :unsigned)) + (let ((symbol (ff-call *nslookup-symbol-in-image* :address header :address cname + :unsigned-fullword #$NSLOOKUPSYMBOLINIMAGE_OPTION_RETURN_ON_ERROR + :address))) + (unless (%null-ptr-p symbol) + ;; compare the found address to the address we are looking for + (let ((foundaddr (ff-call *nsaddress-of-symbol* :address symbol :address))) + ;; (format t "Foundaddr ~s~%" foundaddr) + ;; (format t "Compare to addr ~s~%" addr) + (when (eql foundaddr addr) + (let* ((imgname (ff-call *dyld-get-image-name* :unsigned-fullword i :address)) + (libname (unless (%null-ptr-p imgname) (%get-cstring imgname))) + (libmodule (%int-to-ptr 0)) + (libheader (%int-to-ptr 0))) + (if (eql (pref header :mach_header.filetype) #$MH_BUNDLE) + (setf libmodule (ff-call *nsmodule-for-symbol* :address symbol :address)) + (setf libheader header)) + ;; make sure that this shared library is on *shared-libraries* + (return (shared-library-from-header-module-or-name libheader libmodule libname))))))))))))) + +(defun shlib-containing-address (address name) + (if (zerop *dladdr-entry*) + (legacy-shlib-containing-address address name) + ;; Bootstrapping. RLET might be clearer here. + (%stack-block ((info (record-length #>Dl_info) :clear t)) + (unless (zerop (ff-call *dladdr-entry* + :address address + :address info + :signed-fullword)) + (let* ((addr (pref info #>Dl_info.dli_fbase))) + (format t "~&name = ~s" (pref info #>Dl_info.dli_fname)) + + (dolist (lib *shared-libraries*) + (when (eql (shlib.base lib) addr) + (return lib)))))))) + +(defun shlib-containing-entry (entry &optional name) + (unless name + (error "foreign name must be non-NIL.")) + (with-macptrs (addr) + (entry->addr entry addr) + (shlib-containing-address addr name))) + +;; end Darwin progn +) + +#-(or linux-target darwin-target freebsd-target solaris-target windows-target) +(defun shlib-containing-entry (entry &optional name) + (declare (ignore entry name)) + *rtld-default*) + + +(defun resolve-eep (e &optional (require-resolution t)) + (or (eep.address e) + (let* ((name (eep.name e)) + (container (eep.container e)) + (handle (resolve-container container require-resolution)) + (addr (foreign-symbol-entry name handle))) + (if addr + (progn + (unless container + (setf (eep.container e) (shlib-containing-entry addr name))) + (setf (eep.address e) addr)) + (if require-resolution + (error "Can't resolve foreign symbol ~s" name)))))) + + + +(defun foreign-symbol-address (name &optional (map *rtld-use*)) + "Try to resolve the address of the foreign symbol name. If successful, +return that address encapsulated in a MACPTR, else returns NIL." + (with-cstrs ((n name)) + (let* ((addr (ff-call (%kernel-import target::kernel-import-FindSymbol) :address map :address n :address))) + (unless (%null-ptr-p addr) + addr)))) + +(defun resolve-foreign-variable (fv &optional (require-resolution t)) + (or (fv.addr fv) + (let* ((name (fv.name fv)) + (container (fv.container fv)) + (handle (resolve-container container require-resolution)) + (addr (foreign-symbol-address name handle))) + (if addr + (progn + (unless container + (setf (fv.container fv) (shlib-containing-address addr name))) + (setf (fv.addr fv) addr)) + (if require-resolution + (error "Can't resolve foreign symbol ~s" name)))))) + +(defun load-eep (name) + (let* ((eep (or (gethash name (eeps)) (setf (gethash name *eeps*) (%cons-external-entry-point name))))) + (resolve-eep eep nil) + eep)) + +(defun load-fv (name type) + (let* ((fv (or (gethash name (fvs)) (setf (gethash name *fvs*) (%cons-foreign-variable name type))))) + (resolve-foreign-variable fv nil) + fv)) + + + + + + +#+(or linux-target freebsd-target solaris-target) +(progn + +;;; Return the position of the last dot character in name, if that +;;; character is followed by one or more decimal digits (e.g., the +;;; start of a numeric suffix on a library name.) Return NIL if +;;; there's no such suffix. +(defun last-dot-pos (name) + (do* ((i (1- (length name)) (1- i)) + (default i) + (trailing-digits nil)) + ((<= i 0) default) + (declare (fixnum i)) + (let* ((code (%scharcode name i))) + (declare (type (mod #x110000) code)) + (if (and (>= code (char-code #\0)) + (<= code (char-code #\9))) + (setq trailing-digits t) + (if (= code (char-code #\.)) + (return (if trailing-digits i)) + (return default)))))) + +;;; It's assumed that the set of libraries that the OS has open +;;; (accessible via the _dl_loaded global variable) is a subset of +;;; the libraries on *shared-libraries*. + +(defun revive-shared-libraries () + (dolist (lib *shared-libraries*) + (setf (shlib.map lib) nil + (shlib.pathname lib) nil + (shlib.base lib) nil) + (let* ((soname (shlib.soname lib)) + (last-dot (if soname (last-dot-pos soname)))) + (when soname + (with-cstrs ((soname soname)) + (let* ((map (block found + (%walk-shared-libraries + #'(lambda (m) + (with-macptrs (libname) + (%setf-macptr libname + (soname-ptr-from-link-map m)) + (unless (%null-ptr-p libname) + (when (or (%cstrcmp soname libname) + (and last-dot + (%cnstrcmp soname libname (1+ last-dot)))) + (return-from found m))))))))) + (when map + ;;; Sigh. We can't reliably lookup symbols in the library + ;;; unless we open the library (which is, of course, + ;;; already open ...) ourselves, passing in the + ;;; #$RTLD_GLOBAL flag. + #+linux-target + (ff-call (%kernel-import target::kernel-import-GetSharedLibrary) + :address soname + :unsigned-fullword *dlopen-flags* + :void) + (setf (shlib.base lib) (%int-to-ptr (pref map :link_map.l_addr)) + (shlib.pathname lib) (%get-cstring + (pref map :link_map.l_name)) + (shlib.soname lib) (%get-cstring (soname-ptr-from-link-map map)) + (shlib.map lib) map)))))))) + +;;; Repeatedly iterate over shared libraries, trying to open those +;;; that weren't already opened by the kernel. Keep doing this until +;;; we reach stasis (no failures or no successes.) + +(defun %reopen-user-libraries () + (loop + (let* ((win nil) + (lose nil)) + (dolist (lib *shared-libraries*) + (let* ((map (shlib.map lib)) + (handle (shlib.handle lib))) + (unless map + (with-cstrs ((soname (shlib.soname lib))) + (setq handle + (ff-call + (%kernel-import target::kernel-import-GetSharedLibrary) + :address soname + :unsigned-fullword *dlopen-flags* + :address)) + #-(or freebsd-target solaris-target) (setq map handle) + #+(or freebsd-target solaris-target) + (setq map + (if (%null-ptr-p handle) + handle + (rlet ((p :address)) + (if (eql 0 (ff-call + (foreign-symbol-entry "dlinfo") + :address handle + :int #$RTLD_DI_LINKMAP + :address p + :int)) + (pref p :address) + (%null-ptr))))) + (if (%null-ptr-p map) + (setq lose t) + (setf (shlib.pathname lib) + (%get-cstring (pref map :link_map.l_name)) + (shlib.base lib) + (%int-to-ptr (pref map :link_map.l_addr)) + (shlib.map lib) map + (shlib.handle lib) handle + win t)))))) + (when (or (not lose) (not win)) (return))))) +) + + +(defun refresh-external-entrypoints () + #+linux-target + (setq *statically-linked* (not (eql 0 (%get-kernel-global 'statically-linked)))) + (%revive-macptr *rtld-next*) + (%revive-macptr *rtld-default*) + #+(or linux-target freebsd-target solaris-target) + (unless *statically-linked* + (setq *dladdr-entry* (foreign-symbol-entry "dladdr")) + (revive-shared-libraries) + (%reopen-user-libraries)) + #+darwin-target + (progn + (setup-lookup-calls) + (reopen-user-libraries)) + #+windows-target + (init-windows-ffi) + (when *eeps* + (without-interrupts + (maphash #'(lambda (k v) + (declare (ignore k)) + (setf (eep.address v) nil) + (resolve-eep v nil)) + *eeps*))) + (when *fvs* + (without-interrupts + (maphash #'(lambda (k v) + (declare (ignore k)) + (setf (fv.addr v) nil) + (resolve-foreign-variable v nil)) + *fvs*)))) + + Index: /branches/new-random/level-0/l0-complex.lisp =================================================================== --- /branches/new-random/level-0/l0-complex.lisp (revision 13309) +++ /branches/new-random/level-0/l0-complex.lisp (revision 13309) @@ -0,0 +1,34 @@ +;;;-*- Mode: Lisp; Package: CCL -*- +;;; +;;; Copyright (C) 2009 Clozure Associates +;;; Copyright (C) 1994-2001 Digitool, Inc +;;; This file is part of Clozure CL. +;;; +;;; Clozure CL is licensed under the terms of the Lisp Lesser GNU Public +;;; License , known as the LLGPL and distributed with Clozure CL as the +;;; file "LICENSE". The LLGPL consists of a preamble and the LGPL, +;;; which is distributed with Clozure CL as the file "LGPL". Where these +;;; conflict, the preamble takes precedence. +;;; +;;; Clozure CL is referenced in the preamble as the "LIBRARY." +;;; +;;; The LLGPL is also available online at +;;; http://opensource.franz.com/preamble.html + +(in-package "CCL") + +(eval-when (:compile-toplevel) + (require "NUMBER-MACROS")) + +(defun coerce-to-complex-type (num type) + (cond ((complexp num) + (let ((real (%realpart num)) + (imag (%imagpart num))) + (if (and (typep real type) + (typep imag type)) + num + (complex (coerce real type) + (coerce imag type))))) + (t (complex (coerce num type))))) + +;;; end of l0-complex.lisp Index: /branches/new-random/level-0/l0-def.lisp =================================================================== --- /branches/new-random/level-0/l0-def.lisp (revision 13309) +++ /branches/new-random/level-0/l0-def.lisp (revision 13309) @@ -0,0 +1,251 @@ +;;;-*- Mode: Lisp; Package: CCL -*- +;;; +;;; Copyright (C) 2009 Clozure Associates +;;; Copyright (C) 1994-2001 Digitool, Inc +;;; This file is part of Clozure CL. +;;; +;;; Clozure CL is licensed under the terms of the Lisp Lesser GNU Public +;;; License , known as the LLGPL and distributed with Clozure CL as the +;;; file "LICENSE". The LLGPL consists of a preamble and the LGPL, +;;; which is distributed with Clozure CL as the file "LGPL". Where these +;;; conflict, the preamble takes precedence. +;;; +;;; Clozure CL is referenced in the preamble as the "LIBRARY." +;;; +;;; The LLGPL is also available online at +;;; http://opensource.franz.com/preamble.html + +(in-package "CCL") + +;;; primitives that manipulate function & variable definitions. + + + + + +(defun functionp (arg) + "Return true if OBJECT is a FUNCTION, and NIL otherwise." + (functionp arg)) + +(defun lfunp (arg) + (functionp arg)) + +(defun %proclaim-special (sym &optional initp) + (let* ((oldbits (%symbol-bits sym))) + (declare (fixnum oldbits)) + (%symbol-bits sym (bitset $sym_vbit_special oldbits)) + initp)) + +(setq *lfun-names* (make-hash-table :test 'eq :weak t)) + +(defun lookup-lfun-name (lfun) + (gethash lfun *lfun-names*)) + + +(defun function-name (fun) + (or (and (functionp fun) (lfun-name fun)) + (if (compiled-function-p (setq fun (closure-function fun))) + (lfun-name fun)))) + + +(defun bootstrapping-fmakunbound (name) + (when (consp name) + (unless (eq (%car name) 'setf) + (error "Function spec handler not loaded yet")) + (setq name (setf-function-name (cadr name)))) + (%unfhave name) + name) + +;;; redefined in sysutils. +(%fhave 'fmakunbound #'bootstrapping-fmakunbound) + +(defun bootstrapping-fset (name fn) + (fmakunbound name) + (%fhave name fn) + fn) + +;Redefined in sysutils. +(%fhave 'fset #'bootstrapping-fset) + +(defun bootstrapping-record-source-file (fn &optional type) + (declare (ignore fn type)) + nil) + +;Redefined in l1-utils. +(%fhave 'record-source-file #'bootstrapping-record-source-file) + + +(setq *fasload-print* nil) +(setq *save-doc-strings* t) + + + +(%fhave '%defun-encapsulated-maybe ;Redefined in encapsulate + (qlfun bootstrapping-defun-encapsulated (name fn) + (declare (ignore name fn)) + nil)) + +(%fhave 'encapsulated-function-name ;Redefined in encapsulate - used in l1-io + (qlfun bootstrapping-encapsulated-function-name (fn) + (declare (ignore fn)) + nil)) + +(%fhave 'set-function-info (qlfun set-function-info (name info) + (if (typep info 'string) + (set-documentation name 'function info)) + name)) + +(defun %defun (named-fn &optional info) + (unless (typep named-fn 'function) + (dbg named-fn)) + (let* ((name (function-name named-fn))) + (unless (and name + (or (symbolp name) + (setf-function-name-p name))) + (dbg named-fn)) + (record-source-file name 'function) + (if (not (%defun-encapsulated-maybe name named-fn)) + (fset name named-fn)) + (set-function-info name info) + (when *fasload-print* (format t "~&~S~%" name)) + name)) + +(defun validate-function-name (name) + (if (symbolp name) + name + (if (setf-function-name-p name) + (setf-function-name (cadr name)) + (report-bad-arg name 'function-name)))) + +;;; There are three kinds of things which can go in the function +;;; cell of a symbol: 1) A function. 2) The thing which is the +;;; value of %unbound-function%: a 1-element vector whose 0th +;;; element is a code vector which causes an "undefined function" +;;; error to be signalled. 3) A macro or special-form definition, +;;; which is a 2-element vector whose 0th element is a code vector +;;; which signals a "can't apply macro or special form" error when +;;; executed and whose 1st element is a macro or special-operator +;;; name. It doesn't matter what type of gvector cases 2 and 3 +;;; are. Once that's decided, it wouldn't hurt if %FHAVE +;;; typechecked its second arg. + +(defun %fhave (name def) + (let* ((fname (validate-function-name name))) + (setf (%svref (symptr->symvector (%symbol->symptr fname)) target::symbol.fcell-cell) def))) + +;;; FBOUNDP is true of any symbol whose function-cell contains something other +;;; than %unbound-function%; we expect FBOUNDP to return that something. +(defun fboundp (name) + "Return true if name has a global function definition." + (let* ((fname (validate-function-name name)) + (def (%svref (symptr->symvector (%symbol->symptr fname)) target::symbol.fcell-cell))) + (unless (eq def %unbound-function%) + def))) + +;;; %UNFHAVE doesn't seem to want to deal with SETF names or function specs. +;;; Who does ? + +(defun %unfhave (sym) + (let* ((symvec (symptr->symvector (%symbol->symptr sym))) + (old (%svref symvec target::symbol.fcell-cell)) + (unbound %unbound-function%)) + (setf (%svref symvec target::symbol.fcell-cell) unbound) + (not (eq old unbound)))) + +;;; It's guaranteed that lfun-bits is a fixnum. Might be a 30-bit fixnum ... + + + + + +(defun lfun-vector-name (fun &optional (new-name nil set-name-p)) + (let* ((bits (lfun-bits fun))) + (declare (fixnum bits)) + (if (and (logbitp $lfbits-gfn-bit bits) + (not (logbitp $lfbits-method-bit bits))) + (progn + (if set-name-p + (%gf-name fun new-name) + (%gf-name fun))) + (let* ((has-name-cell (not (logbitp $lfbits-noname-bit bits)))) + (if has-name-cell + (let* ((lfv (lfun-vector fun)) + (name-idx (- (the fixnum (uvsize lfv)) 2)) + (old-name (%svref lfv name-idx))) + (declare (fixnum name-idx)) + (if (and set-name-p (not (eq old-name new-name))) + (setf (%svref lfv name-idx) new-name)) + old-name)))))) + +(defun lfun-name (fun &optional (new-name nil set-name-p)) + (multiple-value-bind (stored-name stored?) (lookup-lfun-name fun) + (unless stored? + (setq stored-name (lfun-vector-name fun))) + (when (and set-name-p (neq new-name stored-name)) + (if (and stored? (eq new-name (lfun-vector-name fun))) + (remhash fun *lfun-names*) + (if (logbitp $lfbits-noname-bit (the fixnum (lfun-bits fun))) ; no name-cell in function vector. + (puthash fun *lfun-names* new-name) + (lfun-vector-name fun new-name)))) + stored-name)) + +(defun lfun-bits (function &optional new) + (unless (functionp function) + (setq function (require-type function 'function))) + (let* ((lfv (lfun-vector function)) + (idx (1- (the fixnum (uvsize lfv)))) + (old (%svref lfv idx))) + (declare (fixnum idx)) + (if new + (setf (%svref lfv idx) new)) + old)) + +(defun %macro-have (symbol macro-function) + (declare (special %macro-code%)) ; magically set by xloader. + (%fhave symbol (vector %macro-code% macro-function))) + + +(defun special-operator-p (symbol) + "If the symbol globally names a special form, return T, otherwise NIL." + (let ((def (fboundp symbol))) + (and (typep def 'simple-vector) + (not (lfunp (svref def 1)))))) + +(defun special-form-p (x) (special-operator-p x)) + +(defun setf-function-name-p (thing) + (and (consp thing) + (consp (%cdr thing)) + (null (%cddr thing)) + (eq (%car thing) 'setf) + (symbolp (%cadr thing)))) + +(defun macro-function (form &optional env) + "If SYMBOL names a macro in ENV, returns the expansion function, + else returns NIL. If ENV is unspecified or NIL, use the global + environment only." + (setq form (require-type form 'symbol)) + (when env + ; A definition-environment isn't a lexical environment, but it can + ; be an ancestor of one. + (unless (istruct-typep env 'lexical-environment) + (report-bad-arg env 'lexical-environment)) + (let ((cell nil)) + (tagbody + top + (if (setq cell (%cdr (assq form (lexenv.functions env)))) + (return-from macro-function + (if (eq (car cell) 'macro) (%cdr cell)))) + (unless (listp (setq env (lexenv.parent-env env))) + (go top))))) + ; Not found in env, look in function cell. + (%global-macro-function form)) + +(defun %fixnum-ref-macptr (fixnum &optional (offset 0)) + (%int-to-ptr (%fixnum-ref-natural fixnum offset))) + +(defun %fixnum-set-macptr (fixnum offset &optional (newval offset newval-p)) + (%fixnum-set-natural fixnum (if newval-p offset 0) (%ptr-to-int newval)) + newval) + +;;; end of l0-def.lisp Index: /branches/new-random/level-0/l0-error.lisp =================================================================== --- /branches/new-random/level-0/l0-error.lisp (revision 13309) +++ /branches/new-random/level-0/l0-error.lisp (revision 13309) @@ -0,0 +1,141 @@ +;;; +;;; Copyright (C) 2009 Clozure Associates +;;; Copyright (C) 1994-2001 Digitool, Inc +;;; This file is part of Clozure CL. +;;; +;;; Clozure CL is licensed under the terms of the Lisp Lesser GNU Public +;;; License , known as the LLGPL and distributed with Clozure CL as the +;;; file "LICENSE". The LLGPL consists of a preamble and the LGPL, +;;; which is distributed with Clozure CL as the file "LGPL". Where these +;;; conflict, the preamble takes precedence. +;;; +;;; Clozure CL is referenced in the preamble as the "LIBRARY." +;;; +;;; The LLGPL is also available online at +;;; http://opensource.franz.com/preamble.html + +(in-package "CCL") + +(defparameter *error-format-strings* + '((1 . "Unbound variable: ~S .") + (2 . "Invalid reference to ~s at index ~s.") + (3 . "Too many arguments.") + (4 . "Too few arguments.") + (5 . "Argument ~S is not of the required type.") + (6 . "Undefined function: ~S .") + (7 . "Invalid assignnnt of ~s at index ~s, to ~s.") + (8 . "Can't coerce ~S to ~S") + (9 . "Funcallable instance ~S was called with args ~s, but has no FUNCALLABLE-INSTANCE-FUNCTION") + (10 . "Out of memory.") + (11 . "Default image file not found.") + (12 . "No translation for ~S") + (13 . "~S can't be FUNCALLed or APPLYed.") + (14 . "~S is not a symbol or lambda expression") + (15 . "Declaration ~S in unexpected position") + (16 . "Can't setq constant ~S") + (17 . "Odd number of forms to setq in ~S") + (18 . "Illegal arg to setq ~S") + (19 . "~S is not a symbol.") + (20 . "~S is a constant.") + (21 . "Bad initialization form: ~S") + (22 . "Symbol macro ~S is declared or proclaimed special") + (23 . "Too many arguments in ~S") + (24 . "Local macro cannot reference lexically defined variable ~S") + (25 . "Local macro cannot reference lexically defined function ~S") + (26 . "Local macro cannot reference lexically defined tag ~S") + (27 . "Local macro cannot reference lexically defined block ~S") + (28 . "Can't find tag ~S") + (29 . "Duplicate tag ~S") + (30 . "Can't find block ~S") + (31 . "Bad lambda list ~S.") + (32 . "~S is not a valid lambda expression.") + (33 . "Can't throw to tag ~S .") + (34 . "Object ~S is not of type ~S.") + (35 . "FUNCTION can't reference lexically defined macro ~S") + (36 . "Unimplemented FPU instruction ~^~S.") + (41 . "Unmatched ')'.") + (42 . "~S and ~S must be on the same volume.") + (43 . "Filename ~S contains illegal character ~S") + (44 . "Illegal use of wildcarded filename ~S") + (45 . "~S is not a FASL or TEXT file.") + (46 . "Cannot rename directory to file ~S") + (47 . "Found a directory instead of a file or vice versa ~S") + (48 . "Cannot copy directories: ~S") + (49 . "String too long for pascal record") + (50 . "Cannot create ~S") + (64 . "Floating point overflow") + (66 . "Can't divide by zero.") + (75 . "Stack overflow. Bytes requested: ~d") + (76 . "Memory allocation request failed.") + (77 . "~S exceeds array size limit of ~S bytes.") + (94. "Printer error.") + (95. "Can't load printer.") + (96. "Can't get printer parameters.") + (97. "Can't start up printer job.") + (98. "Floating point exception.") + (111 . "Unexpected end of file encountered.") + (112 . "Array index ~S out of bounds for ~S .") + (113 . "Reader error: ~S encountered.") + (114 . "Reader error: Unknown reader macro character ~S .") + (115 . "Can't redefine constant ~S .") + (116 . "Reader error: Illegal character ~S .") + (117 . "Reader error: Illegal symbol syntax.") + (118 . "Reader error: Dot context error.") + (119 . "Reader error: Bad value ~S for *READ-BASE*.") + (120 . "Can't construct argument list from ~S.") + (121 . "Wrong FASL version.") + (122 . "Not a FASL file.") + (123 . "Undefined function ~s called with arguments ~s.") + (124 . "Image file incompatible with current version of Lisp.") + (127 . "Using ~S in ~S ~%would cause name conflicts with symbols inherited by that package: ~%~:{~S ~S~%~}") + (128 . "Importing ~S to ~S would conflict with inherited symbol ~S ." ) + (129 . "Reader error: Malformed number in a #b/#o/#x/#r macro." ) + (130 . "There is no package named ~S ." ) + (131 . "Reader error: No external symbol named ~S in package ~S ." ) + (132 . "Bad FASL file: internal inconsistency detected." ) + (133 . "Importing ~S to ~S would conflict with symbol ~S ." ) + (134 . "Uninterning ~S from ~S would cause conflicts among ~S ." ) + (135 . "~S is not accessible in ~S ." ) + (136 . "Exporting ~S in ~S would cause a name conflict with ~S in ~S ." ) + (137 . "Using ~S in ~S ~%would cause name conflicts with symbols already present in that package: ~%~:{~S ~S~%~}") + (139 . "Reader macro function ~S called outside of reader." ) + (140 . "Reader error: undefined character ~S in a ~S dispatch macro." ) + (141 . "Reader dispatch macro character ~S doesn't take an argument." ) + (142 . "Reader dispatch macro character ~S requires an argument." ) + (143 . "Reader error: Bad radix in #R macro." ) + (144 . "Reader error: Duplicate #~S= label." ) + (145 . "Reader error: Missing #~S# label." ) + (146 . "Reader error: Illegal font number in #\\ macro." ) + (147 . "Unknown character name ~S in #\\ macro." ) + (148 . "~S cannot be accessed with ~S subscripts." ) + (149 . "Requested size is too large to displace to ~S ." ) + (150 . "Too many elements in argument list ~S ." ) + (151 . "Arrays are not of the same size" ) + (152 . "Conflicting keyword arguments : ~S ~S, ~S ~S .") + (153 . "Incorrect keyword arguments in ~S .") + (154 . "Two few arguments in form ~S .") + (155 . "Too many arguments in form ~S .") + (157 . "value ~S is not of the expected type ~S.") + (158 . "~S is not a structure.") + (159 . "Access to slot ~S of structure ~S is out of bounds.") + (160 . "Form ~S does not match lambda list ~A .") + (161 . "Temporary number space exhausted.") + (163 . "Illegal #+/- expression ~S.") + (164 . "File ~S does not exist.") + (165 . "~S argument ~S is not of the required type.") + (166 . "~S argument ~S is not of type ~S.") + (167 . "Too many arguments in ~S.") + (168 . "Too few arguments in ~S.") + (169 . "Arguments don't match lambda list in ~S.") + (170 . "~S is not a proper list.") + (171 . "~S is not an array with a fill pointer.") + (172 . "~S is not an adjustable array.") + (173 . "Can't access component ~D of ~S.") + (174 . "~S doesn't match array element type of ~S.") + (175 . "Stack group ~S is exhausted.") + (176 . "Stack group ~S called with arguments ~:S; exactly 1 argument accepted.") + (177 . "Attempt to return too many values.") + (178 . "Can't dynamically bind ~S. ") + (200 . "Foreign exception: ~S. "))) + + Index: /branches/new-random/level-0/l0-float.lisp =================================================================== --- /branches/new-random/level-0/l0-float.lisp (revision 13309) +++ /branches/new-random/level-0/l0-float.lisp (revision 13309) @@ -0,0 +1,1062 @@ +;;; -*- Mode: Lisp; Package: CCL -*- +;;; +;;; Copyright (C) 2009 Clozure Associates +;;; Copyright (C) 1994-2001 Digitool, Inc +;;; This file is part of Clozure CL. +;;; +;;; Clozure CL is licensed under the terms of the Lisp Lesser GNU Public +;;; License , known as the LLGPL and distributed with Clozure CL as the +;;; file "LICENSE". The LLGPL consists of a preamble and the LGPL, +;;; which is distributed with Clozure CL as the file "LGPL". Where these +;;; conflict, the preamble takes precedence. +;;; +;;; Clozure CL is referenced in the preamble as the "LIBRARY." +;;; +;;; The LLGPL is also available online at +;;; http://opensource.franz.com/preamble.html +;;; +;;; level-0;l0-float.lisp + +(in-package "CCL") + +(eval-when (:compile-toplevel :execute) + (require "NUMBER-MACROS") + (require :number-case-macro) +) + +;;; used by float reader +(defun make-float-from-fixnums (hi lo exp sign &optional result) + ;;(require-null-or-double-float-sym result) + ;; maybe nuke all these require-types? + ;;(setq hi (require-type hi 'fixnum)) + ;;(setq lo (require-type lo 'fixnum)) + ;;(setq exp (require-type exp 'fixnum)) + ;;(setq sign (require-type sign 'fixnum)) + (let ((the-float (or result (%make-dfloat)))) + (%make-float-from-fixnums the-float hi lo exp sign) + the-float)) + + +#+32-bit-target +(defun make-short-float-from-fixnums (significand biased-exp sign &optional result) + (%make-short-float-from-fixnums (or result (%make-sfloat)) significand biased-exp sign)) + +#+64-bit-target +(defun make-short-float-from-fixnums (significand biased-exp sign) + (declare (fixnum significand biased-exp sign)) + (host-single-float-from-unsigned-byte-32 + (logior + (the fixnum (if (< sign 0) (ash 1 31) 0)) + (the fixnum (ash biased-exp IEEE-single-float-exponent-offset)) + (the fixnum (logand significand + (1- (ash 1 IEEE-single-float-hidden-bit))))))) + + +(defun float-sign (n1 &optional n2) ; second arg silly + "Return a floating-point number that has the same sign as + FLOAT1 and, if FLOAT2 is given, has the same absolute value + as FLOAT2." + (if (and n2 (not (typep n2 'float))) + (setq n2 (require-type n2 'float))) + (number-case n1 + (double-float + (if (%double-float-sign n1) + (if n2 + (if (if (typep n2 'double-float) (%double-float-minusp n2) (%short-float-minusp n2)) n2 (- n2)) + -1.0d0) + (if n2 + (if (if (typep n2 'double-float) (%double-float-minusp n2) (%short-float-minusp n2)) (- n2) n2) + 1.0d0))) + (short-float + (if (%short-float-sign n1) + (if n2 + (if (if (typep n2 'double-float) (%double-float-minusp n2) (%short-float-minusp n2)) n2 (- n2)) + -1.0s0) + (if n2 + (if (if (typep n2 'double-float) (%double-float-minusp n2) (%short-float-minusp n2)) (- n2) n2) + 1.0s0))))) + + + +(defun %double-float-minusp (n) + (and (%double-float-sign n)(not (%double-float-zerop n)))) + +(defun %short-float-minusp (n) + (and (%short-float-sign n) (not (%short-float-zerop n)))) + +(defun %double-float-abs (n) + (if (not (%double-float-sign n)) + n + (%%double-float-abs! n (%make-dfloat)))) + +#+32-bit-target +(defun %short-float-abs (n) + (if (not (%short-float-sign n)) + n + (%%short-float-abs! n (%make-sfloat)))) + +(defun fixnum-decode-float (n) + (etypecase n + (double-float (%integer-decode-double-float n)))) + +(defun nan-or-infinity-p (n) + (etypecase n + (double-float (eq 2047 (%double-float-exp n))) + (short-float (eq 255 (%short-float-exp n))))) + +; not sure this is right +(defun infinity-p (n) + (etypecase n + (double-float (multiple-value-bind (hi lo exp)(fixnum-decode-float n) + (and (eq 2047 exp) + (eq #x1000000 hi) + (eq 0 lo)))) + (short-float + #+32-bit-target + (multiple-value-bind (high low)(%sfloat-hwords n) + (let* ((mantissa (%ilogior2 low (%ilsl 16 (%ilogand2 high #x007F)))) + (exp (%ilsr 7 (%ilogand2 high #x7F80)))) + (and (eq exp 255) + (eq 0 mantissa)))) + #+64-bit-target + (let* ((bits (single-float-bits n)) + (exp (ldb (byte IEEE-single-float-exponent-width + IEEE-single-float-exponent-offset) + bits)) + (mantissa (ldb (byte IEEE-single-float-mantissa-width + IEEE-single-float-mantissa-offset) + bits))) + (declare (fixnum bits exp mantissa)) + (and (= exp 255) + (zerop mantissa)))))) + +#+32-bit-target +(defun fixnum-decode-short-float (float) + (multiple-value-bind (high low)(%sfloat-hwords float) + (let* ((mantissa (%ilogior2 low (%ilsl 16 (%ilogand2 high #x007F)))) + (exp (%ilsr 7 (%ilogand2 high #x7F80)))) + (if (and (neq exp 0)(neq exp 255))(setq mantissa (%ilogior mantissa #x800000))) + (values mantissa exp (%ilsr 15 high))))) + +#+64-bit-target +(defun fixnum-decode-short-float (float) + (let* ((bits (single-float-bits float))) + (declare (fixnum bits)) + (let* ((mantissa (ldb (byte IEEE-single-float-mantissa-width + IEEE-single-float-mantissa-offset) + bits)) + (exp (ldb (byte IEEE-single-float-exponent-width + IEEE-single-float-exponent-offset) + bits)) + (sign (lsh bits -31))) + (declare (fixnum mantissa exp sign)) + (unless (or (= exp 0) (= exp 255)) + (setq mantissa (logior mantissa (ash 1 IEEE-single-float-hidden-bit)))) + (values mantissa exp sign)))) + + + +#+32-bit-target +(defun integer-decode-double-float (n) + (multiple-value-bind (hi lo exp sign)(%integer-decode-double-float n) + ; is only 53 bits and positive so should be easy + ;(values (logior (ash hi 28) lo) exp sign))) + ; if denormalized, may fit in a fixnum + (setq exp (- exp (if (< hi #x1000000) + (+ IEEE-double-float-mantissa-width IEEE-double-float-bias) + (+ IEEE-double-float-mantissa-width (1+ IEEE-double-float-bias))))) + (if (< hi (ash 1 (1- target::fixnumshift))) ; aka 2 + (values (logior (ash hi 28) lo) exp sign) + ; might fit in 1 word? + (let ((big (%alloc-misc 2 target::subtag-bignum))) + (make-big-53 hi lo big) + (if (< hi #x1000000) (%normalize-bignum big)) + (values big exp sign))))) + +#+64-bit-target +(defun integer-decode-double-float (n) + (multiple-value-bind (hi lo exp sign)(%integer-decode-double-float n) + (setq exp (- exp (if (< hi #x1000000) + (+ IEEE-double-float-mantissa-width IEEE-double-float-bias) + (+ IEEE-double-float-mantissa-width (1+ IEEE-double-float-bias))))) + (values (logior (ash hi 28) lo) exp sign))) + + +;;; actually only called when magnitude bigger than a fixnum +#+32-bit-target +(defun %truncate-double-float (n) + (multiple-value-bind (hi lo exp sign)(%integer-decode-double-float n) + (if (< exp (1+ IEEE-double-float-bias)) ; this is false in practice + 0 + (progn + (setq exp (- exp (+ IEEE-double-float-mantissa-width (1+ IEEE-double-float-bias)))) + (if (eq sign 1) ; positive + (logior (ash hi (+ 28 exp))(ash lo exp)) + (if (<= exp 0) ; exp positive - negate before shift - else after + (let ((poo (logior (ash hi (+ 28 exp))(ash lo exp)))) + (- poo)) + (let ((poo (logior (ash hi 28) lo))) + (ash (- poo) exp)))))))) + +#+64-bit-target +(defun %truncate-double-float (n) + (multiple-value-bind (mantissa exp sign) (integer-decode-float n) + (* sign (ash mantissa exp)))) + + + +; actually only called when bigger than a fixnum +(defun %truncate-short-float (n) + (multiple-value-bind (mantissa exp sign)(fixnum-decode-short-float n) + (if (< exp (1+ IEEE-single-float-bias)) ; is magnitude less than 1 - false in practice + 0 + (progn + (setq exp (- exp (+ IEEE-single-float-mantissa-width (1+ IEEE-single-float-bias)))) + (ash (if (eq sign 0) mantissa (- mantissa)) exp))))) + +(defun decode-float (n) + "Return three values: + 1) a floating-point number representing the significand. This is always + between 0.5 (inclusive) and 1.0 (exclusive). + 2) an integer representing the exponent. + 3) -1.0 or 1.0 (i.e. the sign of the argument.)" + (number-case n + (double-float + (let* ((old-exp (%double-float-exp n)) + (sign (if (%double-float-sign n) -1.0d0 1.0d0))) + (if (eq 0 old-exp) + (if (%double-float-zerop n) + (values 0.0d0 0 sign) + (let* ((val (%make-dfloat)) + (zeros (dfloat-significand-zeros n))) + (%%double-float-abs! n val) + (%%scale-dfloat! val (+ 2 IEEE-double-float-bias zeros) val) ; get it normalized + (set-%double-float-exp val IEEE-double-float-bias) ; then bash exponent + (values val (- old-exp zeros IEEE-double-float-bias) sign))) + (if (> old-exp IEEE-double-float-normal-exponent-max) + (error "Can't decode NAN or infinity ~s" n) + (let ((val (%make-dfloat))) + (%%double-float-abs! n val) + (set-%double-float-exp val IEEE-double-float-bias) + (values val (- old-exp IEEE-double-float-bias) sign)))))) + (short-float + (let* ((old-exp (%short-float-exp n)) + (sign (if (%short-float-sign n) -1.0s0 1.0s0))) + (if (eq 0 old-exp) + (if (%short-float-zerop n) + (values 0.0s0 0 sign) + #+32-bit-target + (let* ((val (%make-sfloat)) + (zeros (sfloat-significand-zeros n))) + (%%short-float-abs! n val) + (%%scale-sfloat! val (+ 2 IEEE-single-float-bias zeros) val) ; get it normalized + (set-%short-float-exp val IEEE-single-float-bias) ; then bash exponent + (values val (- old-exp zeros IEEE-single-float-bias) sign)) + #+64-bit-target + (let* ((zeros (sfloat-significand-zeros n)) + (val (%%scale-sfloat (%short-float-abs n) + (+ 2 IEEE-single-float-bias zeros)))) + (values (set-%short-float-exp val IEEE-single-float-bias) + (- old-exp zeros IEEE-single-float-bias) sign))) + (if (> old-exp IEEE-single-float-normal-exponent-max) + (error "Can't decode NAN or infinity ~s" n) + #+32-bit-target + (let ((val (%make-sfloat))) + (%%short-float-abs! n val) + (set-%short-float-exp val IEEE-single-float-bias) + (values val (- old-exp IEEE-single-float-bias) sign)) + #+64-bit-target + (values (set-%short-float-exp (%short-float-abs n) + IEEE-single-float-bias) + (- old-exp IEEE-single-float-bias) sign))))))) + +; (* float (expt 2 int)) +(defun scale-float (float int) + "Return the value (* f (expt (float 2 f) ex)), but with no unnecessary loss + of precision or overflow." + (unless (fixnump int)(setq int (require-type int 'fixnum))) + (number-case float + (double-float + (let* ((float-exp (%double-float-exp float)) + (new-exp (+ float-exp int))) + (if (eq 0 float-exp) ; already denormalized? + (if (%double-float-zerop float) + float + (let ((result (%make-dfloat))) + (%%scale-dfloat! float (+ (1+ IEEE-double-float-bias) int) result))) + (if (<= new-exp 0) ; maybe going denormalized + (if (<= new-exp (- IEEE-double-float-digits)) + 0.0d0 ; should this be underflow? - should just be normal and result is fn of current fpu-mode + ;(error "Can't scale ~s by ~s." float int) ; should signal something + (let ((result (%make-dfloat))) + (%copy-double-float float result) + (set-%double-float-exp result 1) ; scale by float-exp -1 + (%%scale-dfloat! result (+ IEEE-double-float-bias (+ float-exp int)) result) + result)) + (if (> new-exp IEEE-double-float-normal-exponent-max) + (error (make-condition 'floating-point-overflow + :operation 'scale-float + :operands (list float int))) + (let ((new-float (%make-dfloat))) + (%copy-double-float float new-float) + (set-%double-float-exp new-float new-exp) + new-float)))))) + (short-float + (let* ((float-exp (%short-float-exp float)) + (new-exp (+ float-exp int))) + (if (eq 0 float-exp) ; already denormalized? + (if (%short-float-zerop float) + float + #+32-bit-target + (let ((result (%make-sfloat))) + (%%scale-sfloat! float (+ (1+ IEEE-single-float-bias) int) result)) + #+64-bit-target + (%%scale-sfloat float (+ (1+ IEEE-single-float-bias) int))) + (if (<= new-exp 0) ; maybe going denormalized + (if (<= new-exp (- IEEE-single-float-digits)) + ;; should this be underflow? - should just be normal and + ;; result is fn of current fpu-mode (error "Can't scale + ;; ~s by ~s." float int) ; should signal something + 0.0s0 + #+32-bit-target + (let ((result (%make-sfloat))) + (%copy-short-float float result) + (set-%short-float-exp result 1) ; scale by float-exp -1 + (%%scale-sfloat! result (+ IEEE-single-float-bias (+ float-exp int)) result) + result) + #+64-bit-target + (%%scale-sfloat (set-%short-float-exp float 1) + (+ IEEE-single-float-bias (+ float-exp int)))) + (if (> new-exp IEEE-single-float-normal-exponent-max) + (error (make-condition 'floating-point-overflow + :operation 'scale-float + :operands (list float int))) + #+32-bit-target + (let ((new-float (%make-sfloat))) + (%copy-short-float float new-float) + (set-%short-float-exp new-float new-exp) + new-float) + #+64-bit-target + (set-%short-float-exp float new-exp)))))))) + +(defun %copy-float (f) + ;Returns a freshly consed float. float can also be a macptr. + (cond ((double-float-p f) (%copy-double-float f (%make-dfloat))) + ((macptrp f) + (let ((float (%make-dfloat))) + (%copy-ptr-to-ivector f 0 float (* 4 target::double-float.value-cell) 8) + float)) + (t (error "Illegal arg ~s to %copy-float" f)))) + +(defun float-precision (float) ; not used - not in cltl2 index ? + "Return a non-negative number of significant digits in its float argument. + Will be less than FLOAT-DIGITS if denormalized or zero." + (number-case float + (double-float + (if (eq 0 (%double-float-exp float)) + (if (not (%double-float-zerop float)) + ; denormalized + (- IEEE-double-float-mantissa-width (dfloat-significand-zeros float)) + 0) + IEEE-double-float-digits)) + (short-float + (if (eq 0 (%short-float-exp float)) + (if (not (%short-float-zerop float)) + ; denormalized + (- IEEE-single-float-mantissa-width (sfloat-significand-zeros float)) + 0) + IEEE-single-float-digits)))) + + +(defun %double-float (number &optional result) + ;(require-null-or-double-float-sym result) + ; use number-case when macro is common + (number-case number + (double-float + (if result + (%copy-double-float number result) + number)) + (short-float + (%short-float->double-float number (or result (%make-dfloat)))) + (fixnum + (%fixnum-dfloat number (or result (%make-dfloat)))) + (bignum (%bignum-dfloat number result)) + (ratio + (if (not result)(setq result (%make-dfloat))) + (let* ((num (%numerator number)) + (den (%denominator number))) + ; dont error if result is floatable when either top or bottom is not. + ; maybe do usual first, catching error + (if (not (or (bignump num)(bignump den))) + (with-stack-double-floats ((fnum num) + (fden den)) + (%double-float/-2! fnum fden result)) + (let* ((numlen (integer-length num)) + (denlen (integer-length den)) + (exp (- numlen denlen)) + (minusp (minusp num))) + (if (and (<= numlen IEEE-double-float-bias) + (<= denlen IEEE-double-float-bias) + #|(not (minusp exp))|# + (<= (abs exp) IEEE-double-float-mantissa-width)) + (with-stack-double-floats ((fnum num) + (fden den)) + + (%double-float/-2! fnum fden result)) + (if (> exp IEEE-double-float-mantissa-width) + (progn (%double-float (round num den) result)) + (if (>= exp 0) + ; exp between 0 and 53 and nums big + (let* ((shift (- IEEE-double-float-digits exp)) + (num (if minusp (- num) num)) + (int (round (ash num shift) den)) ; gaak + (intlen (integer-length int)) + (new-exp (+ intlen (- IEEE-double-float-bias shift)))) + + (when (> intlen IEEE-double-float-digits) + (setq shift (1- shift)) + (setq int (round (ash num shift) den)) + (setq intlen (integer-length int)) + (setq new-exp (+ intlen (- IEEE-double-float-bias shift)))) + (when (> new-exp 2046) + (error (make-condition 'floating-point-overflow + :operation 'double-float + :operands (list number)))) + (make-float-from-fixnums (ldb (byte 25 (- intlen 25)) int) + (ldb (byte 28 (max (- intlen 53) 0)) int) + new-exp ;(+ intlen (- IEEE-double-float-bias 53)) + (if minusp -1 1) + result)) + ; den > num - exp negative + (progn + (float-rat-neg-exp num den (if minusp -1 1) result))))))))))) + + +#+32-bit-target +(defun %short-float-ratio (number &optional result) + (if (not result)(setq result (%make-sfloat))) + (let* ((num (%numerator number)) + (den (%denominator number))) + ;; dont error if result is floatable when either top or bottom is + ;; not. maybe do usual first, catching error + (if (not (or (bignump num)(bignump den))) + (target::with-stack-short-floats ((fnum num) + (fden den)) + (%short-float/-2! fnum fden result)) + (let* ((numlen (integer-length num)) + (denlen (integer-length den)) + (exp (- numlen denlen)) + (minusp (minusp num))) + (if (and (<= numlen IEEE-single-float-bias) + (<= denlen IEEE-single-float-bias) + #|(not (minusp exp))|# + (<= (abs exp) IEEE-single-float-mantissa-width)) + (target::with-stack-short-floats ((fnum num) + (fden den)) + (%short-float/-2! fnum fden result)) + (if (> exp IEEE-single-float-mantissa-width) + (progn (%short-float (round num den) result)) + (if (>= exp 0) + ; exp between 0 and 23 and nums big + (let* ((shift (- IEEE-single-float-digits exp)) + (num (if minusp (- num) num)) + (int (round (ash num shift) den)) ; gaak + (intlen (integer-length int)) + (new-exp (+ intlen (- IEEE-single-float-bias shift)))) + (when (> intlen IEEE-single-float-digits) + (setq shift (1- shift)) + (setq int (round (ash num shift) den)) + (setq intlen (integer-length int)) + (setq new-exp (+ intlen (- IEEE-single-float-bias shift)))) + (when (> new-exp IEEE-single-float-normal-exponent-max) + (error (make-condition 'floating-point-overflow + :operation 'short-float + :operands (list number)))) + (make-short-float-from-fixnums + (ldb (byte IEEE-single-float-digits (- intlen IEEE-single-float-digits)) int) + new-exp + (if minusp -1 1) + result)) + ; den > num - exp negative + (progn + (float-rat-neg-exp num den (if minusp -1 1) result t))))))))) + +#+64-bit-target +(defun %short-float-ratio (number) + (let* ((num (%numerator number)) + (den (%denominator number))) + ;; dont error if result is floatable when either top or bottom is + ;; not. maybe do usual first, catching error + (if (not (or (bignump num)(bignump den))) + (/ (the short-float (%short-float num)) + (the short-float (%short-float den))) + (let* ((numlen (integer-length num)) + (denlen (integer-length den)) + (exp (- numlen denlen)) + (minusp (minusp num))) + (if (and (<= numlen IEEE-single-float-bias) + (<= denlen IEEE-single-float-bias) + #|(not (minusp exp))|# + (<= (abs exp) IEEE-single-float-mantissa-width)) + (/ (the short-float (%short-float num)) + (the short-float (%short-float den))) + (if (> exp IEEE-single-float-mantissa-width) + (progn (%short-float (round num den))) + (if (>= exp 0) + ; exp between 0 and 23 and nums big + (let* ((shift (- IEEE-single-float-digits exp)) + (num (if minusp (- num) num)) + (int (round (ash num shift) den)) ; gaak + (intlen (integer-length int)) + (new-exp (+ intlen (- IEEE-single-float-bias shift)))) + (when (> intlen IEEE-single-float-digits) + (setq shift (1- shift)) + (setq int (round (ash num shift) den)) + (setq intlen (integer-length int)) + (setq new-exp (+ intlen (- IEEE-single-float-bias shift)))) + (when (> new-exp IEEE-single-float-normal-exponent-max) + (error (make-condition 'floating-point-overflow + :operation 'short-float + :operands (list number)))) + (make-short-float-from-fixnums + (ldb (byte IEEE-single-float-digits (- intlen IEEE-single-float-digits)) int) + new-exp + (if minusp 1 0))) + ; den > num - exp negative + (progn + (float-rat-neg-exp num den (if minusp -1 1) nil t))))))))) + + +#+32-bit-target +(defun %short-float (number &optional result) + (number-case number + (short-float + (if result (%copy-short-float number result) number)) + (double-float + (%double-float->short-float number (or result (%make-sfloat)))) + (fixnum + (%fixnum-sfloat number (or result (%make-sfloat)))) + (bignum + (%bignum-sfloat number (or result (%make-sfloat)))) + (ratio + (%short-float-ratio number result)))) + +#+64-bit-target +(defun %short-float (number) + (number-case number + (short-float number) + (double-float (%double-float->short-float number)) + (fixnum (%fixnum-sfloat number)) + (bignum (%bignum-sfloat number)) + (ratio (%short-float-ratio number)))) + + +(defun float-rat-neg-exp (integer divisor sign &optional result short) + (if (minusp sign)(setq integer (- integer))) + (let* ((integer-length (integer-length integer)) + ;; make sure we will have enough bits in the quotient + ;; (and a couple extra for rounding) + (shift-factor (+ (- (integer-length divisor) integer-length) (if short 28 60))) ; fix + (scaled-integer integer)) + (if (plusp shift-factor) + (setq scaled-integer (ash integer shift-factor)) + (setq divisor (ash divisor (- shift-factor))) ; assume div > num + ) + ;(pprint (list shift-factor scaled-integer divisor)) + (multiple-value-bind (quotient remainder)(floor scaled-integer divisor) + (unless (zerop remainder) ; whats this - tells us there's junk below + (setq quotient (logior quotient 1))) + ;; why do it return 2 values? + (values (float-and-scale-and-round sign quotient (- shift-factor) short result))))) + + + +;;; when is (negate-bignum (bignum-ashift-right big)) ; can't negate +;;; in place cause may get bigger cheaper than (negate-bignum big) - 6 +;;; 0r 8 digits ; 8 longs so win if digits > 7 or negate it on the +;;; stack + +(defun %bignum-dfloat (big &optional result) + (let* ((minusp (bignum-minusp big))) + (flet + ((doit (new-big) + (let* ((int-len (bignum-integer-length new-big))) + (when (>= int-len (- 2047 IEEE-double-float-bias)) ; args? + (error (make-condition 'floating-point-overflow + :operation 'float :operands (list big)))) + (if (> int-len 53) + (let* ((hi (ldb (byte 25 (- int-len 25)) new-big)) + (lo (ldb (byte 28 (- int-len 53)) new-big))) + ;(print (list new-big hi lo)) + (when (and (logbitp (- int-len 54) new-big) ; round bit + (or (%ilogbitp 0 lo) ; oddp + ;; or more bits below round + (%i< (one-bignum-factor-of-two new-big) (- int-len 54)))) + (if (eq lo #xfffffff) + (setq hi (1+ hi) lo 0) + (setq lo (1+ lo))) + (when (%ilogbitp 25 hi) ; got bigger + (setq int-len (1+ int-len)) + (let ((bit (%ilogbitp 0 hi))) + (setq hi (%ilsr 1 hi)) + (setq lo (%ilsr 1 lo)) + (if bit (setq lo (%ilogior #x8000000 lo)))))) + (make-float-from-fixnums hi lo (+ IEEE-double-float-bias int-len)(if minusp -1 1) result)) + (let* ((hi (ldb (byte 25 (- int-len 25)) new-big)) + (lobits (min (- int-len 25) 28)) + (lo (ldb (byte lobits (- int-len (+ lobits 25))) new-big))) + (if (< lobits 28) (setq lo (ash lo (- 28 lobits)))) + (make-float-from-fixnums hi lo (+ IEEE-double-float-bias int-len) (if minusp -1 1) result)))))) + (declare (dynamic-extent #'doit)) + (with-one-negated-bignum-buffer big doit)))) + +#+32-bit-target +(defun %bignum-sfloat (big &optional result) + (let* ((minusp (bignum-minusp big))) + (flet + ((doit (new-big) + (let* ((int-len (bignum-integer-length new-big))) + (when (>= int-len (- 255 IEEE-single-float-bias)) ; args? + (error (make-condition 'floating-point-overflow + :operation 'float :operands (list big 1.0s0)))) + (if t ;(> int-len IEEE-single-float-digits) ; always true + (let* ((lo (ldb (byte IEEE-single-float-digits (- int-len IEEE-single-float-digits)) new-big))) + (when (and (logbitp (- int-len 25) new-big) ; round bit + (or (%ilogbitp 0 lo) ; oddp + ; or more bits below round + (%i< (one-bignum-factor-of-two new-big) (- int-len 25)))) + (setq lo (1+ lo)) + (when (%ilogbitp 24 lo) ; got bigger + (setq int-len (1+ int-len)) + (setq lo (%ilsr 1 lo)))) + (make-short-float-from-fixnums lo (+ IEEE-single-float-bias int-len)(if minusp -1 1) result)) + )))) + (declare (dynamic-extent #'doit)) + (with-one-negated-bignum-buffer big doit)))) + + +#+64-bit-target +(defun %bignum-sfloat (big) + (let* ((minusp (bignum-minusp big))) + (flet + ((doit (new-big) + (let* ((int-len (bignum-integer-length new-big))) + (when (>= int-len (- 255 IEEE-single-float-bias)) ; args? + (error (make-condition 'floating-point-overflow + :operation 'float :operands (list big 1.0s0)))) + (if t ;(> int-len IEEE-single-float-digits) ; always true + (let* ((lo (ldb (byte IEEE-single-float-digits (- int-len IEEE-single-float-digits)) new-big))) + (when (and (logbitp (- int-len 25) new-big) ; round bit + (or (%ilogbitp 0 lo) ; oddp + ; or more bits below round + (%i< (one-bignum-factor-of-two new-big) (- int-len 25)))) + (setq lo (1+ lo)) + (when (%ilogbitp 24 lo) ; got bigger + (setq int-len (1+ int-len)) + (setq lo (%ilsr 1 lo)))) + (make-short-float-from-fixnums lo (+ IEEE-single-float-bias int-len)(if minusp -1 1))) + )))) + (declare (dynamic-extent #'doit)) + (with-one-negated-bignum-buffer big doit)))) + + + + +(defun %fixnum-dfloat (fix &optional result) + (if (eq 0 fix) + (if result (%copy-double-float 0.0d0 result) 0.0d0) + (progn + (when (not result)(setq result (%make-dfloat))) + ; it better return result + (%int-to-dfloat fix result)))) + + +#+32-bit-target +(defun %fixnum-sfloat (fix &optional result) + (if (eq 0 fix) + (if result (%copy-short-float 0.0s0 result) 0.0s0) + (%int-to-sfloat! fix (or result (%make-sfloat))))) + +#+64-bit-target +(defun %fixnum-sfloat (fix) + (if (eq 0 fix) + 0.0s0 + (%int-to-sfloat fix))) + +;;; Transcendental functions. +(defun sin (x) + "Return the sine of NUMBER." + (if (complexp x) + (let* ((r (realpart x)) + (i (imagpart x))) + (complex (* (sin r) (cosh i)) + (* (cos r) (sinh i)))) + (if (typep x 'double-float) + (%double-float-sin! x (%make-dfloat)) + #+32-bit-target + (target::with-stack-short-floats ((sx x)) + (%single-float-sin! sx (%make-sfloat))) + #+64-bit-target + (%single-float-sin (%short-float x))))) + +(defun cos (x) + "Return the cosine of NUMBER." + (if (complexp x) + (let* ((r (realpart x)) + (i (imagpart x))) + (complex (* (cos r) (cosh i)) + (- (* (sin r) (sinh i))))) + (if (typep x 'double-float) + (%double-float-cos! x (%make-dfloat)) + #+32-bit-target + (target::with-stack-short-floats ((sx x)) + (%single-float-cos! sx (%make-sfloat))) + #+64-bit-target + (%single-float-cos (%short-float x))))) + +(defun tan (x) + "Return the tangent of NUMBER." + (if (complexp x) + (/ (sin x) (cos x)) + (if (typep x 'double-float) + (%double-float-tan! x (%make-dfloat)) + #+32-bit-target + (target::with-stack-short-floats ((sx x)) + (%single-float-tan! sx (%make-sfloat))) + #+64-bit-target + (%single-float-tan (%short-float x)) + ))) + + + + +(defun atan (y &optional (x nil x-p)) + "Return the arc tangent of Y if X is omitted or Y/X if X is supplied." + (if x-p + (if (or (typep x 'double-float) + (typep y 'double-float)) + (with-stack-double-floats ((dy y) + (dx x)) + (%df-atan2 dy dx)) + #+32-bit-target + (target::with-stack-short-floats ((sy y) + (sx x)) + (%sf-atan2! sy sx)) + #+64-bit-target + (%sf-atan2 (%short-float y) (%short-float x))) + (if (typep y 'complex) + (let* ((iy (* (sqrt -1) y))) + (/ (- (log (+ 1 iy)) (log (- 1 iy))) + #c(0 2))) + (if (typep y 'double-float) + (%double-float-atan! y (%make-dfloat)) + #+32-bit-target + (target::with-stack-short-floats ((sy y)) + (%single-float-atan! sy (%make-sfloat))) + #+64-bit-target + (%single-float-atan (%short-float y)) + )))) + + + +(defun log (x &optional (b nil b-p)) + "Return the logarithm of NUMBER in the base BASE, which defaults to e." + (if b-p + (if (zerop b) + (if (zerop x) + (report-bad-arg x '(not (satisfies zerop) )) + (if (floatp x) (float 0.0d0 x) 0)) + (/ (log-e x) (log-e b))) + (log-e x))) + +(defun log-e (x) + (cond + ((bignump x) + (if (minusp x) + (complex (log-e (- x)) pi) + (let* ((base1 3) + (guess (floor (1- (integer-length x)) + (log base1 2))) + (guess1 (* guess (log-e base1)))) + (+ guess1 (log-e (/ x (expt base1 guess))))))) + ((and (ratiop x) + (or (> x most-positive-short-float) + (< x most-negative-short-float))) + (- (log-e (%numerator x)) (log-e (%denominator x)))) + ((typep x 'complex) + (complex (log-e (abs x)) (phase x))) + ((typep x 'double-float) + (with-stack-double-floats ((dx x)) + (if (minusp x) + (complex (%double-float-log! (%%double-float-abs! dx dx) (%make-dfloat)) pi) + (%double-float-log! dx (%make-dfloat))))) + (t + #+32-bit-target + (target::with-stack-short-floats ((sx x)) + (if (minusp x) + (complex (%single-float-log! (%%short-float-abs! sx sx) (%make-sfloat)) + #.(coerce pi 'short-float)) + (%single-float-log! sx (%make-sfloat)))) + #+64-bit-target + (if (minusp x) + (complex (%single-float-log (%short-float-abs (%short-float x))) #.(coerce pi 'single-float)) + (%single-float-log (%short-float x))) + ))) + + + +(defun exp (x) + "Return e raised to the power NUMBER." + (typecase x + (complex (* (exp (realpart x)) (cis (imagpart x)))) + (double-float (%double-float-exp! x (%make-dfloat))) + (t + #+32-bit-target + (target::with-stack-short-floats ((sx x)) + (%single-float-exp! sx (%make-sfloat))) + #+64-bit-target + (%single-float-exp (%short-float x))))) + + + +(defun expt (b e) + "Return BASE raised to the POWER." + (cond ((zerop e) (1+ (* b e))) + ((integerp e) + (if (minusp e) (/ 1 (%integer-power b (- e))) (%integer-power b e))) + ((zerop b) + (if (plusp (realpart e)) b (report-bad-arg e '(number (0) *)))) + ((and (realp b) (plusp b) (realp e)) + (if (or (typep b 'double-float) + (typep e 'double-float)) + (with-stack-double-floats ((b1 b) + (e1 e)) + (%double-float-expt! b1 e1 (%make-dfloat))) + #+32-bit-target + (target::with-stack-short-floats ((b1 b) + (e1 e)) + (%single-float-expt! b1 e1 (%make-sfloat))) + #+64-bit-target + (%single-float-expt (%short-float b) (%short-float e)) + )) + (t (exp (* e (log b)))))) + + + +(defun sqrt (x &aux a b) + "Return the square root of NUMBER." + (cond ((zerop x) x) + ((complexp x) (* (sqrt (abs x)) (cis (/ (phase x) 2)))) + ((minusp x) (complex 0 (sqrt (- x)))) + ((floatp x) + (fsqrt x)) + ((and (integerp x) (eql x (* (setq a (isqrt x)) a))) a) + ((and (ratiop x) + (let ((n (numerator x)) + d) + (and (eql n (* (setq a (isqrt n)) a)) + (eql (setq d (denominator x)) + (* (setq b (isqrt d)) b))))) + (/ a b)) + (t + #+32-bit-target + (target::with-stack-short-floats ((f1)) + (fsqrt (%short-float x f1))) + #+64-bit-target + (fsqrt (%short-float x))))) + + + +(defun asin (x) + "Return the arc sine of NUMBER." + (number-case x + (complex + (let ((sqrt-1-x (sqrt (- 1 x))) + (sqrt-1+x (sqrt (+ 1 x)))) + (complex (atan (/ (realpart x) + (realpart (* sqrt-1-x sqrt-1+x)))) + (asinh (imagpart (* (conjugate sqrt-1-x) + sqrt-1+x)))))) + (double-float + (locally (declare (type double-float x)) + (if (and (<= -1.0d0 x) + (<= x 1.0d0)) + (%double-float-asin! x (%make-dfloat)) + (let* ((temp (+ (complex -0.0d0 x) + (sqrt (- 1.0d0 (the double-float (* x x))))))) + (complex (phase temp) (- (log (abs temp)))))))) + ((short-float rational) + #+32-bit-target + (let* ((x1 (%make-sfloat))) + (declare (dynamic-extent x1)) + (if (and (realp x) + (<= -1.0s0 (setq x (%short-float x x1))) + (<= x 1.0s0)) + (%single-float-asin! x1 (%make-sfloat)) + (progn + (setq x (+ (complex (- (imagpart x)) (realpart x)) + (sqrt (- 1 (* x x))))) + (complex (phase x) (- (log (abs x))))))) + #+64-bit-target + (if (and (realp x) + (<= -1.0s0 (setq x (%short-float x))) + (<= x 1.0s0)) + (%single-float-asin x) + (progn + (setq x (+ (complex (- (imagpart x)) (realpart x)) + (sqrt (- 1 (* x x))))) + (complex (phase x) (- (log (abs x)))))) + ))) + + +(eval-when (:execute :compile-toplevel) + (defconstant double-float-half-pi (asin 1.0d0)) + (defconstant single-float-half-pi (asin 1.0f0)) +) + + + +(defun acos (x) + "Return the arc cosine of NUMBER." + (number-case x + (complex + (let ((sqrt-1+x (sqrt (+ 1 x))) + (sqrt-1-x (sqrt (- 1 x)))) + (complex (* 2 (atan (/ (realpart sqrt-1-x) + (realpart sqrt-1+x)))) + (asinh (imagpart (* (conjugate sqrt-1+x) + sqrt-1-x)))))) + + (double-float + (locally (declare (type double-float x)) + (if (and (<= -1.0d0 x) + (<= x 1.0d0)) + (%double-float-acos! x (%make-dfloat)) + (- double-float-half-pi (asin x))))) + ((short-float rational) + #+32-bit-target + (target::with-stack-short-floats ((sx x)) + (locally + (declare (type short-float sx)) + (if (and (<= -1.0s0 sx) + (<= sx 1.0s0)) + (%single-float-acos! sx (%make-sfloat)) + (- single-float-half-pi (asin sx))))) + #+64-bit-target + (let* ((sx (%short-float x))) + (declare (type short-float sx)) + (if (and (<= -1.0s0 sx) + (<= sx 1.0s0)) + (%single-float-acos sx) + (- single-float-half-pi (asin sx)))) + ))) + + +(defun fsqrt (x) + (etypecase x + (double-float (%double-float-sqrt! x (%make-dfloat))) + (single-float + #+32-bit-target + (%single-float-sqrt! x (%make-sfloat)) + #+64-bit-target + (%single-float-sqrt x)))) + + + +(defun %df-atan2 (y x &optional result) + (if (zerop x) + (if (zerop y) + (if (plusp (float-sign x)) + y + (float-sign y pi)) + (float-sign y double-float-half-pi)) + (%double-float-atan2! y x (or result (%make-dfloat))))) + +#+32-bit-target +(defun %sf-atan2! (y x &optional result) + (if (zerop x) + (if (zerop y) + (if (plusp (float-sign x)) + y + (float-sign y pi)) + (float-sign y single-float-half-pi)) + (%single-float-atan2! y x (or result (%make-sfloat))))) + +#+64-bit-target +(defun %sf-atan2 (y x) + (if (zerop x) + (if (zerop y) + (if (plusp (float-sign x)) + y + (float-sign y pi)) + (float-sign y single-float-half-pi)) + (%single-float-atan2 y x))) + +#+64-bit-target +(defun %short-float-exp (n) + (let* ((bits (single-float-bits n))) + (declare (type (unsigned-byte 32) bits)) + (ldb (byte IEEE-single-float-exponent-width IEEE-single-float-exponent-offset) bits))) + + +#+64-bit-target +(defun set-%short-float-exp (float exp) + (host-single-float-from-unsigned-byte-32 + (dpb exp + (byte IEEE-single-float-exponent-width + IEEE-single-float-exponent-offset) + (the (unsigned-byte 32) (single-float-bits float))))) + +#+64-bit-target +(defun %%scale-sfloat (float int) + (* (the single-float float) + (the single-float (host-single-float-from-unsigned-byte-32 + (dpb int + (byte IEEE-single-float-exponent-width + IEEE-single-float-exponent-offset) + 0))))) + +#+64-bit-target +(defun %double-float-exp (n) + (let* ((highword (double-float-bits n))) + (declare (fixnum highword)) + (logand (1- (ash 1 IEEE-double-float-exponent-width)) + (ash highword (- (- IEEE-double-float-exponent-offset 32)))))) + +#+64-bit-target +(defun set-%double-float-exp (float exp) + (let* ((highword (double-float-bits float))) + (declare (fixnum highword)) + (setf (uvref float target::double-float.val-high-cell) + (dpb exp + (byte IEEE-double-float-exponent-width + (- IEEE-double-float-exponent-offset 32)) + highword)) + exp)) + +#+64-bit-target +(defun %integer-decode-double-float (f) + (multiple-value-bind (hiword loword) (double-float-bits f) + (declare (type (unsigned-byte 32) hiword loword)) + (let* ((exp (ldb (byte IEEE-double-float-exponent-width + (- IEEE-double-float-exponent-offset 32)) + hiword)) + (mantissa (logior + (the fixnum + (dpb (ldb (byte (- IEEE-double-float-mantissa-width 32) + IEEE-double-float-mantissa-offset) + hiword) + (byte (- IEEE-double-float-mantissa-width 32) + 32) + loword)) + (if (zerop exp) + 0 + (ash 1 IEEE-double-float-hidden-bit)))) + (sign (if (logbitp 31 hiword) -1 1))) + (declare (fixnum exp mantissa sign)) + (values (ldb (byte 25 28) mantissa) + (ldb (byte 28 0) mantissa) + exp + sign)))) + +;;; end of l0-float.lisp Index: /branches/new-random/level-0/l0-hash.lisp =================================================================== --- /branches/new-random/level-0/l0-hash.lisp (revision 13309) +++ /branches/new-random/level-0/l0-hash.lisp (revision 13309) @@ -0,0 +1,1996 @@ +;;;-*- Mode: Lisp; Package: CCL -*- +;;; +;;; Copyright (C) 2009 Clozure Associates +;;; Copyright (C) 1994-2001 Digitool, Inc +;;; This file is part of Clozure CL. +;;; +;;; Clozure CL is licensed under the terms of the Lisp Lesser GNU Public +;;; License , known as the LLGPL and distributed with Clozure CL as the +;;; file "LICENSE". The LLGPL consists of a preamble and the LGPL, +;;; which is distributed with Clozure CL as the file "LGPL". Where these +;;; conflict, the preamble takes precedence. +;;; +;;; Clozure CL is referenced in the preamble as the "LIBRARY." +;;; +;;; The LLGPL is also available online at +;;; http://opensource.franz.com/preamble.html + +(in-package "CCL") + +;;;;;;;;;;;;; +;; +;; See hash.lisp for documentation + + +(eval-when (:compile-toplevel :execute) + (require "HASHENV" "ccl:xdump;hashenv") + (require :number-case-macro) + (define-symbol-macro deleted-hash-key-marker (%slot-unbound-marker)) + (define-symbol-macro free-hash-marker (%unbound-marker)) + (define-symbol-macro rehashing-value-marker (%slot-unbound-marker)) + (declaim (inline nhash.vector-size)) + (declaim (inline mixup-hash-code)) + (declaim (inline hash-table-p)) + (declaim (inline %%eqhash)) + (declaim (inline index->vector-index vector-index->index swap)) + (declaim (inline %already-rehashed-p %set-already-rehashed-p)) + (declaim (inline need-use-eql)) + (declaim (inline %needs-rehashing-p)) + (declaim (inline compute-hash-code)) + (declaim (inline eq-hash-find eq-hash-find-for-put)) + (declaim (inline read-lock-hash-table write-lock-hash-table unlock-hash-table)) + (declaim (inline %hash-symbol)) + (declaim (inline hash-mod)) + (declaim (inline set-hash-key-conditional set-hash-value-conditional)) + (declaim (inline hash-lock-free-p lock-free-gethash))) + + + +(defun %cons-hash-table (keytrans-function compare-function vector + threshold rehash-ratio rehash-size find find-new owner &optional lock-free-p) + (%istruct + 'HASH-TABLE ; type + keytrans-function ; nhash.keytransF + compare-function ; nhash.compareF + nil ; nhash.rehash-bits + vector ; nhash.vector + (if lock-free-p $nhash.lock-free 0) ; nhash.lock + owner ; nhash.owner + threshold ; nhash.grow-threshold + rehash-ratio ; nhash.rehash-ratio + rehash-size ; nhash.rehash-size + 0 ; nhash.puthash-count + (if lock-free-p + (make-lock) + (unless owner (make-read-write-lock))) ; nhash.exclusion-lock + find ; nhash.find + find-new ; nhash.find-new + nil ; nhash.read-only + )) + +(defun nhash.vector-size (vector) + (nhash.vector.size vector)) + +(defun hash-mod (hash entries vector) + (fast-mod-3 hash entries (nhash.vector.size-reciprocal vector))) + +;; For lock-free hash tables +(defun set-hash-key-conditional (index vector old new) + (%set-hash-table-vector-key-conditional (%i+ target::misc-data-offset + (ash (the fixnum index) target::word-shift)) + vector + old + new)) + +(defun set-hash-value-conditional (index vector old new) + (store-gvector-conditional (%i+ index 1) vector old new)) + +(defun hash-lock-free-p (hash) + (logtest $nhash.lock-free (the fixnum (nhash.lock hash)))) + +;;; Is KEY something which can be EQL to something it's not EQ to ? +;;; (e.g., is it a number or macptr ?) +;;; This can be more general than necessary but shouldn't be less so. +(defun need-use-eql (key) + (let* ((typecode (typecode key))) + (declare (fixnum typecode)) + (or (= typecode target::subtag-macptr) + #+(or ppc32-target x8632-target) + (and (>= typecode target::min-numeric-subtag) + (<= typecode target::max-numeric-subtag)) + #+64-bit-target + (or (= typecode target::subtag-bignum) + (= typecode target::subtag-double-float) + (= typecode target::subtag-ratio) + (= typecode target::subtag-complex))))) + +;;; Don't rehash at all, unless some key is address-based (directly or +;;; indirectly.) +(defun %needs-rehashing-p (vector) + (let* ((flags (nhash.vector.flags vector))) + (declare (fixnum flags)) + (if (logbitp $nhash_track_keys_bit flags) + ;; GC is tracking key movement + (logbitp $nhash_key_moved_bit flags) + ;; GC is not tracking key movement + (if (logbitp $nhash_component_address_bit flags) + (not (eql (the fixnum (%get-gc-count)) (the fixnum (nhash.vector.gc-count vector)))))))) + +(defun %set-does-not-need-rehashing (vector) + (let* ((flags (nhash.vector.flags vector))) + (declare (fixnum flags)) + (setf (nhash.vector.gc-count vector) (%get-gc-count)) + (when (logbitp $nhash_track_keys_bit flags) + (setf (nhash.vector.flags vector) + (logand (lognot (ash 1 $nhash_key_moved_bit)) flags))))) + + +;;; Tempting though it may be to remove this, a hash table loaded from +;;; a fasl file likely needs to be rehashed, and the MAKE-LOAD-FORM +;;; for hash tables needs to be able to call this or something similar. +(defun %set-needs-rehashing (hash) + (let* ((vector (nhash.vector hash)) + (flags (nhash.vector.flags vector))) + (declare (fixnum flags)) + (setf (nhash.vector.gc-count vector) (the fixnum (1- (the fixnum (%get-gc-count))))) + (when (logbitp $nhash_track_keys_bit flags) + (setf (nhash.vector.flags vector) (logior (ash 1 $nhash_key_moved_bit) flags))))) + +#+32-bit-target +(defun mixup-hash-code (fixnum) + (declare (fixnum fixnum)) + (the fixnum + (+ fixnum + (the fixnum (%ilsl (- 32 8) + (logand (1- (ash 1 (- 8 3))) fixnum)))))) + +#+64-bit-target +(defun mixup-hash-code (fixnum) + (declare (fixnum fixnum)) + (the fixnum + (+ fixnum + (the fixnum (%ilsl 50 + (logand (1- (ash 1 (- 8 3))) fixnum)))))) + + +(defun rotate-hash-code (fixnum) + (declare (fixnum fixnum)) + (let* ((low-3 (logand 7 fixnum)) + (but-low-3 (%ilsr 3 fixnum)) + (low-3*64K (%ilsl 13 low-3)) + (low-3-in-high-3 (%ilsl (- 32 3 3) low-3))) + (declare (fixnum low-3 but-low-3 low-3*64K low-3-in-high-3)) + (the fixnum (+ low-3-in-high-3 + (the fixnum (logxor low-3*64K but-low-3)))))) + + + + +(defconstant $nhash-track-keys-mask + #.(- (ash 1 $nhash_track_keys_bit))) + +(defconstant $nhash-clear-key-bits-mask #xfffff) + + +(defun %hash-symbol (sym) + (if sym + (let* ((vector (%symptr->symvector sym)) + (cell (%svref vector target::symbol.plist-cell)) + (consp (consp cell))) + (or (if consp (%car cell) cell) + (let* ((pname (%svref vector target::symbol.pname-cell)) + (hash (mixup-hash-code (%pname-hash pname (uvsize pname))))) + (declare (type simple-string pname) (fixnum hash)) + (if consp + (setf (%car cell) hash) + (setf (%svref vector target::symbol.plist-cell) hash))))) + +nil-hash+)) + +;;; Hash on address, or at least on some persistent, immutable +;;; attribute of the key. If all keys are fixnums or immediates (or if +;;; that attribute exists), rehashing won't ever be necessary. +(defun %%eqhash (key) + (let* ((typecode (typecode key))) + (if (eq typecode target::tag-fixnum) + (values (mixup-hash-code key) nil) + (if (eq typecode target::subtag-instance) + (values (mixup-hash-code (instance.hash key)) nil) + (if (symbolp key) + (values (%hash-symbol key) nil) + (let ((hash (mixup-hash-code (strip-tag-to-fixnum key)))) + (if (immediate-p-macro key) + (values hash nil) + (values hash :key )))))))) + + +#+32-bit-target +(defun swap (num) + (declare (fixnum num)) + (the fixnum (+ (the fixnum (%ilsl 16 num))(the fixnum (%ilsr 13 num))))) + +#+64-bit-target +(defun swap (num) + (declare (fixnum num)) + (the fixnum (+ (the fixnum (%ilsl 32 num))(the fixnum (%ilsr 29 num))))) + +;;; teeny bit faster when nothing to do +(defun %%eqlhash-internal (key) + (number-case key + (fixnum (mixup-hash-code key)) ; added this + (double-float (%dfloat-hash key)) + (short-float (%sfloat-hash key)) + (bignum (%bignum-hash key)) + (ratio (logxor (swap (%%eqlhash-internal (numerator key))) + (%%eqlhash-internal (denominator key)))) + (complex + (logxor (swap (%%eqlhash-internal (realpart key))) + (%%eqlhash-internal (imagpart key)))) + (t (cond ((macptrp key) + (%macptr-hash key)) + (t key))))) + + + + +;;; new function + +(defun %%eqlhash (key) + ;; if key is a macptr, float, bignum, ratio, or complex, convert it + ;; to a fixnum + (if (hashed-by-identity key) + (%%eqhash key) + (let ((primary (%%eqlhash-internal key))) + (if (eq primary key) + (%%eqhash key) + (mixup-hash-code (strip-tag-to-fixnum primary)))))) + + +(defun %%equalhash (key) + (let* ((id-p (hashed-by-identity key)) + (hash (if (and key (not id-p)) (%%eqlhash-internal key))) + addressp) + (cond ((null key) (mixup-hash-code 17)) + #+64-bit-target + ((and (typep key 'single-float) + (zerop (the single-float key))) + 0) + ((immediate-p-macro key) (mixup-hash-code (strip-tag-to-fixnum key))) + ((and hash (neq hash key)) hash) ; eql stuff + (t (typecase key + (simple-string (%pname-hash key (length key))) + (string + (let ((length (length key))) + (multiple-value-bind (data offset) (array-data-and-offset key) + (%string-hash offset data length)))) + (bit-vector (bit-vector-hash key)) + (cons + (let ((hash 0)) + (do* ((i 0 (1+ i)) + (list key (cdr list))) + ((or (not (consp list)) (> i 11))) ; who figured 11? + (declare (fixnum i)) + (multiple-value-bind (h1 a1) (%%equalhash (%car list)) + (when a1 (setq addressp t)) + ; fix the case of lists of same stuff in different order + ;(setq hash (%ilogxor (fixnum-rotate h1 i) hash)) + (setq hash (%i+ (rotate-hash-code hash) h1)) + )) + (values hash addressp))) + (pathname (%%equalphash key)) + (t (%%eqlhash key))))))) + +(defun update-hash-flags (hash vector addressp) + (when addressp + (flet ((new-flags (flags addressp) + (declare (fixnum flags)) + (if (eq :key addressp) + ;; hash code depended on key's address + (if (logbitp $nhash_component_address_bit flags) + flags + (logior $nhash-track-keys-mask + (if (logbitp $nhash_track_keys_bit flags) + flags + (bitclr $nhash_key_moved_bit flags)))) + ;; hash code depended on component address + (bitset $nhash_component_address_bit + (logand (lognot $nhash-track-keys-mask) flags))))) + (declare (inline new-flags)) + (if (hash-lock-free-p hash) + (loop + (let* ((flags (nhash.vector.flags vector)) + (new-flags (new-flags flags addressp))) + (when (or (eq flags new-flags) + (store-gvector-conditional nhash.vector.flags vector flags new-flags)) + (return)))) + (setf (nhash.vector.flags vector) + (new-flags (nhash.vector.flags vector) addressp)))))) + +(defun compute-hash-code (hash key update-hash-flags &optional + (vector (nhash.vector hash))) ; vectorp)) + (let ((keytransF (nhash.keytransF hash)) + primary addressp) + (if (not (fixnump keytransF)) + ;; not EQ or EQL hash table + (progn + (multiple-value-setq (primary addressp) (funcall keytransF key)) + (let ((immediate-p (immediate-p-macro primary))) + (setq primary (strip-tag-to-fixnum primary)) + (unless immediate-p + (setq primary (mixup-hash-code primary)) + (setq addressp :key)))) + ;; EQ or EQL hash table + (if (and (not (eql keytransF 0)) + (need-use-eql key)) + ;; EQL hash table + (setq primary (%%eqlhash-internal key)) + ;; EQ hash table - or something eql doesn't do + (multiple-value-setq (primary addressp) (%%eqhash key)))) + (when update-hash-flags + (when addressp + (update-hash-flags hash vector addressp))) + (let* ((entries (nhash.vector-size vector))) + (declare (fixnum entries)) + (values primary + (hash-mod primary entries vector) + entries)))) + +(defun %already-rehashed-p (primary rehash-bits) + (declare (optimize (speed 3)(safety 0))) + (declare (type (simple-array bit (*)) rehash-bits)) + (eql 1 (sbit rehash-bits primary))) + +(defun %set-already-rehashed-p (primary rehash-bits) + (declare (optimize (speed 3)(safety 0))) + (declare (type (simple-array bit (*)) rehash-bits)) + (setf (sbit rehash-bits primary) 1)) + + +(defun hash-table-p (hash) + (istruct-typep hash 'hash-table)) + +(defun %normalize-hash-table-count (hash) + (let* ((vector (nhash.vector hash)) + (weak-deletions-count (nhash.vector.weak-deletions-count vector))) + (declare (fixnum weak-deletions-count)) + (unless (eql 0 weak-deletions-count) + (setf (nhash.vector.weak-deletions-count vector) 0) + ;; lock-free hash tables don't maintain deleted-count, since would need to + ;; lock and it's not worth it. + (unless (hash-lock-free-p hash) + (let ((deleted-count (the fixnum + (+ (the fixnum (nhash.vector.deleted-count vector)) + weak-deletions-count))) + (count (the fixnum (- (the fixnum (nhash.vector.count vector)) weak-deletions-count)))) + (setf (nhash.vector.deleted-count vector) deleted-count + (nhash.vector.count vector) count)))))) + + +(defparameter *shared-hash-table-default* t + "Be sure that you understand the implications of changing this +before doing so.") + +(defparameter *lock-free-hash-table-default* :shared + "If NIL, hash tables default to using the standard algorithms, with locks for shared tables. + If :SHARED, shared hash tables default to using the \"lock-free\" algorithm, + which is faster for typical access but slower for rehashing or growing the table. + Otherwise, all hash tables default to the lock-free algorithm") + +(defun make-hash-table (&key (test 'eql) + (size 60) + (rehash-size 1.5) + (rehash-threshold .85) + (hash-function nil) + (weak nil) + (finalizeable nil) + (address-based t) ;; Ignored + (lock-free *lock-free-hash-table-default*) + (shared *shared-hash-table-default*)) + "Create and return a new hash table. The keywords are as follows: + :TEST -- Indicates what kind of test to use. + :SIZE -- A hint as to how many elements will be put in this hash + table. + :REHASH-SIZE -- Indicates how to expand the table when it fills up. + If an integer, add space for that many elements. If a floating + point number (which must be greater than 1.0), multiply the size + by that amount. + :REHASH-THRESHOLD -- Indicates how dense the table can become before + forcing a rehash. Can be any positive number <=1, with density + approaching zero as the threshold approaches 0. Density 1 means an + average of one entry per bucket." + (declare (ignore address-based)) ;; TODO: could reinterpret as "warn if becomes address-based" + (unless (and test (or (functionp test) (symbolp test))) + (report-bad-arg test '(and (not null) (or symbol function)))) + (unless (or (functionp hash-function) (symbolp hash-function)) + (report-bad-arg hash-function '(or symbol function))) + (unless (and (realp rehash-threshold) (<= 0.0 rehash-threshold) (<= rehash-threshold 1.0)) + (report-bad-arg rehash-threshold '(real 0 1))) + (unless (or (fixnump rehash-size) (and (realp rehash-size) (< 1.0 rehash-size))) + (report-bad-arg rehash-size '(or fixnum (real 1 *)))) + (unless (fixnump size) (report-bad-arg size 'fixnum)) + (setq rehash-threshold (/ 1.0 (max 0.01 rehash-threshold))) + (let* ((default-hash-function + (cond ((or (eq test 'eq) (eq test #'eq)) + (setq test 0)) + ((or (eq test 'eql) (eq test #'eql)) + (setq test -1)) + ((or (eq test 'equal) (eq test #'equal)) + (setq test #'equal) #'%%equalhash) + ((or (eq test 'equalp) (eq test #'equalp)) + (setq test #'equalp) #'%%equalphash) + (t (setq test (require-type test 'symbol)) + (or hash-function + (error "non-standard test specified without hash-function"))))) + (find-function + (case test + (0 #'eq-hash-find) + (-1 #'eql-hash-find) + (t #'general-hash-find))) + (find-put-function + (case test + (0 #'eq-hash-find-for-put) + (-1 #'eql-hash-find-for-put) + (t #'general-hash-find-for-put)))) + (setq hash-function + (if hash-function + (require-type hash-function 'symbol) + default-hash-function)) + (when (and weak (neq weak :value) (neq test 0)) + (error "Only EQ hash tables can be weak.")) + (when (and finalizeable (not weak)) + (error "Only weak hash tables can be finalizeable.")) + (when (and (eq lock-free :shared) (not shared)) + (setq lock-free nil)) + (multiple-value-bind (grow-threshold total-size) + (compute-hash-size (1- size) 1 rehash-threshold) + (let* ((flags (+ (if weak (ash 1 $nhash_weak_bit) 0) + (ecase weak + ((t nil :key) 0) + (:value (ash 1 $nhash_weak_value_bit))) + (if finalizeable (ash 1 $nhash_finalizeable_bit) 0) + (if lock-free (ash 1 $nhash_keys_frozen_bit) 0))) + (hash (%cons-hash-table + hash-function test + (%cons-nhash-vector total-size flags) + grow-threshold rehash-threshold rehash-size + find-function find-put-function + (unless shared *current-process*) + lock-free))) + (setf (nhash.vector.hash (nhash.vector hash)) hash) + hash)))) + +(defun compute-hash-size (size rehash-size rehash-ratio) + (let* ((new-size size)) + (declare (fixnum size new-size)) + (setq new-size (max 30 (if (fixnump rehash-size) + (%i+ size rehash-size) + (ceiling (* size rehash-size))))) + (if (<= new-size size) + (setq new-size (1+ size))) ; God save you if you make this happen + + (let ((vector-size (%hash-size (max (+ new-size 2) (ceiling (* new-size rehash-ratio)))))) + ; TODO: perhaps allow more entries, based on actual size: + ; (values (min (floor vector-size rehash-ratio) (%i- vector-size 2)) vector-size)) + (values new-size vector-size) + ))) + +;;; Suggested size is a fixnum: number of pairs. Return a fixnum >= +;;; that size that is relatively prime to all secondary keys. +(defun %hash-size (suggestion) + (declare (fixnum suggestion)) + (declare (optimize (speed 3)(safety 0))) + (if (<= suggestion #.(aref secondary-keys 7)) + (setq suggestion (+ 2 #.(aref secondary-keys 7))) + (setq suggestion (logior 1 suggestion))) + (loop + (dovector (key secondary-keys (return-from %hash-size suggestion)) + (when (eql 0 (fast-mod suggestion key)) + (return))) + (incf suggestion 2))) + + +(defvar *continue-from-readonly-hashtable-lock-error* t) + +(defun signal-read-only-hash-table-error (hash) + (cond ((hash-lock-free-p hash) + ;; We don't really do anything different if this is set, so no problem + (cerror "Modify it anyway" + "Attempt to modify readonly hash table ~s" hash)) + (*continue-from-readonly-hashtable-lock-error* + (cerror "Make the hash-table writable. DANGEROUS! This could damage your lisp if another thread is acccessing this table. CONTINUE ONLY IF YOU KNOW WHAT YOU'RE DOING!" + "Hash-table ~s is readonly" hash) + (assert-hash-table-writeable hash) + (write-lock-hash-table hash)) + (t (error "Hash-table ~s is readonly" hash)))) + +(defun read-lock-hash-table (hash) + (if (nhash.read-only hash) + :readonly + (let* ((lock (nhash.exclusion-lock hash))) + (if lock + (read-lock-rwlock lock) + (unless (eq (nhash.owner hash) *current-process*) + (error "Not owner of hash table ~s" hash)))))) + +(defun write-lock-hash-table (hash) + (if (nhash.read-only hash) + (signal-read-only-hash-table-error hash) + (let* ((lock (nhash.exclusion-lock hash))) + (if lock + (write-lock-rwlock lock) + (unless (eq (nhash.owner hash) *current-process*) + (error "Not owner of hash table ~s" hash)))))) + + +(defun unlock-hash-table (hash was-readonly) + (unless was-readonly + (let* ((lock (nhash.exclusion-lock hash))) + (if lock + (unlock-rwlock lock))))) + +(defun index->vector-index (index) + (declare (fixnum index)) + (the fixnum (+ $nhash.vector_overhead (the fixnum (+ index index))))) + +(defun vector-index->index (index) + (declare (fixnum index)) + (the fixnum (ash (the fixnum (- index $nhash.vector_overhead)) -1))) + +(defun hash-table-count (hash) + "Return the number of entries in the given HASH-TABLE." + (setq hash (require-type hash 'hash-table)) + (when (hash-lock-free-p hash) + ;; We don't try to maintain a running total, so just count. + (return-from hash-table-count (lock-free-count-entries hash))) + (%normalize-hash-table-count hash) + (the fixnum (nhash.vector.count (nhash.vector hash)))) + +(defun hash-table-rehash-size (hash) + "Return the rehash-size HASH-TABLE was created with." + (nhash.rehash-size (require-type hash 'hash-table))) + +(defun hash-table-rehash-threshold (hash) + "Return the rehash-threshold HASH-TABLE was created with." + (/ 1.0 (nhash.rehash-ratio (require-type hash 'hash-table)))) + +(defun hash-table-size (hash) + "Return a size that can be used with MAKE-HASH-TABLE to create a hash + table that can hold however many entries HASH-TABLE can hold without + having to be grown." + (let* ((hash (require-type hash 'hash-table)) + (vector (nhash.vector hash))) + (values (floor (nhash.vector.size vector) (nhash.rehash-ratio hash))))) + +(defun hash-table-test (hash) + "Return the test HASH-TABLE was created with." + (let ((f (nhash.compareF (require-type hash 'hash-table)))) + (if (fixnump f) + (if (eql 0 f) 'eq 'eql) + (let ((name (if (symbolp f) f (function-name f)))) + (if (memq name '(equal equalp)) name f))))) + +;;; sometimes you'd rather have the function than the symbol. +(defun hash-table-test-function (hash) + (let ((f (nhash.compareF (require-type hash 'hash-table)))) + (if (fixnump f) + (if (eql 0 f) #'eq #'eql) + f))) + +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; +;; +;; nearly-lock-free hash tables +;; +;; A modification of the lock-free hash table algorithm described by Cliff Click Jr. in +;; http://blogs.azulsystems.com/cliff/2007/03/a_nonblocking_h.html. +;; +;; The modifications have to do with the fact that our goal is just to minimize the +;; performance impact of thread-safety, by eliminating the need for locking on every +;; read. I don't bother with aspects of his algorithm that aren't relevant to that goal. +;; +;; The main difference from Click's algorithm is that I don't try to do rehashing +;; concurrently. Instead, rehashing grabs a lock, so that only one thread can be +;; rehashing at any given time, and readers/writers will block waiting for the rehashing +;; to finish. +;; +;; In addition, I don't have a separate state for partially inserted key, I reuse the +;; DELETED state for that. So in our implementation the following are the possible states +;; of a hash table entry (where "object" means any object other than the special markers): +;; +;; State Key Value +;; DELETED1 object free-hash-marker +;; DELETED2 deleted-marker free-hash-marker +;; IN-USE object object +;; FREE free-hash-marker free-hash-marker +;; REHASHING object rehashing-value-marker +;; REHASHING free-hash-marker rehashing-value-marker +;; REHASHING deleted-marker rehashing-value-marker +;; +;; No other states are allowed - at no point in time can a hash table entry be in any +;; other state. In addition, the only transitions allowed on the key slot are +;; free-hash-marker -> object/deleted-marker -> deleted-marker. Once a key slot +;; is claimed, it must never change to free or another key value (even after the hash +;; vector has been discarded after rehashing, because there some process might still +;; be looking at it). +;; In particular, rehashing in place is not an option. All rehashing creates a new +;; vector and copies into it. This means it's kinda risky to use lock-free hash +;; tables with address-based keys, because they will thrash in low-memory situations, +;; but we don't disallow it because a particular use might not have this problem. +;; +;; The following operations may take place: +;; +;; * gethash: find matching key - if no match, return not found. Else fetch value, +;; if value is rehashing-value-marker then maybe-rehash and try again; +;; if value is free-hash-marker, return not found, else return found value. +;; +;; * puthash: find matching key or FREE slot. +;; ** If found key, fetch value. +;; if value is rehashing-value-marker then maybe-rehash and try again; +;; else store-conditional the value -> new value, if fails try again. +;; ** Else have FREE slot, store-key-conditional free-hash-marker -> key, +;; and if that succeeds, store-conditional free-hash-marker -> new value, +;; if either fails, maybe-rehash and try again. +;; +;; * remhash: find matching key - if no match, done. Else fetch value, +;; if value is rehashing-value-marker then maybe-rehash and try again; +;; else store-conditional the value -> free-hash-marker, if fails try again. +;; +;; * rehash: grab a lock, estimate number of entries, make a new vector. loop over +;; old vector, at each entry fetch the old value with atomic swap of +;; rehashing-value-marker. This prevents any further state changes involving the +;; value. It doesn't prevent state changes involving the key, but the only ones that +;; can happen is FREE -> DELETED, and DELETED1 <-> DELETED2, all of which are +;; equivalent from the point of view of rehashing. Anyway, if the old value was +;; rehashing-value-marker then bug (because we have a lock). If the old value is +;; free-hash-marker then do nothing, else get the entry key and rehash into the new +;; vector -- if no more room, start over. When done, store the new vector in the +;; hash table and release lock. +;; +;; * gc: for weak tables, gc may convert IN-USE states to DELETED2 states. +;; Even for non-weak tables, gc could convert DELETED1 states to DELETED2. + + +(defun lock-free-rehash (hash) + ;;(break "We think we need to rehash ~s" (nhash.vector hash)) + (with-lock-context + (without-interrupts ;; not re-entrant + (let ((lock (nhash.exclusion-lock hash))) + (%lock-recursive-lock-object lock) + ;; TODO: might also want to rehash if deleted entries are a large percentage + ;; of all entries, more or less. + (when (or (%i<= (nhash.grow-threshold hash) 0) ;; no room + (%needs-rehashing-p (nhash.vector hash))) ;; or keys moved + (%lock-free-rehash hash)) + (%unlock-recursive-lock-object lock))))) + + +;; TODO: This is silly. We're implementing atomic swap using store-conditional, +;; but internally store-conditional is probably implemented using some kind of +;; an atomic swap!! +(defun atomic-swap-gvector (index gvector value) + (loop + (let ((old-value (%svref gvector index))) + (when (store-gvector-conditional index gvector old-value value) + (return old-value))))) + +;; Interrupts are disabled and caller has the hash lock on the table, blocking other +;; threads attempting a rehash. +;; Other threads might be reading/writing/deleting individual entries, but they +;; will block if they see a value = rehashing-value-marker. +;; GC may run, updating the needs-rehashing flags and deleting weak entries in both +;; old and new vectors. +(defun %lock-free-rehash (hash) + (let* ((old-vector (nhash.vector hash)) + (inherited-flags (logand $nhash_weak_flags_mask (nhash.vector.flags old-vector))) + (grow-threshold (nhash.grow-threshold hash)) + count new-vector vector-size) + ;; Prevent puthash from adding new entries. Note this doesn't keep it from undeleting + ;; existing entries, so we might still lose, but this makes the odds much smaller. + (setf (nhash.grow-threshold hash) 0) + (setq count (lock-free-count-entries hash)) + (multiple-value-setq (grow-threshold vector-size) + (if (%i<= grow-threshold 0) ; if ran out of room, grow, else get just enough. + (compute-hash-size count (nhash.rehash-size hash) (nhash.rehash-ratio hash)) + (compute-hash-size count 1 (nhash.rehash-ratio hash)))) + (setq new-vector (%cons-nhash-vector vector-size inherited-flags)) + (loop with full-count = grow-threshold + for i from $nhash.vector_overhead below (uvsize old-vector) by 2 + do (let* ((value (atomic-swap-gvector (%i+ i 1) old-vector rehashing-value-marker)) + (key (%svref old-vector i))) + (when (eq value rehashing-value-marker) (error "Who else is doing this?")) + (unless (or (eq value free-hash-marker) (eq key deleted-hash-key-marker)) + (let* ((new-index (%growhash-probe new-vector hash key)) + (new-vector-index (index->vector-index new-index))) + (%set-hash-table-vector-key new-vector new-vector-index key) + (setf (%svref new-vector (%i+ new-vector-index 1)) value) + (decf grow-threshold) + (when (%i<= grow-threshold 0) + ;; Too many entries got undeleted while we were rehashing (that's the + ;; only way we could end up with more than COUNT entries, as adding + ;; new entries is blocked). Grow the output vector. + (multiple-value-bind (bigger-threshold bigger-vector-size) + (compute-hash-size full-count (nhash.rehash-size hash) (nhash.rehash-ratio hash)) + (assert (> bigger-vector-size vector-size)) + (let ((bigger-vector (%cons-nhash-vector bigger-vector-size 0))) + (%copy-gvector-to-gvector new-vector + $nhash.vector_overhead + bigger-vector + $nhash.vector_overhead + (%i- (uvsize new-vector) $nhash.vector_overhead)) + (setf (nhash.vector.flags bigger-vector) (nhash.vector.flags new-vector)) + (%lock-free-rehash-in-place hash bigger-vector) + (setq grow-threshold (- bigger-threshold full-count)) + (setq full-count bigger-threshold) + (setq new-vector bigger-vector) + (setq vector-size bigger-vector-size)))))))) + (when (%needs-rehashing-p new-vector) ;; keys moved, but at least can use the same new-vector. + (%lock-free-rehash-in-place hash new-vector)) + (setf (nhash.vector.hash new-vector) hash) + (setf (nhash.grow-threshold hash) grow-threshold) + ;; At this point, another thread might decrement the threshold while they're looking at the old + ;; vector. That's ok, just means it will be too small and we'll rehash sooner than planned, + ;; no big deal. + (setf (nhash.vector hash) new-vector))) + +;; This is called on a new vector that hasn't been installed yet, so no other thread is +;; accessing it. However, gc might be deleting stuff from it, which is why it tests +;; key for deleted-hash-key-marker in addition to free-hash-marker value +(defun %lock-free-rehash-in-place (hash vector) + (let* ((vector-index (- $nhash.vector_overhead 2)) + (size (nhash.vector-size vector)) + (rehash-bits (%make-rehash-bits hash size)) + (index -1)) + (declare (fixnum size index vector-index)) + (%set-does-not-need-rehashing vector) + (loop + (when (>= (incf index) size) (return)) + (setq vector-index (+ vector-index 2)) + (unless (%already-rehashed-p index rehash-bits) + (let* ((value (%svref vector (%i+ vector-index 1))) + (key (%svref vector vector-index))) + (if (or (eq value free-hash-marker) + (eq key deleted-hash-key-marker)) + (unless (eq key free-hash-marker) + (setf (%svref vector vector-index) free-hash-marker)) + (let* ((last-index index) + (first t)) + (loop + (let ((found-index (%rehash-probe rehash-bits hash key vector))) + (%set-already-rehashed-p found-index rehash-bits) + (when (eq last-index found-index) + (return)) + (let* ((found-vector-index (index->vector-index found-index)) + (newvalue (%svref vector (the fixnum (1+ found-vector-index)))) + (newkey (%svref vector found-vector-index))) + (declare (fixnum found-vector-index)) + (when first ; or (eq last-index index) ? + (setq first nil) + (setf (%svref vector (the fixnum (1+ vector-index))) free-hash-marker) + (setf (%svref vector vector-index) free-hash-marker)) + (%set-hash-table-vector-key vector found-vector-index key) + (setf (%svref vector (the fixnum (1+ found-vector-index))) value) + (when (or (eq newkey deleted-hash-key-marker) + (eq newvalue free-hash-marker)) + (return)) + (when (eq key newkey) + (cerror "Delete one of the entries." "Duplicate key: ~s in ~s ~s ~s ~s ~s" + key hash value newvalue index found-index) + (return)) + (setq key newkey + value newvalue + last-index found-index)))))))))) + t ) + + +(defun lock-free-gethash (key hash default) + (declare (optimize (speed 3) (safety 0) (debug 0))) + (loop + (let* ((vector (nhash.vector hash)) + (vector-index (funcall (the function (nhash.find hash)) hash key))) + (declare (fixnum vector-index)) + ;; Need to punt if vector changed because no way to know whether nhash.find was + ;; using old or new vector. + (when (eq vector (nhash.vector hash)) + (cond ((eql vector-index -1) + (unless (%needs-rehashing-p vector) + (return-from lock-free-gethash (values default nil)))) + (t (let ((value (%svref vector (%i+ vector-index 1)))) + (unless (eq value rehashing-value-marker) + (if (eq value free-hash-marker) + (return-from lock-free-gethash (values default nil)) + (return-from lock-free-gethash (values value t))))))))) + ;; We're here because the table needs rehashing or it was getting rehashed while we + ;; were searching. Take care of it and try again. + (lock-free-rehash hash))) + +(defun lock-free-remhash (key hash) + (declare (optimize (speed 3) (safety 0) (debug 0))) + (when (nhash.read-only hash) + (signal-read-only-hash-table-error hash)) ;; continuable + (loop + (let* ((vector (nhash.vector hash)) + (vector-index (funcall (the function (nhash.find hash)) hash key))) + (declare (fixnum vector-index)) + ;; Need to punt if vector changed because no way to know whether nhash.find was + ;; using old or new vector. + (when (eq vector (nhash.vector hash)) + (cond ((eql vector-index -1) + (unless (%needs-rehashing-p vector) + (return-from lock-free-remhash nil))) + (t (let ((old-value (%svref vector (%i+ vector-index 1)))) + (unless (eq old-value rehashing-value-marker) + (when (eq old-value free-hash-marker) + (return-from lock-free-remhash nil)) + (when (set-hash-value-conditional vector-index vector old-value free-hash-marker) + ;; We just use this as a flag - tell gc to scan the vector for deleted keys. + ;; It's just a hint, so don't worry about sync'ing + (setf (nhash.vector.deleted-count vector) 1) + (return-from lock-free-remhash t))))))) + ;; We're here because the table needs rehashing or it was getting rehashed while we + ;; were searching. Take care of it and try again. + (lock-free-rehash hash)))) + +(defun lock-free-clrhash (hash) + (when (nhash.read-only hash) + (signal-read-only-hash-table-error hash)) ;;continuable + (with-lock-context + (without-interrupts + (let ((lock (nhash.exclusion-lock hash))) + (%lock-recursive-lock-object lock) ;; disallow rehashing. + (loop + with vector = (nhash.vector hash) + for i1 fixnum from (%i+ $nhash.vector_overhead 1) below (uvsize vector) by 2 + do (setf (%svref vector i1) free-hash-marker) + ;; We just use this as a flag - tell gc to scan the vector for deleted keys. + ;; It's just a hint, so don't worry about sync'ing + finally (setf (nhash.vector.deleted-count vector) 1)) + (%unlock-recursive-lock-object lock)))) + hash) + +(defun lock-free-puthash (key hash value) + (declare (optimize (speed 3) (safety 0) (debug 0))) + (when (or (eq value rehashing-value-marker) + (eq value free-hash-marker)) + (error "Illegal value ~s for storing in a hash table" value)) + (when (nhash.read-only hash) + (signal-read-only-hash-table-error hash)) ;;continuable + (loop + (let* ((vector (nhash.vector hash)) + (vector-index (funcall (nhash.find-new hash) hash key))) + ;; Need to punt if vector changed because no way to know whether nhash.find-new was + ;; using old or new vector. + (when (eq vector (nhash.vector hash)) + (cond ((or (eql vector-index -1) + (eq (%svref vector vector-index) free-hash-marker)) + (unless (or (%needs-rehashing-p vector) + (%i<= (nhash.grow-threshold hash) 0)) + ;; Note if the puthash fails, grow-threshold will end up too small. This + ;; just means we might rehash sooner than absolutely necessary, no real + ;; harm done (the most likely cause of failing is that somebody is + ;; already rehashing anyway). DON'T try to incf it back on failure -- + ;; that risks grow-threshold ending up too big (e.g. if somebody rehashes + ;; before the incf), which _could_ be harmful. + (atomic-decf (nhash.grow-threshold hash)) + (if (set-hash-key-conditional vector-index vector free-hash-marker key) + (when (set-hash-value-conditional vector-index vector free-hash-marker value) + (return-from lock-free-puthash value))))) + (t (let ((old-value (%svref vector (%i+ vector-index 1)))) + (unless (eq old-value rehashing-value-marker) + (when (set-hash-value-conditional vector-index vector old-value value) + (return-from lock-free-puthash value)))))))) + ;; We're here because the table needs rehashing or it was getting rehashed while we + ;; were searching, or no room for new entry, or somebody else claimed the key from + ;; under us (that last case doesn't need to retry, but it's unlikely enough that + ;; it's not worth checking for). Take care of it and try again. + (lock-free-rehash hash))) + +(defun lock-free-count-entries (hash) + ;; Other threads could be adding/removing entries while we count, some of + ;; which will be included in the count (i.e. will be treated as if they + ;; happened after counting) and some won't (i.e. will be treated as if + ;; they happened before counting), but not necessarily in correlation + ;; with their temporal relationship. + (loop + with vector = (nhash.vector hash) + for i fixnum from $nhash.vector_overhead below (uvsize vector) by 2 + count (let ((value (%svref vector (%i+ i 1)))) + (when (eq value rehashing-value-marker) + ;; This table is being rehashed. Wait for it to be + ;; done and try again. + (lock-free-rehash hash) + (return-from lock-free-count-entries (lock-free-count-entries hash))) + (neq value free-hash-marker)))) + +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; + + +(defun gethash (key hash &optional default) + "Finds the entry in HASH-TABLE whose key is KEY and returns the associated + value and T as multiple values, or returns DEFAULT and NIL if there is no + such entry. Entries can be added using SETF." + (unless (typep hash 'hash-table) + (report-bad-arg hash 'hash-table)) + (when (or (eq key free-hash-marker) + (eq key deleted-hash-key-marker)) + (return-from gethash (values default nil))) + (when (hash-lock-free-p hash) + (return-from gethash (lock-free-gethash key hash default))) + (let* ((value nil) + (gc-locked nil) + (readonly nil) + (foundp nil)) + (with-lock-context + (without-interrupts + (setq readonly (eq (read-lock-hash-table hash) :readonly)) + (let* ((vector (nhash.vector hash))) + (if (and (eq key (nhash.vector.cache-key vector)) + ;; Check twice: the GC might nuke the cached key/value pair + (progn (setq value (nhash.vector.cache-value vector)) + (eq key (nhash.vector.cache-key vector)))) + (setq foundp t) + (loop + (let* ((vector-index (funcall (nhash.find hash) hash key))) + (declare (fixnum vector-index)) + (cond ((setq foundp (not (eql vector-index -1))) + ;; Referencing both key and value here - and referencing + ;; value first - is an attempt to compensate for the + ;; possibility that the GC deletes a weak-on-key pair. + (setq value (%svref vector (%i+ vector-index 1))) + (when (nhash.owner hash) + (setf (nhash.vector.cache-key vector) + (%svref vector vector-index) + (nhash.vector.cache-value vector) + value + (nhash.vector.cache-idx vector) + (vector-index->index (the fixnum vector-index)))) + (return)) + ((%needs-rehashing-p vector) + (%lock-gc-lock) + (setq gc-locked t) + (unless readonly + (let* ((lock (nhash.exclusion-lock hash))) + (when lock (%promote-rwlock lock)))) + (when (%needs-rehashing-p vector) + (%rehash hash))) + (t (return))))))) + (when gc-locked (%unlock-gc-lock)) + (unlock-hash-table hash readonly))) + (if foundp + (values value t) + (values default nil)))) + +(defun remhash (key hash) + "Remove the entry in HASH-TABLE associated with KEY. Return T if there + was such an entry, or NIL if not." + (unless (typep hash 'hash-table) + (setq hash (require-type hash 'hash-table))) + (when (hash-lock-free-p hash) + (return-from remhash (lock-free-remhash key hash))) + (let* ((foundp nil)) + (with-lock-context + (without-interrupts + (write-lock-hash-table hash) + (%lock-gc-lock) + (let* ((vector (nhash.vector hash))) + (when (%needs-rehashing-p vector) + (%rehash hash)) + (if (eq key (nhash.vector.cache-key vector)) + (progn + (setf (nhash.vector.cache-key vector) free-hash-marker + (nhash.vector.cache-value vector) nil) + (let ((vidx (index->vector-index (nhash.vector.cache-idx vector)))) + (setf (%svref vector vidx) deleted-hash-key-marker) + (setf (%svref vector (the fixnum (1+ vidx))) nil)) + (incf (the fixnum (nhash.vector.deleted-count vector))) + (decf (the fixnum (nhash.vector.count vector))) + (setq foundp t)) + (let* ((vector-index (funcall (nhash.find hash) hash key))) + (declare (fixnum vector-index)) + (unless (eql vector-index -1) + ;; always clear the cache cause I'm too lazy to call the + ;; comparison function and don't want to keep a possibly + ;; deleted key from being GC'd + (setf (nhash.vector.cache-key vector) free-hash-marker + (nhash.vector.cache-value vector) nil) + ;; Update the count + (incf (the fixnum (nhash.vector.deleted-count vector))) + (decf (the fixnum (nhash.vector.count vector))) + ;; Delete the value from the table. + (setf (%svref vector vector-index) deleted-hash-key-marker + (%svref vector (the fixnum (1+ vector-index))) nil) + (setq foundp t)))) + (when (and foundp + (zerop (the fixnum (nhash.vector.count vector)))) + (do* ((i $nhash.vector_overhead (1+ i)) + (n (uvsize vector))) + ((= i n)) + (declare (fixnum i n)) + (setf (%svref vector i) free-hash-marker)) + (setf (nhash.grow-threshold hash) + (+ (nhash.vector.deleted-count vector) + (nhash.vector.weak-deletions-count vector) + (nhash.grow-threshold hash)) + (nhash.vector.deleted-count vector) 0 + (nhash.vector.weak-deletions-count vector) 0))) + ;; Return T if we deleted something + (%unlock-gc-lock) + (unlock-hash-table hash nil))) + foundp)) + +;;; what if somebody is mapping, growing, rehashing? +(defun clrhash (hash) + "This removes all the entries from HASH-TABLE and returns the hash table + itself." + (unless (typep hash 'hash-table) + (report-bad-arg hash 'hash-table)) + (when (hash-lock-free-p hash) + (return-from clrhash (lock-free-clrhash hash))) + (with-lock-context + (without-interrupts + (write-lock-hash-table hash) + (let* ((vector (nhash.vector hash)) + (size (nhash.vector-size vector)) + (count (+ size size)) + (index $nhash.vector_overhead)) + (declare (fixnum size count index)) + (dotimes (i count) + (setf (%svref vector index) free-hash-marker) + (incf index)) + (incf (the fixnum (nhash.grow-threshold hash)) + (the fixnum (+ (the fixnum (nhash.vector.count vector)) + (the fixnum (nhash.vector.deleted-count vector))))) + (setf (nhash.vector.count vector) 0 + (nhash.vector.cache-key vector) free-hash-marker + (nhash.vector.cache-value vector) nil + (nhash.vector.finalization-alist vector) nil + (nhash.vector.free-alist vector) nil + (nhash.vector.weak-deletions-count vector) 0 + (nhash.vector.deleted-count vector) 0 + (nhash.vector.flags vector) (logand $nhash_weak_flags_mask + (nhash.vector.flags vector)))) + (unlock-hash-table hash nil) + hash))) + + +(defun puthash (key hash default &optional (value default)) + (declare (optimize (speed 3) (space 0))) + (unless (typep hash 'hash-table) + (report-bad-arg hash 'hash-table)) + (when (or (eq key free-hash-marker) + (eq key deleted-hash-key-marker)) + (error "Can't use ~s as a hash-table key" key)) + (when (hash-lock-free-p hash) + (return-from puthash (lock-free-puthash key hash value))) + (with-lock-context + (without-interrupts + (block protected + (tagbody + (write-lock-hash-table hash) + AGAIN + (%lock-gc-lock) + (let ((vector (nhash.vector hash))) + (when (%needs-rehashing-p vector) + (%rehash hash)) + (when (eq key (nhash.vector.cache-key vector)) + (let* ((idx (nhash.vector.cache-idx vector))) + (declare (fixnum idx)) + (setf (%svref vector (the fixnum (1+ (the fixnum (index->vector-index idx))))) + value) + (setf (nhash.vector.cache-value vector) value) + (return-from protected))) + (let* ((vector-index (funcall (nhash.find-new hash) hash key)) + (old-value (%svref vector vector-index))) + (declare (fixnum vector-index)) + + (cond ((eq old-value deleted-hash-key-marker) + (%set-hash-table-vector-key vector vector-index key) + (setf (%svref vector (the fixnum (1+ vector-index))) value) + (incf (the fixnum (nhash.vector.count vector))) + ;; Adjust deleted-count + (when (> 0 (the fixnum + (decf (the fixnum + (nhash.vector.deleted-count vector))))) + (%normalize-hash-table-count hash))) + ((eq old-value free-hash-marker) + (when (eql 0 (nhash.grow-threshold hash)) + (%unlock-gc-lock) + (%grow-hash-table hash) + (go AGAIN)) + (%set-hash-table-vector-key vector vector-index key) + (setf (%svref vector (the fixnum (1+ vector-index))) value) + (decf (the fixnum (nhash.grow-threshold hash))) + (incf (the fixnum (nhash.vector.count vector)))) + (t + ;; Key was already there, update value. + (setf (%svref vector (the fixnum (1+ vector-index))) value))) + (setf (nhash.vector.cache-idx vector) (vector-index->index vector-index) + (nhash.vector.cache-key vector) key + (nhash.vector.cache-value vector) value))))) + (%unlock-gc-lock) + (unlock-hash-table hash nil))) + value) + + +(defun count-entries (hash) + (if (hash-lock-free-p hash) + (lock-free-count-entries hash) + (let* ((vector (nhash.vector hash)) + (size (uvsize vector)) + (idx $nhash.vector_overhead) + (count 0)) + (loop + (when (neq (%svref vector idx) free-hash-marker) + (incf count)) + (when (>= (setq idx (+ idx 2)) size) + (return count)))))) + + + + + + + +(defun grow-hash-table (hash) + (unless (typep hash 'hash-table) + (setq hash (require-type hash 'hash-table))) + (%grow-hash-table hash)) + +;;; Interrupts are disabled, and the caller has an exclusive +;;; lock on the hash table. +(defun %grow-hash-table (hash) + (block grow-hash-table + (%normalize-hash-table-count hash) + (let* ((old-vector (nhash.vector hash)) + (old-size (nhash.vector.count old-vector)) + (old-total-size (nhash.vector.size old-vector)) + (flags 0) + (flags-sans-weak 0) + (weak-flags nil)) + (declare (fixnum old-total-size flags flags-sans-weak)) + (when (> (nhash.vector.deleted-count old-vector) 0) + ;; There are enough deleted entries. Rehash to get rid of them + (%rehash hash) + (return-from grow-hash-table)) + (multiple-value-bind (size total-size) + (compute-hash-size + old-size (nhash.rehash-size hash) (nhash.rehash-ratio hash)) + (unless (eql 0 (nhash.grow-threshold hash)) ; maybe it's done already - shouldnt happen + (return-from grow-hash-table )) + (progn + (unwind-protect + (let ((gc-count (%get-gc-count)) + vector) + (setq flags (nhash.vector.flags old-vector) + flags-sans-weak (logand flags (logxor -1 $nhash_weak_flags_mask)) + weak-flags (logand flags $nhash_weak_flags_mask)) + (setf (nhash.vector.flags old-vector) flags-sans-weak) ; disable GC weak stuff + (%normalize-hash-table-count hash) + (when (> (nhash.vector.deleted-count old-vector) 0) + (setf (nhash.vector.flags old-vector) flags) + (setq weak-flags nil) + (return-from grow-hash-table (%rehash hash))) + (setq vector (%cons-nhash-vector total-size 0)) + (do* ((index 0 (1+ index)) + (vector-index (index->vector-index 0) (+ vector-index 2))) + ((>= index old-total-size)) + (declare (fixnum index vector-index)) + + (let ((key (%svref old-vector vector-index))) + (unless (or (eq key free-hash-marker) + (eq key deleted-hash-key-marker)) + (let* ((new-index (%growhash-probe vector hash key)) + (new-vector-index (index->vector-index new-index))) + (setf (%svref vector new-vector-index) key) + (setf (%svref vector (the fixnum (1+ new-vector-index))) + (%svref old-vector (the fixnum (1+ vector-index)))))))) + (progn + (setf (nhash.vector.finalization-alist vector) + (nhash.vector.finalization-alist old-vector) + (nhash.vector.free-alist vector) + (nhash.vector.free-alist old-vector) + (nhash.vector.count vector) old-size + (nhash.vector.flags vector) + (logior (the fixnum weak-flags) + (the fixnum (nhash.vector.flags vector)))) + (setf (nhash.rehash-bits hash) nil + (nhash.vector hash) vector + (nhash.vector.hash vector) hash + (nhash.vector.cache-key vector) free-hash-marker + (nhash.vector.cache-value vector) nil + (nhash.vector.gc-count vector) gc-count + (nhash.grow-threshold hash) (- size old-size)) + (setq weak-flags nil) ; tell clean-up form we finished the loop + ;; If the old vector's in some static heap, zero it + ;; so that less garbage is retained. + (%init-misc 0 old-vector))) + (when weak-flags + (setf (nhash.vector.flags old-vector) + (logior (the fixnum weak-flags) + (the fixnum (nhash.vector.flags old-vector))))))))))) + + + +(defun general-hash-find (hash key) + (%hash-probe hash key nil)) + +(defun general-hash-find-for-put (hash key) + (%hash-probe hash key (if (hash-lock-free-p hash) :free :reuse))) + +;;; returns a single value: +;;; index - the index in the vector for key (where it was or where +;;; to insert if the current key at that index is deleted-hash-key-marker +;;; or free-hash-marker) + + + +(defun %hash-probe (hash key for-put-p) + (declare (optimize (speed 3) (space 0))) + (multiple-value-bind (hash-code index entries) + (compute-hash-code hash key for-put-p) + (locally (declare (fixnum hash-code index entries)) + (let* ((compareF (nhash.compareF hash)) + (vector (nhash.vector hash)) + (vector-index 0) + table-key + (first-deleted-index nil)) + (declare (fixnum vector-index)) + (macrolet ((return-it (form) + `(return-from %hash-probe ,form))) + (macrolet ((test-it (predicate) + (unless (listp predicate) (setq predicate (list predicate))) + `(progn + (setq vector-index (index->vector-index index) + table-key (%svref vector vector-index)) + (cond ((eq table-key free-hash-marker) + (return-it (if for-put-p + (or first-deleted-index + vector-index) + -1))) + ((eq table-key deleted-hash-key-marker) + (when (and (eq for-put-p :reuse) + (null first-deleted-index)) + (setq first-deleted-index vector-index))) + ((,@predicate key table-key) + (return-it vector-index)))))) + (macrolet ((do-it (predicate) + `(progn + (test-it ,predicate) + ; First probe failed. Iterate on secondary key + (let ((initial-index index) + (secondary-hash (%svref secondary-keys (logand 7 hash-code)))) + (declare (fixnum secondary-hash initial-index)) + (loop + (incf index secondary-hash) + (when (>= index entries) + (decf index entries)) + (when (eql index initial-index) + (return-it (if for-put-p + (or first-deleted-index + (error "Bug: no room in table")) + -1))) + (test-it ,predicate)))))) + (if (fixnump comparef) + ;; EQ or EQL hash table + (if (or (eql 0 comparef) + (immediate-p-macro key) + (not (need-use-eql key))) + ;; EQ hash table or EQL == EQ for KEY + (do-it eq) + (do-it eql)) + ;; general compare function + (do-it (funcall comparef)))))))))) + +(defun eq-hash-find (hash key) + (declare (optimize (speed 3) (safety 0))) + (let* ((vector (nhash.vector hash)) + (hash-code + (let* ((typecode (typecode key))) + (if (eq typecode target::tag-fixnum) + (mixup-hash-code key) + (if (eq typecode target::subtag-instance) + (mixup-hash-code (instance.hash key)) + (if (symbolp key) + (%hash-symbol key) + (mixup-hash-code (strip-tag-to-fixnum key))))))) + (entries (nhash.vector-size vector)) + (vector-index (index->vector-index (hash-mod hash-code entries vector))) + (table-key (%svref vector vector-index))) + (declare (fixnum hash-code entries vector-index)) + (if (eq table-key key) + vector-index + (if (eq table-key free-hash-marker) + -1 + (let* ((secondary-hash (%svref secondary-keys-*-2 + (logand 7 hash-code))) + (initial-index vector-index) + (count (+ entries entries)) + (length (+ count $nhash.vector_overhead))) + (declare (fixnum secondary-hash initial-index count length)) + (loop + (incf vector-index secondary-hash) + (when (>= vector-index length) + (decf vector-index count)) + (setq table-key (%svref vector vector-index)) + (when (= vector-index initial-index) + (return -1)) + (if (eq table-key key) + (return vector-index) + (when (eq table-key free-hash-marker) + (return -1))))))))) + +;;; As above, but note whether the key is in some way address-based +;;; and update the hash-vector's flags word if so. +;;; This only needs to be done by PUTHASH, and it only really needs +;;; to be done if we're adding a new key. +(defun eq-hash-find-for-put (hash key) + (declare (optimize (speed 3) (safety 0))) + (let* ((vector (nhash.vector hash)) + (hash-code + (let* ((typecode (typecode key))) + (if (eq typecode target::tag-fixnum) + (mixup-hash-code key) + (if (eq typecode target::subtag-instance) + (mixup-hash-code (instance.hash key)) + (if (symbolp key) + (%hash-symbol key) + (progn + (unless (immediate-p-macro key) + (update-hash-flags hash vector :key)) + (mixup-hash-code (strip-tag-to-fixnum key)))))))) + (entries (nhash.vector-size vector)) + (vector-index (index->vector-index (hash-mod hash-code entries vector))) + (table-key (%svref vector vector-index)) + (reuse (not (hash-lock-free-p hash)))) + (declare (fixnum hash-code vector-index)) + (if (or (eq key table-key) + (eq table-key free-hash-marker)) + vector-index + (let* ((secondary-hash (%svref secondary-keys-*-2 + (logand 7 hash-code))) + (initial-index vector-index) + (first-deleted-index (and reuse + (eq table-key deleted-hash-key-marker) + vector-index)) + (count (+ entries entries)) + (length (+ count $nhash.vector_overhead))) + (declare (fixnum secondary-hash initial-index count length)) + (loop + (incf vector-index secondary-hash) + (when (>= vector-index length) + (decf vector-index count)) + (setq table-key (%svref vector vector-index)) + (when (= vector-index initial-index) + (return (or first-deleted-index + (error "Bug: no room in table")))) + (if (eq table-key key) + (return vector-index) + (if (eq table-key free-hash-marker) + (return (or first-deleted-index vector-index)) + (if (and reuse + (null first-deleted-index) + (eq table-key deleted-hash-key-marker)) + (setq first-deleted-index vector-index))))))))) + +(defun eql-hash-find (hash key) + (declare (optimize (speed 3) (safety 0))) + (if (need-use-eql key) + (let* ((vector (nhash.vector hash)) + (hash-code (%%eqlhash-internal key)) + (entries (nhash.vector-size vector)) + (vector-index (index->vector-index (hash-mod hash-code entries vector))) + (table-key (%svref vector vector-index))) + (declare (fixnum hash-code entries vector-index)) + (if (eql key table-key) + vector-index + (if (eq table-key free-hash-marker) + -1 + (let* ((secondary-hash (%svref secondary-keys-*-2 + (logand 7 hash-code))) + (initial-index vector-index) + (count (+ entries entries)) + (length (+ count $nhash.vector_overhead))) + (declare (fixnum secondary-hash initial-index count length)) + (loop + (incf vector-index secondary-hash) + (when (>= vector-index length) + (decf vector-index count)) + (setq table-key (%svref vector vector-index)) + (when (= vector-index initial-index) + (return -1)) + (if (eql table-key key) + (return vector-index) + (when (eq table-key free-hash-marker) + (return -1)))))))) + (eq-hash-find hash key))) + +(defun eql-hash-find-for-put (hash key) + (declare (optimize (speed 3) (safety 0))) + (if (need-use-eql key) + (let* ((vector (nhash.vector hash)) + (hash-code (%%eqlhash-internal key)) + (entries (nhash.vector-size vector)) + (vector-index (index->vector-index (hash-mod hash-code entries vector))) + (table-key (%svref vector vector-index)) + (reuse (not (hash-lock-free-p hash)))) + (declare (fixnum hash-code entries vector-index)) + (if (or (eql key table-key) + (eq table-key free-hash-marker)) + vector-index + (let* ((secondary-hash (%svref secondary-keys-*-2 + (logand 7 hash-code))) + (initial-index vector-index) + (first-deleted-index (and reuse + (eq table-key deleted-hash-key-marker) + vector-index)) + (count (+ entries entries)) + (length (+ count $nhash.vector_overhead))) + (declare (fixnum secondary-hash initial-index count length)) + (loop + (incf vector-index secondary-hash) + (when (>= vector-index length) + (decf vector-index count)) + (setq table-key (%svref vector vector-index)) + (when (= vector-index initial-index) + (return (or first-deleted-index + (error "Bug: no room in table")))) + (if (eql table-key key) + (return vector-index) + (if (eq table-key free-hash-marker) + (return (or first-deleted-index vector-index)) + (if (and reuse + (null first-deleted-index) + (eq table-key deleted-hash-key-marker)) + (setq first-deleted-index vector-index)))))))) + (eq-hash-find-for-put hash key))) + +(defun %make-rehash-bits (hash &optional (size (nhash.vector-size (nhash.vector hash)))) + (declare (fixnum size)) + (let ((rehash-bits (nhash.rehash-bits hash))) + (unless (and rehash-bits + (>= (uvsize rehash-bits) size)) + (return-from %make-rehash-bits + (setf (nhash.rehash-bits hash) (make-array size :element-type 'bit :initial-element 0)))) + (fill (the simple-bit-vector rehash-bits) 0))) + +;;; Rehash. Caller should have exclusive access to the hash table +;;; and have disabled interrupts. +(defun %rehash (hash) + (when (hash-lock-free-p hash) + (error "How did we get here?")) + (let* ((vector (nhash.vector hash)) + (flags (nhash.vector.flags vector)) + (vector-index (- $nhash.vector_overhead 2)) + (size (nhash.vector-size vector)) + (rehash-bits (%make-rehash-bits hash size)) + (index -1)) + (declare (fixnum size index vector-index)) + (setf (nhash.vector.flags vector) + (logand flags $nhash-clear-key-bits-mask)) + (setf (nhash.vector.cache-key vector) free-hash-marker + (nhash.vector.cache-value vector) nil) + (%set-does-not-need-rehashing vector) + (loop + (when (>= (incf index) size) (return)) + (setq vector-index (+ vector-index 2)) + (unless (%already-rehashed-p index rehash-bits) + (let* ((key (%svref vector vector-index)) + (deleted (eq key deleted-hash-key-marker))) + (unless + (when (or deleted (eq key free-hash-marker)) + (if deleted ; one less deleted entry + (let ((count (1- (nhash.vector.deleted-count vector)))) + (declare (fixnum count)) + (setf (nhash.vector.deleted-count vector) count) + (if (< count 0) + (let ((wdc (nhash.vector.weak-deletions-count vector))) + (setf (nhash.vector.weak-deletions-count vector) 0) + (incf (nhash.vector.deleted-count vector) wdc) + (decf (nhash.vector.count vector) wdc))) + (incf (nhash.grow-threshold hash)) + ;; Change deleted to free + (setf (%svref vector vector-index) free-hash-marker))) + t) + (let* ((last-index index) + (value (%svref vector (the fixnum (1+ vector-index)))) + (first t)) + (loop + (let ((vector (nhash.vector hash)) + (found-index (%rehash-probe rehash-bits hash key))) + (%set-already-rehashed-p found-index rehash-bits) + (if (eq last-index found-index) + (return) + (let* ((found-vector-index (index->vector-index found-index)) + (newkey (%svref vector found-vector-index)) + (newvalue (%svref vector (the fixnum (1+ found-vector-index))))) + (declare (fixnum found-vector-index)) + (when first ; or (eq last-index index) ? + (setq first nil) + (setf (%svref vector vector-index) free-hash-marker) + (setf (%svref vector (the fixnum (1+ vector-index))) free-hash-marker)) + (%set-hash-table-vector-key vector found-vector-index key) + (setf (%svref vector (the fixnum (1+ found-vector-index))) value) + (when (or (eq newkey free-hash-marker) + (setq deleted (eq newkey deleted-hash-key-marker))) + (when deleted + (let ((count (1- (nhash.vector.deleted-count vector)))) + (declare (fixnum count)) + (setf (nhash.vector.deleted-count vector) count) + (if (< count 0) + (let ((wdc (nhash.vector.weak-deletions-count vector))) + (setf (nhash.vector.weak-deletions-count vector) 0) + (incf (nhash.vector.deleted-count vector) wdc) + (decf (nhash.vector.count vector) wdc))) + (incf (nhash.grow-threshold hash)))) + (return)) + (when (eq key newkey) + (cerror "Delete one of the entries." "Duplicate key: ~s in ~s ~s ~s ~s ~s" + key hash value newvalue index found-index) + (decf (nhash.vector.count vector)) + (incf (nhash.grow-threshold hash)) + (return)) + (setq key newkey + value newvalue + last-index found-index))))))))))) + t ) + +;;; Hash to an index that is not set in rehash-bits + +(defun %rehash-probe (rehash-bits hash key &optional (vector (nhash.vector hash))) + (declare (optimize (speed 3)(safety 0))) + (multiple-value-bind (hash-code index entries)(compute-hash-code hash key t vector) + (declare (fixnum hash-code index entries)) + (when (null hash-code)(cerror "nuts" "Nuts")) + (let* ((vector-index (index->vector-index index))) + (if (or (not (%already-rehashed-p index rehash-bits)) + (eq key (%svref vector vector-index))) + (return-from %rehash-probe index) + (let ((second (%svref secondary-keys (%ilogand 7 hash-code)))) + (declare (fixnum second)) + (loop + (setq index (+ index second)) + (when (>= index entries) + (setq index (- index entries))) + (when (or (not (%already-rehashed-p index rehash-bits)) + (eq key (%svref vector (index->vector-index index)))) + (return-from %rehash-probe index)))))))) + +;;; Returns one value: the index of the entry in the vector +;;; Since we're growing, we don't need to compare and can't find a key that's +;;; already there. +(defun %growhash-probe (vector hash key) + (declare (optimize (speed 3)(safety 0))) + (multiple-value-bind (hash-code index entries)(compute-hash-code hash key t vector) + (declare (fixnum hash-code index entries)) + (let* ((vector-index (index->vector-index index)) + (vector-key nil)) + (declare (fixnum vector-index)) + (if (or (eq free-hash-marker + (setq vector-key (%svref vector vector-index))) + (eq deleted-hash-key-marker vector-key)) + (return-from %growhash-probe index) + (let ((second (%svref secondary-keys (%ilogand 7 hash-code)))) + (declare (fixnum second)) + (loop + (setq index (+ index second)) + (when (>= index entries) + (setq index (- index entries))) + (when (or (eq free-hash-marker + (setq vector-key (%svref vector (index->vector-index index)))) + (eq deleted-hash-key-marker vector-key)) + (return-from %growhash-probe index)))))))) + +;;;;;;;;;;;;; +;; +;; Mapping functions are in "ccl:lib;hash" +;; + + + +;;;;;;;;;;;;; +;; +;; Hashing functions +;; EQ & the EQ part of EQL are done in-line. +;; + + + + + + + + + +;;; so whats so special about bit vectors as opposed to any other vectors of bytes +;;; For starters, it's guaranteed that they exist in the implementation; that may +;;; not be true of other immediate vector types. +(defun bit-vector-hash (bv) + (declare (optimize (speed 3)(safety 0))) + (let ((length (length bv))) + (declare (fixnum length)) ;will this always be true? it's true of all vectors. + (multiple-value-bind (data offset) (array-data-and-offset bv) + (declare (type simple-bit-vector data) (fixnum offset)) + (let* ((hash 0) + (limit (+ length offset)) + (nbytes (ash (the fixnum (+ length 7)) -3))) + (declare (fixnum hash limit nbytes)) + (dotimes (i nbytes (mixup-hash-code hash)) + (let* ((w 0)) + (declare (fixnum w)) + (dotimes (j 8 (setq hash (+ (the fixnum (ash hash -3)) w))) + (setq w (the fixnum + (logxor + (the fixnum + (ash (if (< offset limit) + (the fixnum (sbit data offset)) + 0) + (the fixnum j))) + w))) + (incf offset)))))))) + +#| +(defun bit-vector-hash (bv) + (declare (optimize (speed 3)(safety 0))) + (let ((length (length bv))) + (declare (fixnum length)) + (let* ((all (+ length 15)) + (nwds (ash all -4)) + (rem (logand all 15)) + (hash 0) + (mask (ash (the fixnum (1- (the fixnum (expt 2 rem))))(the fixnum(- 16 rem))))) + (declare (fixnum all nwds rem hash mask)) + (multiple-value-bind (data offset) + (array-data-and-offset bv) + (declare (fixnum offset)) + (locally (declare (type (simple-array (unsigned-byte 16) (*)) data)) + (dotimes (i nwds) + (setq hash (%i+ hash (aref data (the fixnum (+ i offset)))))) + (when (neq 0 mask) + (setq hash (%i+ hash (%ilogand mask (aref data (the fixnum (+ offset nwds))))))) + (mixup-hash-code hash)))))) +|# + + +;;; Same as %%equalhash, but different: +;;; 1) Real numbers are hashed as if they were double-floats. The real components of complex numbers +;;; are hashed as double-floats and XORed together. +;;; 2) Characters and strings are hashed in a case-insensitive manner. +;;; 3) Hash tables are hashed based on their size and type. +;;; 4) Structures and CL array types are hashed based on their content. + + +;;; check fixnum befor immediate-p. call %%eqlhash + +(defun %%equalphash (key) + (cond ((or (fixnump key)(short-float-p key)) + (%dfloat-hash (float key 1.0d0))) + ((immediate-p-macro key) + (mixup-hash-code (strip-tag-to-fixnum (if (characterp key)(char-upcase key) key)))) + ((bignump key) + (if (<= most-negative-double-float key most-positive-double-float) + (%dfloat-hash (float key 1.0d0)) ; with-stack-double-floats + (%%eqlhash-internal key))) + ((double-float-p key) + (%dfloat-hash key)) + ((ratiop key) + (%ilogxor (%%equalphash (numerator key)) (%%equalphash (denominator key)))) + ((complexp key) + (%ilogxor (%%equalphash (realpart key)) (%%equalphash (imagpart key)))) + ((hash-table-p key) + (equalphash-hash-table key)) + ((or (istructp key) + (structurep key)) ; was (gvectorp key) + (%%equalphash-structure 11 key)) + ((or (arrayp key)) ;(uvectorp key)) ;?? + (%%equalphash-array 11 key)) + ((consp key) + (%%equalphash-aux 11 key)) + (t (%%eqlhash key)))) + + +(defun equalphash-hash-table (hash-table) + (let ((hash (%%equalhash "HASH-TABLE")) + addressp) + (declare (fixnum hash)) + (incf hash (the fixnum (%%eqhash (hash-table-count hash-table)))) + (multiple-value-bind (h ap) (%%eqhash (nhash.comparef hash-table)) + (declare (fixnum h)) + (incf hash h) + (if ap (setq addressp t))) + (multiple-value-bind (h ap) (%%eqhash (nhash.keytransF hash-table)) + (declare (fixnum h)) + (incf hash h) + (if ap (setq addressp t))) + (values hash addressp))) + +(defun %%equalphash-structure (limit key) + (let* ((size (uvsize key)) + (hash (mixup-hash-code size)) + addressp) + (declare (fixnum limit size hash)) + (dotimes (i size) + (multiple-value-bind (h ap) (%%equalphash-aux limit (%svref key i)) + (declare (fixnum h)) + (setq hash (the fixnum (+ (the fixnum (rotate-hash-code hash)) h))) + (if ap (setq addressp t))) + (when (<= (decf limit) 0) + (setq hash (the fixnum (+ (the fixnum (rotate-hash-code hash)) + (the fixnum (mixup-hash-code 11))))) + (return))) + (values hash addressp))) + +(defun %%equalphash-array (limit key) + (multiple-value-bind (array offset) (array-data-and-offset key) + (let* ((rank (array-rank key)) + (vectorp (eql rank 1)) + (size (if vectorp (length key) (array-total-size key))) + (hash (mixup-hash-code rank)) + addressp) + (declare (fixnum size hash limit rank)) + (if vectorp + (setq hash + (the fixnum + (+ (the fixnum (rotate-hash-code hash)) + (the fixnum (mixup-hash-code size))))) + (dotimes (i rank) + (declare (fixnum i)) + (setq hash + (the fixnum + (+ (the fixnum (rotate-hash-code hash)) + (the fixnum + (mixup-hash-code (array-dimension key i)))))))) + (dotimes (i size) + (declare (fixnum i)) + (multiple-value-bind (h ap) (%%equalphash-aux limit (uvref array offset)) + (declare (fixnum h)) + (setq hash (the fixnum (+ (the fixnum (rotate-hash-code hash)) h))) + (if ap (setq addressp t))) + (when (<= (decf limit) 0) + (setq hash (the fixnum (+ (the fixnum (rotate-hash-code hash)) + (the fixnum (mixup-hash-code 11))))) + (return)) + (incf offset)) + (values hash addressp)))) + +(defun %%equalphash-aux (limit key) + (if (<= limit 0) + (mixup-hash-code 11) + (if (null key) (mixup-hash-code 17) + (cond ((consp key) + (let ((hash 0) + address-p) + (do ((l limit (1- l))) + ((eq l 0)(values hash address-p)) + (multiple-value-bind (ahash ap) + (%%equalphash-aux l (if (consp key)(car key) key)) + (setq hash (mixup-hash-code (logxor ahash hash))) + (if ap (setq address-p t))) + (when (not (consp key)) + (return (values hash address-p))) + (setq key (cdr key))))) + ((typep key 'hash-table) + (equalphash-hash-table key)) + ; what are the dudes called that contain bits? they are uvectors but not gvectors? + ; ivectors. + ((or (istructp key) + (structurep key)) ;was (gvectorp key) + (%%equalphash-structure limit key)) + ((or (arrayp key)) ; (uvectorp key)) + (%%equalphash-array limit key)) + (t (%%equalphash key)))))) + +(defun alist-hash-table (alist &rest hash-table-args) + (declare (dynamic-extent hash-table-args)) + (if (typep alist 'hash-table) + alist + (let ((hash-table (apply #'make-hash-table hash-table-args))) + (dolist (cons alist) (puthash (car cons) hash-table (cdr cons))) + hash-table))) + +(defun %hash-table-equalp (x y) + ;; X and Y are both hash tables + (and (eq (hash-table-test x) + (hash-table-test y)) + (eql (hash-table-count x) + (hash-table-count y)) + (block nil + (let* ((default (cons nil nil)) + (foo #'(lambda (k v) + (let ((y-value (gethash k y default))) + (unless (and (neq default y-value) + (equalp v y-value)) + (return nil)))))) + (declare (dynamic-extent foo default)) + (maphash foo x)) + t))) + +(defun sxhash (s-expr) + "Computes a hash code for S-EXPR and returns it as an integer." + (logand (sxhash-aux s-expr 7 17) target::target-most-positive-fixnum)) + +(defun sxhash-aux (expr counter key) + (declare (fixnum counter)) + (if (> counter 0) + (typecase expr + ((or string bit-vector number character) (+ key (%%equalhash expr))) + (logical-pathname + (dotimes (i (uvsize expr) key) + (declare (fixnum i)) + (setq key (+ key (sxhash-aux (%svref expr i) (1- counter) key))))) + (pathname + ;; Don't consider %PHYSICAL-PATHNAME-VERSION to be significant + (dotimes (i (uvsize expr) key) + (declare (fixnum i)) + (unless (= i %physical-pathname-version) + (setq key (+ key (sxhash-aux (%svref expr i) (1- counter) key)))))) + (symbol (+ key (%%equalhash (symbol-name expr)))) + (cons (sxhash-aux + (cdr expr) + (the fixnum (1- counter)) + (+ key (sxhash-aux (car expr) (the fixnum (1- counter)) key)))) + (t (+ key (%%equalhash (symbol-name (%type-of expr)))))) + key)) + + + +#+(or ppc32-target x8632-target) +(defun immediate-p (thing) + (let* ((tag (lisptag thing))) + (declare (fixnum tag)) + (or (= tag target::tag-fixnum) + (= tag target::tag-imm)))) + +#+ppc64-target +(defun immediate-p (thing) + (let* ((tag (lisptag thing))) + (declare (fixnum tag)) + (or (= tag ppc64::tag-fixnum) + (= (logand tag ppc64::lowtagmask) ppc64::lowtag-imm)))) + +#+x8664-target +(defun immediate-p (thing) + (let* ((tag (lisptag thing))) + (declare (type (unsigned-byte 3) tag)) + (logbitp tag + (logior (ash 1 x8664::tag-fixnum) + (ash 1 x8664::tag-imm-0) + (ash 1 x8664::tag-imm-1))))) + + + +(defun %cons-nhash-vector (size &optional (flags 0)) + (declare (fixnum size)) + (let* ((vector (%alloc-misc (+ (+ size size) $nhash.vector_overhead) target::subtag-hash-vector free-hash-marker))) + (%init-nhash-vector vector flags) + vector)) + +(defun %init-nhash-vector (vector flags) + (let ((size (vector-index->index (uvsize vector)))) + (declare (fixnum size)) + (setf (nhash.vector.link vector) 0 + (nhash.vector.flags vector) flags + (nhash.vector.gc-count vector) (%get-gc-count) + (nhash.vector.free-alist vector) nil + (nhash.vector.finalization-alist vector) nil + (nhash.vector.weak-deletions-count vector) 0 + (nhash.vector.hash vector) nil + (nhash.vector.deleted-count vector) 0 + (nhash.vector.count vector) 0 + (nhash.vector.cache-key vector) free-hash-marker + (nhash.vector.cache-value vector) nil + (nhash.vector.cache-idx vector) nil + (nhash.vector.size vector) size + (nhash.vector.size-reciprocal vector) (floor (ash 1 (- target::nbits-in-word target::fixnumshift)) size)))) + +(defun assert-hash-table-readonly (hash) + (unless (typep hash 'hash-table) + (report-bad-arg hash 'hash-table)) + (or (nhash.read-only hash) + (when (nhash.owner hash) + (error "Hash~table ~s is thread-private and can't be made read-only for that reason" hash)) + (if (hash-lock-free-p hash) + (setf (nhash.read-only hash) t) + (with-lock-context + (without-interrupts + (write-lock-hash-table hash) + (let* ((flags (nhash.vector.flags (nhash.vector hash)))) + (declare (fixnum flags)) + (when (or (logbitp $nhash_track_keys_bit flags) + (logbitp $nhash_component_address_bit flags)) + (format t "~&Hash-table ~s uses address-based hashing and can't yet be made read-only for that reason." hash) + (unlock-hash-table hash nil) + (return-from assert-hash-table-readonly nil)) + (setf (nhash.read-only hash) t) + (unlock-hash-table hash nil) + t)))))) + +;; This is dangerous, if multiple threads are accessing a read-only +;; hash table. Use it responsibly. +(defun assert-hash-table-writeable (hash) + (unless (typep hash 'hash-table) + (report-bad-arg hash 'hash-table)) + (when (nhash.read-only hash) + (setf (nhash.read-only hash) nil) + t)) + +(defun readonly-hash-table-p (hash) + (unless (typep hash 'hash-table) + (report-bad-arg hash 'hash-table)) + (nhash.read-only hash)) + +(defun hash-table-owner (hash) + (unless (typep hash 'hash-table) + (report-bad-arg hash 'hash-table)) + (nhash.owner hash)) + +(defun claim-hash-table (hash &optional steal) + (unless (typep hash 'hash-table) + (report-bad-arg hash 'hash-table)) + (let* ((owner (nhash.owner hash))) + (if owner + (or (eq owner *current-process*) + (when steal + (setf (nhash.owner hash) *current-process*))) + (progn + (unless (hash-lock-free-p hash) + (write-lock-hash-table hash) + (setf (nhash.exclusion-lock hash) nil)) + (setf (nhash.owner hash) *current-process*) + t)))) + + +;; ** TODO: for lock-free hash tables, we don't need to copy, +;; we could map over the actual hash table vector, because it's +;; always valid. +(defun lock-free-enumerate-hash-keys-and-values (hash keys values) + (do* ((in (nhash.vector hash)) + (in-idx $nhash.vector_overhead (+ in-idx 2)) + (insize (uvsize in)) + (outsize (length (or keys values))) + (out-idx 0)) + ((or (= in-idx insize) + (= out-idx outsize)) + out-idx) + (declare (fixnum in-idx insize out-idx outsize)) + (let* ((key (%svref in in-idx))) + (unless (eq key free-hash-marker) + (let ((val (%svref in (%i+ in-idx 1)))) + (when (eq val rehashing-value-marker) + ;; This table is being rehashed. Wait to finish and try again + (lock-free-rehash hash) + (return-from lock-free-enumerate-hash-keys-and-values + (lock-free-enumerate-hash-keys-and-values hash keys values))) + (unless (eq val free-hash-marker) + (when (eql key deleted-hash-key-marker) + (error "Bug: deleted key but not value?")) + (when keys (setf (%svref keys out-idx) key)) + (when values (setf (%svref values out-idx) val)) + (incf out-idx))))))) + +(defun enumerate-hash-keys-and-values (hash keys values) + (unless (typep hash 'hash-table) + (report-bad-arg hash 'hash-table)) + (when (hash-lock-free-p hash) + (return-from enumerate-hash-keys-and-values + (lock-free-enumerate-hash-keys-and-values hash keys values))) + (with-lock-context + (without-interrupts + (let* ((readonly (eq (read-lock-hash-table hash) :readonly))) + (do* ((in (nhash.vector hash)) + (in-idx $nhash.vector_overhead (+ in-idx 2)) + (insize (uvsize in)) + (outsize (length (or keys values))) + (out-idx 0)) + ((or (= in-idx insize) + (= out-idx outsize)) + (unlock-hash-table hash readonly) + out-idx) + (declare (fixnum in-idx insize out-idx outsize)) + (let* ((key (%svref in in-idx))) + (unless (or (eq key free-hash-marker) + (eq key deleted-hash-key-marker)) + (when keys + (setf (%svref keys out-idx) key)) + (when values + (setf (%svref values out-idx) (%svref in (%i+ in-idx 1)))) + (incf out-idx)))))))) + +(defun enumerate-hash-keys (hash out) + (enumerate-hash-keys-and-values hash out nil)) Index: /branches/new-random/level-0/l0-init.lisp =================================================================== --- /branches/new-random/level-0/l0-init.lisp (revision 13309) +++ /branches/new-random/level-0/l0-init.lisp (revision 13309) @@ -0,0 +1,172 @@ +;;;-*-Mode: LISP; Package: CCL -*- +;;; +;;; Copyright (C) 2009 Clozure Associates +;;; Copyright (C) 1994-2001 Digitool, Inc +;;; This file is part of Clozure CL. +;;; +;;; Clozure CL is licensed under the terms of the Lisp Lesser GNU Public +;;; License , known as the LLGPL and distributed with Clozure CL as the +;;; file "LICENSE". The LLGPL consists of a preamble and the LGPL, +;;; which is distributed with Clozure CL as the file "LGPL". Where these +;;; conflict, the preamble takes precedence. +;;; +;;; Clozure CL is referenced in the preamble as the "LIBRARY." +;;; +;;; The LLGPL is also available online at +;;; http://opensource.franz.com/preamble.html + +(in-package "CCL") + +(defconstant array-total-size-limit + #.(expt 2 (- target::nbits-in-word target::num-subtag-bits)) + "the exclusive upper bound on the total number of elements in an array") + + +;Features for #+/- conditionalization: +(defparameter *features* + '(:common-lisp + :openmcl + :ccl + :ccl-1.2 + :ccl-1.3 + :ccl-1.4 + :clozure + :clozure-common-lisp + :ansi-cl + #-windows-target :unix + :openmcl-unicode-strings + ;; Threads and MOP stuff is pretty redundant. + :openmcl-native-threads + :openmcl-partial-mop + :mcl-common-mop-subset + :openmcl-mop-2 + ;; Thread-private hash-tables were introduced in version 1.0 + :openmcl-private-hash-tables + ;; Hash-consing support (special primitives for allocating + ;; and managing statically allocated CONS cells) will be + ;; added in 1.1 + ;; Was dropped in 1.2 + ;; :openmcl-hash-consing + #+eabi-target :eabi-target + #+ppc-target :powerpc + #+ppc-target :ppc-target + #+ppc-target :ppc-clos ; used in encapsulate + #+ppc32-target :ppc32-target + #+ppc32-target :ppc32-host + #+ppc64-target :ppc64-target + #+ppc64-target :ppc64-host + #+x8632-target :x8632-target + #+x8632-target :x8632-host + #+x8664-target :x86-64 + #+x8664-target :x86_64 + #+x8632-target :x86 + #+x86-target :x86-target + #+x86-target :x86-host + #+x8664-target :x8664-target + #+x8664-target :x8664-host + #+linux-target :linux-host + #+linux-target :linux-target + #+linuxppc-target :linuxppc-target + #+linuxppc-target :linuxppc-host + #+linuxx86-target :linuxx86-target + #+linuxx8664-target :linuxx8664-target + #+linuxx8664-target :linuxx8664-host + #+linuxx8632-target :linuxx8632-target + #+linuxx8632-target :linuxx8632-host + #+darwinppc-target :darwinppc-target + #+darwinppc-target :darwinppc-host + #+darwinppc-target :darwin-target + #+freebsd-target :freebsd-host + #+freebsd-target :freebsd-target + #+freebsdx86-target :freebsdx86-target + #+freebsdx8664-target :freebsdx8664-target + #+freebsdx8664-target :freebsdx8664-host + #+freebsdx8632-target :freebsdx8632-target + #+freebsdx8632-target :freebsdx8632-host + #+darwin-target :darwin-host + #+darwin-target :darwin-target + #+darwinx86-target :darwinx86-target + #+darwinx8632-target :darwinx8632-target + #+darwinx8632-target :darwinx8632-host + #+darwinx8664-target :darwinx8664-target + #+darwinx8664-target :darwinx8664-host + #+windows-target :windows-host + #+windows-target :windows-target + #+win64-target :win64-target + #+win64-target :win64-host + #+win32-target :win32-target + #+win32-target :win32-host + #+solaris-target :solaris-host + #+solaris-target :solaris-target + #+solarisx86-target :solarisx86-target + #+solarisx8664-target :solarisx8664-target + #+solarisx8664-target :solarisx8664-host + #+solarisx8632-target :solarisx8632-target + #+solarisx8632-target :solarisx8632-host + #+(and ppc-target poweropen-target) :poweropen-target + #+64-bit-target :64-bit-target + #+64-bit-target :64-bit-host + #+32-bit-target :32-bit-target + #+32-bit-target :32-bit-host + #+ppc-target :big-endian-target + #+ppc-target :big-endian-host + #+x86-target :little-endian-target + #+x86-target :little-endian-host + #+darwin-target :darwin + #+linux-target :linux + #+freebsd-target :freebsd + #+solaris-target :solaris + #+windows-target :windows + ) + "a list of symbols that describe features provided by the + implementation") + +(defparameter *optional-features* () "Set by build process") + +(defparameter *load-verbose* nil + "the default for the :VERBOSE argument to LOAD") + +;All Lisp package variables... Dunno if this still matters, but it +;used to happen in the kernel... +(dolist (x '(* ** *** *APPLYHOOK* *DEBUG-IO* + *DEFAULT-PATHNAME-DEFAULTS* *ERROR-OUTPUT* *EVALHOOK* + *FEATURES* *LOAD-VERBOSE* *MACROEXPAND-HOOK* *MODULES* + *PACKAGE* *PRINT-ARRAY* *PRINT-BASE* *PRINT-CASE* *PRINT-CIRCLE* + *PRINT-ESCAPE* *PRINT-GENSYM* *PRINT-LENGTH* *PRINT-LEVEL* + *PRINT-PRETTY* *PRINT-RADIX* *QUERY-IO* *RANDOM-STATE* *READ-BASE* + *READ-DEFAULT-FLOAT-FORMAT* *READ-SUPPRESS* *READTABLE* + *STANDARD-INPUT* *STANDARD-OUTPUT* *TERMINAL-IO* *TRACE-OUTPUT* + + ++ +++ - / // /// ARRAY-DIMENSION-LIMIT ARRAY-RANK-LIMIT + ARRAY-TOTAL-SIZE-LIMIT BOOLE-1 BOOLE-2 BOOLE-AND BOOLE-ANDC1 + BOOLE-ANDC2 BOOLE-C1 BOOLE-C2 BOOLE-CLR BOOLE-EQV BOOLE-IOR + BOOLE-NAND BOOLE-NOR BOOLE-ORC1 BOOLE-ORC2 BOOLE-SET BOOLE-XOR + CALL-ARGUMENTS-LIMIT CHAR-CODE-LIMIT + DOUBLE-FLOAT-EPSILON DOUBLE-FLOAT-NEGATIVE-EPSILON + INTERNAL-TIME-UNITS-PER-SECOND LAMBDA-LIST-KEYWORDS + LAMBDA-PARAMETERS-LIMIT LEAST-NEGATIVE-DOUBLE-FLOAT + LEAST-NEGATIVE-LONG-FLOAT LEAST-NEGATIVE-SHORT-FLOAT + LEAST-NEGATIVE-SINGLE-FLOAT LEAST-POSITIVE-DOUBLE-FLOAT + LEAST-POSITIVE-LONG-FLOAT LEAST-POSITIVE-SHORT-FLOAT + LEAST-POSITIVE-SINGLE-FLOAT LONG-FLOAT-EPSILON + LONG-FLOAT-NEGATIVE-EPSILON MOST-NEGATIVE-DOUBLE-FLOAT + MOST-NEGATIVE-FIXNUM MOST-NEGATIVE-LONG-FLOAT + MOST-NEGATIVE-SHORT-FLOAT MOST-NEGATIVE-SINGLE-FLOAT + MOST-POSITIVE-DOUBLE-FLOAT MOST-POSITIVE-FIXNUM + MOST-POSITIVE-LONG-FLOAT MOST-POSITIVE-SHORT-FLOAT + MOST-POSITIVE-SINGLE-FLOAT MULTIPLE-VALUES-LIMIT PI + SHORT-FLOAT-EPSILON SHORT-FLOAT-NEGATIVE-EPSILON + SINGLE-FLOAT-EPSILON SINGLE-FLOAT-NEGATIVE-EPSILON)) + (%symbol-bits x (%ilogior2 (%symbol-bits x) (ash 1 $sym_bit_special)))) + +(defparameter *loading-file-source-file* nil) +(defparameter *loading-toplevel-location* nil) + +(defvar *nx-speed* 1) +(defvar *nx-space* 1) +(defvar *nx-safety* 1) +(defvar *nx-cspeed* 1) +(defvar *nx-debug* 1) + +(defparameter *case-sensitive-filesystem* t) + +;;; end Index: /branches/new-random/level-0/l0-int.lisp =================================================================== --- /branches/new-random/level-0/l0-int.lisp (revision 13309) +++ /branches/new-random/level-0/l0-int.lisp (revision 13309) @@ -0,0 +1,189 @@ +;;;-*- Mode: Lisp; Package: CCL -*- +;;; +;;; Copyright (C) 2009 Clozure Associates +;;; Copyright (C) 1994-2001 Digitool, Inc +;;; This file is part of Clozure CL. +;;; +;;; Clozure CL is licensed under the terms of the Lisp Lesser GNU Public +;;; License , known as the LLGPL and distributed with Clozure CL as the +;;; file "LICENSE". The LLGPL consists of a preamble and the LGPL, +;;; which is distributed with Clozure CL as the file "LGPL". Where these +;;; conflict, the preamble takes precedence. +;;; +;;; Clozure CL is referenced in the preamble as the "LIBRARY." +;;; +;;; The LLGPL is also available online at +;;; http://opensource.franz.com/preamble.html + +(in-package "CCL") + +(eval-when (:compile-toplevel :execute) + (require "NUMBER-MACROS") + (require "NUMBER-CASE-MACRO") +) + + +(defun lsh (fixnum count) + (require-type fixnum 'fixnum) + (require-type count 'fixnum) + (if (> count 0) + (%ilsl count fixnum) + (%ilsr (- count) fixnum))) + +; this called with fixnum +(defun %iabs (n) + (declare (fixnum n)) + (if (minusp n) (- n) n)) + +; called with any integer - is there a cmu version of integer/bignum-abs? +(defun %integer-abs (n) + (number-case n + (fixnum + (locally + (declare (fixnum n)) + (if (minusp n) (- n) n))) + (bignum + (if (minusp n) (- n) n)))) + + +(eval-when (:compile-toplevel :execute) + (assert (< (char-code #\9) (char-code #\A) (char-code #\a)))) + +(defun token2int (string start len radix) + ; simple minded in case you hadn't noticed + (let* ((n start) + (end (+ start len)) + (char0 (schar string n)) + (val 0) + minus) + (declare (fixnum n end start len radix)) ; as if it mattered + (when (or (eq char0 #\+)(eq char0 #\-)) + (setq n (1+ n)) + (if (eq char0 #\-)(setq minus t))) + (while (< n end) + (let ((code (%scharcode string n))) + (if (<= code (char-code #\9)) + (setq code (- code (char-code #\0))) + (progn + (when (>= code (char-code #\a)) + (setq code (- code (- (char-code #\a) (char-code #\A))))) + (setq code (- code (- (char-code #\A) 10))))) + (setq val (+ (* val radix) code)) + (setq n (1+ n)))) + (if minus (- val) val))) + + +(defun %integer-to-string (int &optional (radix 10)) + (%pr-integer int radix nil t)) + + +;;; it may be hard to believe, but this is much faster than the lap +;;; version (3 or 4X) for fixnums that is (stream-write-string vs +;;; stream-tyo ???) + +(defun %pr-integer (int &optional (radix 10) (stream *standard-output*) return-it negate-it) + (declare (fixnum radix)) ; assume caller has checked + (if stream + (if (eq stream t) (setq stream *terminal-io*)) + (setq stream *standard-output*)) + (let ((digit-string "0123456789ABCDEFGHIJKLMNOPQRSTUVWXYZ")) + (cond ((fixnump int) ; ugh + (let ((temstring (make-string (- target::nbits-in-word target::fixnumshift) :element-type 'base-char)) + (i (- target::nbits-in-word target::fixnumshift 1)) + (neg (< int 0)) + (rem 0)) + (declare (fixnum i rem)) + (declare (dynamic-extent temstring)) + (when neg (setq int (- int))) + (when (not (fixnump int)) + (return-from %pr-integer (%pr-integer int radix stream return-it t))) + (locally (declare (fixnum int)) + (loop + (multiple-value-setq (int rem) (%fixnum-truncate int radix)) + (setf (%schar temstring i)(%schar digit-string rem)) + (when (eq 0 int) + (return)) + (setq i (1- i))) + (when neg + (setf (%schar temstring (setq i (1- i))) #\-)) + (if return-it + (%substr temstring i (- target::nbits-in-word + target::fixnumshift)) + (write-string temstring stream :start i :end (- target::nbits-in-word target::fixnumshift)))))) + (t (let* ((size-vect #(nil nil 32 21 16 14 13 12 11 + 11 10 10 9 9 9 9 8 8 + 8 8 8 8 8 8 7 7 7 + 7 7 7 7 7 7 7 7 7 7)) + ;; overestimate # digits by a little for weird + ;; radix + (bigwords (uvsize int)) + (strlen (1+ (* bigwords (svref size-vect radix)))) + (temstring (make-string strlen :element-type 'base-char)) + (i (1- strlen)) + (neg (< int 0)) + ; ;(rem 0) + ;; ;better-bignum-print? + ) ; warn + (declare (dynamic-extent temstring) + (fixnum i strlen)) + (flet ((do-it (newbig) + (print-bignum-2 newbig radix temstring digit-string))) + (declare (dynamic-extent #'do-it)) + (setq i (with-one-negated-bignum-buffer int do-it))) + (when (or neg negate-it) + (setf (%schar temstring (setq i (1- i))) #\-)) + (if return-it + (%substr temstring i strlen) + (write-string temstring stream :start i :end strlen))))))) + + + +;;; *BASE-POWER* holds the number that we keep dividing into the bignum for +;;; each *print-base*. We want this number as close to *most-positive-fixnum* +;;; as possible, i.e. (floor (log most-positive-fixnum *print-base*)). +;;; +(defparameter *base-power* ()) + +;;; *FIXNUM-POWER--1* holds the number of digits for each *print-base* that +;;; fit in the corresponding *base-power*. +;;; +(defparameter *fixnum-power--1* ()) + +(do* ((b (make-array 37 :initial-element nil)) + (f (make-array 37 :initial-element nil)) + (base 2 (1+ base))) + ((= base 37) (setq *base-power* b *fixnum-power--1* f)) + (do ((power-1 -1 (1+ power-1)) + (new-divisor base (* new-divisor base)) + (divisor 1 new-divisor)) + ((not (fixnump new-divisor)) + (setf (aref b base) divisor) + (setf (aref f base) power-1)))) + + +(defun print-bignum-2 (big radix string digit-string) + (declare (optimize (speed 3) (safety 0)) + (simple-base-string string digit-string)) + (let* ((divisor (aref *base-power* radix)) + (power (aref *fixnum-power--1* radix)) + (index (1- (length string))) + (rem 0)) + (declare (fixnum index divisor power)) + ;;(print index) + (loop + (multiple-value-setq (big rem) (truncate big divisor)) + (let* ((int rem) + (rem 0) + (final-index (- index power 1))) + (loop + (multiple-value-setq (int rem) (%fixnum-truncate int radix)) + (setf (schar string index)(schar digit-string rem)) + (when (eql 0 int) + (return index)) + (setq index (1- index))) + (if (zerop big) + (return index) + (dotimes (i (- index final-index) index) + (declare (fixnum i)) + (setq index (1- index)) + (setf (schar string index) #\0))))))) Index: /branches/new-random/level-0/l0-io.lisp =================================================================== --- /branches/new-random/level-0/l0-io.lisp (revision 13309) +++ /branches/new-random/level-0/l0-io.lisp (revision 13309) @@ -0,0 +1,316 @@ +; -*- Mode: Lisp; Package: CCL; -*- +;;; +;;; Copyright (C) 2009 Clozure Associates +;;; Copyright (C) 1994-2001 Digitool, Inc +;;; This file is part of Clozure CL. +;;; +;;; Clozure CL is licensed under the terms of the Lisp Lesser GNU Public +;;; License , known as the LLGPL and distributed with Clozure CL as the +;;; file "LICENSE". The LLGPL consists of a preamble and the LGPL, +;;; which is distributed with Clozure CL as the file "LGPL". Where these +;;; conflict, the preamble takes precedence. +;;; +;;; Clozure CL is referenced in the preamble as the "LIBRARY." +;;; +;;; The LLGPL is also available online at +;;; http://opensource.franz.com/preamble.html + +(in-package "CCL") + + + + +(defun utf-8-octets-in-string (string start end) + (if (>= end start) + (do* ((noctets 0) + (i start (1+ i))) + ((= i end) noctets) + (declare (fixnum noctets)) + (let* ((code (char-code (schar string i)))) + (declare (type (mod #x110000) code)) + (incf noctets + (if (< code #x80) + 1 + (if (< code #x800) + 2 + (if (< code #x10000) + 3 + 4)))))) + 0)) + +(defun utf-16-octets-in-string (string start end) + (if (>= end start) + (do* ((noctets 0) + (i start (1+ i))) + ((= i end) noctets) + (declare (fixnum noctets)) + (let* ((code (char-code (schar string i)))) + (declare (type (mod #x110000) code)) + (incf noctets + (if (< code #x10000) + 2 + 4)))) + 0)) + +(defun utf-8-memory-encode (string pointer idx start end) + (declare (fixnum idx)) + (do* ((i start (1+ i))) + ((>= i end) idx) + (let* ((code (char-code (schar string i)))) + (declare (type (mod #x110000) code)) + (cond ((< code #x80) + (setf (%get-unsigned-byte pointer idx) code) + (incf idx)) + ((< code #x800) + (setf (%get-unsigned-byte pointer idx) + (logior #xc0 (the fixnum (ash code -6)))) + (setf (%get-unsigned-byte pointer (the fixnum (1+ idx))) + (logior #x80 (the fixnum (logand code #x3f)))) + (incf idx 2)) + ((< code #x10000) + (setf (%get-unsigned-byte pointer idx) + (logior #xe0 (the fixnum (ash code -12)))) + (setf (%get-unsigned-byte pointer (the fixnum (1+ idx))) + (logior #x80 (the fixnum (logand #x3f (the fixnum (ash code -6)))))) + (setf (%get-unsigned-byte pointer (the fixnum (+ idx 2))) + (logior #x80 (the fixnum (logand code #x3f)))) + (incf idx 3)) + (t + (setf (%get-unsigned-byte pointer idx) + (logior #xf0 + (the fixnum (logand #x7 (the fixnum (ash code -18)))))) + (setf (%get-unsigned-byte pointer (the fixnum (1+ idx))) + (logior #x80 (the fixnum (logand #x3f (the fixnum (ash code -12)))))) + (setf (%get-unsigned-byte pointer (the fixnum (+ idx 2))) + (logior #x80 (the fixnum (logand #x3f (the fixnum (ash code -6)))))) + (setf (%get-unsigned-byte pointer (the fixnum (+ idx 3))) + (logior #x80 (logand #x3f code))) + (incf idx 4)))))) + +(defun native-utf-16-memory-encode (string pointer idx start end) + (declare (fixnum idx)) + (do* ((i start (1+ i))) + ((>= i end) idx) + (let* ((code (char-code (schar string i))) + (highbits (- code #x10000))) + (declare (type (mod #x110000) code) + (fixnum highbits)) + (cond ((< highbits 0) + (setf (%get-unsigned-word pointer idx) code) + (incf idx 2)) + (t + (setf (%get-unsigned-word pointer idx) (logior #xd800 (the fixnum (ash highbits -10)))) + (incf idx 2) + (setf (%get-unsigned-word pointer idx) (logior #xdc00 (the fixnum (logand highbits #x3ff)))) + (incf idx 2)))))) + +(defun utf-8-memory-decode (pointer noctets idx string) + (declare (fixnum noctets idx)) + (do* ((i 0 (1+ i)) + (end (+ idx noctets)) + (index idx (1+ index))) + ((>= index end) (if (= index end) index 0)) + (let* ((1st-unit (%get-unsigned-byte pointer index))) + (declare (type (unsigned-byte 8) 1st-unit)) + (let* ((char (if (< 1st-unit #x80) + (code-char 1st-unit) + (if (>= 1st-unit #xc2) + (let* ((2nd-unit (%get-unsigned-byte pointer (incf index)))) + (declare (type (unsigned-byte 8) 2nd-unit)) + (if (< 1st-unit #xe0) + (if (< (the fixnum (logxor 2nd-unit #x80)) #x40) + (code-char + (logior + (the fixnum (ash (the fixnum (logand #x1f 1st-unit)) 6)) + (the fixnum (logxor 2nd-unit #x80))))) + (let* ((3rd-unit (%get-unsigned-byte pointer (incf index)))) + (declare (type (unsigned-byte 8) 3rd-unit)) + (if (< 1st-unit #xf0) + (if (and (< (the fixnum (logxor 2nd-unit #x80)) #x40) + (< (the fixnum (logxor 3rd-unit #x80)) #x40) + (or (>= 1st-unit #xe1) + (>= 2nd-unit #xa0))) + (code-char (the fixnum + (logior (the fixnum + (ash (the fixnum (logand 1st-unit #xf)) + 12)) + (the fixnum + (logior + (the fixnum + (ash (the fixnum (logand 2nd-unit #x3f)) + 6)) + (the fixnum (logand 3rd-unit #x3f)))))))) + (if (< 1st-unit #xf8) + (let* ((4th-unit (%get-unsigned-byte pointer (incf index)))) + (declare (type (unsigned-byte 8) 4th-unit)) + (if (and (< (the fixnum (logxor 2nd-unit #x80)) #x40) + (< (the fixnum (logxor 3rd-unit #x80)) #x40) + (< (the fixnum (logxor 4th-unit #x80)) #x40) + (or (>= 1st-unit #xf1) + (>= 2nd-unit #x90))) + (code-char + (logior + (the fixnum + (logior + (the fixnum + (ash (the fixnum (logand 1st-unit 7)) 18)) + (the fixnum + (ash (the fixnum (logxor 2nd-unit #x80)) 12)))) + (the fixnum + (logior + (the fixnum + (ash (the fixnum (logxor 3rd-unit #x80)) 6)) + (the fixnum (logxor 4th-unit #x80))))))))))))))))) + (setf (schar string i) (or char #\Replacement_Character)))))) + +(defun utf-8-length-of-memory-encoding (pointer noctets start) + (do* ((i start) + (end (+ start noctets)) + (nchars 0 (1+ nchars))) + ((= i end) (values nchars (- i start))) + (let* ((code (%get-unsigned-byte pointer i)) + (nexti (+ i (cond ((< code #xc2) 1) + ((< code #xe0) 2) + ((< code #xf0) 3) + ((< code #xf8) 4) + (t 1))))) + (declare (type (unsigned-byte 8) code)) + (if (> nexti end) + (return (values nchars (- i start))) + (setq i nexti))))) + + + +;;; write nbytes bytes from buffer buf to file-descriptor fd. +(defun fd-write (fd buf nbytes) + (ignoring-eintr + (int-errno-ffcall + (%kernel-import target::kernel-import-lisp-write) + :int fd :address buf :ssize_t nbytes :ssize_t))) + +(defun fd-read (fd buf nbytes) + (ignoring-eintr + (int-errno-ffcall + (%kernel-import target::kernel-import-lisp-read) + :int fd :address buf :ssize_t nbytes :ssize_t))) + + +(let* ((pathname-encoding-name ())) + (declare (ignorable pathname-encoding-name)) + (defun pathname-encoding-name () + #+darwin-target :utf-8 + #+windows-target :utf-16le + #-(or darwin-target windows-target) pathname-encoding-name) + (defun set-pathname-encoding-name (new) + #+(or darwin-target windows-target) (declare (ignore new)) + #+darwin-target :utf-8 + #+windows-target :utf-16le + #-(or darwin-target windows-target) + (let* ((encoding (ensure-character-encoding new))) + (setq pathname-encoding-name + (unless (eq encoding (get-character-encoding nil)) + (character-encoding-name encoding)))))) + + +(defun fd-open-path (p flags create-mode) + (let* ((fd (int-errno-ffcall + (%kernel-import target::kernel-import-lisp-open) + :address p :int flags :mode_t create-mode :int))) + (declare (fixnum fd)) + (when (or (= fd (- #$EMFILE)) + (= fd (- #$ENFILE))) + (gc) + (drain-termination-queue) + (setq fd (int-errno-ffcall + (%kernel-import target::kernel-import-lisp-open) + :address p :int flags :mode_t create-mode :int))) + fd)) + +(defun fd-open (path flags &optional (create-mode #o666)) + #+darwin-target (with-utf-8-cstrs ((p path)) + (fd-open-path p flags create-mode)) + #+windows-target (with-native-utf-16-cstrs ((p path)) + (fd-open-path p flags create-mode)) + #-(or darwin-target windows-target) + (let* ((encoding (pathname-encoding-name))) + (if encoding + (with-encoded-cstrs encoding ((p path)) + (fd-open-path p flags create-mode)) + (with-cstrs ((p path)) + (fd-open-path p flags create-mode))))) + +(defun fd-chmod (fd mode) + (int-errno-ffcall (%kernel-import target::kernel-import-lisp-fchmod) + :int fd + :mode_t mode + :int)) + +(defun fd-lseek (fd offset whence) + (int-errno-ffcall + (%kernel-import target::kernel-import-lisp-lseek) + :int fd + :signed-doubleword offset + :int whence + :signed-doubleword)) + +(defun fd-close (fd) + (int-errno-ffcall (%kernel-import target::kernel-import-lisp-close) + :int fd + :int)) + +(defun fd-tell (fd) + (fd-lseek fd 0 #$SEEK_CUR)) + +;;; Kernels prior to 2.4 don't seem to have a "stat" variant +;;; that handles 64-bit file offsets. +(defun fd-size (fd) + (rlet ((stat #+win64-target #>_stat64 #+win32-target #>__stat64 #-windows-target :stat)) + (if (eql 0 (ff-call (%kernel-import target::kernel-import-lisp-fstat) + :int fd + :address stat + :int)) + (pref stat + #-windows-target :stat.st_size + #+win64-target #>_stat64.st_size + #+win32-target #>__stat64.st_size) + -1))) + + +(defun fd-ftruncate (fd new) + (int-errno-ffcall (%kernel-import target::kernel-import-lisp-ftruncate) + :int fd :off_t new :int)) + +(defun %string-to-stderr (str) + (with-cstrs ((s str)) + (fd-write 2 s (length str)))) + +(defun pdbg (string) + (%string-to-stderr string) + (%string-to-stderr #.(string #\LineFeed))) + + + +;;; Not really I/O, but ... +(defun malloc (size) + (ff-call + (%kernel-import target::kernel-import-malloc) + :unsigned-fullword size :address)) + +(defun free (ptr) + (let* ((size (uvsize ptr)) + (flags (if (= size target::xmacptr.size) + (uvref ptr target::xmacptr.flags-cell) + $flags_DisposPtr))) + (declare (fixnum size flags)) + (if (= flags $flags_DisposPtr) + (with-macptrs ((addr ptr)) + (when (= size target::xmacptr.size) + (%setf-macptr ptr (%null-ptr)) + (setf (uvref ptr target::xmacptr.flags-cell) $flags_Normal)) + (ff-call + (%kernel-import target::kernel-import-free) + :address addr :void))))) + + + + Index: /branches/new-random/level-0/l0-misc.lisp =================================================================== --- /branches/new-random/level-0/l0-misc.lisp (revision 13309) +++ /branches/new-random/level-0/l0-misc.lisp (revision 13309) @@ -0,0 +1,1142 @@ +;;;-*- Mode: Lisp; Package: CCL -*- +;;; +;;; Copyright (C) 2009 Clozure Associates +;;; Copyright (C) 1994-2001 Digitool, Inc +;;; This file is part of Clozure CL. +;;; +;;; Clozure CL is licensed under the terms of the Lisp Lesser GNU Public +;;; License , known as the LLGPL and distributed with Clozure CL as the +;;; file "LICENSE". The LLGPL consists of a preamble and the LGPL, +;;; which is distributed with Clozure CL as the file "LGPL". Where these +;;; conflict, the preamble takes precedence. +;;; +;;; Clozure CL is referenced in the preamble as the "LIBRARY." +;;; +;;; The LLGPL is also available online at +;;; http://opensource.franz.com/preamble.html + +(in-package "CCL") + + +;;; Bootstrapping for futexes +#+(and linux-target x86-target) +(eval-when (:compile-toplevel :execute) + (pushnew :futex *features*)) + +#+futex +(eval-when (:compile-toplevel :execute) + ;; We only need a few constants from , which may + ;; not have been included in the :libc .cdb files. + (defconstant FUTEX-WAIT 0) + (defconstant FUTEX-WAKE 1) + (defconstant futex-avail 0) + (defconstant futex-locked 1) + (defconstant futex-contended 2) + (declaim (inline %lock-futex %unlock-futex))) + +;;; Miscellany. + +(defun memq (item list) + (do* ((tail list (%cdr tail))) + ((null tail)) + (if (eq item (car tail)) + (return tail)))) + +(defun %copy-u8-to-string (u8-vector source-idx string dest-idx n) + (declare (optimize (speed 3) (safety 0)) + (fixnum source-idx dest-idx n) + (type (simple-array (unsigned-byte 8) (*)) u8-vector) + (simple-base-string string)) + (do* ((i 0 (1+ i))) + ((= i n) string) + (declare (fixnum i)) + (setf (%scharcode string dest-idx) (aref u8-vector source-idx)) + (incf source-idx) + (incf dest-idx))) + +(defun %copy-string-to-u8 (string source-idx u8-vector dest-idx n) + (declare (optimize (speed 3) (safety 0)) + (fixnum source-idx dest-idx n) + (type (simple-array (unsigned-byte 8) (*)) u8-vector) + (simple-base-string string)) + (do* ((i 0 (1+ i))) + ((= i n) u8-vector) + (declare (fixnum i)) + (let* ((code (%scharcode string source-idx))) + (declare (type (mod #x11000) code)) + (if (> code #xff) + (setq code (char-code #\Sub))) + (setf (aref u8-vector dest-idx) code) + (incf source-idx) + (incf dest-idx)))) + + + + +(defun append-2 (y z) + (if (null y) + z + (let* ((new (cons (car y) nil)) + (tail new)) + (declare (list new tail)) + (dolist (head (cdr y)) + (setq tail (cdr (rplacd tail (cons head nil))))) + (rplacd tail z) + new))) + + + + + + + + + +(defun dbg (&optional arg) + (dbg arg)) + + +; This takes a simple-base-string and passes a C string into +; the kernel "Bug" routine. Not too fancy, but neither is #_DebugStr, +; and there's a better chance that users would see this message. +(defun bug (arg) + (if (typep arg 'simple-base-string) + #+x86-target + (debug-trap-with-string arg) + #-x86-target + (let* ((len (length arg))) + (%stack-block ((buf (1+ len))) + (%cstr-pointer arg buf) + (ff-call + (%kernel-import target::kernel-import-lisp-bug) + :address buf + :void))) + (bug "Bug called with non-simple-base-string."))) + +(defun total-bytes-allocated () + (%heap-bytes-allocated) + #+not-any-more + (+ (unsignedwide->integer *total-bytes-freed*) + (%heap-bytes-allocated))) + +(defun %freebytes () + (with-macptrs (p) + (%setf-macptr-to-object p + (%fixnum-ref (%get-kernel-global 'all-areas) + target::area.succ)) + (- (%get-natural p target::area.high) + (%get-natural p target::area.active)))) + +(defun %reservedbytes () + (with-macptrs (p) + (%setf-macptr-to-object p (%get-kernel-global 'all-areas)) + (- #+32-bit-target + (%get-unsigned-long p target::area.high) + #+64-bit-target + (%%get-unsigned-longlong p target::area.high) + #+32-bit-target + (%get-unsigned-long p target::area.low) + #+64-bit-target + (%%get-unsigned-longlong p target::area.low)))) + +(defun object-in-application-heap-p (address) + (declare (ignore address)) + t) + +(defun frozen-space-dnodes () + "Returns the current size of the frozen area." + (%fixnum-ref-natural (%get-kernel-global 'tenured-area) + target::area.static-dnodes)) +(defun %usedbytes () + (with-lock-grabbed (*kernel-exception-lock*) + (with-lock-grabbed (*kernel-tcr-area-lock*) + (%normalize-areas) + (let ((static 0) + (dynamic 0) + (library 0)) + (do-consing-areas (area) + (let* ((active (%fixnum-ref area target::area.active)) + (bytes (ash (- active + (%fixnum-ref area target::area.low)) + target::fixnumshift)) + (code (%fixnum-ref area target::area.code))) + (when (object-in-application-heap-p active) + (if (eql code area-dynamic) + (incf dynamic bytes) + (if (eql code area-managed-static) + (incf library bytes) + (incf static bytes)))))) + (let* ((frozen-size (ash (frozen-space-dnodes) target::dnode-shift))) + (decf dynamic frozen-size) + (values dynamic static library frozen-size)))))) + + + +(defun %stack-space () + (%normalize-areas) + (let ((free 0) + (used 0)) + (with-macptrs (p) + (do-gc-areas (area) + (when (member (%fixnum-ref area target::area.code) + '(#.area-vstack + #.area-cstack + #.area-tstack)) + (%setf-macptr-to-object p area) + (let ((active + #+32-bit-target + (%get-unsigned-long p target::area.active) + #+64-bit-target + (%%get-unsigned-longlong p target::area.active)) + (high + #+32-bit-target + (%get-unsigned-long p target::area.high) + #+64-bit-target + (%%get-unsigned-longlong p target::area.high)) + (low + #+32-bit-target + (%get-unsigned-long p target::area.low) + #+64-bit-target + (%%get-unsigned-longlong p target::area.low))) + (incf used (- high active)) + (incf free (- active low)))))) + (values (+ free used) used free))) + + + +; Returns an alist of the form: +; ((thread cstack-free cstack-used vstack-free vstack-used tstack-free tstack-used) +; ...) +(defun %stack-space-by-lisp-thread () + (let* ((res nil)) + (without-interrupts + (dolist (p (all-processes)) + (let* ((thread (process-thread p))) + (when thread + (push (cons thread (multiple-value-list (%thread-stack-space thread))) res))))) + res)) + + + +;;; Returns six values. +;;; sp free +;;; sp used +;;; vsp free +;;; vsp used +;;; tsp free +;;; tsp used +(defun %thread-stack-space (&optional (thread *current-lisp-thread*)) + (when (eq thread *current-lisp-thread*) + (%normalize-areas)) + (labels ((free-and-used (area) + (with-macptrs (p) + (%setf-macptr-to-object p area) + (let* ((low + #+32-bit-target + (%get-unsigned-long p target::area.low) + #+64-bit-target + (%%get-unsigned-longlong p target::area.low)) + (high + #+32-bit-target + (%get-unsigned-long p target::area.high) + #+64-bit-target + (%%get-unsigned-longlong p target::area.high)) + (active + #+32-bit-target + (%get-unsigned-long p target::area.active) + #+64-bit-target + (%%get-unsigned-longlong p target::area.active)) + (free (- active low)) + (used (- high active))) + (loop + (setq area (%fixnum-ref area target::area.older)) + (when (eql area 0) (return)) + (%setf-macptr-to-object p area) + (let ((low + #+32-bit-target + (%get-unsigned-long p target::area.low) + #+64-bit-target + (%%get-unsigned-longlong p target::area.low)) + (high + #+32-bit-target + (%get-unsigned-long p target::area.high) + #+64-bit-target + (%%get-unsigned-longlong p target::area.high))) + (declare (fixnum low high)) + (incf used (- high low)))) + (values free used))))) + (let* ((tcr (lisp-thread.tcr thread))) + (if (or (null tcr) + (zerop (%fixnum-ref (%fixnum-ref tcr target::tcr.cs-area)))) + (values 0 0 0 0 0 0) + (multiple-value-bind (cf cu) (free-and-used (%fixnum-ref tcr target::tcr.cs-area)) + (multiple-value-bind (vf vu) (free-and-used (%fixnum-ref tcr target::tcr.vs-area)) + (multiple-value-bind (tf tu) (free-and-used (%fixnum-ref tcr target::tcr.ts-area )) + (values cf cu vf vu tf tu)))))))) + + +(defun room (&optional (verbose :default)) + "Print to *STANDARD-OUTPUT* information about the state of internal + storage and its management. The optional argument controls the + verbosity of output. If it is T, ROOM prints out a maximal amount of + information. If it is NIL, ROOM prints out a minimal amount of + information. If it is :DEFAULT or it is not supplied, ROOM prints out + an intermediate amount of information." + (let* ((freebytes nil) + (usedbytes nil) + (static-used nil) + (staticlib-used nil) + (frozen-space-size nil) + (lispheap nil) + (reserved nil) + (static nil) + (stack-total) + (stack-used) + (stack-free) + (static-cons-reserved nil) + (stack-used-by-thread nil)) + (progn + (progn + (setq freebytes (%freebytes)) + (when verbose + (multiple-value-setq (usedbytes static-used staticlib-used frozen-space-size) + (%usedbytes)) + (setq lispheap (+ freebytes usedbytes) + reserved (%reservedbytes) + static (+ static-used staticlib-used frozen-space-size)) + (multiple-value-setq (stack-total stack-used stack-free) + (%stack-space)) + (unless (eq verbose :default) + (setq stack-used-by-thread (%stack-space-by-lisp-thread)))))) + (format t "~&Approximately ~:D bytes of memory can be allocated ~%before the next full GC is triggered. ~%" freebytes) + (when verbose + (flet ((k (n) (round n 1024))) + (princ " + Total Size Free Used") + (format t "~&Lisp Heap:~15t~10D (~DK)~35t~10D (~DK)~55t~10D (~DK)" + lispheap (k lispheap) + freebytes (k freebytes) + usedbytes (k usedbytes)) + (format t "~&Stacks:~15t~10D (~DK)~35t~10D (~DK)~55t~10D (~DK)" + stack-total (k stack-total) + stack-free (k stack-free) + stack-used (k stack-used)) + (format t "~&Static:~15t~10D (~DK)~35t~10D (~DK)~55t~10D (~DK)" + static (k static) + 0 0 + static (k static)) + (when (and frozen-space-size (not (zerop frozen-space-size))) + (setq static-cons-reserved (ash (reserved-static-conses) target::dnode-shift) + frozen-space-size (- frozen-space-size static-cons-reserved)) + (unless (zerop static-cons-reserved) + (format t "~&~,3f MB of reserved static conses (~d free, ~d reserved)" + (/ static-cons-reserved (float (ash 1 20))) + (free-static-conses) + (reserved-static-conses))) + + (unless (zerop frozen-space-size) + (format t "~&~,3f MB of static memory is \"frozen\" dynamic memory" + (/ frozen-space-size (float (ash 1 20)))))) + (format t "~&~,3f MB reserved for heap expansion." + (/ reserved (float (ash 1 20)))) + (unless (eq verbose :default) + (terpri) + (let* ((processes (all-processes))) + (dolist (thread-info stack-used-by-thread) + (destructuring-bind (thread sp-free sp-used vsp-free vsp-used tsp-free tsp-used) + thread-info + (let* ((process (dolist (p processes) + (when (eq (process-thread p) thread) + (return p))))) + (when process + (let ((sp-total (+ sp-used sp-free)) + (vsp-total (+ vsp-used vsp-free)) + (tsp-total (+ tsp-used tsp-free))) + (format t "~%~a(~d)~% cstack:~12T~10D (~DK) ~33T~10D (~DK) ~54T~10D (~DK)~ + ~% vstack:~12T~10D (~DK) ~33T~10D (~DK) ~54T~10D (~DK)~ + ~% tstack:~12T~10D (~DK) ~33T~10D (~DK) ~54T~10D (~DK)" + (process-name process) + (process-serial-number process) + sp-total (k sp-total) sp-free (k sp-free) sp-used (k sp-used) + vsp-total (k vsp-total) vsp-free (k vsp-free) vsp-used (k vsp-used) + tsp-total (k tsp-total) tsp-free (k tsp-free) tsp-used (k tsp-used))))))))))))) + + +(defun list-length (l) + "Return the length of the given LIST, or NIL if the LIST is circular." + (do* ((n 0 (+ n 2)) + (fast l (cddr fast)) + (slow l (cdr slow))) + ((null fast) n) + (declare (fixnum n)) + (if (null (cdr fast)) + (return (the fixnum (1+ n))) + (if (and (eq fast slow) + (> n 0)) + (return nil))))) + +(defun proper-list-p (l) + (and (typep l 'list) + (do* ((n 0 (+ n 2)) + (fast l (if (and (listp fast) (listp (cdr fast))) + (cddr fast) + (return-from proper-list-p nil))) + (slow l (cdr slow))) + ((null fast) n) + (declare (fixnum n)) + (if (atom fast) + (return nil) + (if (null (cdr fast)) + (return t) + (if (and (eq fast slow) + (> n 0)) + (return nil))))))) + +(defun proper-sequence-p (x) + (cond ((typep x 'vector)) + ((typep x 'list) (not (null (list-length x)))))) + + +(defun length (seq) + "Return an integer that is the length of SEQUENCE." + (seq-dispatch + seq + (or (list-length seq) + (%err-disp $XIMPROPERLIST seq)) + (if (= (the fixnum (typecode seq)) target::subtag-vectorH) + (%svref seq target::vectorH.logsize-cell) + (uvsize seq)))) + +(defun %str-from-ptr (pointer len &optional (dest (make-string len))) + (declare (fixnum len) + (optimize (speed 3) (safety 0))) + (dotimes (i len dest) + (setf (%scharcode dest i) (%get-unsigned-byte pointer i)))) + +(defun %get-cstring (pointer) + (do* ((end 0 (1+ end))) + ((zerop (the (unsigned-byte 8) (%get-unsigned-byte pointer end))) + (%str-from-ptr pointer end)) + (declare (fixnum end)))) + +(defun %get-utf-8-cstring (pointer) + (do* ((end 0 (1+ end))) + ((zerop (the (unsigned-byte 8) (%get-unsigned-byte pointer end))) + (let* ((len (utf-8-length-of-memory-encoding pointer end 0)) + (string (make-string len))) + (utf-8-memory-decode pointer end 0 string) + string)) + (declare (fixnum end)))) + +;;; Assumes that pointer is terminated by a 0-valued 16-bit word +;;; and that it points to a valid utf-16 string with native endianness. +(defun %get-native-utf-16-cstring (pointer) + (do* ((nchars 0 (1+ nchars)) + (i 0 (+ i 2)) + (code (%get-unsigned-word pointer i) (%get-unsigned-word pointer i))) + ((zerop code) + (do* ((string (make-string nchars)) + (out 0 (1+ out)) + (i 0 (+ i 2))) + ((= out nchars) string) + (declare (fixnum i out)) + (let* ((code (%get-unsigned-word pointer i))) + (declare (type (unsigned-byte 16) code)) + (when (and (>= code #xd800) + (< code #xdc00)) + (incf i 2) + (let* ((code2 (%get-unsigned-word pointer i))) + (declare (type (unsigned-byte 16) code2)) + (setq code (utf-16-combine-surrogate-pairs code code2)))) + (setf (schar string out) (code-char code))))) + (when (and (>= code #xd800) (< code #xdc00)) + (incf i 2)))) + + +;;; This is mostly here so we can bootstrap shared libs without +;;; having to bootstrap #_strcmp. +;;; Return true if the cstrings are equal, false otherwise. +(defun %cstrcmp (x y) + (do* ((i 0 (1+ i)) + (bx (%get-byte x i) (%get-byte x i)) + (by (%get-byte y i) (%get-byte y i))) + ((not (= bx by))) + (declare (fixnum i bx by)) + (when (zerop bx) + (return t)))) + +(defun %cnstrcmp (x y n) + (declare (fixnum n)) + (do* ((i 0 (1+ i)) + (bx (%get-byte x i) (%get-byte x i)) + (by (%get-byte y i) (%get-byte y i))) + ((= i n) t) + (declare (fixnum i bx by)) + (unless (= bx by) + (return)))) + +(defvar %documentation nil) + +(defvar %documentation-lock% nil) + +(setq %documentation + (make-hash-table :weak t :size 100 :test 'eq :rehash-threshold .95) + %documentation-lock% (make-lock)) + +(defun %put-documentation (thing doc-id doc) + (with-lock-grabbed (%documentation-lock%) + (let* ((info (gethash thing %documentation)) + (pair (assoc doc-id info))) + (if doc + (progn + (unless (typep doc 'string) + (report-bad-arg doc 'string)) + (if pair + (setf (cdr pair) doc) + (setf (gethash thing %documentation) (cons (cons doc-id doc) info)))) + (when pair + (if (setq info (nremove pair info)) + (setf (gethash thing %documentation) info) + (remhash thing %documentation)))))) + doc) + +(defun %get-documentation (object doc-id) + (cdr (assoc doc-id (gethash object %documentation)))) + +;;; This pretends to be (SETF DOCUMENTATION), until that generic function +;;; is defined. It handles a few common cases. +(defun %set-documentation (thing doc-id doc-string) + (case doc-id + (function + (if (typep thing 'function) + (%put-documentation thing t doc-string) + (if (typep thing 'symbol) + (let* ((def (fboundp thing))) + (if def + (%put-documentation def t doc-string))) + (if (setf-function-name-p thing) + (%set-documentation + (setf-function-name thing) doc-id doc-string))))) + (variable + (if (typep thing 'symbol) + (%put-documentation thing doc-id doc-string))) + (t (%put-documentation thing doc-id doc-string))) + doc-string) + + +(%fhave 'set-documentation #'%set-documentation) + + + +;;; This is intended for use by debugging tools. It's a horrible thing +;;; to do otherwise. The caller really needs to hold the heap-segment +;;; lock; this grabs the tcr queue lock as well. + + +(defparameter *spin-lock-tries* 1) +(defparameter *spin-lock-timeouts* 0) + +#+(and (not futex) (not x86-target)) +(defun %get-spin-lock (p) + (let* ((self (%current-tcr)) + (n *spin-lock-tries*)) + (declare (fixnum n)) + (loop + (dotimes (i n) + (when (eql 0 (%ptr-store-fixnum-conditional p 0 self)) + (return-from %get-spin-lock t))) + (%atomic-incf-node 1 '*spin-lock-timeouts* target::symbol.vcell) + (yield)))) + +(eval-when (:compile-toplevel :execute) + (declaim (inline note-lock-wait note-lock-held note-lock-released))) + + + + + +#-futex +(defun %lock-recursive-lock-object (lock &optional flag) + (let* ((ptr (recursive-lock-ptr lock))) + (with-macptrs ((p) + (owner (%get-ptr ptr target::lockptr.owner)) + (signal (%get-ptr ptr target::lockptr.signal)) + (spin (%inc-ptr ptr target::lockptr.spinlock))) + (%setf-macptr-to-object p (%current-tcr)) + (if (istruct-typep flag 'lock-acquisition) + (setf (lock-acquisition.status flag) nil) + (if flag (report-bad-arg flag 'lock-acquisition))) + (loop + (without-interrupts + (when (eql p owner) + (incf (%get-natural ptr target::lockptr.count)) + (when flag + (setf (lock-acquisition.status flag) t)) + (return t)) + (%get-spin-lock spin) + (when (eql 1 (incf (%get-natural ptr target::lockptr.avail))) + (setf (%get-ptr ptr target::lockptr.owner) p + (%get-natural ptr target::lockptr.count) 1) + (setf (%get-natural spin 0) 0) + (if flag + (setf (lock-acquisition.status flag) t)) + (return t)) + (setf (%get-natural spin 0) 0)) + (%process-wait-on-semaphore-ptr signal 1 0 (recursive-lock-whostate lock)))))) + + + +#+futex +(progn + #-monitor-futex-wait + (defun futex-wait (p val whostate) + (with-process-whostate (whostate) + (int-errno-ffcall + (%kernel-import target::kernel-import-lisp-futex) + :address p :int FUTEX-WAIT :int val :address (%null-ptr) :address (%null-ptr) :int 0 :int))) + #+monitor-futex-wait + (progn + (defparameter *total-futex-wait-calls* 0) + (defparameter *total-futex-wait-times* 0) + (defun futex-wait (p val whostate) + (with-process-whostate (whostate) + (let* ((start (get-internal-real-time))) + (incf *total-futex-wait-calls*) + (int-errno-ffcall + (%kernel-import target::kernel-import-lisp-futex) + :address p :int FUTEX-WAIT :int val :address (%null-ptr) :address (%null-ptr) :int 0 :int) + (incf *total-futex-wait-times* (- (get-internal-real-time) start))))))) + + + + +#+futex +(defun futex-wake (p n) + (int-errno-ffcall (%kernel-import target::kernel-import-lisp-futex) + :address p :int FUTEX-WAKE :int n :address (%null-ptr) :address (%null-ptr) :int 0 :int)) + +#+futex +(defun %lock-futex (p wait-level lock fwhostate) + (let* ((val (%ptr-store-conditional p futex-avail futex-locked))) + (declare (fixnum val)) + (or (eql val futex-avail) + (loop + (if (eql val futex-contended) + (let* ((*interrupt-level* wait-level)) + (futex-wait p val (if fwhostate (funcall fwhostate lock) "futex wait"))) + (setq val futex-contended)) + (when (eql futex-avail (xchgl val p)) + (return t)))))) + +#+futex +(defun %unlock-futex (p) + (unless (eql futex-avail (%atomic-decf-ptr p)) + (setf (%get-natural p target::lockptr.avail) futex-avail) + (futex-wake p #$INT_MAX))) + + + + +#+futex +(defun %lock-recursive-lock-object (lock &optional flag) + (if (istruct-typep flag 'lock-acquisition) + (setf (lock-acquisition.status flag) nil) + (if flag (report-bad-arg flag 'lock-acquisition))) + (let* ((self (%current-tcr)) + (level *interrupt-level*) + (ptr (recursive-lock-ptr lock))) + (declare (fixnum self)) + (without-interrupts + (cond ((eql self (%get-object ptr target::lockptr.owner)) + (incf (%get-natural ptr target::lockptr.count))) + (t (%lock-futex ptr level lock #'recursive-lock-whostate) + (%set-object ptr target::lockptr.owner self) + (setf (%get-natural ptr target::lockptr.count) 1))) + (when flag + (setf (lock-acquisition.status flag) t)) + t))) + + + + + + +#-futex +(defun %try-recursive-lock-object (lock &optional flag) + (let* ((ptr (recursive-lock-ptr lock))) + (with-macptrs ((p) + (owner (%get-ptr ptr target::lockptr.owner)) + (spin (%inc-ptr ptr target::lockptr.spinlock))) + (%setf-macptr-to-object p (%current-tcr)) + (if flag + (if (istruct-typep flag 'lock-acquisition) + (setf (lock-acquisition.status flag) nil) + (report-bad-arg flag 'lock-acquisition))) + (without-interrupts + (cond ((eql p owner) + (incf (%get-natural ptr target::lockptr.count)) + (if flag (setf (lock-acquisition.status flag) t)) + t) + (t + (let* ((win nil)) + (%get-spin-lock spin) + (when (setq win (eql 1 (incf (%get-natural ptr target::lockptr.avail)))) + (setf (%get-ptr ptr target::lockptr.owner) p + (%get-natural ptr target::lockptr.count) 1) + (if flag (setf (lock-acquisition.status flag) t))) + (setf (%get-ptr spin) (%null-ptr)) + win))))))) + + + +#+futex +(defun %try-recursive-lock-object (lock &optional flag) + (let* ((self (%current-tcr)) + (ptr (recursive-lock-ptr lock))) + (declare (fixnum self)) + (if flag + (if (istruct-typep flag 'lock-acquisition) + (setf (lock-acquisition.status flag) nil) + (report-bad-arg flag 'lock-acquisition))) + (without-interrupts + (cond ((eql (%get-object ptr target::lockptr.owner) self) + (incf (%get-natural ptr target::lockptr.count)) + (if flag (setf (lock-acquisition.status flag) t)) + t) + (t + (when (eql 0 (%ptr-store-conditional ptr futex-avail futex-locked)) + (%set-object ptr target::lockptr.owner self) + (setf (%get-natural ptr target::lockptr.count) 1) + (if flag (setf (lock-acquisition.status flag) t)) + t)))))) + + + + + +#-futex +(defun %unlock-recursive-lock-object (lock) + (let* ((ptr (%svref lock target::lock._value-cell))) + (with-macptrs ((signal (%get-ptr ptr target::lockptr.signal)) + (spin (%inc-ptr ptr target::lockptr.spinlock))) + (unless (eql (%get-object ptr target::lockptr.owner) (%current-tcr)) + (error 'not-lock-owner :lock lock)) + (without-interrupts + (when (eql 0 (decf (the fixnum + (%get-natural ptr target::lockptr.count)))) + (%get-spin-lock spin) + (setf (%get-ptr ptr target::lockptr.owner) (%null-ptr)) + (let* ((pending (+ (the fixnum + (1- (the fixnum (%get-fixnum ptr target::lockptr.avail)))) + (the fixnum (%get-fixnum ptr target::lockptr.waiting))))) + (declare (fixnum pending)) + (setf (%get-natural ptr target::lockptr.avail) 0 + (%get-natural ptr target::lockptr.waiting) 0) + (decf pending) + (if (> pending 0) + (setf (%get-natural ptr target::lockptr.waiting) pending)) + (setf (%get-ptr spin) (%null-ptr)) + (if (>= pending 0) + (%signal-semaphore-ptr signal))))))) + nil) + + + +#+futex +(defun %unlock-recursive-lock-object (lock) + (let* ((ptr (%svref lock target::lock._value-cell))) + (unless (eql (%get-object ptr target::lockptr.owner) (%current-tcr)) + (error 'not-lock-owner :lock lock)) + (without-interrupts + (when (eql 0 (decf (the fixnum + (%get-natural ptr target::lockptr.count)))) + (setf (%get-natural ptr target::lockptr.owner) 0) + (%unlock-futex ptr)))) + nil) + + + + +(defun %%lock-owner (lock) + "Intended for debugging only; ownership may change while this code + is running." + (let* ((tcr (%get-object (recursive-lock-ptr lock) target::lockptr.owner))) + (unless (zerop tcr) + (tcr->process tcr)))) + + + + + + + +(defun %rplaca-conditional (cons-cell old new) + (%store-node-conditional target::cons.car cons-cell old new)) + +(defun %rplacd-conditional (cons-cell old new) + (%store-node-conditional target::cons.cdr cons-cell old new)) + +;;; Atomically push NEW onto the list in the I'th cell of uvector V. + +(defun atomic-push-uvector-cell (v i new) + (let* ((cell (cons new nil)) + (offset (+ target::misc-data-offset (ash i target::word-shift)))) + (loop + (let* ((old (%svref v i))) + (rplacd cell old) + (when (%store-node-conditional offset v old cell) + (return cell)))))) + +(defun atomic-pop-uvector-cell (v i) + (let* ((offset (+ target::misc-data-offset (ash i target::word-shift)))) + (loop + (let* ((old (%svref v i))) + (if (null old) + (return (values nil nil)) + (let* ((tail (cdr old))) + (when (%store-node-conditional offset v old tail) + (return (values (car old) t))))))))) + + +(defun store-gvector-conditional (index gvector old new) + (%store-node-conditional (+ target::misc-data-offset + (ash index target::word-shift)) + gvector + old + new)) + +(defun %atomic-incf-car (cell &optional (by 1)) + (%atomic-incf-node (require-type by 'fixnum) + (require-type cell 'cons) + target::cons.car)) + +(defun %atomic-incf-cdr (cell &optional (by 1)) + (%atomic-incf-node (require-type by 'fixnum) + (require-type cell 'cons) + target::cons.cdr)) + +(defun %atomic-incf-gvector (v i &optional (by 1)) + (setq v (require-type v 'gvector)) + (setq i (require-type i 'fixnum)) + (%atomic-incf-node by v (+ target::misc-data-offset (ash i target::word-shift)))) + +(defun %atomic-incf-symbol-value (s &optional (by 1)) + (setq s (require-type s 'symbol)) + (multiple-value-bind (base offset) (%symbol-binding-address s) + (%atomic-incf-node by base offset))) + +;;; What happens if there are some pending readers and another writer, +;;; and we abort out of the semaphore wait ? If the writer semaphore is +;;; signaled before we abandon interest in it +#-futex +(defun %write-lock-rwlock-ptr (ptr lock &optional flag) + (with-macptrs ((write-signal (%get-ptr ptr target::rwlock.writer-signal)) ) + (if (istruct-typep flag 'lock-acquisition) + (setf (lock-acquisition.status flag) nil) + (if flag (report-bad-arg flag 'lock-acquisition))) + (let* ((level *interrupt-level*) + (tcr (%current-tcr))) + (declare (fixnum tcr)) + (without-interrupts + (%get-spin-lock ptr) ;(%get-spin-lock (%inc-ptr ptr target::rwlock.spin)) + (if (eq (%get-object ptr target::rwlock.writer) tcr) + (progn + (incf (%get-signed-natural ptr target::rwlock.state)) + (setf (%get-natural ptr target::rwlock.spin) 0) + (if flag + (setf (lock-acquisition.status flag) t)) + t) + (do* () + ((eql 0 (%get-signed-natural ptr target::rwlock.state)) + ;; That wasn't so bad, was it ? We have the spinlock now. + (setf (%get-signed-natural ptr target::rwlock.state) 1 + (%get-natural ptr target::rwlock.spin) 0) + (%set-object ptr target::rwlock.writer tcr) + (if flag + (setf (lock-acquisition.status flag) t)) + t) + (incf (%get-natural ptr target::rwlock.blocked-writers)) + (setf (%get-natural ptr target::rwlock.spin) 0) + (let* ((*interrupt-level* level)) + (%process-wait-on-semaphore-ptr write-signal 1 0 (rwlock-write-whostate lock))) + (%get-spin-lock ptr))))))) +#+futex +(defun %write-lock-rwlock-ptr (ptr lock &optional flag) + (with-macptrs ((write-signal (%INC-ptr ptr target::rwlock.writer-signal)) ) + (if (istruct-typep flag 'lock-acquisition) + (setf (lock-acquisition.status flag) nil) + (if flag (report-bad-arg flag 'lock-acquisition))) + (let* ((level *interrupt-level*) + (tcr (%current-tcr))) + (declare (fixnum tcr)) + (without-interrupts + (%lock-futex ptr level lock nil) + (if (eq (%get-object ptr target::rwlock.writer) tcr) + (progn + (incf (%get-signed-natural ptr target::rwlock.state)) + (%unlock-futex ptr) + (if flag + (setf (lock-acquisition.status flag) t)) + t) + (do* () + ((eql 0 (%get-signed-natural ptr target::rwlock.state)) + ;; That wasn't so bad, was it ? We have the spinlock now. + (setf (%get-signed-natural ptr target::rwlock.state) 1) + (%unlock-futex ptr) + (%set-object ptr target::rwlock.writer tcr) + (if flag + (setf (lock-acquisition.status flag) t)) + t) + (incf (%get-natural ptr target::rwlock.blocked-writers)) + (let* ((waitval (%get-natural write-signal 0))) + (%unlock-futex ptr) + (with-process-whostate ((rwlock-write-whostate lock)) + (let* ((*interrupt-level* level)) + (futex-wait write-signal waitval (rwlock-write-whostate lock))))) + (%lock-futex ptr level lock nil) + (decf (%get-natural ptr target::rwlock.blocked-writers)))))))) + + + +(defun write-lock-rwlock (lock &optional flag) + (%write-lock-rwlock-ptr (read-write-lock-ptr lock) lock flag)) + +#-futex +(defun %read-lock-rwlock-ptr (ptr lock &optional flag) + (with-macptrs ((read-signal (%get-ptr ptr target::rwlock.reader-signal))) + (if (istruct-typep flag 'lock-acquisition) + (setf (lock-acquisition.status flag) nil) + (if flag (report-bad-arg flag 'lock-acquisition))) + (let* ((level *interrupt-level*) + (tcr (%current-tcr))) + (declare (fixnum tcr)) + (without-interrupts + (%get-spin-lock ptr) ;(%get-spin-lock (%inc-ptr ptr target::rwlock.spin)) + (if (eq (%get-object ptr target::rwlock.writer) tcr) + (progn + (setf (%get-natural ptr target::rwlock.spin) 0) + (error 'deadlock :lock lock)) + (do* ((state + (%get-signed-natural ptr target::rwlock.state) + (%get-signed-natural ptr target::rwlock.state))) + ((<= state 0) + ;; That wasn't so bad, was it ? We have the spinlock now. + (setf (%get-signed-natural ptr target::rwlock.state) + (the fixnum (1- state)) + (%get-natural ptr target::rwlock.spin) 0) + (if flag + (setf (lock-acquisition.status flag) t)) + t) + (declare (fixnum state)) + (incf (%get-natural ptr target::rwlock.blocked-readers)) + (setf (%get-natural ptr target::rwlock.spin) 0) + (let* ((*interrupt-level* level)) + (%process-wait-on-semaphore-ptr read-signal 1 0 (rwlock-read-whostate lock))) + (%get-spin-lock ptr))))))) + +#+futex +(defun %read-lock-rwlock-ptr (ptr lock &optional flag) + (with-macptrs ((reader-signal (%INC-ptr ptr target::rwlock.reader-signal))) + (if (istruct-typep flag 'lock-acquisition) + (setf (lock-acquisition.status flag) nil) + (if flag (report-bad-arg flag 'lock-acquisition))) + (let* ((level *interrupt-level*) + (tcr (%current-tcr))) + (declare (fixnum tcr)) + (without-interrupts + (%lock-futex ptr level lock nil) + (if (eq (%get-object ptr target::rwlock.writer) tcr) + (progn + (%unlock-futex ptr) + (error 'deadlock :lock lock)) + (do* ((state + (%get-signed-natural ptr target::rwlock.state) + (%get-signed-natural ptr target::rwlock.state))) + ((<= state 0) + ;; That wasn't so bad, was it ? We have the spinlock now. + (setf (%get-signed-natural ptr target::rwlock.state) + (the fixnum (1- state))) + (%unlock-futex ptr) + (if flag + (setf (lock-acquisition.status flag) t)) + t) + (declare (fixnum state)) + (incf (%get-natural ptr target::rwlock.blocked-readers)) + (let* ((waitval (%get-natural reader-signal 0))) + (%unlock-futex ptr) + (let* ((*interrupt-level* level)) + (futex-wait reader-signal waitval (rwlock-read-whostate lock)))) + (%lock-futex ptr level lock nil) + (decf (%get-natural ptr target::rwlock.blocked-readers)))))))) + + + +(defun read-lock-rwlock (lock &optional flag) + (%read-lock-rwlock-ptr (read-write-lock-ptr lock) lock flag)) + + + +#-futex +(defun %unlock-rwlock-ptr (ptr lock) + (with-macptrs ((reader-signal (%get-ptr ptr target::rwlock.reader-signal)) + (writer-signal (%get-ptr ptr target::rwlock.writer-signal))) + (without-interrupts + (%get-spin-lock ptr) + (let* ((state (%get-signed-natural ptr target::rwlock.state)) + (tcr (%current-tcr))) + (declare (fixnum state tcr)) + (cond ((> state 0) + (unless (eql tcr (%get-object ptr target::rwlock.writer)) + (setf (%get-natural ptr target::rwlock.spin) 0) + (error 'not-lock-owner :lock lock)) + (decf state)) + ((< state 0) (incf state)) + (t (setf (%get-natural ptr target::rwlock.spin) 0) + (error 'not-locked :lock lock))) + (setf (%get-signed-natural ptr target::rwlock.state) state) + (when (zerop state) + ;; We want any thread waiting for a lock semaphore to + ;; be able to wait interruptibly. When a thread waits, + ;; it increments either the "blocked-readers" or "blocked-writers" + ;; field, but since it may get interrupted before obtaining + ;; the semaphore that's more of "an expression of interest" + ;; in taking the lock than it is "a firm commitment to take it." + ;; It's generally (much) better to signal the semaphore(s) + ;; too often than it would be to not signal them often + ;; enough; spurious wakeups are better than deadlock. + ;; So: if there are blocked writers, the writer-signal + ;; is raised once for each apparent blocked writer. (At most + ;; one writer will actually succeed in taking the lock.) + ;; If there are blocked readers, the reader-signal is raised + ;; once for each of them. (It's possible for both the + ;; reader and writer semaphores to be raised on the same + ;; unlock; the writer semaphore is raised first, so in that + ;; sense, writers still have priority but it's not guaranteed.) + ;; Both the "blocked-writers" and "blocked-readers" fields + ;; are cleared here (they can't be changed from another thread + ;; until this thread releases the spinlock.) + (setf (%get-signed-natural ptr target::rwlock.writer) 0) + (let* ((nwriters (%get-natural ptr target::rwlock.blocked-writers)) + (nreaders (%get-natural ptr target::rwlock.blocked-readers))) + (declare (fixnum nreaders nwriters)) + (when (> nwriters 0) + (setf (%get-natural ptr target::rwlock.blocked-writers) 0) + (dotimes (i nwriters) + (%signal-semaphore-ptr writer-signal))) + (when (> nreaders 0) + (setf (%get-natural ptr target::rwlock.blocked-readers) 0) + (dotimes (i nreaders) + (%signal-semaphore-ptr reader-signal))))) + (setf (%get-natural ptr target::rwlock.spin) 0) + t)))) + +#+futex +(defun %unlock-rwlock-ptr (ptr lock) + (with-macptrs ((reader-signal (%INC-ptr ptr target::rwlock.reader-signal)) + (writer-signal (%INC-ptr ptr target::rwlock.writer-signal))) + (let* ((signal nil) + (wakeup 0)) + (without-interrupts + (%lock-futex ptr -1 lock nil) + (let* ((state (%get-signed-natural ptr target::rwlock.state)) + (tcr (%current-tcr))) + (declare (fixnum state tcr)) + (cond ((> state 0) + (unless (eql tcr (%get-object ptr target::rwlock.writer)) + (%unlock-futex ptr) + (error 'not-lock-owner :lock lock)) + (decf state)) + ((< state 0) (incf state)) + (t (%unlock-futex ptr) + (error 'not-locked :lock lock))) + (setf (%get-signed-natural ptr target::rwlock.state) state) + (when (zerop state) + (setf (%get-signed-natural ptr target::rwlock.writer) 0) + (let* ((nwriters (%get-natural ptr target::rwlock.blocked-writers)) + (nreaders (%get-natural ptr target::rwlock.blocked-readers))) + (declare (fixnum nreaders nwriters)) + (if (> nwriters 0) + (setq signal writer-signal wakeup 1) + (if (> nreaders 0) + (setq signal reader-signal wakeup #$INT_MAX))))) + (when signal (incf (%get-signed-natural signal 0))) + (%unlock-futex ptr) + (when signal (futex-wake signal wakeup)) + t))))) + + +(defun unlock-rwlock (lock) + (%unlock-rwlock-ptr (read-write-lock-ptr lock) lock)) + +;;; There are all kinds of ways to lose here. +;;; The caller must have read access to the lock exactly once, +;;; or have write access. +;;; there's currently no way to detect whether the caller has +;;; read access at all. +;;; If we have to block and get interrupted, cleanup code may +;;; try to unlock a lock that we don't hold. (It might be possible +;;; to circumvent that if we use the same notifcation object here +;;; that controls that cleanup process.) + +(defun %promote-rwlock (lock &optional flag) + (let* ((ptr (read-write-lock-ptr lock))) + (if (istruct-typep flag 'lock-acquisition) + (setf (lock-acquisition.status flag) nil) + (if flag (report-bad-arg flag 'lock-acquisition))) + (let* ((level *interrupt-level*) + (tcr (%current-tcr))) + (without-interrupts + #+futex + (%lock-futex ptr level lock nil) + #-futex + (%get-spin-lock ptr) + (let* ((state (%get-signed-natural ptr target::rwlock.state))) + (declare (fixnum state)) + (cond ((> state 0) + (unless (eql (%get-object ptr target::rwlock.writer) tcr) + #+futex + (%unlock-futex ptr) + #-futex + (setf (%get-natural ptr target::rwlock.spin) 0) + (error :not-lock-owner :lock lock))) + ((= state 0) + #+futex (%unlock-futex ptr) + #-futex (setf (%get-natural ptr target::rwlock.spin) 0) + (error :not-locked :lock lock)) + (t + (if (= state -1) + (progn + (setf (%get-signed-natural ptr target::rwlock.state) 1) + (%set-object ptr target::rwlock.writer tcr) + #+futex + (%unlock-futex ptr) + #-futex + (setf (%get-natural ptr target::rwlock.spin) 0) + (if flag + (setf (lock-acquisition.status flag) t)) + t) + (progn + #+futex + (%unlock-futex ptr) + #-futex + (setf (%get-natural ptr target::rwlock.spin) 0) + (%unlock-rwlock-ptr ptr lock) + (let* ((*interrupt-level* level)) + (%write-lock-rwlock-ptr ptr lock flag))))))))))) + + + +(defun safe-get-ptr (p &optional dest) + (if (null dest) + (setq dest (%null-ptr)) + (unless (typep dest 'macptr) + (check-type dest macptr))) + (without-interrupts ;reentrancy + (%safe-get-ptr p dest))) + + +;;; Useless for anything but using RLET in early level-1 code without +;;; having to bootstrap canonical type ordinals. +(%fhave 'parse-foreign-type (lambda (spec) (declare (ignore spec)))) +(%fhave 'foreign-type-ordinal (lambda (thing) (declare (ignore thing)) 0)) +(%fhave '%foreign-type-or-record (lambda (x) (declare (ignore x)))) Index: /branches/new-random/level-0/l0-numbers.lisp =================================================================== --- /branches/new-random/level-0/l0-numbers.lisp (revision 13309) +++ /branches/new-random/level-0/l0-numbers.lisp (revision 13309) @@ -0,0 +1,2035 @@ +;;; -*- Mode: Lisp; Package: CCL -*- +;;; +;;; Copyright (C) 2009 Clozure Associates +;;; Copyright (C) 1994-2001 Digitool, Inc +;;; This file is part of Clozure CL. +;;; +;;; Clozure CL is licensed under the terms of the Lisp Lesser GNU Public +;;; License , known as the LLGPL and distributed with Clozure CL as the +;;; file "LICENSE". The LLGPL consists of a preamble and the LGPL, +;;; which is distributed with Clozure CL as the file "LGPL". Where these +;;; conflict, the preamble takes precedence. +;;; +;;; Clozure CL is referenced in the preamble as the "LIBRARY." +;;; +;;; The LLGPL is also available online at +;;; http://opensource.franz.com/preamble.html + +;;; +;;; level-0;l0-numbers.lisp + +(in-package "CCL") + +(eval-when (:compile-toplevel :execute) + (require "ARCH") + (require "LISPEQU") + (require "NUMBER-MACROS") + (require "NUMBER-CASE-MACRO") + + + + (defvar *dfloat-dops* '((* . %double-float*-2!)(/ . %double-float/-2!) + (+ . %double-float+-2!)(- . %double-float--2!))) + + (defvar *sfloat-dops* '((* . %short-float*-2!)(/ . %short-float/-2!) + (+ . %short-float+-2!)(- . %short-float--2!))) + + (defmacro dfloat-rat (op x y &optional (destructive-op (cdr (assq op *dfloat-dops*)))) + (if destructive-op + (let ((f2 (gensym))) + `(let ((,f2 (%double-float ,y (%make-dfloat)))) + (,destructive-op ,x ,f2 ,f2))) + `(,op (the double-float ,x) (the double-float (%double-float ,y))))) + + (defmacro rat-dfloat (op x y &optional (destructive-op (cdr (assq op *dfloat-dops*)))) + (if destructive-op + (let ((f1 (gensym))) + `(let ((,f1 (%double-float ,x (%make-dfloat)))) + (,destructive-op ,f1 ,y ,f1))) + `(,op (the double-float (%double-float ,x)) (the double-float ,y)))) + + (defmacro sfloat-rat (op x y &optional (destructive-op (cdr (assq op *sfloat-dops*)))) + (let* ((use-destructive-op + (target-word-size-case + (32 destructive-op) + (64 nil)))) + (if use-destructive-op + (let ((f2 (gensym))) + `(let ((,f2 (%short-float ,y (%make-sfloat)))) + (,destructive-op ,x ,f2 ,f2))) + `(,op (the short-float ,x) (the short-float (%short-float ,y)))))) + + (defmacro rat-sfloat (op x y &optional (destructive-op (cdr (assq op *sfloat-dops*)))) + (let* ((use-destructive-op + (target-word-size-case + (32 destructive-op) + (64 nil)))) + (if use-destructive-op + (let ((f1 (gensym))) + `(let ((,f1 (%short-float ,x (%make-sfloat)))) + (,destructive-op ,f1 ,y ,f1))) + `(,op (the short-float (%short-float ,x)) (the short-float ,y))))) + + + + + + (declaim (inline %make-complex %make-ratio)) + (declaim (inline canonical-complex)) + (declaim (inline build-ratio)) + (declaim (inline maybe-truncate))) + + + +(defun %make-complex (realpart imagpart) + (gvector :complex realpart imagpart)) + +(defun %make-ratio (numerator denominator) + (gvector :ratio numerator denominator)) + + + +; this is no longer used +(defun %integer-signum (num) + (if (fixnump num) + (%fixnum-signum num) + ; there is no such thing as bignum zero we hope + (if (bignum-minusp num) -1 1))) + + +; Destructive primitives. +(macrolet ((defdestructive-df-op (non-destructive-name destructive-name op) + `(progn + (defun ,non-destructive-name (x y) + (,destructive-name x y (%make-dfloat))) + (defun ,destructive-name (x y result) + (declare (double-float x y result)) + (%setf-double-float result (the double-float (,op x y))))))) + (defdestructive-df-op %double-float+-2 %double-float+-2! +) + (defdestructive-df-op %double-float--2 %double-float--2! -) + (defdestructive-df-op %double-float*-2 %double-float*-2! *) + (defdestructive-df-op %double-float/-2 %double-float/-2! /)) + +#-64-bit-target +(macrolet ((defdestructive-sf-op (non-destructive-name destructive-name op) + `(progn + (defun ,non-destructive-name (x y) + (,destructive-name x y (%make-sfloat))) + (defun ,destructive-name (x y result) + (declare (short-float x y result)) + (%setf-short-float result (the short-float (,op x y))))))) + (defdestructive-sf-op %short-float+-2 %short-float+-2! +) + (defdestructive-sf-op %short-float--2 %short-float--2! -) + (defdestructive-sf-op %short-float*-2 %short-float*-2! *) + (defdestructive-sf-op %short-float/-2 %short-float/-2! /)) + + +(defun %negate (x) + (number-case x + (fixnum (- (the fixnum x))) + (double-float (%double-float-negate! x (%make-dfloat))) + (short-float + #+32-bit-target (%short-float-negate! x (%make-sfloat)) + #+64-bit-target (%short-float-negate x)) + (bignum (negate-bignum x)) + (ratio (%make-ratio (%negate (%numerator x)) (%denominator x))) + (complex (%make-complex (%negate (%realpart X))(%negate (%imagpart X))) ))) + +(defun %double-float-zerop (n) + (zerop (the double-float n))) + +(defun %short-float-zerop (n) + (zerop (the single-float n))) + +(defun zerop (number) + "Is this number zero?" + (number-case number + (integer (eq number 0)) + (short-float (%short-float-zerop number)) + (double-float (%double-float-zerop number)) + (ratio nil) + (complex + (number-case (%realpart number) + (short-float (and (%short-float-zerop (%realpart number)) + (%short-float-zerop (%imagpart number)))) + (double-float (and (%double-float-zerop (%realpart number)) + (%double-float-zerop (%imagpart number)))) + (t (and (eql 0 (%realpart number))(eql 0 (%imagpart number)))))))) + +(defun %short-float-plusp (x) + (> (the single-float x) 0.0f0)) + +(defun %double-float-plusp (x) + (> (the double-float x) 0.0d0)) + +(defun plusp (number) + "Is this real number strictly positive?" + (number-case number + (fixnum (%i> number 0)) + (bignum (bignum-plusp number)) + (short-float (%short-float-plusp number)) + (double-float (%double-float-plusp number)) + (ratio (plusp (%numerator number))))) + + +(defun minusp (number) + "Is this real number strictly negative?" + (number-case number + (fixnum (%i< number 0)) + (bignum (bignum-minusp number)) + (short-float (%short-float-minusp number)) + (double-float (%double-float-minusp number)) + (ratio (minusp (%numerator number))))) + + +(defun oddp (n) + "Is this integer odd?" + (case (typecode n) + (#.target::tag-fixnum (logbitp 0 (the fixnum n))) + (#.target::subtag-bignum (%bignum-oddp n)) + (t (report-bad-arg n 'integer)))) + +(defun evenp (n) + "Is this integer even?" + (case (typecode n) + (#.target::tag-fixnum (not (logbitp 0 (the fixnum n)))) + (#.target::subtag-bignum (not (%bignum-oddp n))) + (t (report-bad-arg n 'integer)))) + +;; expansion slightly changed +(defun =-2 (x y) + (number-case x + (fixnum (number-case y + (fixnum (eq x y)) + (double-float (eq 0 (fixnum-dfloat-compare x y))) + (short-float (eq 0 (fixnum-sfloat-compare x y))) + ((bignum ratio) nil) + (complex (and (zerop (%imagpart y)) (= x (%realpart y)))))) + (double-float (number-case y ; x + (double-float (= (the double-float x)(the double-float y))) ;x + (short-float (with-stack-double-floats ((dy y)) + (= (the double-float x) (the double-float dy)))) + (fixnum (eq 0 (fixnum-dfloat-compare y x))) + (bignum (eq 0 (bignum-dfloat-compare y x))) + (ratio (= (rational x) y)) + (complex (and (zerop (%imagpart y)) (= x (%realpart y)))))) + (short-float (number-case y + (short-float (= (the short-float x) (the short-float y))) + (double-float (with-stack-double-floats ((dx x)) + (= (the double-float dx) (the double-float y)))) + (fixnum (eq 0 (fixnum-sfloat-compare y x))) + (bignum (eq 0 (bignum-sfloat-compare y x))) + (ratio (= (rational x) y)) + (complex (and (zerop (%imagpart y)) (= x (%realpart y)))))) + (bignum (number-case y + (bignum (eq 0 (bignum-compare x y))) + ((fixnum ratio) nil) + (double-float (eq 0 (bignum-dfloat-compare x y))) + (short-float (eq 0 (bignum-sfloat-compare x y))) + (complex (and (zerop (%imagpart y)) (= x (%realpart y)))))) + (ratio (number-case y + (integer nil) + (ratio + (and (eql (%numerator x) (%numerator y)) + (eql (%denominator x) (%denominator y)))) + (float (= x (rational y))) + (complex (and (zerop (%imagpart y)) (= x (%realpart y)))))) + (complex (number-case y + (complex (and (= (%realpart x) (%realpart y)) + (= (%imagpart x) (%imagpart y)))) + ((float rational) + (and (zerop (%imagpart x)) (= (%realpart x) y))))))) + +(defun /=-2 (x y) + (declare (notinline =-2)) + (not (= x y))) + + +; true iff (< x y) is false. +(defun >=-2 (x y) + (declare (notinline <-2)) + (not (< x y))) + + + +(defun <=-2 (x y) + (declare (notinline >-2)) + (not (> x y))) + +(defun <-2 (x y) + (number-case x + (fixnum (number-case y + (fixnum (< (the fixnum x) (the fixnum y))) + (double-float (eq -1 (fixnum-dfloat-compare x y))) + (short-float (eq -1 (fixnum-sfloat-compare x y))) + (bignum (bignum-plusp y)) + (ratio (< x (ceiling (%numerator y)(%denominator y)))))) + (double-float (number-case y ; x + (double-float (< (the double-float x)(the double-float y))) ;x + (short-float (with-stack-double-floats ((dy y)) + (< (the double-float x) (the double-float dy)))) + (fixnum (eq 1 (fixnum-dfloat-compare y x))) + (bignum (eq 1 (bignum-dfloat-compare y x))) + (ratio (< (rational x) y)))) + (short-float (number-case y + (short-float (< (the short-float x) (the short-float y))) + (double-float (with-stack-double-floats ((dx x)) + (< (the double-float dx) (the double-float y)))) + (fixnum (eq 1 (fixnum-sfloat-compare y x))) + (bignum (eq 1 (bignum-sfloat-compare y x))) + (ratio (< (rational x) y)))) + (bignum (number-case y + (bignum (EQ -1 (bignum-compare x y))) + (fixnum (not (bignum-plusp x))) + (ratio (< x (ceiling (%numerator y)(%denominator y)))) + (double-float (eq -1 (bignum-dfloat-compare x y))) + (short-float (eq -1 (bignum-sfloat-compare x y))))) + (ratio (number-case y + (integer (< (floor (%numerator x)(%denominator x)) y)) + (ratio + (< (* (%numerator (the ratio x)) + (%denominator (the ratio y))) + (* (%numerator (the ratio y)) + (%denominator (the ratio x))))) + (float (< x (rational y))))))) + + + +(defun >-2 (x y) + ;(declare (optimize (speed 3)(safety 0))) + (number-case x + (fixnum (number-case y + (fixnum (> (the fixnum x) (the fixnum y))) + (bignum (not (bignum-plusp y))) + (double-float (eq 1 (fixnum-dfloat-compare x y))) + (short-float (eq 1 (fixnum-sfloat-compare x y))) + ;; or (> (* x denom) num) ? + (ratio (> x (floor (%numerator y) (%denominator y)))))) + (double-float (number-case y + (double-float (> (the double-float x) (the double-float y))) + (short-float (with-stack-double-floats ((dy y)) + (> (the double-float x) (the double-float dy)))) + (fixnum (eq -1 (fixnum-dfloat-compare y x))) + (bignum (eq -1 (bignum-dfloat-compare y x))) + (ratio (> (rational x) y)))) + (short-float (number-case y + (short-float (> (the short-float x) (the short-float y))) + (double-float (with-stack-double-floats ((dx x)) + (> (the double-float dx) (the double-float y)))) + (fixnum (eq -1 (fixnum-sfloat-compare y x))) + (bignum (eq -1 (bignum-sfloat-compare y x))) + (ratio (> (rational x) y)))) + (bignum (number-case y + (fixnum (bignum-plusp x)) + (bignum (eq 1 (bignum-compare x y))) + ;; or (> (* x demon) num) + (ratio (> x (floor (%numerator y) (%denominator y)))) + (double-float (eq 1 (bignum-dfloat-compare x y))) + (short-float (eq 1 (bignum-sfloat-compare x y))))) + (ratio (number-case y + ;; or (> num (* y denom)) + (integer (> (ceiling (%numerator x) (%denominator x)) y)) + (ratio + (> (* (%numerator (the ratio x)) + (%denominator (the ratio y))) + (* (%numerator (the ratio y)) + (%denominator (the ratio x))))) + (float (> x (rational y))))))) + + +; t if any bits set after exp (unbiased) +(defun hi-lo-fraction-p (hi lo exp) + (declare (fixnum hi lo exp)) + (if (> exp 24) + (not (eql 0 (%ilogand lo (%ilsr (- exp 25) #xfffffff)))) + (or (not (zerop lo))(not (eql 0 (%ilogand hi (%ilsr exp #x1ffffff))))))) + + + +(defun negate-hi-lo (hi lo) + (setq hi (%ilogxor hi #x3ffffff)) + (if (eq 0 lo) + (setq hi (+ hi 1)) + (setq lo (+ (%ilogxor lo #xfffffff) 1))) + (values hi lo)) + + + +(defun fixnum-dfloat-compare (int dfloat) + (declare (double-float dfloat) (fixnum int)) + (if (and (eq int 0)(= dfloat 0.0d0)) + 0 + (with-stack-double-floats ((d1 int)) + (locally (declare (double-float d1)) + (if (eq int (%truncate-double-float->fixnum d1)) + (cond ((< d1 dfloat) -1) + ((= d1 dfloat) 0) + (t 1)) + ;; Whatever we do here should have the effect + ;; of comparing the integer to the result of calling + ;; RATIONAL on the float. We could probably + ;; skip the call to RATIONAL in more cases, + ;; but at least check the obvious ones here + ;; (e.g. different signs) + (multiple-value-bind (mantissa exponent sign) + (integer-decode-double-float dfloat) + (declare (type (integer -1 1) sign) + (fixnum exponent)) + (cond ((zerop int) + (- sign)) + ((and (< int 0) (eql sign 1)) -1) + ((and (> int 0) (eql sign -1)) 1) + (t + ;; See RATIONAL. Can probably avoid this if + ;; magnitudes are clearly dissimilar. + (if (= sign -1) (setq mantissa (- mantissa))) + (let* ((rat (if (< exponent 0) + (/ mantissa (ash 1 (the fixnum (- exponent)))) + (ash mantissa exponent)))) + (if (< int rat) + -1 + (if (eq int rat) + 0 + 1))))))))))) + + + +(defun fixnum-sfloat-compare (int sfloat) + (declare (short-float sfloat) (fixnum int)) + (if (and (eq int 0)(= sfloat 0.0s0)) + 0 + (#+32-bit-target target::with-stack-short-floats #+32-bit-target ((s1 int)) + #-32-bit-target let* #-32-bit-target ((s1 (%int-to-sfloat int))) + (locally + (declare (short-float s1)) + (if (eq (%truncate-short-float->fixnum s1) int) + (cond ((< s1 sfloat) -1) + ((= s1 sfloat) 0) + (t 1)) + ;; Whatever we do here should have the effect + ;; of comparing the integer to the result of calling + ;; RATIONAL on the float. We could probably + ;; skip the call to RATIONAL in more cases, + ;; but at least check the obvious ones here + ;; (e.g. different signs) + (multiple-value-bind (mantissa exponent sign) + (integer-decode-short-float sfloat) + (declare (type (integer -1 1) sign) + (fixnum exponent)) + (cond ((zerop int) + (- sign)) + ((and (< int 0) (eql sign 1)) -1) + ((and (> int 0) (eql sign -1)) 1) + (t + ;; See RATIONAL. Can probably avoid this if + ;; magnitudes are clearly dissimilar. + (if (= sign -1) (setq mantissa (- mantissa))) + (let* ((rat (if (< exponent 0) + (/ mantissa (ash 1 (the fixnum (- exponent)))) + (ash mantissa exponent)))) + (if (< int rat) + -1 + (if (eq int rat) + 0 + 1))))))))))) + + + +;;; lotta stuff to avoid making a rational from a float +;;; returns -1 less, 0 equal, 1 greater +(defun bignum-dfloat-compare (int float) + (cond + ((and (eq int 0)(= float 0.0d0)) 0) + (t + (let* ((fminus (%double-float-minusp float)) + (iminus (minusp int)) + (gt (if iminus -1 1))) + (declare (fixnum gt)) + (if (neq fminus iminus) + gt ; if different signs, done + (let ((intlen (integer-length int)) + (exp (- (the fixnum (%double-float-exp float)) 1022))) + (declare (fixnum intlen exp)) + (cond + ((and (not fminus) (< intlen exp)) -1) + ((> intlen exp) gt) ; if different exp, done + ((and fminus (or (< (1+ intlen) exp) + (and (= (1+ intlen) exp) + (neq (one-bignum-factor-of-two int) intlen)))) + ;(print 'zow) + (the fixnum (- gt))) ; ; integer-length is strange for neg powers of 2 + (t (multiple-value-bind (hi lo)(fixnum-decode-float float) + (declare (fixnum hi lo)) + (when fminus (multiple-value-setq (hi lo)(negate-hi-lo hi lo))) + (let* ((sz 26) ; exp > 28 always + (pos (- exp 25)) + (big-bits (%ldb-fixnum-from-bignum int sz pos))) + (declare (fixnum pos big-bits sz)) + ;(print (list big-bits hi sz pos)) + (cond + ((< big-bits hi) -1) + ((> big-bits hi) 1) + (t (let* ((sz (min (- exp 25) 28)) + (pos (- exp 25 sz)) ; ? + (ilo (if (< exp 53) (ash lo (- exp 53)) lo)) + (big-bits (%ldb-fixnum-from-bignum int sz pos))) + (declare (fixnum pos sz ilo big-bits)) + ;(PRINT (list big-bits ilo)) + (cond + ((< big-bits ilo) -1) + ((> big-bits ilo) 1) + ((eq exp 53) 0) + ((< exp 53) + (if (not (hi-lo-fraction-p hi lo exp)) 0 -1)) ; -1 if pos + (t (if (%i< (one-bignum-factor-of-two int) (- exp 53)) 1 0))))))) + ))))))))) + + + +;;; I don't know if it's worth doing a more "real" version of this. +(defun bignum-sfloat-compare (int float) + (with-stack-double-floats ((df float)) + (bignum-dfloat-compare int df))) + +;;;; Canonicalization utilities: + +;;; CANONICAL-COMPLEX -- Internal +;;; +;;; If imagpart is 0, return realpart, otherwise make a complex. This is +;;; used when we know that realpart and imagpart are the same type, but +;;; rational canonicalization might still need to be done. +;;; + +(defun canonical-complex (realpart imagpart) + (if (eql imagpart 0) + realpart + (%make-complex realpart imagpart))) + + + + +(defun +-2 (x y) + (number-case x + (fixnum (number-case y + (fixnum (+ (the fixnum x) (the fixnum y))) + (double-float (rat-dfloat + x y)) + (short-float (rat-sfloat + x y)) + (bignum (add-bignum-and-fixnum y x)) + (complex (complex (+ x (%realpart y)) + (%imagpart y))) + (ratio (let* ((dy (%denominator y)) + (n (+ (* x dy) (%numerator y)))) + (%make-ratio n dy))))) + (double-float (number-case y + (double-float (+ (the double-float x) (the double-float y))) + (short-float (with-stack-double-floats ((dy y)) + (+ (the double-float x) (the double-float dy)))) + (rational (dfloat-rat + x y)) + (complex (complex (+ x (%realpart y)) + (%imagpart y))))) + (short-float (number-case y + (short-float (+ (the short-float x) (the short-float y))) + (double-float (with-stack-double-floats ((dx x)) + (+ (the double-float dx) (the double-float y)))) + (rational (sfloat-rat + x y)) + (complex (complex (+ x (%realpart y)) + (%imagpart y))))) + (bignum (number-case y + (bignum (add-bignums x y)) + (fixnum (add-bignum-and-fixnum x y)) + (double-float (rat-dfloat + x y)) + (short-float (rat-sfloat + x y)) + (complex (complex (+ x (realpart y)) + (%imagpart y))) + (ratio + (let* ((dy (%denominator y)) + (n (+ (* x dy) (%numerator y)))) + (%make-ratio n dy))))) + (complex (number-case y + (complex (canonical-complex (+ (%realpart x) (%realpart y)) + (+ (%imagpart x) (%imagpart y)))) + ((rational float) (complex (+ (%realpart x) y) (%imagpart x))))) + (ratio (number-case y + (ratio + (let* ((nx (%numerator x)) + (dx (%denominator x)) + (ny (%numerator y)) + (dy (%denominator y)) + (g1 (gcd dx dy))) + (if (eql g1 1) + (%make-ratio (+ (* nx dy) (* dx ny)) (* dx dy)) + (let* ((t1 (+ (* nx (truncate dy g1)) (* (truncate dx g1) ny))) + (g2 (gcd t1 g1)) + (t2 (truncate dx g1))) + (cond ((eql t1 0) 0) + ((eql g2 1) (%make-ratio t1 (* t2 dy))) + (t + (let* ((nn (truncate t1 g2)) + (t3 (truncate dy g2)) + (nd (if (eql t2 1) t3 (* t2 t3)))) + (if (eql nd 1) nn (%make-ratio nn nd))))))))) + (integer + (let* ((dx (%denominator x)) (n (+ (%numerator x) (* y dx)))) + (%make-ratio n dx))) + (double-float (rat-dfloat + x y)) + (short-float (rat-sfloat + x y)) + (complex (complex (+ x (%realpart y)) + (%imagpart y))))))) + +(defun --2 (x y) + (number-case x + (fixnum (number-case y + (fixnum (- (the fixnum x) (the fixnum y))) + (double-float (rat-dfloat - x y)) + (short-float (rat-sfloat - x y)) + (bignum + (with-small-bignum-buffers ((bx x)) + (subtract-bignum bx y))) + (complex (complex (- x (%realpart y)) + (- (%imagpart y)))) + (ratio (let* ((dy (%denominator y)) + (n (- (* x dy) (%numerator y)))) + (%make-ratio n dy))))) + (double-float (number-case y + (double-float (- (the double-float x) (the double-float y))) + (short-float (with-stack-double-floats ((dy y)) + (- (the double-float x) (the double-float dy)))) + (rational (dfloat-rat - x y)) + (complex (complex (- x (%realpart y)) + (- (%imagpart y)))))) + (short-float (number-case y + (short-float (- (the short-float x) (the short-float y))) + (double-float (with-stack-double-floats ((dx x)) + (- (the double-float dx) (the double-float y)))) + (rational (sfloat-rat - x y)) + (complex (complex (- x (%realpart y)) + (- (%imagpart y)))))) + (bignum (number-case y + (bignum (subtract-bignum x y)) + (fixnum (if (eql y target::target-most-negative-fixnum) + (with-small-bignum-buffers ((by y)) + (subtract-bignum x by)) + (add-bignum-and-fixnum x (- y)))) + (double-float (rat-dfloat - x y)) + (short-float (rat-sfloat - x y)) + (complex (complex (- x (realpart y)) + (- (%imagpart y)))) + (ratio + (let* ((dy (%denominator y)) + (n (- (* x dy) (%numerator y)))) + (%make-ratio n dy))))) + (complex (number-case y + (complex (canonical-complex (- (%realpart x) (%realpart y)) + (- (%imagpart x) (%imagpart y)))) + ((rational float) (complex (- (%realpart x) y) (%imagpart x))))) + (ratio (number-case y + (ratio + (let* ((nx (%numerator x)) + (dx (%denominator x)) + (ny (%numerator y)) + (dy (%denominator y)) + (g1 (gcd dx dy))) + (if (eql g1 1) + (%make-ratio (- (* nx dy) (* dx ny)) (* dx dy)) + (let* ((t1 (- (* nx (truncate dy g1)) (* (truncate dx g1) ny))) + (g2 (gcd t1 g1)) + (t2 (truncate dx g1))) + (cond ((eql t1 0) 0) + ((eql g2 1) (%make-ratio t1 (* t2 dy))) + (t + (let* ((nn (truncate t1 g2)) + (t3 (truncate dy g2)) + (nd (if (eql t2 1) t3 (* t2 t3)))) + (if (eql nd 1) nn (%make-ratio nn nd))))))))) + (integer + (let* ((dx (%denominator x)) (n (- (%numerator x) (* y dx)))) + (%make-ratio n dx))) + (double-float (rat-dfloat - x y)) + (short-float (rat-sfloat - x y)) + (complex (complex (- x (%realpart y)) + (- (%imagpart y)))))))) + + +;;; BUILD-RATIO -- Internal +;;; +;;; Given a numerator and denominator with the GCD already divided out, make +;;; a canonical rational. We make the denominator positive, and check whether +;;; it is 1. +;;; + +(defun build-ratio (num den) + (if (minusp den) (setq num (- num) den (- den))) + (case den + (0 (divide-by-zero-error 'build-ratio num den)) + (1 num) + (t (%make-ratio num den)))) + + + + +;;; MAYBE-TRUNCATE -- Internal +;;; +;;; Truncate X and Y, but bum the case where Y is 1. +;;; + + +(defun maybe-truncate (x y) + (if (eql y 1) + x + (truncate x y))) + +(defun *-2 (x y) + ;(declare (optimize (speed 3)(safety 0))) + (flet ((integer*ratio (x y) + (if (eql x 0) 0 + (let* ((ny (%numerator y)) + (dy (%denominator y)) + (gcd (gcd x dy))) + (if (eql gcd 1) + (%make-ratio (* x ny) dy) + (let ((nn (* (truncate x gcd) ny)) + (nd (truncate dy gcd))) + (if (eql nd 1) + nn + (%make-ratio nn nd))))))) + (complex*real (x y) + (canonical-complex (* (%realpart x) y) (* (%imagpart x) y)))) + (number-case x + (double-float (number-case y + (double-float (* (the double-float x)(the double-float y))) + (short-float (with-stack-double-floats ((dy y)) + (* (the double-float x) (the double-float dy)))) + (rational (dfloat-rat * x y)) + (complex (complex*real y x)))) + (short-float (number-case y + (double-float (with-stack-double-floats ((dx x)) + (* (the double-float dx) (the double-float y)))) + (short-float (* (the short-float x) (the short-float y))) + (rational (sfloat-rat * x y)) + (complex (complex*real y x)))) + (bignum (number-case y + (fixnum (multiply-bignum-and-fixnum x y)) + (bignum (multiply-bignums x y)) + (double-float (dfloat-rat * y x)) + (short-float (sfloat-rat * y x)) + (ratio (integer*ratio x y)) + (complex (complex*real y x)))) + (fixnum (number-case y + (bignum (multiply-bignum-and-fixnum y x)) + (fixnum (multiply-fixnums (the fixnum x) (the fixnum y))) + (short-float (sfloat-rat * y x)) + (double-float (dfloat-rat * y x)) + (ratio (integer*ratio x y)) + (complex (complex*real y x)))) + (complex (number-case y + (complex (let* ((rx (%realpart x)) + (ix (%imagpart x)) + (ry (%realpart y)) + (iy (%imagpart y))) + (canonical-complex (- (* rx ry) (* ix iy)) (+ (* rx iy) (* ix ry))))) + (real (complex*real x y)))) + (ratio (number-case y + (ratio (let* ((nx (%numerator x)) + (dx (%denominator x)) + (ny (%numerator y)) + (dy (%denominator y)) + (g1 (gcd nx dy)) + (g2 (gcd dx ny))) + (build-ratio (* (maybe-truncate nx g1) + (maybe-truncate ny g2)) + (* (maybe-truncate dx g2) + (maybe-truncate dy g1))))) + (integer (integer*ratio y x)) + (double-float (rat-dfloat * x y)) + (short-float (rat-sfloat * x y)) + (complex (complex*real y x))))))) + + + +(defun integer*integer (x y &optional res) + (declare (ignore res)) + (number-case x + (fixnum (number-case y + (fixnum (* (the fixnum x) (the fixnum y))) + (t (multiply-bignum-and-fixnum y x)))) + (bignum (number-case y + (fixnum (multiply-bignum-and-fixnum x y)) + (t (multiply-bignums x y)))))) + + + + + +;;; INTEGER-/-INTEGER -- Internal +;;; +;;; Divide two integers, producing a canonical rational. If a fixnum, we +;;; see if they divide evenly before trying the GCD. In the bignum case, we +;;; don't bother, since bignum division is expensive, and the test is not very +;;; likely to suceed. +;;; +(defun integer-/-integer (x y) + (if (and (typep x 'fixnum) (typep y 'fixnum)) + (multiple-value-bind (quo rem) (%fixnum-truncate x y) + (if (eql 0 rem) + quo + (let ((gcd (gcd x y))) + (declare (fixnum gcd)) + (if (eql gcd 1) + (build-ratio x y) + (build-ratio (%fixnum-truncate x gcd) (%fixnum-truncate y gcd)))))) + (let ((gcd (gcd x y))) + (if (eql gcd 1) + (build-ratio x y) + (build-ratio (truncate x gcd) (truncate y gcd)))))) + + + +(defun /-2 (x y) + (number-case x + (double-float (number-case y + (double-float (/ (the double-float x) (the double-float y))) + (short-float (with-stack-double-floats ((dy y)) + (/ (the double-float x) (the double-float dy)))) + (rational (dfloat-rat / x y)) + (complex (let* ((ry (%realpart y)) + (iy (%imagpart y)) + (dn (+ (* ry ry) (* iy iy)))) + (canonical-complex (/ (* x ry) dn) (/ (- (* x iy)) dn)))))) + (short-float (number-case y + (short-float (/ (the short-float x) (the short-float y))) + (double-float (with-stack-double-floats ((dx x)) + (/ (the double-float dx) (the double-float y)))) + (rational (sfloat-rat / x y)) + (complex (let* ((ry (%realpart y)) + (iy (%imagpart y)) + (dn (+ (* ry ry) (* iy iy)))) + (canonical-complex (/ (* x ry) dn) (/ (- (* x iy)) dn)))))) + (integer (number-case y + (double-float (rat-dfloat / x y)) + (short-float (rat-sfloat / x y)) + (integer (integer-/-integer x y)) + (complex (let* ((ry (%realpart y)) + (iy (%imagpart y)) + (dn (+ (* ry ry) (* iy iy)))) + (canonical-complex (/ (* x ry) dn) (/ (- (* x iy)) dn)))) + (ratio + (if (eql 0 x) + 0 + (let* ((ny (%numerator y)) + (dy (%denominator y)) + (gcd (gcd x ny))) + (build-ratio (* (maybe-truncate x gcd) dy) + (maybe-truncate ny gcd))))))) + (complex (number-case y + (complex (let* ((rx (%realpart x)) + (ix (%imagpart x)) + (ry (%realpart y)) + (iy (%imagpart y)) + (dn (+ (* ry ry) (* iy iy)))) + (canonical-complex (/ (+ (* rx ry) (* ix iy)) dn) + (/ (- (* ix ry) (* rx iy)) dn)))) + ((rational float) + (canonical-complex (/ (%realpart x) y) (/ (%imagpart x) y))))) + (ratio (number-case y + (double-float (rat-dfloat / x y)) + (short-float (rat-sfloat / x y)) + (integer + (when (eql y 0) + (divide-by-zero-error '/ x y)) + (let* ((nx (%numerator x)) (gcd (gcd nx y))) + (build-ratio (maybe-truncate nx gcd) + (* (maybe-truncate y gcd) (%denominator x))))) + (complex (let* ((ry (%realpart y)) + (iy (%imagpart y)) + (dn (+ (* ry ry) (* iy iy)))) + (canonical-complex (/ (* x ry) dn) (/ (- (* x iy)) dn)))) + (ratio + (let* ((nx (%numerator x)) + (dx (%denominator x)) + (ny (%numerator y)) + (dy (%denominator y)) + (g1 (gcd nx ny)) + (g2 (gcd dx dy))) + (build-ratio (* (maybe-truncate nx g1) (maybe-truncate dy g2)) + (* (maybe-truncate dx g2) (maybe-truncate ny g1))))))))) + + + +(defun divide-by-zero-error (operation &rest operands) + (error (make-condition 'division-by-zero + :operation operation + :operands operands))) + + +(defun 1+ (number) + "Returns NUMBER + 1." + (+-2 number 1)) + +(defun 1- (number) + "Returns NUMBER - 1." + (--2 number 1)) + + + + +(defun conjugate (number) + "Return the complex conjugate of NUMBER. For non-complex numbers, this is + an identity." + (number-case number + (complex (complex (%realpart number) (- (%imagpart number)))) + (number number))) + +(defun numerator (rational) + "Return the numerator of NUMBER, which must be rational." + (number-case rational + (ratio (%numerator rational)) + (integer rational))) + +(defun denominator (rational) + "Return the denominator of NUMBER, which must be rational." + (number-case rational + (ratio (%denominator rational)) + (integer 1))) + + + +(defun abs (number) + "Return the absolute value of the number." + (number-case number + (fixnum + (locally (declare (fixnum number)) + (if (minusp number) (- number) number))) + (double-float + (%double-float-abs number)) + (short-float + (%short-float-abs number)) + (bignum + (if (bignum-minusp number)(negate-bignum number) number)) + (ratio + (if (minusp number) (- number) number)) + (complex + (let ((rx (%realpart number)) + (ix (%imagpart number))) + (number-case rx + (rational + (sqrt (+ (* rx rx) (* ix ix)))) + (short-float + (%short-float (%hypot (%double-float rx) + (%double-float ix)))) + (double-float + (%hypot rx ix))))))) + + + +(defun phase (number) + "Return the angle part of the polar representation of a complex number. + For complex numbers, this is (atan (imagpart number) (realpart number)). + For non-complex positive numbers, this is 0. For non-complex negative + numbers this is PI." + (number-case number + (rational + (if (minusp number) + (%short-float pi) + 0.0f0)) + (double-float + (if (minusp number) + (%double-float pi) + 0.0d0)) + (complex + (atan (%imagpart number) (%realpart number))) + (short-float + (if (minusp number) + (%short-float pi) + 0.0s0)))) + + + +; from Lib;numbers.lisp, sort of +(defun float (number &optional other) + "Converts any REAL to a float. If OTHER is not provided, it returns a + SINGLE-FLOAT if NUMBER is not already a FLOAT. If OTHER is provided, the + result is the same float format as OTHER." + (if (null other) + (if (typep number 'float) + number + (%short-float number)) + (if (typep other 'double-float) + (%double-float number) + (if (typep other 'short-float) + (%short-float number) + (float number (require-type other 'float)))))) + + + + + +;;; If the numbers do not divide exactly and the result of (/ number divisor) +;;; would be negative then decrement the quotient and augment the remainder by +;;; the divisor. +;;; +(defun floor (number &optional divisor) + "Return the greatest integer not greater than number, or number/divisor. + The second returned value is (mod number divisor)." + (if (null divisor)(setq divisor 1)) + (multiple-value-bind (tru rem) (truncate number divisor) + (if (and (not (zerop rem)) + (if (minusp divisor) + (plusp number) + (minusp number))) + (if (called-for-mv-p) + (values (1- tru) (+ rem divisor)) + (1- tru)) + (values tru rem)))) + + + +(defun %fixnum-floor (number divisor) + (declare (fixnum number divisor)) + (if (eq divisor 1) + (values number 0) + (multiple-value-bind (tru rem) (truncate number divisor) + (if (eq rem 0) + (values tru 0) + (locally (declare (fixnum tru rem)) + (if (and ;(not (zerop rem)) + (if (minusp divisor) + (plusp number) + (minusp number))) + (values (the fixnum (1- tru)) (the fixnum (+ rem divisor))) + (values tru rem))))))) + + + +;;; If the numbers do not divide exactly and the result of (/ number divisor) +;;; would be positive then increment the quotient and decrement the remainder by +;;; the divisor. +;;; +(defun ceiling (number &optional divisor) + "Return the smallest integer not less than number, or number/divisor. + The second returned value is the remainder." + (if (null divisor)(setq divisor 1)) + (multiple-value-bind (tru rem) (truncate number divisor) + (if (and (not (zerop rem)) + (if (minusp divisor) + (minusp number) + (plusp number))) + (if (called-for-mv-p) + (values (+ tru 1) (- rem divisor)) + (+ tru 1)) + (values tru rem)))) + + + +(defun %fixnum-ceiling (number divisor) + "Returns the smallest integer not less than number, or number/divisor. + The second returned value is the remainder." + (declare (fixnum number divisor)) + (multiple-value-bind (tru rem) (%fixnum-truncate number divisor) + (if (eq 0 rem) + (values tru 0) + (locally (declare (fixnum tru rem)) + (if (and ;(not (zerop rem)) + (if (minusp divisor) + (minusp number) + (plusp number))) + (values (the fixnum (+ tru 1))(the fixnum (- rem divisor))) + (values tru rem)))))) + + + +(defun integer-decode-denorm-short-float (mantissa sign) + (declare (fixnum mantissa sign)) + (do* ((bias 0 (1+ bias)) + (sig mantissa (ash sig 1))) + ((logbitp 23 sig) + (values sig + (- (- IEEE-single-float-bias) + IEEE-single-float-digits + bias) + sign)))) + + +(defun integer-decode-short-float (sfloat) + (multiple-value-bind (mantissa exp sign)(fixnum-decode-short-float sfloat) + (let* ((biased (- exp IEEE-single-float-bias IEEE-single-float-digits))) + (setq sign (if (eql 0 sign) 1 -1)) + (if (eq exp 255) + (error "Can't decode NAN/Inf: ~s" sfloat)) + (if (eql 0 exp) + (if (eql 0 mantissa) + (values 0 biased sign) + (integer-decode-denorm-short-float (ash mantissa 1) sign)) + (values (logior #x800000 mantissa) biased sign))))) + + + + +;;; INTEGER-DECODE-FLOAT -- Public +;;; +;;; Dispatch to the correct type-specific i-d-f function. +;;; +(defun integer-decode-float (x) + "Returns three values: + 1) an integer representation of the significand. + 2) the exponent for the power of 2 that the significand must be multiplied + by to get the actual value. This differs from the DECODE-FLOAT exponent + by FLOAT-DIGITS, since the significand has been scaled to have all its + digits before the radix point. + 3) -1 or 1 (i.e. the sign of the argument.)" + (number-case x + (short-float + (integer-decode-short-float x)) + (double-float + (integer-decode-double-float x)))) + + +;;; %UNARY-TRUNCATE -- Interface +;;; +;;; This function is called when we are doing a truncate without any funky +;;; divisor, i.e. converting a float or ratio to an integer. Note that we do +;;; *not* return the second value of truncate, so it must be computed by the +;;; caller if needed. +;;; +;;; In the float case, we pick off small arguments so that compiler can use +;;; special-case operations. We use an exclusive test, since (due to round-off +;;; error), (float most-positive-fixnum) may be greater than +;;; most-positive-fixnum. +;;; +(defun %unary-truncate (number) + (number-case number + (integer number) + (ratio (truncate-no-rem (%numerator number) (%denominator number))) + (double-float + (if (and (< (the double-float number) + (float (1- (ash 1 (- (1- target::nbits-in-word) target::fixnumshift))) 0.0d0)) + (< (float (ash -1 (- (1- target::nbits-in-word) target::fixnumshift)) 0.0d0) + (the double-float number))) + (%truncate-double-float->fixnum number) + (%truncate-double-float number))) + (short-float + (if (and (< (the short-float number) + (float (1- (ash 1 (- (1- target::nbits-in-word) target::fixnumshift))) 0.0s0)) + (< (float (ash -1 (- (1- target::nbits-in-word) target::fixnumshift)) 0.0s0) + (the short-float number))) + (%truncate-short-float->fixnum number) + (%truncate-short-float number))))) + + + +; cmucl:compiler:float-tran.lisp +(defun xform-truncate (x) + (let ((res (%unary-truncate x))) + (values res (- x res)))) + + + +(defun truncate (number &optional divisor) + "Returns number (or number/divisor) as an integer, rounded toward 0. + The second returned value is the remainder." + (if (null divisor)(setq divisor 1)) + (when (not (called-for-mv-p)) + (return-from truncate (truncate-no-rem number divisor))) + (macrolet + ((truncate-rat-dfloat (number divisor) + `(with-stack-double-floats ((fnum ,number) + (f2)) + (let ((res (%unary-truncate (%double-float/-2! fnum ,divisor f2)))) + (values res + (%double-float--2 fnum (%double-float*-2! (%double-float res f2) ,divisor f2)))))) + (truncate-rat-sfloat (number divisor) + #+32-bit-target + `(target::with-stack-short-floats ((fnum ,number) + (f2)) + (let ((res (%unary-truncate (%short-float/-2! fnum ,divisor f2)))) + (values res + (%short-float--2 fnum (%short-float*-2! (%short-float res f2) ,divisor f2))))) + #+64-bit-target + `(let* ((temp (%short-float ,number)) + (res (%unary-truncate (/ (the short-float temp) + (the short-float ,divisor))))) + (values res + (- (the short-float temp) + (the short-float (* (the short-float (%short-float res)) + (the short-float ,divisor))))))) + ) + (number-case number + (fixnum + (if (eql number target::target-most-negative-fixnum) + (if (zerop divisor) + (error 'division-by-zero :operation 'truncate :operands (list number divisor)) + (with-small-bignum-buffers ((bn number)) + (multiple-value-bind (quo rem) (truncate bn divisor) + (if (eq quo bn) + (values number rem) + (values quo rem))))) + (number-case divisor + (fixnum (if (eq divisor 1) (values number 0) (%fixnum-truncate number divisor))) + (bignum (values 0 number)) + (double-float (truncate-rat-dfloat number divisor)) + (short-float (truncate-rat-sfloat number divisor)) + (ratio (let ((q (truncate (* number (%denominator divisor)) ; this was wrong + (%numerator divisor)))) + (values q (- number (* q divisor)))))))) + (bignum (number-case divisor + (fixnum (if (eq divisor 1) (values number 0) + (if (eq divisor target::target-most-negative-fixnum);; << aargh + (with-small-bignum-buffers ((bd divisor)) + (bignum-truncate number bd)) + (bignum-truncate-by-fixnum number divisor)))) + (bignum (bignum-truncate number divisor)) + (double-float (truncate-rat-dfloat number divisor)) + (short-float (truncate-rat-sfloat number divisor)) + (ratio (let ((q (truncate (* number (%denominator divisor)) ; so was this + (%numerator divisor)))) + (values q (- number (* q divisor))))))) + (short-float (if (eql divisor 1) + (let* ((res (%unary-truncate number))) + (values res (- number res))) + (number-case divisor + (short-float + #+32-bit-target + (target::with-stack-short-floats ((f2)) + (let ((res (%unary-truncate (%short-float/-2! number divisor f2)))) + (values res + (%short-float--2 + number + (%short-float*-2! (%short-float res f2) divisor f2))))) + #+64-bit-target + (let ((res (%unary-truncate + (/ (the short-float number) + (the short-float divisor))))) + (values res + (- (the short-float number) + (* (the short-float (%short-float res)) + (the short-float divisor)))))) + ((fixnum bignum ratio) + #+32-bit-target + (target::with-stack-short-floats ((fdiv divisor) + (f2)) + (let ((res (%unary-truncate (%short-float/-2! number fdiv f2)))) + (values res + (%short-float--2 + number + (%short-float*-2! (%short-float res f2) fdiv f2))))) + #+64-bit-target + (let* ((fdiv (%short-float divisor)) + (res (%unary-truncate + (/ (the short-float number) + (the short-float fdiv))))) + (values res (- number (* res fdiv)))) + + ) + (double-float + (with-stack-double-floats ((fnum number) + (f2)) + (let* ((res (%unary-truncate (%double-float/-2! fnum divisor f2)))) + (values res + (%double-float--2 + fnum + (%double-float*-2! (%double-float res f2) divisor f2))))))))) + (double-float (if (eql divisor 1) + (let ((res (%unary-truncate number))) + (values res (- number res))) + (number-case divisor + ((fixnum bignum ratio short-float) + (with-stack-double-floats ((fdiv divisor) + (f2)) + (let ((res (%unary-truncate (%double-float/-2! number fdiv f2)))) + (values res + (%double-float--2 + number + (%double-float*-2! (%double-float res f2) fdiv f2)))))) + (double-float + (with-stack-double-floats ((f2)) + (let ((res (%unary-truncate (%double-float/-2! number divisor f2)))) + (values res + (%double-float--2 + number + (%double-float*-2! (%double-float res f2) divisor f2))))))))) + (ratio (number-case divisor + (double-float (truncate-rat-dfloat number divisor)) + (short-float (truncate-rat-sfloat number divisor)) + (rational + (let ((q (truncate (%numerator number) + (* (%denominator number) divisor)))) + (values q (- number (* q divisor)))))))))) + +(defun truncate-no-rem (number divisor) + "Returns number (or number/divisor) as an integer, rounded toward 0." + (macrolet + ((truncate-rat-dfloat (number divisor) + `(with-stack-double-floats ((fnum ,number) + (f2)) + (%unary-truncate (%double-float/-2! fnum ,divisor f2)))) + (truncate-rat-sfloat (number divisor) + #+32-bit-target + `(target::with-stack-short-floats ((fnum ,number) + (f2)) + (%unary-truncate (%short-float/-2! fnum ,divisor f2))) + #+64-bit-target + `(let ((fnum (%short-float ,number))) + (%unary-truncate (/ (the short-float fnum) + (the short-float ,divisor)))))) + (number-case number + (fixnum + (if (eql number target::target-most-negative-fixnum) + (if (zerop divisor) + (error 'division-by-zero :operation 'truncate :operands (list number divisor)) + (with-small-bignum-buffers ((bn number)) + (let* ((result (truncate-no-rem bn divisor))) + (if (eq result bn) + number + result)))) + (number-case divisor + (fixnum (if (eq divisor 1) number (values (%fixnum-truncate number divisor)))) + (bignum 0) + (double-float (truncate-rat-dfloat number divisor)) + (short-float (truncate-rat-sfloat number divisor)) + (ratio (let ((q (truncate (* number (%denominator divisor)) + (%numerator divisor)))) + q))))) + (bignum (number-case divisor + (fixnum (if (eq divisor 1) number + (if (eq divisor target::target-most-negative-fixnum) + (with-small-bignum-buffers ((bd divisor)) + (bignum-truncate number bd :no-rem)) + (bignum-truncate-by-fixnum number divisor)))) + (bignum (bignum-truncate number divisor :no-rem)) + (double-float (truncate-rat-dfloat number divisor)) + (short-float (truncate-rat-sfloat number divisor)) + (ratio (let ((q (truncate (* number (%denominator divisor)) + (%numerator divisor)))) + Q)))) + (double-float (if (eql divisor 1) + (let ((res (%unary-truncate number))) + RES) + (number-case divisor + ((fixnum bignum ratio) + (with-stack-double-floats ((fdiv divisor) + (f2)) + (let ((res (%unary-truncate (%double-float/-2! number fdiv f2)))) + RES))) + (short-float + (with-stack-double-floats ((ddiv divisor) + (f2)) + (%unary-truncate (%double-float/-2! number ddiv f2)))) + (double-float + (with-stack-double-floats ((f2)) + (%unary-truncate (%double-float/-2! number divisor f2))))))) + (short-float (if (eql divisor 1) + (let ((res (%unary-truncate number))) + RES) + (number-case divisor + ((fixnum bignum ratio) + #+32-bit-target + (target::with-stack-short-floats ((fdiv divisor) + (f2)) + (let ((res (%unary-truncate (%short-float/-2! number fdiv f2)))) + RES)) + #+64-bit-target + (%unary-truncate (/ (the short-float number) + (the short-float (%short-float divisor))))) + (short-float + #+32-bit-target + (target::with-stack-short-floats ((ddiv divisor) + (f2)) + (%unary-truncate (%short-float/-2! number ddiv f2))) + #+64-bit-target + (%unary-truncate (/ (the short-float number) + (the short-float (%short-float divisor))))) + (double-float + (with-stack-double-floats ((n2 number) + (f2)) + (%unary-truncate (%double-float/-2! n2 divisor f2))))))) + (ratio (number-case divisor + (double-float (truncate-rat-dfloat number divisor)) + (short-float (truncate-rat-sfloat number divisor)) + (rational + (let ((q (truncate (%numerator number) + (* (%denominator number) divisor)))) + Q))))))) + + +;;; %UNARY-ROUND -- Interface +;;; +;;; Similar to %UNARY-TRUNCATE, but rounds to the nearest integer. If we +;;; can't use the round primitive, then we do our own round-to-nearest on the +;;; result of i-d-f. [Note that this rounding will really only happen with +;;; double floats, since the whole single-float fraction will fit in a fixnum, +;;; so all single-floats larger than most-positive-fixnum can be precisely +;;; represented by an integer.] +;;; +;;; returns both values today + +(defun %unary-round (number) + (number-case number + (integer (values number 0)) + (ratio (let ((q (round (%numerator number) (%denominator number)))) + (values q (- number q)))) + (double-float + (if (and (< (the double-float number) + (float (1- (ash 1 (- (1- target::nbits-in-word) target::fixnumshift))) 1.0d0)) + (< (float (ash -1 (- (1- target::nbits-in-word) target::fixnumshift)) 1.0d0) + (the double-float number))) + (let ((round (%unary-round-to-fixnum number))) + (values round (- number round))) + (multiple-value-bind (trunc rem) (truncate number) + (if (not (%double-float-minusp number)) + (if (or (> rem 0.5d0)(and (= rem 0.5d0) (oddp trunc))) + (values (+ trunc 1) (- rem 1.0d0)) + (values trunc rem)) + (if (or (> rem -0.5d0)(and (evenp trunc)(= rem -0.5d0))) + (values trunc rem) + (values (1- trunc) (+ 1.0d0 rem))))))) + (short-float + (if (and (< (the short-float number) + (float (1- (ash 1 (- (1- target::nbits-in-word) target::fixnumshift))) 1.0s0)) + (< (float (ash -1 (- (1- target::nbits-in-word) target::fixnumshift)) 1.0s0) + (the double-float number))) + (let ((round (%unary-round-to-fixnum number))) + (values round (- number round))) + (multiple-value-bind (trunc rem) (truncate number) + (if (not (%short-float-minusp number)) + (if (or (> rem 0.5s0)(and (= rem 0.5s0) (oddp trunc))) + (values (+ trunc 1) (- rem 1.0s0)) + (values trunc rem)) + (if (or (> rem -0.5s0)(and (evenp trunc)(= rem -0.5s0))) + (values trunc rem) + (values (1- trunc) (+ 1.0s0 rem))))))))) + +(defun %unary-round-to-fixnum (number) + (number-case number + (double-float + (%round-nearest-double-float->fixnum number)) + (short-float + (%round-nearest-short-float->fixnum number)))) + + + + +; cmucl:compiler:float-tran.lisp +#| +(defun xform-round (x) + (let ((res (%unary-round x))) + (values res (- x res)))) +|# + +#| +(defun round (number &optional divisor) + "Rounds number (or number/divisor) to nearest integer. + The second returned value is the remainder." + (if (null divisor)(setq divisor 1)) + (if (eql divisor 1) + (xform-round number) + (multiple-value-bind (tru rem) (truncate number divisor) + (let ((thresh (if (integerp divisor) (ash (abs divisor) -1)(/ (abs divisor) 2)))) ; does this need to be a ratio? + (cond ((or (> rem thresh) + (and (= rem thresh) (oddp tru))) + (if (minusp divisor) + (values (- tru 1) (+ rem divisor)) + (values (+ tru 1) (- rem divisor)))) + ((let ((-thresh (- thresh))) + (or (< rem -thresh) + (and (= rem -thresh) (oddp tru)))) + (if (minusp divisor) + (values (+ tru 1) (- rem divisor)) + (values (- tru 1) (+ rem divisor)))) + (t (values tru rem))))))) +|# + + +(defun %fixnum-round (number divisor) + (declare (fixnum number divisor)) + (multiple-value-bind (quo rem)(truncate number divisor) ; should => %fixnum-truncate + (if (= 0 rem) + (values quo rem) + (locally (declare (fixnum quo rem)) + (let* ((minusp-num (minusp number)) + (minusp-div (minusp divisor)) + (2rem (* rem (if (neq minusp-num minusp-div) -2 2)))) + ;(declare (fixnum 2rem)) ; no way jose + ;(truncate (1- most-positive-fixnum) most-positive-fixnum) + ; 2rem has same sign as divisor + (cond (minusp-div + (if (or (< 2rem divisor) + (and (= 2rem divisor)(logbitp 0 quo))) + (if minusp-num + (values (the fixnum (+ quo 1))(the fixnum (- rem divisor))) + (values (the fixnum (- quo 1))(the fixnum (+ rem divisor)))) + (values quo rem))) + (t (if (or (> 2rem divisor) + (and (= 2rem divisor)(logbitp 0 quo))) + (if minusp-num + (values (the fixnum (- quo 1))(the fixnum (+ rem divisor))) + (values (the fixnum (+ quo 1))(the fixnum (- rem divisor)))) + (values quo rem))))))))) +#| +; + + => + + +; + - => - + +; - + => - - +; - - => + - +(defun %fixnum-round (number divisor) + (declare (fixnum number divisor)) + "Rounds number (or number/divisor) to nearest integer. + The second returned value is the remainder." + (if (eq divisor 1) + (values number 0) + (multiple-value-bind (tru rem) (truncate number divisor) + (if (= 0 rem) + (values tru rem) + (locally (declare (fixnum tru rem)) + (let* ((minusp-num (minusp number)) + (minusp-div (minusp divisor)) + (half-div (ash (if minusp-div (- divisor) divisor) -1)) + (abs-rem (if minusp-num (- rem) rem))) + (declare (fixnum half-div abs-rem)) ; true of abs-rem? + (if (or (> abs-rem half-div) + (and + (not (logbitp 0 divisor)) + (logbitp 0 tru) ; oddp + (= abs-rem half-div))) + (if (eq minusp-num minusp-div) + (values (the fixnum (+ tru 1))(the fixnum (- rem divisor))) + (values (the fixnum (- tru 1))(the fixnum (+ rem divisor)))) + (values tru rem)))))))) +|# + + + +;; makes 1 piece of garbage instead of average of 2 +(defun round (number &optional divisor) + "Rounds number (or number/divisor) to nearest integer. + The second returned value is the remainder." + (if (null divisor)(setq divisor 1)) + (if (eql divisor 1) + (%unary-round number) + (multiple-value-bind (tru rem) (truncate number divisor) + (if (= 0 rem) + (values tru rem) + (let* ((mv-p (called-for-mv-p)) + (minusp-num (minusp number)) + (minusp-div (minusp divisor)) + (2rem (* rem (if (neq minusp-num minusp-div) -2 2)))) + ; 2rem has same sign as divisor + (cond (minusp-div + (if (or (< 2rem divisor) + (and (= 2rem divisor)(oddp tru))) + (if mv-p + (if minusp-num + (values (+ tru 1)(- rem divisor)) + (values (- tru 1)(+ rem divisor))) + (if minusp-num (+ tru 1)(- tru 1))) + (values tru rem))) + (t (if (or (> 2rem divisor) + (and (= 2rem divisor)(oddp tru))) + (if mv-p + (if minusp-num + (values (- tru 1)(+ rem divisor)) + (values (+ tru 1)(- rem divisor))) + (if minusp-num (- tru 1)(+ tru 1))) + (values tru rem))))))))) + + +;; #-PPC IN L1-NUMBERS.LISP (or implement %%numdiv) +;; Anyone caught implementing %%numdiv will be summarily executed. +(defun rem (number divisor) + "Returns second result of TRUNCATE." + (number-case number + (fixnum + (number-case divisor + (fixnum (nth-value 1 (%fixnum-truncate number divisor))) + (bignum number) + (t (nth-value 1 (truncate number divisor))))) + (bignum + (number-case divisor + (fixnum + (if (eq divisor target::target-most-negative-fixnum) + (nth-value 1 (truncate number divisor)) + (bignum-truncate-by-fixnum-no-quo number divisor))) + (bignum + (bignum-rem number divisor)) + (t (nth-value 1 (truncate number divisor))))) + (t (nth-value 1 (truncate number divisor))))) + +;; #-PPC IN L1-NUMBERS.LISP (or implement %%numdiv) +;; See above. +(defun mod (number divisor) + "Returns second result of FLOOR." + (let ((rem (rem number divisor))) + (if (and (not (zerop rem)) + (if (minusp divisor) + (plusp number) + (minusp number))) + (+ rem divisor) + rem))) + +(defun cis (theta) + "Return cos(Theta) + i sin(Theta), i.e. exp(i Theta)." + (if (complexp theta) + (error "Argument to CIS is complex: ~S" theta) + (complex (cos theta) (sin theta)))) + + +(defun complex (realpart &optional (imagpart 0)) + "Return a complex number with the specified real and imaginary components." + (number-case realpart + (short-float + (number-case imagpart + (short-float (canonical-complex realpart imagpart)) + (double-float (canonical-complex (%double-float realpart) imagpart)) + (rational (canonical-complex realpart (%short-float imagpart))))) + (double-float + (number-case imagpart + (double-float (canonical-complex + (the double-float realpart) + (the double-float imagpart))) + (short-float (canonical-complex realpart (%double-float imagpart))) + (rational (canonical-complex + (the double-float realpart) + (the double-float (%double-float imagpart)))))) + (rational (number-case imagpart + (double-float (canonical-complex + (the double-float (%double-float realpart)) + (the double-float imagpart))) + (short-float (canonical-complex (%short-float realpart) imagpart)) + (rational (canonical-complex realpart imagpart)))))) + +;; #-PPC IN L1-NUMBERS.LISP +(defun realpart (number) + "Extract the real part of a number." + (number-case number + (complex (%realpart number)) + (number number))) + +;; #-PPC IN L1-NUMBERS.LISP +(defun imagpart (number) + "Extract the imaginary part of a number." + (number-case number + (complex (%imagpart number)) + (float (* 0 number)) + (rational 0))) + +(defun logand-2 (x y) + (number-case x + (fixnum (number-case y + (fixnum + (%ilogand (the fixnum x)(the fixnum y))) + (bignum (fix-big-logand x y)))) + (bignum (number-case y + (fixnum (fix-big-logand y x)) + (bignum (bignum-logical-and x y)))))) + +(defun logior-2 (x y) + (number-case x + (fixnum (number-case y + (fixnum (%ilogior2 x y)) + (bignum + (if (zerop x) + y + (with-small-bignum-buffers ((bx x)) + (bignum-logical-ior bx y)))))) + (bignum (number-case y + (fixnum (if (zerop y) + x + (with-small-bignum-buffers ((by y)) + (bignum-logical-ior x by)))) + (bignum (bignum-logical-ior x y)))))) + +(defun logxor-2 (x y) + (number-case x + (fixnum (number-case y + (fixnum (%ilogxor2 x y)) + (bignum + (with-small-bignum-buffers ((bx x)) + (bignum-logical-xor bx y))))) + (bignum (number-case y + (fixnum (with-small-bignum-buffers ((by y)) + (bignum-logical-xor x by))) + (bignum (bignum-logical-xor x y)))))) + + + +; see cmucl:compiler:srctran.lisp for transforms + +(defun lognand (integer1 integer2) + "Complement the logical AND of INTEGER1 and INTEGER2." + (lognot (logand integer1 integer2))) + +(defun lognor (integer1 integer2) + "Complement the logical AND of INTEGER1 and INTEGER2." + (lognot (logior integer1 integer2))) + +(defun logandc1 (x y) + "Return the logical AND of (LOGNOT integer1) and integer2." + (number-case x + (fixnum (number-case y + (fixnum (%ilogand (%ilognot x) y)) + (bignum (fix-big-logandc1 x y)))) ; (%ilogand-fix-big (%ilognot x) y)))) + (bignum (number-case y + (fixnum (fix-big-logandc2 y x)) ; (%ilogandc2-fix-big y x)) + (bignum (bignum-logandc2 y x)))))) ;(bignum-logical-and (bignum-logical-not x) y)))))) + + +#| ; its in numbers +(defun logandc2 (integer1 integer2) + "Returns the logical AND of integer1 and (LOGNOT integer2)." + (logand integer1 (lognot integer2))) +|# + +(defun logorc1 (integer1 integer2) + "Return the logical OR of (LOGNOT integer1) and integer2." + (logior (lognot integer1) integer2)) + +#| +(defun logorc2 (integer1 integer2) + "Returns the logical OR of integer1 and (LOGNOT integer2)." + (logior integer1 (lognot integer2))) +|# + +(defun logtest (integer1 integer2) + "Predicate which returns T if logand of integer1 and integer2 is not zero." + ; (not (zerop (logand integer1 integer2))) + (number-case integer1 + (fixnum (number-case integer2 + (fixnum (not (= 0 (%ilogand integer1 integer2)))) + (bignum (logtest-fix-big integer1 integer2)))) + (bignum (number-case integer2 + (fixnum (logtest-fix-big integer2 integer1)) + (bignum (bignum-logtest integer1 integer2)))))) + + + +(defun lognot (number) + "Return the bit-wise logical not of integer." + (number-case number + (fixnum (%ilognot number)) + (bignum (bignum-logical-not number)))) + +(defun logcount (integer) + "Count the number of 1 bits if INTEGER is positive, and the number of 0 bits + if INTEGER is negative." + (number-case integer + (fixnum + (%ilogcount (if (minusp (the fixnum integer)) + (%ilognot integer) + integer))) + (bignum + (bignum-logcount integer)))) + + + +(defun ash (integer count) + "Shifts integer left by count places preserving sign. - count shifts right." + (etypecase integer + (fixnum + (etypecase count + (fixnum + (if (eql integer 0) + 0 + (if (eql count 0) + integer + (let ((length (integer-length (the fixnum integer)))) + (declare (fixnum length count)) + (cond ((and (plusp count) + (> (+ length count) + (- (1- target::nbits-in-word) target::fixnumshift))) + (with-small-bignum-buffers ((bi integer)) + (bignum-ashift-left bi count))) + ((and (minusp count) (< count (- (1- target::nbits-in-word)))) + (if (minusp integer) -1 0)) + (t (%iash (the fixnum integer) count))))))) + (bignum + (if (minusp count) + (if (minusp integer) -1 0) + (error "Count ~s too large for ASH" count))))) + (bignum + (etypecase count + (fixnum + (if (eql count 0) + integer + (if (plusp count) + (bignum-ashift-left integer count) + (bignum-ashift-right integer (- count))))) + (bignum + (if (minusp count) + (if (minusp integer) -1 0) + (error "Count ~s too large for ASH" count))))))) + +(defun integer-length (integer) + "Return the number of significant bits in the absolute value of integer." + (number-case integer + (fixnum + (%fixnum-intlen (the fixnum integer))) + (bignum + (bignum-integer-length integer)))) + + +; not CL, used below +(defun byte-mask (size) + (1- (ash 1 (the fixnum size)))) + +(defun byte-position (bytespec) + "Return the position part of the byte specifier bytespec." + (if (> bytespec 0) + (- (integer-length bytespec) (logcount bytespec)) + (- bytespec))) + + +; CMU CL returns T. +(defun upgraded-complex-part-type (type) + "Return the element type of the most specialized COMPLEX number type that + can hold parts of type SPEC." + (declare (ignore type)) + 'real) + + + +(defun init-random-state-seeds () + (let* ((ticks (ldb (byte 32 0) (+ (mixup-hash-code (%current-tcr)) + (let* ((iface(primary-ip-interface))) + (or (and iface (ip-interface-addr iface)) + 0)) + (mixup-hash-code + (logand (get-internal-real-time) + (1- target::target-most-positive-fixnum)))))) + (high (ldb (byte 16 16) (if (zerop ticks) #x10000 ticks))) + (low (ldb (byte 16 0) ticks))) + (declare (fixnum high low)) + (values high low))) + + +#+32-bit-target +(defun random (number &optional (state *random-state*)) + (if (not (typep state 'random-state)) (report-bad-arg state 'random-state)) + (cond + ((and (fixnump number) (> (the fixnum number) 0)) + (locally (declare (fixnum number)) + (if (< number 65536) + (fast-mod (%next-random-seed state) number) + (let* ((n 0) + (nhalf (ash (+ 15 (integer-length number)) -4))) + (declare (fixnum n nhalf)) + (dotimes (i nhalf (fast-mod n number)) + (setq n (logior (the fixnum (ash n 16)) + (the fixnum (%next-random-seed state))))))))) + ((and (typep number 'double-float) (> (the double-float number) 0.0)) + (%float-random number state)) + ((and (typep number 'short-float) (> (the short-float number) 0.0s0)) + (%float-random number state)) + ((and (bignump number) (> number 0)) + (%bignum-random number state)) + (t (report-bad-arg number '(or (integer (0)) (float (0.0))))))) + +#+64-bit-target +(defun random (number &optional (state *random-state*)) + (if (not (typep state 'random-state)) (report-bad-arg state 'random-state)) + (cond + ((and (fixnump number) (> (the fixnum number) 0)) + (locally (declare (fixnum number)) + (let* ((n 0) + (n32 (ash (+ 31 (integer-length number)) -5))) + (declare (fixnum n n32)) + (dotimes (i n32 (fast-mod n number)) + (setq n (logior (the fixnum (ash n 32)) + (the fixnum (%next-random-seed state)))))))) + ((and (typep number 'double-float) (> (the double-float number) 0.0)) + (%float-random number state)) + ((and (typep number 'short-float) (> (the short-float number) 0.0s0)) + (%float-random number state)) + ((and (bignump number) (> number 0)) + (%bignum-random number state)) + (t (report-bad-arg number '(or (integer (0)) (float (0.0))))))) + + +#| +Date: Mon, 3 Feb 1997 10:04:08 -0500 +To: info-mcl@digitool.com, wineberg@franz.scs.carleton.ca +From: dds@flavors.com (Duncan Smith) +Subject: Re: More info on the random number generator +Sender: owner-info-mcl@digitool.com +Precedence: bulk + +The generator is a Linear Congruential Generator: + + X[n+1] = (aX[n] + c) mod m + +where: a = 16807 (Park&Miller recommend 48271) + c = 0 + m = 2^31 - 1 + +See: Knuth, Seminumerical Algorithms (Volume 2), Chapter 3. + +The period is: 2^31 - 2 (zero is excluded). + +What makes this generator so simple is that multiplication and addition mod +2^n-1 is easy. See Knuth Ch. 4.3.2 (2nd Ed. p 272). + + ab mod m = ... + +If m = 2^n-1 + u = ab mod 2^n + v = floor( ab / 2^n ) + + ab mod m = u + v : u+v < 2^n + ab mod m = ((u + v) mod 2^n) + 1 : u+v >= 2^n + +What we do is use 2b and 2^n so we can do arithemetic mod 2^32 instead of +2^31. This reduces the whole generator to 5 instructions on the 680x0 or +80x86, and 8 on the 60x. + +-Duncan + +|# + +#+64-bit-target +(defun %next-random-seed (state) + (let* ((n (the fixnum (* (the fixnum (random.seed-1 state)) 48271)))) + (declare (fixnum n)) + (setf (random.seed-1 state) (fast-mod n (1- (expt 2 31)))) + (logand n (1- (ash 1 32))))) + +#+32-bit-target +(defun %next-random-seed (state) + (multiple-value-bind (high low) (%next-random-pair (random.seed-1 state) + (random.seed-2 state)) + (declare (type (unsigned-byte 15) high) + (type (unsigned-byte 16) low)) + (setf (random.seed-1 state) high + (random.seed-2 state) low) + (logior high (the fixnum (logand low (ash 1 15)))))) + +#+32-bit-target +(defun %bignum-random (number state) + (let* ((bits (+ (integer-length number) 8)) + (half-words (ash (the fixnum (+ bits 15)) -4)) + (long-words (ash (+ half-words 1) -1)) + (dividend (%alloc-misc long-words target::subtag-bignum)) + (16-bit-dividend dividend) + (index 1)) + (declare (fixnum long-words index bits) + (dynamic-extent dividend) + (type (simple-array (unsigned-byte 16) (*)) 16-bit-dividend) ;lie + (optimize (speed 3) (safety 0))) + (loop + ;; This had better inline due to the lie above, or it will error + #+big-endian-target + (setf (aref 16-bit-dividend index) (%next-random-seed state)) + #+little-endian-target + (setf (aref 16-bit-dividend (the fixnum (1- index))) + (%next-random-seed state)) + (decf half-words) + (when (<= half-words 0) (return)) + #+big-endian-target + (setf (aref 16-bit-dividend (the fixnum (1- index))) + (%next-random-seed state)) + #+little-endian-target + (setf (aref 16-bit-dividend index) (%next-random-seed state)) + (decf half-words) + (when (<= half-words 0) (return)) + (incf index 2)) + ;; The bignum code expects normalized bignums + (let* ((result (mod dividend number))) + (if (eq dividend result) + (copy-uvector result) + result)))) + +(defun %float-random (number state) + (let ((ratio (gvector :ratio (random target::target-most-positive-fixnum state) target::target-most-positive-fixnum))) + (declare (dynamic-extent ratio)) + (* number ratio))) + +(eval-when (:compile-toplevel :execute) + (defmacro bignum-abs (nexp) + (let ((n (gensym))) + `(let ((,n ,nexp)) + (if (bignum-minusp ,n) (negate-bignum ,n) ,n)))) + + (defmacro fixnum-abs (nexp) + (let ((n (gensym))) + `(let ((,n ,nexp)) + (if (minusp (the fixnum ,n)) + (if (eq ,n target::target-most-negative-fixnum) + (- ,n) + (the fixnum (- (the fixnum ,n)))) + ,n)))) + ) + + +;;; TWO-ARG-GCD -- Internal +;;; +;;; Do the GCD of two integer arguments. With fixnum arguments, we use the +;;; binary GCD algorithm from Knuth's seminumerical algorithms (slightly +;;; structurified), otherwise we call BIGNUM-GCD. We pick off the special case +;;; of 0 before the dispatch so that the bignum code doesn't have to worry +;;; about "small bignum" zeros. +;;; +(defun gcd-2 (n1 n2) + ;(declare (optimize (speed 3)(safety 0))) + (cond + ((eql n1 0) (%integer-abs n2)) + ((eql n2 0) (%integer-abs n1)) + (t (number-case n1 + (fixnum + (number-case n2 + (fixnum + (if (eql n1 target::target-most-negative-fixnum) + (if (eql n2 target::target-most-negative-fixnum) + (- target::target-most-negative-fixnum) + (bignum-fixnum-gcd (- target::target-most-negative-fixnum) (abs n2))) + (if (eql n2 target::target-most-negative-fixnum) + (bignum-fixnum-gcd (- target::target-most-negative-fixnum) (abs n1)) + (locally + (declare (optimize (speed 3) (safety 0)) + (fixnum n1 n2)) + (if (minusp n1)(setq n1 (the fixnum (- n1)))) + (if (minusp n2)(setq n2 (the fixnum (- n2)))) + (%fixnum-gcd n1 n2))))) + (bignum (if (eql n1 target::target-most-negative-fixnum) + (%bignum-bignum-gcd n2 (- target::target-most-negative-fixnum)) + (bignum-fixnum-gcd (bignum-abs n2)(fixnum-abs n1)))))) + (bignum + (number-case n2 + (fixnum + (if (eql n2 target::target-most-negative-fixnum) + (%bignum-bignum-gcd (bignum-abs n1)(fixnum-abs n2)) + (bignum-fixnum-gcd (bignum-abs n1)(fixnum-abs n2)))) + (bignum (%bignum-bignum-gcd n1 n2)))))))) + +#| +(defun fixnum-gcd (n1 n2) + (declare (optimize (speed 3) (safety 0)) + (fixnum n1 n2)) + (do* ((k 0 (%i+ 1 k)) + (n1 n1 (%iasr 1 n1)) + (n2 n2 (%iasr 1 n2))) + ((oddp (logior n1 n2)) + (do ((temp (if (oddp n1) (the fixnum (- n2)) (%iasr 1 n1)) + (%iasr 1 temp))) + (nil) + (declare (fixnum temp)) + (when (oddp temp) + (if (plusp temp) + (setq n1 temp) + (setq n2 (- temp))) + (setq temp (the fixnum (- n1 n2))) + (when (zerop temp) + (let ((res (%ilsl k n1))) + (return res)))))) + (declare (fixnum n1 n2 k)))) +|# + + + +(defun %quo-1 (n) + (/ 1 n)) + +; x & y must both be double floats +(defun %hypot (x y) + (with-stack-double-floats ((x**2) (y**2)) + (let ((res**2 x**2)) + (%double-float*-2! x x x**2) + (%double-float*-2! y y y**2) + (%double-float+-2! x**2 y**2 res**2) + (fsqrt res**2)))) + + Index: /branches/new-random/level-0/l0-pred.lisp =================================================================== --- /branches/new-random/level-0/l0-pred.lisp (revision 13309) +++ /branches/new-random/level-0/l0-pred.lisp (revision 13309) @@ -0,0 +1,1115 @@ +;;;-*- Mode: Lisp; Package: CCL -*- +;;; +;;; Copyright (C) 2009 Clozure Associates +;;; Copyright (C) 1994-2001 Digitool, Inc +;;; This file is part of Clozure CL. +;;; +;;; Clozure CL is licensed under the terms of the Lisp Lesser GNU Public +;;; License , known as the LLGPL and distributed with Clozure CL as the +;;; file "LICENSE". The LLGPL consists of a preamble and the LGPL, +;;; which is distributed with Clozure CL as the file "LGPL". Where these +;;; conflict, the preamble takes precedence. +;;; +;;; Clozure CL is referenced in the preamble as the "LIBRARY." +;;; +;;; The LLGPL is also available online at +;;; http://opensource.franz.com/preamble.html + +(in-package "CCL") + +;; Non-portable type-predicates & such. + + +;; bootstrapping defs - real ones in l1-typesys, l1-clos, sysutils + +(defun find-builtin-cell (type &optional create) + (declare (ignore create)) + (cons type nil)) + + +(defun builtin-typep (form cell) + (typep form (class-cell-name cell))) + +(defun class-cell-typep (arg class-cell) + (typep arg (class-cell-name class-cell))) + +(defun class-cell-find-class (class-cell errorp) + (declare (ignore errorp)) ; AARGH can't be right + ;(dbg-paws #x100) + (let ((class (and class-cell (class-cell-class class-cell)))) + (or class + (if (fboundp 'find-class) + (find-class (class-cell-name class-cell) nil))))) + +(defun %require-type-builtin (form foo) + (declare (ignore foo)) + form) + +(defun %require-type-class-cell (form cell) + (declare (ignore cell)) + form) + +(defun non-nil-symbol-p (x) + (if (symbolp x) x)) + +(defun pathnamep (thing) + (or (istruct-typep thing 'pathname) (istruct-typep thing 'logical-pathname))) + +(defun compiled-function-p (form) + "Return true if OBJECT is a COMPILED-FUNCTION, and NIL otherwise." + (and (functionp form) + (not (logbitp $lfbits-trampoline-bit (the fixnum (lfun-bits form)))))) + +;;; all characters are base-chars. +(defun extended-char-p (c) + (declare (ignore c))) + + +;;; Some of these things are probably open-coded. +;;; The functions have to exist SOMEWHERE ... +(defun fixnump (x) + (= (the fixnum (lisptag x)) target::tag-fixnum)) + +(defun bignump (x) + (= (the fixnum (typecode x)) target::subtag-bignum)) + +(defun integerp (x) + "Return true if OBJECT is an INTEGER, and NIL otherwise." + (let* ((typecode (typecode x))) + (declare (fixnum typecode)) + (or (= typecode target::tag-fixnum) + (= typecode target::subtag-bignum)))) + +(defun ratiop (x) + (= (the fixnum (typecode x)) target::subtag-ratio)) + + +(defun rationalp (x) + "Return true if OBJECT is a RATIONAL, and NIL otherwise." + (or (fixnump x) + (let* ((typecode (typecode x))) + (declare (fixnum typecode)) + #+(or ppc32-target x8632-target) + (and (>= typecode target::min-numeric-subtag) + (<= typecode target::max-rational-subtag)) + #+(or ppc64-target x8664-target) + (cond ((= typecode target::subtag-bignum) t) + ((= typecode target::subtag-ratio) t))))) + +(defun short-float-p (x) + (= (the fixnum (typecode x)) target::subtag-single-float)) + + +(defun double-float-p (x) + (= (the fixnum (typecode x)) target::subtag-double-float)) + +(defun floatp (x) + "Return true if OBJECT is a FLOAT, and NIL otherwise." + (let* ((typecode (typecode x))) + (declare (fixnum typecode)) + (or (= typecode target::subtag-single-float) + (= typecode target::subtag-double-float)))) + +(defun realp (x) + "Return true if OBJECT is a REAL, and NIL otherwise." + (let* ((typecode (typecode x))) + (declare (fixnum typecode)) + #+(or ppc32-target x8632-target) + (or (= typecode target::tag-fixnum) + (and (>= typecode target::min-numeric-subtag) + (<= typecode target::max-real-subtag))) + #+ppc64-target + (if (<= typecode ppc64::subtag-double-float) + (logbitp (the (integer 0 #.ppc64::subtag-double-float) typecode) + (logior (ash 1 ppc64::tag-fixnum) + (ash 1 ppc64::subtag-single-float) + (ash 1 ppc64::subtag-double-float) + (ash 1 ppc64::subtag-bignum) + (ash 1 ppc64::subtag-ratio)))) + #+x8664-target + (if (<= typecode x8664::subtag-double-float) + (logbitp (the (integer 0 #.x8664::subtag-double-float) typecode) + (logior (ash 1 x8664::tag-fixnum) + (ash 1 x8664::subtag-bignum) + (ash 1 x8664::tag-single-float) + (ash 1 x8664::subtag-double-float) + (ash 1 x8664::subtag-ratio)))))) + +(defun complexp (x) + "Return true if OBJECT is a COMPLEX, and NIL otherwise." + (= (the fixnum (typecode x)) target::subtag-complex)) + +(defun numberp (x) + "Return true if OBJECT is a NUMBER, and NIL otherwise." + (let* ((typecode (typecode x))) + (declare (fixnum typecode)) + #+(or ppc32-target x8632-target) + (or (= typecode target::tag-fixnum) + (and (>= typecode target::min-numeric-subtag) + (<= typecode target::max-numeric-subtag))) + #+ppc64-target + (if (<= typecode ppc64::subtag-double-float) + (logbitp (the (integer 0 #.ppc64::subtag-double-float) typecode) + (logior (ash 1 ppc64::tag-fixnum) + (ash 1 ppc64::subtag-bignum) + (ash 1 ppc64::subtag-single-float) + (ash 1 ppc64::subtag-double-float) + (ash 1 ppc64::subtag-ratio) + (ash 1 ppc64::subtag-complex)))) + #+x8664-target + (if (< typecode x8664::nbits-in-word) + (logbitp (the (integer 0 #.x8664::subtag-double-float) typecode) + (logior (ash 1 x8664::tag-fixnum) + (ash 1 x8664::subtag-bignum) + (ash 1 x8664::tag-single-float) + (ash 1 x8664::subtag-double-float) + (ash 1 x8664::subtag-ratio) + (ash 1 x8664::subtag-complex)))) + + )) + +(defun arrayp (x) + "Return true if OBJECT is an ARRAY, and NIL otherwise." + (>= (the fixnum (typecode x)) target::min-array-subtag)) + +(defun vectorp (x) + "Return true if OBJECT is a VECTOR, and NIL otherwise." + (>= (the fixnum (typecode x)) target::min-vector-subtag)) + + +(defun stringp (x) + "Return true if OBJECT is a STRING, and NIL otherwise." + (let* ((typecode (typecode x))) + (declare (fixnum typecode)) + (if (= typecode target::subtag-vectorH) + (setq typecode (ldb target::arrayH.flags-cell-subtag-byte (the fixnum (%svref x target::arrayH.flags-cell))))) + (= typecode target::subtag-simple-base-string))) + + +(defun simple-base-string-p (x) + (= (the fixnum (typecode x)) target::subtag-simple-base-string)) + +(defun simple-string-p (x) + "Return true if OBJECT is a SIMPLE-STRING, and NIL otherwise." + (= (the fixnum (typecode x)) target::subtag-simple-base-string)) + +(defun complex-array-p (x) + (let* ((typecode (typecode x))) + (declare (fixnum typecode)) + (if (or (= typecode target::subtag-arrayH) + (= typecode target::subtag-vectorH)) + (not (%array-header-simple-p x))))) + +(defun simple-array-p (thing) + "Returns T if the object is a simple array, else returns NIL. + That's why it's called SIMPLE-ARRAY-P. Get it ? + A simple-array may have no fill-pointer, may not be displaced, + and may not be adjustable." + (let* ((typecode (typecode thing))) + (declare (fixnum typecode)) + (if (or (= typecode target::subtag-arrayH) + (= typecode target::subtag-vectorH)) + (%array-header-simple-p thing) + (> typecode target::subtag-vectorH)))) + +(defun macptrp (x) + (= (the fixnum (typecode x)) target::subtag-macptr)) + +(defun dead-macptr-p (x) + (= (the fixnum (typecode x)) target::subtag-dead-macptr)) + + +;;; Note that this is true of symbols and functions and many other +;;; things that it wasn't true of on the 68K. +(defun gvectorp (x) + #+(or ppc32-target x8632-target) + (= (the fixnum (logand (the fixnum (typecode x)) target::fulltagmask)) target::fulltag-nodeheader) + #+ppc64-target + (= (the fixnum (logand (the fixnum (typecode x)) ppc64::lowtagmask)) ppc64::lowtag-nodeheader) + #+x8664-target + (let* ((fulltag (logand (the fixnum (typecode x)) x8664::fulltagmask))) + (declare (fixnum fulltag)) + (or (= fulltag x8664::fulltag-nodeheader-0) + (= fulltag x8664::fulltag-nodeheader-1))) + ) + + +(setf (type-predicate 'gvector) 'gvectorp) + +(defun ivectorp (x) + #+(or ppc32-target x8632-target) + (= (the fixnum (logand (the fixnum (typecode x)) target::fulltagmask)) + target::fulltag-immheader) + #+ppc64-target + (= (the fixnum (logand (the fixnum (typecode x)) ppc64::lowtagmask)) ppc64::lowtag-immheader) + #+x8664-target + (let* ((fulltag (logand (the fixnum (typecode x)) x8664::fulltagmask))) + (declare (fixnum fulltag)) + (or (= fulltag x8664::fulltag-immheader-0) + (= fulltag x8664::fulltag-immheader-1) + (= fulltag x8664::fulltag-immheader-2))) + ) + +(setf (type-predicate 'ivector) 'ivectorp) + +(defun miscobjp (x) + #+(or ppc32-target x8632-target x8664-target) + (= (the fixnum (lisptag x)) target::tag-misc) + #+ppc64-target + (= (the fixnum (fulltag x)) ppc64::fulltag-misc) + ) + +(defun simple-vector-p (x) + "Return true if OBJECT is a SIMPLE-VECTOR, and NIL otherwise." + (= (the fixnum (typecode x)) target::subtag-simple-vector)) + +(defun base-string-p (thing) + (let* ((typecode (typecode thing))) + (declare (fixnum typecode)) + (or (= typecode target::subtag-simple-base-string) + (and (= typecode target::subtag-vectorh) + (= (the fixnum + (ldb target::arrayH.flags-cell-subtag-byte (the fixnum (%svref thing target::arrayH.flags-cell)))) + target::subtag-simple-base-string))))) + +(defun simple-bit-vector-p (form) + "Return true if OBJECT is a SIMPLE-BIT-VECTOR, and NIL otherwise." + (= (the fixnum (typecode form)) target::subtag-bit-vector)) + +(defun bit-vector-p (thing) + "Return true if OBJECT is a BIT-VECTOR, and NIL otherwise." + (let* ((typecode (typecode thing))) + (declare (fixnum typecode)) + (or (= typecode target::subtag-bit-vector) + (and (= typecode target::subtag-vectorh) + (= (the fixnum + (ldb target::arrayH.flags-cell-subtag-byte (the fixnum (%svref thing target::arrayH.flags-cell)))) + target::subtag-bit-vector))))) + +(defun displaced-array-p (array) + (if (%array-is-header array) + (do* ((disp (%svref array target::arrayH.displacement-cell) + (+ disp (the fixnum (%svref target target::arrayH.displacement-cell)))) + (target (%svref array target::arrayH.data-vector-cell) + (%svref target target::arrayH.data-vector-cell))) + ((not (%array-is-header target)) + (values target disp))) + (values nil 0))) + + + +(defun eq (x y) + "Return T if OBJ1 and OBJ2 are the same object, otherwise NIL." + (eq x y)) + + +(defun cons-equal (x y) + (declare (cons x y)) + (if (equal (car x) (car y)) + (equal (cdr x) (cdr y)))) + +(defun hairy-equal (x y) + (declare (optimize (speed 3))) + ;; X and Y are not EQL, and are both of tag target::fulltag-misc. + (let* ((x-type (typecode x)) + (y-type (typecode y))) + (declare (fixnum x-type y-type)) + (if (and (>= x-type target::subtag-vectorH) + (>= y-type target::subtag-vectorH)) + (let* ((x-simple (if (= x-type target::subtag-vectorH) + (ldb target::arrayH.flags-cell-subtag-byte + (the fixnum (%svref x target::arrayH.flags-cell))) + x-type)) + (y-simple (if (= y-type target::subtag-vectorH) + (ldb target::arrayH.flags-cell-subtag-byte + (the fixnum (%svref y target::arrayH.flags-cell))) + y-type))) + (declare (fixnum x-simple y-simple)) + (if (= x-simple target::subtag-simple-base-string) + (if (= y-simple target::subtag-simple-base-string) + (locally + (declare (optimize (speed 3) (safety 0))) + (let* ((x-len (if (= x-type target::subtag-vectorH) + (%svref x target::vectorH.logsize-cell) + (uvsize x))) + (x-pos 0) + (y-len (if (= y-type target::subtag-vectorH) + (%svref y target::vectorH.logsize-cell) + (uvsize y))) + (y-pos 0)) + (declare (fixnum x-len x-pos y-len y-pos)) + (when (= x-type target::subtag-vectorH) + (multiple-value-setq (x x-pos) (array-data-and-offset x))) + (when (= y-type target::subtag-vectorH) + (multiple-value-setq (y y-pos) (array-data-and-offset y))) + (%simple-string= x y x-pos y-pos (the fixnum (+ x-pos x-len)) (the fixnum (+ y-pos y-len)))))) + ;;Bit-vector case or fail. + (and (= x-simple target::subtag-bit-vector) + (= y-simple target::subtag-bit-vector) + (locally + (declare (optimize (speed 3) (safety 0))) + (let* ((x-len (if (= x-type target::subtag-vectorH) + (%svref x target::vectorH.logsize-cell) + (uvsize x))) + (x-pos 0) + (y-len (if (= y-type target::subtag-vectorH) + (%svref y target::vectorH.logsize-cell) + (uvsize y))) + (y-pos 0)) + (declare (fixnum x-len x-pos y-len y-pos)) + (when (= x-len y-len) + (when (= x-type target::subtag-vectorH) + (multiple-value-setq (x x-pos) (array-data-and-offset x))) + (when (= y-type target::subtag-vectorH) + (multiple-value-setq (y y-pos) (array-data-and-offset y))) + (do* ((i 0 (1+ i))) + ((= i x-len) t) + (declare (fixnum i)) + (unless (= (the bit (sbit x x-pos)) (the bit (sbit y y-pos))) + (return)) + (incf x-pos) + (incf y-pos)))))))) + (if (= x-type y-type) + (if (= x-type target::subtag-istruct) + (and (let* ((structname (istruct-cell-name (%svref x 0)))) + (and (eq structname (istruct-cell-name (%svref y 0))) + (or (eq structname 'pathname) + (eq structname 'logical-pathname))) + (locally + (declare (optimize (speed 3) (safety 0))) + (let* ((x-size (uvsize x)) + (skip (if (eq structname 'pathname) + %physical-pathname-version + -1))) + (declare (fixnum x-size skip)) + (when (= x-size (the fixnum (uvsize y))) + (if *case-sensitive-filesystem* + (do* ((i 1 (1+ i))) + ((= i x-size) t) + (declare (fixnum i)) + (unless (or (= i skip) + (equal (%svref x i) (%svref y i))) + (return))) + (do* ((i 1 (1+ i))) + ((= i x-size) t) + (declare (fixnum i)) + (unless (or (= i skip) + (equalp (%svref x i) (%svref y i))) + (return)))))))))))))) + +#+ppc32-target +(progn +(defparameter *nodeheader-types* + #(bogus ; 0 + ratio ; 1 + bogus ; 2 + complex ; 3 + catch-frame ; 4 + function ; 5 + basic-stream ; 6 + symbol ; 7 + lock ; 8 + hash-table-vector ; 9 + pool ; 10 + population ; 11 + package ; 12 + slot-vector ; 13 + standard-instance ; 14 + structure ; 15 + internal-structure ; 16 + value-cell ; 17 + xfunction ; 18 + array-header ; 19 + vector-header ; 20 + simple-vector ; 21 + bogus ; 22 + bogus ; 23 + bogus ; 24 + bogus ; 25 + bogus ; 26 + bogus ; 27 + bogus ; 28 + bogus ; 29 + bogus ; 30 + bogus ; 31 + )) + + +(defparameter *immheader-types* + #(bignum ; 0 + short-float ; 1 + double-float ; 2 + macptr ; 3 + dead-macptr ; 4 + code-vector ; 5 + creole-object ; 6 + ;; 8-19 are unused + xcode-vector ; 7 + bogus ; 8 + bogus ; 9 + bogus ; 10 + bogus ; 11 + bogus ; 12 + bogus ; 13 + bogus ; 14 + bogus ; 15 + bogus ; 16 + bogus ; 17 + bogus ; 18 + bogus ; 19 + simple-short-float-vector ; 20 + simple-unsigned-long-vector ; 21 + simple-signed-long-vector ; 22 + simple-fixnum-vector ; 23 + simple-base-string ; 24 + simple-unsigned-byte-vector ; 25 + simple-signed-byte-vector ; 26 + bogus ; 27 + simple-unsigned-word-vector ; 28 + simple-signed-word-vector ; 29 + simple-double-float-vector ; 30 + simple-bit-vector ; 31 + )) + +(defun %type-of (thing) + (let* ((typecode (typecode thing))) + (declare (fixnum typecode)) + (if (= typecode ppc32::tag-fixnum) + 'fixnum + (if (= typecode ppc32::tag-list) + (if thing 'cons 'null) + (if (= typecode ppc32::tag-imm) + (if (base-char-p thing) + 'base-char + 'immediate) + (if (= typecode ppc32::subtag-macptr) + (if (classp thing) + (class-name thing) + 'macptr) + (let* ((tag-type (logand typecode ppc32::full-tag-mask)) + (tag-val (ash typecode (- ppc32::ntagbits)))) + (declare (fixnum tag-type tag-val)) + (if (/= tag-type ppc32::fulltag-nodeheader) + (%svref *immheader-types* tag-val) + (let ((type (%svref *nodeheader-types* tag-val))) + (if (eq type 'function) + (let ((bits (lfun-bits thing))) + (declare (fixnum bits)) + (if (logbitp $lfbits-trampoline-bit bits) + (let ((inner-fn (closure-function thing))) + (if (neq inner-fn thing) + (let ((inner-bits (lfun-bits inner-fn))) + (if (logbitp $lfbits-method-bit inner-bits) + 'compiled-lexical-closure + (if (logbitp $lfbits-gfn-bit inner-bits) + 'standard-generic-function ; not precisely - see class-of + (if (logbitp $lfbits-cm-bit inner-bits) + 'combined-method + 'compiled-lexical-closure)))) + 'compiled-lexical-closure)) + (if (logbitp $lfbits-method-bit bits) + 'method-function + 'compiled-function))) + (if (eq type 'lock) + (or (uvref thing ppc32::lock.kind-cell) + type) + type))))))))))) + +);#+ppc32-target + +#+ppc64-target +(progn +(defparameter *immheader-types* + #(bogus + bogus + code-vector + bogus + bogus + bogus + xcode-vector + macptr + bogus + bogus + bignum + dead-macptr + bogus + bogus + double-float + bogus + bogus + bogus + bogus + bogus + bogus + bogus + bogus + bogus + bogus + bogus + bogus + bogus + bogus + bogus + bogus + bogus + bogus + bogus + bogus + bogus + simple-signed-byte-vector + simple-signed-word-vector + simple-signed-long-vector + simple-signed-doubleword-vector + simple-unsigned-byte-vector + simple-unsigned-word-vector + simple-unsigned-long-vector + simple-unsigned-doubleword-vector + bogus + bogus + simple-short-float-vector + simple-fixnum-vector + bogus + bogus + bogus + simple-double-float-vector + bogus + bogus + simple-base-string + bogus + bogus + bogus + bogus + bogus + bogus + simple-bit-vector + bogus + bogus)) + +(defparameter *nodeheader-types* + #(function + catch-frame + slot-vector + ratio + symbol + basic-stream + standard-instance + complex + bogus + lock + structure + bogus + bogus + hash-vector + internal-structure + bogus + bogus + pool + value-cell + bogus + bogus + population + xfunction + bogus + bogus + package + bogus + bogus + bogus + bogus + bogus + bogus + bogus + array-header + vector-header + simple-vector + bogus + bogus + bogus + bogus + bogus + bogus + bogus + bogus + bogus + bogus + bogus + bogus + bogus + bogus + bogus + bogus + bogus + bogus + bogus + bogus + bogus + bogus + bogus + bogus + bogus + bogus + bogus + bogus + ) + ) + + +(defun %type-of (thing) + (if (null thing) + 'null + (let* ((typecode (typecode thing))) + (declare (fixnum typecode)) + (cond ((= typecode ppc64::tag-fixnum) 'fixnum) + ((= typecode ppc64::fulltag-cons) 'cons) + ((= typecode ppc64::subtag-character) 'character) + ((= typecode ppc64::subtag-single-float) 'short-float) + (t (let* ((lowtag (logand typecode ppc64::lowtagmask))) + (declare (fixnum lowtag)) + (cond ((= lowtag ppc64::lowtag-immheader) + (%svref *immheader-types* (ash typecode -2))) + ((= lowtag ppc64::lowtag-nodeheader) + (let* ((type (%svref *nodeheader-types* + (ash typecode -2)))) + (cond ((eq type 'function) + (let ((bits (lfun-bits thing))) + (declare (fixnum bits)) + (if (logbitp $lfbits-trampoline-bit bits) + (let ((inner-fn (closure-function thing))) + (if (neq inner-fn thing) + (let ((inner-bits (lfun-bits inner-fn))) + (if (logbitp $lfbits-method-bit inner-bits) + 'compiled-lexical-closure + (if (logbitp $lfbits-gfn-bit inner-bits) + 'standard-generic-function ; not precisely - see class-of + (if (logbitp $lfbits-cm-bit inner-bits) + 'combined-method + 'compiled-lexical-closure)))) + 'compiled-lexical-closure)) + (if (logbitp $lfbits-method-bit bits) + 'method-function + 'compiled-function)))) + ((eq type 'lock) + (or (uvref thing ppc64::lock.kind-cell) + type)) + (t type)))) + (t 'immediate)))))))) +);#+ppc64-target + + +#+x8632-target +(progn +(defparameter *nodeheader-types* + #(bogus ; 0 + ratio ; 1 + bogus ; 2 + complex ; 3 + catch-frame ; 4 + function ; 5 + basic-stream ; 6 + symbol ; 7 + lock ; 8 + hash-table-vector ; 9 + pool ; 10 + population ; 11 (weak?) + package ; 12 + slot-vector ; 13 + standard-instance ; 14 + structure ; 15 + internal-structure ; 16 + value-cell ; 17 + xfunction ; 18 + array-header ; 19 + vector-header ; 20 + simple-vector ; 21 + bogus ; 22 + bogus ; 23 + bogus ; 24 + bogus ; 25 + bogus ; 26 + bogus ; 27 + bogus ; 28 + bogus ; 29 + bogus ; 30 + bogus ; 31 + )) + + +(defparameter *immheader-types* + #(bignum ; 0 + short-float ; 1 + double-float ; 2 + macptr ; 3 + dead-macptr ; 4 + code-vector ; 5 + creole-object ; 6 + xcode-vector ; 7 + bogus ; 8 + bogus ; 9 + bogus ; 10 + bogus ; 11 + bogus ; 12 + bogus ; 13 + bogus ; 14 + bogus ; 15 + bogus ; 16 + bogus ; 17 + bogus ; 18 + bogus ; 19 + simple-short-float-vector ; 20 + simple-unsigned-long-vector ; 21 + simple-signed-long-vector ; 22 + simple-fixnum-vector ; 23 + simple-base-string ; 24 + simple-unsigned-byte-vector ; 25 + simple-signed-byte-vector ; 26 + bogus ; 27 + simple-unsigned-word-vector ; 28 + simple-signed-word-vector ; 29 + simple-double-float-vector ; 30 + simple-bit-vector ; 31 + )) + +(defun %type-of (thing) + (let* ((typecode (typecode thing))) + (declare (fixnum typecode)) + (if (= typecode x8632::tag-fixnum) + 'fixnum + (if (= typecode x8632::tag-list) ;a misnomer on x8632... + (if (= (fulltag thing) x8632::fulltag-cons) + (if thing 'cons 'null) + 'tagged-return-address) + (if (= typecode x8632::tag-imm) + (if (base-char-p thing) + 'base-char + 'immediate) + (if (= typecode x8632::subtag-macptr) + (if (classp thing) + (class-name thing) + 'macptr) + (let* ((tag-type (logand typecode x8632::fulltagmask)) + (tag-val (ash typecode (- x8632::ntagbits)))) + (declare (fixnum tag-type tag-val)) + (if (/= tag-type x8632::fulltag-nodeheader) + (%svref *immheader-types* tag-val) + (let ((type (%svref *nodeheader-types* tag-val))) + (if (eq type 'function) + (let ((bits (lfun-bits thing))) + (declare (fixnum bits)) + (if (logbitp $lfbits-trampoline-bit bits) + (let ((inner-fn (closure-function thing))) + (if (neq inner-fn thing) + (let ((inner-bits (lfun-bits inner-fn))) + (if (logbitp $lfbits-method-bit inner-bits) + 'compiled-lexical-closure + (if (logbitp $lfbits-gfn-bit inner-bits) + 'standard-generic-function ; not precisely - see class-of + (if (logbitp $lfbits-cm-bit inner-bits) + 'combined-method + 'compiled-lexical-closure)))) + 'compiled-lexical-closure)) + (if (logbitp $lfbits-method-bit bits) + 'method-function + 'compiled-function))) + (if (eq type 'lock) + (or (uvref thing x8632::lock.kind-cell) + type) + type))))))))))) + +) ;x8632-target + +#+x8664-target +(progn +(defparameter *nodeheader-0-types* + #(bogus + symbol-vector + catch-frame + hash-vector + pool + population + package + slot-vector + basic-stream + function-vector ;8 + array-header + bogus + bogus + bogus + bogus + bogus + )) + +(defparameter *nodeheader-1-types* + #(bogus + ratio + complex + structure + internal-structure + value-cell + xfunction + lock + instance + bogus + vector-header + simple-vector + bogus + bogus + bogus + bogus + )) + +(defparameter *immheader-0-types* + #(bogus + bogus + bogus + bogus + bogus + bogus + bogus + bogus + bogus + bogus + simple-signed-word-vector + simple-unsigned-word-vector + bogus + simple-signed-byte-vector + simple-unsigned-byte-vector + bit-vector)) + +(defparameter *immheader-1-types* + #(bogus + bignum + double-float + xcode-vector + bogus + bogus + bogus + bogus + bogus + bogus + bogus + bogus + simple-base-string + simple-signed-long-vector + simple-unsigned-long-vector + single-float-vector)) + +(defparameter *immheader-2-types* + #(bogus + macptr + dead-macptr + bogus + bogus + bogus + bogus + bogus + bogus + bogus + bogus + bogus + simple-fixnum-vector + simple-signed-doubleword-vector + simple-unsigned-doubleword-vector + double-float-vector)) + + +(defparameter *x8664-%type-of-functions* nil) + +(let* ((fixnum (lambda (x) (declare (ignore x)) 'fixnum)) + (tra (lambda (x) (declare (ignore x)) 'tagged-return-address)) + (bogus (lambda (x) (declare (ignore x)) 'bogus))) + (setq *x8664-%type-of-functions* + (vector + fixnum ;0 + (lambda (x) (declare (ignore x)) 'short-float) ;1 + (lambda (x) (if (characterp x) 'character 'immediate)) ;2 + (lambda (x) (declare (ignore x)) 'cons) ;3 + tra ;4 + bogus ;5 + bogus ;6 + bogus ;7 + fixnum ;8 + bogus ;9 + bogus ;10 + (lambda (x) (declare (ignore x)) 'null) ;11 + tra ;12 + (lambda (x) (let* ((typecode (typecode x)) + (low4 (logand typecode x8664::fulltagmask)) + (high4 (ash typecode (- x8664::ntagbits)))) + (declare (type (unsigned-byte 8) typecode) + (type (unsigned-byte 4) low4 high4)) + (let* ((name + (cond ((= low4 x8664::fulltag-immheader-0) + (%svref *immheader-0-types* high4)) + ((= low4 x8664::fulltag-immheader-1) + (%svref *immheader-1-types* high4)) + ((= low4 x8664::fulltag-immheader-2) + (%svref *immheader-2-types* high4)) + ((= low4 x8664::fulltag-nodeheader-0) + (%svref *nodeheader-0-types* high4)) + ((= low4 x8664::fulltag-nodeheader-1) + (%svref *nodeheader-1-types* high4)) + (t 'bogus)))) + (or (and (eq name 'lock) + (uvref x x8664::lock.kind-cell)) + name)))) ;13 + (lambda (x) (declare (ignore x)) 'symbol) ;14 + (lambda (thing) + (let ((bits (lfun-bits thing))) + (declare (fixnum bits)) + (if (logbitp $lfbits-trampoline-bit bits) + (let ((inner-fn (closure-function thing))) + (if (neq inner-fn thing) + (let ((inner-bits (lfun-bits inner-fn))) + (if (logbitp $lfbits-method-bit inner-bits) + 'compiled-lexical-closure + (if (logbitp $lfbits-gfn-bit inner-bits) + 'standard-generic-function ; not precisely - see class-of + (if (logbitp $lfbits-cm-bit inner-bits) + 'combined-method + 'compiled-lexical-closure)))) + 'compiled-lexical-closure)) + (if (logbitp $lfbits-method-bit bits) + 'method-function + 'compiled-function))))))) ;15 + + + + + +(defun %type-of (thing) + (let* ((f (fulltag thing))) + (funcall (%svref *x8664-%type-of-functions* f) thing))) + + + +);#+x8664-target + + +;;; real machine specific huh +(defun consp (x) + "Return true if OBJECT is a CONS, and NIL otherwise." + (consp x)) + +(defun characterp (arg) + "Return true if OBJECT is a CHARACTER, and NIL otherwise." + (characterp arg)) + +(defun base-char-p (c) + (base-char-p c)) + + + + +(defun structurep (form) + "True if the given object is a named structure, Nil otherwise." + (= (the fixnum (typecode form)) target::subtag-struct)) + +(defun istructp (form) + (= (the fixnum (typecode form)) target::subtag-istruct)) + + +;;; Not to be conused with STRUCTURE-TYPE-P, defined in ccl:lib;pprint.lisp. +;;; (If you've ever been "conused", I'm sure you know just how painful +;;; that can be.) +(defun structure-typep (thing type) + (if (= (the fixnum (typecode thing)) target::subtag-struct) + (let* ((types (%svref thing 0))) + (if (typep type 'symbol) + (dolist (x types) + (when (eq (class-cell-name x) type) + (return t))) + (dolist (x types) + (when (eq x type) + (return t))))))) + + + +(defun istruct-typep (thing type) + (if (= (the fixnum (typecode thing)) target::subtag-istruct) + (eq (istruct-cell-name (%svref thing 0)) type))) + +(defun istruct-type-name (thing) + (if (= (the fixnum (typecode thing)) target::subtag-istruct) + (istruct-cell-name (%svref thing 0)))) + + +;;; This is actually set to an alist in the xloader. +(defparameter *istruct-cells* nil) + +;;; This should only ever push anything on the list in the cold +;;; load (e.g., when running single-threaded.) +(defun register-istruct-cell (name) + (or (assq name *istruct-cells*) + (let* ((pair (cons name nil))) + (push pair *istruct-cells*) + pair))) + +(defun set-istruct-cell-info (cell info) + (etypecase cell + (cons (%rplacd cell info))) + info) + + +(defun symbolp (thing) + "Return true if OBJECT is a SYMBOL, and NIL otherwise." + #+(or ppc32-target x8632-target) + (if thing + (= (the fixnum (typecode thing)) target::subtag-symbol) + t) + #+ppc64-target + (= (the fixnum (typecode thing)) ppc64::subtag-symbol) + #+x8664-target + (if thing + (= (the fixnum (lisptag thing)) x8664::tag-symbol) + t) + ) + +(defun packagep (thing) + (= (the fixnum (typecode thing)) target::subtag-package)) + +;;; 1 if by land, 2 if by sea. +(defun sequence-type (x) + (unless (>= (the fixnum (typecode x)) target::min-vector-subtag) + (or (listp x) + (report-bad-arg x 'sequence)))) + +(defun uvectorp (x) + (= (the fixnum (fulltag x)) target::fulltag-misc)) + +(setf (type-predicate 'uvector) 'uvectorp) + +(defun listp (x) + (listp x)) + +(defparameter *type-cells* nil) + + + +(defparameter *type-cells-lock* nil) + + +;;; The weird handling to the special variables here has to do with +;;; xload issues. +(defun register-type-cell (specifier) + (with-lock-grabbed ((or *type-cells-lock* + (setq *type-cells-lock* (make-lock)))) + (unless *type-cells* + (setq *type-cells* (make-hash-table :test 'equal))) + (or (values (gethash specifier *type-cells*)) + (setf (gethash specifier *type-cells*) + (make-type-cell specifier))))) + + +(defvar %find-classes% nil) + +(setq %find-classes% (make-hash-table :test 'eq)) + + +(defun find-class-cell (name create?) + (unless %find-classes% + (dbg name)) + (let ((cell (gethash name %find-classes%))) + (or cell + (and create? + (setf (gethash name %find-classes%) (make-class-cell name)))))) + Index: /branches/new-random/level-0/l0-symbol.lisp =================================================================== --- /branches/new-random/level-0/l0-symbol.lisp (revision 13309) +++ /branches/new-random/level-0/l0-symbol.lisp (revision 13309) @@ -0,0 +1,271 @@ +;;;-*- Mode: Lisp; Package: CCL -*- +;;; +;;; Copyright (C) 2009 Clozure Associates +;;; Copyright (C) 1994-2001 Digitool, Inc +;;; This file is part of Clozure CL. +;;; +;;; Clozure CL is licensed under the terms of the Lisp Lesser GNU Public +;;; License , known as the LLGPL and distributed with Clozure CL as the +;;; file "LICENSE". The LLGPL consists of a preamble and the LGPL, +;;; which is distributed with Clozure CL as the file "LGPL". Where these +;;; conflict, the preamble takes precedence. +;;; +;;; Clozure CL is referenced in the preamble as the "LIBRARY." +;;; +;;; The LLGPL is also available online at +;;; http://opensource.franz.com/preamble.html + +(in-package "CCL") + +;;; No error checking, no interrupts, no protect_caller, no nuthin. +;;; No error, no cons. No problem. +(defun %progvrestore (saved) + (declare (optimize (speed 3) (safety 0))) + (dolist (pair saved) + (%set-sym-value (car pair) (cdr pair)))) + +;;; Check that something that's supposed to be a proper list of +;;; symbols is; error otherwise. +;;; This is called only by the compiler output of a PROGV form. +;;; It checks for the maximum length that the progvsave subprim +;;; can handle. + +(defun check-symbol-list (l &optional (max-length + (floor (- 4096 20) (* target::node-size 3)) + )) + (let ((len (list-length l))) + (if (and len + (or (null max-length) + (< len max-length)) + (dolist (s l t) + (unless (and (symbolp s) + (not (constant-symbol-p s)) + (not (logbitp $sym_vbit_global (the fixnum (%symbol-bits s)))) + (ensure-binding-index s)) + (return nil)))) + l + (error "~s is not a proper list of bindable symbols~@[ of length < ~s~]." l max-length)))) + +;;; The type-checking done on the "plist" arg shouldn't be removed. +(defun set-symbol-plist (sym plist) + (when plist + (let* ((len (list-length plist))) + (unless (and len (evenp len)) + (error "Bad plist: ~s" plist)))) + (let* ((vector (symptr->symvector (%symbol->symptr sym))) + (cell (%svref vector target::symbol.plist-cell)) + (consp (consp cell))) + (if plist + (if consp + (setf (cdr cell) plist) + (cdr (setf (%svref vector target::symbol.plist-cell) (cons nil plist)))) + (progn + (if consp + (setf (%svref vector target::symbol.plist-cell) (%car cell))) + nil)))) + + +(eval-when (:compile-toplevel :execute) + (declaim (inline %pl-search))) + +(defun %pl-search (l key) + (declare (list l) (optimize (speed 3))) + (loop + (if (eq (car l) key) + (return) + (if l + (setq l (cdr (the list (cdr l)))) + (return)))) + l) + + +(defun symbol-plist (sym) + "Return SYMBOL's property list." + (let* ((cell (%svref (symptr->symvector (%symbol->symptr sym)) target::symbol.plist-cell))) + (if (consp cell) + (cdr cell)))) + + +(defun get (sym key &optional default) + "Look on the property list of SYMBOL for the specified INDICATOR. If this + is found, return the associated value, else return DEFAULT." + (let* ((cell (%svref (symptr->symvector (%symbol->symptr sym)) target::symbol.plist-cell)) + (tail (if (consp cell) + (%pl-search (cdr cell ) key)))) + (if tail (%cadr tail) default))) + +(defun put (sym key value) + (let* ((symptr (%symbol->symptr sym)) + (vector (symptr->symvector symptr)) + (cell (%svref vector target::symbol.plist-cell)) + (plist (if (consp cell) (cdr cell))) + (tail (%pl-search plist key))) + (if tail + (%rplaca (%cdr tail) value) + (progn + (setq plist (cons key (cons value plist))) + (if (consp cell) + (setf (cdr cell) plist) + (setf (%svref vector target::symbol.plist-cell) (cons nil plist))))) + value)) + + +(defun get-type-predicate (name) + (let* ((symvec (symptr->symvector (%symbol->symptr name))) + (pp (%svref symvec target::symbol.package-predicate-cell))) + (if (consp pp) + (%cdr pp)))) + +(defun set-type-predicate (name function) + (let* ((bits (%symbol-bits name)) + (symvec (symptr->symvector (%symbol->symptr name))) + (spp (%svref symvec target::symbol.package-predicate-cell))) + (declare (fixnum bits)) + (if (logbitp $sym_vbit_typeppred bits) + (%rplacd spp function) + (progn + (%symbol-bits name (the fixnum (bitset $sym_vbit_typeppred bits))) + (setf (%svref symvec target::symbol.package-predicate-cell) (cons spp function)))) + function)) + +(defun symbol-value (sym) + "Return SYMBOL's current bound value." + (let* ((val (%sym-value sym))) + (if (eq val (%unbound-marker)) + (%kernel-restart $xvunbnd sym) + val))) + +(defun set (sym value) + "Set SYMBOL's value cell to NEW-VALUE." + (let* ((bits (%symbol-bits sym))) + (declare (fixnum bits)) + (if (logbitp $sym_vbit_const bits) + (%err-disp $XCONST sym) + (%set-sym-value sym value)))) + +(defun constant-symbol-p (sym) + (and (symbolp sym) + (%ilogbitp $sym_vbit_const (%symbol-bits sym)))) + +;;; This leaves the SPECIAL bit alone, clears the others. +(defun makunbound (sym) + "Make SYMBOL unbound, removing any value it may currently have." + (if (and *warn-if-redefine-kernel* + (constant-symbol-p sym)) + (cerror "Make ~S be unbound anyway." + "~S is a constant; making it unbound might be a bad idea." sym)) + (%symbol-bits sym (the fixnum (logand (logior #xff00 (ash 1 $sym_bit_special)) + (the fixnum (%symbol-bits sym))))) + (%set-sym-value sym (%unbound-marker)) + sym) + +(defun non-nil-symbolp (x) + "Returns symbol if true" + (if (symbolp x) x)) + +(defun symbol-package (sym) + "Return the package SYMBOL was interned in, or NIL if none." + (let* ((pp (%svref (symptr->symvector (%symbol->symptr sym)) target::symbol.package-predicate-cell))) + (if (consp pp) (car pp) pp))) + +(defun boundp (sym) + "Return non-NIL if SYMBOL is bound to a value." + (not (eq (%sym-value sym) (%unbound-marker)))) + +(defun make-symbol (name) + "Make and return a new symbol with the NAME as its print name." + (symvector->symptr + (%gvector target::subtag-symbol + (ensure-simple-string name) ; pname + (%unbound-marker) ; value cell + %unbound-function% ; function cell + nil ; package&predicate + 0 ; flags + nil ; plist + 0))) ; binding-index + +(defun %symbol-bits (sym &optional new) + (let* ((p (%symbol->symptr sym)) + (bits (%svref (symptr->symvector p) target::symbol.flags-cell))) + (if new + (setf (%svref (symptr->symvector p) target::symbol.flags-cell) new)) + bits)) + +(defun %sym-value (name) + (%symptr-value (%symbol->symptr name))) + +(defun %set-sym-value (name val) + (%set-symptr-value (%symbol->symptr name) val)) + +(defun %sym-global-value (name) + (%svref (symptr->symvector (%symbol->symptr name)) target::symbol.vcell-cell)) + +(defun %set-sym-global-value (name val) + (setf (%svref (symptr->symvector (%symbol->symptr name)) target::symbol.vcell-cell) val)) + +(defun symbol-name (sym) + "Return SYMBOL's name as a string." + #+(or ppc32-target x8632-target x8664-target) + (%svref (symptr->symvector (%symbol->symptr sym)) target::symbol.pname-cell) + #+ppc64-target + (if sym ;NIL's pname is implicit + (%svref (%symbol->symptr sym) ppc64::symbol.pname-cell) + "NIL") + ) + + + + +(defun %global-macro-function (symbol) + (let* ((fbinding (fboundp symbol))) + (if (and (typep fbinding 'simple-vector) + (= (the fixnum (uvsize fbinding)) 2)) + (let* ((fun (%svref fbinding 1))) + (if (functionp fun) fun))))) + +(defun %symbol-binding-address (sym) + (%symptr-binding-address (%symbol->symptr sym))) + +(defun symbol-binding-index (sym) + (%svref (symptr->symvector (%symbol->symptr sym)) target::symbol.binding-index-cell)) + +(defvar *interrupt-level* -1) + +;;; Special binding indices, and the inverse mapping between indices +;;; and symbols +(let* ((binding-index-lock (make-lock)) + (binding-index-reverse-map (make-hash-table :test #'eq :weak :value)) + (next-binding-index 0)) + (defun %set-binding-index (val) (setq next-binding-index val)) + (defun next-binding-index () (1+ next-binding-index)) + (defun ensure-binding-index (sym) + (with-lock-grabbed (binding-index-lock) + (let* ((symvec (symptr->symvector (%symbol->symptr sym))) + (idx (%svref symvec target::symbol.binding-index-cell)) + (bits (%symbol-bits sym))) + (declare (fixnum idx bits)) + (if (or (logbitp $sym_vbit_global bits) + (logbitp $sym_vbit_const bits)) + (unless (zerop idx) + (remhash idx binding-index-reverse-map) + (setf (%svref symvec target::symbol.binding-index-cell) 0)) + (if (zerop idx) + (let* ((new-idx (incf next-binding-index))) + (setf (%svref symvec target::symbol.binding-index-cell) new-idx) + (setf (gethash new-idx binding-index-reverse-map) sym)))) + sym))) + (defun binding-index-symbol (idx) + (with-lock-grabbed (binding-index-lock) + (gethash idx binding-index-reverse-map))) + (defun cold-load-binding-index (sym) + ;; Index may have been assigned via xloader. Update + ;; reverse map + (with-lock-grabbed (binding-index-lock) + (let* ((idx (%svref (symptr->symvector (%symbol->symptr sym)) + target::symbol.binding-index-cell))) + (declare (fixnum idx)) + (unless (zerop idx) + (setf (gethash idx binding-index-reverse-map) sym)))))) + + + Index: /branches/new-random/level-0/l0-utils.lisp =================================================================== --- /branches/new-random/level-0/l0-utils.lisp (revision 13309) +++ /branches/new-random/level-0/l0-utils.lisp (revision 13309) @@ -0,0 +1,197 @@ +; -*- Mode: Lisp; Package: CCL; -*- +;;; +;;; Copyright (C) 2009 Clozure Associates +;;; Copyright (C) 1994-2001 Digitool, Inc +;;; This file is part of Clozure CL. +;;; +;;; Clozure CL is licensed under the terms of the Lisp Lesser GNU Public +;;; License , known as the LLGPL and distributed with Clozure CL as the +;;; file "LICENSE". The LLGPL consists of a preamble and the LGPL, +;;; which is distributed with Clozure CL as the file "LGPL". Where these +;;; conflict, the preamble takes precedence. +;;; +;;; Clozure CL is referenced in the preamble as the "LIBRARY." +;;; +;;; The LLGPL is also available online at +;;; http://opensource.franz.com/preamble.html + + + +; l0-utils.lisp + + +(in-package "CCL") + +(defun %proclaim-notspecial (sym) + (%symbol-bits sym (logandc2 (%symbol-bits sym) (ash 1 $sym_bit_special)))) + + +(defun heap-area-name (code) + (cond ((eq code area-void) :void) + ((eq code area-cstack) :cstack) + ((eq code area-vstack) :vstack) + ((eq code area-tstack) :tstack) + ((eq code area-readonly) :readonly) + ((eq code area-watched) :watched) + ((eq code area-managed-static) :managed-static) + ((eq code area-static) :static) + ((eq code area-dynamic) :dynamic) + (t code))) + +(defun heap-area-code (name) + (case name + (:void area-void) + (:cstack area-cstack) + (:vstack area-vstack) + (:tstack area-tstack) + (:readonly area-readonly) + (:watched area-watched) + (:managed-static area-managed-static) + (:static area-static) + (:dynamic area-dynamic) + (t (if (and (fixnump name) + (<= area-readonly name area-dynamic)) + name + (heap-area-code (require-type name '(member :void :cstack :vstack :tstack + :readonly :managed-static :static :dynamic))))))) + + +;;; We MAY need a scheme for finding all of the areas in a lisp library. +(defun %map-areas (function &optional area) + (let* ((area (cond ((or (eq area t) (eq area nil)) nil) + ((consp area) (mapcar #'heap-area-code area)) ;; list of areas + (t (heap-area-code area)))) + (mincode area-readonly) + (maxcode area-dynamic)) + (declare (fixnum maxcode mincode)) + (do* ((a (%normalize-areas) (%lisp-word-ref a (ash target::area.succ (- target::fixnumshift)))) + (code area-dynamic (%lisp-word-ref a (ash target::area.code (- target::fixnumshift)))) + (dynamic t nil)) + ((= code area-void)) + (declare (fixnum code)) + (if (and (<= code maxcode) + (>= code mincode) + (or (null area) + (eql code area) + (and (consp area) (member code area)))) + (if dynamic + (walk-dynamic-area a function) + (unless (= code area-dynamic) ; ignore egc areas, 'cause walk-dynamic-area sees them. + (walk-static-area a function))))))) + + +;;; there'll be functions in static lib areas. +;;; (Well, there would be if there were really static lib areas.) + +(defun %map-lfuns (f) + (let* ((filter #'(lambda (obj) (when (= (the fixnum (typecode obj)) + target::subtag-function) + (funcall f (lfun-vector-lfun obj)))))) + (declare (dynamic-extent filter)) + (%map-areas filter '(:dynamic :static :managed-static :readonly)))) + + +(defun ensure-simple-string (s) + (cond ((simple-string-p s) s) + ((stringp s) + (let* ((len (length s)) + (new (make-string len :element-type 'base-char))) + (declare (fixnum len)(optimize (speed 3)(safety 0))) + (multiple-value-bind (ss offset) (array-data-and-offset s) + (%copy-ivector-to-ivector ss (ash offset 2) new 0 (ash len 2))) + new)) + (t (report-bad-arg s 'string)))) + +(defun nremove (elt list) + (let* ((handle (cons nil list)) + (splice handle)) + (declare (dynamic-extent handle)) + (loop + (if (eq elt (car (%cdr splice))) + (unless (setf (%cdr splice) (%cddr splice)) (return)) + (unless (cdr (setq splice (%cdr splice))) + (return)))) + (%cdr handle))) + + +(eval-when (:compile-toplevel :execute) + #+32-bit-target + (defmacro need-use-eql-macro (key) + `(let* ((typecode (typecode ,key))) + (declare (fixnum typecode)) + (or (= typecode target::subtag-macptr) + (and (>= typecode target::min-numeric-subtag) + (<= typecode target::max-numeric-subtag))))) + #+64-bit-target + (defmacro need-use-eql-macro (key) + `(let* ((typecode (typecode ,key))) + (declare (fixnum typecode)) + (cond ((= typecode target::tag-fixnum) t) + ((= typecode target::subtag-single-float) t) + ((= typecode target::subtag-bignum) t) + ((= typecode target::subtag-double-float) t) + ((= typecode target::subtag-ratio) t) + ((= typecode target::subtag-complex) t) + ((= typecode target::subtag-macptr) t)))) + +) + +(defun asseql (item list) + (if (need-use-eql-macro item) + (dolist (pair list) + (if pair + (if (eql item (car pair)) + (return pair)))) + (assq item list))) + +(defun assequal (item list) + (dolist (pair list) + (if pair + (if (equal item (car pair)) + (return pair))))) + + +;;; (memeql item list) <=> (member item list :test #'eql :key #'identity) +(defun memeql (item list) + (if (need-use-eql-macro item) + (do* ((l list (%cdr l))) + ((endp l)) + (when (eql (%car l) item) (return l))) + (memq item list))) + +(defun memequal (item list) + (do* ((l list (%cdr l))) + ((endp l)) + (when (equal (%car l) item) (return l)))) + + +; (member-test item list test-fn) +; <=> +; (member item list :test test-fn :key #'identity) +(defun member-test (item list test-fn) + (if (or (eq test-fn 'eq)(eq test-fn #'eq) + (and (or (eq test-fn 'eql)(eq test-fn #'eql)) + (not (need-use-eql-macro item)))) + (do* ((l list (cdr l))) + ((null l)) + (when (eq item (car l))(return l))) + (if (or (eq test-fn 'eql)(eq test-fn #'eql)) + (do* ((l list (cdr l))) + ((null l)) + (when (eql item (car l))(return l))) + (do* ((l list (cdr l))) + ((null l)) + (when (funcall test-fn item (car l)) (return l)))))) + +(defun s32->u32 (s32) + (%stack-block ((buf 4)) + (setf (%get-signed-long buf) s32) + (%get-unsigned-long buf))) + +(defun u32->s32 (u32) + (%stack-block ((buf 4)) + (setf (%get-unsigned-long buf) u32) + (%get-signed-long buf))) + + +; end Index: /branches/new-random/level-0/nfasload.lisp =================================================================== --- /branches/new-random/level-0/nfasload.lisp (revision 13309) +++ /branches/new-random/level-0/nfasload.lisp (revision 13309) @@ -0,0 +1,1207 @@ +;;;-*- Mode: Lisp; Package: CCL -*- +;;; +;;; Copyright (C) 2009 Clozure Associates +;;; Copyright (C) 1994-2001 Digitool, Inc +;;; This file is part of Clozure CL. +;;; +;;; Clozure CL is licensed under the terms of the Lisp Lesser GNU Public +;;; License , known as the LLGPL and distributed with Clozure CL as the +;;; file "LICENSE". The LLGPL consists of a preamble and the LGPL, +;;; which is distributed with Clozure CL as the file "LGPL". Where these +;;; conflict, the preamble takes precedence. +;;; +;;; Clozure CL is referenced in the preamble as the "LIBRARY." +;;; +;;; The LLGPL is also available online at +;;; http://opensource.franz.com/preamble.html + +(in-package "CCL") + +(eval-when (:compile-toplevel :execute) + +(require "FASLENV" "ccl:xdump;faslenv") + + +(defconstant $primsizes (make-array 23 + :element-type '(unsigned-byte 16) + :initial-contents + '(41 61 97 149 223 337 509 769 887 971 1153 1559 1733 + 2609 2801 3917 5879 8819 13229 19843 24989 29789 32749))) +(defconstant $hprimes (make-array 8 + :element-type '(unsigned-byte 16) + :initial-contents '(5 7 11 13 17 19 23 29))) + +;;; Symbol hash tables: (htvec . (hcount . hlimit)) + +(defmacro htvec (htab) `(%car ,htab)) +(defmacro htcount (htab) `(%cadr ,htab)) +(defmacro htlimit (htab) `(%cddr ,htab)) +) + +(eval-when (:execute :compile-toplevel) + (assert (= 80 numfaslops))) + + + + + +(defvar *fasl-dispatch-table* #80(%bad-fasl)) + + + + + +(defun %bad-fasl (s) + (error "bad opcode near position ~d in FASL file ~s" + (%fasl-get-file-pos s) + (faslstate.faslfname s))) + +(defun %cant-epush (s) + (if (faslstate.faslepush s) + (%bad-fasl s))) + +(defun %epushval (s val) + (setf (faslstate.faslval s) val) + (when (faslstate.faslepush s) + (setf (svref (faslstate.faslevec s) (faslstate.faslecnt s)) val) + (incf (the fixnum (faslstate.faslecnt s)))) + val) + +(defun %simple-fasl-read-buffer (s) + (let* ((fd (faslstate.faslfd s)) + (buffer (faslstate.iobuffer s)) + (bufptr (%get-ptr buffer))) + (declare (dynamic-extent bufptr) + (type macptr buffer bufptr)) + (%setf-macptr bufptr (%inc-ptr buffer target::node-size)) + (setf (%get-ptr buffer) bufptr) + (let* ((n (fd-read fd bufptr $fasl-buf-len))) + (declare (fixnum n)) + (if (> n 0) + (setf (faslstate.bufcount s) n) + (error "Fix this: look at errno, EOF"))))) + + +(defun %simple-fasl-read-byte (s) + (loop + (let* ((buffer (faslstate.iobuffer s)) + (bufptr (%get-ptr buffer))) + (declare (dynamic-extent bufptr) + (type macptr buffer bufptr)) + (if (>= (the fixnum (decf (the fixnum (faslstate.bufcount s)))) + 0) + (return + (prog1 + (%get-unsigned-byte bufptr) + (setf (%get-ptr buffer) + (%incf-ptr bufptr)))) + (%fasl-read-buffer s))))) + +(defun %fasl-read-word (s) + (the fixnum + (logior (the fixnum (ash (the fixnum (%fasl-read-byte s)) 8)) + (the fixnum (%fasl-read-byte s))))) + + +(defun %fasl-read-long (s) + (logior (ash (%fasl-read-word s) 16) (%fasl-read-word s))) + +(defun %fasl-read-signed-long (s) + (logior (ash (%word-to-int (%fasl-read-word s)) 16) + (%fasl-read-word s))) + + +(defun %fasl-read-count (s) + (do* ((val 0) + (shift 0 (+ shift 7)) + (done nil)) + (done val) + (let* ((b (%fasl-read-byte s))) + (declare (type (unsigned-byte 8) b)) + (setq done (logbitp 7 b) val (logior val (ash (logand b #x7f) shift)))))) + +(defun %simple-fasl-read-n-bytes (s ivector byte-offset n) + (declare (fixnum byte-offset n)) + (do* () + ((= n 0)) + (let* ((count (faslstate.bufcount s)) + (buffer (faslstate.iobuffer s)) + (bufptr (%get-ptr buffer)) + (nthere (if (< count n) count n))) + (declare (dynamic-extent bufptr) + (type macptr buffer bufptr) + (fixnum count nthere)) + (if (= nthere 0) + (%fasl-read-buffer s) + (progn + (decf n nthere) + (decf (the fixnum (faslstate.bufcount s)) nthere) + (%copy-ptr-to-ivector bufptr 0 ivector byte-offset nthere) + (incf byte-offset nthere) + (setf (%get-ptr buffer) + (%incf-ptr bufptr nthere))))))) + + +(defun %fasl-read-utf-8-string (s string nchars nextra) + (declare (fixnum nchars nextra)) + (if (eql 0 nextra) + (dotimes (i nchars) + (setf (%scharcode string i) (%fasl-read-byte s))) + (flet ((trailer-byte () + (when (> nextra 0) + (decf nextra) + (let* ((b (%fasl-read-byte s))) + (declare ((unsigned-byte 8) b)) + (and (>= b #x80) + (< b #xc0) + (logand b #x3f)))))) + (declare (inline trailer-byte)) + (dotimes (i nchars) + (let* ((b0 (%fasl-read-byte s))) + (declare ((unsigned-byte 8) b0)) + (setf (%scharcode string i) + (or + (cond ((< b0 #x80) b0) + ((and (>= b0 #xc2) + (< b0 #xe0)) + (let* ((b1 (trailer-byte))) + (and b1 (logior (ash (logand b0 #x1f) 6) b1)))) + ((and (>= b0 #xe0) + (< b0 #xf0)) + (let* ((b1 (trailer-byte)) + (b2 (trailer-byte))) + (and b1 b2 (logior (ash (logand b0 #x0f) 12) + (logior (ash b1 6) + b2))))) + ((and (>= b0 #xf0) + (< b0 #xf5)) + (let* ((b1 (trailer-byte)) + (b2 (trailer-byte)) + (b3 (trailer-byte))) + (and b1 + b2 + b3 + (logior (ash (logand b0 #x7) 18) + (logior (ash b1 12) + (logior (ash b2 6) + b3))))))) + (char-code #\Replacement_Character)))))))) + + +(defun %fasl-vreadstr (s) + (let* ((nchars (%fasl-read-count s)) + (nextra (%fasl-read-count s)) + (copy t) + (n nchars) + (str (faslstate.faslstr s))) + (declare (fixnum nchars n nextra)) + (if (> n (length str)) + (setq str (make-string n :element-type 'base-char)) + (setq copy nil)) + (%fasl-read-utf-8-string s str nchars nextra) + (values str nchars copy))) + + +(defun %fasl-read-n-string (s string start n) + (declare (fixnum start n)) + (do* ((i start (1+ i)) + (n n (1- n))) + ((<= n 0)) + (declare (fixnum i n)) + (setf (%scharcode string i) (%fasl-read-byte s)))) + +(defun %fasl-nvreadstr (s) + (let* ((nchars (%fasl-read-count s)) + (copy t) + (n nchars) + (str (faslstate.faslstr s))) + (declare (fixnum n nchars)) + (if (> n (length str)) + (setq str (make-string n :element-type 'base-char)) + (setq copy nil)) + (%fasl-read-n-string s str 0 nchars) + (values str n copy))) + +(defun %fasl-copystr (str len) + (declare (fixnum len)) + (let* ((new (make-string len :element-type 'base-char))) + (declare (simple-base-string new)) + (declare (optimize (speed 3)(safety 0))) + (dotimes (i len new) + (setf (schar new i) (schar str i))))) + +(defun %fasl-dispatch (s op) + (declare (fixnum op)) + (setf (faslstate.faslepush s) (logbitp $fasl-epush-bit op)) + #+debug + (format t "~& dispatch: op = ~d at ~x" (logand op (lognot (ash 1 $fasl-epush-bit))) + (1- (%fasl-get-file-pos s))) + (funcall (svref (faslstate.fasldispatch s) (logand op (lognot (ash 1 $fasl-epush-bit)))) + s)) + +(defun %fasl-expr (s) + (%fasl-dispatch s (%fasl-read-byte s)) + (faslstate.faslval s)) + +(defun %fasl-expr-preserve-epush (s) + (let* ((epush (faslstate.faslepush s)) + (val (%fasl-expr s))) + (setf (faslstate.faslepush s) epush) + val)) + + +(defun %fasl-vmake-symbol (s &optional idx) + (let* ((n (%fasl-read-count s)) + (nextra (%fasl-read-count s)) + (str (make-string n :element-type 'base-char))) + (declare (fixnum n)) + (%fasl-read-utf-8-string s str n nextra) + (let* ((sym (make-symbol str))) + (when idx (ensure-binding-index sym)) + (%epushval s sym)))) + +(defun %fasl-nvmake-symbol (s &optional idx) + (let* ((n (%fasl-read-count s)) + (str (make-string n :element-type 'base-char))) + (declare (fixnum n)) + (%fasl-read-n-string s str 0 n) + (let* ((sym (make-symbol str))) + (when idx (ensure-binding-index sym)) + (%epushval s sym)))) + +(defun %fasl-vintern (s package &optional binding-index) + (multiple-value-bind (str len new-p) (%fasl-vreadstr s) + (with-package-lock (package) + (multiple-value-bind (symbol access internal-offset external-offset) + (%find-symbol str len package) + (unless access + (unless new-p (setq str (%fasl-copystr str len))) + (setq symbol (%add-symbol str package internal-offset external-offset))) + (when binding-index + (ensure-binding-index symbol)) + (%epushval s symbol))))) + +(defun %fasl-nvintern (s package &optional binding-index) + (multiple-value-bind (str len new-p) (%fasl-nvreadstr s) + (with-package-lock (package) + (multiple-value-bind (symbol access internal-offset external-offset) + (%find-symbol str len package) + (unless access + (unless new-p (setq str (%fasl-copystr str len))) + (setq symbol (%add-symbol str package internal-offset external-offset))) + (when binding-index + (ensure-binding-index symbol)) + (%epushval s symbol))))) + +(defvar *package-refs*) +(setq *package-refs* (make-hash-table :test #'equal)) +(defvar *package-refs-lock*) +(setq *package-refs-lock* (make-lock)) + +(defun register-package-ref (name) + (unless (typep name 'string) + (report-bad-arg name 'string)) + (let* ((ref + (or (gethash name *package-refs*) + (with-lock-grabbed (*package-refs-lock*) + (or + (gethash name *package-refs*) ; check again + (let* ((r (make-package-ref name))) + (setf (gethash name *package-refs*) r))))))) + (unless (package-ref.pkg ref) + (setf (package-ref.pkg ref) (find-package name))) + ref)) + + +(dolist (p %all-packages%) + (dolist (name (pkg.names p)) + (setf (package-ref.pkg (register-package-ref name)) p))) + + +(defun find-package (name) + (if (typep name 'package) + name + (%find-pkg (string name)))) + +(defun %pkg-ref-find-package (ref) + (package-ref.pkg ref)) + +(defun set-package (name &aux (pkg (find-package name))) + (if pkg + (setq *package* pkg) + (set-package (%kernel-restart $xnopkg name)))) + + +(defun %find-pkg (name &optional (len (length name))) + (declare (fixnum len)) + (with-package-list-read-lock + (dolist (p %all-packages%) + (if (dolist (pkgname (pkg.names p)) + (when (and (= (the fixnum (length pkgname)) len) + (dotimes (i len t) + ;; Aref: allow non-simple strings + (unless (eq (aref name i) (schar pkgname i)) + (return)))) + (return t))) + (return p))))) + + + +(defun pkg-arg (thing &optional deleted-ok) + (let* ((xthing (cond ((or (symbolp thing) (typep thing 'character)) + (string thing)) + ((typep thing 'string) + (ensure-simple-string thing)) + (t + thing)))) + (let* ((typecode (typecode xthing))) + (declare (fixnum typecode)) + (cond ((= typecode target::subtag-package) + (if (or deleted-ok (pkg.names xthing)) + xthing + (error "~S is a deleted package ." thing))) + ((= typecode target::subtag-simple-base-string) + (or (%find-pkg xthing) + (%kernel-restart $xnopkg xthing))) + (t (report-bad-arg thing 'simple-string)))))) + +(defun %fasl-vpackage (s) + (multiple-value-bind (str len new-p) (%fasl-vreadstr s) + (let* ((p (%find-pkg str len))) + (%epushval s (or p (%kernel-restart $XNOPKG (if new-p str (%fasl-copystr str len)))))))) + + +(defun %fasl-nvpackage (s) + (multiple-value-bind (str len new-p) (%fasl-nvreadstr s) + (let* ((p (%find-pkg str len))) + (%epushval s (or p (%kernel-restart $XNOPKG (if new-p str (%fasl-copystr str len)))))))) + +(defun %fasl-vlistX (s dotp) + (let* ((len (%fasl-read-count s))) + (declare (fixnum len)) + (let* ((val (%epushval s (cons nil nil))) + (tail val)) + (declare (type cons val tail)) + (setf (car val) (%fasl-expr s)) + (dotimes (i len) + (setf (cdr tail) (setq tail (cons (%fasl-expr s) nil)))) + (if dotp + (setf (cdr tail) (%fasl-expr s))) + (setf (faslstate.faslval s) val)))) + +(deffaslop $fasl-noop (s) + (%cant-epush s)) + + +(deffaslop $fasl-vetab-alloc (s) + (%cant-epush s) + (setf (faslstate.faslevec s) (make-array (the fixnum (%fasl-read-count s))) + (faslstate.faslecnt s) 0)) + +(deffaslop $fasl-platform (s) + (%cant-epush s) + (let* ((platform (%fasl-expr s)) + (host-platform (%get-kernel-global 'host-platform))) + (declare (fixnum platform host-platform)) + (unless (= platform host-platform) + (error "Not a native fasl file : ~s" (faslstate.faslfname s))))) + + +(deffaslop $fasl-veref (s) + (let* ((idx (%fasl-read-count s))) + (declare (fixnum idx)) + (if (>= idx (the fixnum (faslstate.faslecnt s))) + (%bad-fasl s)) + (%epushval s (svref (faslstate.faslevec s) idx)))) + +#+x86-target +;;; Read a "concatenated" lisp function, in which the machine code +;;; and constants are both contained in the same underlying uvector. +(deffaslop $fasl-clfun (s) + (let* ((size-in-elements (%fasl-read-count s)) + (size-of-code (%fasl-read-count s)) + (vector (%alloc-misc size-in-elements target::subtag-function)) + (function (function-vector-to-function vector))) + (declare (fixnum size-in-elements size-of-code)) + (%epushval s function) + (%fasl-read-n-bytes s vector 0 (ash size-of-code target::word-shift)) + #+x8632-target + (%update-self-references vector) + (do* ((numconst (- size-in-elements size-of-code)) + (i 0 (1+ i)) + (constidx size-of-code (1+ constidx))) + ((= i numconst) + (setf (faslstate.faslval s) function)) + (declare (fixnum i numconst constidx)) + (setf (%svref vector constidx) (%fasl-expr s))))) + + +(deffaslop $fasl-lfuncall (s) + (let* ((fun (%fasl-expr-preserve-epush s))) + ;(break "fun = ~s" fun) + (%epushval s (funcall fun)))) + +(deffaslop $fasl-globals (s) + (setf (faslstate.faslgsymbols s) (%fasl-expr s))) + +(deffaslop $fasl-char (s) + (%epushval s (code-char (%fasl-read-count s)))) + +;;; Deprecated +(deffaslop $fasl-fixnum (s) + (%epushval + s + (logior (the fixnum (ash (the fixnum (%word-to-int (%fasl-read-word s))) + 16)) + (the fixnum (%fasl-read-word s))) )) + +(deffaslop $fasl-s32 (s) + (%epushval s (%fasl-read-signed-long s))) + +(deffaslop $fasl-s64 (s) + (%epushval s (logior (ash (%fasl-read-signed-long s) 32) + (%fasl-read-long s)))) + +(deffaslop $fasl-dfloat (s) + ;; A double-float is a 3-element "misc" object. + ;; Element 0 is always 0 and exists solely to keep elements 1 and 2 + ;; aligned on a 64-bit boundary. + (%epushval s (double-float-from-bits (%fasl-read-long s) (%fasl-read-long s)))) + +(deffaslop $fasl-sfloat (s) + (%epushval s (host-single-float-from-unsigned-byte-32 (%fasl-read-long s)))) + +(deffaslop $fasl-vstr (s) + (let* ((nchars (%fasl-read-count s)) + (nextra (%fasl-read-count s)) + (str (make-string (the fixnum nchars) :element-type 'base-char))) + (%epushval s str) + (%fasl-read-utf-8-string s str nchars nextra))) + + +(deffaslop $fasl-nvstr (s) + (let* ((n (%fasl-read-count s)) + (str (make-string (the fixnum n) :element-type 'base-char))) + (%epushval s str) + (%fasl-read-n-string s str 0 n))) + +(deffaslop $fasl-word-fixnum (s) + (%epushval s (%word-to-int (%fasl-read-word s)))) + +(deffaslop $fasl-vmksym (s) + (%fasl-vmake-symbol s)) + +(deffaslop $fasl-nvmksym (s) + (%fasl-nvmake-symbol s)) + +(deffaslop $fasl-vmksym-special (s) + (%fasl-vmake-symbol s t)) + +(deffaslop $fasl-nvmksym-special (s) + (%fasl-nvmake-symbol s t)) + +(deffaslop $fasl-vintern (s) + (%fasl-vintern s *package*)) + +(deffaslop $fasl-nvintern (s) + (%fasl-nvintern s *package*)) + +(deffaslop $fasl-vintern-special (s) + (%fasl-vintern s *package* t)) + +(deffaslop $fasl-nvintern-special (s) + (%fasl-nvintern s *package* t)) + + + + +(deffaslop $fasl-vpkg-intern (s) + (let* ((pkg (%fasl-expr-preserve-epush s))) + #+paranoia + (setq pkg (pkg-arg pkg)) + (%fasl-vintern s pkg))) + +(deffaslop $fasl-nvpkg-intern (s) + (let* ((pkg (%fasl-expr-preserve-epush s))) + #+paranoia + (setq pkg (pkg-arg pkg)) + (%fasl-nvintern s pkg))) + +(deffaslop $fasl-vpkg-intern-special (s) + (let* ((pkg (%fasl-expr-preserve-epush s))) + #+paranoia + (setq pkg (pkg-arg pkg)) + (%fasl-vintern s pkg t))) + +(deffaslop $fasl-nvpkg-intern-special (s) + (let* ((pkg (%fasl-expr-preserve-epush s))) + #+paranoia + (setq pkg (pkg-arg pkg)) + (%fasl-nvintern s pkg t))) + +(deffaslop $fasl-vpkg (s) + (%fasl-vpackage s)) + +(deffaslop $fasl-nvpkg (s) + (%fasl-nvpackage s)) + +(deffaslop $fasl-cons (s) + (let* ((cons (%epushval s (cons nil nil)))) + (declare (type cons cons)) + (setf (car cons) (%fasl-expr s) + (cdr cons) (%fasl-expr s)) + (setf (faslstate.faslval s) cons))) + +(deffaslop $fasl-vlist (s) + (%fasl-vlistX s nil)) + +(deffaslop $fasl-vlist* (s) + (%fasl-vlistX s t)) + +(deffaslop $fasl-nil (s) + (%epushval s nil)) + +(deffaslop $fasl-timm (s) + (rlet ((p :int)) + (setf (%get-long p) (%fasl-read-long s)) + (%epushval s (%get-unboxed-ptr p)))) + +(deffaslop $fasl-symfn (s) + (%epushval s (%function (%fasl-expr-preserve-epush s)))) + +(deffaslop $fasl-eval (s) + (%epushval s (eval (%fasl-expr-preserve-epush s)))) + +;;; For bootstrapping. The real version is cheap-eval in l1-readloop +(when (not (fboundp 'eval)) + (defun eval (form) + (if (and (listp form) + (let ((f (%car form))) + (and (symbolp f) + (functionp (fboundp f))))) + (do* ((tail (%cdr form) (%cdr tail))) + ((null tail) (apply (%car form) (%cdr form))) + (let* ((head (car tail))) + (when (and (consp head) (eq (car head) 'quote)) + (setf (car tail) (cadr head))))) + (error "Can't eval yet: ~s" form)))) + + +(deffaslop $fasl-vivec (s) + (let* ((subtag (%fasl-read-byte s)) + (element-count (%fasl-read-count s)) + (size-in-bytes (subtag-bytes subtag element-count)) + (vector (%alloc-misc element-count subtag)) + (byte-offset (or #+32-bit-target (if (= subtag target::subtag-double-float-vector) 4) 0))) + (declare (fixnum subtag element-count size-in-bytes)) + (%epushval s vector) + (%fasl-read-n-bytes s vector byte-offset size-in-bytes) + vector)) + +(defun fasl-read-ivector (s subtag) + (let* ((element-count (%fasl-read-count s)) + (size-in-bytes (subtag-bytes subtag element-count)) + (vector (%alloc-misc element-count subtag))) + (declare (fixnum subtag element-count size-in-bytes)) + (%epushval s vector) + (%fasl-read-n-bytes s vector 0 size-in-bytes) + vector)) + +(deffaslop $fasl-u8-vector (s) + (fasl-read-ivector s target::subtag-u8-vector)) + +(deffaslop $fasl-s8-vector (s) + (fasl-read-ivector s target::subtag-s8-vector)) + +(deffaslop $fasl-u16-vector (s) + (fasl-read-ivector s target::subtag-u16-vector)) + +(deffaslop $fasl-s16-vector (s) + (fasl-read-ivector s target::subtag-s16-vector)) + +(deffaslop $fasl-u32-vector (s) + (fasl-read-ivector s target::subtag-u32-vector)) + +(deffaslop $fasl-s32-vector (s) + (fasl-read-ivector s target::subtag-s32-vector)) + +#+64-bit-target +(deffaslop $fasl-u64-vector (s) + (fasl-read-ivector s target::subtag-u64-vector)) + +#+64-bit-target +(deffaslop $fasl-u64-vector (s) + (fasl-read-ivector s target::subtag-s64-vector)) + +(deffaslop $fasl-bit-vector (s) + (fasl-read-ivector s target::subtag-bit-vector)) + +(deffaslop $fasl-bignum32 (s) + (let* ((element-count (%fasl-read-count s)) + (size-in-bytes (* element-count 4)) + (num (%alloc-misc element-count target::subtag-bignum))) + (declare (fixnum element-count size-in-bytes)) + (%fasl-read-n-bytes s num 0 size-in-bytes) + (setq num (%normalize-bignum-2 t num)) + (%epushval s num) + num)) + +(deffaslop $fasl-single-float-vector (s) + (fasl-read-ivector s target::subtag-single-float-vector)) + +(deffaslop $fasl-double-float-vector (s) + #+64-bit-target + (fasl-read-ivector s target::subtag-double-float-vector) + #+32-bit-target + (let* ((element-count (%fasl-read-count s)) + (size-in-bytes (subtag-bytes target::subtag-double-float-vector + element-count)) + (vector (%alloc-misc element-count + target::subtag-double-float-vector))) + (declare (fixnum element-count size-in-bytes)) + (%epushval s vector) + (%fasl-read-n-bytes s vector (- target::misc-dfloat-offset + target::misc-data-offset) + size-in-bytes) + vector)) + + + +#-x86-target +(deffaslop $fasl-code-vector (s) + (let* ((element-count (%fasl-read-count s)) + (size-in-bytes (* 4 element-count)) + (vector (allocate-typed-vector :code-vector element-count))) + (declare (fixnum element-count size-in-bytes)) + (%epushval s vector) + (%fasl-read-n-bytes s vector 0 size-in-bytes) + (%make-code-executable vector) + vector)) + +(defun fasl-read-gvector (s subtype) + (let* ((n (%fasl-read-count s)) + (vector (%alloc-misc n subtype))) + (declare (fixnum n subtype)) + (%epushval s vector) + (dotimes (i n (setf (faslstate.faslval s) vector)) + (setf (%svref vector i) (%fasl-expr s))))) + +(deffaslop $fasl-vgvec (s) + (let* ((subtype (%fasl-read-byte s))) + (fasl-read-gvector s subtype))) + +(deffaslop $fasl-ratio (s) + (let* ((r (%alloc-misc target::ratio.element-count target::subtag-ratio))) + (%epushval s r) + (setf (%svref r target::ratio.numer-cell) (%fasl-expr s) + (%svref r target::ratio.denom-cell) (%fasl-expr s)) + (setf (faslstate.faslval s) r))) + +(deffaslop $fasl-complex (s) + (let* ((c (%alloc-misc target::complex.element-count + target::subtag-complex))) + (%epushval s c) + (setf (%svref c target::complex.realpart-cell) (%fasl-expr s) + (%svref c target::complex.imagpart-cell) (%fasl-expr s)) + (setf (faslstate.faslval s) c))) + +(deffaslop $fasl-t-vector (s) + (fasl-read-gvector s target::subtag-simple-vector)) + +(deffaslop $fasl-function (s) + (fasl-read-gvector s target::subtag-function)) + +(deffaslop $fasl-istruct (s) + (fasl-read-gvector s target::subtag-istruct)) + +(deffaslop $fasl-vector-header (s) + (fasl-read-gvector s target::subtag-vectorH)) + +(deffaslop $fasl-array-header (s) + (fasl-read-gvector s target::subtag-arrayH)) + + +(deffaslop $fasl-defun (s) + (%cant-epush s) + (%defun (%fasl-expr s) (%fasl-expr s))) + +(deffaslop $fasl-macro (s) + (%cant-epush s) + (%macro (%fasl-expr s) (%fasl-expr s))) + +(deffaslop $fasl-defconstant (s) + (%cant-epush s) + (%defconstant (%fasl-expr s) (%fasl-expr s) (%fasl-expr s))) + +(deffaslop $fasl-defparameter (s) + (%cant-epush s) + (let* ((sym (%fasl-expr s)) + (val (%fasl-expr s))) + (%defvar sym (%fasl-expr s)) + (set sym val))) + +;;; (defvar var) +(deffaslop $fasl-defvar (s) + (%cant-epush s) + (%defvar (%fasl-expr s))) + +;;; (defvar var initfom doc) +(deffaslop $fasl-defvar-init (s) + (%cant-epush s) + (let* ((sym (%fasl-expr s)) + (val (%fasl-expr s))) + (unless (%defvar sym (%fasl-expr s)) + (set sym val)))) + + +(deffaslop $fasl-prog1 (s) + (let* ((val (%fasl-expr s))) + (%fasl-expr s) + (setf (faslstate.faslval s) val))) + + + +(deffaslop $fasl-src (s) + (%cant-epush s) + (let* ((source-file (%fasl-expr s))) + ; (format t "~& source-file = ~s" source-file) + (setq *loading-file-source-file* source-file))) + +(deffaslop $fasl-toplevel-location (s) + (%cant-epush s) + (setq *loading-toplevel-location* (%fasl-expr s))) + +(defvar *modules* nil) + +;;; Bootstrapping version +(defun provide (module-name) + (push (string module-name) *modules*)) + +(deffaslop $fasl-provide (s) + (provide (%fasl-expr s))) + +(deffaslop $fasl-istruct-cell (s) + (%epushval s (register-istruct-cell (%fasl-expr-preserve-epush s)))) + + + +;;; files compiled with code coverage do this +;; list of lfuns and (source-fn-name . vector-of-lfuns), the latter put there by fasloading. +(defvar *code-covered-functions* nil) + +(defun register-code-covered-functions (functions) + ;; unpack the parent-note references - see comment at fcomp-digest-code-notes + (labels ((reg (lfun refs) + (unless (memq lfun refs) + (let* ((lfv (function-to-function-vector lfun)) + (start #+ppc-target 0 #+x86-target (%function-code-words lfun)) + (refs (cons lfun refs))) + (declare (dynamic-extent refs)) + (loop for i from start below (uvsize lfv) as imm = (uvref lfv i) + do (typecase imm + (code-note + (let ((parent (code-note-parent-note imm))) + (when (integerp parent) + (setf (code-note-parent-note imm) (uvref lfv parent))))) + (function (reg imm refs)))))))) + (loop for fn across functions do (reg fn nil))) + (let ((a (assoc (pathname *loading-file-source-file*) + *code-covered-functions* + :test #'(lambda (p q) + (and (equalp (pathname-name p) (pathname-name q)) + ;; same name, so worth trying harder to match 'em up. + (or (equal p q) + (let ((p (full-pathname p)) (q (full-pathname q))) + (and p q (equalp p q))) + (let ((p (probe-file p)) (q (probe-file q))) + (and p q (equalp p q))))))))) + (when (null a) + (push (setq a (list nil nil)) *code-covered-functions*)) + (setf (car a) *loading-file-source-file* (cdr a) functions)) + nil) + +;;; The loader itself + +(defun %simple-fasl-set-file-pos (s new) + (let* ((fd (faslstate.faslfd s)) + (posoffset (fd-tell fd))) + (if (>= (decf posoffset new) 0) + (let* ((count (faslstate.bufcount s))) + (if (>= (decf count posoffset ) 0) + (progn + (setf (faslstate.bufcount s) posoffset) + (incf #+32-bit-target (%get-long (faslstate.iobuffer s)) + #+64-bit-target (%%get-signed-longlong (faslstate.iobuffer s) + 0) + count) + (return-from %simple-fasl-set-file-pos nil))))) + (progn + (setf (faslstate.bufcount s) 0) + (fd-lseek fd new #$SEEK_SET)))) + +(defun %simple-fasl-get-file-pos (s) + (- (fd-tell (faslstate.faslfd s)) (faslstate.bufcount s))) + +(defparameter *%fasload-verbose* t) + +;;; the default fasl file opener sets up the fasl state and checks the header +(defun %simple-fasl-open (string s) + (let* ((ok nil) + (fd (fd-open string #$O_RDONLY)) + (err 0)) + (declare (fixnum fd)) + (if (>= fd 0) + (if (< (fd-lseek fd 0 #$SEEK_END) 4) + (setq err $xnotfasl) + (progn + (setq err 0) + (setf (faslstate.bufcount s) 0 + (faslstate.faslfd s) fd) + (fd-lseek fd 0 #$SEEK_SET) + (multiple-value-setq (ok err) (%fasl-check-header s)))) + (setq err fd)) + (unless (eql err 0) (setf (faslstate.faslerr s) err)) + ok)) + +;;; once the fasl state is set up, this checks the fasl header and +;;; returns (values ok err) +(defun %fasl-check-header (s) + (let* ((signature (%fasl-read-word s))) + (declare (fixnum signature)) + (if (= signature $fasl-file-id) + (values t 0) + (if (= signature $fasl-file-id1) + (progn + (%fasl-set-file-pos s (%fasl-read-long s)) + (values t 0)) + (values nil $xnotfasl))))) + +(defun %simple-fasl-close (s) + (let* ((fd (faslstate.faslfd s))) + (when fd (fd-close fd)))) + +(defun %simple-fasl-init-buffer (s) + (declare (ignore s)) + nil) + +(defvar *fasl-api* nil) +(setf *fasl-api* (%istruct 'faslapi + #'%simple-fasl-open + #'%simple-fasl-close + #'%simple-fasl-init-buffer + #'%simple-fasl-set-file-pos + #'%simple-fasl-get-file-pos + #'%simple-fasl-read-buffer + #'%simple-fasl-read-byte + #'%simple-fasl-read-n-bytes)) + +(defun %fasl-open (string s) + (funcall (faslapi.fasl-open *fasl-api*) string s)) +(defun %fasl-close (s) + (funcall (faslapi.fasl-close *fasl-api*) s)) +(defun %fasl-init-buffer (s) + (funcall (faslapi.fasl-init-buffer *fasl-api*) s)) +(defun %fasl-set-file-pos (s new) + (funcall (faslapi.fasl-set-file-pos *fasl-api*) s new)) +(defun %fasl-get-file-pos (s) + (funcall (faslapi.fasl-get-file-pos *fasl-api*) s)) +(defun %fasl-read-buffer (s) + (funcall (faslapi.fasl-read-buffer *fasl-api*) s)) +(defun %fasl-read-byte (s) + (funcall (faslapi.fasl-read-byte *fasl-api*) s)) +(defun %fasl-read-n-bytes (s ivector byte-offset n) + (funcall (faslapi.fasl-read-n-bytes *fasl-api*) s ivector byte-offset n)) + +(defun %fasload (string &optional (table *fasl-dispatch-table*)) + ;;(dbg string) + (when (and *%fasload-verbose* + (not *load-verbose*)) + (%string-to-stderr ";Loading ") (pdbg string)) + (let* ((s (%istruct + 'faslstate + nil + nil + nil + nil + nil + nil + nil + nil + nil + nil + nil + nil + nil + nil))) + (declare (dynamic-extent s)) + (setf (faslstate.faslfname s) string) + (setf (faslstate.fasldispatch s) table) + (setf (faslstate.faslversion s) 0) + (%stack-block ((buffer (+ target::node-size $fasl-buf-len))) + (setf (faslstate.iobuffer s) buffer) + (%fasl-init-buffer s) + (let* ((parse-string (make-string 255 :element-type 'base-char))) + (declare (dynamic-extent parse-string)) + (setf (faslstate.oldfaslstr s) nil + (faslstate.faslstr s) parse-string) + (unwind-protect + (when (%fasl-open string s) + (let* ((nblocks (%fasl-read-word s))) + (declare (fixnum nblocks)) + (unless (= nblocks 0) + (let* ((pos (%fasl-get-file-pos s))) + (dotimes (i nblocks) + (%fasl-set-file-pos s pos) + (%fasl-set-file-pos s (%fasl-read-long s)) + (incf pos 8) + (let* ((version (%fasl-read-word s))) + (declare (fixnum version)) + (if (or (> version (+ #xff00 $fasl-vers)) + (< version (+ #xff00 $fasl-min-vers))) + (%err-disp (if (>= version #xff00) $xfaslvers $xnotfasl)) + (progn + (setf (faslstate.faslversion s) version) + (%fasl-read-word s) + (%fasl-read-word s) ; Ignore kernel version stuff + (setf (faslstate.faslevec s) nil + (faslstate.faslecnt s) 0) + (do* ((op (%fasl-read-byte s) (%fasl-read-byte s))) + ((= op $faslend)) + (declare (fixnum op)) + (%fasl-dispatch s op)))))))))) + (%fasl-close s)) + (let* ((err (faslstate.faslerr s))) + (if err + (progn + (when *%fasload-verbose* + (let* ((herald ";!!Error loading ") + (hlen (length herald)) + (len (length string)) + (msg (make-string (+ hlen len)))) + (declare (dynamic-extent msg)) + (%copy-ivector-to-ivector herald 0 msg 0 (* hlen 4)) + (%copy-ivector-to-ivector string 0 msg (* hlen 4) (* len 4)) + (bug msg))) + (values nil err)) + (values t nil))))))) + + +(defun %new-package-hashtable (size) + (%initialize-htab (cons nil (cons 0 0)) size)) + +(defun %initialize-htab (htab size) + (declare (fixnum size)) + ;; Ensure that "size" is relatively prime to all secondary hash values. + ;; If it's small enough, pick the next highest known prime out of the + ;; "primsizes" array. Otherwize, iterate through all all of "hprimes" + ;; until we find something relatively prime to all of them. + (setq size + (if (> size 32749) + (do* ((nextsize (logior 1 size) (+ nextsize 2))) + () + (declare (fixnum nextsize)) + (when (dotimes (i 8 t) + (unless (eql 1 (gcd nextsize (uvref #.$hprimes i))) + (return))) + (return nextsize))) + (dotimes (i (the fixnum (length #.$primsizes))) + (let* ((psize (uvref #.$primsizes i))) + (declare (fixnum psize)) + (if (>= psize size) + (return psize)))))) + (setf (htvec htab) (make-array size #|:initial-element 0|#)) + (setf (htcount htab) 0) + (setf (htlimit htab) (the fixnum (- size (the fixnum (ash size -3))))) + htab) + + +(defun %resize-htab (htab) + (declare (optimize (speed 3) (safety 0))) + (without-interrupts + (let* ((old-vector (htvec htab)) + (old-len (length old-vector))) + (declare (fixnum old-len) + (simple-vector old-vector)) + (let* ((nsyms 0)) + (declare (fixnum nsyms)) + (dovector (s old-vector) + (when (symbolp s) (incf nsyms))) + (%initialize-htab htab + (the fixnum (+ + (the fixnum + (+ nsyms (the fixnum (ash nsyms -2)))) + 2))) + (let* ((new-vector (htvec htab)) + (nnew 0)) + (declare (fixnum nnew) + (simple-vector new-vector)) + (dotimes (i old-len (setf (htcount htab) nnew)) + (let* ((s (svref old-vector i))) + (if (symbolp s) + (let* ((pname (symbol-name s))) + (setf (svref + new-vector + (nth-value + 2 + (%get-htab-symbol + pname + (length pname) + htab))) + s) + (incf nnew))))) + htab))))) + +(defun hash-pname (str len) + (declare (optimize (speed 3) (safety 0))) + (let* ((primary (%pname-hash str len))) + (declare (fixnum primary)) + (values primary (aref (the (simple-array (unsigned-byte 16) (8)) $hprimes) (logand primary 7))))) + + + +(defun %get-hashed-htab-symbol (str len htab primary secondary) + (declare (optimize (speed 3) (safety 0)) + (fixnum primary secondary len)) + (let* ((vec (htvec htab)) + (vlen (length vec))) + (declare (fixnum vlen)) + (do* ((idx (fast-mod primary vlen) (+ i secondary)) + (i idx (if (>= idx vlen) (- idx vlen) idx)) + (elt (svref vec i) (svref vec i))) + ((eql elt 0) (values nil nil i)) + (declare (fixnum i idx)) + (when (symbolp elt) + (let* ((pname (symbol-name elt))) + (if (and + (= (the fixnum (length pname)) len) + (dotimes (j len t) + (unless (eq (aref str j) (schar pname j)) + (return)))) + (return (values t (%symptr->symbol elt) i)))))))) + +(defun %get-htab-symbol (string len htab) + (declare (optimize (speed 3) (safety 0))) + (multiple-value-bind (p s) (hash-pname string len) + (%get-hashed-htab-symbol string len htab p s))) + +(defun %find-symbol (string len package) + (declare (optimize (speed 3) (safety 0))) + (multiple-value-bind (found-p sym internal-offset) + (%get-htab-symbol string len (pkg.itab package)) + (if found-p + (values sym :internal internal-offset nil) + (multiple-value-bind (found-p sym external-offset) + (%get-htab-symbol string len (pkg.etab package)) + (if found-p + (values sym :external internal-offset external-offset) + (dolist (p (pkg.used package) (values nil nil internal-offset external-offset)) + (multiple-value-bind (found-p sym) + (%get-htab-symbol string len (pkg.etab p)) + (when found-p + (return (values sym :inherited internal-offset external-offset)))))))))) + +(defun %htab-add-symbol (symbol htab idx) + (declare (optimize (speed 3) (safety 0))) + (setf (svref (htvec htab) idx) (%symbol->symptr symbol)) + (if (>= (incf (the fixnum (htcount htab))) + (the fixnum (htlimit htab))) + (%resize-htab htab)) + symbol) + +(defun %set-symbol-package (symbol package-or-nil) + (declare (optimize (speed 3) (safety 0))) + (let* ((symvec (symptr->symvector (%symbol->symptr symbol))) + (old-pp (%svref symvec target::symbol.package-predicate-cell))) + (if (consp old-pp) + (setf (car old-pp) package-or-nil) + (setf (%svref symvec target::symbol.package-predicate-cell) package-or-nil)))) + + +(let* ((force-export-packages (list *keyword-package*)) + (force-export-packages-lock (make-lock))) + (defun force-export-packages () + (with-lock-grabbed (force-export-packages-lock) + (copy-list force-export-packages))) + (defun package-force-export (p) + (let* ((pkg (pkg-arg p))) + (with-lock-grabbed (force-export-packages-lock) + (pushnew pkg force-export-packages)) + pkg)) + (defun force-export-package-p (pkg) + (with-lock-grabbed (force-export-packages-lock) + (if (memq pkg force-export-packages) + t)))) + + +(defun %insert-symbol (symbol package internal-idx external-idx &optional force-export) + (let* ((symvec (symptr->symvector (%symbol->symptr symbol))) + (package-predicate (%svref symvec target::symbol.package-predicate-cell)) + (keyword-package (eq package *keyword-package*))) + ;; Set home package + (if package-predicate + (if (listp package-predicate) + (unless (%car package-predicate) (%rplaca package-predicate package))) + (setf (%svref symvec target::symbol.package-predicate-cell) package)) + (if (or force-export (force-export-package-p package)) + (progn + (%htab-add-symbol symbol (pkg.etab package) external-idx) + (if keyword-package + ;;(define-constant symbol symbol) + (progn + (%set-sym-global-value symbol symbol) + (%symbol-bits symbol + (logior (ash 1 $sym_vbit_special) + (ash 1 $sym_vbit_const) + (the fixnum (%symbol-bits symbol))))))) + (%htab-add-symbol symbol (pkg.itab package) internal-idx)) + (let* ((hook (pkg.intern-hook package))) + (when hook (funcall hook symbol))) + symbol)) + +;;; PNAME must be a simple string! +(defun %add-symbol (pname package internal-idx external-idx &optional force-export) + (let* ((sym (make-symbol pname))) + (%insert-symbol sym package internal-idx external-idx force-export))) + + + + +;;; The initial %toplevel-function% sets %toplevel-function% to NIL; +;;; if the %fasload call fails, the lisp should exit (instead of +;;; repeating the process endlessly ... + + +(defvar %toplevel-function% + #'(lambda () + (declare (special *xload-cold-load-functions* + *xload-cold-load-documentation* + *xload-startup-file* + *early-class-cells*)) + (%set-tcr-toplevel-function (%current-tcr) nil) ; should get reset by l1-boot. + (setq %system-locks% (%cons-population nil)) + ;; Need to make %ALL-PACKAGES-LOCK% early, so that we can casually + ;; do SET-PACKAGE in cold load functions. + (setq %all-packages-lock% (make-read-write-lock)) + (dolist (f (prog1 *xload-cold-load-functions* (setq *xload-cold-load-functions* nil))) + (funcall f)) + (dolist (pair (prog1 *early-class-cells* (setq *early-class-cells* nil))) + (setf (gethash (car pair) %find-classes%) (cdr pair))) + (dolist (p %all-packages%) + (%resize-htab (pkg.itab p)) + (%resize-htab (pkg.etab p))) + (dolist (f (prog1 *xload-cold-load-documentation* (setq *xload-cold-load-documentation* nil))) + (apply 'set-documentation f)) + ;; Can't bind any specials until this happens + (let* ((max 0)) + (%map-areas #'(lambda (symvec) + (when (= (the fixnum (typecode symvec)) + target::subtag-symbol) + (let* ((s (symvector->symptr symvec)) + (idx (symbol-binding-index s))) + (when (> idx 0) + (cold-load-binding-index s)) + (when (> idx max) + (setq max idx)))))) + (%set-binding-index max)) + (%fasload *xload-startup-file*))) + Index: /branches/new-random/level-1/.cvsignore =================================================================== --- /branches/new-random/level-1/.cvsignore (revision 13309) +++ /branches/new-random/level-1/.cvsignore (revision 13309) @@ -0,0 +1,1 @@ +*~.* Index: /branches/new-random/level-1/l1-application.lisp =================================================================== --- /branches/new-random/level-1/l1-application.lisp (revision 13309) +++ /branches/new-random/level-1/l1-application.lisp (revision 13309) @@ -0,0 +1,314 @@ +;;;-*-Mode: LISP; Package: CCL -*- +;;; +;;; Copyright (C) 1994-2001 Digitool, Inc +;;; Portions Copyright (C) 2001-2009, Clozure Associates +;;; This file is part of Clozure CL. +;;; +;;; Clozure CL is licensed under the terms of the Lisp Lesser GNU Public +;;; License , known as the LLGPL and distributed with Clozure CL as the +;;; file "LICENSE". The LLGPL consists of a preamble and the LGPL, +;;; which is distributed with Clozure CL as the file "LGPL". Where these +;;; conflict, the preamble takes precedence. +;;; +;;; Clozure CL is referenced in the preamble as the "LIBRARY." +;;; +;;; The LLGPL is also available online at +;;; http://opensource.franz.com/preamble.html + +(in-package "CCL") + +;; Application classes + +(defstruct command-line-argument + keyword + help-string + option-char + long-name + may-take-operand + allow-multiple ; option can appear multiple times +) + +(defvar *standard-help-argument* + (make-command-line-argument + :keyword :help + :help-string "this text" + :option-char #\h + :long-name "help")) + +(defvar *standard-version-argument* + (make-command-line-argument + :keyword :version + :help-string "print (LISP-IMPLEMENTATION-VERSION) and exit" + :option-char #\V + :long-name "version")) + +(defvar *standard-terminal-encoding-argument* + (make-command-line-argument + :option-char #\K + :long-name "terminal-encoding" + :help-string "specify character encoding to use for *TERMINAL-IO*" + :may-take-operand t + :keyword :terminal-encoding + :allow-multiple nil)) + +(defclass application () + ((command-line-arguments + :initform + (list *standard-help-argument* *standard-version-argument*)) + (ui-object :initform nil :initarg :ui-object :accessor application-ui-object))) + +(defclass ui-object () + ()) + +;;; It's intended that this be specialized ... +(defmethod ui-object-do-operation ((u ui-object) operation &rest args) + (declare (ignore operation args))) + + +(defun %usage-exit (banner exit-status other-args) + (with-cstrs ((banner banner) + (other-args other-args)) + (ff-call (%kernel-import target::kernel-import-usage-exit) + :address banner + :signed-fullword exit-status + :address other-args + :void))) + +(defloadvar *unprocessed-command-line-arguments* ()) + +;;; Returns four values: error-flag, options-alist, non-option-arguments, unprocessed arguments +(defmethod parse-application-arguments ((a application)) + (let* ((cla (slot-value a 'command-line-arguments)) + (vals (cdr *command-line-argument-list*)) + (options ()) + (non-options ()) + (rest-arg nil)) + (do* () + ((null vals) + (values nil (nreverse options) (nreverse non-options) rest-arg)) + (let* ((val (pop vals)) + (val-len (length val)) + (short-p nil) + (option + (if (and (>= val-len 2) + (eql (schar val 0) #\-)) + (if (eql (schar val 1) #\-) + (find val cla + :key #'command-line-argument-long-name + :test #'(lambda (k v) (string= k v :start1 2))) + (progn + (setq short-p t) + (find (schar val 1) cla + :key #'command-line-argument-option-char)))))) + (if (null option) + (if (and (>= val-len 1) + (eql (schar val 0) #\-)) + (if (and (= val-len 2) + (eql (schar val 1) #\-)) + (setq rest-arg vals + vals nil) + (return (values :unknown-option val nil nil))) + (push val non-options)) ;non-option argument + ;; We recognized the option. Is it a duplicate of + ;; something already seen? + (let* ((key (command-line-argument-keyword option)) + (operand nil)) + (when (and (assoc key options) + (not (command-line-argument-allow-multiple option))) + (return (values :duplicate-option val nil))) + (when (command-line-argument-may-take-operand option) + ;; A short option name can be followed by the operand, + ;; without intervening whitespace. + (if (and short-p (> val-len 2)) + (setq operand (subseq val 2)) + (if vals + (setq operand (pop vals)) + (return (values :missing-operand val nil))))) + (push (cons key operand) options))))))) + +(defmethod summarize-option-syntax ((a application)) + (flet ((summarize-option (o) + (format nil "~8t-~a, --~a : ~a~%" + (command-line-argument-option-char o) + (command-line-argument-long-name o) + (command-line-argument-help-string o)))) + (format nil "~{~a~}" (mapcar #'summarize-option + (slot-value a 'command-line-arguments))))) + + +;;; Process the "help" and "version" options, report parsing errors. +(defmethod process-application-arguments ((a application) error-flag opts args) + (declare (ignore args)) + (if (null error-flag) + (if (assoc :help opts) + (%usage-exit "" 0 (summarize-option-syntax a)) + (if (assoc :version opts) + ;; Can't use lisp streams yet. + (progn + (with-cstrs ((s (format nil "~&~a~&" (application-version-string a)))) + (fd-write 1 s (%cstrlen s))) + (#_ _exit 0)) + (let* ((encoding (assoc :terminal-encoding opts))) + (when (cdr encoding) + (let* ((encoding-name + (let* ((*package* (find-package "KEYWORD"))) + (ignore-errors (read-from-string (cdr encoding)))))) + (when encoding-name + (let* ((character-encoding (lookup-character-encoding encoding-name))) + (when character-encoding + (setq *terminal-character-encoding-name* + (character-encoding-name character-encoding)))))))))) + (%usage-exit + (format nil + (case error-flag + (:missing-argument "Missing argument to ~a option") + (:duplicate-argument "Duplicate ~a option") + (:unknown-option "Unknown option: ~a") + (t "~a")) + opts) + #-windows-target #$EX_USAGE #+windows-target #$EXIT_FAILURE + (summarize-option-syntax a)))) + + +;;; an example method to base a specialization on +(defmethod toplevel-function ((a application) init-file) + (declare (ignore init-file)) + nil ) + +(defmethod toplevel-function :before ((a application) init-file) + (declare (ignore init-file)) + (multiple-value-bind (error-flag options args rest-arg) + (parse-application-arguments a) + (setq *unprocessed-command-line-arguments* rest-arg) + (process-application-arguments a error-flag options args) + (let* ((encoding (lookup-character-encoding *terminal-character-encoding-name*))) + (when encoding + (set-terminal-encoding (character-encoding-name encoding)))))) + +(defmethod repl-function-name ((a application)) + "Return the name of a function that should be run in a TTY-like +listener thread (if that concept makes sense); return NIL otherwise." + nil) + +(defmethod application-version-string ((a application)) + "Return a string which (arbitrarily) represents the application version. +Default version returns Clozure CL version info." + (lisp-implementation-version)) + +(defmethod application-ui-operation ((a application) operation &rest args) + (let* ((ui-object (application-ui-object a))) + (when ui-object + (apply #'ui-object-do-operation ui-object operation args)))) + + + + +(defmethod application-init-file ((app application)) nil) + + +(defclass lisp-development-system (application) + ((command-line-arguments + :initform + (list *standard-help-argument* + *standard-version-argument* + *standard-terminal-encoding-argument* + (make-command-line-argument + :option-char #\n + :long-name "no-init" + :keyword :noinit + :help-string "suppress loading of init file") + (make-command-line-argument + :option-char #\e + :long-name "eval" + :keyword :eval + :help-string "evaluate (may need to quote in shell)" + :may-take-operand t + :allow-multiple t) + (make-command-line-argument + :option-char #\l + :long-name "load" + :keyword :load + :help-string "load " + :may-take-operand t + :allow-multiple t) + (make-command-line-argument + :option-char #\T + :long-name "set-lisp-heap-gc-threshold" + :help-string "set lisp-heap-gc-threshold to " + :keyword :gc-threshold + :may-take-operand t + :allow-multiple nil) + (make-command-line-argument + :option-char #\Q + :long-name "quiet" + :help-string "if --batch, also suppress printing of heralds, prompts" + :keyword :quiet + :may-take-operand nil + :allow-multiple nil) + )) + (initial-listener-process :initform nil))) + +(defparameter *application* + (make-instance 'lisp-development-system)) + +(defvar *load-lisp-init-file* t) +(defvar *lisp-startup-parameters* ()) + +(defmethod process-application-arguments ((a lisp-development-system) + error-flag options args) + (declare (ignorable error-flag)) + (call-next-method) ; handle help, errors + (if args + (%usage-exit (format nil "Unrecognized non-option arguments: ~a" args) + #-windows-target #$EX_USAGE #+windows-target #$EXIT_FAILURE + (summarize-option-syntax a)) + (progn + (setq *load-lisp-init-file* (not (assoc :noinit options)) + *quiet-flag* (if *batch-flag* + (not (null (assoc :quiet options)))) + *lisp-startup-parameters* + (mapcan #'(lambda (x) + (and (member (car x) '(:load :eval :gc-threshold)) (list x))) + options))))) + + +(defmethod repl-function-name ((a lisp-development-system)) + 'listener-function) + +(defmethod toplevel-function ((a lisp-development-system) init-file) + (let* ((sr (input-stream-shared-resource *terminal-input*)) + (f (or (repl-function-name a) 'listener-function))) + (with-slots (initial-listener-process) a + (setq initial-listener-process + (make-mcl-listener-process + "listener" + *terminal-input* + *terminal-output* + #'(lambda () (when sr (setf (shared-resource-primary-owner sr) + *initial-process*))) + :initial-function + #'(lambda () + (startup-ccl (and *load-lisp-init-file* init-file)) + (funcall f) + nil) + :close-streams nil + :control-stack-size *initial-listener-default-control-stack-size* + :value-stack-size *initial-listener-default-value-stack-size* + :temp-stack-size *initial-listener-default-temp-stack-size* + :class 'tty-listener + :process initial-listener-process)))) + (%set-toplevel #'housekeeping-loop) + (toplevel)) + +(defun housekeeping-loop () + (with-standard-abort-handling nil + (loop + #+windows-target (#_SleepEx 333 #$true) + #-windows-target (%nanosleep *periodic-task-seconds* *periodic-task-nanoseconds*) + (housekeeping)))) + + +(defmethod application-init-file ((app lisp-development-system)) + ;; This is the init file loaded before cocoa. + #+unix '("home:ccl-init" "home:\\.ccl-init") + #+windows "home:ccl-init") Index: /branches/new-random/level-1/l1-aprims.lisp =================================================================== --- /branches/new-random/level-1/l1-aprims.lisp (revision 13309) +++ /branches/new-random/level-1/l1-aprims.lisp (revision 13309) @@ -0,0 +1,3636 @@ +;;;-*-Mode: LISP; Package: CCL -*- +;;; +;;; Copyright (C) 2009 Clozure Associates +;;; Copyright (C) 1994-2001 Digitool, Inc +;;; This file is part of Clozure CL. +;;; +;;; Clozure CL is licensed under the terms of the Lisp Lesser GNU Public +;;; License , known as the LLGPL and distributed with Clozure CL as the +;;; file "LICENSE". The LLGPL consists of a preamble and the LGPL, +;;; which is distributed with Clozure CL as the file "LGPL". Where these +;;; conflict, the preamble takes precedence. +;;; +;;; Clozure CL is referenced in the preamble as the "LIBRARY." +;;; +;;; The LLGPL is also available online at +;;; http://opensource.franz.com/preamble.html + +;; L1-aprims.lisp + + +(in-package "CCL") + + +(let* ((standard-initial-bindings ()) + (standard-initial-bindings-lock (make-read-write-lock))) + + (defun standard-initial-bindings () + (with-read-lock (standard-initial-bindings-lock) + (copy-list standard-initial-bindings))) + + (defun define-standard-initial-binding (symbol initform) + (setq symbol (require-type symbol 'symbol)) + (%proclaim-special symbol) + (unless (boundp symbol) + (set symbol (funcall initform))) + (with-write-lock (standard-initial-bindings-lock) + (let* ((pair (assoc symbol standard-initial-bindings))) + (if pair + (setf (cdr pair) initform) + (push (cons symbol initform) standard-initial-bindings)))) + (record-source-file symbol 'variable) + symbol)) + +(defstatic *kernel-tcr-area-lock* (%make-lock (%null-ptr) "Kernel tcr-area-lock")) + +(defstatic *kernel-exception-lock* (%make-lock (%null-ptr) "Kernel exception-lock")) + +(def-ccl-pointers kernel-locks () + (let* ((p (recursive-lock-ptr *kernel-tcr-area-lock*)) + (q (recursive-lock-ptr *kernel-exception-lock*))) + (%revive-macptr p) + (%revive-macptr q) + (%get-kernel-global-ptr area-lock p) + (%get-kernel-global-ptr exception-lock q))) + +(def-standard-initial-binding *package*) +(def-standard-initial-binding *gensym-counter* 0) +(def-standard-initial-binding *random-state* (initialize-random-state #xFBF1 9)) +(def-standard-initial-binding *whostate* "Reset") +(setq *whostate* "Reset") +(def-standard-initial-binding *error-print-length* 20) +(def-standard-initial-binding *error-print-level* 8) + +(defun %badarg (arg type) + (%err-disp $XWRONGTYPE arg type)) + +(defun atom (arg) + "Return true if OBJECT is an ATOM, and NIL otherwise." + (not (consp arg))) + +(defun list (&rest args) + "Return constructs and returns a list of its arguments." + args) + +(%fhave '%temp-list #'list) + +(defun list* (arg &rest others) + "Return a list of the arguments with last cons a dotted pair" + (cond ((null others) arg) + ((null (cdr others)) (cons arg (car others))) + (t (do ((x others (cdr x))) + ((null (cddr x)) (rplacd x (cadr x)))) + (cons arg others)))) + + + +(defun funcall (fn &rest args) + "Call FUNCTION with the given ARGUMENTS." + (declare (dynamic-extent args)) + (apply fn args)) + + +(defun apply (function arg &rest args) + "Apply FUNCTION to a list of arguments produced by evaluating ARGUMENTS in + the manner of LIST*. That is, a list is made of the values of all but the + last argument, appended to the value of the last argument, which must be a + list." + (declare (dynamic-extent args)) + (cond ((null args) + (apply function arg)) + ((null (cdr args)) + (apply function arg (car args))) + (t (do* ((a1 args a2) + (a2 (cdr args) (cdr a2))) + ((atom (cdr a2)) + (rplacd a1 (car a2)) + (apply function arg args)))))) + + +;;; This is not fast, but it gets the functionality that +;;; Wood and possibly other code depend on. +(defun applyv (function arg &rest other-args) + (declare (dynamic-extent other-args)) + (let* ((other-args (cons arg other-args)) + (last-arg (car (last other-args))) + (last-arg-length (length last-arg)) + (butlast-args (nbutlast other-args)) + (rest-args (make-list last-arg-length)) + (rest-args-tail rest-args)) + (declare (dynamic-extent other-args rest-args)) + (dotimes (i last-arg-length) + (setf (car rest-args-tail) (aref last-arg i)) + (pop rest-args-tail)) + (apply function (nconc butlast-args rest-args)))) + +;;; This is slow, and since %apply-lexpr isn't documented either, +;;; nothing in the world should depend on it. This is just being +;;; anal retentive. VERY anal retentive. + +(defun %apply-lexpr (function arg &rest args) + (cond ((null args) (%apply-lexpr function arg)) + (t (apply function arg (nconc (nbutlast args) + (collect-lexpr-args (car (last args)) 0)))))) + + +(defun values-list (arg) + "Return all of the elements of LIST, in order, as values." + (apply #'values arg)) + + + + + + +; copy-list + +(defun copy-list (list) + "Return a new list which is EQUAL to LIST." + (if list + (let ((result (cons (car list) '()) )) + (do ((x (cdr list) (cdr x)) + (splice result + (%cdr (%rplacd splice (cons (%car x) '() ))) )) + ((atom x) (unless (null x) + (%rplacd splice x)) result))))) + +(defun alt-list-length (l) + "Detect (and complain about) cirucular lists; allow any atom to +terminate the list" + (do* ((n 0 (1+ n)) + (fast l) + (slow l)) + ((atom fast) n) + (declare (fixnum n)) + (setq fast (cdr fast)) + (if (logbitp 0 n) + (if (eq (setq slow (cdr slow)) fast) + (%err-disp $XIMPROPERLIST l))))) + + +(defun last (list &optional (n 1)) + "Return the last N conses (not the last element!) of a list." + (if (and (typep n 'fixnum) + (>= (the fixnum n) 0)) + (locally (declare (fixnum n)) + (do* ((checked-list list (cdr checked-list)) + (returned-list list) + (index 0 (1+ index))) + ((atom checked-list) returned-list) + (declare (type fixnum index)) + (if (>= index n) + (pop returned-list)))) + (if (and (typep n 'bignum) + (> n 0)) + (require-type list 'list) + (report-bad-arg n 'unsigned-byte)))) + + + + + +(defun nthcdr (index list) + "Performs the cdr function n times on a list." + (setq list (require-type list 'list)) + (if (and (typep index 'fixnum) + (>= (the fixnum index) 0)) + (locally (declare (fixnum index)) + (dotimes (i index list) + (when (null (setq list (cdr list))) (return)))) + (progn + (unless (typep index 'unsigned-byte) + (report-bad-arg index 'unsigned-byte)) + (do* ((n index (- n target::target-most-positive-fixnum))) + ((typep n 'fixnum) (nthcdr n list)) + (unless (setq list (nthcdr target::target-most-positive-fixnum list)) + (return)))))) + + +(defun nth (index list) + "Return the nth object in a list where the car is the zero-th element." + (car (nthcdr index list))) + + +(defun nconc (&rest lists) + (declare (dynamic-extent lists)) + "Concatenates the lists given as arguments (by changing them)" + (do* ((top lists (cdr top))) + ((null top) nil) + (let* ((top-of-top (car top))) + (cond + ((consp top-of-top) + (let* ((result top-of-top) + (splice result)) + (do* ((elements (cdr top) (cdr elements))) + ((endp elements)) + (let ((ele (car elements))) + (typecase ele + (cons (rplacd (last splice) ele) + (setf splice ele)) + (null (rplacd (last splice) nil)) + (atom (if (cdr elements) + (report-bad-arg ele 'list) + (rplacd (last splice) ele))) + (t (report-bad-arg ele 'list))))) + (return result))) + ((null top-of-top) nil) + (t + (if (cdr top) + (report-bad-arg top-of-top 'list) + (return top-of-top))))))) + + +(defvar %setf-function-names% (make-hash-table :weak t :test 'eq)) +(defvar %setf-function-name-inverses% (make-hash-table :weak t :test 'eq)) + +(defun setf-function-name (sym) + "Returns the symbol in the SETF package that holds the binding of (SETF sym)" + (or (gethash sym %setf-function-names%) + (progn + (let* ((setf-package-sym (construct-setf-function-name sym))) + (setf (gethash setf-package-sym %setf-function-name-inverses%) sym + (gethash sym %setf-function-names%) setf-package-sym))))) + +(defun existing-setf-function-name (sym) + (gethash sym %setf-function-names%)) + +(defun maybe-setf-name (sym) + (let* ((other (gethash sym %setf-function-name-inverses%))) + (if other + `(setf ,other) + sym))) + + + +(defconstant *setf-package* (or (find-package "SETF") (make-package "SETF" :use nil :external-size 1))) + +(defun construct-setf-function-name (sym) + (let ((pkg (symbol-package sym))) + (setq sym (symbol-name sym)) + (if (null pkg) + (gentemp sym *setf-package*) + (values + (intern + ;;I wonder, if we didn't check, would anybody report it as a bug? + (if (not (%str-member #\: (setq pkg (package-name pkg)))) + (%str-cat pkg "::" sym) + (%str-cat (prin1-to-string pkg) "::" (princ-to-string sym))) + *setf-package*))))) + +(defun setf-function-name-p (name) + (and (consp name) + (consp (%cdr name)) + (null (%cddr name)) + (symbolp (%cadr name)) + (eq (car name) 'setf))) + +(defun valid-function-name-p (name) + (if (symbolp name) ; Nil is a valid function name. I guess. + (values t name) + (if (setf-function-name-p name) + (values t (setf-function-name (%cadr name))) + ; What other kinds of function names do we care to support ? + (values nil nil)))) + +;;; Why isn't this somewhere else ? +(defun ensure-valid-function-name (name) + (multiple-value-bind (valid-p nm) (valid-function-name-p name) + (if valid-p nm (error "Invalid function name ~s." name)))) + + +(defun maybe-setf-function-name (name) + (if (setf-function-name-p name) + (setf-function-name (cadr name)) + name)) + + +;;; Returns index if char appears in string, else nil. + +(defun %str-member (char string &optional start end) + (let* ((base-string-p (typep string 'simple-base-string))) + (unless base-string-p + (setq string (require-type string 'simple-string))) + (unless (characterp char) + (setq char (require-type char 'character))) + (do* ((i (or start 0) (1+ i)) + (n (or end (uvsize string)))) + ((= i n)) + (declare (fixnum i n) (optimize (speed 3) (safety 0))) + (if (eq (schar (the simple-base-string string) i) char) + (return i))))) + + + +;;; Returns index of elt in vector, or nil if it's not there. +(defun %vector-member (elt vector) + (unless (typep vector 'simple-vector) + (report-bad-arg vector 'simple-vector)) + (dotimes (i (the fixnum (length vector))) + (when (eq elt (%svref vector i)) (return i)))) + +(defun logical-pathname-p (thing) (istruct-typep thing 'logical-pathname)) + +(progn +;;; It's back ... +(defun list-nreverse (list) + (nreconc list nil)) + +;;; We probably want to make this smarter so that less boxing +;;; (and bignum/double-float consing!) takes place. + +(defun vector-nreverse (v) + (let* ((len (length v)) + (middle (ash (the fixnum len) -1))) + (declare (fixnum middle len)) + (do* ((left 0 (1+ left)) + (right (1- len) (1- right))) + ((= left middle) v) + (declare (fixnum left right)) + (rotatef (aref v left) (aref v right))))) + +(defun nreverse (seq) + "Return a sequence of the same elements in reverse order; the argument + is destroyed." + (when seq + (seq-dispatch seq + (list-nreverse seq) + (vector-nreverse seq))))) + +(defun nreconc (x y) + "Return (NCONC (NREVERSE X) Y)." + (do ((1st (cdr x) (if (endp 1st) 1st (cdr 1st))) + (2nd x 1st) ;2nd follows first down the list. + (3rd y 2nd)) ;3rd follows 2nd down the list. + ((atom 2nd) 3rd) + (rplacd 2nd 3rd))) + +;;; The two-arg case is maybe a bit faster. We -don't- want to +;;; do the two-arg case repeatedly to implement the N-arg case. +(defun append (&rest lists) + (declare (dynamic-extent lists)) + "Construct a new list by concatenating the list arguments" + (if lists + (let* ((head (cons nil nil)) + (tail head)) + (declare (dynamic-extent head) + (cons head tail)) + (do* () + ((null lists) (cdr head)) + (let* ((list (pop lists))) + (if (null lists) + (rplacd tail list) + (dolist (element list) + (setq tail (cdr (rplacd tail (cons element nil))))))))))) + + + + + + + + + + + +(progn +(defun list-reverse (l) + (do* ((new ())) + ((null l) new) + (push (pop l) new))) + +; Again, it's worth putting more work into this when the dust settles. +(defun vector-reverse (v) + (let* ((len (length v)) + (new (make-array (the fixnum len) :element-type (array-element-type v)))) ; a LOT more work ... + (declare (fixnum len)) + (do* ((left 0 (1+ left)) + (right (1- len) (1- right))) + ((= left len) new) + (declare (fixnum left right)) + (setf (uvref new left) + (aref v right))))) + +(defun reverse (seq) + "Return a new sequence containing the same elements but in reverse order." + (seq-dispatch seq (list-reverse seq) (vector-reverse seq))) +) + + +(defun check-sequence-bounds (seq start end) + (flet ((bad-sequence-interval (seq start end) + (unless (typep start 'unsigned-byte) + (report-bad-arg start 'unsigned-byte)) + (if (and end (not (typep end 'unsigned-byte))) + (report-bad-arg end '(or null unsigned-byte))) + (error "Bad interval for sequence operation on ~s : start = ~s, end = ~s" seq start end))) + (let* ((length (length seq))) + (declare (fixnum length)) + (if (and (typep start 'fixnum) + (<= 0 (the fixnum start)) + (if (null end) + (<= (the fixnum start) (the fixnum (setq end length))) + (and (typep end 'fixnum) + (<= (the fixnum start) (the fixnum end)) + (<= (the fixnum end) (the fixnum length))))) + + end + (bad-sequence-interval seq start end))))) + + + +(defun byte-length (string &optional (start 0) end) + (setq end (check-sequence-bounds string start end)) + (- end start)) + + + +(defun make-cstring (string) + (let* ((len (length string))) + (declare (fixnum len)) + (let* ((s (malloc (the fixnum (1+ len))))) + (setf (%get-byte s len) 0) + (multiple-value-bind (data offset) (array-data-and-offset string) + (dotimes (i len s) + (setf (%get-unsigned-byte s i) (%scharcode data (+ offset i)))) + s)))) + +(defun move-string-bytes (source dest off1 off2 n) + (declare (fixnum off1 off2 n) + (simple-base-string source dest) + (optimize (speed 3) (safety 0))) + (dotimes (i n dest) + (setf (schar dest off2) (schar source off1)) + (incf off1) + (incf off2))) + + +(defun %str-cat (s1 s2 &rest more) + (declare (dynamic-extent more)) + (require-type s1 'simple-string) + (require-type s2 'simple-string) + (let* ((len1 (length s1)) + (len2 (length s2)) + (len (%i+ len2 len1))) + (declare (optimize (speed 3)(safety 0))) + (dolist (s more) + (require-type s 'simple-string) + (setq len (+ len (length s)))) + (let ((new-string (make-string len :element-type 'base-char))) + (move-string-bytes s1 new-string 0 0 len1) + (move-string-bytes s2 new-string 0 len1 len2) + (dolist (s more) + (setq len2 (%i+ len1 len2)) + (move-string-bytes s new-string 0 len2 (setq len1 (length s)))) + new-string))) + + +(defun %substr (str start end) + (require-type start 'fixnum) + (require-type end 'fixnum) + (require-type str 'string) + (let ((len (length str))) + (multiple-value-bind (str strb)(array-data-and-offset str) + (let ((newlen (%i- end start))) + (when (%i> end len)(error "End ~S exceeds length ~S." end len)) + (when (%i< start 0)(error "Negative start")) + (let ((new (make-string newlen))) + (do* ((i 0 (1+ i)) + (pos (%i+ start strb) (1+ pos))) + ((= i newlen) new) + (declare (fixnum i pos)) + (setf (schar new i) (schar str pos)))))))) + + + +;;; 3 callers +(defun %list-to-uvector (subtype list) ; subtype may be nil (meaning simple-vector + (let* ((n (length list)) + (new (%alloc-misc n (or subtype target::subtag-simple-vector)))) ; yech + (dotimes (i n) + (declare (fixnum i)) + (uvset new i (%car list)) + (setq list (%cdr list))) + new)) + + +; appears to be unused +(defun upgraded-array-element-type (type &optional env) + "Return the element type that will actually be used to implement an array + with the specifier :ELEMENT-TYPE Spec." + (declare (ignore env)) + (element-subtype-type (element-type-subtype type))) + +(defun upgraded-complex-part-type (type &optional env) + (declare (ignore env)) + (declare (ignore type)) ; Ok, ok. So (upgraded-complex-part-type 'bogus) is 'REAL. So ? + 'real) + + +#+ppc32-target +(progn + (defparameter array-element-subtypes + #(single-float + (unsigned-byte 32) + (signed-byte 32) + fixnum + base-char ;ucs4 + (unsigned-byte 8) + (signed-byte 8) + base-char + (unsigned-byte 16) + (signed-byte 16) + double-float + bit)) + + ;; given uvector subtype - what is the corresponding element-type + (defun element-subtype-type (subtype) + (declare (fixnum subtype)) + (if (= subtype ppc32::subtag-simple-vector) t + (svref array-element-subtypes + (ash (- subtype ppc32::min-cl-ivector-subtag) (- ppc32::ntagbits))))) + ) + +#+x8632-target +(progn + (defparameter array-element-subtypes + #(single-float + (unsigned-byte 32) + (signed-byte 32) + fixnum + base-char ;ucs4 + (unsigned-byte 8) + (signed-byte 8) + base-char + (unsigned-byte 16) + (signed-byte 16) + double-float + bit)) + + ;; given uvector subtype - what is the corresponding element-type + (defun element-subtype-type (subtype) + (declare (fixnum subtype)) + (if (= subtype x8632::subtag-simple-vector) t + (svref array-element-subtypes + (ash (- subtype x8632::min-cl-ivector-subtag) (- x8632::ntagbits))))) + ) + +#+ppc64-target +(progn + +(defparameter array-element-subtypes + #(bogus + bogus + bogus + bogus + (signed-byte 8) + (signed-byte 16) + (signed-byte 32) + (signed-byte 64) + (unsigned-byte 8) + (unsigned-byte 16) + (unsigned-byte 32) + (unsigned-byte 64) + bogus + bogus + single-float + fixnum + bogus + bogus + bogus + double-float + bogus + bogus + base-char + bogus + bogus + bogus + bogus + bogus + bogus + bit + bogus + bogus)) + + + ;;; given uvector subtype - what is the corresponding element-type + (defun element-subtype-type (subtype) + (declare (fixnum subtype)) + (if (= subtype ppc64::subtag-simple-vector) + t + (svref array-element-subtypes + (ash (- subtype 128) -2)))) + ) + +#+x8664-target +(progn + + ;;; 1, 8, 16-bit element types + (defparameter *immheader-0-array-element-types* + #(bogus + bogus + bogus + bogus + bogus + bogus + bogus + bogus + bogus + bogus + (signed-byte 16) + (unsigned-byte 16) + base-char + (signed-byte 8) + (unsigned-byte 8) + bit)) + + ;;; 32-bit element types + (defparameter *immheader-1-array-element-types* + #(bogus + bogus + bogus + bogus + bogus + bogus + bogus + bogus + bogus + bogus + bogus + bogus + base-char + (signed-byte 32) + (unsigned-byte 32) + single-float)) + + ;;; 64-bit element types + (defparameter *immheader-2-array-element-types* + #(bogus + bogus + bogus + bogus + bogus + bogus + bogus + bogus + bogus + bogus + bogus + bogus + fixnum + (signed-byte 64) + (unsigned-byte 64) + double-float)) + + + (defun element-subtype-type (subtype) + (declare (type (unsigned-byte 8) subtype)) + (if (= subtype x8664::subtag-simple-vector) + t + (let* ((class (ash subtype (- x8664::ntagbits))) + (tag (logand subtype x8664::fulltagmask))) + (declare (type (unsigned-byte 4) class tag)) + (cond ((= tag x8664::fulltag-immheader-0) + (%svref *immheader-0-array-element-types* class)) + ((= tag x8664::fulltag-immheader-1) + (%svref *immheader-1-array-element-types* class)) + ((= tag x8664::fulltag-immheader-2) + (%svref *immheader-2-array-element-types* class)) + (t 'bogus))))) + ) + + +;;; %make-displaced-array assumes the following + +(eval-when (:compile-toplevel) + (assert (eql target::arrayH.flags-cell target::vectorH.flags-cell)) + (assert (eql target::arrayH.displacement-cell target::vectorH.displacement-cell)) + (assert (eql target::arrayH.data-vector-cell target::vectorH.data-vector-cell))) + + +(defun %make-displaced-array (dimensions displaced-to + &optional fill adjustable + offset explicitp) + (if offset + (unless (and (fixnump offset) (>= (the fixnum offset) 0)) + (setq offset (require-type offset '(and fixnum (integer 0 *))))) + (setq offset 0)) + (locally (declare (fixnum offset)) + (let* ((disp-size (array-total-size displaced-to)) + (rank (if (listp dimensions)(length dimensions) 1)) + (new-size (if (fixnump dimensions) + dimensions + (if (listp dimensions) + (if (eql rank 1) + (car dimensions) + (if (eql rank 0) 1 ; why not 0? + (apply #'* dimensions)))))) + (vect-subtype (typecode displaced-to)) + (target displaced-to) + (real-offset offset) + (flags 0)) + (declare (fixnum disp-size rank flags vect-subtype real-offset)) + (when explicitp + (setq flags (bitset $arh_exp_disp_bit flags))) + (if (not (fixnump new-size))(error "Bad array dimensions ~s." dimensions)) + (locally (declare (fixnum new-size)) + ; (when (> (+ offset new-size) disp-size) ...), but don't cons bignums + (when (or (> new-size disp-size) + (let ((max-offset (- disp-size new-size))) + (declare (fixnum max-offset)) + (> offset max-offset))) + (%err-disp $err-disp-size displaced-to)) + (if adjustable (setq flags (bitset $arh_adjp_bit flags))) + (when fill + (if (eq fill t) + (setq fill new-size) + (unless (and (eql rank 1) + (fixnump fill) + (locally (declare (fixnum fill)) + (and (>= fill 0) (<= fill new-size)))) + (error "Bad fill pointer ~s" fill))) + (setq flags (bitset $arh_fill_bit flags)))) + ; If displaced-to is an array or vector header and is either + ; adjustable or its target is a header, then we need to set the + ; $arh_disp_bit. If displaced-to is not adjustable, then our + ; target can be its target instead of itself. + (when (or (eql vect-subtype target::subtag-arrayH) + (eql vect-subtype target::subtag-vectorH)) + (let ((dflags (%svref displaced-to target::arrayH.flags-cell))) + (declare (fixnum dflags)) + (when (or (logbitp $arh_adjp_bit dflags) + t + (progn + #+nope + (setq target (%svref displaced-to target::arrayH.data-vector-cell) + real-offset (+ offset (%svref displaced-to target::arrayH.displacement-cell))) + (logbitp $arh_disp_bit dflags) + #-nope t)) + (setq flags (bitset $arh_disp_bit flags)))) + (setq vect-subtype (%array-header-subtype displaced-to))) + ; assumes flags is low byte + (setq flags (dpb vect-subtype target::arrayH.flags-cell-subtag-byte flags)) + (if (eq rank 1) + (%gvector target::subtag-vectorH + (if (fixnump fill) fill new-size) + new-size + target + real-offset + flags) + (let ((val (%alloc-misc (+ target::arrayh.dim0-cell rank) target::subtag-arrayH))) + (setf (%svref val target::arrayH.rank-cell) rank) + (setf (%svref val target::arrayH.physsize-cell) new-size) + (setf (%svref val target::arrayH.data-vector-cell) target) + (setf (%svref val target::arrayH.displacement-cell) real-offset) + (setf (%svref val target::arrayH.flags-cell) flags) + (do* ((dims dimensions (cdr dims)) + (i 0 (1+ i))) + ((null dims)) + (declare (fixnum i)(list dims)) + (setf (%svref val (%i+ target::arrayH.dim0-cell i)) (car dims))) + val))))) + +(defun make-array (dims &key (element-type t element-type-p) + displaced-to + displaced-index-offset + adjustable + fill-pointer + (initial-element nil initial-element-p) + (initial-contents nil initial-contents-p)) + (when (and initial-element-p initial-contents-p) + (error "Cannot specify both ~S and ~S" :initial-element-p :initial-contents-p)) + (make-array-1 dims element-type element-type-p + displaced-to + displaced-index-offset + adjustable + fill-pointer + initial-element initial-element-p + initial-contents initial-contents-p + nil)) + + + + + +(defun vector-pop (vector) + "Decrease the fill pointer by 1 and return the element pointed to by the + new fill pointer." + (let* ((fill (fill-pointer vector))) + (declare (fixnum fill)) + (if (zerop fill) + (error "Fill pointer of ~S is 0 ." vector) + (progn + (decf fill) + (%set-fill-pointer vector fill) + (aref vector fill))))) + + + + +(defun elt (sequence idx) + "Return the element of SEQUENCE specified by INDEX." + (seq-dispatch + sequence + (let* ((cell (nthcdr idx sequence))) + (if (consp cell) + (car (the cons cell)) + (if cell + (report-bad-arg sequence '(satisfies proper-list-p)) + (%err-disp $XACCESSNTH idx sequence)))) + + (progn + (unless (and (typep idx 'fixnum) (>= (the fixnum idx) 0)) + (report-bad-arg idx 'unsigned-byte)) + (locally + (if (>= idx (length sequence)) + (%err-disp $XACCESSNTH idx sequence) + (aref sequence idx)))))) + + + + +(defun set-elt (sequence idx value) + (seq-dispatch + sequence + (let* ((cell (nthcdr idx sequence))) + (if (consp cell) + (setf (car (the cons cell)) value) + (if cell + (report-bad-arg sequence '(satisfies proper-list-p)) + (%err-disp $XACCESSNTH idx sequence)))) + (progn + (unless (and (typep idx 'fixnum) (>= (the fixnum idx) 0)) + (report-bad-arg idx 'unsigned-byte)) + (locally + (declare (fixnum idx)) + (if (>= idx (length sequence)) + (%err-disp $XACCESSNTH idx sequence) + (setf (aref sequence idx) value)))))) + + + + +(%fhave 'equalp #'equal) ; bootstrapping + +(defun copy-tree (tree) + "Recursively copy trees of conses." + (if (atom tree) + tree + (locally (declare (type cons tree)) + (do* ((tail (cdr tree) (cdr tail)) + (result (cons (copy-tree (car tree)) nil)) + (ptr result (cdr ptr))) + ((atom tail) + (setf (cdr ptr) tail) + result) + (declare (type cons ptr result)) + (locally + (declare (type cons tail)) + (setf (cdr ptr) (cons (copy-tree (car tail)) nil))))))) + + + + +(defvar *periodic-task-interval* 0.3) +(defvar *periodic-task-seconds* 0) +(defvar *periodic-task-nanoseconds* 300000000) + +(defun set-periodic-task-interval (n) + (multiple-value-setq (*periodic-task-seconds* *periodic-task-nanoseconds*) + (nanoseconds n)) + (setq *periodic-task-interval* n)) + +(defun periodic-task-interval () + *periodic-task-interval*) + + + +(defun char-downcase (c) + "Return CHAR converted to lower-case if that is possible." + (declare (optimize (speed 3))) ; open-code the %CHAR-CODE-DOWNCASE here. + (code-char (the valid-char-code (%char-code-downcase (char-code c))))) + + + +(defun digit-char-p (char &optional radix) + "If char is a digit in the specified radix, returns the fixnum for + which that digit stands, else returns NIL." + (let* ((code (char-code char)) + (r (if radix (if (and (typep radix 'fixnum) + (%i>= radix 2) + (%i<= radix 36)) + radix + (%validate-radix radix)) 10)) + (weight (if (and (<= code (char-code #\9)) + (>= code (char-code #\0))) + (the fixnum (- code (char-code #\0))) + (if (and (<= code (char-code #\Z)) + (>= code (char-code #\A))) + (the fixnum (+ 10 (the fixnum (- code (char-code #\A))))) + (if (and (<= code (char-code #\z)) + (>= code (char-code #\a))) + (the fixnum (+ 10 (the fixnum (- code (char-code #\a)))))))))) + (declare (fixnum code r)) + (and weight (< (the fixnum weight) r) weight))) + + + + + + + +(defun string-start-end (string start end) + (setq string (string string)) + (let ((len (length (the string string)))) + (flet ((are (a i)(error "Array index ~S out of bounds for ~S." i a))) + (if (and end (> end len))(are string end)) + (if (and start (or (< start 0)(> start len)))(are string start)) + (setq start (or start 0) end (or end len)) + (if (%i> start end) + (error "Start ~S exceeds end ~S." start end)) + (if (typep string 'simple-string) + (values string start end) + (multiple-value-bind (str off)(array-data-and-offset string) + (values str (%i+ off start)(%i+ off end))))))) + +(defun get-properties (place indicator-list) + "Like GETF, except that INDICATOR-LIST is a list of indicators which will + be looked for in the property list stored in PLACE. Three values are + returned, see manual for details." + (do ((plist place (cddr plist))) + ((null plist) (values nil nil nil)) + (cond ((atom (cdr plist)) + (report-bad-arg place '(satisfies proper-list-p))) + ((memq (car plist) indicator-list) ;memq defined in kernel + (return (values (car plist) (cadr plist) plist)))))) + +(defun string= (string1 string2 &key start1 end1 start2 end2) + "Given two strings (string1 and string2), and optional integers start1, + start2, end1 and end2, compares characters in string1 to characters in + string2 (using char=)." + (locally (declare (optimize (speed 3)(safety 0))) + (if (and (simple-string-p string1)(null start1)(null end1)) + (setq start1 0 end1 (length string1)) + (multiple-value-setq (string1 start1 end1)(string-start-end string1 start1 end1))) + (if (and (simple-string-p string2)(null start2)(null end2)) + (setq start2 0 end2 (length string2)) + (multiple-value-setq (string2 start2 end2)(string-start-end string2 start2 end2))) + (%simple-string= string1 string2 start1 start2 end1 end2))) + + +(defun lfun-keyvect (lfun) + (let ((bits (lfun-bits lfun))) + (declare (fixnum bits)) + (and (logbitp $lfbits-keys-bit bits) + (or (logbitp $lfbits-method-bit bits) + (and (not (logbitp $lfbits-gfn-bit bits)) + (not (logbitp $lfbits-cm-bit bits)))) + (nth-immediate lfun 1)))) + + +(defun function-entry-code-note (fn) + (let ((bits (lfun-bits (setq fn (require-type fn 'function))))) + (declare (fixnum bits)) + (and (logbitp $lfbits-code-coverage-bit bits) + (loop for i upfrom 1 as imm = (nth-immediate fn i) + when (code-note-p imm) do (return imm))))) + + +(defun function-lambda-expression (fn) + "Return (VALUES DEFINING-LAMBDA-EXPRESSION CLOSURE-P NAME), where + DEFINING-LAMBDA-EXPRESSION is NIL if unknown, or a suitable argument + to COMPILE otherwise, CLOSURE-P is non-NIL if the function's definition + might have been enclosed in some non-null lexical environment, and + NAME is some name (for debugging only) or NIL if there is no name." + ;(declare (values def env-p name)) + (let* ((bits (lfun-bits (setq fn (require-type fn 'function))))) + (declare (fixnum bits)) + (if (logbitp $lfbits-trampoline-bit bits) + (function-lambda-expression (nth-immediate fn 1)) + (values (uncompile-function fn) + (logbitp $lfbits-nonnullenv-bit bits) + (function-name fn))))) + +; env must be a lexical-environment or NIL. +; If env contains function or variable bindings or SPECIAL declarations, return t. +; Else return nil +(defun %non-empty-environment-p (env) + (loop + (when (or (null env) (istruct-typep env 'definition-environment)) + (return nil)) + (when (or (consp (lexenv.variables env)) + (consp (lexenv.functions env)) + (dolist (vdecl (lexenv.vdecls env)) + (when (eq (cadr vdecl) 'special) + (return t)))) + (return t)) + (setq env (lexenv.parent-env env)))) + +;(coerce object 'compiled-function) +(defun coerce-to-compiled-function (object) + (setq object (coerce-to-function object)) + (unless (typep object 'compiled-function) + (multiple-value-bind (def envp) (function-lambda-expression object) + (when (or envp (null def)) + (%err-disp $xcoerce object 'compiled-function)) + (setq object (compile-user-function def nil)))) + object) + + + +(defun %set-toplevel (&optional (fun nil fun-p)) + ;(setq fun (require-type fun '(or symbol function))) + (let* ((tcr (%current-tcr))) + (prog1 (%tcr-toplevel-function tcr) + (when fun-p + (%set-tcr-toplevel-function tcr fun))))) + + +(defun gccounts () + (let* ((total (%get-gc-count)) + (full (full-gccount)) + (g2-count 0) + (g1-count 0) + (g0-count 0)) + (when (egc-enabled-p) + (let* ((a (%active-dynamic-area))) + (setq g0-count (%fixnum-ref a target::area.gc-count) a (%fixnum-ref a target::area.older)) + (setq g1-count (%fixnum-ref a target::area.gc-count) a (%fixnum-ref a target::area.older)) + (setq g2-count (%fixnum-ref a target::area.gc-count)))) + (values total full g2-count g1-count g0-count))) + + + + + +(defstatic %pascal-functions% + #(NIL NIL NIL NIL NIL NIL NIL NIL + NIL NIL NIL NIL NIL NIL NIL NIL + NIL NIL NIL NIL NIL NIL NIL NIL + NIL NIL NIL NIL NIL NIL NIL NIL)) + + +(defun gc-retain-pages (arg) + "Try to influence the GC to retain/recycle the pages allocated between +GCs if arg is true, and to release them otherwise. This is generally a +gtradeoff between paging and other VM considerations." + (setq *gc-event-status-bits* + (if arg + (bitset $gc-retain-pages-bit *gc-event-status-bits*) + (bitclr $gc-retain-pages-bit *gc-event-status-bits*))) + (not (null arg))) + +(defun gc-retaining-pages () + "Return T if the GC tries to retain pages between full GCs and NIL if +it's trying to release them to improve VM paging performance." + (logbitp $gc-retain-pages-bit *gc-event-status-bits*)) + + +(defun gc-verbose (on-full-gc &optional (egc-too on-full-gc)) + "If the first (required) argument is non-NIL, configures the GC to print +informational messages on entry and exit to each full GC; if the first argument +is NIL, suppresses those messages. The second (optional) argument controls printing of messages on entry and exit to an ephemeral GC. Returns values as per GC-VERBOSE-P." + (let* ((bits *gc-event-status-bits*)) + (if on-full-gc + (bitsetf $gc-verbose-bit bits) + (bitclrf $gc-verbose-bit bits)) + (if egc-too + (bitsetf $egc-verbose-bit bits) + (bitclrf $egc-verbose-bit bits)) + (setq *gc-event-status-bits* bits) + (values on-full-gc egc-too))) + + +(defun gc-verbose-p () + "Returns two values: the first is true if the GC is configured to +print messages on each full GC; the second is true if the GC is configured +to print messages on each ephemeral GC." + (let* ((bits *gc-event-status-bits*)) + (values (logbitp $gc-verbose-bit bits) + (logbitp $egc-verbose-bit bits)))) + +(defun egc-active-p () + "Return T if the EGC was active at the time of the call, NIL otherwise. +Since this is generally a volatile piece of information, it's not clear +whether this function serves a useful purpose when native threads are +involved." + (and (egc-enabled-p) + (not (eql 0 (%get-kernel-global 'oldest-ephemeral))))) + +; this IS effectively a passive way of inquiring about enabled status. +(defun egc-enabled-p () + "Return T if the EGC was enabled at the time of the call, NIL otherwise." + (not (eql 0 (%fixnum-ref (%active-dynamic-area) target::area.older)))) + +(defun egc-configuration () + "Return as multiple values the sizes in kilobytes of the thresholds +associated with the youngest ephemeral generation, the middle ephemeral +generation, and the oldest ephemeral generation." + (let* ((ta (%get-kernel-global 'tenured-area)) + (g2 (%fixnum-ref ta target::area.younger)) + (g1 (%fixnum-ref g2 target::area.younger)) + (g0 (%fixnum-ref g1 target::area.younger))) + (values (ash (the fixnum (%fixnum-ref g0 target::area.threshold)) (- (- 10 target::fixnum-shift))) + (ash (the fixnum (%fixnum-ref g1 target::area.threshold)) (- (- 10 target::fixnum-shift))) + (ash (the fixnum (%fixnum-ref g2 target::area.threshold)) (- (- 10 target::fixnum-shift)))))) + + +(defun configure-egc (e0size e1size e2size) + "If the EGC is currently disabled, put the indicated threshold sizes in +effect and returns T, otherwise, returns NIL. The provided threshold sizes +are rounded up to a multiple of 64Kbytes." + (let* ((was-enabled (egc-active-p)) + (e2size (require-type e2size '(unsigned-byte 18))) + (e1size (require-type e1size '(unsigned-byte 18))) + (e0size (require-type e0size '(integer 1 #.(ash 1 18))))) + (unless (<= e0size e1size e2size) + (error "Generation ~s threshold cannot be smaller than generation ~s threshold" + (if (> e0size e1size) 1 2) (if (> e0size e1size) 0 1))) + (unwind-protect + (progn + (egc nil) + (setq e2size (logand (lognot #xffff) (+ #xffff (ash e2size 10))) + e1size (logand (lognot #xffff) (+ #xffff (ash e1size 10))) + e0size (logand (lognot #xffff) (+ #xffff (ash e0size 10)))) + (%configure-egc e0size e1size e2size)) + (egc was-enabled)))) + + + +(defun macptr-flags (macptr) + (if (eql (uvsize (setq macptr (require-type macptr 'macptr))) 1) + 0 + (uvref macptr TARGET::XMACPTR.FLAGS-CELL))) + + +; This doesn't really make the macptr be gcable (now has to be +; on linked list), but we might have other reasons for setting +; other flag bits. +(defun set-macptr-flags (macptr value) + (unless (eql (uvsize (setq macptr (require-type macptr 'macptr))) 1) + (setf (%svref macptr TARGET::XMACPTR.FLAGS-CELL) value) + value)) + +(defun %new-gcable-ptr (size &optional clear-p) + (let ((p (make-gcable-macptr $flags_DisposPtr))) + (%setf-macptr p (malloc size)) + (if clear-p + (#_memset p 0 size)) + p)) + +(defun %gcable-ptr-p (p) + (and (typep p 'macptr) + (= (uvsize p) target::xmacptr.element-count))) + +(defstatic *upper-to-lower* nil) +(defstatic *lower-to-upper* nil) + +;;; "address" should be the address (as returned by FOREIGN-SYMBOL-ADDRESS) +;;; of a foreign function that accepts a pointer as an argument and does +;;; whatever's needed to dispose of it. That function can be called from +;;; the GC, so it shouldn't call back into lisp. +(defun register-xmacptr-dispose-function (address) + (ff-call (%kernel-import target::kernel-import-register-xmacptr-dispose-function) + :address address + :int)) + + +;;; This alist is automatically (and not too cleverly ...) generated. +;;; +;;; NB: it was generated from Unicode 5.0 character tables, check to +;;; see if anything's changed in 5.1 or later versions. +;;; +;;; The (upper . lower) pairs have the property that UPPER is the +;;; value "simple uppercase equivalent" entry for LOWER in the +;;; UnicodeData.txt file and LOWER is the corresponding entry for +;;; UPPER, +(let* ((mapping + '((#\Latin_Capital_Letter_A_With_Grave . #\Latin_Small_Letter_A_With_Grave) + (#\Latin_Capital_Letter_A_With_Acute . #\Latin_Small_Letter_A_With_Acute) + (#\Latin_Capital_Letter_A_With_Circumflex + . #\Latin_Small_Letter_A_With_Circumflex) + (#\Latin_Capital_Letter_A_With_Tilde . #\Latin_Small_Letter_A_With_Tilde) + (#\Latin_Capital_Letter_A_With_Diaeresis + . #\Latin_Small_Letter_A_With_Diaeresis) + (#\Latin_Capital_Letter_A_With_Ring_Above + . #\Latin_Small_Letter_A_With_Ring_Above) + + (#\Latin_Capital_Letter_Ae . #\Latin_Small_Letter_Ae) + + (#\Latin_Capital_Letter_C_With_Cedilla . #\Latin_Small_Letter_C_With_Cedilla) + + (#\Latin_Capital_Letter_E_With_Grave . #\Latin_Small_Letter_E_With_Grave) + + (#\Latin_Capital_Letter_E_With_Acute . #\Latin_Small_Letter_E_With_Acute) + + (#\Latin_Capital_Letter_E_With_Circumflex + . #\Latin_Small_Letter_E_With_Circumflex) + + (#\Latin_Capital_Letter_E_With_Diaeresis + . #\Latin_Small_Letter_E_With_Diaeresis) + + (#\Latin_Capital_Letter_I_With_Grave . #\Latin_Small_Letter_I_With_Grave) + + (#\Latin_Capital_Letter_I_With_Acute . #\Latin_Small_Letter_I_With_Acute) + + (#\Latin_Capital_Letter_I_With_Circumflex + . #\Latin_Small_Letter_I_With_Circumflex) + + (#\Latin_Capital_Letter_I_With_Diaeresis + . #\Latin_Small_Letter_I_With_Diaeresis) + + (#\Latin_Capital_Letter_Eth . #\Latin_Small_Letter_Eth) + + (#\Latin_Capital_Letter_N_With_Tilde . #\Latin_Small_Letter_N_With_Tilde) + + (#\Latin_Capital_Letter_O_With_Grave . #\Latin_Small_Letter_O_With_Grave) + + (#\Latin_Capital_Letter_O_With_Acute . #\Latin_Small_Letter_O_With_Acute) + + (#\Latin_Capital_Letter_O_With_Circumflex + . #\Latin_Small_Letter_O_With_Circumflex) + + (#\Latin_Capital_Letter_O_With_Tilde . #\Latin_Small_Letter_O_With_Tilde) + + (#\Latin_Capital_Letter_O_With_Diaeresis + . #\Latin_Small_Letter_O_With_Diaeresis) + + (#\Latin_Capital_Letter_O_With_Stroke . #\Latin_Small_Letter_O_With_Stroke) + + (#\Latin_Capital_Letter_U_With_Grave . #\Latin_Small_Letter_U_With_Grave) + + (#\Latin_Capital_Letter_U_With_Acute . #\Latin_Small_Letter_U_With_Acute) + + (#\Latin_Capital_Letter_U_With_Circumflex + . #\Latin_Small_Letter_U_With_Circumflex) + + (#\Latin_Capital_Letter_U_With_Diaeresis + . #\Latin_Small_Letter_U_With_Diaeresis) + + (#\Latin_Capital_Letter_Y_With_Acute . #\Latin_Small_Letter_Y_With_Acute) + + (#\Latin_Capital_Letter_Thorn . #\Latin_Small_Letter_Thorn) + + (#\Latin_Capital_Letter_A_With_Macron . #\Latin_Small_Letter_A_With_Macron) + + (#\Latin_Capital_Letter_A_With_Breve . #\Latin_Small_Letter_A_With_Breve) + + (#\Latin_Capital_Letter_A_With_Ogonek . #\Latin_Small_Letter_A_With_Ogonek) + + (#\Latin_Capital_Letter_C_With_Acute . #\Latin_Small_Letter_C_With_Acute) + + (#\Latin_Capital_Letter_C_With_Circumflex + . #\Latin_Small_Letter_C_With_Circumflex) + + (#\Latin_Capital_Letter_C_With_Dot_Above + . #\Latin_Small_Letter_C_With_Dot_Above) + + (#\Latin_Capital_Letter_C_With_Caron . #\Latin_Small_Letter_C_With_Caron) + + (#\Latin_Capital_Letter_D_With_Caron . #\Latin_Small_Letter_D_With_Caron) + + (#\Latin_Capital_Letter_D_With_Stroke . #\Latin_Small_Letter_D_With_Stroke) + + (#\Latin_Capital_Letter_E_With_Macron . #\Latin_Small_Letter_E_With_Macron) + + (#\Latin_Capital_Letter_E_With_Breve . #\Latin_Small_Letter_E_With_Breve) + + (#\Latin_Capital_Letter_E_With_Dot_Above + . #\Latin_Small_Letter_E_With_Dot_Above) + + (#\Latin_Capital_Letter_E_With_Ogonek . #\Latin_Small_Letter_E_With_Ogonek) + + (#\Latin_Capital_Letter_E_With_Caron . #\Latin_Small_Letter_E_With_Caron) + + (#\Latin_Capital_Letter_G_With_Circumflex + . #\Latin_Small_Letter_G_With_Circumflex) + + (#\Latin_Capital_Letter_G_With_Breve . #\Latin_Small_Letter_G_With_Breve) + + (#\Latin_Capital_Letter_G_With_Dot_Above + . #\Latin_Small_Letter_G_With_Dot_Above) + + (#\Latin_Capital_Letter_G_With_Cedilla . #\Latin_Small_Letter_G_With_Cedilla) + + (#\Latin_Capital_Letter_H_With_Circumflex + . #\Latin_Small_Letter_H_With_Circumflex) + + (#\Latin_Capital_Letter_H_With_Stroke . #\Latin_Small_Letter_H_With_Stroke) + + (#\Latin_Capital_Letter_I_With_Tilde . #\Latin_Small_Letter_I_With_Tilde) + + (#\Latin_Capital_Letter_I_With_Macron . #\Latin_Small_Letter_I_With_Macron) + + (#\Latin_Capital_Letter_I_With_Breve . #\Latin_Small_Letter_I_With_Breve) + + (#\Latin_Capital_Letter_I_With_Ogonek . #\Latin_Small_Letter_I_With_Ogonek) + + (#\Latin_Capital_Ligature_Ij . #\Latin_Small_Ligature_Ij) + + (#\Latin_Capital_Letter_J_With_Circumflex + . #\Latin_Small_Letter_J_With_Circumflex) + + (#\Latin_Capital_Letter_K_With_Cedilla . #\Latin_Small_Letter_K_With_Cedilla) + + (#\Latin_Capital_Letter_L_With_Acute . #\Latin_Small_Letter_L_With_Acute) + + (#\Latin_Capital_Letter_L_With_Cedilla . #\Latin_Small_Letter_L_With_Cedilla) + + (#\Latin_Capital_Letter_L_With_Caron . #\Latin_Small_Letter_L_With_Caron) + + (#\Latin_Capital_Letter_L_With_Middle_Dot + . #\Latin_Small_Letter_L_With_Middle_Dot) + + (#\Latin_Capital_Letter_L_With_Stroke . #\Latin_Small_Letter_L_With_Stroke) + + (#\Latin_Capital_Letter_N_With_Acute . #\Latin_Small_Letter_N_With_Acute) + + (#\Latin_Capital_Letter_N_With_Cedilla . #\Latin_Small_Letter_N_With_Cedilla) + + (#\Latin_Capital_Letter_N_With_Caron . #\Latin_Small_Letter_N_With_Caron) + + (#\Latin_Capital_Letter_Eng . #\Latin_Small_Letter_Eng) + + (#\Latin_Capital_Letter_O_With_Macron . #\Latin_Small_Letter_O_With_Macron) + + (#\Latin_Capital_Letter_O_With_Breve . #\Latin_Small_Letter_O_With_Breve) + + (#\Latin_Capital_Letter_O_With_Double_Acute + . #\Latin_Small_Letter_O_With_Double_Acute) + + (#\Latin_Capital_Ligature_Oe . #\Latin_Small_Ligature_Oe) + + (#\Latin_Capital_Letter_R_With_Acute . #\Latin_Small_Letter_R_With_Acute) + + (#\Latin_Capital_Letter_R_With_Cedilla . #\Latin_Small_Letter_R_With_Cedilla) + + (#\Latin_Capital_Letter_R_With_Caron . #\Latin_Small_Letter_R_With_Caron) + + (#\Latin_Capital_Letter_S_With_Acute . #\Latin_Small_Letter_S_With_Acute) + + (#\Latin_Capital_Letter_S_With_Circumflex + . #\Latin_Small_Letter_S_With_Circumflex) + + (#\Latin_Capital_Letter_S_With_Cedilla . #\Latin_Small_Letter_S_With_Cedilla) + + (#\Latin_Capital_Letter_S_With_Caron . #\Latin_Small_Letter_S_With_Caron) + + (#\Latin_Capital_Letter_T_With_Cedilla . #\Latin_Small_Letter_T_With_Cedilla) + + (#\Latin_Capital_Letter_T_With_Caron . #\Latin_Small_Letter_T_With_Caron) + + (#\Latin_Capital_Letter_T_With_Stroke . #\Latin_Small_Letter_T_With_Stroke) + + (#\Latin_Capital_Letter_U_With_Tilde . #\Latin_Small_Letter_U_With_Tilde) + + (#\Latin_Capital_Letter_U_With_Macron . #\Latin_Small_Letter_U_With_Macron) + + (#\Latin_Capital_Letter_U_With_Breve . #\Latin_Small_Letter_U_With_Breve) + + (#\Latin_Capital_Letter_U_With_Ring_Above + . #\Latin_Small_Letter_U_With_Ring_Above) + + (#\Latin_Capital_Letter_U_With_Double_Acute + . #\Latin_Small_Letter_U_With_Double_Acute) + + (#\Latin_Capital_Letter_U_With_Ogonek . #\Latin_Small_Letter_U_With_Ogonek) + + (#\Latin_Capital_Letter_W_With_Circumflex + . #\Latin_Small_Letter_W_With_Circumflex) + + (#\Latin_Capital_Letter_Y_With_Circumflex + . #\Latin_Small_Letter_Y_With_Circumflex) + + (#\Latin_Capital_Letter_Y_With_Diaeresis + . #\Latin_Small_Letter_Y_With_Diaeresis) + + (#\Latin_Capital_Letter_Z_With_Acute . #\Latin_Small_Letter_Z_With_Acute) + + (#\Latin_Capital_Letter_Z_With_Dot_Above + . #\Latin_Small_Letter_Z_With_Dot_Above) + + (#\Latin_Capital_Letter_Z_With_Caron . #\Latin_Small_Letter_Z_With_Caron) + + (#\Latin_Capital_Letter_B_With_Hook . #\Latin_Small_Letter_B_With_Hook) + + (#\Latin_Capital_Letter_B_With_Topbar . #\Latin_Small_Letter_B_With_Topbar) + + (#\Latin_Capital_Letter_Tone_Six . #\Latin_Small_Letter_Tone_Six) + + (#\Latin_Capital_Letter_Open_O . #\Latin_Small_Letter_Open_O) + + (#\Latin_Capital_Letter_C_With_Hook . #\Latin_Small_Letter_C_With_Hook) + + (#\Latin_Capital_Letter_African_D . #\Latin_Small_Letter_D_With_Tail) + + (#\Latin_Capital_Letter_D_With_Hook . #\Latin_Small_Letter_D_With_Hook) + + (#\Latin_Capital_Letter_D_With_Topbar . #\Latin_Small_Letter_D_With_Topbar) + + (#\Latin_Capital_Letter_Reversed_E . #\Latin_Small_Letter_Turned_E) + + (#\Latin_Capital_Letter_Schwa . #\Latin_Small_Letter_Schwa) + + (#\Latin_Capital_Letter_Open_E . #\Latin_Small_Letter_Open_E) + + (#\Latin_Capital_Letter_F_With_Hook . #\Latin_Small_Letter_F_With_Hook) + + (#\Latin_Capital_Letter_G_With_Hook . #\Latin_Small_Letter_G_With_Hook) + + (#\Latin_Capital_Letter_Gamma . #\Latin_Small_Letter_Gamma) + + (#\Latin_Capital_Letter_Iota . #\Latin_Small_Letter_Iota) + + (#\Latin_Capital_Letter_I_With_Stroke . #\Latin_Small_Letter_I_With_Stroke) + + (#\Latin_Capital_Letter_K_With_Hook . #\Latin_Small_Letter_K_With_Hook) + + (#\Latin_Capital_Letter_Turned_M . #\Latin_Small_Letter_Turned_M) + + (#\Latin_Capital_Letter_N_With_Left_Hook + . #\Latin_Small_Letter_N_With_Left_Hook) + + (#\Latin_Capital_Letter_O_With_Middle_Tilde . #\Latin_Small_Letter_Barred_O) + + (#\Latin_Capital_Letter_O_With_Horn . #\Latin_Small_Letter_O_With_Horn) + + (#\Latin_Capital_Letter_Oi . #\Latin_Small_Letter_Oi) + + (#\Latin_Capital_Letter_P_With_Hook . #\Latin_Small_Letter_P_With_Hook) + + (#\Latin_Letter_Yr . #\Latin_Letter_Small_Capital_R) + + (#\Latin_Capital_Letter_Tone_Two . #\Latin_Small_Letter_Tone_Two) + + (#\Latin_Capital_Letter_Esh . #\Latin_Small_Letter_Esh) + + (#\Latin_Capital_Letter_T_With_Hook . #\Latin_Small_Letter_T_With_Hook) + + (#\Latin_Capital_Letter_T_With_Retroflex_Hook + . #\Latin_Small_Letter_T_With_Retroflex_Hook) + + (#\Latin_Capital_Letter_U_With_Horn . #\Latin_Small_Letter_U_With_Horn) + + (#\Latin_Capital_Letter_Upsilon . #\Latin_Small_Letter_Upsilon) + + (#\Latin_Capital_Letter_V_With_Hook . #\Latin_Small_Letter_V_With_Hook) + + (#\Latin_Capital_Letter_Y_With_Hook . #\Latin_Small_Letter_Y_With_Hook) + + (#\Latin_Capital_Letter_Z_With_Stroke . #\Latin_Small_Letter_Z_With_Stroke) + + (#\Latin_Capital_Letter_Ezh . #\Latin_Small_Letter_Ezh) + + (#\Latin_Capital_Letter_Ezh_Reversed . #\Latin_Small_Letter_Ezh_Reversed) + + (#\Latin_Capital_Letter_Tone_Five . #\Latin_Small_Letter_Tone_Five) + + (#\Latin_Capital_Letter_Dz_With_Caron . #\Latin_Small_Letter_Dz_With_Caron) + + (#\Latin_Capital_Letter_Lj . #\Latin_Small_Letter_Lj) + + (#\Latin_Capital_Letter_Nj . #\Latin_Small_Letter_Nj) + + (#\Latin_Capital_Letter_A_With_Caron . #\Latin_Small_Letter_A_With_Caron) + + (#\Latin_Capital_Letter_I_With_Caron . #\Latin_Small_Letter_I_With_Caron) + + (#\Latin_Capital_Letter_O_With_Caron . #\Latin_Small_Letter_O_With_Caron) + + (#\Latin_Capital_Letter_U_With_Caron . #\Latin_Small_Letter_U_With_Caron) + + (#\Latin_Capital_Letter_U_With_Diaeresis_And_Macron + . #\Latin_Small_Letter_U_With_Diaeresis_And_Macron) + + (#\Latin_Capital_Letter_U_With_Diaeresis_And_Acute + . #\Latin_Small_Letter_U_With_Diaeresis_And_Acute) + + (#\Latin_Capital_Letter_U_With_Diaeresis_And_Caron + . #\Latin_Small_Letter_U_With_Diaeresis_And_Caron) + + (#\Latin_Capital_Letter_U_With_Diaeresis_And_Grave + . #\Latin_Small_Letter_U_With_Diaeresis_And_Grave) + + (#\Latin_Capital_Letter_A_With_Diaeresis_And_Macron + . #\Latin_Small_Letter_A_With_Diaeresis_And_Macron) + + (#\Latin_Capital_Letter_A_With_Dot_Above_And_Macron + . #\Latin_Small_Letter_A_With_Dot_Above_And_Macron) + + (#\Latin_Capital_Letter_Ae_With_Macron . #\Latin_Small_Letter_Ae_With_Macron) + + (#\Latin_Capital_Letter_G_With_Stroke . #\Latin_Small_Letter_G_With_Stroke) + + (#\Latin_Capital_Letter_G_With_Caron . #\Latin_Small_Letter_G_With_Caron) + + (#\Latin_Capital_Letter_K_With_Caron . #\Latin_Small_Letter_K_With_Caron) + + (#\Latin_Capital_Letter_O_With_Ogonek . #\Latin_Small_Letter_O_With_Ogonek) + + (#\Latin_Capital_Letter_O_With_Ogonek_And_Macron + . #\Latin_Small_Letter_O_With_Ogonek_And_Macron) + + (#\Latin_Capital_Letter_Ezh_With_Caron . #\Latin_Small_Letter_Ezh_With_Caron) + + (#\Latin_Capital_Letter_Dz . #\Latin_Small_Letter_Dz) + + (#\Latin_Capital_Letter_G_With_Acute . #\Latin_Small_Letter_G_With_Acute) + + (#\Latin_Capital_Letter_Hwair . #\Latin_Small_Letter_Hv) + + (#\Latin_Capital_Letter_Wynn . #\Latin_Letter_Wynn) + + (#\Latin_Capital_Letter_N_With_Grave . #\Latin_Small_Letter_N_With_Grave) + + (#\Latin_Capital_Letter_A_With_Ring_Above_And_Acute + . #\Latin_Small_Letter_A_With_Ring_Above_And_Acute) + + (#\Latin_Capital_Letter_Ae_With_Acute . #\Latin_Small_Letter_Ae_With_Acute) + + (#\Latin_Capital_Letter_O_With_Stroke_And_Acute + . #\Latin_Small_Letter_O_With_Stroke_And_Acute) + + (#\Latin_Capital_Letter_A_With_Double_Grave + . #\Latin_Small_Letter_A_With_Double_Grave) + + (#\Latin_Capital_Letter_A_With_Inverted_Breve + . #\Latin_Small_Letter_A_With_Inverted_Breve) + + (#\Latin_Capital_Letter_E_With_Double_Grave + . #\Latin_Small_Letter_E_With_Double_Grave) + + (#\Latin_Capital_Letter_E_With_Inverted_Breve + . #\Latin_Small_Letter_E_With_Inverted_Breve) + + (#\Latin_Capital_Letter_I_With_Double_Grave + . #\Latin_Small_Letter_I_With_Double_Grave) + + (#\Latin_Capital_Letter_I_With_Inverted_Breve + . #\Latin_Small_Letter_I_With_Inverted_Breve) + + (#\Latin_Capital_Letter_O_With_Double_Grave + . #\Latin_Small_Letter_O_With_Double_Grave) + + (#\Latin_Capital_Letter_O_With_Inverted_Breve + . #\Latin_Small_Letter_O_With_Inverted_Breve) + + (#\Latin_Capital_Letter_R_With_Double_Grave + . #\Latin_Small_Letter_R_With_Double_Grave) + + (#\Latin_Capital_Letter_R_With_Inverted_Breve + . #\Latin_Small_Letter_R_With_Inverted_Breve) + + (#\Latin_Capital_Letter_U_With_Double_Grave + . #\Latin_Small_Letter_U_With_Double_Grave) + + (#\Latin_Capital_Letter_U_With_Inverted_Breve + . #\Latin_Small_Letter_U_With_Inverted_Breve) + + (#\Latin_Capital_Letter_S_With_Comma_Below + . #\Latin_Small_Letter_S_With_Comma_Below) + + (#\Latin_Capital_Letter_T_With_Comma_Below + . #\Latin_Small_Letter_T_With_Comma_Below) + + (#\Latin_Capital_Letter_Yogh . #\Latin_Small_Letter_Yogh) + + (#\Latin_Capital_Letter_H_With_Caron . #\Latin_Small_Letter_H_With_Caron) + + (#\Latin_Capital_Letter_N_With_Long_Right_Leg + . #\Latin_Small_Letter_N_With_Long_Right_Leg) + + (#\Latin_Capital_Letter_Ou . #\Latin_Small_Letter_Ou) + + (#\Latin_Capital_Letter_Z_With_Hook . #\Latin_Small_Letter_Z_With_Hook) + + (#\Latin_Capital_Letter_A_With_Dot_Above + . #\Latin_Small_Letter_A_With_Dot_Above) + + (#\Latin_Capital_Letter_E_With_Cedilla . #\Latin_Small_Letter_E_With_Cedilla) + + (#\Latin_Capital_Letter_O_With_Diaeresis_And_Macron + . #\Latin_Small_Letter_O_With_Diaeresis_And_Macron) + + (#\Latin_Capital_Letter_O_With_Tilde_And_Macron + . #\Latin_Small_Letter_O_With_Tilde_And_Macron) + + (#\Latin_Capital_Letter_O_With_Dot_Above + . #\Latin_Small_Letter_O_With_Dot_Above) + + (#\Latin_Capital_Letter_O_With_Dot_Above_And_Macron + . #\Latin_Small_Letter_O_With_Dot_Above_And_Macron) + + (#\Latin_Capital_Letter_Y_With_Macron . #\Latin_Small_Letter_Y_With_Macron) + + (#\Latin_Capital_Letter_A_With_Stroke . #\U+2C65) + + (#\Latin_Capital_Letter_C_With_Stroke . #\Latin_Small_Letter_C_With_Stroke) + + (#\Latin_Capital_Letter_L_With_Bar . #\Latin_Small_Letter_L_With_Bar) + + (#\Latin_Capital_Letter_T_With_Diagonal_Stroke . #\U+2C66) + + (#\Latin_Capital_Letter_Glottal_Stop . #\Latin_Small_Letter_Glottal_Stop) + + (#\Latin_Capital_Letter_B_With_Stroke . #\Latin_Small_Letter_B_With_Stroke) + + (#\Latin_Capital_Letter_U_Bar . #\Latin_Small_Letter_U_Bar) + + (#\Latin_Capital_Letter_Turned_V . #\Latin_Small_Letter_Turned_V) + + (#\Latin_Capital_Letter_E_With_Stroke . #\Latin_Small_Letter_E_With_Stroke) + + (#\Latin_Capital_Letter_J_With_Stroke . #\Latin_Small_Letter_J_With_Stroke) + + (#\Latin_Capital_Letter_Small_Q_With_Hook_Tail + . #\Latin_Small_Letter_Q_With_Hook_Tail) + + (#\Latin_Capital_Letter_R_With_Stroke . #\Latin_Small_Letter_R_With_Stroke) + + (#\Latin_Capital_Letter_Y_With_Stroke . #\Latin_Small_Letter_Y_With_Stroke) + + (#\Greek_Capital_Letter_Alpha_With_Tonos + . #\Greek_Small_Letter_Alpha_With_Tonos) + + (#\Greek_Capital_Letter_Epsilon_With_Tonos + . #\Greek_Small_Letter_Epsilon_With_Tonos) + + (#\Greek_Capital_Letter_Eta_With_Tonos . #\Greek_Small_Letter_Eta_With_Tonos) + + (#\Greek_Capital_Letter_Iota_With_Tonos + . #\Greek_Small_Letter_Iota_With_Tonos) + + (#\Greek_Capital_Letter_Omicron_With_Tonos + . #\Greek_Small_Letter_Omicron_With_Tonos) + + (#\Greek_Capital_Letter_Upsilon_With_Tonos + . #\Greek_Small_Letter_Upsilon_With_Tonos) + + (#\Greek_Capital_Letter_Omega_With_Tonos + . #\Greek_Small_Letter_Omega_With_Tonos) + + (#\Greek_Capital_Letter_Alpha . #\Greek_Small_Letter_Alpha) + + (#\Greek_Capital_Letter_Beta . #\Greek_Small_Letter_Beta) + + (#\Greek_Capital_Letter_Gamma . #\Greek_Small_Letter_Gamma) + + (#\Greek_Capital_Letter_Delta . #\Greek_Small_Letter_Delta) + + (#\Greek_Capital_Letter_Epsilon . #\Greek_Small_Letter_Epsilon) + + (#\Greek_Capital_Letter_Zeta . #\Greek_Small_Letter_Zeta) + + (#\Greek_Capital_Letter_Eta . #\Greek_Small_Letter_Eta) + + (#\Greek_Capital_Letter_Theta . #\Greek_Small_Letter_Theta) + + (#\Greek_Capital_Letter_Iota . #\Greek_Small_Letter_Iota) + + (#\Greek_Capital_Letter_Kappa . #\Greek_Small_Letter_Kappa) + + (#\Greek_Capital_Letter_Lamda . #\Greek_Small_Letter_Lamda) + + (#\Greek_Capital_Letter_Mu . #\Greek_Small_Letter_Mu) + + (#\Greek_Capital_Letter_Nu . #\Greek_Small_Letter_Nu) + + (#\Greek_Capital_Letter_Xi . #\Greek_Small_Letter_Xi) + + (#\Greek_Capital_Letter_Omicron . #\Greek_Small_Letter_Omicron) + + (#\Greek_Capital_Letter_Pi . #\Greek_Small_Letter_Pi) + + (#\Greek_Capital_Letter_Rho . #\Greek_Small_Letter_Rho) + + (#\Greek_Capital_Letter_Sigma . #\Greek_Small_Letter_Sigma) + + (#\Greek_Capital_Letter_Tau . #\Greek_Small_Letter_Tau) + + (#\Greek_Capital_Letter_Upsilon . #\Greek_Small_Letter_Upsilon) + + (#\Greek_Capital_Letter_Phi . #\Greek_Small_Letter_Phi) + + (#\Greek_Capital_Letter_Chi . #\Greek_Small_Letter_Chi) + + (#\Greek_Capital_Letter_Psi . #\Greek_Small_Letter_Psi) + + (#\Greek_Capital_Letter_Omega . #\Greek_Small_Letter_Omega) + + (#\Greek_Capital_Letter_Iota_With_Dialytika + . #\Greek_Small_Letter_Iota_With_Dialytika) + + (#\Greek_Capital_Letter_Upsilon_With_Dialytika + . #\Greek_Small_Letter_Upsilon_With_Dialytika) + + (#\Greek_Letter_Archaic_Koppa . #\Greek_Small_Letter_Archaic_Koppa) + + (#\Greek_Letter_Stigma . #\Greek_Small_Letter_Stigma) + + (#\Greek_Letter_Digamma . #\Greek_Small_Letter_Digamma) + + (#\Greek_Letter_Koppa . #\Greek_Small_Letter_Koppa) + + (#\Greek_Letter_Sampi . #\Greek_Small_Letter_Sampi) + + (#\Coptic_Capital_Letter_Shei . #\Coptic_Small_Letter_Shei) + + (#\Coptic_Capital_Letter_Fei . #\Coptic_Small_Letter_Fei) + + (#\Coptic_Capital_Letter_Khei . #\Coptic_Small_Letter_Khei) + + (#\Coptic_Capital_Letter_Hori . #\Coptic_Small_Letter_Hori) + + (#\Coptic_Capital_Letter_Gangia . #\Coptic_Small_Letter_Gangia) + + (#\Coptic_Capital_Letter_Shima . #\Coptic_Small_Letter_Shima) + + (#\Coptic_Capital_Letter_Dei . #\Coptic_Small_Letter_Dei) + + (#\Greek_Capital_Letter_Sho . #\Greek_Small_Letter_Sho) + + (#\Greek_Capital_Lunate_Sigma_Symbol . #\Greek_Lunate_Sigma_Symbol) + + (#\Greek_Capital_Letter_San . #\Greek_Small_Letter_San) + + (#\Greek_Capital_Reversed_Lunate_Sigma_Symbol + . #\Greek_Small_Reversed_Lunate_Sigma_Symbol) + + (#\Greek_Capital_Dotted_Lunate_Sigma_Symbol + . #\Greek_Small_Dotted_Lunate_Sigma_Symbol) + + (#\Greek_Capital_Reversed_Dotted_Lunate_Sigma_Symbol + . #\Greek_Small_Reversed_Dotted_Lunate_Sigma_Symbol) + + (#\Cyrillic_Capital_Letter_Ie_With_Grave + . #\Cyrillic_Small_Letter_Ie_With_Grave) + + (#\Cyrillic_Capital_Letter_Io . #\Cyrillic_Small_Letter_Io) + + (#\Cyrillic_Capital_Letter_Dje . #\Cyrillic_Small_Letter_Dje) + + (#\Cyrillic_Capital_Letter_Gje . #\Cyrillic_Small_Letter_Gje) + + (#\Cyrillic_Capital_Letter_Ukrainian_Ie + . #\Cyrillic_Small_Letter_Ukrainian_Ie) + + (#\Cyrillic_Capital_Letter_Dze . #\Cyrillic_Small_Letter_Dze) + + (#\Cyrillic_Capital_Letter_Byelorussian-Ukrainian_I + . #\Cyrillic_Small_Letter_Byelorussian-Ukrainian_I) + + (#\Cyrillic_Capital_Letter_Yi . #\Cyrillic_Small_Letter_Yi) + + (#\Cyrillic_Capital_Letter_Je . #\Cyrillic_Small_Letter_Je) + + (#\Cyrillic_Capital_Letter_Lje . #\Cyrillic_Small_Letter_Lje) + + (#\Cyrillic_Capital_Letter_Nje . #\Cyrillic_Small_Letter_Nje) + + (#\Cyrillic_Capital_Letter_Tshe . #\Cyrillic_Small_Letter_Tshe) + + (#\Cyrillic_Capital_Letter_Kje . #\Cyrillic_Small_Letter_Kje) + + (#\Cyrillic_Capital_Letter_I_With_Grave + . #\Cyrillic_Small_Letter_I_With_Grave) + + (#\Cyrillic_Capital_Letter_Short_U . #\Cyrillic_Small_Letter_Short_U) + + (#\Cyrillic_Capital_Letter_Dzhe . #\Cyrillic_Small_Letter_Dzhe) + + (#\Cyrillic_Capital_Letter_A . #\Cyrillic_Small_Letter_A) + + (#\Cyrillic_Capital_Letter_Be . #\Cyrillic_Small_Letter_Be) + + (#\Cyrillic_Capital_Letter_Ve . #\Cyrillic_Small_Letter_Ve) + + (#\Cyrillic_Capital_Letter_Ghe . #\Cyrillic_Small_Letter_Ghe) + + (#\Cyrillic_Capital_Letter_De . #\Cyrillic_Small_Letter_De) + + (#\Cyrillic_Capital_Letter_Ie . #\Cyrillic_Small_Letter_Ie) + + (#\Cyrillic_Capital_Letter_Zhe . #\Cyrillic_Small_Letter_Zhe) + + (#\Cyrillic_Capital_Letter_Ze . #\Cyrillic_Small_Letter_Ze) + + (#\Cyrillic_Capital_Letter_I . #\Cyrillic_Small_Letter_I) + + (#\Cyrillic_Capital_Letter_Short_I . #\Cyrillic_Small_Letter_Short_I) + + (#\Cyrillic_Capital_Letter_Ka . #\Cyrillic_Small_Letter_Ka) + + (#\Cyrillic_Capital_Letter_El . #\Cyrillic_Small_Letter_El) + + (#\Cyrillic_Capital_Letter_Em . #\Cyrillic_Small_Letter_Em) + + (#\Cyrillic_Capital_Letter_En . #\Cyrillic_Small_Letter_En) + + (#\Cyrillic_Capital_Letter_O . #\Cyrillic_Small_Letter_O) + + (#\Cyrillic_Capital_Letter_Pe . #\Cyrillic_Small_Letter_Pe) + + (#\Cyrillic_Capital_Letter_Er . #\Cyrillic_Small_Letter_Er) + + (#\Cyrillic_Capital_Letter_Es . #\Cyrillic_Small_Letter_Es) + + (#\Cyrillic_Capital_Letter_Te . #\Cyrillic_Small_Letter_Te) + + (#\Cyrillic_Capital_Letter_U . #\Cyrillic_Small_Letter_U) + + (#\Cyrillic_Capital_Letter_Ef . #\Cyrillic_Small_Letter_Ef) + + (#\Cyrillic_Capital_Letter_Ha . #\Cyrillic_Small_Letter_Ha) + + (#\Cyrillic_Capital_Letter_Tse . #\Cyrillic_Small_Letter_Tse) + + (#\Cyrillic_Capital_Letter_Che . #\Cyrillic_Small_Letter_Che) + + (#\Cyrillic_Capital_Letter_Sha . #\Cyrillic_Small_Letter_Sha) + + (#\Cyrillic_Capital_Letter_Shcha . #\Cyrillic_Small_Letter_Shcha) + + (#\Cyrillic_Capital_Letter_Hard_Sign . #\Cyrillic_Small_Letter_Hard_Sign) + + (#\Cyrillic_Capital_Letter_Yeru . #\Cyrillic_Small_Letter_Yeru) + + (#\Cyrillic_Capital_Letter_Soft_Sign . #\Cyrillic_Small_Letter_Soft_Sign) + + (#\Cyrillic_Capital_Letter_E . #\Cyrillic_Small_Letter_E) + + (#\Cyrillic_Capital_Letter_Yu . #\Cyrillic_Small_Letter_Yu) + + (#\Cyrillic_Capital_Letter_Ya . #\Cyrillic_Small_Letter_Ya) + + (#\Cyrillic_Capital_Letter_Omega . #\Cyrillic_Small_Letter_Omega) + + (#\Cyrillic_Capital_Letter_Yat . #\Cyrillic_Small_Letter_Yat) + + (#\Cyrillic_Capital_Letter_Iotified_E . #\Cyrillic_Small_Letter_Iotified_E) + + (#\Cyrillic_Capital_Letter_Little_Yus . #\Cyrillic_Small_Letter_Little_Yus) + + (#\Cyrillic_Capital_Letter_Iotified_Little_Yus + . #\Cyrillic_Small_Letter_Iotified_Little_Yus) + + (#\Cyrillic_Capital_Letter_Big_Yus . #\Cyrillic_Small_Letter_Big_Yus) + + (#\Cyrillic_Capital_Letter_Iotified_Big_Yus + . #\Cyrillic_Small_Letter_Iotified_Big_Yus) + + (#\Cyrillic_Capital_Letter_Ksi . #\Cyrillic_Small_Letter_Ksi) + + (#\Cyrillic_Capital_Letter_Psi . #\Cyrillic_Small_Letter_Psi) + + (#\Cyrillic_Capital_Letter_Fita . #\Cyrillic_Small_Letter_Fita) + + (#\Cyrillic_Capital_Letter_Izhitsa . #\Cyrillic_Small_Letter_Izhitsa) + + (#\Cyrillic_Capital_Letter_Izhitsa_With_Double_Grave_Accent + . #\Cyrillic_Small_Letter_Izhitsa_With_Double_Grave_Accent) + + (#\Cyrillic_Capital_Letter_Uk . #\Cyrillic_Small_Letter_Uk) + + (#\Cyrillic_Capital_Letter_Round_Omega . #\Cyrillic_Small_Letter_Round_Omega) + + (#\Cyrillic_Capital_Letter_Omega_With_Titlo + . #\Cyrillic_Small_Letter_Omega_With_Titlo) + + (#\Cyrillic_Capital_Letter_Ot . #\Cyrillic_Small_Letter_Ot) + + (#\Cyrillic_Capital_Letter_Koppa . #\Cyrillic_Small_Letter_Koppa) + + (#\Cyrillic_Capital_Letter_Short_I_With_Tail + . #\Cyrillic_Small_Letter_Short_I_With_Tail) + + (#\Cyrillic_Capital_Letter_Semisoft_Sign + . #\Cyrillic_Small_Letter_Semisoft_Sign) + + (#\Cyrillic_Capital_Letter_Er_With_Tick + . #\Cyrillic_Small_Letter_Er_With_Tick) + + (#\Cyrillic_Capital_Letter_Ghe_With_Upturn + . #\Cyrillic_Small_Letter_Ghe_With_Upturn) + + (#\Cyrillic_Capital_Letter_Ghe_With_Stroke + . #\Cyrillic_Small_Letter_Ghe_With_Stroke) + + (#\Cyrillic_Capital_Letter_Ghe_With_Middle_Hook + . #\Cyrillic_Small_Letter_Ghe_With_Middle_Hook) + + (#\Cyrillic_Capital_Letter_Zhe_With_Descender + . #\Cyrillic_Small_Letter_Zhe_With_Descender) + + (#\Cyrillic_Capital_Letter_Ze_With_Descender + . #\Cyrillic_Small_Letter_Ze_With_Descender) + + (#\Cyrillic_Capital_Letter_Ka_With_Descender + . #\Cyrillic_Small_Letter_Ka_With_Descender) + + (#\Cyrillic_Capital_Letter_Ka_With_Vertical_Stroke + . #\Cyrillic_Small_Letter_Ka_With_Vertical_Stroke) + + (#\Cyrillic_Capital_Letter_Ka_With_Stroke + . #\Cyrillic_Small_Letter_Ka_With_Stroke) + + (#\Cyrillic_Capital_Letter_Bashkir_Ka . #\Cyrillic_Small_Letter_Bashkir_Ka) + + (#\Cyrillic_Capital_Letter_En_With_Descender + . #\Cyrillic_Small_Letter_En_With_Descender) + + (#\Cyrillic_Capital_Ligature_En_Ghe . #\Cyrillic_Small_Ligature_En_Ghe) + + (#\Cyrillic_Capital_Letter_Pe_With_Middle_Hook + . #\Cyrillic_Small_Letter_Pe_With_Middle_Hook) + + (#\Cyrillic_Capital_Letter_Abkhasian_Ha + . #\Cyrillic_Small_Letter_Abkhasian_Ha) + + (#\Cyrillic_Capital_Letter_Es_With_Descender + . #\Cyrillic_Small_Letter_Es_With_Descender) + + (#\Cyrillic_Capital_Letter_Te_With_Descender + . #\Cyrillic_Small_Letter_Te_With_Descender) + + (#\Cyrillic_Capital_Letter_Straight_U . #\Cyrillic_Small_Letter_Straight_U) + + (#\Cyrillic_Capital_Letter_Straight_U_With_Stroke + . #\Cyrillic_Small_Letter_Straight_U_With_Stroke) + + (#\Cyrillic_Capital_Letter_Ha_With_Descender + . #\Cyrillic_Small_Letter_Ha_With_Descender) + + (#\Cyrillic_Capital_Ligature_Te_Tse . #\Cyrillic_Small_Ligature_Te_Tse) + + (#\Cyrillic_Capital_Letter_Che_With_Descender + . #\Cyrillic_Small_Letter_Che_With_Descender) + + (#\Cyrillic_Capital_Letter_Che_With_Vertical_Stroke + . #\Cyrillic_Small_Letter_Che_With_Vertical_Stroke) + + (#\Cyrillic_Capital_Letter_Shha . #\Cyrillic_Small_Letter_Shha) + + (#\Cyrillic_Capital_Letter_Abkhasian_Che + . #\Cyrillic_Small_Letter_Abkhasian_Che) + + (#\Cyrillic_Capital_Letter_Abkhasian_Che_With_Descender + . #\Cyrillic_Small_Letter_Abkhasian_Che_With_Descender) + + (#\Cyrillic_Letter_Palochka . #\Cyrillic_Small_Letter_Palochka) + + (#\Cyrillic_Capital_Letter_Zhe_With_Breve + . #\Cyrillic_Small_Letter_Zhe_With_Breve) + + (#\Cyrillic_Capital_Letter_Ka_With_Hook + . #\Cyrillic_Small_Letter_Ka_With_Hook) + + (#\Cyrillic_Capital_Letter_El_With_Tail + . #\Cyrillic_Small_Letter_El_With_Tail) + + (#\Cyrillic_Capital_Letter_En_With_Hook + . #\Cyrillic_Small_Letter_En_With_Hook) + + (#\Cyrillic_Capital_Letter_En_With_Tail + . #\Cyrillic_Small_Letter_En_With_Tail) + + (#\Cyrillic_Capital_Letter_Khakassian_Che + . #\Cyrillic_Small_Letter_Khakassian_Che) + + (#\Cyrillic_Capital_Letter_Em_With_Tail + . #\Cyrillic_Small_Letter_Em_With_Tail) + + (#\Cyrillic_Capital_Letter_A_With_Breve + . #\Cyrillic_Small_Letter_A_With_Breve) + + (#\Cyrillic_Capital_Letter_A_With_Diaeresis + . #\Cyrillic_Small_Letter_A_With_Diaeresis) + + (#\Cyrillic_Capital_Ligature_A_Ie . #\Cyrillic_Small_Ligature_A_Ie) + + (#\Cyrillic_Capital_Letter_Ie_With_Breve + . #\Cyrillic_Small_Letter_Ie_With_Breve) + + (#\Cyrillic_Capital_Letter_Schwa . #\Cyrillic_Small_Letter_Schwa) + + (#\Cyrillic_Capital_Letter_Schwa_With_Diaeresis + . #\Cyrillic_Small_Letter_Schwa_With_Diaeresis) + + (#\Cyrillic_Capital_Letter_Zhe_With_Diaeresis + . #\Cyrillic_Small_Letter_Zhe_With_Diaeresis) + + (#\Cyrillic_Capital_Letter_Ze_With_Diaeresis + . #\Cyrillic_Small_Letter_Ze_With_Diaeresis) + + (#\Cyrillic_Capital_Letter_Abkhasian_Dze + . #\Cyrillic_Small_Letter_Abkhasian_Dze) + + (#\Cyrillic_Capital_Letter_I_With_Macron + . #\Cyrillic_Small_Letter_I_With_Macron) + + (#\Cyrillic_Capital_Letter_I_With_Diaeresis + . #\Cyrillic_Small_Letter_I_With_Diaeresis) + + (#\Cyrillic_Capital_Letter_O_With_Diaeresis + . #\Cyrillic_Small_Letter_O_With_Diaeresis) + + (#\Cyrillic_Capital_Letter_Barred_O . #\Cyrillic_Small_Letter_Barred_O) + + (#\Cyrillic_Capital_Letter_Barred_O_With_Diaeresis + . #\Cyrillic_Small_Letter_Barred_O_With_Diaeresis) + + (#\Cyrillic_Capital_Letter_E_With_Diaeresis + . #\Cyrillic_Small_Letter_E_With_Diaeresis) + + (#\Cyrillic_Capital_Letter_U_With_Macron + . #\Cyrillic_Small_Letter_U_With_Macron) + + (#\Cyrillic_Capital_Letter_U_With_Diaeresis + . #\Cyrillic_Small_Letter_U_With_Diaeresis) + + (#\Cyrillic_Capital_Letter_U_With_Double_Acute + . #\Cyrillic_Small_Letter_U_With_Double_Acute) + + (#\Cyrillic_Capital_Letter_Che_With_Diaeresis + . #\Cyrillic_Small_Letter_Che_With_Diaeresis) + + (#\Cyrillic_Capital_Letter_Ghe_With_Descender + . #\Cyrillic_Small_Letter_Ghe_With_Descender) + + (#\Cyrillic_Capital_Letter_Yeru_With_Diaeresis + . #\Cyrillic_Small_Letter_Yeru_With_Diaeresis) + + (#\Cyrillic_Capital_Letter_Ghe_With_Stroke_And_Hook + . #\Cyrillic_Small_Letter_Ghe_With_Stroke_And_Hook) + + (#\Cyrillic_Capital_Letter_Ha_With_Hook + . #\Cyrillic_Small_Letter_Ha_With_Hook) + + (#\Cyrillic_Capital_Letter_Ha_With_Stroke + . #\Cyrillic_Small_Letter_Ha_With_Stroke) + + (#\Cyrillic_Capital_Letter_Komi_De . #\Cyrillic_Small_Letter_Komi_De) + + (#\Cyrillic_Capital_Letter_Komi_Dje . #\Cyrillic_Small_Letter_Komi_Dje) + + (#\Cyrillic_Capital_Letter_Komi_Zje . #\Cyrillic_Small_Letter_Komi_Zje) + + (#\Cyrillic_Capital_Letter_Komi_Dzje . #\Cyrillic_Small_Letter_Komi_Dzje) + + (#\Cyrillic_Capital_Letter_Komi_Lje . #\Cyrillic_Small_Letter_Komi_Lje) + + (#\Cyrillic_Capital_Letter_Komi_Nje . #\Cyrillic_Small_Letter_Komi_Nje) + + (#\Cyrillic_Capital_Letter_Komi_Sje . #\Cyrillic_Small_Letter_Komi_Sje) + + (#\Cyrillic_Capital_Letter_Komi_Tje . #\Cyrillic_Small_Letter_Komi_Tje) + + (#\Cyrillic_Capital_Letter_Reversed_Ze . #\Cyrillic_Small_Letter_Reversed_Ze) + + (#\Cyrillic_Capital_Letter_El_With_Hook + . #\Cyrillic_Small_Letter_El_With_Hook) + + (#\Armenian_Capital_Letter_Ayb . #\Armenian_Small_Letter_Ayb) + + (#\Armenian_Capital_Letter_Ben . #\Armenian_Small_Letter_Ben) + + (#\Armenian_Capital_Letter_Gim . #\Armenian_Small_Letter_Gim) + + (#\Armenian_Capital_Letter_Da . #\Armenian_Small_Letter_Da) + + (#\Armenian_Capital_Letter_Ech . #\Armenian_Small_Letter_Ech) + + (#\Armenian_Capital_Letter_Za . #\Armenian_Small_Letter_Za) + + (#\Armenian_Capital_Letter_Eh . #\Armenian_Small_Letter_Eh) + + (#\Armenian_Capital_Letter_Et . #\Armenian_Small_Letter_Et) + + (#\Armenian_Capital_Letter_To . #\Armenian_Small_Letter_To) + + (#\Armenian_Capital_Letter_Zhe . #\Armenian_Small_Letter_Zhe) + + (#\Armenian_Capital_Letter_Ini . #\Armenian_Small_Letter_Ini) + + (#\Armenian_Capital_Letter_Liwn . #\Armenian_Small_Letter_Liwn) + + (#\Armenian_Capital_Letter_Xeh . #\Armenian_Small_Letter_Xeh) + + (#\Armenian_Capital_Letter_Ca . #\Armenian_Small_Letter_Ca) + + (#\Armenian_Capital_Letter_Ken . #\Armenian_Small_Letter_Ken) + + (#\Armenian_Capital_Letter_Ho . #\Armenian_Small_Letter_Ho) + + (#\Armenian_Capital_Letter_Ja . #\Armenian_Small_Letter_Ja) + + (#\Armenian_Capital_Letter_Ghad . #\Armenian_Small_Letter_Ghad) + + (#\Armenian_Capital_Letter_Cheh . #\Armenian_Small_Letter_Cheh) + + (#\Armenian_Capital_Letter_Men . #\Armenian_Small_Letter_Men) + + (#\Armenian_Capital_Letter_Yi . #\Armenian_Small_Letter_Yi) + + (#\Armenian_Capital_Letter_Now . #\Armenian_Small_Letter_Now) + + (#\Armenian_Capital_Letter_Sha . #\Armenian_Small_Letter_Sha) + + (#\Armenian_Capital_Letter_Vo . #\Armenian_Small_Letter_Vo) + + (#\Armenian_Capital_Letter_Cha . #\Armenian_Small_Letter_Cha) + + (#\Armenian_Capital_Letter_Peh . #\Armenian_Small_Letter_Peh) + + (#\Armenian_Capital_Letter_Jheh . #\Armenian_Small_Letter_Jheh) + + (#\Armenian_Capital_Letter_Ra . #\Armenian_Small_Letter_Ra) + + (#\Armenian_Capital_Letter_Seh . #\Armenian_Small_Letter_Seh) + + (#\Armenian_Capital_Letter_Vew . #\Armenian_Small_Letter_Vew) + + (#\Armenian_Capital_Letter_Tiwn . #\Armenian_Small_Letter_Tiwn) + + (#\Armenian_Capital_Letter_Reh . #\Armenian_Small_Letter_Reh) + + (#\Armenian_Capital_Letter_Co . #\Armenian_Small_Letter_Co) + + (#\Armenian_Capital_Letter_Yiwn . #\Armenian_Small_Letter_Yiwn) + + (#\Armenian_Capital_Letter_Piwr . #\Armenian_Small_Letter_Piwr) + + (#\Armenian_Capital_Letter_Keh . #\Armenian_Small_Letter_Keh) + + (#\Armenian_Capital_Letter_Oh . #\Armenian_Small_Letter_Oh) + + (#\Armenian_Capital_Letter_Feh . #\Armenian_Small_Letter_Feh) + + (#\U+10A0 . #\U+2D00) + (#\U+10A1 . #\U+2D01) + (#\U+10A2 . #\U+2D02) + + (#\U+10A3 . #\U+2D03) + (#\U+10A4 . #\U+2D04) + (#\U+10A5 . #\U+2D05) + + (#\U+10A6 . #\U+2D06) + (#\U+10A7 . #\U+2D07) + (#\U+10A8 . #\U+2D08) + + (#\U+10A9 . #\U+2D09) + (#\U+10AA . #\U+2D0A) + (#\U+10AB . #\U+2D0B) + + (#\U+10AC . #\U+2D0C) + (#\U+10AD . #\U+2D0D) + (#\U+10AE . #\U+2D0E) + + (#\U+10AF . #\U+2D0F) + (#\U+10B0 . #\U+2D10) + (#\U+10B1 . #\U+2D11) + + (#\U+10B2 . #\U+2D12) + (#\U+10B3 . #\U+2D13) + (#\U+10B4 . #\U+2D14) + + (#\U+10B5 . #\U+2D15) + (#\U+10B6 . #\U+2D16) + (#\U+10B7 . #\U+2D17) + + (#\U+10B8 . #\U+2D18) + (#\U+10B9 . #\U+2D19) + (#\U+10BA . #\U+2D1A) + + (#\U+10BB . #\U+2D1B) + (#\U+10BC . #\U+2D1C) + (#\U+10BD . #\U+2D1D) + + (#\U+10BE . #\U+2D1E) + (#\U+10BF . #\U+2D1F) + (#\U+10C0 . #\U+2D20) + + (#\U+10C1 . #\U+2D21) + (#\U+10C2 . #\U+2D22) + (#\U+10C3 . #\U+2D23) + + (#\U+10C4 . #\U+2D24) + (#\U+10C5 . #\U+2D25) + (#\U+1E00 . #\U+1E01) + + (#\U+1E02 . #\U+1E03) + (#\U+1E04 . #\U+1E05) + (#\U+1E06 . #\U+1E07) + + (#\U+1E08 . #\U+1E09) + (#\U+1E0A . #\U+1E0B) + (#\U+1E0C . #\U+1E0D) + + (#\U+1E0E . #\U+1E0F) + (#\U+1E10 . #\U+1E11) + (#\U+1E12 . #\U+1E13) + + (#\U+1E14 . #\U+1E15) + (#\U+1E16 . #\U+1E17) + (#\U+1E18 . #\U+1E19) + + (#\U+1E1A . #\U+1E1B) + (#\U+1E1C . #\U+1E1D) + (#\U+1E1E . #\U+1E1F) + + (#\U+1E20 . #\U+1E21) + (#\U+1E22 . #\U+1E23) + (#\U+1E24 . #\U+1E25) + + (#\U+1E26 . #\U+1E27) + (#\U+1E28 . #\U+1E29) + (#\U+1E2A . #\U+1E2B) + + (#\U+1E2C . #\U+1E2D) + (#\U+1E2E . #\U+1E2F) + (#\U+1E30 . #\U+1E31) + + (#\U+1E32 . #\U+1E33) + (#\U+1E34 . #\U+1E35) + (#\U+1E36 . #\U+1E37) + + (#\U+1E38 . #\U+1E39) + (#\U+1E3A . #\U+1E3B) + (#\U+1E3C . #\U+1E3D) + + (#\U+1E3E . #\U+1E3F) + (#\U+1E40 . #\U+1E41) + (#\U+1E42 . #\U+1E43) + + (#\U+1E44 . #\U+1E45) + (#\U+1E46 . #\U+1E47) + (#\U+1E48 . #\U+1E49) + + (#\U+1E4A . #\U+1E4B) + (#\U+1E4C . #\U+1E4D) + (#\U+1E4E . #\U+1E4F) + + (#\U+1E50 . #\U+1E51) + (#\U+1E52 . #\U+1E53) + (#\U+1E54 . #\U+1E55) + + (#\U+1E56 . #\U+1E57) + (#\U+1E58 . #\U+1E59) + (#\U+1E5A . #\U+1E5B) + + (#\U+1E5C . #\U+1E5D) + (#\U+1E5E . #\U+1E5F) + (#\U+1E60 . #\U+1E61) + + (#\U+1E62 . #\U+1E63) + (#\U+1E64 . #\U+1E65) + (#\U+1E66 . #\U+1E67) + + (#\U+1E68 . #\U+1E69) + (#\U+1E6A . #\U+1E6B) + (#\U+1E6C . #\U+1E6D) + + (#\U+1E6E . #\U+1E6F) + (#\U+1E70 . #\U+1E71) + (#\U+1E72 . #\U+1E73) + + (#\U+1E74 . #\U+1E75) + (#\U+1E76 . #\U+1E77) + (#\U+1E78 . #\U+1E79) + + (#\U+1E7A . #\U+1E7B) + (#\U+1E7C . #\U+1E7D) + (#\U+1E7E . #\U+1E7F) + + (#\U+1E80 . #\U+1E81) + (#\U+1E82 . #\U+1E83) + (#\U+1E84 . #\U+1E85) + + (#\U+1E86 . #\U+1E87) + (#\U+1E88 . #\U+1E89) + (#\U+1E8A . #\U+1E8B) + + (#\U+1E8C . #\U+1E8D) + (#\U+1E8E . #\U+1E8F) + (#\U+1E90 . #\U+1E91) + + (#\U+1E92 . #\U+1E93) + (#\U+1E94 . #\U+1E95) + (#\U+1EA0 . #\U+1EA1) + + (#\U+1EA2 . #\U+1EA3) + (#\U+1EA4 . #\U+1EA5) + (#\U+1EA6 . #\U+1EA7) + + (#\U+1EA8 . #\U+1EA9) + (#\U+1EAA . #\U+1EAB) + (#\U+1EAC . #\U+1EAD) + + (#\U+1EAE . #\U+1EAF) + (#\U+1EB0 . #\U+1EB1) + (#\U+1EB2 . #\U+1EB3) + + (#\U+1EB4 . #\U+1EB5) + (#\U+1EB6 . #\U+1EB7) + (#\U+1EB8 . #\U+1EB9) + + (#\U+1EBA . #\U+1EBB) + (#\U+1EBC . #\U+1EBD) + (#\U+1EBE . #\U+1EBF) + + (#\U+1EC0 . #\U+1EC1) + (#\U+1EC2 . #\U+1EC3) + (#\U+1EC4 . #\U+1EC5) + + (#\U+1EC6 . #\U+1EC7) + (#\U+1EC8 . #\U+1EC9) + (#\U+1ECA . #\U+1ECB) + + (#\U+1ECC . #\U+1ECD) + (#\U+1ECE . #\U+1ECF) + (#\U+1ED0 . #\U+1ED1) + + (#\U+1ED2 . #\U+1ED3) + (#\U+1ED4 . #\U+1ED5) + (#\U+1ED6 . #\U+1ED7) + + (#\U+1ED8 . #\U+1ED9) + (#\U+1EDA . #\U+1EDB) + (#\U+1EDC . #\U+1EDD) + + (#\U+1EDE . #\U+1EDF) + (#\U+1EE0 . #\U+1EE1) + (#\U+1EE2 . #\U+1EE3) + + (#\U+1EE4 . #\U+1EE5) + (#\U+1EE6 . #\U+1EE7) + (#\U+1EE8 . #\U+1EE9) + + (#\U+1EEA . #\U+1EEB) + (#\U+1EEC . #\U+1EED) + (#\U+1EEE . #\U+1EEF) + + (#\U+1EF0 . #\U+1EF1) + (#\U+1EF2 . #\U+1EF3) + (#\U+1EF4 . #\U+1EF5) + + (#\U+1EF6 . #\U+1EF7) + (#\U+1EF8 . #\U+1EF9) + (#\U+1F08 . #\U+1F00) + + (#\U+1F09 . #\U+1F01) + (#\U+1F0A . #\U+1F02) + (#\U+1F0B . #\U+1F03) + + (#\U+1F0C . #\U+1F04) + (#\U+1F0D . #\U+1F05) + (#\U+1F0E . #\U+1F06) + + (#\U+1F0F . #\U+1F07) + (#\U+1F18 . #\U+1F10) + (#\U+1F19 . #\U+1F11) + + (#\U+1F1A . #\U+1F12) + (#\U+1F1B . #\U+1F13) + (#\U+1F1C . #\U+1F14) + + (#\U+1F1D . #\U+1F15) + (#\U+1F28 . #\U+1F20) + (#\U+1F29 . #\U+1F21) + + (#\U+1F2A . #\U+1F22) + (#\U+1F2B . #\U+1F23) + (#\U+1F2C . #\U+1F24) + + (#\U+1F2D . #\U+1F25) + (#\U+1F2E . #\U+1F26) + (#\U+1F2F . #\U+1F27) + + (#\U+1F38 . #\U+1F30) + (#\U+1F39 . #\U+1F31) + (#\U+1F3A . #\U+1F32) + + (#\U+1F3B . #\U+1F33) + (#\U+1F3C . #\U+1F34) + (#\U+1F3D . #\U+1F35) + + (#\U+1F3E . #\U+1F36) + (#\U+1F3F . #\U+1F37) + (#\U+1F48 . #\U+1F40) + + (#\U+1F49 . #\U+1F41) + (#\U+1F4A . #\U+1F42) + (#\U+1F4B . #\U+1F43) + + (#\U+1F4C . #\U+1F44) + (#\U+1F4D . #\U+1F45) + (#\U+1F59 . #\U+1F51) + + (#\U+1F5B . #\U+1F53) + (#\U+1F5D . #\U+1F55) + (#\U+1F5F . #\U+1F57) + + (#\U+1F68 . #\U+1F60) + (#\U+1F69 . #\U+1F61) + (#\U+1F6A . #\U+1F62) + + (#\U+1F6B . #\U+1F63) + (#\U+1F6C . #\U+1F64) + (#\U+1F6D . #\U+1F65) + + (#\U+1F6E . #\U+1F66) + (#\U+1F6F . #\U+1F67) + (#\U+1F88 . #\U+1F80) + + (#\U+1F89 . #\U+1F81) + (#\U+1F8A . #\U+1F82) + (#\U+1F8B . #\U+1F83) + + (#\U+1F8C . #\U+1F84) + (#\U+1F8D . #\U+1F85) + (#\U+1F8E . #\U+1F86) + + (#\U+1F8F . #\U+1F87) + (#\U+1F98 . #\U+1F90) + (#\U+1F99 . #\U+1F91) + + (#\U+1F9A . #\U+1F92) + (#\U+1F9B . #\U+1F93) + (#\U+1F9C . #\U+1F94) + + (#\U+1F9D . #\U+1F95) + (#\U+1F9E . #\U+1F96) + (#\U+1F9F . #\U+1F97) + + (#\U+1FA8 . #\U+1FA0) + (#\U+1FA9 . #\U+1FA1) + (#\U+1FAA . #\U+1FA2) + + (#\U+1FAB . #\U+1FA3) + (#\U+1FAC . #\U+1FA4) + (#\U+1FAD . #\U+1FA5) + + (#\U+1FAE . #\U+1FA6) + (#\U+1FAF . #\U+1FA7) + (#\U+1FB8 . #\U+1FB0) + + (#\U+1FB9 . #\U+1FB1) + (#\U+1FBA . #\U+1F70) + (#\U+1FBB . #\U+1F71) + + (#\U+1FBC . #\U+1FB3) + (#\U+1FC8 . #\U+1F72) + (#\U+1FC9 . #\U+1F73) + + (#\U+1FCA . #\U+1F74) + (#\U+1FCB . #\U+1F75) + (#\U+1FCC . #\U+1FC3) + + (#\U+1FD8 . #\U+1FD0) + (#\U+1FD9 . #\U+1FD1) + (#\U+1FDA . #\U+1F76) + + (#\U+1FDB . #\U+1F77) + (#\U+1FE8 . #\U+1FE0) + (#\U+1FE9 . #\U+1FE1) + + (#\U+1FEA . #\U+1F7A) + (#\U+1FEB . #\U+1F7B) + (#\U+1FEC . #\U+1FE5) + + (#\U+1FF8 . #\U+1F78) + (#\U+1FF9 . #\U+1F79) + (#\U+1FFA . #\U+1F7C) + + (#\U+1FFB . #\U+1F7D) + (#\U+1FFC . #\U+1FF3) + (#\U+2132 . #\U+214E) + + (#\U+2160 . #\U+2170) + (#\U+2161 . #\U+2171) + (#\U+2162 . #\U+2172) + + (#\U+2163 . #\U+2173) + (#\U+2164 . #\U+2174) + (#\U+2165 . #\U+2175) + + (#\U+2166 . #\U+2176) + (#\U+2167 . #\U+2177) + (#\U+2168 . #\U+2178) + + (#\U+2169 . #\U+2179) + (#\U+216A . #\U+217A) + (#\U+216B . #\U+217B) + + (#\U+216C . #\U+217C) + (#\U+216D . #\U+217D) + (#\U+216E . #\U+217E) + + (#\U+216F . #\U+217F) + (#\U+2183 . #\U+2184) + (#\U+24B6 . #\U+24D0) + + (#\U+24B7 . #\U+24D1) + (#\U+24B8 . #\U+24D2) + (#\U+24B9 . #\U+24D3) + + (#\U+24BA . #\U+24D4) + (#\U+24BB . #\U+24D5) + (#\U+24BC . #\U+24D6) + + (#\U+24BD . #\U+24D7) + (#\U+24BE . #\U+24D8) + (#\U+24BF . #\U+24D9) + + (#\U+24C0 . #\U+24DA) + (#\U+24C1 . #\U+24DB) + (#\U+24C2 . #\U+24DC) + + (#\U+24C3 . #\U+24DD) + (#\U+24C4 . #\U+24DE) + (#\U+24C5 . #\U+24DF) + + (#\U+24C6 . #\U+24E0) + (#\U+24C7 . #\U+24E1) + (#\U+24C8 . #\U+24E2) + + (#\U+24C9 . #\U+24E3) + (#\U+24CA . #\U+24E4) + (#\U+24CB . #\U+24E5) + + (#\U+24CC . #\U+24E6) + (#\U+24CD . #\U+24E7) + (#\U+24CE . #\U+24E8) + + (#\U+24CF . #\U+24E9) + (#\U+2C00 . #\U+2C30) + (#\U+2C01 . #\U+2C31) + + (#\U+2C02 . #\U+2C32) + (#\U+2C03 . #\U+2C33) + (#\U+2C04 . #\U+2C34) + + (#\U+2C05 . #\U+2C35) + (#\U+2C06 . #\U+2C36) + (#\U+2C07 . #\U+2C37) + + (#\U+2C08 . #\U+2C38) + (#\U+2C09 . #\U+2C39) + (#\U+2C0A . #\U+2C3A) + + (#\U+2C0B . #\U+2C3B) + (#\U+2C0C . #\U+2C3C) + (#\U+2C0D . #\U+2C3D) + + (#\U+2C0E . #\U+2C3E) + (#\U+2C0F . #\U+2C3F) + (#\U+2C10 . #\U+2C40) + + (#\U+2C11 . #\U+2C41) + (#\U+2C12 . #\U+2C42) + (#\U+2C13 . #\U+2C43) + + (#\U+2C14 . #\U+2C44) + (#\U+2C15 . #\U+2C45) + (#\U+2C16 . #\U+2C46) + + (#\U+2C17 . #\U+2C47) + (#\U+2C18 . #\U+2C48) + (#\U+2C19 . #\U+2C49) + + (#\U+2C1A . #\U+2C4A) + (#\U+2C1B . #\U+2C4B) + (#\U+2C1C . #\U+2C4C) + + (#\U+2C1D . #\U+2C4D) + (#\U+2C1E . #\U+2C4E) + (#\U+2C1F . #\U+2C4F) + + (#\U+2C20 . #\U+2C50) + (#\U+2C21 . #\U+2C51) + (#\U+2C22 . #\U+2C52) + + (#\U+2C23 . #\U+2C53) + (#\U+2C24 . #\U+2C54) + (#\U+2C25 . #\U+2C55) + + (#\U+2C26 . #\U+2C56) + (#\U+2C27 . #\U+2C57) + (#\U+2C28 . #\U+2C58) + + (#\U+2C29 . #\U+2C59) + (#\U+2C2A . #\U+2C5A) + (#\U+2C2B . #\U+2C5B) + + (#\U+2C2C . #\U+2C5C) + (#\U+2C2D . #\U+2C5D) + (#\U+2C2E . #\U+2C5E) + + (#\U+2C60 . #\U+2C61) + (#\U+2C62 . #\Latin_Small_Letter_L_With_Middle_Tilde) + + (#\U+2C63 . #\U+1D7D) + (#\U+2C64 . #\Latin_Small_Letter_R_With_Tail) + + (#\U+2C67 . #\U+2C68) + (#\U+2C69 . #\U+2C6A) + (#\U+2C6B . #\U+2C6C) + + (#\U+2C75 . #\U+2C76) + (#\U+2C80 . #\U+2C81) + (#\U+2C82 . #\U+2C83) + + (#\U+2C84 . #\U+2C85) + (#\U+2C86 . #\U+2C87) + (#\U+2C88 . #\U+2C89) + + (#\U+2C8A . #\U+2C8B) + (#\U+2C8C . #\U+2C8D) + (#\U+2C8E . #\U+2C8F) + + (#\U+2C90 . #\U+2C91) + (#\U+2C92 . #\U+2C93) + (#\U+2C94 . #\U+2C95) + + (#\U+2C96 . #\U+2C97) + (#\U+2C98 . #\U+2C99) + (#\U+2C9A . #\U+2C9B) + + (#\U+2C9C . #\U+2C9D) + (#\U+2C9E . #\U+2C9F) + (#\U+2CA0 . #\U+2CA1) + + (#\U+2CA2 . #\U+2CA3) + (#\U+2CA4 . #\U+2CA5) + (#\U+2CA6 . #\U+2CA7) + + (#\U+2CA8 . #\U+2CA9) + (#\U+2CAA . #\U+2CAB) + (#\U+2CAC . #\U+2CAD) + + (#\U+2CAE . #\U+2CAF) + (#\U+2CB0 . #\U+2CB1) + (#\U+2CB2 . #\U+2CB3) + + (#\U+2CB4 . #\U+2CB5) + (#\U+2CB6 . #\U+2CB7) + (#\U+2CB8 . #\U+2CB9) + + (#\U+2CBA . #\U+2CBB) + (#\U+2CBC . #\U+2CBD) + (#\U+2CBE . #\U+2CBF) + + (#\U+2CC0 . #\U+2CC1) + (#\U+2CC2 . #\U+2CC3) + (#\U+2CC4 . #\U+2CC5) + + (#\U+2CC6 . #\U+2CC7) + (#\U+2CC8 . #\U+2CC9) + (#\U+2CCA . #\U+2CCB) + + (#\U+2CCC . #\U+2CCD) + (#\U+2CCE . #\U+2CCF) + (#\U+2CD0 . #\U+2CD1) + + (#\U+2CD2 . #\U+2CD3) + (#\U+2CD4 . #\U+2CD5) + (#\U+2CD6 . #\U+2CD7) + + (#\U+2CD8 . #\U+2CD9) + (#\U+2CDA . #\U+2CDB) + (#\U+2CDC . #\U+2CDD) + + (#\U+2CDE . #\U+2CDF) + (#\U+2CE0 . #\U+2CE1) + (#\U+2CE2 . #\U+2CE3) + + (#\U+FF21 . #\U+FF41) + (#\U+FF22 . #\U+FF42) + (#\U+FF23 . #\U+FF43) + + (#\U+FF24 . #\U+FF44) + (#\U+FF25 . #\U+FF45) + (#\U+FF26 . #\U+FF46) + + (#\U+FF27 . #\U+FF47) + (#\U+FF28 . #\U+FF48) + (#\U+FF29 . #\U+FF49) + + (#\U+FF2A . #\U+FF4A) + (#\U+FF2B . #\U+FF4B) + (#\U+FF2C . #\U+FF4C) + + (#\U+FF2D . #\U+FF4D) + (#\U+FF2E . #\U+FF4E) + (#\U+FF2F . #\U+FF4F) + + (#\U+FF30 . #\U+FF50) + (#\U+FF31 . #\U+FF51) + (#\U+FF32 . #\U+FF52) + + (#\U+FF33 . #\U+FF53) + (#\U+FF34 . #\U+FF54) + (#\U+FF35 . #\U+FF55) + + (#\U+FF36 . #\U+FF56) + (#\U+FF37 . #\U+FF57) + (#\U+FF38 . #\U+FF58) + + (#\U+FF39 . #\U+FF59) + (#\U+FF3A . #\U+FF5A) + (#\U+10400 . #\U+10428) + + (#\U+10401 . #\U+10429) + (#\U+10402 . #\U+1042A) + (#\U+10403 . #\U+1042B) + + (#\U+10404 . #\U+1042C) + (#\U+10405 . #\U+1042D) + (#\U+10406 . #\U+1042E) + + (#\U+10407 . #\U+1042F) + (#\U+10408 . #\U+10430) + (#\U+10409 . #\U+10431) + + (#\U+1040A . #\U+10432) + (#\U+1040B . #\U+10433) + (#\U+1040C . #\U+10434) + + (#\U+1040D . #\U+10435) + (#\U+1040E . #\U+10436) + (#\U+1040F . #\U+10437) + + (#\U+10410 . #\U+10438) + (#\U+10411 . #\U+10439) + (#\U+10412 . #\U+1043A) + + (#\U+10413 . #\U+1043B) + (#\U+10414 . #\U+1043C) + (#\U+10415 . #\U+1043D) + + (#\U+10416 . #\U+1043E) + (#\U+10417 . #\U+1043F) + (#\U+10418 . #\U+10440) + + (#\U+10419 . #\U+10441) + (#\U+1041A . #\U+10442) + (#\U+1041B . #\U+10443) + + (#\U+1041C . #\U+10444) + (#\U+1041D . #\U+10445) + (#\U+1041E . #\U+10446) + + (#\U+1041F . #\U+10447) + (#\U+10420 . #\U+10448) + (#\U+10421 . #\U+10449) + + (#\U+10422 . #\U+1044A) + (#\U+10423 . #\U+1044B) + (#\U+10424 . #\U+1044C) + + (#\U+10425 . #\U+1044D) + (#\U+10426 . #\U+1044E) + (#\U+10427 . #\U+1044F) + )) + (max-upper #\u+0000) + (max-lower #\u+0000)) + (declare (optimize speed)) ;; make sure everything gets inlined that needs to be. + (dolist (pair mapping) + (destructuring-bind (upper . lower) pair + (when (char> upper max-upper) + (setq max-upper upper)) + (when (char> lower max-lower) + (setq max-lower lower)))) + (let* ((upper-to-lower (make-array (the fixnum (1+ (the fixnum (char-code max-upper)))) :element-type '(signed-byte 16))) + (lower-to-upper (make-array (the fixnum (1+ (the fixnum (char-code max-lower)))) :element-type '(signed-byte 16)))) + (dolist (pair mapping) + (destructuring-bind (upper . lower) pair + (let* ((upper-code (char-code upper)) + (lower-code (char-code lower)) + (diff (- lower-code upper-code))) + (declare (type (mod #x110000) upper-code lower-code) + (type (signed-byte 16) diff)) + (setf (aref upper-to-lower upper-code) diff + (aref lower-to-upper lower-code) (the fixnum (- diff)))))) + (do* ((upper (char-code #\A) (1+ upper)) + (lower (char-code #\a) (1+ lower))) + ((> upper (char-code #\Z))) + (setf (aref upper-to-lower upper) (- lower upper) + (aref lower-to-upper lower) (- upper lower))) + (setq *lower-to-upper* lower-to-upper + *upper-to-lower* upper-to-lower) + nil)) + +(eval-when (:compile-toplevel) + (declaim (inline %char-code-case-fold))) + +(defun %char-code-case-fold (code table) + (declare (type (mod #x110000) code) + (type (simple-array (signed-byte 16) (*)) table)) + (if (>= code (length table)) + code + (locally (declare (optimize (speed 3) (safety 0))) + (the fixnum (+ code (the (signed-byte 16) (aref table code))))))) + +(defun %char-code-upcase (code) + (%char-code-case-fold code *lower-to-upper*)) + +(defun char-upcase (c) + "Return CHAR converted to upper-case if that is possible. Don't convert + lowercase eszet (U+DF)." + (declare (optimize speed)) ; so that %char-code-case-fold inlines + (code-char (the valid-char-code (%char-code-case-fold (char-code c) *lower-to-upper*)))) + + + + +(defun %char-code-downcase (code) + (declare (type (mod #x110000) code)) + (let* ((table *upper-to-lower*)) + (declare (type (simple-array (signed-byte 16) (*)) table)) + (if (>= code (length table)) + code + (locally (declare (optimize (speed 3) (safety 0))) + (the fixnum (+ code (the (signed-byte 16) (aref table code)))))))) + + +;;;True for a-z, and maybe other things. +(defun lower-case-p (c) + "The argument must be a character object; LOWER-CASE-P returns T if the + argument is a lower-case character, NIL otherwise." + (let* ((code (char-code c)) + (table *lower-to-upper*)) + (declare (type (mod #x110000) code) + (type (simple-array (signed-byte 16) (*)) table)) + (if (< code (length table)) + (not (eql 0 (the (signed-byte 16) (aref table code))))))) + + + +(defstatic *alpha-char-bits* + (let* ((bits (make-array #x2fa1e :element-type 'bit))) + (declare (optimize speed)) ;; make sure everything gets inlined that needs to be. + (dolist (range '((#x0041 . #x005A) + (#x0061 . #x007A) + #x00AA + #x00B5 + #x00BA + (#x00C0 . #x00D6) + (#x00D8 . #x00F6) + (#x00F8 . #x01BA) + #x01BB + (#x01BC . #x01BF) + (#x01C0 . #x01C3) + (#x01C4 . #x0293) + #x0294 + (#x0295 . #x02AF) + (#x02B0 . #x02C1) + (#x02C6 . #x02D1) + (#x02E0 . #x02E4) + #x02EC + #x02EE + #x0345 + (#x0370 . #x0373) + #x0374 + (#x0376 . #x0377) + #x037A + (#x037B . #x037D) + #x0386 + (#x0388 . #x038A) + #x038C + (#x038E . #x03A1) + (#x03A3 . #x03F5) + (#x03F7 . #x0481) + (#x048A . #x0523) + (#x0531 . #x0556) + #x0559 + (#x0561 . #x0587) + (#x05B0 . #x05BD) + #x05BF + (#x05C1 . #x05C2) + (#x05C4 . #x05C5) + #x05C7 + (#x05D0 . #x05EA) + (#x05F0 . #x05F2) + (#x0610 . #x061A) + (#x0621 . #x063F) + #x0640 + (#x0641 . #x064A) + (#x064B . #x0657) + (#x0659 . #x065E) + (#x066E . #x066F) + #x0670 + (#x0671 . #x06D3) + #x06D5 + (#x06D6 . #x06DC) + (#x06E1 . #x06E4) + (#x06E5 . #x06E6) + (#x06E7 . #x06E8) + #x06ED + (#x06EE . #x06EF) + (#x06FA . #x06FC) + #x06FF + #x0710 + #x0711 + (#x0712 . #x072F) + (#x0730 . #x073F) + (#x074D . #x07A5) + (#x07A6 . #x07B0) + #x07B1 + (#x07CA . #x07EA) + (#x07F4 . #x07F5) + #x07FA + (#x0901 . #x0902) + #x0903 + (#x0904 . #x0939) + #x093D + (#x093E . #x0940) + (#x0941 . #x0948) + (#x0949 . #x094C) + #x0950 + (#x0958 . #x0961) + (#x0962 . #x0963) + #x0971 + #x0972 + (#x097B . #x097F) + #x0981 + (#x0982 . #x0983) + (#x0985 . #x098C) + (#x098F . #x0990) + (#x0993 . #x09A8) + (#x09AA . #x09B0) + #x09B2 + (#x09B6 . #x09B9) + #x09BD + (#x09BE . #x09C0) + (#x09C1 . #x09C4) + (#x09C7 . #x09C8) + (#x09CB . #x09CC) + #x09CE + #x09D7 + (#x09DC . #x09DD) + (#x09DF . #x09E1) + (#x09E2 . #x09E3) + (#x09F0 . #x09F1) + (#x0A01 . #x0A02) + #x0A03 + (#x0A05 . #x0A0A) + (#x0A0F . #x0A10) + (#x0A13 . #x0A28) + (#x0A2A . #x0A30) + (#x0A32 . #x0A33) + (#x0A35 . #x0A36) + (#x0A38 . #x0A39) + (#x0A3E . #x0A40) + (#x0A41 . #x0A42) + (#x0A47 . #x0A48) + (#x0A4B . #x0A4C) + #x0A51 + (#x0A59 . #x0A5C) + #x0A5E + (#x0A70 . #x0A71) + (#x0A72 . #x0A74) + #x0A75 + (#x0A81 . #x0A82) + #x0A83 + (#x0A85 . #x0A8D) + (#x0A8F . #x0A91) + (#x0A93 . #x0AA8) + (#x0AAA . #x0AB0) + (#x0AB2 . #x0AB3) + (#x0AB5 . #x0AB9) + #x0ABD + (#x0ABE . #x0AC0) + (#x0AC1 . #x0AC5) + (#x0AC7 . #x0AC8) + #x0AC9 + (#x0ACB . #x0ACC) + #x0AD0 + (#x0AE0 . #x0AE1) + (#x0AE2 . #x0AE3) + #x0B01 + (#x0B02 . #x0B03) + (#x0B05 . #x0B0C) + (#x0B0F . #x0B10) + (#x0B13 . #x0B28) + (#x0B2A . #x0B30) + (#x0B32 . #x0B33) + (#x0B35 . #x0B39) + #x0B3D + #x0B3E + #x0B3F + #x0B40 + (#x0B41 . #x0B44) + (#x0B47 . #x0B48) + (#x0B4B . #x0B4C) + #x0B56 + #x0B57 + (#x0B5C . #x0B5D) + (#x0B5F . #x0B61) + (#x0B62 . #x0B63) + #x0B71 + #x0B82 + #x0B83 + (#x0B85 . #x0B8A) + (#x0B8E . #x0B90) + (#x0B92 . #x0B95) + (#x0B99 . #x0B9A) + #x0B9C + (#x0B9E . #x0B9F) + (#x0BA3 . #x0BA4) + (#x0BA8 . #x0BAA) + (#x0BAE . #x0BB9) + (#x0BBE . #x0BBF) + #x0BC0 + (#x0BC1 . #x0BC2) + (#x0BC6 . #x0BC8) + (#x0BCA . #x0BCC) + #x0BD0 + #x0BD7 + (#x0C01 . #x0C03) + (#x0C05 . #x0C0C) + (#x0C0E . #x0C10) + (#x0C12 . #x0C28) + (#x0C2A . #x0C33) + (#x0C35 . #x0C39) + #x0C3D + (#x0C3E . #x0C40) + (#x0C41 . #x0C44) + (#x0C46 . #x0C48) + (#x0C4A . #x0C4C) + (#x0C55 . #x0C56) + (#x0C58 . #x0C59) + (#x0C60 . #x0C61) + (#x0C62 . #x0C63) + (#x0C82 . #x0C83) + (#x0C85 . #x0C8C) + (#x0C8E . #x0C90) + (#x0C92 . #x0CA8) + (#x0CAA . #x0CB3) + (#x0CB5 . #x0CB9) + #x0CBD + #x0CBE + #x0CBF + (#x0CC0 . #x0CC4) + #x0CC6 + (#x0CC7 . #x0CC8) + (#x0CCA . #x0CCB) + #x0CCC + (#x0CD5 . #x0CD6) + #x0CDE + (#x0CE0 . #x0CE1) + (#x0CE2 . #x0CE3) + (#x0D02 . #x0D03) + (#x0D05 . #x0D0C) + (#x0D0E . #x0D10) + (#x0D12 . #x0D28) + (#x0D2A . #x0D39) + #x0D3D + (#x0D3E . #x0D40) + (#x0D41 . #x0D44) + (#x0D46 . #x0D48) + (#x0D4A . #x0D4C) + #x0D57 + (#x0D60 . #x0D61) + (#x0D62 . #x0D63) + (#x0D7A . #x0D7F) + (#x0D82 . #x0D83) + (#x0D85 . #x0D96) + (#x0D9A . #x0DB1) + (#x0DB3 . #x0DBB) + #x0DBD + (#x0DC0 . #x0DC6) + (#x0DCF . #x0DD1) + (#x0DD2 . #x0DD4) + #x0DD6 + (#x0DD8 . #x0DDF) + (#x0DF2 . #x0DF3) + (#x0E01 . #x0E30) + #x0E31 + (#x0E32 . #x0E33) + (#x0E34 . #x0E3A) + (#x0E40 . #x0E45) + #x0E46 + #x0E4D + (#x0E81 . #x0E82) + #x0E84 + (#x0E87 . #x0E88) + #x0E8A + #x0E8D + (#x0E94 . #x0E97) + (#x0E99 . #x0E9F) + (#x0EA1 . #x0EA3) + #x0EA5 + #x0EA7 + (#x0EAA . #x0EAB) + (#x0EAD . #x0EB0) + #x0EB1 + (#x0EB2 . #x0EB3) + (#x0EB4 . #x0EB9) + (#x0EBB . #x0EBC) + #x0EBD + (#x0EC0 . #x0EC4) + #x0EC6 + #x0ECD + (#x0EDC . #x0EDD) + #x0F00 + (#x0F40 . #x0F47) + (#x0F49 . #x0F6C) + (#x0F71 . #x0F7E) + #x0F7F + (#x0F80 . #x0F81) + (#x0F88 . #x0F8B) + (#x0F90 . #x0F97) + (#x0F99 . #x0FBC) + (#x1000 . #x102A) + (#x102B . #x102C) + (#x102D . #x1030) + #x1031 + (#x1032 . #x1036) + #x1038 + (#x103B . #x103C) + (#x103D . #x103E) + #x103F + (#x1050 . #x1055) + (#x1056 . #x1057) + (#x1058 . #x1059) + (#x105A . #x105D) + (#x105E . #x1060) + #x1061 + #x1062 + (#x1065 . #x1066) + (#x1067 . #x1068) + (#x106E . #x1070) + (#x1071 . #x1074) + (#x1075 . #x1081) + #x1082 + (#x1083 . #x1084) + (#x1085 . #x1086) + #x108E + (#x10A0 . #x10C5) + (#x10D0 . #x10FA) + #x10FC + (#x1100 . #x1159) + (#x115F . #x11A2) + (#x11A8 . #x11F9) + (#x1200 . #x1248) + (#x124A . #x124D) + (#x1250 . #x1256) + #x1258 + (#x125A . #x125D) + (#x1260 . #x1288) + (#x128A . #x128D) + (#x1290 . #x12B0) + (#x12B2 . #x12B5) + (#x12B8 . #x12BE) + #x12C0 + (#x12C2 . #x12C5) + (#x12C8 . #x12D6) + (#x12D8 . #x1310) + (#x1312 . #x1315) + (#x1318 . #x135A) + #x135F + (#x1380 . #x138F) + (#x13A0 . #x13F4) + (#x1401 . #x166C) + (#x166F . #x1676) + (#x1681 . #x169A) + (#x16A0 . #x16EA) + (#x16EE . #x16F0) + (#x1700 . #x170C) + (#x170E . #x1711) + (#x1712 . #x1713) + (#x1720 . #x1731) + (#x1732 . #x1733) + (#x1740 . #x1751) + (#x1752 . #x1753) + (#x1760 . #x176C) + (#x176E . #x1770) + (#x1772 . #x1773) + (#x1780 . #x17B3) + #x17B6 + (#x17B7 . #x17BD) + (#x17BE . #x17C5) + #x17C6 + (#x17C7 . #x17C8) + #x17D7 + #x17DC + (#x1820 . #x1842) + #x1843 + (#x1844 . #x1877) + (#x1880 . #x18A8) + #x18A9 + #x18AA + (#x1900 . #x191C) + (#x1920 . #x1922) + (#x1923 . #x1926) + (#x1927 . #x1928) + (#x1929 . #x192B) + (#x1930 . #x1931) + #x1932 + (#x1933 . #x1938) + (#x1950 . #x196D) + (#x1970 . #x1974) + (#x1980 . #x19A9) + (#x19B0 . #x19C0) + (#x19C1 . #x19C7) + (#x19C8 . #x19C9) + (#x1A00 . #x1A16) + (#x1A17 . #x1A18) + (#x1A19 . #x1A1B) + (#x1B00 . #x1B03) + #x1B04 + (#x1B05 . #x1B33) + #x1B35 + (#x1B36 . #x1B3A) + #x1B3B + #x1B3C + (#x1B3D . #x1B41) + #x1B42 + #x1B43 + (#x1B45 . #x1B4B) + (#x1B80 . #x1B81) + #x1B82 + (#x1B83 . #x1BA0) + #x1BA1 + (#x1BA2 . #x1BA5) + (#x1BA6 . #x1BA7) + (#x1BA8 . #x1BA9) + (#x1BAE . #x1BAF) + (#x1C00 . #x1C23) + (#x1C24 . #x1C2B) + (#x1C2C . #x1C33) + (#x1C34 . #x1C35) + (#x1C4D . #x1C4F) + (#x1C5A . #x1C77) + (#x1C78 . #x1C7D) + (#x1D00 . #x1D2B) + (#x1D2C . #x1D61) + (#x1D62 . #x1D77) + #x1D78 + (#x1D79 . #x1D9A) + (#x1D9B . #x1DBF) + (#x1E00 . #x1F15) + (#x1F18 . #x1F1D) + (#x1F20 . #x1F45) + (#x1F48 . #x1F4D) + (#x1F50 . #x1F57) + #x1F59 + #x1F5B + #x1F5D + (#x1F5F . #x1F7D) + (#x1F80 . #x1FB4) + (#x1FB6 . #x1FBC) + #x1FBE + (#x1FC2 . #x1FC4) + (#x1FC6 . #x1FCC) + (#x1FD0 . #x1FD3) + (#x1FD6 . #x1FDB) + (#x1FE0 . #x1FEC) + (#x1FF2 . #x1FF4) + (#x1FF6 . #x1FFC) + #x2071 + #x207F + (#x2090 . #x2094) + #x2102 + #x2107 + (#x210A . #x2113) + #x2115 + (#x2119 . #x211D) + #x2124 + #x2126 + #x2128 + (#x212A . #x212D) + (#x212F . #x2134) + (#x2135 . #x2138) + #x2139 + (#x213C . #x213F) + (#x2145 . #x2149) + #x214E + (#x2160 . #x2182) + (#x2183 . #x2184) + (#x2185 . #x2188) + (#x24B6 . #x24E9) + (#x2C00 . #x2C2E) + (#x2C30 . #x2C5E) + (#x2C60 . #x2C6F) + (#x2C71 . #x2C7C) + #x2C7D + (#x2C80 . #x2CE4) + (#x2D00 . #x2D25) + (#x2D30 . #x2D65) + #x2D6F + (#x2D80 . #x2D96) + (#x2DA0 . #x2DA6) + (#x2DA8 . #x2DAE) + (#x2DB0 . #x2DB6) + (#x2DB8 . #x2DBE) + (#x2DC0 . #x2DC6) + (#x2DC8 . #x2DCE) + (#x2DD0 . #x2DD6) + (#x2DD8 . #x2DDE) + (#x2DE0 . #x2DFF) + #x2E2F + #x3005 + #x3006 + #x3007 + (#x3021 . #x3029) + (#x3031 . #x3035) + (#x3038 . #x303A) + #x303B + #x303C + (#x3041 . #x3096) + (#x309D . #x309E) + #x309F + (#x30A1 . #x30FA) + (#x30FC . #x30FE) + #x30FF + (#x3105 . #x312D) + (#x3131 . #x318E) + (#x31A0 . #x31B7) + (#x31F0 . #x31FF) + (#x3400 . #x4DB5) + (#x4E00 . #x9FC3) + (#xA000 . #xA014) + #xA015 + (#xA016 . #xA48C) + (#xA500 . #xA60B) + #xA60C + (#xA610 . #xA61F) + (#xA62A . #xA62B) + (#xA640 . #xA65F) + (#xA662 . #xA66D) + #xA66E + #xA67F + (#xA680 . #xA697) + (#xA717 . #xA71F) + (#xA722 . #xA76F) + #xA770 + (#xA771 . #xA787) + #xA788 + (#xA78B . #xA78C) + (#xA7FB . #xA801) + (#xA803 . #xA805) + (#xA807 . #xA80A) + (#xA80C . #xA822) + (#xA823 . #xA824) + (#xA825 . #xA826) + #xA827 + (#xA840 . #xA873) + (#xA880 . #xA881) + (#xA882 . #xA8B3) + (#xA8B4 . #xA8C3) + (#xA90A . #xA925) + (#xA926 . #xA92A) + (#xA930 . #xA946) + (#xA947 . #xA951) + #xA952 + (#xAA00 . #xAA28) + (#xAA29 . #xAA2E) + (#xAA2F . #xAA30) + (#xAA31 . #xAA32) + (#xAA33 . #xAA34) + (#xAA35 . #xAA36) + (#xAA40 . #xAA42) + #xAA43 + (#xAA44 . #xAA4B) + #xAA4C + #xAA4D + (#xAC00 . #xD7A3) + (#xF900 . #xFA2D) + (#xFA30 . #xFA6A) + (#xFA70 . #xFAD9) + (#xFB00 . #xFB06) + (#xFB13 . #xFB17) + #xFB1D + #xFB1E + (#xFB1F . #xFB28) + (#xFB2A . #xFB36) + (#xFB38 . #xFB3C) + #xFB3E + (#xFB40 . #xFB41) + (#xFB43 . #xFB44) + (#xFB46 . #xFBB1) + (#xFBD3 . #xFD3D) + (#xFD50 . #xFD8F) + (#xFD92 . #xFDC7) + (#xFDF0 . #xFDFB) + (#xFE70 . #xFE74) + (#xFE76 . #xFEFC) + (#xFF21 . #xFF3A) + (#xFF41 . #xFF5A) + (#xFF66 . #xFF6F) + #xFF70 + (#xFF71 . #xFF9D) + (#xFF9E . #xFF9F) + (#xFFA0 . #xFFBE) + (#xFFC2 . #xFFC7) + (#xFFCA . #xFFCF) + (#xFFD2 . #xFFD7) + (#xFFDA . #xFFDC) + (#x10000 . #x1000B) + (#x1000D . #x10026) + (#x10028 . #x1003A) + (#x1003C . #x1003D) + (#x1003F . #x1004D) + (#x10050 . #x1005D) + (#x10080 . #x100FA) + (#x10140 . #x10174) + (#x10280 . #x1029C) + (#x102A0 . #x102D0) + (#x10300 . #x1031E) + (#x10330 . #x10340) + #x10341 + (#x10342 . #x10349) + #x1034A + (#x10380 . #x1039D) + (#x103A0 . #x103C3) + (#x103C8 . #x103CF) + (#x103D1 . #x103D5) + (#x10400 . #x1044F) + (#x10450 . #x1049D) + (#x10800 . #x10805) + #x10808 + (#x1080A . #x10835) + (#x10837 . #x10838) + #x1083C + #x1083F + (#x10900 . #x10915) + (#x10920 . #x10939) + #x10A00 + (#x10A01 . #x10A03) + (#x10A05 . #x10A06) + (#x10A0C . #x10A0F) + (#x10A10 . #x10A13) + (#x10A15 . #x10A17) + (#x10A19 . #x10A33) + (#x12000 . #x1236E) + (#x12400 . #x12462) + (#x1D400 . #x1D454) + (#x1D456 . #x1D49C) + (#x1D49E . #x1D49F) + #x1D4A2 + (#x1D4A5 . #x1D4A6) + (#x1D4A9 . #x1D4AC) + (#x1D4AE . #x1D4B9) + #x1D4BB + (#x1D4BD . #x1D4C3) + (#x1D4C5 . #x1D505) + (#x1D507 . #x1D50A) + (#x1D50D . #x1D514) + (#x1D516 . #x1D51C) + (#x1D51E . #x1D539) + (#x1D53B . #x1D53E) + (#x1D540 . #x1D544) + #x1D546 + (#x1D54A . #x1D550) + (#x1D552 . #x1D6A5) + (#x1D6A8 . #x1D6C0) + (#x1D6C2 . #x1D6DA) + (#x1D6DC . #x1D6FA) + (#x1D6FC . #x1D714) + (#x1D716 . #x1D734) + (#x1D736 . #x1D74E) + (#x1D750 . #x1D76E) + (#x1D770 . #x1D788) + (#x1D78A . #x1D7A8) + (#x1D7AA . #x1D7C2) + (#x1D7C4 . #x1D7CB) + (#x20000 . #x2A6D6) + (#x2F800 . #x2FA1D)) + bits) + (let* ((low (if (atom range) range (car range))) + (high (1+ (if (atom range) range (cdr range))))) + (do* ((i low (1+ i))) + ((= i high)) + (setf (sbit bits i) 1)))))) + + +(defun alpha-char-p (c) + "The argument must be a character object. ALPHA-CHAR-P returns T if the + argument is an alphabetic character; otherwise NIL." + (let* ((code (char-code c)) + (bits *alpha-char-bits*)) + (declare (type (mod #x110000) code) + (simple-bit-vector bits)) + (and (< code (length bits)) + (not (eql 0 (sbit bits code)))))) + + +;;; def-accessors type-tracking stuff. Used by inspector +(defvar *def-accessor-types* nil) + +(defun add-accessor-types (types names) + (dolist (type types) + (let ((cell (or (assq type *def-accessor-types*) + (car (push (cons type nil) *def-accessor-types*))))) + (setf (cdr cell) (if (vectorp names) names (%list-to-uvector nil names)))))) + + +;;; Some simple explicit storage management for cons cells + +(def-standard-initial-binding *cons-pool* (%cons-pool nil)) + +(defun cheap-cons (car cdr) + (let* ((pool *cons-pool*) + (cons (pool.data pool))) + (if cons + (locally (declare (type cons cons)) + (setf (pool.data pool) (cdr cons) + (car cons) car + (cdr cons) cdr) + cons) + (cons car cdr)))) + +(defun free-cons (cons) + (when (consp cons) + (locally (declare (type cons cons)) + (setf (car cons) nil + (cdr cons) nil) + (let* ((pool *cons-pool*) + (freelist (pool.data pool))) + (setf (pool.data pool) cons + (cdr cons) freelist))))) + +(defun cheap-copy-list (list) + (let ((l list) + res) + (loop + (when (atom l) + (return (nreconc res l))) + (setq res (cheap-cons (pop l) res))))) + +(defun cheap-list (&rest args) + (declare (dynamic-extent args)) + (cheap-copy-list args)) + +;;; Works for dotted lists +(defun cheap-free-list (list) + (let ((l list) + next-l) + (loop + (setq next-l (cdr l)) + (free-cons l) + (when (atom (setq l next-l)) + (return))))) + +(defmacro pop-and-free (place) + (setq place (require-type place 'symbol)) ; all I need for now. + (let ((list (gensym)) + (cdr (gensym))) + `(let* ((,list ,place) + (,cdr (cdr ,list))) + (prog1 + (car ,list) + (setf ,place ,cdr) + (free-cons ,list))))) + +;;; Support for defresource & using-resource macros +(defun make-resource (constructor &key destructor initializer) + (%cons-resource constructor destructor initializer)) + +(defun allocate-resource (resource) + (setq resource (require-type resource 'resource)) + (with-lock-grabbed ((resource.lock resource)) + (let ((pool (resource.pool resource)) + res) + (let ((data (pool.data pool))) + (when data + (setf res (car data) + (pool.data pool) (cdr (the cons data))) + (free-cons data))) + (if res + (let ((initializer (resource.initializer resource))) + (when initializer + (funcall initializer res))) + (setq res (funcall (resource.constructor resource)))) + res))) + +(defun free-resource (resource instance) + (setq resource (require-type resource 'resource)) + (with-lock-grabbed ((resource.lock resource)) + (let ((pool (resource.pool resource)) + (destructor (resource.destructor resource))) + (when destructor + (funcall destructor instance)) + (setf (pool.data pool) + (cheap-cons instance (pool.data pool))))) + resource) + +(defun valid-char-code-p (code) + (and (typep code 'fixnum) + (locally (declare (fixnum code)) + (and + (>= code 0) + (< code #x110000) + (or (< code #xfffe) + (> code #xffff)) + (or (< code #xd800) + (> code #xdfff)))))) + + +(defpackage #.(ftd-interface-package-name + (backend-target-foreign-type-data *target-backend*)) + (:nicknames "OS") + (:use "COMMON-LISP")) + + + Index: /branches/new-random/level-1/l1-boot-1.lisp =================================================================== --- /branches/new-random/level-1/l1-boot-1.lisp (revision 13309) +++ /branches/new-random/level-1/l1-boot-1.lisp (revision 13309) @@ -0,0 +1,124 @@ +;;;-*-Mode: LISP; Package: CCL -*- +;;; +;;; Copyright (C) 2009 Clozure Associates +;;; Copyright (C) 1994-2001 Digitool, Inc +;;; This file is part of Clozure CL. +;;; +;;; Clozure CL is licensed under the terms of the Lisp Lesser GNU Public +;;; License , known as the LLGPL and distributed with Clozure CL as the +;;; file "LICENSE". The LLGPL consists of a preamble and the LGPL, +;;; which is distributed with Clozure CL as the file "LGPL". Where these +;;; conflict, the preamble takes precedence. +;;; +;;; Clozure CL is referenced in the preamble as the "LIBRARY." +;;; +;;; The LLGPL is also available online at +;;; http://opensource.franz.com/preamble.html + +;; L1-boot.lisp + +(in-package "CCL") + +(defparameter *gensym-counter* 0 "counter for generating unique GENSYM symbols") + +(defparameter *inhibit-greeting* nil) + +;the below 3 variables are expected to be redefined in the user's init file +(defparameter *short-site-name* nil) +(defparameter *long-site-name* nil) +#| +(defparameter *machine-instance* nil) +|# + +(defun lisp-implementation-type () + #+clozure-common-lisp "Clozure Common Lisp" + #-clozure-common-lisp "OpenMCL") + + +(defparameter *platform-os-names* + `((,platform-os-vxworks . :vxwork) + (,platform-os-linux . :linux) + (,platform-os-solaris . :solaris) + (,platform-os-darwin . :darwin) + (,platform-os-freebsd . :freebsd) + (,platform-os-windows . :windows))) + +(defparameter *platform-cpu-names* + `((,platform-cpu-ppc . :ppc) + (,platform-cpu-sparc . :sparc) + (,platform-cpu-x86 . :x86))) + +(defun host-platform () + (let* ((pf (%get-kernel-global 'host-platform))) + (values + (or (cdr (assoc (logand pf platform-os-mask) + *platform-os-names*)) + :unknown) + (if (logtest pf platform-word-size-mask) + 64 + 32) + (or (cdr (assoc (logand pf platform-cpu-mask) + *platform-cpu-names*)) + :unknown)))) + + +(defun platform-description () + (multiple-value-bind (os bits cpu) (host-platform) + (format nil "~a~a~d" (string-capitalize os) cpu bits))) + +(defun lisp-implementation-version () + (%str-cat "Version " (format nil *openmcl-version* (platform-description)))) + + + + +(defun replace-base-translation (host-dir new-base-dir) + (let* ((host (pathname-host host-dir)) + (device (pathname-device new-base-dir)) + (host-dir (full-pathname host-dir)) + (trans (logical-pathname-translations host)) + (host-wild (merge-pathnames "**/*.*" host-dir))) + (setq host-dir (pathname-directory host-dir)) + (setq new-base-dir (pathname-directory new-base-dir)) + (setf + (logical-pathname-translations host) + (mapcar + #'(lambda (pair) + (let ((rhs (cadr pair))) + (if (and (physical-pathname-p rhs) + (pathname-match-p rhs host-wild)) + (list (car pair) + (merge-pathnames + (make-pathname + :defaults nil + :device device + :directory (append new-base-dir + (nthcdr (length host-dir) + (pathname-directory rhs)))) + rhs)) + pair))) + trans)))) + +(defun set-ccl-directory (path) + (replace-base-translation "ccl:" (translate-logical-pathname path))) + + + + +; only do these if exist +(defun init-logical-directories () + (replace-base-translation "home:" (user-homedir-pathname)) + (replace-base-translation "ccl:" (ccl-directory))) + +(push #'init-logical-directories *lisp-system-pointer-functions*) + + +(catch :toplevel + (init-logical-directories) + ) + + + + + + Index: /branches/new-random/level-1/l1-boot-2.lisp =================================================================== --- /branches/new-random/level-1/l1-boot-2.lisp (revision 13309) +++ /branches/new-random/level-1/l1-boot-2.lisp (revision 13309) @@ -0,0 +1,332 @@ +;;;-*- Mode: Lisp; Package: CCL -*- +;;; +;;; Copyright (C) 2009 Clozure Associates +;;; Copyright (C) 1994-2001 Digitool, Inc +;;; This file is part of Clozure CL. +;;; +;;; Clozure CL is licensed under the terms of the Lisp Lesser GNU Public +;;; License , known as the LLGPL and distributed with Clozure CL as the +;;; file "LICENSE". The LLGPL consists of a preamble and the LGPL, +;;; which is distributed with Clozure CL as the file "LGPL". Where these +;;; conflict, the preamble takes precedence. +;;; +;;; Clozure CL is referenced in the preamble as the "LIBRARY." +;;; +;;; The LLGPL is also available online at +;;; http://opensource.franz.com/preamble.html + +;; l1-boot-2.lisp +;; Second part of l1-boot + +(in-package "CCL") + +(macrolet ((l1-load (name) + (let* ((namestring + (concatenate 'simple-base-string + "./l1-fasls/" + (string name) + (namestring (backend-target-fasl-pathname + *target-backend*))))) + `(let* ((*loading-file-source-file* *loading-file-source-file*) + (*loading-toplevel-location* *loading-toplevel-location*)) + (%fasload ,namestring)))) + (bin-load (name) + (let* ((namestring + (concatenate 'simple-base-string + "./bin/" + (string name) + (namestring (backend-target-fasl-pathname + *target-backend*))))) + `(let* ((*loading-file-source-file* *loading-file-source-file*) + (*loading-toplevel-location* *loading-toplevel-location*)) + (%fasload ,namestring))))) + + +(catch :toplevel + #+ppc-target + (l1-load "ppc-error-signal") + #+x86-target + (l1-load "x86-error-signal") + (l1-load "l1-error-signal") + (l1-load "l1-sockets") + (setq *LEVEL-1-LOADED* t)) + +#+ppc-target +(defun altivec-available-p () + "Return non-NIL if AltiVec is available." + (not (eql (%get-kernel-global 'ppc::altivec-present) 0))) + +#+ppc-target +(defloadvar *altivec-available* (altivec-available-p) + "This variable is intitialized each time a Clozure CL session starts based +on information provided by the lisp kernel. Its value is true if AltiVec is +present and false otherwise. This variable shouldn't be set by user code.") + + +(defstatic *auto-flush-streams* ()) +(def-ccl-pointers *auto-flush-streams* () (setq *auto-flush-streams* nil)) +(defstatic *auto-flush-streams-lock* (make-lock)) + + +(defvar *batch-flag* (not (eql (%get-kernel-global 'batch-flag) 0))) +(defloadvar *quiet-flag* nil) +(defvar *terminal-input* ()) +(defvar *terminal-output* ()) +(defvar *stdin* ()) +(defvar *stdout* ()) +(defvar *stderr* ()) + + +(defun set-basic-stream-prototype (class) + (when (subtypep class 'basic-stream) + (setf (%class.prototype class) (or (%class.prototype class) + (allocate-basic-stream class))) + (dolist (subclass (class-direct-subclasses class)) + (set-basic-stream-prototype subclass)))) + +(set-basic-stream-prototype (find-class 'basic-stream)) + + +;;; The hard parts here have to do with setting up *TERMINAL-IO*. +;;; Note that opening /dev/tty can fail, and that failure would +;;; be reported as a negative return value from FD-OPEN. +;;; It's pretty important that nothing signals an error here, +;;; since there may not be any valid streams to write an error +;;; message to. + +(defglobal *interactive-streams-initialized* nil) + +(defun initialize-interactive-streams () + (let* ((encoding (lookup-character-encoding *terminal-character-encoding-name*)) + (encoding-name (if encoding (character-encoding-name encoding)))) + (setq *stdin* (make-fd-stream #-windows-target 0 + #+windows-target (%ptr-to-int + (#_GetStdHandle #$STD_INPUT_HANDLE)) + :basic t + :sharing :lock + :direction :input + :interactive (not *batch-flag*) + :encoding encoding-name + #+windows-target :line-termination #+windows-target :cp/m)) + (setq *stdout* (make-fd-stream #-windows-target 1 + #+windows-target (%ptr-to-int + (#_GetStdHandle #$STD_OUTPUT_HANDLE)) + :basic t :direction :output :sharing :lock :encoding encoding-name #+windows-target :line-termination #+windows-target :msdos)) + (setq *stderr* (make-fd-stream #-windows-target 2 + #+windows-target (%ptr-to-int + (#_GetStdHandle #$STD_ERROR_HANDLE)) + :basic t :direction :output :sharing :lock :encoding encoding-name #+windows-target :line-termination #+windows-target :crlf)) + (if *batch-flag* + (let* ((tty-fd + #-windows-target + (let* ((fd (fd-open "/dev/tty" #$O_RDWR))) + (if (>= fd 0) fd))) + (can-use-tty #-windows-target (and tty-fd (eql (tcgetpgrp tty-fd) (getpid))))) + (if can-use-tty + (setq + *terminal-input* (make-fd-stream tty-fd + :basic t + :direction :input + :interactive t + :sharing :lock + :encoding encoding-name) + *terminal-output* (make-fd-stream tty-fd :basic t :direction :output :sharing :lock :encoding encoding-name) + *terminal-io* (make-echoing-two-way-stream + *terminal-input* *terminal-output*)) + (progn + (when tty-fd (fd-close tty-fd)) + (setq *terminal-input* *stdin* + *terminal-output* *stdout* + *terminal-io* (make-two-way-stream + *terminal-input* *terminal-output*)))) + (setq *standard-input* *stdin* + *standard-output* *stdout*)) + (progn + (setq *terminal-input* *stdin* + *terminal-output* *stdout* + *terminal-io* (make-echoing-two-way-stream + *terminal-input* *terminal-output*)) + (setq *standard-input* (make-synonym-stream '*terminal-io*) + *standard-output* (make-synonym-stream '*terminal-io*)))) + (setq *error-output* (if *batch-flag* + (make-synonym-stream '*stderr*) + (make-synonym-stream '*terminal-io*))) + (setq *query-io* (make-synonym-stream '*terminal-io*)) + (setq *debug-io* *query-io*) + (setq *trace-output* *standard-output*) + (push *stdout* *auto-flush-streams*) + (setf (input-stream-shared-resource *terminal-input*) + (make-shared-resource "Shared Terminal Input"))) + (setq *interactive-streams-initialized* t)) + +(initialize-interactive-streams) + +(def-standard-initial-binding *standard-input*) +(def-standard-initial-binding *standard-output*) +(def-standard-initial-binding *error-output*) +(def-standard-initial-binding *trace-output*) +(def-standard-initial-binding *debug-io*) +(def-standard-initial-binding *query-io*) + + +(defun set-terminal-encoding (encoding-name) + #+windows-target (when (atom encoding-name) + (setq encoding-name `(:character-encoding ,encoding-name + :line-termination :crlf))) + (let* ((exformat (normalize-external-format t encoding-name))) + (setf (stream-external-format *stdin*) exformat + (stream-external-format *stdout*) exformat + (stream-external-format *stderr*) exformat + (stream-external-format *terminal-input*) exformat + (stream-external-format *terminal-output*) exformat)) + encoding-name) + +(catch :toplevel + (macrolet ((l1-load-provide (module path) + `(let* ((*package* *package*)) + (l1-load ,path) + (provide ,module))) + (bin-load-provide (module path) + `(let* ((*package* *package*)) + (bin-load ,path) + (provide ,module)))) + (bin-load-provide "SORT" "sort") + (bin-load-provide "NUMBERS" "numbers") + + (bin-load-provide "SUBPRIMS" "subprims") + #+ppc32-target + (bin-load-provide "PPC32-ARCH" "ppc32-arch") + #+ppc64-target + (bin-load-provide "PPC64-ARCH" "ppc64-arch") + #+x86-target + (bin-load-provide "X8632-ARCH" "x8632-arch") + #+x86-target + (bin-load-provide "X8664-ARCH" "x8664-arch") + (bin-load-provide "VREG" "vreg") + + #+ppc-target + (bin-load-provide "PPC-ASM" "ppc-asm") + + (bin-load-provide "VINSN" "vinsn") + (bin-load-provide "REG" "reg") + + #+ppc-target + (bin-load-provide "PPC-LAP" "ppc-lap") + (bin-load-provide "BACKEND" "backend") + (bin-load-provide "NX2" "nx2") + + #+ppc-target + (provide "PPC2") ; Lie, load the module manually + + #+x86-target + (provide "X862") + + (l1-load-provide "NX" "nx") + + #+ppc-target + (bin-load "ppc2") + + #+x86-target + (bin-load "x862") + + (bin-load-provide "LEVEL-2" "level-2") + (bin-load-provide "MACROS" "macros") + (bin-load-provide "SETF" "setf") + (bin-load-provide "SETF-RUNTIME" "setf-runtime") + (bin-load-provide "FORMAT" "format") + (bin-load-provide "STREAMS" "streams") + (bin-load-provide "OPTIMIZERS" "optimizers") + (bin-load-provide "DEFSTRUCT-MACROS" "defstruct-macros") + (bin-load-provide "DEFSTRUCT-LDS" "defstruct-lds") + (bin-load-provide "NFCOMP" "nfcomp") + (bin-load-provide "BACKQUOTE" "backquote") + (bin-load-provide "BACKTRACE-LDS" "backtrace-lds") + (bin-load-provide "BACKTRACE" "backtrace") + (bin-load-provide "READ" "read") + (bin-load-provide "ARRAYS-FRY" "arrays-fry") + (bin-load-provide "APROPOS" "apropos") + (bin-load-provide "SOURCE-FILES" "source-files") + + #+ppc-target + (progn + (bin-load-provide "PPC-DISASSEMBLE" "ppc-disassemble") + (bin-load-provide "PPC-LAPMACROS" "ppc-lapmacros")) + + #+x86-target + (progn + (bin-load-provide "X86-DISASSEMBLE" "x86-disassemble") + (bin-load-provide "X86-LAPMACROS" "x86-lapmacros")) + + + (bin-load-provide "FOREIGN-TYPES" "foreign-types") + (install-standard-foreign-types *host-ftd*) + + #+(and ppc32-target linux-target) + (bin-load-provide "FFI-LINUXPPC32" "ffi-linuxppc32") + #+(and ppc32-target darwin-target) + (bin-load-provide "FFI-DARWINPPC32" "ffi-darwinppc32") + #+(and ppc64-target darwin-target) + (bin-load-provide "FFI-DARWINPPC64" "ffi-darwinppc64") + #+(and ppc64-target linux-target) + (bin-load-provide "FFI-LINUXPPC64" "ffi-linuxppc64") + #+(and x8632-target darwin-target) + (bin-load-provide "FFI-DARWINX8632" "ffi-darwinx8632") + #+(and x8664-target linux-target) + (bin-load-provide "FFI-LINUXX8664" "ffi-linuxx8664") + #+(and x8664-target darwin-target) + (bin-load-provide "FFI-DARWINX8664" "ffi-darwinx8664") + #+(and x8664-target freebsd-target) + (bin-load-provide "FFI-FREEBSDX8664" "ffi-freebsdx8664") + #+(and x8664-target solaris-target) + (bin-load-provide "FFI-SOLARISX8664" "ffi-solarisx8664") + #+win64-target + (bin-load-provide "FFI-WIN64" "ffi-win64") + #+linuxx8632-target + (bin-load-provide "FFI-LINUXX8632" "ffi-linuxx8632") + #+win32-target + (bin-load-provide "FFI-WIN32" "ffi-win32") + #+solarisx8632-target + (bin-load-provide "FFI-SOLARISX8632" "ffi-solarisx8632") + #+freebsdx8632-target + (bin-load-provide "FFI-FREEBSDX8632" "ffi-freebsdx8632") + + + ;; Knock wood: all standard reader macros and no non-standard + ;; reader macros are defined at this point. + (setq *readtable* (copy-readtable *readtable*)) + + (bin-load-provide "DB-IO" "db-io") + + (canonicalize-foreign-type-ordinals *host-ftd*) + + (bin-load-provide "CASE-ERROR" "case-error") + (bin-load-provide "ENCAPSULATE" "encapsulate") + (bin-load-provide "METHOD-COMBINATION" "method-combination") + (bin-load-provide "MISC" "misc") + (bin-load-provide "PPRINT" "pprint") + (bin-load-provide "DUMPLISP" "dumplisp") + (bin-load-provide "PATHNAMES" "pathnames") + (bin-load-provide "TIME" "time") + (bin-load-provide "COMPILE-CCL" "compile-ccl") + (bin-load-provide "ARGLIST" "arglist") + (bin-load-provide "EDIT-CALLERS" "edit-callers") + (bin-load-provide "DESCRIBE" "describe") + (bin-load-provide "COVER" "cover") + (bin-load-provide "LEAKS" "leaks") + (bin-load-provide "CORE-FILES" "core-files") + (bin-load-provide "MCL-COMPAT" "mcl-compat") + (require "LOOP") + (bin-load-provide "CCL-EXPORT-SYMS" "ccl-export-syms") + (l1-load-provide "VERSION" "version") + (require "JP-ENCODE") + (require "LISPEQU") ; Shouldn't need this at load time ... + ) + (setq *%fasload-verbose* nil) + ) +) + + + + + + Index: /branches/new-random/level-1/l1-boot-3.lisp =================================================================== --- /branches/new-random/level-1/l1-boot-3.lisp (revision 13309) +++ /branches/new-random/level-1/l1-boot-3.lisp (revision 13309) @@ -0,0 +1,33 @@ +;;;-*- Mode: Lisp; Package: CCL -*- +;;; +;;; Copyright (C) 2009 Clozure Associates +;;; Copyright (C) 1994-2001 Digitool, Inc +;;; This file is part of Clozure CL. +;;; +;;; Clozure CL is licensed under the terms of the Lisp Lesser GNU Public +;;; License , known as the LLGPL and distributed with Clozure CL as the +;;; file "LICENSE". The LLGPL consists of a preamble and the LGPL, +;;; which is distributed with Clozure CL as the file "LGPL". Where these +;;; conflict, the preamble takes precedence. +;;; +;;; Clozure CL is referenced in the preamble as the "LIBRARY." +;;; +;;; The LLGPL is also available online at +;;; http://opensource.franz.com/preamble.html + +;;; l1-boot-3.lisp +;;; Third part of l1-boot + +(in-package "CCL") + +(catch :toplevel + (or (find-package "COMMON-LISP-USER") + (make-package "COMMON-LISP-USER" :use '("COMMON-LISP" "CCL") :NICKNAMES '("CL-USER"))) +) + +(set-periodic-task-interval .33) +(setq cmain xcmain) +(setq %err-disp %xerr-disp) + +;;;end of l1-boot-3.lisp + Index: /branches/new-random/level-1/l1-boot-lds.lisp =================================================================== --- /branches/new-random/level-1/l1-boot-lds.lisp (revision 13309) +++ /branches/new-random/level-1/l1-boot-lds.lisp (revision 13309) @@ -0,0 +1,123 @@ +;;;-*-Mode: LISP; Package: CCL -*- +;;; +;;; Copyright (C) 2009 Clozure Associates +;;; Copyright (C) 1994-2001 Digitool, Inc +;;; This file is part of Clozure CL. +;;; +;;; Clozure CL is licensed under the terms of the Lisp Lesser GNU Public +;;; License , known as the LLGPL and distributed with Clozure CL as the +;;; file "LICENSE". The LLGPL consists of a preamble and the LGPL, +;;; which is distributed with Clozure CL as the file "LGPL". Where these +;;; conflict, the preamble takes precedence. +;;; +;;; Clozure CL is referenced in the preamble as the "LIBRARY." +;;; +;;; The LLGPL is also available online at +;;; http://opensource.franz.com/preamble.html + + +; l1-boot-lds.lisp + +(in-package "CCL") + + + + + +(defun command-line-arguments () + *command-line-argument-list*) + +(defun startup-ccl (&optional init-file) + (with-simple-restart (abort "Abort startup.") + (let ((init-files (if (listp init-file) init-file (list init-file)))) + (dolist (init-file init-files) + (with-simple-restart (continue "Skip loading init file.") + (when (load init-file :if-does-not-exist nil :verbose nil) + (return))))) + (flet ((eval-string (s) + (with-simple-restart (continue "Skip evaluation of ~a" s) + (eval (read-from-string s)))) + (load-file (name) + (with-simple-restart (continue "Skip loading ~s" name) + (load name)))) + (dolist (p *lisp-startup-parameters*) + (let* ((param (cdr p))) + (case (car p) + (:gc-threshold + (multiple-value-bind (n last) (parse-integer param :junk-allowed t) + (when n + (if (< last (length param)) + (case (schar param last) + ((#\k #\K) (setq n (ash n 10))) + ((#\m #\M) (setq n (ash n 20))))) + (set-lisp-heap-gc-threshold n) + (use-lisp-heap-gc-threshold)))) + (:eval (eval-string param)) + (:load (load-file param)))))))) + + +(defun listener-function () + (progn + (unless (or *inhibit-greeting* *quiet-flag*) + (format t "~&Welcome to ~A ~A!~%" + (lisp-implementation-type) + (lisp-implementation-version))) + (toplevel-loop))) + + +(defun make-mcl-listener-process (procname + input-stream + output-stream + cleanup-function + &key + (initial-function #'listener-function) + (close-streams t) + (class 'process) + (control-stack-size *default-control-stack-size*) + (auto-flush t) + (value-stack-size *default-value-stack-size*) + (temp-stack-size *default-temp-stack-size*) + (echoing t) + (process)) + (let ((p (if (typep process class) + (progn + (setf (process-thread process) + (new-thread procname control-stack-size value-stack-size temp-stack-size)) + process) + (make-process procname + :class class + :stack-size control-stack-size + :vstack-size value-stack-size + :tstack-size temp-stack-size)))) + (process-preset p #'(lambda () + (let ((*terminal-io* + (if echoing + (make-echoing-two-way-stream + input-stream output-stream) + (make-two-way-stream + input-stream output-stream)))) + (unwind-protect + (progn + (when auto-flush + (add-auto-flush-stream output-stream)) + (let* ((shared-input + (input-stream-shared-resource + input-stream))) + (when shared-input + (setf (shared-resource-primary-owner + shared-input) + *current-process*))) + (application-ui-operation + *application* + :note-current-package *package*) + (funcall initial-function)) + (remove-auto-flush-stream output-stream) + (funcall cleanup-function) + (when close-streams + (close input-stream) + (close output-stream)))))) + (process-enable p) + p)) + + +; End of l1-boot-lds.lisp Index: /branches/new-random/level-1/l1-callbacks.lisp =================================================================== --- /branches/new-random/level-1/l1-callbacks.lisp (revision 13309) +++ /branches/new-random/level-1/l1-callbacks.lisp (revision 13309) @@ -0,0 +1,154 @@ +;;;-*- Mode: Lisp; Package: CCL -*- +;;; +;;; Copyright (C) 2009 Clozure Associates +;;; Copyright (C) 1994-2001 Digitool, Inc +;;; This file is part of Clozure CL. +;;; +;;; Clozure CL is licensed under the terms of the Lisp Lesser GNU Public +;;; License , known as the LLGPL and distributed with Clozure CL as the +;;; file "LICENSE". The LLGPL consists of a preamble and the LGPL, +;;; which is distributed with Clozure CL as the file "LGPL". Where these +;;; conflict, the preamble takes precedence. +;;; +;;; Clozure CL is referenced in the preamble as the "LIBRARY." +;;; +;;; The LLGPL is also available online at +;;; http://opensource.franz.com/preamble.html + +;;; l1-callbacks.lisp + +(in-package "CCL") + +(defstatic *callback-lock* (make-lock)) + + +;;; (defcallback ...) expands into a call to this function. +(defun define-callback-function (lisp-function &optional doc-string (without-interrupts t) info &aux name trampoline) + (unless (functionp lisp-function) + (setq lisp-function (require-type lisp-function 'function))) + (unless (and (symbolp (setq name (function-name lisp-function))) + ;;Might as well err out now before do any _Newptr's... + (not (constant-symbol-p name))) + (report-bad-arg name '(and symbol (not (satisfies constantp))))) + (with-lock-grabbed (*callback-lock*) + (let ((len (length %pascal-functions%))) + (declare (fixnum len)) + (when (and name (boundp name)) + (let ((old-tramp (symbol-value name))) + (dotimes (i len) + (let ((pfe (%svref %pascal-functions% i))) + (when (and (vectorp pfe) + (eql old-tramp (pfe.routine-descriptor pfe))) + + (setf (pfe.without-interrupts pfe) without-interrupts) + (setf (pfe.lisp-function pfe) lisp-function) + (setq trampoline old-tramp)))))) + (unless trampoline + (let ((index (dotimes (i (length %pascal-functions%) + (let* ((new-len (if (zerop len) 32 (* len 2))) + (new-pf (make-array (the fixnum new-len)))) + (declare (fixnum new-len)) + (dotimes (i len) + (setf (%svref new-pf i) (%svref %pascal-functions% i))) + (do ((i len (1+ i))) + ((>= i new-len)) + (declare (fixnum i)) + (setf (%svref new-pf i) nil)) + (setq %pascal-functions% new-pf) + len)) + (unless (%svref %pascal-functions% i) + (return i))))) + (setq trampoline (make-callback-trampoline index info)) + (setf (%svref %pascal-functions% index) + (%cons-pfe trampoline info lisp-function name without-interrupts)))))) + ;;(%proclaim-special name) ; + ;; already done by defpascal expansion + (when name (set name trampoline)) + (record-source-file name 'callback) + (when (and doc-string *save-doc-strings*) + (setf (documentation name 'variable) doc-string)) + (when *fasload-print* (format t "~&~S~%" name)) + (or name trampoline)) + +(defun %lookup-pascal-function (index) + (declare (optimize (speed 3) (safety 0))) + (with-lock-grabbed (*callback-lock*) + (let* ((pfe (svref %pascal-functions% index))) + (values (pfe.lisp-function pfe) + (pfe.without-interrupts pfe) + (pfe.trace-p pfe))))) + + +(defun %callback-function (pointer) + (if (typep pointer 'symbol) + (setq pointer (symbol-value pointer))) + (with-lock-grabbed (*callback-lock*) + (let* ((index (dotimes (i (length %pascal-functions%)) + (when (eql (pfe.routine-descriptor (svref %pascal-functions% i)) pointer) + (return i))))) + (when index + (let* ((entry (svref %pascal-functions% index))) + (pfe.lisp-function entry)))))) + + +(defun %delete-pascal-function (pointer) + (with-lock-grabbed (*callback-lock*) + (let* ((index (dotimes (i (length %pascal-functions%)) + (when (eql (pfe.routine-descriptor (svref %pascal-functions% i)) pointer) + (return i))))) + (when index + (let* ((entry (svref %pascal-functions% index)) + (sym (pfe.sym entry))) + (setf (svref %pascal-functions% index) nil) + (when (and sym + (boundp sym) + (eql (symbol-value sym) + (pfe.routine-descriptor entry))) + (set (symbol-value sym) nil)) + (free (pfe.routine-descriptor entry)) + t))))) + + +;; The kernel only really knows how to call back to one function, +;; and you're looking at it ... +(defun %pascal-functions% (index args-ptr-fixnum) + (declare (optimize (speed 3) (safety 0))) + (multiple-value-bind (lisp-function without-interrupts *callback-trace-p*) + (%lookup-pascal-function index) + (declare (special *callback-trace-p*)) + (if without-interrupts + (without-interrupts (funcall lisp-function args-ptr-fixnum)) + (funcall lisp-function args-ptr-fixnum)))) + +(defstatic *callback-alloc-lock* (make-lock)) + +;;; +(defun %make-executable-page () + #-windows-target + (#_mmap (%null-ptr) + (#_getpagesize) + (logior #$PROT_READ #$PROT_WRITE #$PROT_EXEC) + (logior #$MAP_PRIVATE #$MAP_ANON) + -1 + 0) + #+windows-target + (#_VirtualAlloc (%null-ptr) + (ash 1 16) ; should use GetSystemInfo + (logior #$MEM_RESERVE #$MEM_COMMIT) + #$PAGE_EXECUTE_READWRITE) + ) + +(defstatic *available-bytes-for-callbacks* 0) +(defstatic *current-callback-page* nil) + +(defun reset-callback-storage () + (setq *available-bytes-for-callbacks* #-windows-target (#_getpagesize) #+windows-target (ash 1 16) + *current-callback-page* (%make-executable-page))) + +(defun %allocate-callback-pointer (n) + (with-lock-grabbed (*callback-alloc-lock*) + (when (< *available-bytes-for-callbacks* n) + (reset-callback-storage)) + (decf *available-bytes-for-callbacks* n) + (values (%inc-ptr *current-callback-page* *available-bytes-for-callbacks*)))) + Index: /branches/new-random/level-1/l1-cl-package.lisp =================================================================== --- /branches/new-random/level-1/l1-cl-package.lisp (revision 13309) +++ /branches/new-random/level-1/l1-cl-package.lisp (revision 13309) @@ -0,0 +1,1022 @@ +;;;-*- Mode: Lisp; Package: CCL -*- +;;; +;;; Copyright (C) 2009 Clozure Associates +;;; Copyright (C) 1994-2001 Digitool, Inc +;;; This file is part of Clozure CL. +;;; +;;; Clozure CL is licensed under the terms of the Lisp Lesser GNU Public +;;; License , known as the LLGPL and distributed with Clozure CL as the +;;; file "LICENSE". The LLGPL consists of a preamble and the LGPL, +;;; which is distributed with Clozure CL as the file "LGPL". Where these +;;; conflict, the preamble takes precedence. +;;; +;;; Clozure CL is referenced in the preamble as the "LIBRARY." +;;; +;;; The LLGPL is also available online at +;;; http://opensource.franz.com/preamble.html + +; l1-cl-package.lisp + +(in-package "CCL") + + +(eval-when (:compile-toplevel :execute) + (defconstant %lisp-symbols% + '("&ALLOW-OTHER-KEYS" + "&AUX" + "&BODY" + "&ENVIRONMENT" + "&KEY" + "&OPTIONAL" + "&REST" + "&WHOLE" + "*" + "**" + "***" + "*BREAK-ON-SIGNALS*" + "*COMPILE-FILE-PATHNAME*" + "*COMPILE-FILE-TRUENAME*" + "*COMPILE-PRINT*" + "*COMPILE-VERBOSE*" + "*DEBUG-IO*" + "*DEBUGGER-HOOK*" + "*DEFAULT-PATHNAME-DEFAULTS*" + "*ERROR-OUTPUT*" + "*FEATURES*" + "*GENSYM-COUNTER*" + "*LOAD-PATHNAME*" + "*LOAD-PRINT*" + "*LOAD-TRUENAME*" + "*LOAD-VERBOSE*" + "*MACROEXPAND-HOOK*" + "*MODULES*" + "*PACKAGE*" + "*PRINT-ARRAY*" + "*PRINT-BASE*" + "*PRINT-CASE*" + "*PRINT-CIRCLE*" + "*PRINT-ESCAPE*" + "*PRINT-GENSYM*" + "*PRINT-LENGTH*" + "*PRINT-LEVEL*" + "*PRINT-LINES*" + "*PRINT-MISER-WIDTH*" + "*PRINT-PPRINT-DISPATCH*" + "*PRINT-PRETTY*" + "*PRINT-RADIX*" + "*PRINT-READABLY*" + "*PRINT-RIGHT-MARGIN*" + "*QUERY-IO*" + "*RANDOM-STATE*" + "*READ-BASE*" + "*READ-DEFAULT-FLOAT-FORMAT*" + "*READ-EVAL*" + "*READ-SUPPRESS*" + "*READTABLE*" + "*STANDARD-INPUT*" + "*STANDARD-OUTPUT*" + "*TERMINAL-IO*" + "*TRACE-OUTPUT*" + "+" + "++" + "+++" + "-" + "/" + "//" + "///" + "/=" + "1+" + "1-" + "<" + "<=" + "=" + ">" + ">=" + "ABORT" + "ABS" + "ACONS" + "ACOS" + "ACOSH" + "ADD-METHOD" + "ADJOIN" + "ADJUST-ARRAY" + "ADJUSTABLE-ARRAY-P" + "ALLOCATE-INSTANCE" + "ALPHA-CHAR-P" + "ALPHANUMERICP" + "AND" + "APPEND" + "APPLY" + "APROPOS" + "APROPOS-LIST" + "AREF" + "ARITHMETIC-ERROR" + "ARITHMETIC-ERROR-OPERANDS" + "ARITHMETIC-ERROR-OPERATION" + "ARRAY" + "ARRAY-DIMENSION" + "ARRAY-DIMENSION-LIMIT" + "ARRAY-DIMENSIONS" + "ARRAY-DISPLACEMENT" + "ARRAY-ELEMENT-TYPE" + "ARRAY-HAS-FILL-POINTER-P" + "ARRAY-IN-BOUNDS-P" + "ARRAY-RANK" + "ARRAY-RANK-LIMIT" + "ARRAY-ROW-MAJOR-INDEX" + "ARRAY-TOTAL-SIZE" + "ARRAY-TOTAL-SIZE-LIMIT" + "ARRAYP" + "ASH" + "ASIN" + "ASINH" + "ASSERT" + "ASSOC" + "ASSOC-IF" + "ASSOC-IF-NOT" + "ATAN" + "ATANH" + "ATOM" + "BASE-CHAR" + "BASE-STRING" + "BIGNUM" + "BIT" + "BIT-AND" + "BIT-ANDC1" + "BIT-ANDC2" + "BIT-EQV" + "BIT-IOR" + "BIT-NAND" + "BIT-NOR" + "BIT-NOT" + "BIT-ORC1" + "BIT-ORC2" + "BIT-VECTOR" + "BIT-VECTOR-P" + "BIT-XOR" + "BLOCK" + "BOOLE" + "BOOLE-1" + "BOOLE-2" + "BOOLE-AND" + "BOOLE-ANDC1" + "BOOLE-ANDC2" + "BOOLE-C1" + "BOOLE-C2" + "BOOLE-CLR" + "BOOLE-EQV" + "BOOLE-IOR" + "BOOLE-NAND" + "BOOLE-NOR" + "BOOLE-ORC1" + "BOOLE-ORC2" + "BOOLE-SET" + "BOOLE-XOR" + "BOOLEAN" + "BOTH-CASE-P" + "BOUNDP" + "BREAK" + "BROADCAST-STREAM" + "BROADCAST-STREAM-STREAMS" + "BUILT-IN-CLASS" + "BUTLAST" + "BYTE" + "BYTE-POSITION" + "BYTE-SIZE" + "CAAAAR" + "CAAADR" + "CAAAR" + "CAADAR" + "CAADDR" + "CAADR" + "CAAR" + "CADAAR" + "CADADR" + "CADAR" + "CADDAR" + "CADDDR" + "CADDR" + "CADR" + "CALL-ARGUMENTS-LIMIT" + "CALL-METHOD" + "CALL-NEXT-METHOD" + "CAR" + "CASE" + "CATCH" + "CCASE" + "CDAAAR" + "CDAADR" + "CDAAR" + "CDADAR" + "CDADDR" + "CDADR" + "CDAR" + "CDDAAR" + "CDDADR" + "CDDAR" + "CDDDAR" + "CDDDDR" + "CDDDR" + "CDDR" + "CDR" + "CEILING" + "CELL-ERROR" + "CELL-ERROR-NAME" + "CERROR" + "CHANGE-CLASS" + "CHAR" + "CHAR-CODE" + "CHAR-CODE-LIMIT" + "CHAR-DOWNCASE" + "CHAR-EQUAL" + "CHAR-GREATERP" + "CHAR-INT" + "CHAR-LESSP" + "CHAR-NAME" + "CHAR-NOT-EQUAL" + "CHAR-NOT-GREATERP" + "CHAR-NOT-LESSP" + "CHAR-UPCASE" + "CHAR/=" + "CHAR<" + "CHAR<=" + "CHAR=" + "CHAR>" + "CHAR>=" + "CHARACTER" + "CHARACTERP" + "CHECK-TYPE" + "CIS" + "CLASS" + "CLASS-NAME" + "CLASS-OF" + "CLEAR-INPUT" + "CLEAR-OUTPUT" + "CLOSE" + "CLRHASH" + "CODE-CHAR" + "COERCE" + "COMPILATION-SPEED" + "COMPILE" + "COMPILE-FILE" + "COMPILE-FILE-PATHNAME" + "COMPILED-FUNCTION" + "COMPILED-FUNCTION-P" + "COMPILER-MACRO" + "COMPILER-MACRO-FUNCTION" + "COMPLEMENT" + "COMPLEX" + "COMPLEXP" + "COMPUTE-APPLICABLE-METHODS" + "COMPUTE-RESTARTS" + "CONCATENATE" + "CONCATENATED-STREAM" + "CONCATENATED-STREAM-STREAMS" + "COND" + "CONDITION" + "CONJUGATE" + "CONS" + "CONSP" + "CONSTANTLY" + "CONSTANTP" + "CONTINUE" + "CONTROL-ERROR" + "COPY-ALIST" + "COPY-LIST" + "COPY-PPRINT-DISPATCH" + "COPY-READTABLE" + "COPY-SEQ" + "COPY-STRUCTURE" + "COPY-SYMBOL" + "COPY-TREE" + "COS" + "COSH" + "COUNT" + "COUNT-IF" + "COUNT-IF-NOT" + "CTYPECASE" + "DEBUG" + "DECF" + "DECLAIM" + "DECLARATION" + "DECLARE" + "DECODE-FLOAT" + "DECODE-UNIVERSAL-TIME" + "DEFCLASS" + "DEFCONSTANT" + "DEFGENERIC" + "DEFINE-COMPILER-MACRO" + "DEFINE-CONDITION" + "DEFINE-METHOD-COMBINATION" + "DEFINE-MODIFY-MACRO" + "DEFINE-SETF-EXPANDER" + "DEFINE-SYMBOL-MACRO" + "DEFMACRO" + "DEFMETHOD" + "DEFPACKAGE" + "DEFPARAMETER" + "DEFSETF" + "DEFSTRUCT" + "DEFTYPE" + "DEFUN" + "DEFVAR" + "DELETE" + "DELETE-DUPLICATES" + "DELETE-FILE" + "DELETE-IF" + "DELETE-IF-NOT" + "DELETE-PACKAGE" + "DENOMINATOR" + "DEPOSIT-FIELD" + "DESCRIBE" + "DESCRIBE-OBJECT" + "DESTRUCTURING-BIND" + "DIGIT-CHAR" + "DIGIT-CHAR-P" + "DIRECTORY" + "DIRECTORY-NAMESTRING" + "DISASSEMBLE" + "DIVISION-BY-ZERO" + "DO" + "DO*" + "DO-ALL-SYMBOLS" + "DO-EXTERNAL-SYMBOLS" + "DO-SYMBOLS" + "DOCUMENTATION" + "DOLIST" + "DOTIMES" + "DOUBLE-FLOAT" + "DOUBLE-FLOAT-EPSILON" + "DOUBLE-FLOAT-NEGATIVE-EPSILON" + "DPB" + "DRIBBLE" + "DYNAMIC-EXTENT" + "ECASE" + "ECHO-STREAM" + "ECHO-STREAM-INPUT-STREAM" + "ECHO-STREAM-OUTPUT-STREAM" + "ED" + "EIGHTH" + "ELT" + "ENCODE-UNIVERSAL-TIME" + "END-OF-FILE" + "ENDP" + "ENOUGH-NAMESTRING" + "ENSURE-DIRECTORIES-EXIST" + "ENSURE-GENERIC-FUNCTION" + "EQ" + "EQL" + "EQUAL" + "EQUALP" + "ERROR" + "ETYPECASE" + "EVAL" + "EVAL-WHEN" + "EVENP" + "EVERY" + "EXP" + "EXPORT" + "EXPT" + "EXTENDED-CHAR" + "FBOUNDP" + "FCEILING" + "FDEFINITION" + "FFLOOR" + "FIFTH" + "FILE-AUTHOR" + "FILE-ERROR" + "FILE-ERROR-PATHNAME" + "FILE-LENGTH" + "FILE-NAMESTRING" + "FILE-POSITION" + "FILE-STREAM" + "FILE-STRING-LENGTH" + "FILE-WRITE-DATE" + "FILL" + "FILL-POINTER" + "FIND" + "FIND-ALL-SYMBOLS" + "FIND-CLASS" + "FIND-IF" + "FIND-IF-NOT" + "FIND-METHOD" + "FIND-PACKAGE" + "FIND-RESTART" + "FIND-SYMBOL" + "FINISH-OUTPUT" + "FIRST" + "FIXNUM" + "FLET" + "FLOAT" + "FLOAT-DIGITS" + "FLOAT-PRECISION" + "FLOAT-RADIX" + "FLOAT-SIGN" + "FLOATING-POINT-INEXACT" + "FLOATING-POINT-INVALID-OPERATION" + "FLOATING-POINT-OVERFLOW" + "FLOATING-POINT-UNDERFLOW" + "FLOATP" + "FLOOR" + "FMAKUNBOUND" + "FORCE-OUTPUT" + "FORMAT" + "FORMATTER" + "FOURTH" + "FRESH-LINE" + "FROUND" + "FTRUNCATE" + "FTYPE" + "FUNCALL" + "FUNCTION" + "FUNCTION-KEYWORDS" + "FUNCTION-LAMBDA-EXPRESSION" + "FUNCTIONP" + "GCD" + "GENERIC-FUNCTION" + "GENSYM" + "GENTEMP" + "GET" + "GET-DECODED-TIME" + "GET-DISPATCH-MACRO-CHARACTER" + "GET-INTERNAL-REAL-TIME" + "GET-INTERNAL-RUN-TIME" + "GET-MACRO-CHARACTER" + "GET-OUTPUT-STREAM-STRING" + "GET-PROPERTIES" + "GET-SETF-EXPANSION" + "GET-UNIVERSAL-TIME" + "GETF" + "GETHASH" + "GO" + "GRAPHIC-CHAR-P" + "HANDLER-BIND" + "HANDLER-CASE" + "HASH-TABLE" + "HASH-TABLE-COUNT" + "HASH-TABLE-P" + "HASH-TABLE-REHASH-SIZE" + "HASH-TABLE-REHASH-THRESHOLD" + "HASH-TABLE-SIZE" + "HASH-TABLE-TEST" + "HOST-NAMESTRING" + "IDENTITY" + "IF" + "IGNORABLE" + "IGNORE" + "IGNORE-ERRORS" + "IMAGPART" + "IMPORT" + "IN-PACKAGE" + "INCF" + "INITIALIZE-INSTANCE" + "INLINE" + "INPUT-STREAM-P" + "INSPECT" + "INTEGER" + "INTEGER-DECODE-FLOAT" + "INTEGER-LENGTH" + "INTEGERP" + "INTERACTIVE-STREAM-P" + "INTERN" + "INTERNAL-TIME-UNITS-PER-SECOND" + "INTERSECTION" + "INVALID-METHOD-ERROR" + "INVOKE-DEBUGGER" + "INVOKE-RESTART" + "INVOKE-RESTART-INTERACTIVELY" + "ISQRT" + "KEYWORD" + "KEYWORDP" + "LABELS" + "LAMBDA" + "LAMBDA-LIST-KEYWORDS" + "LAMBDA-PARAMETERS-LIMIT" + "LAST" + "LCM" + "LDB" + "LDB-TEST" + "LDIFF" + "LEAST-NEGATIVE-DOUBLE-FLOAT" + "LEAST-NEGATIVE-LONG-FLOAT" + "LEAST-NEGATIVE-NORMALIZED-DOUBLE-FLOAT" + "LEAST-NEGATIVE-NORMALIZED-LONG-FLOAT" + "LEAST-NEGATIVE-NORMALIZED-SHORT-FLOAT" + "LEAST-NEGATIVE-NORMALIZED-SINGLE-FLOAT" + "LEAST-NEGATIVE-SHORT-FLOAT" + "LEAST-NEGATIVE-SINGLE-FLOAT" + "LEAST-POSITIVE-DOUBLE-FLOAT" + "LEAST-POSITIVE-LONG-FLOAT" + "LEAST-POSITIVE-NORMALIZED-DOUBLE-FLOAT" + "LEAST-POSITIVE-NORMALIZED-LONG-FLOAT" + "LEAST-POSITIVE-NORMALIZED-SHORT-FLOAT" + "LEAST-POSITIVE-NORMALIZED-SINGLE-FLOAT" + "LEAST-POSITIVE-SHORT-FLOAT" + "LEAST-POSITIVE-SINGLE-FLOAT" + "LENGTH" + "LET" + "LET*" + "LISP-IMPLEMENTATION-TYPE" + "LISP-IMPLEMENTATION-VERSION" + "LIST" + "LIST*" + "LIST-ALL-PACKAGES" + "LIST-LENGTH" + "LISTEN" + "LISTP" + "LOAD" + "LOAD-LOGICAL-PATHNAME-TRANSLATIONS" + "LOAD-TIME-VALUE" + "LOCALLY" + "LOG" + "LOGAND" + "LOGANDC1" + "LOGANDC2" + "LOGBITP" + "LOGCOUNT" + "LOGEQV" + "LOGICAL-PATHNAME" + "LOGICAL-PATHNAME-TRANSLATIONS" + "LOGIOR" + "LOGNAND" + "LOGNOR" + "LOGNOT" + "LOGORC1" + "LOGORC2" + "LOGTEST" + "LOGXOR" + "LONG-FLOAT" + "LONG-FLOAT-EPSILON" + "LONG-FLOAT-NEGATIVE-EPSILON" + "LONG-SITE-NAME" + "LOOP" + "LOOP-FINISH" + "LOWER-CASE-P" + "MACHINE-INSTANCE" + "MACHINE-TYPE" + "MACHINE-VERSION" + "MACRO-FUNCTION" + "MACROEXPAND" + "MACROEXPAND-1" + "MACROLET" + "MAKE-ARRAY" + "MAKE-BROADCAST-STREAM" + "MAKE-CONCATENATED-STREAM" + "MAKE-CONDITION" + "MAKE-DISPATCH-MACRO-CHARACTER" + "MAKE-ECHO-STREAM" + "MAKE-HASH-TABLE" + "MAKE-INSTANCE" + "MAKE-INSTANCES-OBSOLETE" + "MAKE-LIST" + "MAKE-LOAD-FORM" + "MAKE-LOAD-FORM-SAVING-SLOTS" + "MAKE-METHOD" + "MAKE-PACKAGE" + "MAKE-PATHNAME" + "MAKE-RANDOM-STATE" + "MAKE-SEQUENCE" + "MAKE-STRING" + "MAKE-STRING-INPUT-STREAM" + "MAKE-STRING-OUTPUT-STREAM" + "MAKE-SYMBOL" + "MAKE-SYNONYM-STREAM" + "MAKE-TWO-WAY-STREAM" + "MAKUNBOUND" + "MAP" + "MAP-INTO" + "MAPC" + "MAPCAN" + "MAPCAR" + "MAPCON" + "MAPHASH" + "MAPL" + "MAPLIST" + "MASK-FIELD" + "MAX" + "MEMBER" + "MEMBER-IF" + "MEMBER-IF-NOT" + "MERGE" + "MERGE-PATHNAMES" + "METHOD" + "METHOD-COMBINATION" + "METHOD-COMBINATION-ERROR" + "METHOD-QUALIFIERS" + "MIN" + "MINUSP" + "MISMATCH" + "MOD" + "MOST-NEGATIVE-DOUBLE-FLOAT" + "MOST-NEGATIVE-FIXNUM" + "MOST-NEGATIVE-LONG-FLOAT" + "MOST-NEGATIVE-SHORT-FLOAT" + "MOST-NEGATIVE-SINGLE-FLOAT" + "MOST-POSITIVE-DOUBLE-FLOAT" + "MOST-POSITIVE-FIXNUM" + "MOST-POSITIVE-LONG-FLOAT" + "MOST-POSITIVE-SHORT-FLOAT" + "MOST-POSITIVE-SINGLE-FLOAT" + "MUFFLE-WARNING" + "MULTIPLE-VALUE-BIND" + "MULTIPLE-VALUE-CALL" + "MULTIPLE-VALUE-LIST" + "MULTIPLE-VALUE-PROG1" + "MULTIPLE-VALUE-SETQ" + "MULTIPLE-VALUES-LIMIT" + "NAME-CHAR" + "NAMESTRING" + "NBUTLAST" + "NCONC" + "NEXT-METHOD-P" + "NIL" + "NINTERSECTION" + "NINTH" + "NO-APPLICABLE-METHOD" + "NO-NEXT-METHOD" + "NOT" + "NOTANY" + "NOTEVERY" + "NOTINLINE" + "NRECONC" + "NREVERSE" + "NSET-DIFFERENCE" + "NSET-EXCLUSIVE-OR" + "NSTRING-CAPITALIZE" + "NSTRING-DOWNCASE" + "NSTRING-UPCASE" + "NSUBLIS" + "NSUBST" + "NSUBST-IF" + "NSUBST-IF-NOT" + "NSUBSTITUTE" + "NSUBSTITUTE-IF" + "NSUBSTITUTE-IF-NOT" + "NTH" + "NTH-VALUE" + "NTHCDR" + "NULL" + "NUMBER" + "NUMBERP" + "NUMERATOR" + "NUNION" + "ODDP" + "OPEN" + "OPEN-STREAM-P" + "OPTIMIZE" + "OR" + "OTHERWISE" + "OUTPUT-STREAM-P" + "PACKAGE" + "PACKAGE-ERROR" + "PACKAGE-ERROR-PACKAGE" + "PACKAGE-NAME" + "PACKAGE-NICKNAMES" + "PACKAGE-SHADOWING-SYMBOLS" + "PACKAGE-USE-LIST" + "PACKAGE-USED-BY-LIST" + "PACKAGEP" + "PAIRLIS" + "PARSE-ERROR" + "PARSE-INTEGER" + "PARSE-NAMESTRING" + "PATHNAME" + "PATHNAME-DEVICE" + "PATHNAME-DIRECTORY" + "PATHNAME-HOST" + "PATHNAME-MATCH-P" + "PATHNAME-NAME" + "PATHNAME-TYPE" + "PATHNAME-VERSION" + "PATHNAMEP" + "PEEK-CHAR" + "PHASE" + "PI" + "PLUSP" + "POP" + "POSITION" + "POSITION-IF" + "POSITION-IF-NOT" + "PPRINT" + "PPRINT-DISPATCH" + "PPRINT-EXIT-IF-LIST-EXHAUSTED" + "PPRINT-FILL" + "PPRINT-INDENT" + "PPRINT-LINEAR" + "PPRINT-LOGICAL-BLOCK" + "PPRINT-NEWLINE" + "PPRINT-POP" + "PPRINT-TAB" + "PPRINT-TABULAR" + "PRIN1" + "PRIN1-TO-STRING" + "PRINC" + "PRINC-TO-STRING" + "PRINT" + "PRINT-NOT-READABLE" + "PRINT-NOT-READABLE-OBJECT" + "PRINT-OBJECT" + "PRINT-UNREADABLE-OBJECT" + "PROBE-FILE" + "PROCLAIM" + "PROG" + "PROG*" + "PROG1" + "PROG2" + "PROGN" + "PROGRAM-ERROR" + "PROGV" + "PROVIDE" + "PSETF" + "PSETQ" + "PUSH" + "PUSHNEW" + "QUOTE" + "RANDOM" + "RANDOM-STATE" + "RANDOM-STATE-P" + "RASSOC" + "RASSOC-IF" + "RASSOC-IF-NOT" + "RATIO" + "RATIONAL" + "RATIONALIZE" + "RATIONALP" + "READ" + "READ-BYTE" + "READ-CHAR" + "READ-CHAR-NO-HANG" + "READ-DELIMITED-LIST" + "READ-FROM-STRING" + "READ-LINE" + "READ-PRESERVING-WHITESPACE" + "READ-SEQUENCE" + "READER-ERROR" + "READTABLE" + "READTABLE-CASE" + "READTABLEP" + "REAL" + "REALP" + "REALPART" + "REDUCE" + "REINITIALIZE-INSTANCE" + "REM" + "REMF" + "REMHASH" + "REMOVE" + "REMOVE-DUPLICATES" + "REMOVE-IF" + "REMOVE-IF-NOT" + "REMOVE-METHOD" + "REMPROP" + "RENAME-FILE" + "RENAME-PACKAGE" + "REPLACE" + "REQUIRE" + "REST" + "RESTART" + "RESTART-BIND" + "RESTART-CASE" + "RESTART-NAME" + "RETURN" + "RETURN-FROM" + "REVAPPEND" + "REVERSE" + "ROOM" + "ROTATEF" + "ROUND" + "ROW-MAJOR-AREF" + "RPLACA" + "RPLACD" + "SAFETY" + "SATISFIES" + "SBIT" + "SCALE-FLOAT" + "SCHAR" + "SEARCH" + "SECOND" + "SEQUENCE" + "SERIOUS-CONDITION" + "SET" + "SET-DIFFERENCE" + "SET-DISPATCH-MACRO-CHARACTER" + "SET-EXCLUSIVE-OR" + "SET-MACRO-CHARACTER" + "SET-PPRINT-DISPATCH" + "SET-SYNTAX-FROM-CHAR" + "SETF" + "SETQ" + "SEVENTH" + "SHADOW" + "SHADOWING-IMPORT" + "SHARED-INITIALIZE" + "SHIFTF" + "SHORT-FLOAT" + "SHORT-FLOAT-EPSILON" + "SHORT-FLOAT-NEGATIVE-EPSILON" + "SHORT-SITE-NAME" + "SIGNAL" + "SIGNED-BYTE" + "SIGNUM" + "SIMPLE-ARRAY" + "SIMPLE-BASE-STRING" + "SIMPLE-BIT-VECTOR" + "SIMPLE-BIT-VECTOR-P" + "SIMPLE-CONDITION" + "SIMPLE-CONDITION-FORMAT-ARGUMENTS" + "SIMPLE-CONDITION-FORMAT-CONTROL" + "SIMPLE-ERROR" + "SIMPLE-STRING" + "SIMPLE-STRING-P" + "SIMPLE-TYPE-ERROR" + "SIMPLE-VECTOR" + "SIMPLE-VECTOR-P" + "SIMPLE-WARNING" + "SIN" + "SINGLE-FLOAT" + "SINGLE-FLOAT-EPSILON" + "SINGLE-FLOAT-NEGATIVE-EPSILON" + "SINH" + "SIXTH" + "SLEEP" + "SLOT-BOUNDP" + "SLOT-EXISTS-P" + "SLOT-MAKUNBOUND" + "SLOT-MISSING" + "SLOT-UNBOUND" + "SLOT-VALUE" + "SOFTWARE-TYPE" + "SOFTWARE-VERSION" + "SOME" + "SORT" + "SPACE" + "SPECIAL" + "SPECIAL-OPERATOR-P" + "SPEED" + "SQRT" + "STABLE-SORT" + "STANDARD" + "STANDARD-CHAR" + "STANDARD-CHAR-P" + "STANDARD-CLASS" + "STANDARD-GENERIC-FUNCTION" + "STANDARD-METHOD" + "STANDARD-OBJECT" + "STEP" + "STORAGE-CONDITION" + "STORE-VALUE" + "STREAM" + "STREAM-ELEMENT-TYPE" + "STREAM-ERROR" + "STREAM-ERROR-STREAM" + "STREAM-EXTERNAL-FORMAT" + "STREAMP" + "STRING" + "STRING-CAPITALIZE" + "STRING-DOWNCASE" + "STRING-EQUAL" + "STRING-GREATERP" + "STRING-LEFT-TRIM" + "STRING-LESSP" + "STRING-NOT-EQUAL" + "STRING-NOT-GREATERP" + "STRING-NOT-LESSP" + "STRING-RIGHT-TRIM" + "STRING-STREAM" + "STRING-TRIM" + "STRING-UPCASE" + "STRING/=" + "STRING<" + "STRING<=" + "STRING=" + "STRING>" + "STRING>=" + "STRINGP" + "STRUCTURE" + "STRUCTURE-CLASS" + "STRUCTURE-OBJECT" + "STYLE-WARNING" + "SUBLIS" + "SUBSEQ" + "SUBSETP" + "SUBST" + "SUBST-IF" + "SUBST-IF-NOT" + "SUBSTITUTE" + "SUBSTITUTE-IF" + "SUBSTITUTE-IF-NOT" + "SUBTYPEP" + "SVREF" + "SXHASH" + "SYMBOL" + "SYMBOL-FUNCTION" + "SYMBOL-MACROLET" + "SYMBOL-NAME" + "SYMBOL-PACKAGE" + "SYMBOL-PLIST" + "SYMBOL-VALUE" + "SYMBOLP" + "SYNONYM-STREAM" + "SYNONYM-STREAM-SYMBOL" + "T" + "TAGBODY" + "TAILP" + "TAN" + "TANH" + "TENTH" + "TERPRI" + "THE" + "THIRD" + "THROW" + "TIME" + "TRACE" + "TRANSLATE-LOGICAL-PATHNAME" + "TRANSLATE-PATHNAME" + "TREE-EQUAL" + "TRUENAME" + "TRUNCATE" + "TWO-WAY-STREAM" + "TWO-WAY-STREAM-INPUT-STREAM" + "TWO-WAY-STREAM-OUTPUT-STREAM" + "TYPE" + "TYPE-ERROR" + "TYPE-ERROR-DATUM" + "TYPE-ERROR-EXPECTED-TYPE" + "TYPE-OF" + "TYPECASE" + "TYPEP" + "UNBOUND-SLOT" + "UNBOUND-SLOT-INSTANCE" + "UNBOUND-VARIABLE" + "UNDEFINED-FUNCTION" + "UNEXPORT" + "UNINTERN" + "UNION" + "UNLESS" + "UNREAD-CHAR" + "UNSIGNED-BYTE" + "UNTRACE" + "UNUSE-PACKAGE" + "UNWIND-PROTECT" + "UPDATE-INSTANCE-FOR-DIFFERENT-CLASS" + "UPDATE-INSTANCE-FOR-REDEFINED-CLASS" + "UPGRADED-ARRAY-ELEMENT-TYPE" + "UPGRADED-COMPLEX-PART-TYPE" + "UPPER-CASE-P" + "USE-PACKAGE" + "USE-VALUE" + "USER-HOMEDIR-PATHNAME" + "VALUES" + "VALUES-LIST" + "VARIABLE" + "VECTOR" + "VECTOR-POP" + "VECTOR-PUSH" + "VECTOR-PUSH-EXTEND" + "VECTORP" + "WARN" + "WARNING" + "WHEN" + "WILD-PATHNAME-P" + "WITH-ACCESSORS" + "WITH-COMPILATION-UNIT" + "WITH-CONDITION-RESTARTS" + "WITH-HASH-TABLE-ITERATOR" + "WITH-INPUT-FROM-STRING" + "WITH-OPEN-FILE" + "WITH-OPEN-STREAM" + "WITH-OUTPUT-TO-STRING" + "WITH-PACKAGE-ITERATOR" + "WITH-SIMPLE-RESTART" + "WITH-SLOTS" + "WITH-STANDARD-IO-SYNTAX" + "WRITE" + "WRITE-BYTE" + "WRITE-CHAR" + "WRITE-LINE" + "WRITE-SEQUENCE" + "WRITE-STRING" + "WRITE-TO-STRING" + "Y-OR-N-P" + "YES-OR-NO-P" + "ZEROP" + ) + )) + +(let* ((pkg *common-lisp-package*) + (etab (pkg.etab pkg)) + (itab (pkg.itab pkg))) + (without-interrupts + (dolist (name '#.%lisp-symbols%) + (let* ((namelen (length name))) + (multiple-value-bind (found-int symbol int-offset) + (%get-htab-symbol name namelen itab) + (multiple-value-bind (found-ext ignore ext-offset) + (%get-htab-symbol name namelen etab) + (declare (ignore ignore)) + (if found-int ; This shouldn't happen. + (progn + (setf (%svref (car itab) int-offset) (%unbound-marker-8)) + (%htab-add-symbol symbol etab ext-offset)) + (unless found-ext + (%add-symbol name pkg int-offset ext-offset t))))))))) Index: /branches/new-random/level-1/l1-clos-boot.lisp =================================================================== --- /branches/new-random/level-1/l1-clos-boot.lisp (revision 13309) +++ /branches/new-random/level-1/l1-clos-boot.lisp (revision 13309) @@ -0,0 +1,3860 @@ +;;;-*-Mode: LISP; Package: CCL -*- +;;; +;;; Copyright (C) 2009 Clozure Associates +;;; Copyright (C) 1994-2001 Digitool, Inc +;;; This file is part of Clozure CL. +;;; +;;; Clozure CL is licensed under the terms of the Lisp Lesser GNU Public +;;; License , known as the LLGPL and distributed with Clozure CL as the +;;; file "LICENSE". The LLGPL consists of a preamble and the LGPL, +;;; which is distributed with Clozure CL as the file "LGPL". Where these +;;; conflict, the preamble takes precedence. +;;; +;;; Clozure CL is referenced in the preamble as the "LIBRARY." +;;; +;;; The LLGPL is also available online at +;;; http://opensource.franz.com/preamble.html + + + + +;;; l1-clos-boot.lisp + + +(in-package "CCL") + + +;;; Early accessors. These functions eventually all get replaced with +;;; generic functions with "real", official names. + + +(declaim (inline instance-slots %non-standard-instance-slots)) +(defun %non-standard-instance-slots (instance typecode) + (cond ((eql typecode target::subtag-macptr) (foreign-slots-vector instance)) + ((or (typep instance 'standard-generic-function) + (typep instance 'funcallable-standard-object)) + (gf.slots instance)) + (t (error "Don't know how to find slots of ~s" instance)))) + +(defun instance-slots (instance) + (let* ((typecode (typecode instance))) + (cond ((eql typecode target::subtag-instance) (instance.slots instance)) + (t (%non-standard-instance-slots instance typecode))))) + + +;;; True if X is a class but not a foreign-class. +(defun native-class-p (x) + (if (%standard-instance-p x) + (< (the fixnum (instance.hash x)) max-class-ordinal))) + +(defun %class-name (class) + (if (native-class-p class) + (%class.name class) + (class-name class))) + +(defun %class-info (class) + (if (native-class-p class) + (%class.info class) + (class-info class))) + + +(defun %class-kernel-p (class) + (car (%class-info class))) + +(defun (setf %class-kernel-p) (new class) + (setf (car (%class-info class)) new)) + +(defun %class-proper-name (class) + (cdr (%class-info class))) + +(defun (setf %class-proper-name) (new class) + (setf (cdr (%class-info class)) new)) + + +(defun %class-own-wrapper (class) + (if (native-class-p class) + (%class.own-wrapper class) + (class-own-wrapper class))) + +(defun (setf %class-own-wrapper) (new class) + (setf (%class.own-wrapper class) new)) + +(defun %class-alist (class) + (%class.alist class)) + +(defun (setf %class-alist) (new class) + (if (typep class 'slots-class) + (setf (%class.alist class) new) + new)) + +(defun %class-slots (class) + (if (native-class-p class) + (%class.slots class) + (class-slots class))) + +(defun (setf %class-slots) (new class) + (if (native-class-p class) + (setf (%class.slots class) new) + (setf (class-slots class) new))) + +(defun %class-direct-slots (class) + (if (native-class-p class) + (%class.direct-slots class) + (class-direct-slots class))) + +(defun (setf %class-direct-slots) (new class) + (if (native-class-p class) + (setf (%class.direct-slots class) new) + (setf (class-direct-slots class) new))) + + + + + + +(defun %class-direct-superclasses (class) + (%class.local-supers class)) + +(defun (setf %class-direct-superclasses) (new class) + (setf (%class.local-supers class) new)) + +(defun %class-direct-subclasses (class) + (%class.subclasses class)) + +(defun (setf %class-direct-subclasses) (new class) + (setf (%class.subclasses class) new)) + +(defun %class-direct-default-initargs (class) + (if (typep class 'std-class) + (%class.local-default-initargs class))) + +(defun (setf %class-direct-default-initargs) (new class) + (if (typep class 'std-class) + (setf (%class.local-default-initargs class) new) + new)) + + +(defun %class-default-initargs (class) + (if (typep class 'std-class) + (%class.default-initargs class))) + + +(defun (setf %class-default-initargs) (new class) + (setf (%class.default-initargs class) new)) + +(defun %slot-definition-name (slotd) + (standard-slot-definition.name slotd)) + + +(defun %slot-definition-type (slotd) + (standard-slot-definition.type slotd)) + +(defun %slot-definition-initargs (slotd) + (standard-slot-definition.initargs slotd)) + + +(defun %slot-definition-initform (slotd) + (standard-slot-definition.initform slotd)) + +(defun %slot-definition-initfunction (slotd) + (standard-slot-definition.initfunction slotd)) + +(defun %slot-definition-allocation (slotd) + (standard-slot-definition.allocation slotd)) + +(defun %slot-definition-class (slotd) + (standard-slot-definition.class slotd)) + +;;; Returns (VALUES BOUNDP VALUE). +(defun %slot-definition-documentation (slotd) + (let* ((val (%standard-instance-instance-location-access + slotd + standard-slot-definition.documentation))) + (if (eq val (%slot-unbound-marker)) + (values nil nil) + (values t val)))) + + +(defun %slot-definition-location (slotd) + (standard-effective-slot-definition.location slotd)) + +(defun (setf %slot-definition-location) (new slotd) + (setf (standard-effective-slot-definition.location slotd) new)) + +(defun %slot-definition-readers (slotd) + (standard-direct-slot-definition.readers slotd)) + +(defun (setf %slot-definition-readers) (new slotd) + (setf (standard-direct-slot-definition.readers slotd) new)) + +(defun %slot-definition-writers (slotd) + (standard-direct-slot-definition.writers slotd)) + +(defun (setf %slot-definition-writers) (new slotd) + (setf (standard-direct-slot-definition.writers slotd) new)) + +(defun %generic-function-name (gf) + (sgf.name gf)) + +(defun %generic-function-method-combination (gf) + (sgf.method-combination gf)) + +(defun %generic-function-method-class (gf) + (sgf.method-class gf)) + + +(defun %method-qualifiers (m) + (%method.qualifiers m)) + +(defun %method-specializers (m) + (%method.specializers m)) + +(defun %method-function (m) + (%method.function m)) + +(defun (setf %method-function) (new m) + (setf (%method.function m) new)) + +(defun %method-gf (m) + (%method.gf m)) + +(defun (setf %method-gf) (new m) + (setf (%method.gf m) new)) + +(defun %method-name (m) + (%method.name m)) + +(defun %method-lambda-list (m) + (%method.lambda-list m)) + + + +;;; Map slot-names (symbols) to SLOT-ID objects (which contain unique indices). +(let* ((slot-id-lock (make-lock)) + (next-slot-index 1) ; 0 is never a valid slot-index + (slot-id-hash (make-hash-table :test #'eq :weak t))) + (defun ensure-slot-id (slot-name) + (setq slot-name (require-type slot-name 'symbol)) + (with-lock-grabbed (slot-id-lock) + (or (gethash slot-name slot-id-hash) + (setf (gethash slot-name slot-id-hash) + (%istruct 'slot-id slot-name (prog1 + next-slot-index + (incf next-slot-index))))))) + (defun current-slot-index () (with-lock-grabbed (slot-id-lock) + next-slot-index)) + ) + + + + +(defun %slot-id-lookup-obsolete (instance slot-id) + (update-obsolete-instance instance) + (funcall (%wrapper-slot-id->slotd (instance.class-wrapper instance)) + instance slot-id)) +(defun slot-id-lookup-no-slots (instance slot-id) + (declare (ignore instance slot-id))) + +(defun %slot-id-ref-obsolete (instance slot-id) + (update-obsolete-instance instance) + (funcall (%wrapper-slot-id-value (instance.class-wrapper instance)) + instance slot-id)) +(defun %slot-id-ref-missing (instance slot-id) + (values (slot-missing (class-of instance) instance (slot-id.name slot-id) 'slot-value))) + +(defun %slot-id-set-obsolete (instance slot-id new-value) + (update-obsolete-instance instance) + (funcall (%wrapper-set-slot-id-value (instance.class-wrapper instance)) + instance slot-id new-value)) + +(defun %slot-id-set-missing (instance slot-id new-value) + (slot-missing (class-of instance) instance (slot-id.name slot-id) 'setf new-value) + new-value + ) + + + + +;;; This becomes (apply #'make-instance &rest args). +(fset '%make-method-instance + (nlambda bootstrapping-%make-method-instance (class &key + qualifiers + specializers + function + name + lambda-list + &allow-other-keys) + (let* ((method + (%instance-vector (%class-own-wrapper class) + qualifiers + specializers + function + nil + name + lambda-list))) + (when function + (let* ((inner (closure-function function))) + (unless (eq inner function) + (copy-method-function-bits inner function))) + (lfun-name function method)) + method))) + + + +(defun encode-lambda-list (l &optional return-keys?) + (multiple-value-bind (ok req opttail resttail keytail auxtail) + (verify-lambda-list l) + (when ok + (let* ((bits 0) + (temp nil) + (nreq (length req)) + (num-opt 0) + (rest nil) + (lexpr nil) + (keyp nil) + (key-list nil) + (aokp nil) + (hardopt nil)) + (when (> nreq #.(ldb $lfbits-numreq $lfbits-numreq)) + (return-from encode-lambda-list nil)) + (when (eq (pop opttail) '&optional) + (until (eq opttail resttail) + (when (and (consp (setq temp (pop opttail))) + (%cadr temp)) + (setq hardopt t)) + (setq num-opt (%i+ num-opt 1)))) + (when (eq (%car resttail) '&rest) + (setq rest t)) + (when (eq (%car resttail) '&lexpr) + (setq lexpr t)) + (when (eq (pop keytail) '&key) + (setq keyp t) + (labels ((ensure-symbol (x) + (if (symbolp x) x (return-from encode-lambda-list nil))) + (ensure-keyword (x) + (make-keyword (ensure-symbol x)))) + (declare (dynamic-extent #'ensure-symbol #'ensure-keyword)) + (until (eq keytail auxtail) + (setq temp (pop keytail)) + (if (eq temp '&allow-other-keys) + (progn + (setq aokp t) + (unless (eq keytail auxtail) + (return-from encode-lambda-list nil))) + (when return-keys? + (push (if (consp temp) + (if (consp (setq temp (%car temp))) + (ensure-symbol (%car temp)) + (ensure-keyword temp)) + (ensure-keyword temp)) + key-list)))))) + (when (%i> nreq (ldb $lfbits-numreq -1)) + (setq nreq (ldb $lfbits-numreq -1))) + (setq bits (dpb nreq $lfbits-numreq bits)) + (when (%i> num-opt (ldb $lfbits-numopt -1)) + (setq num-opt (ldb $lfbits-numopt -1))) + (setq bits (dpb num-opt $lfbits-numopt bits)) + (when hardopt (setq bits (%ilogior (%ilsl $lfbits-optinit-bit 1) bits))) + (when rest (setq bits (%ilogior (%ilsl $lfbits-rest-bit 1) bits))) + (when lexpr (setq bits (%ilogior (%ilsl $lfbits-restv-bit 1) bits))) + (when keyp (setq bits (%ilogior (%ilsl $lfbits-keys-bit 1) bits))) + (when aokp (setq bits (%ilogior (%ilsl $lfbits-aok-bit 1) bits))) + (if return-keys? + (values bits (and keyp (apply #'vector (nreverse key-list)))) + bits))))) + +(defun pair-arg-p (thing &optional lambda-list-ok supplied-p-ok keyword-nesting-ok) + (or (symbol-arg-p thing lambda-list-ok) ; nil ok in destructuring case + (and (consp thing) + (or (null (%cdr thing)) + (and (consp (%cdr thing)) + (or (null (%cddr thing)) + (and supplied-p-ok + (consp (%cddr thing)) + (null (%cdddr thing)))))) + (if (not keyword-nesting-ok) + (req-arg-p (%car thing) lambda-list-ok) + (or (symbol-arg-p (%car thing) lambda-list-ok) + (and (consp (setq thing (%car thing))) + (consp (%cdr thing)) + (null (%cddr thing)) + (%car thing) + (symbolp (%car thing)) + (req-arg-p (%cadr thing) lambda-list-ok))))))) + +(defun req-arg-p (thing &optional lambda-list-ok) + (or + (symbol-arg-p thing lambda-list-ok) + (lambda-list-arg-p thing lambda-list-ok))) + +(defun symbol-arg-p (thing nil-ok) + (and + (symbolp thing) + (or thing nil-ok) + (not (memq thing lambda-list-keywords)))) + +(defun lambda-list-arg-p (thing lambda-list-ok) + (and + lambda-list-ok + (listp thing) + (if (verify-lambda-list thing t t) + (setq *structured-lambda-list* t)))) + +(defun opt-arg-p (thing &optional lambda-ok) + (pair-arg-p thing lambda-ok t nil)) + +(defun key-arg-p (thing &optional lambda-ok) + (pair-arg-p thing lambda-ok t t)) + +(defun proclaimed-ignore-p (sym) + (cdr (assq sym *nx-proclaimed-ignore*))) + +(defun verify-lambda-list (l &optional destructure-p whole-p env-p) + (let* ((the-keys lambda-list-keywords) + opttail + resttail + keytail + allowothertail + auxtail + safecopy + whole + m + n + req + sym + (*structured-lambda-list* nil)) + (prog () + (multiple-value-setq (safecopy whole) + (normalize-lambda-list l whole-p env-p)) + (unless (or destructure-p (eq l safecopy) (go LOSE))) + (setq l safecopy) + (unless (dolist (key the-keys t) + (when (setq m (cdr (memq key l))) + (if (memq key m) (return)))) + (go LOSE)) + (if (null l) (go WIN)) + (setq opttail (memq '&optional l)) + (setq m (or (memq '&rest l) + (unless destructure-p (memq '&lexpr l)))) + (setq n (if destructure-p (memq '&body l))) + (if (and m n) (go LOSE) (setq resttail (or m n))) + (setq keytail (memq '&key l)) + (if (and (setq allowothertail (memq '&allow-other-keys l)) + (not keytail)) + (go LOSE)) + (if (and (eq (car resttail) '&lexpr) + (or keytail opttail)) + (go lose)) + (setq auxtail (memq '&aux l)) + (loop + (when (null l) (go WIN)) + (when (or (eq l opttail) + (eq l resttail) + (eq l keytail) + (eq l allowothertail) + (eq l auxtail)) + (return)) + (setq sym (pop l)) + (unless (and (req-arg-p sym destructure-p) + (or (proclaimed-ignore-p sym) + (and destructure-p (null sym)) + (not (memq sym req)))) ; duplicate required args + (go LOSE)) + (push sym req)) + (when (eq l opttail) + (setq l (%cdr l)) + (loop + (when (null l) (go WIN)) + (when (or (eq l resttail) + (eq l keytail) + (eq l allowothertail) + (eq l auxtail)) + (return)) + (unless (opt-arg-p (pop l) destructure-p) + (go LOSE)))) + (when (eq l resttail) + (setq l (%cdr l)) + (when (or (null l) + (eq l opttail) + (eq l keytail) + (eq l allowothertail) + (eq l auxtail)) + (go LOSE)) + (unless (req-arg-p (pop l) destructure-p) (go LOSE))) + (unless (or (eq l keytail) ; allowothertail is a sublist of keytail if present + (eq l auxtail)) + (go LOSE)) + (when (eq l keytail) + (pop l) + (loop + (when (null l) (go WIN)) + (when (or (eq l opttail) + (eq l resttail)) + (go LOSE)) + (when (or (eq l auxtail) (setq n (eq l allowothertail))) + (if n (setq l (%cdr l))) + (return)) + (unless (key-arg-p (pop l) destructure-p) (go LOSE)))) + (when (eq l auxtail) + (setq l (%cdr l)) + (loop + (when (null l) (go WIN)) + (when (or (eq l opttail) + (eq l resttail) + (eq l keytail)) + (go LOSE)) + (unless (pair-arg-p (pop l)) (go LOSE)))) + (when l (go LOSE)) + WIN + (return (values + t + (nreverse req) + (or opttail resttail keytail auxtail) + (or resttail keytail auxtail) + (or keytail auxtail) + auxtail + safecopy + whole + *structured-lambda-list*)) + LOSE + (return (values nil nil nil nil nil nil nil nil nil nil))))) + +(defun normalize-lambda-list (x &optional whole-p env-p) + (let* ((y x) whole env envtail head) + (setq + x + (loop + (when (atom y) + (if (or (null y) (eq x y)) (return x)) + (setq x (copy-list x) y x) + (return + (loop + (when (atom (%cdr y)) + (%rplacd y (list '&rest (%cdr y))) + (return x)) + (setq y (%cdr y))))) + (setq y (%cdr y)))) + (when env-p + ;; Trapped in a world it never made ... + (when (setq y (memq '&environment x)) + (setq envtail (%cddr y) + env (%cadr y)) + (cond ((eq y x) + (setq x envtail)) + (t + (dolist (v x) + (if (eq v '&environment) + (return) + (push v head))) + (setq x (nconc (nreverse head) envtail) y (%car envtail)))))) + (when (and whole-p + (eq (%car x) '&whole) + (%cadr x)) + (setq whole (%cadr x) x (%cddr x))) + (values x whole env))) + + + + +(eval-when (eval compile) + (require 'defstruct-macros)) + +(eval-when (:compile-toplevel :execute) + (defmacro make-instance-vector (wrapper len) + (let* ((instance (gensym)) + (slots (gensym))) + `(let* ((,slots (allocate-typed-vector :slot-vector (1+ ,len) (%slot-unbound-marker))) + (,instance (gvector :instance 0 ,wrapper ,slots))) + (setf (instance.hash ,instance) (strip-tag-to-fixnum ,instance) + (slot-vector.instance ,slots) ,instance)))) +) + +(eval-when (:compile-toplevel :execute) + (defmacro make-structure-vector (size) + `(%alloc-misc ,size target::subtag-struct nil)) + +) +;;;;;;;;;;;;;;;;;;;;;;;;;;; defmethod support ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; + +(%fhave '%move-method-encapsulations-maybe ; Redefined in encapsulate + (qlfun boot-%move-method-encapsulations-maybe (m1 m2) + (declare (ignore m1 m2)) + nil)) + +(%fhave 'find-unencapsulated-definition ;Redefined in encapsulate + (qlfun bootstrapping-find-unencapsulated-definition (fn) + fn)) + +(%fhave 'function-encapsulated-p ;Redefined in encapsulate + (qlfun bootstrapping-function-encapsulated-p (fn) + (declare (ignore fn)) + nil)) + +(defparameter *uniquify-dcode* #+unique-dcode t #-unique-dcode nil + "If true, each gf will get its own unique copy of its dcode. Not recommended for + real use (for one thing, it's known to break gf tracing), but may be helpful for + profiling") + +(let* ((class-wrapper-random-state (make-random-state)) + (class-wrapper-random-state-lock (make-lock))) + + (defun new-class-wrapper-hash-index () + ;; mustn't be 0 + (with-lock-grabbed (class-wrapper-random-state-lock) + (the fixnum (1+ (the fixnum (random target::target-most-positive-fixnum class-wrapper-random-state))))))) + + +(defun %inner-method-function (method) + (closure-function + (find-unencapsulated-definition + (%method-function method)))) + +(defun copy-method-function-bits (from to) + (let ((new-bits (logior (logand (logior (lsh 1 $lfbits-method-bit) + (ash 1 $lfbits-nextmeth-bit) + (ash 1 $lfbits-nextmeth-with-args-bit) + $lfbits-args-mask) + (lfun-bits from)) + (logand (lognot (logior (lsh 1 $lfbits-method-bit) + (ash 1 $lfbits-nextmeth-bit) + (ash 1 $lfbits-nextmeth-with-args-bit) + $lfbits-args-mask)) + (lfun-bits to))))) + (lfun-bits to new-bits) + new-bits)) + +(defun %ensure-generic-function-using-class (gf function-name &rest keys + &key + &allow-other-keys) + (if gf + (apply #'%ensure-existing-generic-function-using-class gf function-name keys) + (apply #'%ensure-new-generic-function-using-class function-name keys))) + +(defun ensure-generic-function (function-name &rest keys &key &allow-other-keys) + (let* ((def (fboundp function-name))) + (when (and def (not (typep def 'generic-function))) + (cerror "Try to remove any global non-generic function or macro definition." + (make-condition 'simple-program-error :format-control "The function ~s is defined as something other than a generic function." :format-arguments (list function-name))) + (fmakunbound function-name) + (setq def nil)) + (apply #'%ensure-generic-function-using-class def function-name keys))) + + +(defun %ensure-new-generic-function-using-class + (function-name &rest keys &key + (generic-function-class *standard-generic-function-class* gfc-p) + &allow-other-keys) + (declare (dynamic-extent keys)) + (when gfc-p + (if (symbolp generic-function-class) + (setq generic-function-class (find-class generic-function-class))) + (unless (subtypep generic-function-class *standard-generic-function-class*) + (error "~s is not a subtype of ~s" generic-function-class *generic-function-class*)) + (remf keys :generic-function-class)) + (let* ((gf (apply #'%make-gf-instance generic-function-class keys))) + (unless (eq (%gf-method-combination gf) *standard-method-combination*) + (register-gf-method-combination gf (%gf-method-combination gf))) + (setf (sgf.name gf) (getf keys :name function-name)) + (setf (fdefinition function-name) gf))) + +(defun %ensure-existing-generic-function-using-class + (gf function-name &key + (generic-function-class *standard-generic-function-class* gfc-p) + (method-combination *standard-method-combination* mcomb-p) + (method-class *standard-method-class* mclass-p) + (argument-precedence-order nil apo-p) + declarations + (lambda-list nil ll-p) + name) + (when gfc-p + (if (symbolp generic-function-class) + (setq generic-function-class (find-class generic-function-class))) + (unless (subtypep generic-function-class *standard-generic-function-class*) + (error "~s is not a subtype of ~s" generic-function-class *standard-generic-function-class*))) + (when mcomb-p + (unless (typep method-combination 'method-combination) + (report-bad-arg method-combination 'method-combination))) + (when mclass-p + (if (symbolp method-class) + (setq method-class (find-class method-class))) + (unless (subtypep method-class *method-class*) + (error "~s is not a subtype of ~s." method-class *method-class*))) + (when declarations + (unless (list-length declarations) + (error "~s is not a proper list" declarations))) + ;; Fix APO, lambda-list + (if apo-p + (if (not ll-p) + (error "Cannot specify ~s without specifying ~s" :argument-precedence-order + :lambda-list))) + (let* ((old-mc (sgf.method-combination gf))) + (unless (eq old-mc method-combination) + (unless (eq old-mc *standard-method-combination*) + (unregister-gf-method-combination gf method-combination)))) + (setf (sgf.name gf) (or name function-name) + (sgf.decls gf) declarations + (sgf.method-class gf) method-class + (sgf.method-combination gf) method-combination) + (unless (eq method-combination *standard-method-combination*) + (register-gf-method-combination gf method-combination)) + (when ll-p + (if apo-p + (set-gf-arg-info gf :lambda-list lambda-list + :argument-precedence-order argument-precedence-order) + (set-gf-arg-info gf :lambda-list lambda-list))) + (setf (fdefinition function-name) gf)) + +(defun canonicalize-specializers (specializers &optional (copy t)) + (flet ((canonicalize-specializer (spec) + (if (specializer-p spec) + spec + (if (symbolp spec) + (find-class spec) + (if (and (consp spec) + (eq (car spec) 'eql) + (consp (cdr spec)) + (null (cddr spec))) + (intern-eql-specializer (cadr spec)) + (error "Unknown specializer form ~s" spec)))))) + (if (and (not copy) + (dolist (s specializers t) + (unless (specializer-p s) (return nil)))) + specializers + (mapcar #'canonicalize-specializer specializers)))) + +(defparameter *sealed-clos-world* nil "When true, class and method definition -at least - are disallowed.") + +(defun ensure-method (name specializers &rest keys &key (documentation nil doc-p) qualifiers + &allow-other-keys) + (declare (dynamic-extent keys)) + (if *sealed-clos-world* + (error "Method (re)definition is not allowed in this environment.") + (progn + (setq specializers (canonicalize-specializers specializers)) + (let* ((gf (ensure-generic-function name)) + (method (apply #'%make-method-instance + (%gf-method-class gf) + :name name + :specializers specializers + keys)) + (old-method (when (%gf-methods gf) + (ignore-errors + (find-method gf qualifiers specializers nil))))) + + (%add-method gf method) + (when (and doc-p *save-doc-strings*) + (set-documentation method t documentation)) + (record-source-file method 'method) + (when old-method (%move-method-encapsulations-maybe old-method method)) + method)))) + + +(defun %anonymous-method (function specializers qualifiers lambda-list &optional documentation + &aux name method-class) + (let ((inner-function (closure-function function))) + (unless (%method-function-p inner-function) + (report-bad-arg inner-function 'method-function)) ; Well, I suppose we'll have to shoot you. + (unless (eq inner-function function) ; must be closed over + (copy-method-function-bits inner-function function)) + (setq name (function-name inner-function)) + (if (typep name 'standard-method) ; method-function already installed. + (setq name (%method-name name))) + (setq method-class *standard-method-class*) + (unless (memq *standard-method-class* (or (%class.cpl method-class) + (%class.cpl (update-class method-class t)))) + (%badarg method-class 'standard-method)) + #| + (unless (member qualifiers '(() (:before) (:after) (:around)) :test #'equal) + (report-bad-arg qualifiers)) + ||# + (setq specializers (mapcar #'(lambda (s) + (or (and (consp s) + (eq (%car s) 'eql) + (consp (%cdr s)) + (null (%cddr s)) + (intern-eql-specializer (%cadr s))) + (and (specializer-p s) s) + (find-class s))) + specializers)) + (let ((method (%make-method-instance method-class + :name name + :lambda-list lambda-list + :qualifiers qualifiers + :specializers specializers + :function function))) + (lfun-name inner-function method) + (when documentation + (set-documentation method t documentation)) + method))) + + +(defun check-defmethod-congruency (gf method) + (unless (congruent-lambda-lists-p gf method) + (cerror (format nil + "Remove ~d method~:p from the generic-function and change its lambda list." + (length (%gf-methods gf))) + "Lambda list of method ~S ~%~ +is incompatible with that of the generic function ~S.~%~ +Method's lambda-list : ~s~%~ +Generic-function's : ~s~%" method (or (generic-function-name gf) gf) (flatten-method-lambda-list (%method-lambda-list method)) (generic-function-lambda-list gf)) + (loop + (let ((methods (%gf-methods gf))) + (if methods + (remove-method gf (car methods)) + (return)))) + (%set-defgeneric-keys gf nil) + (inner-lfun-bits gf (%ilogior (%ilsl $lfbits-gfn-bit 1) + (%ilogand $lfbits-args-mask + (lfun-bits (%method-function method)))))) + gf) + + + +(defun %method-function-method (method-function) + (setq method-function + (closure-function + (find-unencapsulated-definition method-function))) + (setq method-function (require-type method-function 'method-function)) + (lfun-name method-function)) + +(defstatic %defgeneric-methods% (make-hash-table :test 'eq :weak t)) + +(defun %defgeneric-methods (gf) + (gethash gf %defgeneric-methods%)) + +(defun %set-defgeneric-methods (gf &rest methods) + (if methods + (setf (gethash gf %defgeneric-methods%) methods) + (remhash gf %defgeneric-methods%))) + +(defun %defgeneric-keys (gf) + (%gf-dispatch-table-keyvect (%gf-dispatch-table gf))) + +(defun %set-defgeneric-keys (gf keyvect) + (setf (%gf-dispatch-table-keyvect (%gf-dispatch-table gf)) keyvect)) + +(defun congruent-lfbits-p (gbits mbits) + (and (eq (ldb $lfbits-numreq gbits) (ldb $lfbits-numreq mbits)) + (eq (ldb $lfbits-numopt gbits) (ldb $lfbits-numopt mbits)) + (eq (or (logbitp $lfbits-rest-bit gbits) + (logbitp $lfbits-restv-bit gbits) + (logbitp $lfbits-keys-bit gbits)) + (or (logbitp $lfbits-rest-bit mbits) + (logbitp $lfbits-restv-bit mbits) + (logbitp $lfbits-keys-bit mbits))))) + +(defun congruent-lambda-lists-p (gf method &optional + error-p gbits mbits gkeys) + (unless gbits (setq gbits (inner-lfun-bits gf))) + (unless mbits (setq mbits (lfun-bits (%method-function method)))) + (and (congruent-lfbits-p gbits mbits) + (or (and (or (logbitp $lfbits-rest-bit mbits) + (logbitp $lfbits-restv-bit mbits)) + (not (logbitp $lfbits-keys-bit mbits))) + (logbitp $lfbits-aok-bit mbits) + (progn + (unless gkeys (setq gkeys (%defgeneric-keys gf))) + (or (null gkeys) + (eql 0 (length gkeys)) + (let ((mkeys (lfun-keyvect + (%inner-method-function method)))) + (dovector (key gkeys t) + (unless (find key mkeys :test 'eq) + (if error-p + (error "~s does not specify keys: ~s" method gkeys)) + (return nil))))))))) + +(defun %add-method (gf method) + (%add-standard-method-to-standard-gf gf method)) + +;; Redefined in l1-clos.lisp +(fset 'maybe-remove-make-instance-optimization + (nlambda bootstrapping-maybe-remove-make-instance-optimization (gfn method) + (declare (ignore gfn method)) + nil)) + +(defun %add-standard-method-to-standard-gf (gfn method) + (when (%method-gf method) + (error "~s is already a method of ~s." method (%method-gf method))) + (set-gf-arg-info gfn :new-method method) + (let* ((dt (%gf-dispatch-table gfn)) + (methods (sgf.methods gfn)) + (specializers (%method-specializers method)) + (qualifiers (%method-qualifiers method))) + (remove-obsoleted-combined-methods method dt specializers) + (maybe-remove-make-instance-optimization gfn method) + (apply #'invalidate-initargs-vector-for-gf gfn specializers) + (dolist (m methods) + (when (and (equal specializers (%method-specializers m)) + (equal qualifiers (%method-qualifiers m))) + (remove-method gfn m) + ;; There can be at most one match + (return))) + (push method (sgf.methods gfn)) + (setf (%gf-dispatch-table-methods dt) (sgf.methods gfn)) + (setf (%method-gf method) gfn) + (%add-direct-methods method) + (compute-dcode gfn dt) + (when (sgf.dependents gfn) + (map-dependents gfn #'(lambda (d) + (update-dependent gfn d 'add-method method))))) + gfn) + +(defstatic *standard-kernel-method-class* nil) + +(defun redefine-kernel-method (method) + (when (and *warn-if-redefine-kernel* + (or (let ((class *standard-kernel-method-class*)) + (and class (typep method class))) + (and (standard-method-p method) + (kernel-function-p (%method-function method))))) + (cerror "Replace the definition of ~S." + "The method ~S is predefined in Clozure CL." method))) + +;;; Called by the expansion of generic-labels. Which doesn't exist. +(defun %add-methods (gf &rest methods) + (declare (dynamic-extent methods)) + (dolist (m methods) + (add-method gf m))) + +(defun methods-congruent-p (m1 m2) + (when (and (standard-method-p m1)(standard-method-p m2)) + (when (equal (%method-qualifiers m1) (%method-qualifiers m2)) + (let ((specs (%method-specializers m1))) + (dolist (msp (%method-specializers m2) t) + (let ((spec (%pop specs))) + (unless (eq msp spec) + (return nil)))))))) + +(defvar *maintain-class-direct-methods* nil) + + + +;;; CAR is an EQL hash table for objects whose identity is not used by EQL +;;; (numbers and macptrs) +;;; CDR is a weak EQ hash table for other objects. +(defvar *eql-methods-hashes* (cons (make-hash-table :test 'eql) + (make-hash-table :test 'eq :weak :key))) + +(defun eql-methods-cell (object &optional addp) + (let ((hashes *eql-methods-hashes*)) + (without-interrupts + (let* ((hash (cond + ((or (typep object 'number) + (typep object 'macptr)) + (car hashes)) + (t (cdr hashes)))) + (cell (gethash object hash))) + (when (and (null cell) addp) + (setf (gethash object hash) (setq cell (cons nil nil)))) + cell)))) + + + + +(defun map-classes (function) + (with-hash-table-iterator (m %find-classes%) + (loop + (multiple-value-bind (found name cell) (m) + (declare (optimize speed) (type class-cell cell)) + (unless found (return)) + (when cell + (funcall function name (class-cell-class cell))))))) + + + +(defun %class-primary-slot-accessor-info (class accessor-or-slot-name &optional create?) + (let ((info-list (%class-get class '%class-primary-slot-accessor-info))) + (or (car (member accessor-or-slot-name info-list + :key #'(lambda (x) (%slot-accessor-info.accessor x)))) + (and create? + (let ((info (%cons-slot-accessor-info class accessor-or-slot-name))) + (setf (%class-get class '%class-primary-slot-accessor-info) + (cons info info-list)) + info))))) + +;;; Clear the %class.primary-slot-accessor-info for an added or +;;; removed method's specializers +(defun clear-accessor-method-offsets (gf method) + (when (or (typep method 'standard-accessor-method) + (member 'standard-accessor-method + (%gf-methods gf) + :test #'(lambda (sam meth) + (declare (ignore sam)) + (typep meth 'standard-accessor-method)))) + (labels ((clear-class (class) + (when (typep class 'standard-class) + (let ((info (%class-primary-slot-accessor-info class gf))) + (when info + (setf (%slot-accessor-info.offset info) nil))) + (mapc #'clear-class (%class.subclasses class))))) + (declare (dynamic-extent #'clear-class)) + (mapc #'clear-class (%method-specializers method))))) + +;;; Remove methods which specialize on a sub-class of method's +;;; specializers from the generic-function dispatch-table dt. +(defun remove-obsoleted-combined-methods (method &optional dt + (specializers (%method-specializers method))) + (without-interrupts + (unless dt + (let ((gf (%method-gf method))) + (when gf (setq dt (%gf-dispatch-table gf))))) + (when dt + (if specializers + (let* ((argnum (%gf-dispatch-table-argnum dt))) + (when (>= argnum 0) + (let ((class (nth argnum specializers)) + (size (%gf-dispatch-table-size dt)) + (index 0)) + (clear-accessor-method-offsets (%gf-dispatch-table-gf dt) method) + (if (typep class 'eql-specializer) + (setq class (class-of (eql-specializer-object class)))) + (while (%i< index size) + (let* ((wrapper (%gf-dispatch-table-ref dt index)) + hash-index-0? + (cpl (and wrapper + (not (setq hash-index-0? + (eql 0 (%wrapper-hash-index wrapper)))) + (%inited-class-cpl + (require-type (%wrapper-class wrapper) 'class))))) + (when (or hash-index-0? (and cpl (cpl-index class cpl))) + (setf (%gf-dispatch-table-ref dt index) *obsolete-wrapper* + (%gf-dispatch-table-ref dt (%i+ index 1)) *gf-dispatch-bug*)) + (setq index (%i+ index 2))))))) + (setf (%gf-dispatch-table-ref dt 1) nil))))) ; clear 0-arg gf cm + +;;; SETQ'd below after the GF's exist. +(defvar *initialization-invalidation-alist* nil) + +;;; Called by %add-method, %remove-method +(defun invalidate-initargs-vector-for-gf (gf &optional first-specializer &rest other-specializers) + (declare (ignore other-specializers)) + (when (and first-specializer (typep first-specializer 'class)) ; no eql methods or gfs with no specializers need apply + (let ((indices (cdr (assq gf *initialization-invalidation-alist*)))) + (when indices + (labels ((invalidate (class indices) + (when (std-class-p class) ; catch the class named T + (dolist (index indices) + (setf (standard-instance-instance-location-access class index) nil))) + (dolist (subclass (%class.subclasses class)) + (invalidate subclass indices)))) + (invalidate first-specializer indices)))))) + +;;; Return two values: +;;; 1) the index of the first non-T specializer of method, or NIL if +;;; all the specializers are T or only the first one is T +;;; 2) the index of the first non-T specializer +(defun multi-method-index (method &aux (i 0) index) + (dolist (s (%method.specializers method) (values nil index)) + (unless (eq s *t-class*) + (unless index (setq index i)) + (unless (eql i 0) (return (values index index)))) + (incf i))) + +(defun %remove-standard-method-from-containing-gf (method) + (setq method (require-type method 'standard-method)) + (let ((gf (%method-gf method))) + (when gf + (let* ((dt (%gf-dispatch-table gf)) + (methods (sgf.methods gf))) + (setf (%method-gf method) nil) + (setq methods (nremove method methods)) + (setf (%gf-dispatch-table-methods dt) methods + (sgf.methods gf) methods) + (%remove-direct-methods method) + (remove-obsoleted-combined-methods method dt) + (apply #'invalidate-initargs-vector-for-gf gf (%method-specializers method)) + (compute-dcode gf dt) + (when (sgf.dependents gf) + (map-dependents + gf + #'(lambda (d) + (update-dependent gf d 'remove-method method))))))) + method) + + +(defvar *reader-method-function-proto* + #'(lambda (instance) + (slot-value instance 'x))) + + +(defvar *writer-method-function-proto* + #'(lambda (new instance) + (set-slot-value instance 'x new))) + +(defun dcode-for-gf (gf dcode) + (if *uniquify-dcode* + (let ((new-dcode (%copy-function dcode))) + (lfun-name new-dcode (list (lfun-name dcode) (lfun-name gf))) + new-dcode) + dcode)) + +(defstatic *non-dt-dcode-functions* () "List of functions which return a dcode function for the GF which is their argument. The dcode functions will be caled with all of the incoming arguments.") + +(defun non-dt-dcode-function (gf) + (dolist (f *non-dt-dcode-functions*) + (let* ((dcode (funcall f gf))) + (when dcode (return dcode))))) + +(defun compute-dcode (gf &optional dt) + (setq gf (require-type gf 'standard-generic-function)) + (unless dt (setq dt (%gf-dispatch-table gf))) + (let* ((methods (%gf-dispatch-table-methods dt)) + (bits (inner-lfun-bits gf)) + (nreq (ldb $lfbits-numreq bits)) + (0-args? (eql 0 nreq)) + (other-args? (or (not (eql 0 (ldb $lfbits-numopt bits))) + (logbitp $lfbits-rest-bit bits) + (logbitp $lfbits-restv-bit bits) + (logbitp $lfbits-keys-bit bits) + (logbitp $lfbits-aok-bit bits))) + multi-method-index + min-index) + (when methods + (unless 0-args? + (dolist (m methods) + (multiple-value-bind (mm-index index) (multi-method-index m) + (when mm-index + (if (or (null multi-method-index) (< mm-index multi-method-index)) + (setq multi-method-index mm-index))) + (when index + (if (or (null min-index) (< index min-index)) + (setq min-index index)))))) + (let* ((non-dt (non-dt-dcode-function gf)) + (dcode (or non-dt + (if 0-args? + #'%%0-arg-dcode + (or (if multi-method-index + #'%%nth-arg-dcode) + (if (null other-args?) + (if (eql nreq 1) + #'%%one-arg-dcode + (if (eql nreq 2) + #'%%1st-two-arg-dcode + #'%%1st-arg-dcode)) + #'%%1st-arg-dcode)))))) + (setq multi-method-index + (if multi-method-index + (if min-index + (min multi-method-index min-index) + multi-method-index) + 0)) + (let* ((old-dcode (%gf-dcode (find-unencapsulated-definition gf)))) + (when (or non-dt + (neq dcode old-dcode) + (neq multi-method-index (%gf-dispatch-table-argnum dt))) + (clear-gf-dispatch-table dt) + (setf (%gf-dispatch-table-argnum dt) multi-method-index) + (if (function-encapsulated-p gf) + (%set-encapsulated-gf-dcode gf dcode) + (setf (%gf-dcode gf) dcode)))) + (values dcode multi-method-index))))) + +(defun inherits-from-standard-generic-function-p (class) + (memq *standard-generic-function-class* + (%inited-class-cpl (require-type class 'class)))) + +;;;;;;;;;;; The type system needs to get wedged into CLOS fairly early ;;;;;;; + + +;;; Could check for duplicates, but not really worth it. They're all +;;; allocated here +(defun new-type-class (name) + (let* ((class (%istruct + 'type-class + name + #'missing-type-method + nil + nil + #'(lambda (x y) (hierarchical-union2 x y)) + nil + #'(lambda (x y) (hierarchical-intersection2 x y)) + nil + #'missing-type-method + nil + #'missing-type-method))) + (push (cons name class) *type-classes*) + class)) + +;; There are ultimately about a dozen entries on this alist. +(defvar *type-classes* nil) +(declaim (special *wild-type* *empty-type* *universal-type*)) +(defvar *type-kind-info* (make-hash-table :test #'equal)) + +(defun info-type-kind (name) + (gethash name *type-kind-info*)) + +(defun (setf info-type-kind) (val name) + (if val + (setf (gethash name *type-kind-info*) val) + (remhash name *type-kind-info*))) + +(defun missing-type-method (&rest foo) + (error "Missing type method for ~S" foo)) + +(new-type-class 'values) +(new-type-class 'function) +(new-type-class 'constant) +(new-type-class 'wild) +(new-type-class 'bottom) +(new-type-class 'named) +(new-type-class 'hairy) +(new-type-class 'unknown) +(new-type-class 'number) +(new-type-class 'array) +(new-type-class 'member) +(new-type-class 'union) +(new-type-class 'foreign) +(new-type-class 'cons) +(new-type-class 'intersection) +(new-type-class 'negation) +(defparameter *class-type-class* (new-type-class 'class)) + + + + + +;;;;;;;;;;;;;;;;;;;;;;;; Instances and classes ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; + +(declaim (inline non-standard-instance-class-wrapper)) + +(defun non-standard-instance-class-wrapper (instance) + (let* ((typecode (typecode instance))) + (declare (type (unsigned-byte 8) typecode)) + (cond ((eql typecode target::subtag-struct) + (%class.own-wrapper + (class-cell-class (car (%svref instance 0))))) + ((eql typecode target::subtag-istruct) + (istruct-cell-info (%svref instance 0))) + ((eql typecode target::subtag-basic-stream) + (basic-stream.wrapper instance)) + ((typep instance 'funcallable-standard-object) + (gf.instance.class-wrapper instance)) + ((eql typecode target::subtag-macptr) (foreign-instance-class-wrapper instance)) + (t (%class.own-wrapper (class-of instance)))))) + +(defun instance-class-wrapper (instance) + (if (= (typecode instance) target::subtag-instance) + (instance.class-wrapper instance) + (non-standard-instance-class-wrapper instance))) + + +(defun std-instance-class-cell-typep (form class-cell) + (let* ((typecode (typecode form)) + (wrapper (cond ((= typecode target::subtag-instance) + (instance.class-wrapper form)) + ((= typecode target::subtag-basic-stream) + (basic-stream.wrapper form)) + (t nil)))) + (declare (type (unsigned-byte 8) typecode)) + (when wrapper + (loop + (let ((class (class-cell-class class-cell))) + (if class + (let* ((ordinal (%class-ordinal class)) + (bits (or (%wrapper-cpl-bits wrapper) + (make-cpl-bits (%inited-class-cpl (%wrapper-class wrapper)))))) + (declare (fixnum ordinal)) + (return + (if bits + (locally (declare (simple-bit-vector bits) + (optimize (speed 3) (safety 0))) + (if (< ordinal (length bits)) + (not (eql 0 (sbit bits ordinal)))))))) + (let* ((name (class-cell-name class-cell)) + (new-cell (find-class-cell name nil))) + (unless + (if (and new-cell (not (eq class-cell new-cell))) + (setq class-cell new-cell class (class-cell-class class-cell)) + (return (typep form name))))))))))) + +(defun class-cell-typep (form class-cell) + (locally (declare (type class-cell class-cell)) + (loop + (let ((class (class-cell-class class-cell))) + (if class + (let* ((ordinal (%class-ordinal class)) + (wrapper (instance-class-wrapper form)) + (bits (or (%wrapper-cpl-bits wrapper) + (make-cpl-bits (%inited-class-cpl (%wrapper-class wrapper)))))) + (declare (fixnum ordinal)) + (return + (if bits + (locally (declare (simple-bit-vector bits) + (optimize (speed 3) (safety 0))) + (if (< ordinal (length bits)) + (not (eql 0 (sbit bits ordinal)))))))) + (let* ((name (class-cell-name class-cell)) + (new-cell (find-class-cell name nil))) + (unless + (if (and new-cell (not (eq class-cell new-cell))) + (setq class-cell new-cell class (class-cell-class class-cell)) + (return (typep form name)))))))))) + + + +(defun %require-type-class-cell (arg class-cell) + (if (class-cell-typep arg class-cell) + arg + (%kernel-restart $xwrongtype arg (car class-cell)))) + + + + +(defun find-class (name &optional (errorp t) environment) + (declare (optimize speed)) + (let* ((cell (find-class-cell name nil))) + (declare (type class-cell cell)) + (or (and cell (class-cell-class cell)) + (let ((defenv (and environment (definition-environment environment)))) + (when defenv + (dolist (class (defenv.classes defenv)) + (when (eq name (%class.name class)) + (return class))))) + (when (or errorp (not (symbolp name))) + (cerror "Try finding the class again" + "Class named ~S not found." name) + (find-class name errorp environment))))) + +(fset 'pessimize-make-instance-for-class-name ;; redefined later + (qlfun bootstrapping-pessimize-make-instance-for-class-name (name) name)) + +(defun update-class-proper-names (name old-class new-class) + (when name + (pessimize-make-instance-for-class-name name)) + (when (and old-class + (not (eq old-class new-class)) + (eq (%class-proper-name old-class) name)) + (setf (%class-proper-name old-class) nil)) + (when (and new-class (eq (%class-name new-class) name)) + (setf (%class-proper-name new-class) name))) + + +(fset 'set-find-class (nfunction bootstrapping-set-find-class ; redefined below + (lambda (name class) + (clear-type-cache) + (let* ((cell (find-class-cell name t)) + (old-class (class-cell-class cell))) + (when class + (if (eq name (%class.name class)) + (setf (info-type-kind name) :instance))) + (setf (class-cell-class cell) class) + (update-class-proper-names name old-class class) + class)))) + + +;;; bootstrapping definition. real one is in "sysutils.lisp" +(fset 'built-in-type-p (nfunction boostrapping-built-in-typep-p + (lambda (name) + (or (type-predicate name) + (memq name '(signed-byte unsigned-byte mod + values satisfies member and or not)) + (typep (find-class name nil) 'built-in-class))))) + + + +(defun %compile-time-defclass (name environment) + (note-type-info name 'class environment) + (unless (find-class name nil environment) + (let ((defenv (definition-environment environment))) + (when defenv + (push (make-instance 'compile-time-class :name name) + (defenv.classes defenv))))) + name) + +(eval-when (:compile-toplevel :execute) +(declaim (inline standard-instance-p)) +) + + + + +(defun standard-instance-p (i) + (eq (typecode i) target::subtag-instance)) + +(defun check-setf-find-class-protected-class (old-class new-class name) + (when (and (standard-instance-p old-class) + (%class-kernel-p old-class) + *warn-if-redefine-kernel* + ;; EQL might be necessary on foreign classes + (not (eq new-class old-class))) + (cerror "Setf (FIND-CLASS ~s) to the new class." + "The class name ~s currently denotes the class ~s that +marked as being a critical part of the system; an attempt is being made +to replace that class with ~s" name old-class new-class) + (setf (%class-kernel-p old-class) nil))) + + +(queue-fixup + (defun set-find-class (name class) + (setq name (require-type name 'symbol)) + (let* ((cell (find-class-cell name t)) + (old-class (class-cell-class cell))) + (declare (type class-cell cell)) + (when old-class + (when (eq (%class.name old-class) name) + (setf (info-type-kind name) nil) + (clear-type-cache)) + (when *warn-if-redefine-kernel* + (check-setf-find-class-protected-class old-class class name))) + (when (null class) + (when cell + (setf (class-cell-class cell) nil)) + (update-class-proper-names name old-class class) + (return-from set-find-class nil)) + (setq class (require-type class 'class)) + (when (built-in-type-p name) + (unless (eq (class-cell-class cell) class) + (error "Cannot redefine built-in type name ~S" name))) + (when (eq (%class.name class) name) + (when (%deftype-expander name) + (cerror "set ~S anyway, removing the ~*~S definition" + "Cannot set ~S because type ~S is already defined by ~S" + `(find-class ',name) name 'deftype) + (%deftype name nil nil)) + (setf (info-type-kind name) :instance)) + (update-class-proper-names name old-class class) + (setf (class-cell-class cell) class))) + ) ; end of queue-fixup + + + +#|| +; This tended to cluster entries in gf dispatch tables too much. +(defvar *class-wrapper-hash-index* 0) +(defun new-class-wrapper-hash-index () + (let ((index *class-wrapper-hash-index*)) + (setq *class-wrapper-hash-index* + (if (< index (- most-positive-fixnum 2)) + ; Increment by two longwords. This is important! + ; The dispatch code will break if you change this. + (%i+ index 3) ; '3 = 24 bytes = 6 longwords in lap. + 1)))) +||# + +(defglobal *next-class-ordinal* 0) + +(defun %next-class-ordinal () + (%atomic-incf-node 1 '*next-class-ordinal* target::symbol.vcell)) + +;;; Initialized after built-in-class is made +(defvar *built-in-class-wrapper* nil) + +(defun make-class-ctype (class) + (%istruct 'class-ctype *class-type-class* nil class nil)) + +(defun %class-ordinal (class &optional no-error) + (if (standard-instance-p class) + (instance.hash class) + (if (typep class 'macptr) + (foreign-class-ordinal class) + (unless no-error + (error "Can't determine ordinal of ~s" class))))) + +(defun (setf %class-ordinal) (new class &optional no-error) + (if (standard-instance-p class) + (setf (instance.hash class) new) + (if (typep class 'macptr) + (setf (foreign-class-ordinal class) new) + (unless no-error + (error "Can't set ordinal of class ~s to ~s" class new))))) + + +(defvar *t-class* (let* ((class (%cons-built-in-class 't))) + (setf (instance.hash class) 0) + (let* ((cpl (list class)) + (wrapper (%cons-wrapper class (new-class-wrapper-hash-index)))) + (setf (%class.cpl class) cpl) + (setf (%wrapper-cpl wrapper) cpl + (%class.own-wrapper class) wrapper + (%wrapper-cpl-bits wrapper) #*1) + (setf (%class.ctype class) (make-class-ctype class)) + (setf (find-class 't) class) + class))) + +(defun compute-cpl (class) + (flet ((%real-class-cpl (class) + (or (%class-cpl class) + (compute-cpl class)))) + (let* ((predecessors (list (list class))) candidates cpl) + (dolist (sup (%class-direct-superclasses class)) + (when (symbolp sup) (report-bad-arg sup 'class)) + (dolist (sup (%real-class-cpl sup)) + (unless (assq sup predecessors) (push (list sup) predecessors)))) + (labels ((compute-predecessors (class table) + (dolist (sup (%class-direct-superclasses class) table) + (compute-predecessors sup table) + ;(push class (cdr (assq sup table))) + (let ((a (assq sup table))) (%rplacd a (cons class (%cdr a)))) + (setq class sup)))) + (compute-predecessors class predecessors)) + (setq candidates (list (assq class predecessors))) + (while predecessors + (dolist (c candidates (error "Inconsistent superclasses for ~d" class)) + (when (null (%cdr c)) + (setq predecessors (nremove c predecessors)) + (dolist (p predecessors) (%rplacd p (nremove (%car c) (%cdr p)))) + (setq candidates (nremove c candidates)) + (setq cpl (%rplacd c cpl)) + (dolist (sup (%class-direct-superclasses (%car c))) + (when (setq c (assq sup predecessors)) (push c candidates))) + (return)))) + (setq cpl (nreverse cpl)) + (do* ((tail cpl (%cdr tail)) + sup-cpl) + ((null (setq sup-cpl (and (cdr tail) (%real-class-cpl (cadr tail)))))) + (when (equal (%cdr tail) sup-cpl) + (setf (%cdr tail) sup-cpl) + (return))) + cpl))) + +(defun make-cpl-bits (cpl) + (declare (optimize speed)) + (when cpl + (let* ((max 0)) + (declare (fixnum max)) + (dolist (class cpl) + (let* ((ordinal (%class-ordinal class))) + (declare (fixnum ordinal)) + (when (> ordinal max) + (setq max ordinal)))) + (let* ((bits (make-array (the fixnum (1+ max)) :element-type 'bit))) + (dolist (class cpl bits) + (let* ((ordinal (%class-ordinal class))) + (setf (sbit bits ordinal) 1))))))) + + +(defun make-built-in-class (name &rest supers) + (if (null supers) + (setq supers (list *t-class*)) + (do ((supers supers (%cdr supers))) + ((null supers)) + (when (symbolp (%car supers)) (%rplaca supers (find-class (%car supers)))))) + (let ((class (find-class name nil))) + (if class + (progn + ;Must be debugging. Give a try at redefinition... + (dolist (sup (%class.local-supers class)) + (setf (%class.subclasses sup) (nremove class (%class.subclasses sup))))) + (progn + (setq class (%cons-built-in-class name)) + (setf (instance.hash class) (%next-class-ordinal)))) + (dolist (sup supers) + (setf (%class.subclasses sup) (cons class (%class.subclasses sup)))) + (setf (%class.local-supers class) supers) + (let* ((wrapper (%cons-wrapper class (new-class-wrapper-hash-index))) + (cpl (compute-cpl class))) + (setf (%class.cpl class) cpl) + (setf (%class.own-wrapper class) wrapper) + (setf (%wrapper-cpl wrapper) cpl + (%wrapper-cpl-bits wrapper) (make-cpl-bits cpl) + (%wrapper-class-ordinal wrapper) (%class-ordinal class))) + (setf (%class.ctype class) (make-class-ctype class)) + (setf (find-class name) class) + (dolist (sub (%class.subclasses class)) ; Only non-nil if redefining + ;Recompute the cpl. + (apply #'make-built-in-class (%class.name sub) (%class.local-supers sub))) + class)) + +(defun make-istruct-class (name &rest supers) + (let* ((class (apply #'make-built-in-class name supers)) + (cell (register-istruct-cell name))) + (setf (istruct-cell-info cell) (%class.own-wrapper class)) + class)) + +;;; This will be filled in below. Need it defined now as it goes in +;;; the instance.class-wrapper of all the classes that STANDARD-CLASS +;;; inherits from. +(defstatic *standard-class-wrapper* + (%cons-wrapper 'standard-class)) + +(defun make-standard-class (name &rest supers) + (make-class name *standard-class-wrapper* supers)) + +(defun make-class (name metaclass-wrapper supers &optional own-wrapper) + (let ((class (if (find-class name nil) + (error "Attempt to remake standard class ~s" name) + (%cons-standard-class name metaclass-wrapper)))) + (setf (instance.hash class) (%next-class-ordinal)) + (if (null supers) + (setq supers (list *standard-class-class*)) + (do ((supers supers (cdr supers)) + sup) + ((null supers)) + (setq sup (%car supers)) + (if (symbolp sup) (setf (%car supers) (setq sup (find-class (%car supers))))) + #+nil (unless (or (eq sup *t-class*) (std-class-p sup)) + (error "~a is not of type ~a" sup 'std-class)))) + (setf (%class.local-supers class) supers) + (let ((cpl (compute-cpl class)) + (wrapper (if own-wrapper + (progn + (setf (%wrapper-class own-wrapper) class) + own-wrapper) + (%cons-wrapper class)))) + (setf (%class.cpl class) cpl + (%wrapper-instance-slots wrapper) (vector) + (%class.own-wrapper class) wrapper + (%class.ctype class) (make-class-ctype class) + (%class.slots class) nil + (%wrapper-class-ordinal wrapper) (%class-ordinal class) + (%wrapper-cpl wrapper) cpl + (%wrapper-cpl-bits wrapper) (make-cpl-bits cpl) + (find-class name) class + ) + (dolist (sup supers) + (setf (%class.subclasses sup) (cons class (%class.subclasses sup)))) + class))) + + + + + +(defun standard-object-p (thing) + ;; returns thing's class-wrapper or nil if it isn't a standard-object + (if (standard-instance-p thing) + (instance.class-wrapper thing) + (if (typep thing 'macptr) + (foreign-instance-class-wrapper thing)))) + + +(defun std-class-p (class) + ;; (typep class 'std-class) + ;; but works at bootstrapping time as well + (let ((wrapper (standard-object-p class))) + (and wrapper + (or (eq wrapper *standard-class-wrapper*) + (memq *std-class-class* (%inited-class-cpl (%wrapper-class wrapper) t)))))) + +(set-type-predicate 'std-class 'std-class-p) + +(defun slots-class-p (class) + (let ((wrapper (standard-object-p class))) + (and wrapper + (or (eq wrapper *slots-class-wrapper*) + (memq *slots-class* (%inited-class-cpl (%wrapper-class wrapper) t)))))) + +(set-type-predicate 'slots-class 'slots-class-p) + +(defun specializer-p (thing) + (memq *specializer-class* (%inited-class-cpl (class-of thing)))) + +(defstatic *standard-object-class* (make-standard-class 'standard-object *t-class*)) + +(defstatic *metaobject-class* (make-standard-class 'metaobject *standard-object-class*)) + +(defstatic *specializer-class* (make-standard-class 'specializer *metaobject-class*)) +(defstatic *eql-specializer-class* (make-standard-class 'eql-specializer *specializer-class*)) + +(defstatic *standard-method-combination* + (make-instance-vector + (%class.own-wrapper + (make-standard-class + 'standard-method-combination + (make-standard-class 'method-combination *metaobject-class*))) + 1)) + + +(defun eql-specializer-p (x) + (memq *eql-specializer-class* (%inited-class-cpl (class-of x)))) + +(setf (type-predicate 'eql-specializer) 'eql-specializer-p) + +;;; The *xxx-class-class* instances get slots near the end of this file. +(defstatic *class-class* (make-standard-class 'class *specializer-class*)) + +(defstatic *slots-class* (make-standard-class 'slots-class *class-class*)) +(defstatic *slots-class-wrapper* (%class.own-wrapper *slots-class*)) + + +;;; an implementation class that exists so that +;;; standard-class & funcallable-standard-class can have a common ancestor not +;;; shared by anybody but their subclasses. + +(defstatic *std-class-class* (make-standard-class 'std-class *slots-class*)) + +;;; The class of all objects whose metaclass is standard-class. Yow. +(defstatic *standard-class-class* (make-standard-class 'standard-class *std-class-class*)) +;;; Replace its wrapper and the circle is closed. +(setf (%class.own-wrapper *standard-class-class*) *standard-class-wrapper* + (%wrapper-class *standard-class-wrapper*) *standard-class-class* + (%wrapper-class-ordinal *standard-class-wrapper*) (%class-ordinal *standard-class-class*) + (%wrapper-instance-slots *standard-class-wrapper*) (vector)) + +(defstatic *built-in-class-class* (make-standard-class 'built-in-class *class-class*)) +(setf *built-in-class-wrapper* (%class.own-wrapper *built-in-class-class*) + (instance.class-wrapper *t-class*) *built-in-class-wrapper*) + +(defstatic *structure-class-class* (make-standard-class 'structure-class *slots-class*)) +(defstatic *structure-class-wrapper* (%class.own-wrapper *structure-class-class*)) +(defstatic *structure-object-class* + (make-class 'structure-object *structure-class-wrapper* (list *t-class*))) + +(defstatic *forward-referenced-class-class* + (make-standard-class 'forward-referenced-class *class-class*)) + +(defstatic *function-class* (make-built-in-class 'function)) + +(defun alias-class (name class) + (setf (find-class name) class + (info-type-kind name) :instance) + class) + +;;;Right now, all functions are compiled. + + +(defstatic *compiled-function-class* *function-class*) +(alias-class 'compiled-function *compiled-function-class*) + +(defstatic *compiled-lexical-closure-class* + (make-standard-class 'compiled-lexical-closure *function-class*)) + + + + + +(defstatic *funcallable-standard-class-class* + (make-standard-class 'funcallable-standard-class *std-class-class*)) + +(defstatic *funcallable-standard-object-class* + (make-class 'funcallable-standard-object + (%class.own-wrapper *funcallable-standard-class-class*) + (list *standard-object-class* *function-class*))) + +(defstatic *generic-function-class* + (make-class 'generic-function + (%class.own-wrapper *funcallable-standard-class-class*) + (list *metaobject-class* *funcallable-standard-object-class*))) +(setq *generic-function-class-wrapper* (%class.own-wrapper *generic-function-class*)) + +(defstatic *standard-generic-function-class* + (make-class 'standard-generic-function + (%class.own-wrapper *funcallable-standard-class-class*) + (list *generic-function-class*))) +(setq *standard-generic-function-class-wrapper* + (%class.own-wrapper *standard-generic-function-class*)) + +;;; *standard-method-class* is upgraded to a real class below +(defstatic *method-class* (make-standard-class 'method *metaobject-class*)) +(defstatic *standard-method-class* (make-standard-class 'standard-method *method-class*)) +(defstatic *accessor-method-class* (make-standard-class 'standard-accessor-method *standard-method-class*)) +(defstatic *standard-reader-method-class* (make-standard-class 'standard-reader-method *accessor-method-class*)) +(defstatic *standard-writer-method-class* (make-standard-class 'standard-writer-method *accessor-method-class*)) +(defstatic *method-function-class* (make-standard-class 'method-function *function-class*)) + + +(defstatic *combined-method-class* (make-standard-class 'combined-method *function-class*)) + +(defstatic *slot-definition-class* (make-standard-class 'slot-definition *metaobject-class*)) +(defstatic direct-slot-definition-class (make-standard-class 'direct-slot-definition + *slot-definition-class*)) +(defstatic effective-slot-definition-class (make-standard-class 'effective-slot-definition + *slot-definition-class*)) +(defstatic *standard-slot-definition-class* (make-standard-class 'standard-slot-definition + *slot-definition-class*)) +(defstatic *standard-direct-slot-definition-class* (make-class + 'standard-direct-slot-definition + *standard-class-wrapper* + (list + *standard-slot-definition-class* + direct-slot-definition-class))) + +(defstatic *standard-effective-slot-definition-class* (make-class + 'standard-effective-slot-definition + *standard-class-wrapper* + (list + *standard-slot-definition-class* + effective-slot-definition-class) +)) + +(defstatic *standard-effective-slot-definition-class-wrapper* + (%class.own-wrapper *standard-effective-slot-definition-class*)) + + + + + + + +(let ((*dont-find-class-optimize* t) + (ordinal-type-class-alist ()) + (ordinal-type-class-alist-lock (make-lock))) + + (declare (optimize speed)) ;; make sure everything gets inlined that needs to be. + +;; The built-in classes. + (defstatic *array-class* (make-built-in-class 'array)) + (defstatic *character-class* (make-built-in-class 'character)) + (make-built-in-class 'number) + (make-built-in-class 'sequence) + (defstatic *symbol-class* (make-built-in-class 'symbol)) + (defstatic *immediate-class* (make-built-in-class 'immediate)) ; Random immediate + ;; Random uvectors - these are NOT class of all things represented by a uvector + ;;type. Just random uvectors which don't fit anywhere else. + (make-built-in-class 'ivector) ; unknown ivector + (make-built-in-class 'gvector) ; unknown gvector + (defstatic *istruct-class* (make-built-in-class 'internal-structure)) ; unknown istruct + + (defstatic *slot-vector-class* (make-built-in-class 'slot-vector (find-class 'gvector))) + + (defstatic *macptr-class* (make-built-in-class 'macptr)) + (defstatic *foreign-standard-object-class* + (make-standard-class 'foreign-standard-object + *standard-object-class* *macptr-class*)) + + (defstatic *foreign-class-class* + (make-standard-class 'foreign-class *foreign-standard-object-class* *slots-class*)) + + (make-built-in-class 'population) + (make-built-in-class 'pool) + (make-built-in-class 'package) + (defstatic *lock-class* (make-built-in-class 'lock)) + (defstatic *recursive-lock-class* (make-built-in-class 'recursive-lock *lock-class*)) + (defstatic *read-write-lock-class* (make-built-in-class 'read-write-lock *lock-class*)) + + (make-istruct-class 'lock-acquisition *istruct-class*) + (make-istruct-class 'semaphore-notification *istruct-class*) + (make-istruct-class 'class-wrapper *istruct-class*) + ;; Compiler stuff, mostly + (make-istruct-class 'faslapi *istruct-class*) + (make-istruct-class 'faslstate *istruct-class*) + (make-istruct-class 'var *istruct-class*) + (make-istruct-class 'afunc *istruct-class*) + (make-istruct-class 'lexical-environment *istruct-class*) + (make-istruct-class 'definition-environment *istruct-class*) + (make-istruct-class 'compiler-policy *istruct-class*) + (make-istruct-class 'deferred-warnings *istruct-class*) + (make-istruct-class 'ptaskstate *istruct-class*) + (make-istruct-class 'entry *istruct-class*) + (make-istruct-class 'foreign-object-domain *istruct-class*) + + + (make-istruct-class 'slot-id *istruct-class*) + (make-built-in-class 'value-cell) + (make-istruct-class 'restart *istruct-class*) + (make-istruct-class 'hash-table *istruct-class*) + (make-istruct-class 'readtable *istruct-class*) + (make-istruct-class 'pathname *istruct-class*) + (make-istruct-class 'random-state *istruct-class*) + (make-istruct-class 'xp-structure *istruct-class*) + (make-istruct-class 'lisp-thread *istruct-class*) + (make-istruct-class 'resource *istruct-class*) + (make-istruct-class 'periodic-task *istruct-class*) + (make-istruct-class 'semaphore *istruct-class*) + + (make-istruct-class 'type-class *istruct-class*) + + (defstatic *ctype-class* (make-istruct-class 'ctype *istruct-class*)) + (make-istruct-class 'key-info *istruct-class*) + (defstatic *args-ctype* (make-istruct-class 'args-ctype *ctype-class*)) + (make-istruct-class 'values-ctype *args-ctype*) + (make-istruct-class 'function-ctype *args-ctype*) + (make-istruct-class 'constant-ctype *ctype-class*) + (make-istruct-class 'named-ctype *ctype-class*) + (make-istruct-class 'cons-ctype *ctype-class*) + (make-istruct-class 'unknown-ctype (make-istruct-class 'hairy-ctype *ctype-class*)) + (make-istruct-class 'numeric-ctype *ctype-class*) + (make-istruct-class 'array-ctype *ctype-class*) + (make-istruct-class 'member-ctype *ctype-class*) + (make-istruct-class 'union-ctype *ctype-class*) + (make-istruct-class 'foreign-ctype *ctype-class*) + (make-istruct-class 'class-ctype *ctype-class*) + (make-istruct-class 'negation-ctype *ctype-class*) + (make-istruct-class 'intersection-ctype *ctype-class*) + + (make-istruct-class 'class-cell *istruct-class*) + (make-istruct-class 'type-cell *istruct-class*) + (make-istruct-class 'package-ref *istruct-class*) + + (make-istruct-class 'foreign-variable *istruct-class*) + (make-istruct-class 'external-entry-point *istruct-class*) + (make-istruct-class 'shlib *istruct-class*) + + (make-built-in-class 'complex (find-class 'number)) + (make-built-in-class 'real (find-class 'number)) + (defstatic *float-class* (make-built-in-class 'float (find-class 'real))) + (defstatic *double-float-class* (make-built-in-class 'double-float (find-class 'float))) + (defstatic *single-float-class* (make-built-in-class 'single-float (find-class 'float))) + (alias-class 'short-float *single-float-class*) + (alias-class 'long-float *double-float-class*) + + (make-built-in-class 'rational (find-class 'real)) + (make-built-in-class 'ratio (find-class 'rational)) + (make-built-in-class 'integer (find-class 'rational)) + (defstatic *fixnum-class* (make-built-in-class 'fixnum (find-class 'integer))) + + #+x86-target + (defstatic *tagged-return-address-class* (make-built-in-class 'tagged-return-address)) + (make-built-in-class 'bignum (find-class 'integer)) + + (make-built-in-class 'bit *fixnum-class*) + (make-built-in-class 'unsigned-byte (find-class 'integer)) + (make-built-In-class 'signed-byte (find-class 'integer)) + + + (make-istruct-class 'logical-pathname (find-class 'pathname)) + + (make-istruct-class 'destructure-state *istruct-class*) + + (defstatic *base-char-class* (alias-class 'base-char *character-class*)) + (defstatic *standard-char-class* (make-built-in-class 'standard-char *base-char-class*)) + + (defstatic *keyword-class* (make-built-in-class 'keyword *symbol-class*)) + + (make-built-in-class 'list (find-class 'sequence)) + (defstatic *cons-class* (make-built-in-class 'cons (find-class 'list))) + (defstatic *null-class* (make-built-in-class 'null *symbol-class* (find-class 'list))) + + (defstatic *vector-class* (make-built-in-class 'vector *array-class* (find-class 'sequence))) + (defstatic *simple-array-class* (make-built-in-class 'simple-array *array-class*)) + (make-built-in-class 'simple-1d-array *vector-class* *simple-array-class*) + + ;;Maybe should do *float-array-class* etc? + ;;Also, should straighten out the simple-n-dim-array mess... + (make-built-in-class 'unsigned-byte-vector *vector-class*) + (make-built-in-class 'simple-unsigned-byte-vector (find-class 'unsigned-byte-vector) (find-class 'simple-1d-array)) + (make-built-in-class 'unsigned-word-vector *vector-class*) + (make-built-in-class 'simple-unsigned-word-vector (find-class 'unsigned-word-vector) (find-class 'simple-1d-array)) + (make-built-in-class 'fixnum-vector *vector-class*) + (make-built-in-class 'simple-fixnum-vector (find-class 'fixnum-vector) (find-class 'simple-1d-array)) + + + (progn + (make-built-in-class 'double-float-vector *vector-class*) + (make-built-in-class 'short-float-vector *vector-class*) + (alias-class 'long-float-vector (find-class 'double-float-vector)) + (alias-class 'single-float-vector (find-class 'short-float-vector)) + (make-built-in-class 'simple-double-float-vector (find-class 'double-float-vector) (find-class 'simple-1d-array)) + (make-built-in-class 'simple-short-float-vector (find-class 'short-float-vector) (find-class 'simple-1d-array)) + (alias-class 'simple-long-float-vector (find-class 'simple-double-float-vector)) + (alias-class 'simple-single-float-vector (find-class 'simple-short-float-vector)) + ) + + #+x8664-target + (progn + (make-built-in-class 'symbol-vector (find-class 'gvector)) + (make-built-in-class 'function-vector (find-class 'gvector))) + + #+64-bit-target + (progn + (make-built-in-class 'doubleword-vector *vector-class*) + (make-built-in-class 'simple-doubleword-vector (find-class 'doubleword-vector) (find-class 'simple-1d-array)) + (make-built-in-class 'unsigned-doubleword-vector *vector-class*) + (make-built-in-class 'simple-unsigned-doubleword-vector (find-class 'unsigned-doubleword-vector) (find-class 'simple-1d-array)) + ) ; #+64-bit-target + + (make-built-in-class 'long-vector *vector-class*) + (make-built-in-class 'simple-long-vector (find-class 'long-vector) (find-class 'simple-1d-array)) + (make-built-in-class 'unsigned-long-vector *vector-class*) + (make-built-in-class 'simple-unsigned-long-vector (find-class 'unsigned-long-vector) (find-class 'simple-1d-array)) + (make-built-in-class 'byte-vector *vector-class*) + (make-built-in-class 'simple-byte-vector (find-class 'byte-vector) (find-class 'simple-1d-array)) + (make-built-in-class 'bit-vector *vector-class*) + (make-built-in-class 'simple-bit-vector (find-class 'bit-vector) (find-class 'simple-1d-array)) + (make-built-in-class 'word-vector *vector-class*) + (make-built-in-class 'simple-word-vector (find-class 'word-vector) (find-class 'simple-1d-array)) + (make-built-in-class 'string *vector-class*) + (make-built-in-class 'base-string (find-class 'string)) + (make-built-in-class 'simple-string (find-class 'string) (find-class 'simple-1d-array)) + (make-built-in-class 'simple-base-string (find-class 'base-string) (find-class 'simple-string)) + (make-built-in-class 'general-vector *vector-class*) + (make-built-in-class 'simple-vector (find-class 'general-vector) (find-class 'simple-1d-array)) + + (make-built-in-class 'hash-table-vector) + (make-built-in-class 'catch-frame) + (make-built-in-class 'code-vector) + #+ppc32-target + (make-built-in-class 'creole-object) + + (make-built-in-class 'xfunction) + (make-built-in-class 'xcode-vector) + + (defun class-cell-find-class (class-cell errorp) + (unless (istruct-typep class-cell 'class-cell) + (setq class-cell (%kernel-restart $xwrongtype class-cell 'class-cell))) + (locally (declare (type class-cell class-cell)) + (let ((class (class-cell-class class-cell))) + (or class + (and + (setq class (find-class (class-cell-name class-cell) nil)) + (when class + (setf (class-cell-class class-cell) class) + class)) + (if errorp (error "Class ~s not found." (class-cell-name class-cell)) nil))))) + +;;; (%wrapper-class (instance.class-wrapper frob)) + + + + (defstatic *general-vector-class* (find-class 'general-vector)) + + #+ppc32-target + (defparameter *ivector-vector-classes* + (vector (find-class 'short-float-vector) + (find-class 'unsigned-long-vector) + (find-class 'long-vector) + (find-class 'fixnum-vector) + (find-class 'base-string) + (find-class 'unsigned-byte-vector) + (find-class 'byte-vector) + *t-class* ; old base-string + (find-class 'unsigned-word-vector) + (find-class 'word-vector) + (find-class 'double-float-vector) + (find-class 'bit-vector))) + + #+ppc64-target + (defparameter *ivector-vector-classes* + (vector *t-class* + *t-class* + *t-class* + *t-class* + (find-class 'byte-vector) + (find-class 'word-vector) + (find-class 'long-vector) + (find-class 'doubleword-vector) + (find-class 'unsigned-byte-vector) + (find-class 'unsigned-word-vector) + (find-class 'unsigned-long-vector) + (find-class 'unsigned-doubleword-vector) + *t-class* + *t-class* + (find-class 'short-float-vector) + (find-class 'fixnum-vector) + *t-class* + *t-class* + *t-class* + (find-class 'double-float-vector) + (find-class 'base-string) + *t-class* + (find-class 'base-string) + *t-class* + *t-class* + *t-class* + *t-class* + *t-class* + *t-class* + (find-class 'bit-vector) + *t-class* + *t-class*)) + + #+x8632-target + (defparameter *ivector-vector-classes* + (vector (find-class 'short-float-vector) + (find-class 'unsigned-long-vector) + (find-class 'long-vector) + (find-class 'fixnum-vector) + (find-class 'base-string) + (find-class 'unsigned-byte-vector) + (find-class 'byte-vector) + *t-class* + (find-class 'unsigned-word-vector) + (find-class 'word-vector) + (find-class 'double-float-vector) + (find-class 'bit-vector))) + + #+x8664-target + (progn + (defparameter *immheader-0-classes* + (vector *t-class* + *t-class* + *t-class* + *t-class* + *t-class* + *t-class* + *t-class* + *t-class* + *t-class* + *t-class* + (find-class 'word-vector) + (find-class 'unsigned-word-vector) + (find-class 'base-string) ;old + (find-class 'byte-vector) + (find-class 'unsigned-byte-vector) + (find-class 'bit-vector))) + + (defparameter *immheader-1-classes* + (vector *t-class* + *t-class* + *t-class* + *t-class* + *t-class* + *t-class* + *t-class* + *t-class* + *t-class* + *t-class* + *t-class* + *t-class* + (find-class 'base-string) + (find-class 'long-vector) + (find-class 'unsigned-long-vector) + (find-class 'short-float-vector))) + + (defparameter *immheader-2-classes* + (vector *t-class* + *t-class* + *t-class* + *t-class* + *t-class* + *t-class* + *t-class* + *t-class* + *t-class* + *t-class* + *t-class* + *t-class* + (find-class 'fixnum-vector) + (find-class 'doubleword-vector) + (find-class 'unsigned-doubleword-vector) + (find-class 'double-float-vector)))) + + + + (defun make-foreign-object-domain (&key index name recognize class-of classp + instance-class-wrapper + class-own-wrapper + slots-vector class-ordinal + set-class-ordinal) + (%istruct 'foreign-object-domain index name recognize class-of classp + instance-class-wrapper class-own-wrapper slots-vector + class-ordinal set-class-ordinal)) + + (let* ((n-foreign-object-domains 0) + (foreign-object-domains (make-array 10)) + (foreign-object-domain-lock (make-lock))) + (defun register-foreign-object-domain (name + &key + recognize + class-of + classp + instance-class-wrapper + class-own-wrapper + slots-vector + class-ordinal + set-class-ordinal) + (with-lock-grabbed (foreign-object-domain-lock) + (dotimes (i n-foreign-object-domains) + (let* ((already (svref foreign-object-domains i))) + (when (eq name (foreign-object-domain-name already)) + (setf (foreign-object-domain-recognize already) recognize + (foreign-object-domain-class-of already) class-of + (foreign-object-domain-classp already) classp + (foreign-object-domain-instance-class-wrapper already) + instance-class-wrapper + (foreign-object-domain-class-own-wrapper already) + class-own-wrapper + (foreign-object-domain-slots-vector already) slots-vector + (foreign-object-domain-class-ordinal already) class-ordinal + (foreign-object-domain-set-class-ordinal already) + set-class-ordinal) + (return-from register-foreign-object-domain i)))) + (let* ((i n-foreign-object-domains) + (new (make-foreign-object-domain :index i + :name name + :recognize recognize + :class-of class-of + :classp classp + :instance-class-wrapper + instance-class-wrapper + :class-own-wrapper + class-own-wrapper + :slots-vector + slots-vector + :class-ordinal class-ordinal + :set-class-ordinal set-class-ordinal))) + (incf n-foreign-object-domains) + (if (= i (length foreign-object-domains)) + (setq foreign-object-domains (%extend-vector i foreign-object-domains (* i 2)))) + (setf (svref foreign-object-domains i) new) + i))) + (defun foreign-class-of (p) + (funcall (foreign-object-domain-class-of (svref foreign-object-domains (%macptr-domain p))) p)) + (defun foreign-classp (p) + (funcall (foreign-object-domain-classp (svref foreign-object-domains (%macptr-domain p))) p)) + (defun foreign-instance-class-wrapper (p) + (funcall (foreign-object-domain-instance-class-wrapper (svref foreign-object-domains (%macptr-domain p))) p)) + (defun foreign-class-own-wrapper (p) + (funcall (foreign-object-domain-class-own-wrapper (svref foreign-object-domains (%macptr-domain p))) p)) + (defun foreign-slots-vector (p) + (funcall (foreign-object-domain-slots-vector (svref foreign-object-domains (%macptr-domain p))) p)) + (defun foreign-class-ordinal (p) + (funcall (foreign-object-domain-class-ordinal (svref foreign-object-domains (%macptr-domain p))) p)) + (defun (setf foreign-class-ordinal) (new p) + (funcall (foreign-object-domain-set-class-ordinal (svref foreign-object-domains (%macptr-domain p))) p new)) + (defun classify-foreign-pointer (p) + (do* ((i (1- n-foreign-object-domains) (1- i))) + ((zerop i) (error "this can't happen")) + (when (funcall (foreign-object-domain-recognize (svref foreign-object-domains i)) p) + (%set-macptr-domain p i) + (return p))))) + + (defun constantly (x) + "Return a function that always returns VALUE." + #'(lambda (&rest ignore) + (declare (dynamic-extent ignore) + (ignore ignore)) + x)) + + (defun %register-type-ordinal-class (foreign-type class-name) + ;; ordinal-type-class shouldn't already exist + (with-lock-grabbed (ordinal-type-class-alist-lock) + (or (let* ((class (cdr (assq foreign-type ordinal-type-class-alist)))) + (if (and class (eq class-name (class-name class))) + class)) + (let* ((class (make-built-in-class class-name 'macptr))) + (push (cons foreign-type class) ordinal-type-class-alist) + class)))) + + (defun %ordinal-type-class-for-macptr (p) + (with-lock-grabbed (ordinal-type-class-alist-lock) + (or (unless (%null-ptr-p p) + (cdr (assoc (%macptr-type p) ordinal-type-class-alist :key #'foreign-type-ordinal))) + *macptr-class*))) + + + (register-foreign-object-domain :unclassified + :recognize #'(lambda (p) + (declare (ignore p)) + (error "Shouldn't happen")) + :class-of #'(lambda (p) + (foreign-class-of + (classify-foreign-pointer p))) + :classp #'(lambda (p) + (foreign-classp + (classify-foreign-pointer p))) + :instance-class-wrapper + #'(lambda (p) + (foreign-instance-class-wrapper + (classify-foreign-pointer p))) + :class-own-wrapper + #'(lambda (p) + (foreign-class-own-wrapper + (classify-foreign-pointer p))) + :slots-vector + #'(lambda (p) + (foreign-slots-vector + (classify-foreign-pointer p)))) + +;;; "Raw" macptrs, that aren't recognized as "standard foreign objects" +;;; in some other domain, should always be recognized as such (and this +;;; pretty much has to be domain #1.) + + (register-foreign-object-domain :raw + :recognize #'true + :class-of #'%ordinal-type-class-for-macptr + :classp #'false + :instance-class-wrapper + (lambda (p) + (%class.own-wrapper (%ordinal-type-class-for-macptr p))) + :class-own-wrapper #'false + :slots-vector #'false) + + (defstatic *class-table* + (let* ((v (make-array 256 :initial-element nil)) + (class-of-function-function + #'(lambda (thing) + (let ((bits (lfun-bits-known-function thing))) + (declare (fixnum bits)) + (if (logbitp $lfbits-trampoline-bit bits) + ;; closure + (let ((inner-fn (closure-function thing))) + (if (neq inner-fn thing) + (let ((inner-bits (lfun-bits inner-fn))) + (if (logbitp $lfbits-method-bit inner-bits) + *compiled-lexical-closure-class* + (if (logbitp $lfbits-gfn-bit inner-bits) + (%wrapper-class (gf.instance.class-wrapper thing)) + (if (logbitp $lfbits-cm-bit inner-bits) + *combined-method-class* + *compiled-lexical-closure-class*)))) + *compiled-lexical-closure-class*)) + (if (logbitp $lfbits-method-bit bits) + *method-function-class* + (if (logbitp $lfbits-gfn-bit bits) + (%wrapper-class (gf.instance.class-wrapper thing)) + (if (logbitp $lfbits-cm-bit bits) + *combined-method-class* + *compiled-function-class*)))))))) + ;; Make one loop through the vector, initializing fixnum & list + ;; cells. Set all immediates to *immediate-class*, then + ;; special-case characters later. + #+ppc32-target + (do* ((slice 0 (+ 8 slice))) + ((= slice 256)) + (declare (type (unsigned-byte 8) slice)) + (setf (%svref v (+ slice ppc32::fulltag-even-fixnum)) *fixnum-class* + (%svref v (+ slice ppc32::fulltag-odd-fixnum)) *fixnum-class* + (%svref v (+ slice ppc32::fulltag-cons)) *cons-class* + (%svref v (+ slice ppc32::fulltag-nil)) *null-class* + (%svref v (+ slice ppc32::fulltag-imm)) *immediate-class*)) + #+ppc64-target + (do* ((slice 0 (+ 16 slice))) + ((= slice 256)) + (declare (type (unsigned-byte 8) slice)) + (setf (%svref v (+ slice ppc64::fulltag-even-fixnum)) *fixnum-class* + (%svref v (+ slice ppc64::fulltag-odd-fixnum)) *fixnum-class* + (%svref v (+ slice ppc64::fulltag-cons)) *cons-class* + (%svref v (+ slice ppc64::fulltag-imm-0)) *immediate-class* + (%svref v (+ slice ppc64::fulltag-imm-1)) *immediate-class* + (%svref v (+ slice ppc64::fulltag-imm-2)) *immediate-class* + (%svref v (+ slice ppc64::fulltag-imm-3)) *immediate-class*)) + #+x8632-target + (do* ((slice 0 (+ 8 slice)) + (cons-fn #'(lambda (x) (if (null x) *null-class* *cons-class*)))) + ((= slice 256)) + (declare (type (unsigned-byte 8) slice)) + (setf (%svref v (+ slice x8632::fulltag-even-fixnum)) *fixnum-class* + (%svref v (+ slice x8632::fulltag-odd-fixnum)) *fixnum-class* + (%svref v (+ slice x8632::fulltag-cons)) cons-fn + (%svref v (+ slice x8632::fulltag-tra)) *tagged-return-address-class* + (%svref v (+ slice x8632::fulltag-imm)) *immediate-class*)) + #+x8664-target + (do* ((slice 0 (+ 16 slice))) + ((= slice 256)) + (declare (type (unsigned-byte 8) slice)) + (setf (%svref v (+ slice x8664::fulltag-even-fixnum)) *fixnum-class* + (%svref v (+ slice x8664::fulltag-odd-fixnum)) *fixnum-class* + (%svref v (+ slice x8664::fulltag-cons)) *cons-class* + (%svref v (+ slice x8664::fulltag-imm-0)) *immediate-class* + (%svref v (+ slice x8664::fulltag-imm-1)) *immediate-class* + (%svref v (+ slice x8664::fulltag-tra-0)) *tagged-return-address-class* + (%svref v (+ slice x8664::fulltag-tra-1)) *tagged-return-address-class* + (%svref v (+ slice x8664::fulltag-nil)) *null-class*)) + (macrolet ((map-subtag (subtag class-name) + `(setf (%svref v ,subtag) (find-class ',class-name)))) + ;; immheader types map to built-in classes. + (map-subtag target::subtag-bignum bignum) + (map-subtag target::subtag-double-float double-float) + (map-subtag target::subtag-single-float short-float) + (map-subtag target::subtag-dead-macptr ivector) + #-x86-target + (map-subtag target::subtag-code-vector code-vector) + #+ppc32-target + (map-subtag ppc32::subtag-creole-object creole-object) + (map-subtag target::subtag-xcode-vector xcode-vector) + (map-subtag target::subtag-xfunction xfunction) + (map-subtag target::subtag-single-float-vector simple-short-float-vector) + #+64-bit-target + (map-subtag target::subtag-u64-vector simple-unsigned-doubleword-vector) + #+64-bit-target + (map-subtag target::subtag-s64-vector simple-doubleword-vector) + (map-subtag target::subtag-fixnum-vector simple-fixnum-vector) + (map-subtag target::subtag-u32-vector simple-unsigned-long-vector) + (map-subtag target::subtag-s32-vector simple-long-vector) + (map-subtag target::subtag-u8-vector simple-unsigned-byte-vector) + (map-subtag target::subtag-s8-vector simple-byte-vector) + (map-subtag target::subtag-simple-base-string simple-base-string) + (map-subtag target::subtag-u16-vector simple-unsigned-word-vector) + (map-subtag target::subtag-s16-vector simple-word-vector) + (map-subtag target::subtag-double-float-vector simple-double-float-vector) + (map-subtag target::subtag-bit-vector simple-bit-vector) + ;; Some nodeheader types map to built-in-classes; others require + ;; further dispatching. + (map-subtag target::subtag-ratio ratio) + (map-subtag target::subtag-complex complex) + (map-subtag target::subtag-catch-frame catch-frame) + (map-subtag target::subtag-hash-vector hash-table-vector) + (map-subtag target::subtag-value-cell value-cell) + (map-subtag target::subtag-pool pool) + (map-subtag target::subtag-weak population) + (map-subtag target::subtag-package package) + (map-subtag target::subtag-simple-vector simple-vector) + (map-subtag target::subtag-slot-vector slot-vector) + #+x8664-target (map-subtag x8664::subtag-symbol symbol-vector) + #+x8664-target (map-subtag x8664::subtag-function function-vector)) + (setf (%svref v target::subtag-arrayH) + #'(lambda (x) + (if (logbitp $arh_simple_bit + (the fixnum (%svref x target::arrayH.flags-cell))) + *simple-array-class* + *array-class*))) + ;; These need to be special-cased: + (setf (%svref v target::subtag-macptr) #'foreign-class-of) + (setf (%svref v target::subtag-character) + #'(lambda (c) (let* ((code (%char-code c))) + (if (or (eq c #\NewLine) + (and (>= code (char-code #\space)) + (< code (char-code #\rubout)))) + *standard-char-class* + *base-char-class*)))) + (setf (%svref v target::subtag-struct) + #'(lambda (s) (%structure-class-of s))) ; need DEFSTRUCT + (setf (%svref v target::subtag-istruct) + #'(lambda (i) + (let* ((cell (%svref i 0)) + (wrapper (istruct-cell-info cell))) + (if wrapper + (%wrapper-class wrapper) + (or (find-class (istruct-cell-name cell) nil) + *istruct-class*))))) + (setf (%svref v target::subtag-basic-stream) + #'(lambda (b) (%wrapper-class (basic-stream.wrapper b)))) + (setf (%svref v target::subtag-instance) + #'%class-of-instance) + (setf (%svref v #+ppc-target target::subtag-symbol + #+x8632-target target::subtag-symbol + #+x8664-target target::tag-symbol) + #-ppc64-target + #'(lambda (s) (if (eq (symbol-package s) *keyword-package*) + *keyword-class* + *symbol-class*)) + #+ppc64-target + #'(lambda (s) + (if s + (if (eq (symbol-package s) *keyword-package*) + *keyword-class* + *symbol-class*) + *null-class*))) + + (setf (%svref v + #+ppc-target target::subtag-function + #+x8632-target target::subtag-function + #+x8664-target target::tag-function) + class-of-function-function) + (setf (%svref v target::subtag-vectorH) + #'(lambda (v) + (let* ((subtype (%array-header-subtype v))) + (declare (fixnum subtype)) + (if (eql subtype target::subtag-simple-vector) + *general-vector-class* + #-x8664-target + (%svref *ivector-vector-classes* + #+ppc32-target + (ash (the fixnum (- subtype ppc32::min-cl-ivector-subtag)) + (- ppc32::ntagbits)) + #+ppc64-target + (ash (the fixnum (logand subtype #x7f)) (- ppc64::nlowtagbits)) + #+x8632-target + (ash (the fixnum (- subtype x8632::min-cl-ivector-subtag)) + (- x8632::ntagbits))) + #+x8664-target + (let* ((class (logand x8664::fulltagmask subtype)) + (idx (ash subtype (- x8664::ntagbits)))) + (cond ((= class x8664::fulltag-immheader-0) + (%svref *immheader-0-classes* idx)) + ((= class x8664::fulltag-immheader-1) + (%svref *immheader-1-classes* idx)) + ((= class x8664::fulltag-immheader-2) + (%svref *immheader-2-classes* idx)) + (t *t-class*))) + + )))) + (setf (%svref v target::subtag-lock) + #'(lambda (thing) + (case (%svref thing target::lock.kind-cell) + (recursive-lock *recursive-lock-class*) + (read-write-lock *read-write-lock-class*) + (t *lock-class*)))) + v)) + + + + + + (defun no-class-error (x) + (error "Bug (probably): can't determine class of ~s" x)) + + + ; return frob from table + + + + + ) ; end let + + + +(defun classp (x) + (if (%standard-instance-p x) + (< (the fixnum (instance.hash x)) max-class-ordinal) + (and (typep x 'macptr) (foreign-classp x)))) + +(set-type-predicate 'class 'classp) + +(defun subclassp (c1 c2) + (and (classp c1) + (classp c2) + (not (null (memq c2 (%inited-class-cpl c1 t)))))) + +(defun %class-get (class indicator &optional default) + (let ((cell (assq indicator (%class-alist class)))) + (if cell (cdr cell) default))) + +(defun %class-put (class indicator value) + (let ((cell (assq indicator (%class-alist class)))) + (if cell + (setf (cdr cell) value) + (push (cons indicator value) (%class-alist class)))) + value) + +(defsetf %class-get %class-put) + +(defun %class-remprop (class indicator) + (let* ((handle (cons nil (%class-alist class))) + (last handle)) + (declare (dynamic-extent handle)) + (while (cdr last) + (if (eq indicator (caar (%cdr last))) + (progn + (setf (%cdr last) (%cddr last)) + (setf (%class-alist class) (%cdr handle))) + (setf last (%cdr last)))))) + + +(pushnew :primary-classes *features*) + +(defun %class-primary-p (class) + (if (typep class 'slots-class) + (%class-get class :primary-p) + t)) + +(defun (setf %class-primary-p) (value class) + (if value + (setf (%class-get class :primary-p) value) + (progn + (%class-remprop class :primary-p) + nil))) + +;;; Returns the first element of the CPL that is primary +(defun %class-or-superclass-primary-p (class) + (unless (class-has-a-forward-referenced-superclass-p class) + (dolist (super (%inited-class-cpl class t)) + (when (and (typep super 'standard-class) (%class-primary-p super)) + (return super))))) + + +;;; Bootstrapping version of union +(unless (fboundp 'union) + (fset 'union (nlambda bootstrapping-union (l1 l2) + (dolist (e l1) + (unless (memq e l2) + (push e l2))) + l2)) +) + +(defun %add-direct-methods (method) + (dolist (spec (%method-specializers method)) + (%do-add-direct-method spec method))) + +(defun %do-add-direct-method (spec method) + (pushnew method (specializer.direct-methods spec))) + +(defun %remove-direct-methods (method) + (dolist (spec (%method-specializers method)) + (%do-remove-direct-method spec method))) + +(defun %do-remove-direct-method (spec method) + (setf (specializer.direct-methods spec) + (nremove method (specializer.direct-methods spec)))) + +(ensure-generic-function 'initialize-instance + :lambda-list '(instance &rest initargs &key &allow-other-keys)) + +(defmethod find-method ((generic-function standard-generic-function) + method-qualifiers specializers &optional (errorp t)) + (dolist (m (%gf-methods generic-function) + (when errorp + (cerror "Try finding the method again" + "~s has no method for ~s ~s" + generic-function method-qualifiers specializers) + (find-method generic-function method-qualifiers specializers + errorp))) + (flet ((err () + (error "Wrong number of specializers: ~s" specializers))) + (let ((ss (%method-specializers m)) + (q (%method-qualifiers m)) + s) + (when (equal q method-qualifiers) + (dolist (spec (canonicalize-specializers specializers nil) + (if (null ss) + (return-from find-method m) + (err))) + (unless (setq s (pop ss)) + (err)) + (unless (eq s spec) + (return)))))))) + +(defmethod create-reader-method-function ((class slots-class) + (reader-method-class standard-reader-method) + (dslotd direct-slot-definition)) + #+ppc-target + (gvector :function + (uvref *reader-method-function-proto* 0) + (ensure-slot-id (%slot-definition-name dslotd)) + 'slot-id-value + nil ;method-function name + (dpb 1 $lfbits-numreq (ash 1 $lfbits-method-bit))) + #+x86-target + (%clone-x86-function + *reader-method-function-proto* + (ensure-slot-id (%slot-definition-name dslotd)) + 'slot-id-value + nil ;method-function name + (dpb 1 $lfbits-numreq (ash 1 $lfbits-method-bit)))) + +(defmethod create-writer-method-function ((class slots-class) + (writer-method-class standard-writer-method) + (dslotd direct-slot-definition)) + #+ppc-target + (gvector :function + (uvref *writer-method-function-proto* 0) + (ensure-slot-id (%slot-definition-name dslotd)) + 'set-slot-id-value + nil + (dpb 2 $lfbits-numreq (ash 1 $lfbits-method-bit))) + #+x86-target + (%clone-x86-function + *writer-method-function-proto* + (ensure-slot-id (%slot-definition-name dslotd)) + 'set-slot-id-value + nil + (dpb 2 $lfbits-numreq (ash 1 $lfbits-method-bit))) + ) + + + + + + +(defun %make-instance (class-cell &rest initargs) + (declare (dynamic-extent initargs)) + (declare (optimize speed)) ;; make sure everything gets inlined that needs to be. + (apply #'make-instance + (or (class-cell-class class-cell) (class-cell-name (the class-cell class-cell))) + initargs)) + + +(defmethod make-instance ((class symbol) &rest initargs) + (declare (dynamic-extent initargs)) + (apply 'make-instance (find-class class) initargs)) + + +(defmethod make-instance ((class standard-class) &rest initargs &key &allow-other-keys) + (declare (dynamic-extent initargs)) + (%make-std-instance class initargs)) + +(defmethod make-instance ((class std-class) &rest initargs &key &allow-other-keys) + (declare (dynamic-extent initargs)) + (%make-std-instance class initargs)) + + +(defun %make-std-instance (class initargs) + (setq initargs (default-initargs class initargs)) + (when initargs + (apply #'check-initargs + nil class initargs t + #'initialize-instance #'allocate-instance #'shared-initialize + nil)) + (let ((instance (apply #'allocate-instance class initargs))) + (apply #'initialize-instance instance initargs) + instance)) + +(defun default-initargs (class initargs) + (unless (std-class-p class) + (setq class (require-type class 'std-class))) + (when (null (%class.cpl class)) (update-class class t)) + (let ((defaults ())) + (dolist (key.form (%class-default-initargs class)) + (unless (pl-search initargs (%car key.form)) + (setq defaults + (list* (funcall (caddr key.form)) + (%car key.form) + defaults)))) + (when defaults + (setq initargs (append initargs (nreverse defaults)))) + initargs)) + + +(defun %allocate-std-instance (class) + (unless (class-finalized-p class) + (finalize-inheritance class)) + (let* ((wrapper (%class.own-wrapper class)) + (len (length (%wrapper-instance-slots wrapper)))) + (declare (fixnum len)) + (make-instance-vector wrapper len))) + + + + +(defmethod copy-instance ((instance standard-object)) + (let* ((new-slots (copy-uvector (instance.slots instance))) + (copy (gvector :instance 0 (instance-class-wrapper instance) new-slots))) + (setf (instance.hash copy) (strip-tag-to-fixnum copy) + (slot-vector.instance new-slots) copy))) + +(defmethod initialize-instance ((instance standard-object) &rest initargs) + (declare (dynamic-extent initargs)) + (apply 'shared-initialize instance t initargs)) + + +(defmethod reinitialize-instance ((instance standard-object) &rest initargs) + (declare (dynamic-extent initargs)) + (when initargs + (check-initargs + instance nil initargs t #'reinitialize-instance #'shared-initialize)) + (apply 'shared-initialize instance nil initargs)) + +(defmethod shared-initialize ((instance standard-object) slot-names &rest initargs) + (declare (dynamic-extent initargs)) + (%shared-initialize instance slot-names initargs)) + +(defmethod shared-initialize ((instance standard-generic-function) slot-names + &rest initargs) + (declare (dynamic-extent initargs)) + (%shared-initialize instance slot-names initargs)) + + + +;;; Slot-value, slot-boundp, slot-makunbound, etc. +(declaim (inline find-slotd)) +(defun find-slotd (name slots) + (dolist (slotd slots) + (when (eq name (standard-slot-definition.name slotd)) + (return slotd)))) + +(declaim (inline %std-slot-vector-value)) + +(defun %std-slot-vector-value (slot-vector slotd) + (let* ((loc (standard-effective-slot-definition.location slotd))) + (symbol-macrolet ((instance (slot-vector.instance slot-vector))) + (typecase loc + (fixnum + (%slot-ref slot-vector loc)) + (cons + (let* ((val (%cdr loc))) + (if (eq val (%slot-unbound-marker)) + (slot-unbound (class-of instance) instance (standard-effective-slot-definition.name slotd)) + val))) + (t + (error "Slot definition ~s has invalid location ~s (allocation ~s)." + slotd loc (slot-definition-allocation slotd))))))) + + +(defmethod slot-value-using-class ((class standard-class) + instance + (slotd standard-effective-slot-definition)) + (ecase (standard-slot-definition.allocation slotd) + ((:instance :class) + (%std-slot-vector-value (instance-slots instance) slotd)))) + +(defun %maybe-std-slot-value-using-class (class instance slotd) + (if (and (eql (typecode class) target::subtag-instance) + (eql (typecode slotd) target::subtag-instance) + (eq *standard-effective-slot-definition-class-wrapper* + (instance.class-wrapper slotd)) + (eq *standard-class-wrapper* (instance.class-wrapper class)) + (let* ((allocation (standard-effective-slot-definition.location slotd))) + (or (eq allocation :instance) (eq allocation :class)))) + (%std-slot-vector-value (instance-slots instance) slotd) + (if (= (the fixnum (typecode instance)) target::subtag-struct) + (struct-ref instance (standard-effective-slot-definition.location slotd)) + (slot-value-using-class class instance slotd)))) + + +(declaim (inline %set-std-slot-vector-value)) + +(defun %set-std-slot-vector-value (slot-vector slotd new) + (let* ((loc (standard-effective-slot-definition.location slotd)) + (type (standard-effective-slot-definition.type slotd)) + (type-predicate (standard-effective-slot-definition.type-predicate slotd))) + (unless (or (eq new (%slot-unbound-marker)) + (null type-predicate) + (funcall type-predicate new)) + (error 'bad-slot-type + :instance (slot-vector.instance slot-vector) + :datum new :expected-type type + :slot-definition slotd)) + (typecase loc + (fixnum + (setf (%svref slot-vector loc) new)) + (cons + (setf (%cdr loc) new)) + (t + (error "Slot definition ~s has invalid location ~s (allocation ~s)." + slotd loc (slot-definition-allocation slotd)))))) + + +(defmethod (setf slot-value-using-class) + (new + (class standard-class) + instance + (slotd standard-effective-slot-definition)) + (ecase (standard-slot-definition.allocation slotd) + ((:instance :class) + (%set-std-slot-vector-value (instance-slots instance) slotd new)))) + + +(defun %maybe-std-setf-slot-value-using-class (class instance slotd new) + (if (and (eql (typecode class) target::subtag-instance) + (eql (typecode slotd) target::subtag-instance) + (eq *standard-effective-slot-definition-class-wrapper* + (instance.class-wrapper slotd)) + (eq *standard-class-wrapper* (instance.class-wrapper class)) + (let* ((allocation (standard-effective-slot-definition.allocation slotd))) + (or (eq allocation :instance) (eq allocation :class)))) + ;; Not safe to use instance.slots here, since the instance is not + ;; definitely of type SUBTAG-INSTANCE. (Anyway, INSTANCE-SLOTS + ;; should be inlined here.) + (%set-std-slot-vector-value (instance-slots instance) slotd new) + (if (structurep instance) + (setf (struct-ref instance (standard-effective-slot-definition.location slotd)) + new) + (setf (slot-value-using-class class instance slotd) new)))) + +(defmethod slot-value-using-class ((class funcallable-standard-class) + instance + (slotd standard-effective-slot-definition)) + (%std-slot-vector-value (gf.slots instance) slotd)) + +(defmethod (setf slot-value-using-class) + (new + (class funcallable-standard-class) + instance + (slotd standard-effective-slot-definition)) + (%set-std-slot-vector-value (gf.slots instance) slotd new)) + +(defun slot-value (instance slot-name) + (let* ((wrapper + (let* ((w (instance-class-wrapper instance))) + (if (eql 0 (%wrapper-hash-index w)) + (instance.class-wrapper (update-obsolete-instance instance)) + w))) + (class (%wrapper-class wrapper)) + (slotd (find-slotd slot-name (if (%standard-instance-p class) + (%class.slots class) + (class-slots class))))) + (if slotd + (%maybe-std-slot-value-using-class class instance slotd) + (if (typep slot-name 'symbol) + (restart-case + (values (slot-missing class instance slot-name 'slot-value)) + (continue () + :report "Try accessing the slot again" + (slot-value instance slot-name)) + (use-value (value) + :report "Return a value" + :interactive (lambda () + (format *query-io* "~&Value to use: ") + (list (read *query-io*))) + value)) + (report-bad-arg slot-name 'symbol))))) + + +(defmethod slot-unbound (class instance slot-name) + (declare (ignore class)) + (restart-case (error 'unbound-slot :name slot-name :instance instance) + (use-value (value) + :report "Return a value" + :interactive (lambda () + (format *query-io* "~&Value to use: ") + (list (read *query-io*))) + value))) + + + +(defmethod slot-makunbound-using-class ((class slots-class) + instance + (slotd standard-effective-slot-definition)) + (setf (slot-value-using-class class instance slotd) (%slot-unbound-marker)) + instance) + +(defmethod slot-missing (class object slot-name operation &optional new-value) + (declare (ignore class operation new-value)) + (error "~s has no slot named ~s." object slot-name)) + + +(defun set-slot-value (instance name value) + (let* ((wrapper + (let* ((w (instance-class-wrapper instance))) + (if (eql 0 (%wrapper-hash-index w)) + (instance.class-wrapper (update-obsolete-instance instance)) + w))) + (class (%wrapper-class wrapper)) + (slotd (find-slotd name (if (%standard-instance-p class) + (%class.slots class) + (class-slots class))))) + (if slotd + (%maybe-std-setf-slot-value-using-class class instance slotd value) + (if (typep name 'symbol) + (progn + (slot-missing class instance name 'setf value) + value) + (report-bad-arg name 'symbol))))) + +(defsetf slot-value set-slot-value) + +(defun slot-makunbound (instance name) + (let* ((class (class-of instance)) + (slotd (find-slotd name (%class-slots class)))) + (if slotd + (slot-makunbound-using-class class instance slotd) + (slot-missing class instance name 'slot-makunbound)) + instance)) + +(defun %std-slot-vector-boundp (slot-vector slotd) + (let* ((loc (standard-effective-slot-definition.location slotd))) + (typecase loc + (fixnum + (not (eq (%svref slot-vector loc) (%slot-unbound-marker)))) + (cons + (not (eq (%cdr loc) (%slot-unbound-marker)))) + (t + (error "Slot definition ~s has invalid location ~s (allocation ~s)." + slotd loc (slot-definition-allocation slotd)))))) + +(defun %maybe-std-slot-boundp-using-class (class instance slotd) + (if (and (eql (typecode class) target::subtag-instance) + (eql (typecode slotd) target::subtag-instance) + (eq *standard-effective-slot-definition-class-wrapper* + (instance.class-wrapper slotd)) + (eq *standard-class-wrapper* (instance.class-wrapper class)) + (let* ((allocation (standard-slot-definition.allocation slotd))) + (or (eq allocation :class) + (eq allocation :instance)))) + (%std-slot-vector-boundp (instance-slots instance) slotd) + (slot-boundp-using-class class instance slotd))) + + +(defmethod slot-boundp-using-class ((class standard-class) + instance + (slotd standard-effective-slot-definition)) + (ecase (standard-slot-definition.allocation slotd) + ((:instance :class) + (%std-slot-vector-boundp (instance-slots instance) slotd)))) + +(defmethod slot-boundp-using-class ((class funcallable-standard-class) + instance + (slotd standard-effective-slot-definition)) + (%std-slot-vector-boundp (gf.slots instance) slotd)) + + + +(defun slot-boundp (instance name) + (let* ((wrapper + (let* ((w (instance-class-wrapper instance))) + (if (eql 0 (%wrapper-hash-index w)) + (instance.class-wrapper (update-obsolete-instance instance)) + w))) + (class (%wrapper-class wrapper)) + (slotd (find-slotd name (if (%standard-instance-p class) + (%class.slots class) + (class-slots class))))) + (if slotd + (%maybe-std-slot-boundp-using-class class instance slotd) + (if (typep name 'symbol) + (values (slot-missing class instance name 'slot-boundp)) + (report-bad-arg name 'symbol))))) + +(defun slot-value-if-bound (instance name &optional default) + (if (slot-boundp instance name) + (slot-value instance name) + default)) + +(defun slot-exists-p (instance name) + (let* ((class (class-of instance)) + (slots (class-slots class))) + (find-slotd name slots))) + + +(defun slot-id-value (instance slot-id) + (let* ((wrapper (instance-class-wrapper instance))) + (funcall (%wrapper-slot-id-value wrapper) instance slot-id))) + +(defun set-slot-id-value (instance slot-id value) + (let* ((wrapper (instance-class-wrapper instance))) + (funcall (%wrapper-set-slot-id-value wrapper) instance slot-id value))) + +(defun slot-id-boundp (instance slot-id) + (let* ((wrapper (instance-class-wrapper instance)) + (class (%wrapper-class wrapper)) + (slotd (funcall (%wrapper-slot-id->slotd wrapper) instance slot-id))) + (if slotd + (%maybe-std-slot-boundp-using-class class instance slotd) + (values (slot-missing class instance (slot-id.name slot-id) 'slot-boundp))))) + +;;; returns nil if (apply gf args) wil cause an error because of the +;;; non-existance of a method (or if GF is not a generic function or the name +;;; of a generic function). +(defun method-exists-p (gf &rest args) + (declare (dynamic-extent args)) + (when (symbolp gf) + (setq gf (fboundp gf))) + (when (typep gf 'standard-generic-function) + (or (null args) + (let* ((methods (sgf.methods gf))) + (dolist (m methods) + (when (null (%method-qualifiers m)) + (let ((specializers (%method-specializers m)) + (args args)) + (when (dolist (s specializers t) + (unless (cond ((typep s 'eql-specializer) + (eql (eql-specializer-object s) + (car args))) + (t (memq s (%inited-class-cpl + (class-of (car args)))))) + (return nil)) + (pop args)) + (return-from method-exists-p m))))) + nil)))) + +(defun funcall-if-method-exists (gf &optional default &rest args) + (declare (dynamic-extent args)) + (if (apply #'method-exists-p gf args) + (apply gf args) + (if default (apply default args)))) + + +(defun find-specializer (specializer) + (if (and (listp specializer) (eql (car specializer) 'eql)) + (intern-eql-specializer (cadr specializer)) + (find-class specializer))) + +(defmethod make-instances-obsolete ((class symbol)) + (make-instances-obsolete (find-class class))) + +(defmethod make-instances-obsolete ((class standard-class)) + (let ((wrapper (%class-own-wrapper class))) + (when wrapper + (setf (%class-own-wrapper class) nil) + (make-wrapper-obsolete wrapper))) + class) + +(defmethod make-instances-obsolete ((class funcallable-standard-class)) + (let ((wrapper (%class.own-wrapper class))) + (when wrapper + (setf (%class-own-wrapper class) nil) + (make-wrapper-obsolete wrapper))) + class) + +(defmethod make-instances-obsolete ((class structure-class)) + ;; could maybe warn that instances are obsolete, but there's not + ;; much that we can do about that. + class) + + + +;;; A wrapper is made obsolete by setting the hash-index & instance-slots to 0 +;;; The instance slots are saved for update-obsolete-instance +;;; by consing them onto the class slots. +;;; Method dispatch looks at the hash-index. +;;; slot-value & set-slot-value look at the instance-slots. +;;; Each wrapper may have an associated forwarding wrapper, which must +;;; also be made obsolete. The forwarding-wrapper is stored in the +;;; hash table below keyed on the wrapper-hash-index of the two +;;; wrappers. +(defvar *forwarding-wrapper-hash-table* (make-hash-table :test 'eq)) + + +(defun make-wrapper-obsolete (wrapper) + (without-interrupts + (let ((forwarding-info + (unless (eql 0 (%wrapper-instance-slots wrapper)) ; already forwarded or obsolete? + (%cons-forwarding-info (%wrapper-instance-slots wrapper) + (%wrapper-class-slots wrapper))))) + (when forwarding-info + (setf (%wrapper-hash-index wrapper) 0 + (%wrapper-cpl wrapper) nil + (%wrapper-cpl-bits wrapper) nil + (%wrapper-instance-slots wrapper) 0 + (%wrapper-forwarding-info wrapper) forwarding-info + (%wrapper-slot-id->slotd wrapper) #'%slot-id-lookup-obsolete + (%wrapper-slot-id-value wrapper) #'%slot-id-ref-obsolete + (%wrapper-set-slot-id-value wrapper) #'%slot-id-set-obsolete + )))) + wrapper) + +(defun %clear-class-primary-slot-accessor-offsets (class) + (let ((info-list (%class-get class '%class-primary-slot-accessor-info))) + (dolist (info info-list) + (setf (%slot-accessor-info.offset info) nil)))) + +(defun primary-class-slot-offset (class slot-name) + (dolist (super (%class.cpl class)) + (let* ((pos (and (typep super 'standard-class) + (%class-primary-p super) + (dolist (slot (%class-slots class)) + (when (eq (%slot-definition-allocation slot) + :instance) + (when (eq slot-name (%slot-definition-name slot)) + (return (%slot-definition-location slot)))))))) + (when pos (return pos))))) + +;;; Called by the compiler-macro expansion for slot-value +;;; info is the result of a %class-primary-slot-accessor-info call. +;;; value-form is specified if this is set-slot-value. +;;; Otherwise it's slot-value. +(defun primary-class-slot-value (instance info &optional (value-form nil value-form-p)) + (let ((slot-name (%slot-accessor-info.slot-name info))) + (prog1 + (if value-form-p + (setf (slot-value instance slot-name) value-form) + (slot-value instance slot-name)) + (setf (%slot-accessor-info.offset info) + (primary-class-slot-offset (class-of instance) slot-name))))) + +(defun primary-class-accessor (instance info &optional (value-form nil value-form-p)) + (let ((accessor (%slot-accessor-info.accessor info))) + (prog1 + (if value-form-p + (funcall accessor value-form instance) + (funcall accessor instance)) + (let ((methods (compute-applicable-methods + accessor + (if value-form-p (list value-form instance) (list instance)))) + method) + (when (and (eql (length methods) 1) + (typep (setq method (car methods)) 'standard-accessor-method)) + (let* ((slot-name (method-slot-name method))) + (setf (%slot-accessor-info.offset info) + (primary-class-slot-offset (class-of instance) slot-name)))))))) + +(defun exchange-slot-vectors-and-wrappers (a b) + (if (typep a 'generic-function) + (let* ((temp-wrapper (gf.instance.class-wrapper a)) + (orig-a-slots (gf.slots a)) + (orig-b-slots (gf.slots b))) + (setf (gf.instance.class-wrapper a) (gf.instance.class-wrapper b) + (gf.instance.class-wrapper b) temp-wrapper + (gf.slots a) orig-b-slots + (gf.slots b) orig-a-slots + (slot-vector.instance orig-a-slots) b + (slot-vector.instance orig-b-slots) a)) + (let* ((temp-wrapper (instance.class-wrapper a)) + (orig-a-slots (instance.slots a)) + (orig-b-slots (instance.slots b))) + (setf (instance.class-wrapper a) (instance.class-wrapper b) + (instance.class-wrapper b) temp-wrapper + (instance.slots a) orig-b-slots + (instance.slots b) orig-a-slots + (slot-vector.instance orig-a-slots) b + (slot-vector.instance orig-b-slots) a)))) + + + + +;;; How slot values transfer (from PCL): +;;; +;;; local --> local transfer +;;; local --> shared discard +;;; local --> -- discard +;;; shared --> local transfer +;;; shared --> shared discard +;;; shared --> -- discard +;;; -- --> local added +;;; -- --> shared -- +;;; +;;; See make-wrapper-obsolete to see how we got here. +;;; A word about forwarding. When a class is made obsolete, the +;;; %wrapper-instance-slots slot of its wrapper is set to 0. +;;; %wrapper-class-slots = (instance-slots . class-slots) +;;; Note: this should stack-cons the new-instance if we can reuse the +;;; old instance or it's forwarded value. +(defun update-obsolete-instance (instance) + (let* ((added ()) + (discarded ()) + (plist ())) + (without-interrupts ; Not -close- to being correct + (let* ((old-wrapper (standard-object-p instance))) + (unless old-wrapper + (when (standard-generic-function-p instance) + (setq old-wrapper (gf.instance.class-wrapper instance))) + (unless old-wrapper + (report-bad-arg instance '(or standard-instance standard-generic-function)))) + (when (eql 0 (%wrapper-instance-slots old-wrapper)) ; is it really obsolete? + (let* ((class (%wrapper-class old-wrapper)) + (new-wrapper (or (%class.own-wrapper class) + (progn + (update-class class t) + (%class.own-wrapper class)))) + (forwarding-info (%wrapper-forwarding-info old-wrapper)) + (old-class-slots (%forwarding-class-slots forwarding-info)) + (old-instance-slots (%forwarding-instance-slots forwarding-info)) + (new-instance-slots (%wrapper-instance-slots new-wrapper)) + (new-class-slots (%wrapper-class-slots new-wrapper)) + (new-instance (allocate-instance class)) + (old-slot-vector (instance.slots instance)) + (new-slot-vector (instance.slots new-instance))) + ;; Lots to do. Hold onto your hat. + (let* ((old-size (uvsize old-instance-slots)) + (new-size (uvsize new-instance-slots))) + (declare (fixnum old-size new-size)) + (dotimes (i old-size) + (declare (fixnum i)) + (let* ((slot-name (%svref old-instance-slots i)) + (pos (%vector-member slot-name new-instance-slots)) + (val (%svref old-slot-vector (%i+ i 1)))) + (if pos + (setf (%svref new-slot-vector (%i+ pos 1)) val) + (progn + (push slot-name discarded) + (unless (eq val (%slot-unbound-marker)) + (setf (getf plist slot-name) val)))))) + ;; Go through old class slots + (dolist (pair old-class-slots) + (let* ((slot-name (%car pair)) + (val (%cdr pair)) + (pos (%vector-member slot-name new-instance-slots))) + (if pos + (setf (%svref new-slot-vector (%i+ pos 1)) val) + (progn + (push slot-name discarded) + (unless (eq val (%slot-unbound-marker)) + (setf (getf plist slot-name) val)))))) + ; Go through new instance slots + (dotimes (i new-size) + (declare (fixnum i)) + (let* ((slot-name (%svref new-instance-slots i))) + (unless (or (%vector-member slot-name old-instance-slots) + (assoc slot-name old-class-slots)) + (push slot-name added)))) + ;; Go through new class slots + (dolist (pair new-class-slots) + (let ((slot-name (%car pair))) + (unless (or (%vector-member slot-name old-instance-slots) + (assoc slot-name old-class-slots)) + (push slot-name added)))) + (exchange-slot-vectors-and-wrappers new-instance instance)))))) + ;; run user code with interrupts enabled. + (update-instance-for-redefined-class instance added discarded plist)) + instance) + + +(defmethod update-instance-for-redefined-class ((instance standard-object) + added-slots + discarded-slots + property-list + &rest initargs) + (declare (ignore discarded-slots property-list)) + (when initargs + (check-initargs + instance nil initargs t + #'update-instance-for-redefined-class #'shared-initialize)) + (apply #'shared-initialize instance added-slots initargs)) + +(defmethod update-instance-for-redefined-class ((instance standard-generic-function) + added-slots + discarded-slots + property-list + &rest initargs) + (declare (ignore discarded-slots property-list)) + (when initargs + (check-initargs + instance nil initargs t + #'update-instance-for-redefined-class #'shared-initialize)) + (apply #'shared-initialize instance added-slots initargs)) + +(defun check-initargs (instance class initargs errorp &rest functions) + (declare (dynamic-extent functions)) + (declare (list functions)) + (setq class (require-type (or class (class-of instance)) 'std-class)) + (unless (getf initargs :allow-other-keys) + (let ((initvect (initargs-vector instance class functions))) + (when (eq initvect t) (return-from check-initargs nil)) + (do* ((tail initargs (cddr tail)) + (initarg (car tail) (car tail)) + bad-keys? bad-key) + ((null (cdr tail)) + (if bad-keys? + (if errorp + (signal-program-error + "~s is an invalid initarg to ~s for ~s.~%~ + Valid initargs: ~s." + bad-key + (function-name (car functions)) + class (coerce initvect 'list)) + (values bad-keys? bad-key)))) + (if (eq initarg :allow-other-keys) + (if (cadr tail) + (return)) ; (... :allow-other-keys t ...) + (unless (or bad-keys? (%vector-member initarg initvect)) + (setq bad-keys? t + bad-key initarg))))))) + +(defun initargs-vector (instance class functions) + (let ((index (cadr (assq (car functions) *initialization-invalidation-alist*)))) + (unless index + (error "Unknown initialization function: ~s." (car functions))) + (let ((initvect (%svref (instance-slots class) index))) + (unless initvect + (setf (%svref (instance-slots class) index) + (setq initvect (compute-initargs-vector instance class functions)))) + initvect))) + + +;; This is used for compile-time defclass option checking. +(defun class-keyvect (class-arg initargs) + (let* ((class (if (typep class-arg 'class) class-arg (find-class class-arg nil))) + (meta-arg (getf initargs :metaclass (if (and class (not (typep class 'forward-referenced-class))) + (class-of class) + *standard-class-class*))) + (meta-spec (if (quoted-form-p meta-arg) (%cadr meta-arg) meta-arg)) + (meta (if (typep meta-spec 'class) meta-spec (find-class meta-spec nil)))) + (if (and meta (not (typep meta 'forward-referenced-class))) + (compute-initargs-vector class meta (list #'initialize-instance #'allocate-instance #'shared-initialize) t) + t))) + +(defun compute-initargs-vector (instance class functions &optional require-rest) + (let ((initargs (class-slot-initargs class)) + (cpl (%inited-class-cpl class))) + (dolist (f functions) ; for all the functions passed + #+no + (if (logbitp $lfbits-aok-bit (lfun-bits f)) + (return-from compute-initargs-vector t)) + (dolist (method (%gf-methods f)) ; for each applicable method + (let ((spec (car (%method-specializers method)))) + (when (if (typep spec 'eql-specializer) + (eql instance (eql-specializer-object spec)) + (memq spec cpl)) + (let* ((func (%inner-method-function method)) + (keyvect (if (and (logbitp $lfbits-aok-bit (lfun-bits func)) + (or (not require-rest) + (logbitp $lfbits-rest-bit (lfun-bits func)))) + (return-from compute-initargs-vector t) + (lfun-keyvect func)))) + (dovector (key keyvect) + (pushnew key initargs))))))) ; add all of the method's keys + (apply #'vector initargs))) + + + +;;; A useful function +(defun class-make-instance-initargs (class) + (setq class (require-type (if (symbolp class) (find-class class) class) + 'std-class)) + (flet ((iv (class &rest functions) + (declare (dynamic-extent functions)) + (initargs-vector (class-prototype class) class functions))) + (let ((initvect (apply #'iv + class + #'initialize-instance #'allocate-instance #'shared-initialize + nil))) + (if (eq initvect 't) + t + (concatenate 'list initvect))))) + + + +;;; This is part of the MOP +;;; Maybe it was, at one point in the distant past ... +(defmethod class-slot-initargs ((class slots-class)) + (collect ((initargs)) + (dolist (slot (%class-slots class) (initargs)) + (dolist (i (%slot-definition-initargs slot)) + (initargs i))))) + + +(defun maybe-update-obsolete-instance (instance) + (let ((wrapper (standard-object-p instance))) + (unless wrapper + (when (typep instance 'funcallable-standard-object) + (setq wrapper (gf.instance.class-wrapper instance))) + + (unless wrapper + (report-bad-arg instance '(or standard-object funcallable-standard-object)))) + (when (eql 0 (%wrapper-hash-index wrapper)) + (update-obsolete-instance instance))) + instance) + + +;;; If you ever reference one of these through anyone who might call +;;; update-obsolete-instance, you will lose badly. +(defun %maybe-forwarded-instance (instance) + (maybe-update-obsolete-instance instance) + instance) + + + +(defmethod change-class (instance + (new-class symbol) + &rest initargs &key &allow-other-keys) + (declare (dynamic-extent initargs)) + (apply #'change-class instance (find-class new-class) initargs)) + +(defmethod change-class ((instance standard-object) + (new-class standard-class) + &rest initargs &key &allow-other-keys) + (declare (dynamic-extent initargs)) + (%change-class instance new-class initargs)) + + +(defun %change-class (object new-class initargs) + (let* ((old-class (class-of object)) + (old-wrapper (%class.own-wrapper old-class)) + (new-wrapper (or (%class.own-wrapper new-class) + (progn + (update-class new-class t) + (%class.own-wrapper new-class)))) + (old-instance-slots-vector (%wrapper-instance-slots old-wrapper)) + (new-instance-slots-vector (%wrapper-instance-slots new-wrapper)) + (num-new-instance-slots (length new-instance-slots-vector)) + (new-object (allocate-instance new-class))) + (declare (fixnum num-new-instance-slots) + (simple-vector new-instance-slots-vector old-instance-slots-vector)) + ;; Retain local slots shared between the new class and the old. + (do* ((new-pos 0 (1+ new-pos)) + (new-slot-location 1 (1+ new-slot-location))) + ((= new-pos num-new-instance-slots)) + (declare (fixnum new-pos new-slot-location)) + (let* ((old-pos (position (svref new-instance-slots-vector new-pos) + old-instance-slots-vector :test #'eq))) + (when old-pos + (setf (%standard-instance-instance-location-access + new-object + new-slot-location) + (%standard-instance-instance-location-access + object + (the fixnum (1+ (the fixnum old-pos)))))))) + ;; If the new class defines a local slot whos name matches + ;; that of a shared slot in the old class, the shared slot's + ;; value is used to initialize the new instance's local slot. + (dolist (shared-slot (%wrapper-class-slots old-wrapper)) + (destructuring-bind (name . value) shared-slot + (let* ((new-slot-pos (position name new-instance-slots-vector + :test #'eq))) + (if new-slot-pos + (setf (%standard-instance-instance-location-access + new-object + (the fixnum (1+ (the fixnum new-slot-pos)))) + value))))) + (exchange-slot-vectors-and-wrappers object new-object) + (apply #'update-instance-for-different-class new-object object initargs) + object)) + +(defmethod update-instance-for-different-class ((previous standard-object) + (current standard-object) + &rest initargs) + (declare (dynamic-extent initargs)) + (%update-instance-for-different-class previous current initargs)) + +(defun %update-instance-for-different-class (previous current initargs) + (when initargs + (check-initargs + current nil initargs t + #'update-instance-for-different-class #'shared-initialize)) + (let* ((previous-slots (class-slots (class-of previous))) + (current-slots (class-slots (class-of current))) + (added-slot-names ())) + (dolist (s current-slots) + (let* ((name (%slot-definition-name s))) + (unless (find-slotd name previous-slots) + (push name added-slot-names)))) + (apply #'shared-initialize + current + added-slot-names + initargs))) + + + + +;;; Clear all the valid initargs caches. +(defun clear-valid-initargs-caches () + (map-classes #'(lambda (name class) + (declare (ignore name)) + (when (std-class-p class) + (setf (%class.make-instance-initargs class) nil + (%class.reinit-initargs class) nil + (%class.redefined-initargs class) nil + (%class.changed-initargs class) nil))))) + +(defun clear-clos-caches () + (clear-all-gf-caches) + (clear-valid-initargs-caches)) + +(defmethod allocate-instance ((class standard-class) &rest initargs) + (declare (ignore initargs)) + (%allocate-std-instance class)) + +(defmethod allocate-instance ((class funcallable-standard-class) &rest initargs) + (declare (ignore initargs)) + (%allocate-gf-instance class)) + +(unless *initialization-invalidation-alist* + (setq *initialization-invalidation-alist* + (list (list #'initialize-instance %class.make-instance-initargs) + (list #'allocate-instance %class.make-instance-initargs) + (list #'reinitialize-instance %class.reinit-initargs) + (list #'shared-initialize + %class.make-instance-initargs %class.reinit-initargs + %class.redefined-initargs %class.changed-initargs) + (list #'update-instance-for-redefined-class + %class.redefined-initargs) + (list #'update-instance-for-different-class + %class.changed-initargs)))) + + +(defstatic *initialization-function-lists* + (list (list #'initialize-instance #'allocate-instance #'shared-initialize) + (list #'reinitialize-instance #'shared-initialize) + (list #'update-instance-for-redefined-class #'shared-initialize) + (list #'update-instance-for-different-class #'shared-initialize))) + + + +(unless *clos-initialization-functions* + (setq *clos-initialization-functions* + (list #'initialize-instance #'allocate-instance #'shared-initialize + #'reinitialize-instance + #'update-instance-for-different-class #'update-instance-for-redefined-class))) + +(defun compute-initialization-functions-alist () + (let ((res nil) + (lists *initialization-function-lists*)) + (dolist (cell *initialization-invalidation-alist*) + (let (res-list) + (dolist (slot-num (cdr cell)) + (push + (ecase slot-num + (#.%class.make-instance-initargs + (assq #'initialize-instance lists)) + (#.%class.reinit-initargs + (assq #'reinitialize-instance lists)) + (#.%class.redefined-initargs + (assq #'update-instance-for-redefined-class lists)) + (#.%class.changed-initargs + (assq #'update-instance-for-different-class lists))) + res-list)) + (push (cons (car cell) (nreverse res-list)) res))) + (setq *initialization-functions-alist* res))) + +(compute-initialization-functions-alist) + + + + + + +;;; Need to define this for all of the BUILT-IN-CLASSes. +(defmethod class-prototype ((class class)) + (%class.prototype class)) + +(defmethod class-prototype ((class std-class)) + (or (%class.prototype class) + (setf (%class.prototype class) (allocate-instance class)))) + + +(defun gf-class-prototype (class) + (%allocate-gf-instance class)) + + + +(defmethod class-prototype ((class structure-class)) + (or (%class.prototype class) + (setf (%class.prototype class) + (let* ((sd (gethash (class-name class) %defstructs%)) + (slots (class-slots class)) + (proto (allocate-typed-vector :struct (1+ (length slots))))) + (setf (uvref proto 0) (sd-superclasses sd)) + (dolist (slot slots proto) + (setf (slot-value-using-class class proto slot) + (funcall (slot-definition-initfunction slot)))))))) + + +(defmethod remove-method ((generic-function standard-generic-function) + (method standard-method)) + (when (eq generic-function (%method-gf method)) + (%remove-standard-method-from-containing-gf method)) + generic-function) + + + +(defmethod function-keywords ((method standard-method)) + (let ((f (%inner-method-function method))) + (values + (concatenate 'list (lfun-keyvect f)) + (%ilogbitp $lfbits-aok-bit (lfun-bits f))))) + +(defmethod no-next-method ((generic-function standard-generic-function) + (method standard-method) + &rest args) + (error "There is no next method for ~s~%args: ~s" method args)) + +(defmethod add-method ((generic-function standard-generic-function) (method standard-method)) + (%add-standard-method-to-standard-gf generic-function method)) + +(defmethod no-applicable-method (gf &rest args) + (cerror "Try calling it again" + "There is no applicable method for the generic function:~% ~s~%when called with arguments:~% ~s" gf args) + (apply gf args)) + + +(defmethod no-applicable-primary-method (gf methods) + (%method-combination-error "No applicable primary methods for ~s~@ + Applicable methods: ~s" gf methods)) + +(defmethod compute-applicable-methods ((gf standard-generic-function) args) + (%compute-applicable-methods* gf args)) + +(defmethod compute-applicable-methods-using-classes ((gf standard-generic-function) args) + (let ((res (%compute-applicable-methods* gf args t))) + (if (eq res :undecidable) + (values nil nil) + (values res t)))) + +(defun %compute-applicable-methods+ (gf &rest args) + (declare (dynamic-extent args)) + (%compute-applicable-methods* gf args)) + +(defun %compute-applicable-methods* (gf args &optional using-classes-p) + (let* ((methods (%gf-methods gf)) + (args-length (length args)) + (bits (inner-lfun-bits gf)) + arg-count res) + (when methods + (setq arg-count (length (%method-specializers (car methods)))) + (unless (<= arg-count args-length) + (error "Too few args to ~s" gf)) + (unless (or (logbitp $lfbits-rest-bit bits) + (logbitp $lfbits-restv-bit bits) + (logbitp $lfbits-keys-bit bits) + (<= args-length + (+ (ldb $lfbits-numreq bits) (ldb $lfbits-numopt bits)))) + (error "Too many args to ~s" gf)) + (let ((cpls (make-list arg-count))) + (declare (dynamic-extent cpls)) + (do* ((args-tail args (cdr args-tail)) + (cpls-tail cpls (cdr cpls-tail))) + ((null cpls-tail)) + (setf (car cpls-tail) + (%class-precedence-list (if using-classes-p + ;; extension for use in source location support + (if (typep (car args-tail) 'eql-specializer) + (class-of (eql-specializer-object (car args-tail))) + (car args-tail)) + (class-of (car args-tail)))))) + (dolist (m methods) + (let ((appp (%method-applicable-p m args cpls using-classes-p))) + (when appp + (when (eq appp :undecidable) ;; can only happen if using-classes-p + (return-from %compute-applicable-methods* appp)) + (push m res)))) + (sort-methods res cpls (%gf-precedence-list gf)))))) + + +(defun %method-applicable-p (method args cpls &optional using-classes-p) + (do* ((specs (%method-specializers method) (%cdr specs)) + (args args (%cdr args)) + (cpls cpls (%cdr cpls))) + ((null specs) t) + (let ((spec (%car specs)) + (arg (%car args))) + (if (typep spec 'eql-specializer) + (if using-classes-p + (if (typep arg 'eql-specializer) ;; extension for use in source location support + (unless (eql (eql-specializer-object arg) (eql-specializer-object spec)) + (return nil)) + (if (typep (eql-specializer-object spec) arg) + ;; Can't tell if going to be applicable or not based on class alone + ;; Except for the special case of NULL which is a singleton + (unless (eq arg *null-class*) + (return :undecidable)) + (return nil))) + (unless (eql arg (eql-specializer-object spec)) + (return nil))) + (unless (memq spec (%car cpls)) + (return nil)))))) + + +;;; Need this so that (compute-applicable-methods +;;; #'class-precedence-list ...) will not recurse. +(defun %class-precedence-list (class) + (if (eq (class-of class) *standard-class-class*) + (%inited-class-cpl class) + (class-precedence-list class))) + +(defmethod class-precedence-list ((class class)) + (%inited-class-cpl class)) + + +(defun make-all-methods-kernel () + (dolist (f (population.data %all-gfs%)) + (let ((smc *standard-method-class*)) + (dolist (method (slot-value-if-bound f 'methods)) + (when (eq (class-of method) smc) + (change-class method *standard-kernel-method-class*)))))) + + +(defun make-all-methods-non-kernel () + (dolist (f (population.data %all-gfs%)) + (let ((skmc *standard-kernel-method-class*)) + (dolist (method (slot-value-if-bound f 'methods)) + (when (eq (class-of method) skmc) + (change-class method *standard-method-class*)))))) + + +(defun required-lambda-list-args (l) + (multiple-value-bind (ok req) (verify-lambda-list l) + (unless ok (error "Malformed lambda-list: ~s" l)) + req)) + + +(defun check-generic-function-lambda-list (ll &optional (errorp t)) + (multiple-value-bind (ok reqsyms opttail resttail keytail auxtail) + (verify-lambda-list ll) + (declare (ignore reqsyms resttail)) + (when ok + (block checkit + (when (eq (car opttail) '&optional) + (dolist (elt (cdr opttail)) + (when (memq elt lambda-list-keywords) (return)) + (unless (or (symbolp elt) + (and (listp elt) + (non-nil-symbol-p (car elt)) + (null (cdr elt)))) + (return-from checkit (setq ok nil))))) + (dolist (elt (cdr keytail)) + (when (memq elt lambda-list-keywords) (return)) + (unless (or (symbolp elt) + (and (listp elt) + (or (non-nil-symbol-p (car elt)) + (and (listp (car elt)) + (non-nil-symbol-p (caar elt)) + (non-nil-symbol-p (cadar elt)) + (null (cddar elt)))) + (null (cdr elt)))) + (return-from checkit (setq ok nil)))) + (when auxtail (setq ok nil)))) + (when (and errorp (not ok)) + (signal-program-error "Bad generic function lambda list: ~s" ll)) + ok)) + + +(defun canonicalize-argument-precedence-order (apo req) + (cond ((equal apo req) nil) + ((not (eql (length apo) (length req))) + (signal-program-error "Lengths of ~S and ~S differ." apo req)) + (t (let ((res nil)) + (dolist (arg apo (nreverse res)) + (let ((index (position arg req))) + (if (or (null index) (memq index res)) + (error "Missing or duplicate arguments in ~s" apo)) + (push index res))))))) + + +(defun %defgeneric (function-name lambda-list method-combination generic-function-class + options) + (setq generic-function-class (find-class generic-function-class)) + (setq method-combination + (find-method-combination + (class-prototype generic-function-class) + (car method-combination) + (cdr method-combination))) + (let ((gf (fboundp function-name))) + (when gf + (dolist (method (%defgeneric-methods gf)) + (remove-method gf method)))) + (record-source-file function-name 'function) + (record-arglist function-name lambda-list) + (apply #'ensure-generic-function + function-name + :lambda-list lambda-list + :method-combination method-combination + :generic-function-class generic-function-class + options)) + + + + +;;; Redefined in lib;method-combination.lisp +(defmethod find-method-combination ((gf standard-generic-function) type options) + (unless (and (eq type 'standard) (null options)) + (error "non-standard method-combination not supported yet.")) + *standard-method-combination*) + + + +(defmethod add-direct-method ((spec specializer) (method method)) + (pushnew method (specializer.direct-methods spec))) + +(setf (fdefinition '%do-add-direct-method) #'add-direct-method) + +(defmethod remove-direct-method ((spec specializer) (method method)) + (setf (specializer.direct-methods spec) + (nremove method (specializer.direct-methods spec)))) + +(setf (fdefinition '%do-remove-direct-method) #'remove-direct-method) + + + + + + + + + +(defvar *make-load-form-saving-slots-hash* (make-hash-table :test 'eq)) + +(defun make-load-form-saving-slots (object &key + (slot-names nil slot-names-p) + environment) + (declare (ignore environment)) + (let* ((class (class-of object)) + (class-name (class-name class)) + (structurep (structurep object)) + (sd (and structurep (require-type (gethash class-name %defstructs%) 'vector)))) + (unless (or structurep + (standard-instance-p object)) + (%badarg object '(or standard-object structure-object))) + (if slot-names-p + (dolist (slot slot-names) + (unless (slot-exists-p object slot) + (error "~s has no slot named ~s" object slot))) + (setq slot-names + (if structurep + (let ((res nil)) + (dolist (slot (sd-slots sd)) + (unless (fixnump (car slot)) + (push (%car slot) res))) + (nreverse res)) + (mapcar '%slot-definition-name + (extract-instance-effective-slotds + (class-of object)))))) + (values + (let* ((form (gethash class-name *make-load-form-saving-slots-hash*))) + (or (and (consp form) + (eq (car form) 'allocate-instance) + form) + (setf (gethash class-name *make-load-form-saving-slots-hash*) + `(allocate-instance (find-class ',class-name))))) + ;; initform is NIL when there are no slots + (when slot-names + `(%set-slot-values + ',object + ',slot-names + ',(let ((temp #'(lambda (slot) + (if (slot-boundp object slot) + (slot-value object slot) + (%slot-unbound-marker))))) + (declare (dynamic-extent temp)) + (mapcar temp slot-names))))))) + + + + +(defmethod allocate-instance ((class structure-class) &rest initargs) + (declare (ignore initargs)) + (let* ((class-name (%class-name class)) + (sd (or (gethash class-name %defstructs%) + (error "Can't find structure named ~s" class-name))) + (res (make-structure-vector (sd-size sd)))) + (setf (%svref res 0) (mapcar (lambda (x) + (find-class-cell x t)) (sd-superclasses sd))) + res)) + + +(defun %set-slot-values (object slots values) + (dolist (slot slots) + (let ((value (pop values))) + (if (eq value (%slot-unbound-marker)) + (slot-makunbound object slot) + (setf (slot-value object slot) value))))) + + +(defun %recache-class-direct-methods () + (let ((*maintain-class-direct-methods* t)) ; in case we get an error + (dolist (f (population-data %all-gfs%)) + (when (standard-generic-function-p f) + (dolist (method (%gf-methods f)) + (%add-direct-methods method))))) + (setq *maintain-class-direct-methods* t)) ; no error, all is well + Index: /branches/new-random/level-1/l1-clos.lisp =================================================================== --- /branches/new-random/level-1/l1-clos.lisp (revision 13309) +++ /branches/new-random/level-1/l1-clos.lisp (revision 13309) @@ -0,0 +1,2512 @@ +;;;-*-Mode: LISP; Package: CCL -*- +;;; +;;; Copyright (C) 1994-2001 Digitool, Inc +;;; Copyright (C) 2002-2009 Clozure Associates +;;; This file is part of Clozure CL. +;;; +;;; Clozure CL is licensed under the terms of the Lisp Lesser GNU Public +;;; License , known as the LLGPL and distributed with Clozure CL as the +;;; file "LICENSE". The LLGPL consists of a preamble and the LGPL, +;;; which is distributed with Clozure CL as the file "LGPL". Where these +;;; conflict, the preamble takes precedence. +;;; +;;; Clozure CL is referenced in the preamble as the "LIBRARY." +;;; +;;; The LLGPL is also available online at +;;; http://opensource.franz.com/preamble.html +;;; + +;;; At this point in the load sequence, the handful of extant basic classes +;;; exist only in skeletal form (without direct or effective slot-definitions.) + +(in-package "CCL") + +(defun extract-slotds-with-allocation (allocation slotds) + (collect ((right-ones)) + (dolist (s slotds (right-ones)) + (if (eq (%slot-definition-allocation s) allocation) + (right-ones s))))) + +(defun extract-instance-direct-slotds (class) + (extract-slotds-with-allocation :instance (%class-direct-slots class))) + +(defun extract-class-direct-slotds (class) + (extract-slotds-with-allocation :class (%class-direct-slots class))) + +(defun extract-instance-effective-slotds (class) + (extract-slotds-with-allocation :instance (%class-slots class))) + +(defun extract-class-effective-slotds (class) + (extract-slotds-with-allocation :class (%class-slots class))) + +(defun extract-instance-class-and-other-slotds (slotds) + (collect ((instance-slots) + (shared-slots) + (other-slots)) + (dolist (s slotds (values (instance-slots) (shared-slots) (other-slots))) + (case (%slot-definition-allocation s) + (:instance (instance-slots s)) + (:class (shared-slots s)) + (t (other-slots s)))))) + + +(defun %early-shared-initialize (instance slot-names initargs) + (unless (or (listp slot-names) (eq slot-names t)) + (report-bad-arg slot-names '(or list (eql t)))) + ;; Check that initargs contains valid key/value pairs, + ;; signal a PROGRAM-ERROR otherwise. (Yes, this is + ;; an obscure way to do so.) + (destructuring-bind (&key &allow-other-keys) initargs) + (let* ((wrapper (instance-class-wrapper instance)) + (class (%wrapper-class wrapper))) + (when (eql 0 (%wrapper-hash-index wrapper)) ; obsolete + (update-obsolete-instance instance) + (setq wrapper (instance-class-wrapper instance))) + (dolist (slotd (%class-slots class)) + (let* ((loc (%slot-definition-location slotd))) + (multiple-value-bind (ignore new-value foundp) + (get-properties initargs + (%slot-definition-initargs slotd)) + (declare (ignore ignore)) + (if foundp + (progn + (unless (funcall (standard-effective-slot-definition.type-predicate slotd) new-value) + (error 'bad-slot-type-from-initarg + :slot-definition slotd + :instance instance + :datum new-value + :expected-type (%slot-definition-type slotd) + :initarg-name (car foundp))) + (if (consp loc) + (rplacd loc new-value) + (setf (standard-instance-instance-location-access instance loc) + new-value))) + (if (or (eq slot-names t) + (member (%slot-definition-name slotd) + slot-names + :test #'eq)) + (let* ((curval (if (consp loc) + (cdr loc) + (%standard-instance-instance-location-access + instance loc)))) + (if (eq curval (%slot-unbound-marker)) + (let* ((initfunction (%slot-definition-initfunction slotd))) + (if initfunction + (let* ((newval (funcall initfunction))) + (unless (funcall (standard-effective-slot-definition.type-predicate slotd) newval) + (error 'bad-slot-type-from-initform + :slot-definition slotd + :expected-type (%slot-definition-type slotd) + :datum newval + :instance instance)) + (if (consp loc) + (rplacd loc newval) + (setf (standard-instance-instance-location-access + instance loc) + newval))))))))))))) + instance) + +(setf (fdefinition '%shared-initialize) #'%early-shared-initialize) + +;;; This is redefined (to call MAKE-INSTANCE) below. +(setf (fdefinition '%make-direct-slotd) + #'(lambda (slotd-class &key + name + initfunction + initform + initargs + (allocation :instance) + class + (type t) + (documentation (%slot-unbound-marker)) + readers + writers) + (declare (ignore slotd-class)) + (%instance-vector + (%class.own-wrapper *standard-direct-slot-definition-class*) + name type initfunction initform initargs allocation + documentation class readers writers))) + +;;; Also redefined below, after MAKE-INSTANCE is possible. +(setf (fdefinition '%make-effective-slotd) + #'(lambda (slotd-class &key + name + initfunction + initform + initargs + allocation + class + type + documentation) + (declare (ignore slotd-class)) + (%instance-vector + (%class.own-wrapper *standard-effective-slot-definition-class*) + name type initfunction initform initargs allocation + documentation class nil (ensure-slot-id name) #'true))) + + +(defmethod compile-time-class-p ((class class)) nil) + +(defmethod direct-slot-definition-class ((class std-class) &key &allow-other-keys) + *standard-direct-slot-definition-class*) + +(defmethod effective-slot-definition-class ((class std-class) &key &allow-other-keys) + *standard-effective-slot-definition-class*) + +(defun make-direct-slot-definition (class initargs) + (apply #'%make-direct-slotd + (apply #'direct-slot-definition-class class initargs) + :class class + initargs)) + +(defun make-effective-slot-definition (class &rest initargs) + (declare (dynamic-extent initargs)) + (apply #'%make-effective-slotd + (apply #'effective-slot-definition-class class initargs) + initargs)) + +;; Bootstrapping version, replaced in l1-typesys +(fset 'standardized-type-specifier + (nlambda bootstrapping-standardized-type-specifier (spec) + (when (and (consp spec) + (memq (%car spec) '(and or)) + (consp (%cdr spec)) + (null (%cddr spec))) + (setq spec (%cadr spec))) + (if (consp spec) + (cons (%car spec) (mapcar #'standardized-type-specifier (%cdr spec))) + (or (cdr (assoc spec '((string . base-string)))) + spec)))) + +;;; The type of an effective slot definition is the intersection of +;;; the types of the direct slot definitions it's initialized from. +(defun dslotd-type-intersection (direct-slots) + (or (dolist (dslotd direct-slots t) + (unless (eq t (%slot-definition-type dslotd)) + (return))) + (standardized-type-specifier + (if (cdr direct-slots) + `(and ,@(mapcar #'(lambda (d) (or (%slot-definition-type d) t)) + direct-slots)) + (%slot-definition-type (car direct-slots)))))) + +(defmethod compute-effective-slot-definition ((class slots-class) + name + direct-slots) + + (let* ((initer (dolist (s direct-slots) + (when (%slot-definition-initfunction s) + (return s)))) + (documentor (dolist (s direct-slots) + (when (%slot-definition-documentation s) + (return s)))) + (first (car direct-slots)) + (initargs (let* ((initargs nil)) + (dolist (dslot direct-slots initargs) + (dolist (dslot-arg (%slot-definition-initargs dslot)) + (pushnew dslot-arg initargs :test #'eq)))))) + (make-effective-slot-definition + class + :name name + :allocation (%slot-definition-allocation first) + :documentation (when documentor (nth-value + 1 + (%slot-definition-documentation + documentor))) + :class (%slot-definition-class first) + :initargs initargs + :initfunction (if initer (%slot-definition-initfunction initer)) + :initform (if initer (%slot-definition-initform initer)) + :type (dslotd-type-intersection direct-slots)))) + +(defmethod compute-slots ((class slots-class)) + (let* ((slot-name-alist ())) + (labels ((note-direct-slot (dslot) + (let* ((sname (%slot-definition-name dslot)) + (pair (assq sname slot-name-alist))) + (if pair + (push dslot (cdr pair)) + (push (list sname dslot) slot-name-alist)))) + (rwalk (tail) + (when tail + (rwalk (cdr tail)) + (let* ((c (car tail))) + (unless (eq c *t-class*) + (dolist (dslot (%class-direct-slots c)) + (note-direct-slot dslot))))))) + (rwalk (class-precedence-list class))) + (collect ((effective-slotds)) + (dolist (pair (nreverse slot-name-alist) (effective-slotds)) + (effective-slotds (compute-effective-slot-definition class (car pair) (cdr pair))))))) + + +(defmethod compute-slots :around ((class std-class)) + (let* ((cpl (%class.cpl class))) + (multiple-value-bind (instance-slots class-slots other-slots) + (extract-instance-class-and-other-slotds (call-next-method)) + (setq instance-slots (sort-effective-instance-slotds instance-slots class cpl)) + (do* ((loc 1 (1+ loc)) + (islotds instance-slots (cdr islotds))) + ((null islotds)) + (declare (fixnum loc)) + (setf (%slot-definition-location (car islotds)) loc)) + (dolist (eslotd class-slots) + (setf (%slot-definition-location eslotd) + (assoc (%slot-definition-name eslotd) + (%class-get (%slot-definition-class eslotd) + :class-slots) + :test #'eq))) + (append instance-slots class-slots other-slots)))) + +(defmethod compute-slots :around ((class structure-class)) + (let* ((slots (call-next-method)) ) + (do* ((loc 1 (1+ loc)) + (islotds slots (cdr islotds))) + ((null islotds) slots) + (declare (fixnum loc)) + (setf (%slot-definition-location (car islotds)) loc)))) + +;;; Should eventually do something here. +;(defmethod compute-slots ((s structure-class)) +; (call-next-method)) + +(defmethod direct-slot-definition-class ((class structure-class) &rest initargs) + (declare (ignore initargs)) + (find-class 'structure-direct-slot-definition)) + +(defmethod effective-slot-definition-class ((class structure-class) &rest initargs) + (declare (ignore initargs)) + (find-class 'structure-effective-slot-definition)) + + +(defmethod compute-default-initargs ((class slots-class)) + (let* ((initargs ())) + (dolist (c (%class-precedence-list class) (nreverse initargs)) + (if (typep c 'forward-referenced-class) + (error + "Class precedence list of ~s contains FORWARD-REFERENCED-CLASS ~s ." + class c) + (dolist (i (%class-direct-default-initargs c)) + (pushnew i initargs :test #'eq :key #'car)))))) + + + + +(defvar *update-slots-preserve-existing-wrapper* nil) + +(defvar *optimized-dependents* (make-hash-table :test 'eq :weak :key) + "Hash table mapping a class to a list of all objects that have been optimized to + depend in some way on the layout of the class") + +(defun note-class-dependent (class gf) + (pushnew gf (gethash class *optimized-dependents*))) + +(defun unoptimize-dependents (class) + (pessimize-make-instance-for-class-name (%class-name class)) + (loop for obj in (gethash class *optimized-dependents*) + do (etypecase obj + (standard-generic-function + (clear-gf-dispatch-table (%gf-dispatch-table obj)) + (compute-dcode obj))))) + +(defun update-slots (class eslotds) + (let* ((instance-slots (extract-slotds-with-allocation :instance eslotds)) + (new-ordering + (let* ((v (make-array (the fixnum (length instance-slots)))) + (i 0)) + (declare (simple-vector v) (fixnum i)) + (dolist (e instance-slots v) + (setf (svref v i) + (%slot-definition-name e)) + (incf i)))) + (old-wrapper (%class-own-wrapper class)) + (new-wrapper + (cond ((null old-wrapper) + (%cons-wrapper class)) + ((and old-wrapper *update-slots-preserve-existing-wrapper*) + old-wrapper) + (t + (unoptimize-dependents class) + (make-instances-obsolete class) + (%cons-wrapper class))))) + (setf (%class-slots class) eslotds) + (setf (%wrapper-instance-slots new-wrapper) new-ordering + (%wrapper-class-slots new-wrapper) (%class-get class :class-slots) + (%class-own-wrapper class) new-wrapper) + (setup-slot-lookup new-wrapper eslotds))) + + + +(defun setup-slot-lookup (wrapper eslotds) + (when eslotds + (let* ((nslots (length eslotds)) + (total-slot-ids (current-slot-index)) + (small (< nslots 255)) + (map + (if small + (make-array total-slot-ids :element-type '(unsigned-byte 8)) + (make-array total-slot-ids :element-type '(unsigned-byte 32)))) + (table (make-array (the fixnum (1+ nslots)))) + (i 0)) + (declare (fixnum nslots total-slot-ids i) (simple-vector table)) + (setf (svref table 0) nil) + (dolist (slotd eslotds) + (incf i) + (setf (svref table i) slotd) + (if small + (locally (declare (type (simple-array (unsigned-byte 8) (*)) map)) + (setf (aref map + (slot-id.index + (standard-effective-slot-definition.slot-id slotd))) + i)) + (locally (declare (type (simple-array (unsigned-byte 32) (*)) map)) + (setf (aref map + (slot-id.index + (standard-effective-slot-definition.slot-id slotd))) + i)))) + (let* ((lookup-f + #+ppc-target + (gvector :function + (%svref (if small + #'%small-map-slot-id-lookup + #'%large-map-slot-id-lookup) 0) + map + table + (dpb 1 $lfbits-numreq + (ash -1 $lfbits-noname-bit))) + #+x86-target + (%clone-x86-function (if small + #'%small-map-slot-id-lookup + #'%large-map-slot-id-lookup) + map + table + (dpb 1 $lfbits-numreq + (ash -1 $lfbits-noname-bit)))) + (class (%wrapper-class wrapper)) + (get-f + #+ppc-target + (gvector :function + (%svref (if small + #'%small-slot-id-value + #'%large-slot-id-value) 0) + map + table + class + #'%maybe-std-slot-value-using-class + #'%slot-id-ref-missing + (dpb 2 $lfbits-numreq + (ash -1 $lfbits-noname-bit))) + #+x86-target + (%clone-x86-function (if small + #'%small-slot-id-value + #'%large-slot-id-value) + map + table + class + #'%maybe-std-slot-value-using-class + #'%slot-id-ref-missing + (dpb 2 $lfbits-numreq + (ash -1 $lfbits-noname-bit)))) + (set-f + #+ppc-target + (gvector :function + (%svref (if small + #'%small-set-slot-id-value + #'%large-set-slot-id-value) 0) + map + table + class + #'%maybe-std-setf-slot-value-using-class + #'%slot-id-set-missing + (dpb 3 $lfbits-numreq + (ash -1 $lfbits-noname-bit))) + #+x86-target + (%clone-x86-function + (if small + #'%small-set-slot-id-value + #'%large-set-slot-id-value) + map + table + class + #'%maybe-std-setf-slot-value-using-class + #'%slot-id-set-missing + (dpb 3 $lfbits-numreq + (ash -1 $lfbits-noname-bit))))) + (setf (%wrapper-slot-id->slotd wrapper) lookup-f + (%wrapper-slot-id-value wrapper) get-f + (%wrapper-set-slot-id-value wrapper) set-f + (%wrapper-slot-id-map wrapper) map + (%wrapper-slot-definition-table wrapper) table)))) + wrapper) + + + + +(defmethod validate-superclass ((class class) (super class)) + (or (eq super *t-class*) + (let* ((class-of-class (class-of class)) + (class-of-super (class-of super))) + (or (eq class-of-class class-of-super) + (and (eq class-of-class *standard-class-class*) + (eq class-of-super *funcallable-standard-class-class*)) + (and (eq class-of-class *funcallable-standard-class-class*) + (eq class-of-super *standard-class-class*)))))) + +(defmethod validate-superclass ((class foreign-class) (super standard-class)) + t) + +(defmethod validate-superclass ((class std-class) (super forward-referenced-class)) + t) + + +(defmethod add-direct-subclass ((class class) (subclass class)) + (pushnew subclass (%class-direct-subclasses class)) + subclass) + +(defmethod remove-direct-subclass ((class class) (subclass class)) + (setf (%class-direct-subclasses class) + (remove subclass (%class-direct-subclasses class))) + subclass) + +(defun add-direct-subclasses (class new) + (dolist (n new) + (unless (memq class (%class-direct-subclasses class)) + (add-direct-subclass n class)))) + +(defun remove-direct-subclasses (class old-supers new-supers) + (dolist (o old-supers) + (unless (memq o new-supers) + (remove-direct-subclass o class)))) + +;;; Built-in classes are always finalized. +(defmethod class-finalized-p ((class class)) + t) + +;;; Standard classes are finalized if they have a wrapper and that +;;; wrapper has an instance-slots vector; that implies that +;;; both UPDATE-CPL and UPDATE-SLOTS have been called on the class. +(defmethod class-finalized-p ((class std-class)) + (let* ((w (%class-own-wrapper class))) + (and w (typep (%wrapper-instance-slots w) 'vector)))) + +(defmethod finalize-inheritance ((class std-class)) + (update-class class t)) + + +(defmethod finalize-inheritance ((class forward-referenced-class)) + (error "Class ~s can't be finalized." class)) + +(defmethod class-primary-p ((class slots-class)) + (%class-primary-p class)) + +(defmethod (setf class-primary-p) (new (class std-class)) + (setf (%class-primary-p class) new)) + +(defmethod class-primary-p ((class class)) + t) + +(defmethod (setf class-primary-p) (new (class class)) + new) + + +(defun forward-referenced-class-p (class) + (and (%standard-instance-p class) + (eq (%class-of-instance class) *forward-referenced-class-class*))) + +;;; This uses the primary class information to sort the slots of a class. +(defun sort-effective-instance-slotds (slotds class cpl) + (let (primary-slotds + primary-slotds-class + (primary-slotds-length 0)) + (declare (fixnum primary-slotds-length)) + (dolist (sup (cdr cpl)) + (unless (eq sup *t-class*) + (when (class-primary-p sup) + (let ((sup-slotds (extract-instance-effective-slotds sup))) + (if (null primary-slotds-class) + (setf primary-slotds-class sup + primary-slotds sup-slotds + primary-slotds-length (length sup-slotds)) + (let ((sup-slotds-length (length sup-slotds))) + (do* ((i 0 (1+ i)) + (n (min sup-slotds-length primary-slotds-length)) + (sup-slotds sup-slotds (cdr sup-slotds)) + (primary-slotds primary-slotds (cdr primary-slotds))) + ((= i n)) + (unless (eq (%slot-definition-name (car sup-slotds)) + (%slot-definition-name (car primary-slotds))) + (error "While initializing ~s:~%~ + attempt to mix incompatible primary classes:~%~ + ~s and ~s" + class sup primary-slotds-class))) + (when (> sup-slotds-length primary-slotds-length) + (setq primary-slotds-class sup + primary-slotds sup-slotds + primary-slotds-length sup-slotds-length)))))))) + (if (null primary-slotds-class) + slotds + (flet ((slotd-position (slotd) + (let* ((slotd-name (%slot-definition-name slotd))) + (do* ((i 0 (1+ i)) + (primary-slotds primary-slotds (cdr primary-slotds))) + ((= i primary-slotds-length) primary-slotds-length) + (declare (fixnum i)) + (when (eq slotd-name + (%slot-definition-name (car primary-slotds))) + (return i)))))) + (declare (dynamic-extent #'slotd-position)) + (sort-list slotds '< #'slotd-position))))) + + + + +(defun update-cpl (class cpl) + (if (class-finalized-p class) + (unless (equal (%class.cpl class) cpl) + (setf (%class.cpl class) cpl) + #|(force-cache-flushes class)|#) + (setf (%class.cpl class) cpl)) + cpl) + + +(defun class-has-a-forward-referenced-superclass-p (original) + (labels ((scan-forward-refs (class seen) + (unless (memq class seen) + (or (if (forward-referenced-class-p class) class) + (let ((seen (cons class seen))) + (declare (dynamic-extent seen)) + (dolist (s (%class-direct-superclasses class)) + (when (eq s original) + (error "circular class hierarchy: the class ~s is a superclass of at least one of its superclasses (~s)." original class)) + (let* ((fwdref (scan-forward-refs s seen))) + (when fwdref (return fwdref))))))))) + (or (compile-time-class-p original) + (scan-forward-refs original ())))) + +(defun class-forward-referenced-superclasses (original) + (labels ((scan-forward-refs (class seen fwdrefs) + (unless (memq class seen) + (if (forward-referenced-class-p class) + (push class fwdrefs) + (let ((seen (cons class seen))) + (declare (dynamic-extent seen)) + (dolist (s (%class-direct-superclasses class)) + (when (eq s original) + (error "circular class hierarchy: the class ~s is a superclass of at least one of its superclasses (~s)." original class)) + (setq fwdrefs (scan-forward-refs s seen fwdrefs)))))) + fwdrefs)) + (scan-forward-refs original () ()))) + + + +(defmethod compute-class-precedence-list ((class class)) + (let* ((fwdrefs (class-forward-referenced-superclasses class))) + (if fwdrefs + (if (cdr fwdrefs) + (error "Class ~s can't be finalized because superclasses ~s are not defined yet" + class (mapcar #'%class-name fwdrefs)) + (error "Class ~s can't be finalized because superclass ~s is not defined yet" + class (%class-name (car fwdrefs)))) + (compute-cpl class)))) + +;;; Classes that can't be instantiated via MAKE-INSTANCE have no +;;; initargs caches. +(defmethod %flush-initargs-caches ((class class)) + ) + +;;; Classes that have initargs caches should flush them when the +;;; class is finalized. +(defmethod %flush-initargs-caches ((class std-class)) + (setf (%class.make-instance-initargs class) nil + (%class.reinit-initargs class) nil + (%class.redefined-initargs class) nil + (%class.changed-initargs class) nil)) + +(defun update-class (class finalizep) + ;; + ;; Calling UPDATE-SLOTS below sets the class wrapper of CLASS, which + ;; makes the class finalized. When UPDATE-CLASS isn't called from + ;; FINALIZE-INHERITANCE, make sure that this finalization invokes + ;; FINALIZE-INHERITANCE as per AMOP. Note, that we can't simply + ;; delay the finalization when CLASS has no forward referenced + ;; superclasses because that causes bootstrap problems. + (when (and (not (or finalizep (class-finalized-p class))) + (not (class-has-a-forward-referenced-superclass-p class))) + (finalize-inheritance class) + (return-from update-class)) + (when (or finalizep (class-finalized-p class)) + (let* ((cpl (update-cpl class (compute-class-precedence-list class)))) + ;; This -should- be made to work for structure classes + (update-slots class (compute-slots class)) + (setf (%class-default-initargs class) (compute-default-initargs class)) + (%flush-initargs-caches class) + (let* ((wrapper (%class-own-wrapper class))) + (when wrapper + (setf (%wrapper-cpl wrapper) cpl + (%wrapper-cpl-bits wrapper) (make-cpl-bits cpl)))))) + (unless finalizep + (dolist (sub (%class-direct-subclasses class)) + (update-class sub nil)))) + +(defun add-accessor-methods (class dslotds) + (dolist (dslotd dslotds) + (dolist (reader (%slot-definition-readers dslotd)) + (add-reader-method class + (ensure-generic-function reader) + dslotd)) + (dolist (writer (%slot-definition-writers dslotd)) + (add-writer-method class + (ensure-generic-function writer) + dslotd)))) + +(defun remove-accessor-methods (class dslotds) + (dolist (dslotd dslotds) + (dolist (reader (%slot-definition-readers dslotd)) + (remove-reader-method class (ensure-generic-function reader :lambda-list '(x)))) + (dolist (writer (%slot-definition-writers dslotd)) + (remove-writer-method class (ensure-generic-function writer :lambda-list '(x y)))))) + +(defmethod reinitialize-instance :before ((class std-class) &key direct-superclasses) + (remove-accessor-methods class (%class-direct-slots class)) + (remove-direct-subclasses class (%class-direct-superclasses class) direct-superclasses)) + +(defmethod shared-initialize :after + ((class slots-class) + slot-names &key + (direct-superclasses nil direct-superclasses-p) + (direct-slots nil direct-slots-p) + (direct-default-initargs nil direct-default-initargs-p) + (documentation nil doc-p) + (primary-p nil primary-p-p)) + (if (or direct-superclasses-p (eq slot-names t)) + (progn + (setq direct-superclasses + (or direct-superclasses + (list (if (typep class 'funcallable-standard-class) + *funcallable-standard-object-class* + *standard-object-class*)))) + (dolist (superclass direct-superclasses) + (unless (validate-superclass class superclass) + (error "The class ~S was specified as a~%super-class of the class ~S;~%~ + but the meta-classes ~S and~%~S are incompatible." + superclass class (class-of superclass) (class-of class)))) + (setf (%class-direct-superclasses class) direct-superclasses)) + (setq direct-superclasses (%class-direct-superclasses class))) + (setq direct-slots + (if direct-slots-p + (setf (%class-direct-slots class) + (mapcar #'(lambda (initargs) + (make-direct-slot-definition class initargs)) + direct-slots)) + (%class-direct-slots class))) + (if direct-default-initargs-p + (setf (%class-direct-default-initargs class) direct-default-initargs) + (setq direct-default-initargs (%class-direct-default-initargs class))) + (let* ((new-class-slot-cells ()) + (old-class-slot-cells (%class-get class :class-slots))) + (dolist (slot direct-slots) + (when (eq (%slot-definition-allocation slot) :class) + (let* ((slot-name (%slot-definition-name slot)) + (pair (assq slot-name old-class-slot-cells))) + ;;; If the slot existed as a class slot in the old + ;;; class, retain the definition (even if it's unbound.) + (unless pair + (let* ((initfunction (%slot-definition-initfunction slot))) + (setq pair (cons slot-name + (if initfunction + (funcall initfunction) + (%slot-unbound-marker)))))) + (push pair new-class-slot-cells)))) + (when new-class-slot-cells + (setf (%class-get class :class-slots) new-class-slot-cells))) + (when doc-p + (set-documentation class 'type documentation)) + (when primary-p-p + (setf (class-primary-p class) primary-p)) + + (add-direct-subclasses class direct-superclasses) + (update-class class nil) + (add-accessor-methods class direct-slots)) + +(defmethod initialize-instance :before ((class class) &key &allow-other-keys) + (setf (%class-ordinal class) (%next-class-ordinal)) + (setf (%class.ctype class) (make-class-ctype class))) + +(defun ensure-class-metaclass-and-initargs (class args) + (let* ((initargs (copy-list args)) + (missing (cons nil nil)) + (supplied-meta (getf initargs :metaclass missing)) + (supplied-supers (getf initargs :direct-superclasses missing)) + (supplied-slots (getf initargs :direct-slots missing)) + (metaclass (cond ((not (eq supplied-meta missing)) + (if (typep supplied-meta 'class) + supplied-meta + (find-class supplied-meta))) + ((or (null class) + (typep class 'forward-referenced-class)) + *standard-class-class*) + (t (class-of class))))) + (declare (dynamic-extent missing)) + (flet ((fix-super (s) + (cond ((classp s) s) + ((not (and s (symbolp s))) + (error "~s is not a class or a legal class name." s)) + (t + (or (find-class s nil) + (setf (find-class s) + (make-instance 'forward-referenced-class :name s)))))) + (excise-all (keys) + (dolist (key keys) + (loop (unless (remf initargs key) (return)))))) + (excise-all '(:metaclass :direct-superclasses :direct-slots)) + (values metaclass + `(,@ (unless (eq supplied-supers missing) + `(:direct-superclasses ,(mapcar #'fix-super supplied-supers))) + ,@ (unless (eq supplied-slots missing) + `(:direct-slots ,supplied-slots)) + ,@initargs))))) + + +;;; This defines a new class. +(defmethod ensure-class-using-class ((class null) name &rest keys &key &allow-other-keys) + (multiple-value-bind (metaclass initargs) + (ensure-class-metaclass-and-initargs class keys) + (let* ((class (apply #'make-instance metaclass :name name initargs))) + (setf (find-class name) class)))) + +(defmethod ensure-class-using-class ((class forward-referenced-class) name &rest keys &key &allow-other-keys) + (multiple-value-bind (metaclass initargs) + (ensure-class-metaclass-and-initargs class keys) + (apply #'change-class class metaclass initargs) + (apply #'reinitialize-instance class initargs) + (setf (find-class name) class))) + +;; Can't go with optimize-make-instance-for-class-name because +;; ensure-class-using-class is called before that is defined. +(defun pessimize-make-instance-for-class-name (class-name) + (let ((cell (find-class-cell class-name nil))) + (when cell + (init-class-cell-instantiator cell)))) + +(defun init-class-cell-instantiator (cell) + (when cell + (setf (class-cell-instantiate cell) '%make-instance) + (setf (class-cell-extra cell) nil))) + +;;; Redefine an existing (not forward-referenced) class. +(defmethod ensure-class-using-class ((class class) name &rest keys &key) + (multiple-value-bind (metaclass initargs) + (ensure-class-metaclass-and-initargs class keys) + (unless (eq (class-of class) metaclass) + (error "Can't change metaclass of ~s to ~s." class metaclass)) + (apply #'reinitialize-instance class initargs) + (setf (find-class name) class))) + + +(defun ensure-class (name &rest keys &key &allow-other-keys) + (declare (dynamic-extent keys)) + (apply #'ensure-class-using-class (find-class name nil) name keys)) + +(defparameter *defclass-redefines-improperly-named-classes-pedantically* + t + "ANSI CL expects DEFCLASS to redefine an existing class only when +the existing class is properly named, the MOP function ENSURE-CLASS +redefines existing classes regardless of their CLASS-NAME. This variable +governs whether DEFCLASS makes that distinction or not.") + +(defun ensure-class-for-defclass (name &rest keys &key &allow-other-keys) + (declare (dynamic-extent keys)) + (record-source-file name 'class) + (let* ((existing-class (find-class name nil))) + (when (and *defclass-redefines-improperly-named-classes-pedantically* + existing-class + (not (eq (class-name existing-class) name))) + ;; Class isn't properly named; act like it didn't exist + (setq existing-class nil)) + (apply #'ensure-class-using-class existing-class name keys))) + + + + +(defmethod method-slot-name ((m standard-accessor-method)) + (standard-direct-slot-definition.name (%accessor-method.slot-definition m))) + + +(defun %ensure-class-preserving-wrapper (&rest args) + (declare (dynamic-extent args)) + (let* ((*update-slots-preserve-existing-wrapper* t)) + (apply #'ensure-class args))) + +(defun %find-direct-slotd (class name) + (dolist (dslotd (%class-direct-slots class) + (error "Direct slot definition for ~s not found in ~s" name class)) + (when (eq (%slot-definition-name dslotd) name) + (return dslotd)))) + +(defun %add-slot-readers (class-name pairs) + (let* ((class (find-class class-name))) + (dolist (pair pairs) + (destructuring-bind (slot-name &rest readers) pair + (setf (%slot-definition-readers (%find-direct-slotd class slot-name)) readers))) + (add-accessor-methods class (%class-direct-slots class)))) + +(defun %add-slot-writers (class-name pairs) + (let* ((class (find-class class-name))) + (dolist (pair pairs) + (destructuring-bind (slot-name &rest readers) pair + (setf (%slot-definition-writers (%find-direct-slotd class slot-name)) readers))) + (add-accessor-methods class (%class-direct-slots class)))) + + +(%ensure-class-preserving-wrapper + 'standard-method + :direct-superclasses '(method) + :direct-slots `((:name qualifiers :initargs (:qualifiers) :initfunction ,#'false :initform nil) + (:name specializers :initargs (:specializers) :initfunction ,#'false :initform nil) + (:name function :initargs (:function)) + (:name generic-function :initargs (:generic-function) :initfunction ,#'false :initform nil) + (:name name :initargs (:name) :initfunction ,#'false :initform nil) + (:name lambda-list :initform nil :initfunction ,#'false + :initargs (:lambda-list))) + :primary-p t) + +(defmethod shared-initialize :after ((method standard-method) + slot-names + &key function &allow-other-keys) + (declare (ignore slot-names)) + (when function + (let* ((inner (closure-function function))) + (unless (eq inner function) + (copy-method-function-bits inner function))) + (lfun-name function method))) + +;;; Reader & writer methods classes. +(%ensure-class-preserving-wrapper + 'standard-accessor-method + :direct-superclasses '(standard-method) + :direct-slots '((:name slot-definition :initargs (:slot-definition))) + :primary-p t) + +(%ensure-class-preserving-wrapper + 'standard-reader-method + :direct-superclasses '(standard-accessor-method)) + +(%ensure-class-preserving-wrapper + 'standard-writer-method + :direct-superclasses '(standard-accessor-method)) + +(defmethod reader-method-class ((class standard-class) + (dslotd standard-direct-slot-definition) + &rest initargs) + (declare (ignore initargs)) + *standard-reader-method-class*) + +(defmethod reader-method-class ((class funcallable-standard-class) + (dslotd standard-direct-slot-definition) + &rest initargs) + (declare (ignore initargs)) + *standard-reader-method-class*) + +(defmethod add-reader-method ((class slots-class) gf dslotd) + (let* ((initargs + `(:qualifiers nil + :specializers ,(list class) + :lambda-list (,(or (%class-name class) 'instance)) + :name ,(function-name gf) + :slot-definition ,dslotd)) + (reader-method-class + (apply #'reader-method-class class dslotd initargs)) + (method-function (create-reader-method-function + class (class-prototype reader-method-class) dslotd)) + (method (apply #'make-instance reader-method-class + :function method-function + initargs))) + (declare (dynamic-extent initargs)) + (record-source-file method 'reader-method) + (add-method gf method))) + +(defmethod remove-reader-method ((class std-class) gf) + (let* ((method (find-method gf () (list class) nil))) + (when method (remove-method gf method)))) + +(defmethod writer-method-class ((class standard-class) + (dslotd standard-direct-slot-definition) + &rest initargs) + (declare (ignore initargs)) + *standard-writer-method-class*) + +(defmethod writer-method-class ((class funcallable-standard-class) + (dslotd standard-direct-slot-definition) + &rest initargs) + (declare (ignore initargs)) + *standard-writer-method-class*) + + +(defmethod add-writer-method ((class slots-class) gf dslotd) + (let* ((initargs + `(:qualifiers nil + :specializers ,(list *t-class* class) + :lambda-list (new-value ,(or (%class-name class) 'instance)) + :name ,(function-name gf) + :slot-definition ,dslotd)) + (method-class (apply #'writer-method-class class dslotd initargs)) + (method + (apply #'make-instance + method-class + :function (create-writer-method-function + class + (class-prototype method-class) + dslotd) + initargs))) + (declare (dynamic-extent initargs)) + (record-source-file method 'writer-method) + (add-method gf method))) + +(defmethod remove-writer-method ((class std-class) gf) + (let* ((method (find-method gf () (list *t-class* class) nil))) + (when method (remove-method gf method)))) + +;;; We can now define accessors. Fix up the slots in the classes defined +;;; thus far. + +(%add-slot-readers 'standard-method '((qualifiers method-qualifiers) + (specializers method-specializers) + (name method-name) + ;(function method-function) + (generic-function method-generic-function) + (lambda-list method-lambda-list))) + +(%add-slot-writers 'standard-method '((function (setf method-function)) + (generic-function (setf method-generic-function)))) + + +(defmethod method-function ((m standard-method)) + (%method.function m)) + + +(%add-slot-readers 'standard-accessor-method + '((slot-definition accessor-method-slot-definition))) + + +(%ensure-class-preserving-wrapper + 'specializer + :direct-superclasses '(metaobject) + :direct-slots `((:name direct-methods + :readers (specializer-direct-methods) + :initform nil :initfunction ,#'false)) + :primary-p t) + +(%ensure-class-preserving-wrapper + 'eql-specializer + :direct-superclasses '(specializer) + :direct-slots '((:name object :initargs (:object) :readers (eql-specializer-object))) + :primary-p t) + + +(%ensure-class-preserving-wrapper + 'class + :direct-superclasses '(specializer) + :direct-slots + `((:name prototype :initform nil :initfunction ,#'false) + (:name name :initargs (:name) :initform nil :initfunction ,#'false :readers (class-name)) + (:name precedence-list :initform nil :initfunction ,#'false) + (:name own-wrapper :initform nil :initfunction ,#'false :readers (class-own-wrapper) :writers ((setf class-own-wrapper))) + (:name direct-superclasses :initform nil :initfunction ,#'false :readers (class-direct-superclasses)) + (:name direct-subclasses :initform nil :initfunction ,#'false :readers (class-direct-subclasses)) + (:name dependents :initform nil :initfunction ,#'false) + (:name class-ctype :initform nil :initfunction ,#'false) + (:name direct-slots :initform nil :initfunction ,#'false + :readers (class-direct-slots) + :writers ((setf class-direct-slots))) + (:name slots :initform nil :initfunction ,#'false + :readers (class-slots) + :writers ((setf class-slots))) + (:name info :initform (cons nil nil) :initfunction ,(lambda () (cons nil nil)) :readers (class-info)) + (:name direct-default-initargs :initform nil :initfunction ,#'false :readers (class-direct-default-initargs)) + (:name default-initargs :initform nil :initfunction ,#'false :readers (class-default-initargs))) + :primary-p t) + +(%ensure-class-preserving-wrapper + 'forward-referenced-class + :direct-superclasses '(class)) + + + +(%ensure-class-preserving-wrapper + 'built-in-class + :direct-superclasses '(class)) + + +(%ensure-class-preserving-wrapper + 'slots-class + :direct-superclasses '(class) + :direct-slots `((:name alist :initform nil :initfunction ,#'false)) + :primary-p t) + +;;; This class exists only so that standard-class & funcallable-standard-class +;;; can inherit its slots. +(%ensure-class-preserving-wrapper + 'std-class + :direct-superclasses '(slots-class) + :direct-slots `( + (:name make-instance-initargs :initform nil :initfunction ,#'false) + (:name reinit-initargs :initform nil :initfunction ,#'false) + (:name redefined-initargs :initform nil :initfunction ,#'false) + (:name changed-initargs :initform nil :initfunction ,#'false)) + :primary-p t) + + + +(%ensure-class-preserving-wrapper + 'standard-class + :direct-superclasses '(std-class)) + +(%ensure-class-preserving-wrapper + 'funcallable-standard-class + :direct-superclasses '(std-class)) + + +(%ensure-class-preserving-wrapper + 'funcallable-standard-object +#|| + :direct-superclasses '(standard-object function) +||# + :direct-slots `((:name name :initargs (:name) :readers (generic-function-name))) + :metaclass 'funcallable-standard-class) + +(%ensure-class-preserving-wrapper + 'generic-function + :direct-superclasses '(metaobject funcallable-standard-object) + :direct-slots `( + (:name method-combination :initargs (:method-combination) + :initform *standard-method-combination* + :initfunction ,#'(lambda () *standard-method-combination*) + :readers (generic-function-method-combination)) + (:name method-class :initargs (:method-class) + :initform *standard-method-class* + :initfunction ,#'(lambda () *standard-method-class*) + :readers (generic-function-method-class)) + (:name methods :initargs (:methods) + :initform nil :initfunction ,#'false + :readers (generic-function-methods)) + (:name declarations + :initargs (:declarations) + :initform nil :initfunction ,#'false + :readers (generic-function-declarations)) + (:name %lambda-list + :initform :unspecified + :initfunction ,(constantly :unspecified)) + (:name dependents + :initform nil :initfunction ,#'false)) + :metaclass 'funcallable-standard-class) + + + +(%ensure-class-preserving-wrapper + 'standard-generic-function + :direct-superclasses '(generic-function) + + :metaclass 'funcallable-standard-class + :primary-p t) + +(%ensure-class-preserving-wrapper + 'standard-generic-function + :direct-superclasses '(generic-function) + + :metaclass 'funcallable-standard-class) + +(%ensure-class-preserving-wrapper + 'structure-class + :direct-superclasses '(slots-class)) + +(%ensure-class-preserving-wrapper + 'slot-definition + :direct-superclasses '(metaobject) + :direct-slots `((:name name :initargs (:name) :readers (slot-definition-name) + :initform nil :initfunction ,#'false) + (:name type :initargs (:type) :readers (slot-definition-type) + :initform t :initfunction ,#'true) + (:name initfunction :initargs (:initfunction) :readers (slot-definition-initfunction) + :initform nil :initfunction ,#'false) + (:name initform :initargs (:initform) :readers (slot-definition-initform) + :initform nil :initfunction ,#'false) + (:name initargs :initargs (:initargs) :readers (slot-definition-initargs) + :initform nil :initfunction ,#'false) + (:name allocation :initargs (:allocation) :readers (slot-definition-allocation) + :initform :instance :initfunction ,(constantly :instance)) + (:name documentation :initargs (:documentation) :readers (slot-definition-documentation) + :initform nil :initfunction ,#'false) + (:name class :initargs (:class) :readers (slot-definition-class))) + + :primary-p t) + +(%ensure-class-preserving-wrapper + 'direct-slot-definition + :direct-superclasses '(slot-definition) + :direct-slots `((:name readers :initargs (:readers) :initform nil + :initfunction ,#'false :readers (slot-definition-readers)) + (:name writers :initargs (:writers) :initform nil + :initfunction ,#'false :readers (slot-definition-writers)))) + +(%ensure-class-preserving-wrapper + 'effective-slot-definition + :direct-superclasses '(slot-definition) + :direct-slots `((:name location :initform nil :initfunction ,#'false + :readers (slot-definition-location)) + (:name slot-id :initform nil :initfunction ,#'false + :readers (slot-definition-slot-id)) + (:name type-predicate :initform nil + :initfunction ,#'false + :readers (slot-definition-predicate)) + ) + + :primary-p t) + +(%ensure-class-preserving-wrapper + 'standard-slot-definition + :direct-superclasses '(slot-definition) +) + + + + + + + +(%ensure-class-preserving-wrapper + 'standard-direct-slot-definition + :direct-superclasses '(standard-slot-definition direct-slot-definition) +) + +(%ensure-class-preserving-wrapper + 'standard-effective-slot-definition + :direct-superclasses '(standard-slot-definition effective-slot-definition)) + + + + + + + + + +;;; Fake method-combination, redefined in lib;method-combination. +(unless *type-system-initialized* + (defclass method-combination (metaobject) + ((name :initarg :name)))) + + + + +(defclass standard-method-combination (method-combination) ()) + +(initialize-instance *standard-method-combination* :name 'standard) + +(setq *standard-kernel-method-class* + (defclass standard-kernel-method (standard-method) + ())) + +(unless *standard-method-combination* + (setq *standard-method-combination* + (make-instance 'standard-method-combination :name 'standard))) + +;;; For %compile-time-defclass +(defclass compile-time-class (class) ()) + +(defmethod compile-time-class-p ((class compile-time-class)) + t) + +(defmethod class-finalized-p ((class compile-time-class)) + nil) + + +(defclass structure-slot-definition (slot-definition) ()) +(defclass structure-effective-slot-definition (structure-slot-definition + effective-slot-definition) + ()) + +(defclass structure-direct-slot-definition (structure-slot-definition + direct-slot-definition) + ()) + +(defmethod shared-initialize :after ((class structure-class) + slot-names + &key + (direct-superclasses nil direct-superclasses-p) + &allow-other-keys) + (declare (ignore slot-names)) + (labels ((obsolete (class) + (dolist (sub (%class-direct-subclasses class)) (obsolete sub)) + ;;Need to save old class info in wrapper for obsolete + ;;instance access... + (setf (%class.cpl class) nil))) + (obsolete class) + (when direct-superclasses-p + (let* ((old-supers (%class-direct-superclasses class)) + (new-supers direct-superclasses)) + (dolist (c old-supers) + (unless (memq c new-supers) + (remove-direct-subclass c class))) + (dolist (c new-supers) + (unless (memq c old-supers) + (add-direct-subclass c class))) + (setf (%class.local-supers class) new-supers))) + (let* ((wrapper (or (%class-own-wrapper class) + (setf (%class-own-wrapper class) (%cons-wrapper class)))) + (cpl (compute-cpl class))) + (setf (%class.cpl class) cpl) + (setf (%wrapper-cpl wrapper) cpl + (%wrapper-cpl-bits wrapper) (make-cpl-bits cpl))))) + + + + +;;; Called from DEFSTRUCT expansion. +(defun %define-structure-class (sd) + (let* ((dslots ())) + (dolist (ssd (cdr (sd-slots sd)) (setq dslots (nreverse dslots))) + (let* ((type (ssd-type ssd)) + (refinfo (ssd-refinfo ssd))) + (unless (logbitp $struct-inherited refinfo) + (let* ((name (ssd-name ssd)) + (initform (cadr ssd)) + (initfunction (constantly initform))) + (push `(:name ,name :type ,type :initform ,initform :initfunction ,initfunction :initargs ,(list (make-keyword name))) dslots))))) + (ensure-class (sd-name sd) + :metaclass 'structure-class + :direct-superclasses (list (or (cadr (sd-superclasses sd)) 'structure-object)) + :direct-slots dslots + ))) + + +(defun standard-instance-access (instance location) + (etypecase location + (fixnum (%standard-instance-instance-location-access instance location)) + (cons (%cdr location)))) + +(defun (setf standard-instance-access) (new instance location) + (etypecase location + (fixnum (setf (standard-instance-instance-location-access instance location) + new)) + (cons (setf (%cdr location) new)))) + +(defun funcallable-standard-instance-access (instance location) + (etypecase location + (fixnum (%standard-generic-function-instance-location-access instance location)) + (cons (%cdr location)))) + +(defun (setf funcallable-standard-instance-access) (new instance location) + (etypecase location + (fixnum (setf (%standard-generic-function-instance-location-access instance location) new)) + (cons (setf (%cdr location) new)))) + +;;; Handle a trap from %slot-ref +(defun %slot-unbound-trap (slotv idx frame-ptr) + (let* ((instance nil) + (class nil) + (slot nil)) + (if (and (eq (typecode slotv) target::subtag-slot-vector) + (setq instance (slot-vector.instance slotv)) + (setq slot + (find idx (class-slots (setq class (class-of instance))) + :key #'slot-definition-location))) + (slot-unbound class instance (slot-definition-name slot)) + (%error "Unbound slot at index ~d in ~s" (list idx slotv) frame-ptr)))) + + + +;;; +;;; Now that CLOS is nominally bootstrapped, it's possible to redefine some +;;; of the functions that really should have been generic functions ... +(setf (fdefinition '%class-name) #'class-name + (fdefinition '%class-default-initargs) #'class-default-initargs + (fdefinition '%class-direct-default-initargs) #'class-direct-default-initargs + (fdefinition '(setf %class-direct-default-initargs)) + #'(lambda (new class) + (if (typep class 'slots-class) + (setf (slot-value class 'direct-default-initargs) new) + new)) + (fdefinition '%class-direct-slots) #'class-direct-slots + (fdefinition '(setf %class-direct-slots)) + #'(setf class-direct-slots) + (fdefinition '%class-slots) #'class-slots + (fdefinition '%class-direct-superclasses) #'class-direct-superclasses + (fdefinition '(setf %class-direct-superclasses)) + #'(lambda (new class) + (setf (slot-value class 'direct-superclasses) new)) + (fdefinition '%class-direct-subclasses) #'class-direct-subclasses + ;(fdefinition '%class-own-wrapper) #'class-own-wrapper + (fdefinition '(setf %class-own-wrapper)) #'(setf class-own-wrapper) +) + + + +(setf (fdefinition '%slot-definition-name) #'slot-definition-name + (fdefinition '%slot-definition-type) #'slot-definition-type + (fdefinition '%slot-definition-initargs) #'slot-definition-initargs + (fdefinition '%slot-definition-allocation) #'slot-definition-allocation + (fdefinition '%slot-definition-location) #'slot-definition-location + (fdefinition '%slot-definition-readers) #'slot-definition-readers + (fdefinition '%slot-definition-writers) #'slot-definition-writers) + + +(setf (fdefinition '%method-qualifiers) #'method-qualifiers + (fdefinition '%method-specializers) #'method-specializers + (fdefinition '%method-function) #'method-function + (fdefinition '(setf %method-function)) #'(setf method-function) + (fdefinition '%method-gf) #'method-generic-function + (fdefinition '(setf %method-gf)) #'(setf method-generic-function) + (fdefinition '%method-name) #'method-name + (fdefinition '%method-lambda-list) #'method-lambda-list + ) + +(setf (fdefinition '%add-method) #'add-method) + + +;;; Make a direct-slot-definition of the appropriate class. +(defun %make-direct-slotd (slotd-class &rest initargs) + (declare (dynamic-extent initargs)) + (apply #'make-instance slotd-class initargs)) + +;;; Likewise, for an effective-slot-definition. +(defun %make-effective-slotd (slotd-class &rest initargs) + (declare (dynamic-extent initargs)) + (apply #'make-instance slotd-class initargs)) + +;;; Likewise, for methods +(defun %make-method-instance (class &rest initargs) + (apply #'make-instance class initargs)) + +(defmethod initialize-instance :after ((slotd effective-slot-definition) &key name) + (setf (standard-effective-slot-definition.slot-id slotd) + (ensure-slot-id name))) + + +(defmethod specializer-direct-generic-functions ((s specializer)) + (let* ((gfs ()) + (methods (specializer-direct-methods s))) + (dolist (m methods gfs) + (let* ((gf (method-generic-function m))) + (when gf (pushnew gf gfs)))))) + +(defmethod generic-function-lambda-list ((gf standard-generic-function)) + (%maybe-compute-gf-lambda-list gf (car (generic-function-methods gf)))) + +(defmethod generic-function-argument-precedence-order + ((gf standard-generic-function)) + (let* ((req (required-lambda-list-args (generic-function-lambda-list gf))) + (apo (%gf-dispatch-table-precedence-list + (%gf-dispatch-table gf)))) + (if (null apo) + req + (mapcar #'(lambda (n) (nth n req)) apo)))) + +(defun normalize-egf-keys (keys gf) + (let* ((missing (cons nil nil)) + (env (getf keys :environment nil))) + (declare (dynamic-extent missing)) + (remf keys :environment) + (let* ((gf-class (getf keys :generic-function-class missing)) + (mcomb (getf keys :method-combination missing)) + (method-class (getf keys :method-class missing))) + (if (eq gf-class missing) + (setf gf-class (if gf (class-of gf) *standard-generic-function-class*)) + (progn + (remf keys :generic-function-class) + (if (typep gf-class 'symbol) + (setq gf-class + (find-class gf-class t env))) + (unless (or (eq gf-class *standard-generic-function-class*) + (subtypep gf-class *generic-function-class*)) + (error "Class ~S is not a subclass of ~S" + gf-class *generic-function-class*)))) + (unless (eq mcomb missing) + (unless (typep mcomb 'method-combination) + (setf (getf keys :method-combination) + (find-method-combination (class-prototype gf-class) + (car mcomb) + (cdr mcomb))))) + (unless (eq method-class missing) + (if (typep method-class 'symbol) + (setq method-class (find-class method-class t env))) + (unless (subtypep method-class *method-class*) + (error "~s is not a subclass of ~s" method-class *method-class*)) + (setf (getf keys :method-class) method-class)) + (values gf-class keys)))) + +(defmethod ensure-generic-function-using-class + ((gf null) + function-name + &rest keys + &key + &allow-other-keys) + (declare (dynamic-extent keys)) + (multiple-value-bind (gf-class initargs) + (normalize-egf-keys keys nil) + (let* ((gf (apply #'make-instance gf-class + :name function-name + initargs))) + (setf (fdefinition function-name) gf)))) + +(defparameter *error-on-gf-class-redefinition* nil + "The MOP spec requires ENSURE-GENERIC-FUNCTION-USING-CLASS of an + existing gf to signal an error if the :GENERIC-FUNCTION-CLASS + argument specifies a class other than the existing gf's class. + ANSI CL allows this kind of redefinition if the classes are + \"compatible\", but doesn't define what compatibility means + in this case. When *ERROR-ON-GF-CLASS-REDEFINITION* is true, + a continuable error is signaled. + + Historically, Clozure CL CERRORed, but didn't offer a useful + CHANGE-CLASS method that would change the GF's class") + +(defmethod ensure-generic-function-using-class + ((gf generic-function) + function-name + &rest keys + &key + &allow-other-keys) + (declare (dynamic-extent keys) (ignorable function-name)) + (multiple-value-bind (gf-class initargs) + (normalize-egf-keys keys gf) + (unless (eq gf-class (class-of gf)) + (when *error-on-gf-class-redefinition* + (cerror (format nil "Change the class of ~s to ~s." gf gf-class) + "The class of the existing generic function ~s is not ~s" + gf gf-class)) + (change-class gf gf-class)) + (apply #'reinitialize-instance gf initargs))) + + +(defmethod initialize-instance :before ((instance generic-function) + &key &allow-other-keys) + (setf (%gf-dcode instance) #'%%0-arg-dcode)) + +(defmethod initialize-instance :after ((gf standard-generic-function) + &key + (lambda-list nil ll-p) + (argument-precedence-order nil apo-p) + &allow-other-keys) + (if (and apo-p (not ll-p)) + (error + "Cannot specify :ARGUMENT-PRECEDENCE-ORDER without specifying :LAMBDA-LIST")) + (if ll-p + (progn + (unless (verify-lambda-list lambda-list) + (error "~s is not a valid generic function lambda list" lambda-list)) + (if apo-p + (set-gf-arg-info gf :lambda-list lambda-list + :argument-precedence-order argument-precedence-order) + (set-gf-arg-info gf :lambda-list lambda-list))) + (set-gf-arg-info gf)) + (if (gf-arg-info-valid-p gf) + (compute-dcode gf (%gf-dispatch-table gf))) + gf) + +(defmethod reinitialize-instance :after ((gf standard-generic-function) + &rest args + &key + (lambda-list nil ll-p) + (argument-precedence-order nil apo-p) + &allow-other-keys) + (if (and apo-p (not ll-p)) + (error + "Cannot specify :ARGUMENT-PRECEDENCE-ORDER without specifying :LAMBDA-LIST")) + (if ll-p + (progn + (unless (verify-lambda-list lambda-list) + (error "~s is not a valid generic function lambda list" lambda-list)) + (if apo-p + (set-gf-arg-info gf :lambda-list lambda-list + :argument-precedence-order argument-precedence-order) + (set-gf-arg-info gf :lambda-list lambda-list))) + (set-gf-arg-info gf)) + (if (and (gf-arg-info-valid-p gf) + args + (or ll-p (cddr args))) + (compute-dcode gf (%gf-dispatch-table gf))) + (when (sgf.dependents gf) + (map-dependents gf #'(lambda (d) + (apply #'update-dependent gf d args)))) + gf) + + +(defun decode-method-lambda-list (method-lambda-list) + (flet ((bad () + (error "Invalid lambda-list syntax in ~s" method-lambda-list))) + (collect ((specnames) + (required)) + (do* ((tail method-lambda-list (cdr tail)) + (head (car tail) (car tail))) + ((or (null tail) (member head lambda-list-keywords)) + (if (verify-lambda-list tail) + (values (required) tail (specnames)) + (bad))) + (cond ((atom head) + (unless (typep head 'symbol) (bad)) + (required head) + (specnames t)) + (t + (unless (and (typep (car head) 'symbol) + (consp (cdr head)) + (null (cddr head))) + (bad)) + (required (car head)) + (specnames (cadr head)))))))) + +(defun extract-specializer-names (method-lambda-list) + (nth-value 2 (decode-method-lambda-list method-lambda-list))) + +(defun extract-lambda-list (method-lambda-list) + (multiple-value-bind (required tail) + (decode-method-lambda-list method-lambda-list) + (nconc required tail))) + +(setf (fdefinition '%ensure-generic-function-using-class) + #'ensure-generic-function-using-class) + + +(defmethod shared-initialize :after ((gf generic-function) slot-names + &key + (documentation nil doc-p)) + (declare (ignore slot-names)) + (when doc-p + (if documentation (check-type documentation string)) + (set-documentation gf t documentation))) + + + + +(defmethod allocate-instance ((b built-in-class) &rest initargs) + (declare (ignore initargs)) + (error "Can't allocate instances of BUILT-IN-CLASS.")) + +(defmethod reinitialize-instance ((m method) &rest initargs) + (declare (ignore initargs)) + (error "Can't reinitialze ~s ~s" (class-of m) m)) + +(defmethod add-dependent ((class class) dependent) + (pushnew dependent (%class.dependents class))) + +(defmethod add-dependent ((gf standard-generic-function) dependent) + (pushnew dependent (sgf.dependents gf))) + +(defmethod remove-dependent ((class class) dependent) + (setf (%class.dependents class) + (delete dependent (%class.dependents class)))) + +(defmethod remove-dependent ((gf standard-generic-function) dependent) + (setf (sgf.dependents gf) + (delete dependent (sgf.dependents gf)))) + +(defmethod map-dependents ((class class) function) + (dolist (d (%class.dependents class)) + (funcall function d))) + +(defmethod map-dependents ((gf standard-generic-function) function) + (dolist (d (sgf.dependents gf)) + (funcall function d))) + +(defgeneric update-dependent (metaobject dependent &rest initargs)) + +(defmethod reinitialize-instance :after ((class std-class) &rest initargs) + (map-dependents class #'(lambda (d) + (apply #'update-dependent class d initargs)))) + + +(defun %allocate-gf-instance (class) + (unless (class-finalized-p class) + (finalize-inheritance class)) + (let* ((wrapper (%class.own-wrapper class)) + (gf-p (member *generic-function-class* (%class-cpl class))) + (len (length (%wrapper-instance-slots wrapper))) + (dt (if gf-p (make-gf-dispatch-table))) + (slots (allocate-typed-vector :slot-vector (1+ len) (%slot-unbound-marker))) + (fn + #+ppc-target + (gvector :function + *unset-fin-code* + wrapper + slots + dt + #'false + 0 + (logior (ash 1 $lfbits-gfn-bit) + (ash 1 $lfbits-aok-bit))) + #+x86-target + (%clone-x86-function #'unset-fin-trampoline + wrapper + slots + dt + #'false + 0 + (logior (ash 1 $lfbits-gfn-bit) + (ash 1 $lfbits-aok-bit))))) + (setf + (slot-vector.instance slots) fn) + (when dt + (setf (%gf-dispatch-table-gf dt) fn)) + (if gf-p + (push fn (population.data %all-gfs%))) + fn)) + + +(defmethod slot-value-using-class ((class structure-class) + instance + (slotd structure-effective-slot-definition)) + (let* ((loc (standard-effective-slot-definition.location slotd))) + (typecase loc + (fixnum + (struct-ref instance loc)) + (t + (error "Slot definition ~s has invalid location ~s (allocation ~s)." + slotd loc (slot-definition-allocation slotd)))))) + +;;; Some STRUCTURE-CLASS leftovers. +(defmethod (setf slot-value-using-class) + (new + (class structure-class) + instance + (slotd structure-effective-slot-definition)) + (let* ((loc (standard-effective-slot-definition.location slotd)) + (type (standard-effective-slot-definition.type slotd))) + (if (and type (not (eq type t))) + (unless (or (eq new (%slot-unbound-marker)) + (typep new type)) + (setq new (require-type new type)))) + (typecase loc + (fixnum + (setf (struct-ref instance loc) new)) + (t + (error "Slot definition ~s has invalid location ~s (allocation ~s)." + slotd loc (slot-definition-allocation slotd)))))) + +(defmethod slot-boundp-using-class ((class structure-class) + instance + (slotd structure-effective-slot-definition)) + (declare (ignore instance)) + t) + +;;; This has to be somewhere, so it might as well be here. +(defmethod make-load-form ((s slot-id) &optional env) + (declare (ignore env)) + `(ensure-slot-id ,(slot-id.name s))) + +(defmethod make-load-form ((c class-cell) &optional env) + (declare (ignore env)) + `(find-class-cell ',(class-cell-name c) t)) + + + +(defmethod (setf class-name) (new (class class)) + (check-type new symbol) + (when (and (standard-instance-p class) + (%class-kernel-p class) + (not (eq new (%class.name class))) + *warn-if-redefine-kernel*) + (cerror "Change the name of ~s to ~s." + "The class ~s may be a critical part of the system; +changing its name to ~s may have serious consequences." class new)) + (let* ((old-name (class-name class))) + (if (eq (find-class old-name nil) class) + (progn + (setf (info-type-kind old-name) nil) + (clear-type-cache)))) + (when (eq (find-class new nil) class) + (when (%deftype-expander new) + (cerror "Change the name of ~S anyway, removing the DEFTYPE definition." + "Changing the name of ~S to ~S would conflict with the type defined by DEFTYPE." + class new) + (%deftype new nil nil)) + (setf (info-type-kind new) :instance) + (clear-type-cache)) + (reinitialize-instance class :name new) + (setf (%class-proper-name class) + (if (eq (find-class new nil) class) + new)) + new) + + +;;; From Tim Moore, as part of a set of patches to support funcallable +;;; instances. + +;;; Support for objects with metaclass funcallable-instance-class that are not +;;; standard-generic-function. The objects still look a lot like generic +;;; functions, complete with vestigial dispatch +;;; tables. set-funcallable-instance-function will work on generic functions, +;;; though after that it won't be much of a generic function. + + + + + +(defun set-funcallable-instance-function (funcallable-instance function) + (unless (typep funcallable-instance 'funcallable-standard-object) + (error "~S is not a funcallable instance" funcallable-instance)) + (unless (functionp function) + (error "~S is not a function" function)) + (setf (%gf-dcode funcallable-instance) function)) + +(defmethod reinitialize-instance ((slotd slot-definition) &key &allow-other-keys) + (error "Can't reinitialize ~s" slotd)) + +(defmethod (setf generic-function-name) (new-name (gf generic-function)) + (reinitialize-instance gf :name new-name)) + +;;; Are we CLOS yet ? + +(defun %shared-initialize (instance slot-names initargs) + (unless (or (listp slot-names) (eq slot-names t)) + (report-bad-arg slot-names '(or list (eql t)))) + ;; Check that initargs contains valid key/value pairs, + ;; signal a PROGRAM-ERROR otherwise. (Yes, this is + ;; an obscure way to do so.) + (destructuring-bind (&key &allow-other-keys) initargs) + ;; I'm not sure if there's a more portable way of detecting + ;; obsolete instances. This'll eventually call + ;; UPDATE-INSTANCE-FOR-REDEFINED-CLASS if it needs to. + (let* ((wrapper (if (eq (typecode instance) target::subtag-instance) + (instance.class-wrapper instance) + (instance-class-wrapper instance))) + (class (%wrapper-class wrapper))) + (when (eql 0 (%wrapper-hash-index wrapper)) ; obsolete + (update-obsolete-instance instance)) + ;; Now loop over all of the class's effective slot definitions. + (dolist (slotd (class-slots class)) + ;; Anything that inherits from STANDARD-EFFECTIVE-SLOT-DEFINITION + ;; in Clozure CL will have a CCL::TYPE-PREDICATE slot. It's not + ;; well-defined to inherit from EFFECTIVE-SLOT-DEFINITION without + ;; also inheriting from STANDARD-EFFECTIVE-SLOT-DEFINITION, + ;; and I'd rather not check here. If you really want to + ;; create that kind of slot definition, write your own SHARED-INITIALIZE + ;; method for classes that use such slot definitions ... + (let* ((predicate (slot-definition-predicate slotd))) + (multiple-value-bind (ignore new-value foundp) + (get-properties initargs (slot-definition-initargs slotd)) + (declare (ignore ignore)) + (cond (foundp + ;; an initarg for the slot was passed to this function + ;; Typecheck the new-value, then call + ;; (SETF SLOT-VALUE-USING-CLASS) + (unless (or (null predicate) + (funcall predicate new-value)) + (error 'bad-slot-type-from-initarg + :slot-definition slotd + :instance instance + :datum new-value + :expected-type (slot-definition-type slotd) + :initarg-name (car foundp))) + (setf (slot-value-using-class class instance slotd) new-value)) + ((and (or (eq slot-names t) + (member (slot-definition-name slotd) + slot-names + :test #'eq)) + (not (slot-boundp-using-class class instance slotd))) + ;; If the slot name is among the specified slot names, or + ;; we're reinitializing all slots, and the slot is currently + ;; unbound in the instance, set the slot's value based + ;; on the initfunction (which captures the :INITFORM). + (let* ((initfunction (slot-definition-initfunction slotd))) + (if initfunction + (let* ((newval (funcall initfunction))) + (unless (or (null predicate) + (funcall predicate newval)) + (error 'bad-slot-type-from-initform + :slot-definition slotd + :expected-type (slot-definition-type slotd) + :datum newval + :instance instance)) + (setf (slot-value-using-class class instance slotd) + newval)))))))))) + instance) + +(defmethod shared-initialize ((struct structure-object) slot-names &rest initargs) + (unless (eq slot-names t) + (error "Structure instance ~s can't be reinitialized." struct)) + (dolist (slotd (class-slots (class-cell-class (car (%svref struct 0))))) + (let* ((predicate (slot-definition-predicate slotd)) + (location (slot-definition-location slotd))) + (declare (fixnum location)) + (multiple-value-bind (ignore new-value foundp) + (get-properties initargs (slot-definition-initargs slotd)) + (declare (ignore ignore)) + (cond (foundp + ;; an initarg for the slot was passed to this function + ;; Typecheck the new-value, then call + ;; (SETF SLOT-VALUE-USING-CLASS) + (unless (or (null predicate) + (funcall predicate new-value)) + (error 'bad-slot-type-from-initarg + :slot-definition slotd + :instance struct + :datum new-value + :expected-type (slot-definition-type slotd) + :initarg-name (car foundp))) + (setf (struct-ref struct location) new-value)) + (t + ;; If the slot name is among the specified slot names, or + ;; we're reinitializing all slots, and the slot is currently + ;; unbound in the instance, set the slot's value based + ;; on the initfunction (which captures the :INITFORM). + (let* ((initfunction (slot-definition-initfunction slotd))) + (if initfunction + (let* ((newval (funcall initfunction))) + (unless (or (null predicate) + (funcall predicate newval)) + (error 'bad-slot-type-from-initform + :slot-definition slotd + :expected-type (slot-definition-type slotd) + :datum newval + :instance struct)) + (setf (struct-ref struct location) newval))))))))) + struct) + +(defmethod initialize-instance ((struct structure-object) &rest initargs &key &allow-other-keys) + (declare (dynamic-extent initargs)) + (apply #'shared-initialize struct t initargs)) + +(defmethod make-instance ((class structure-class) &rest initargs &key &allow-other-keys) + (declare (dynamic-extent initargs)) + (let* ((struct (apply #'allocate-instance class initargs))) + (apply #'initialize-instance struct initargs))) + + + +;;; Sometimes you can do a lot better at generic function dispatch than the +;;; default. This supports that for the one-arg-dcode case. +(defmethod override-one-method-one-arg-dcode ((generic-function t) (method t)) + nil) + +(defun optimize-generic-function-dispatching () + (dolist (gf (population.data %all-gfs%)) + (optimize-dispatching-for-gf gf))) + +(defun optimize-dispatching-for-gf (gf) + (let* ((dcode (%gf-dcode gf)) + (name (function-name dcode))) + (when (or (eq name '%%one-arg-dcode) + (eq name '%%nth-arg-dcode)) + (let ((methods (generic-function-methods gf))) + (when (and methods (null (cdr methods))) + (when (or (eq #'%%one-arg-dcode dcode) + (and (eq #'%%nth-arg-dcode dcode) + (let ((spec (method-specializers (car methods))) + (argnum (%gf-dispatch-table-argnum + (%gf-dispatch-table gf)))) + (and (eql 2 (length spec)) + (and (eql argnum 1) (eq (car spec) *t-class*)))))) + (override-one-method-one-arg-dcode gf (car methods)))))))) + +(defparameter *unique-reader-dcode-functions* t) + +;;; dcode for a GF with a single reader method which accesses +;;; a slot in a class that has no subclasses (that restriction +;;; makes typechecking simpler and also ensures that the slot's +;;; location is correct.) +(defun singleton-reader-dcode (dt instance) + (declare (optimize (speed 3) (safety 0))) + (let* ((wrapper (%svref dt %gf-dispatch-table-first-data)) + (location (%svref dt (1+ %gf-dispatch-table-first-data)))) + (if (eq (if (eq (typecode instance) target::subtag-instance) + (instance.class-wrapper instance)) + wrapper) + (%slot-ref (instance.slots instance) location) + (cond ((and (eq (typecode instance) target::subtag-instance) + (eq 0 (%wrapper-hash-index (instance.class-wrapper instance))) + (progn (update-obsolete-instance instance) + (eq (instance.class-wrapper instance) wrapper))) + (%slot-ref (instance.slots instance) location)) + (t (no-applicable-method (%gf-dispatch-table-gf dt) instance)))))) +(register-dcode-proto #'singleton-reader-dcode *gf-proto-one-arg*) + +;;; Dcode for a GF whose methods are all reader-methods which access a +;;; slot in one or more classes which have multiple subclasses, all of +;;; which (by luck or design) have the same slot-definition location. +(defun reader-constant-location-dcode (dt instance) + (declare (optimize (speed 3) (safety 0))) + (if (memq (if (eq (typecode instance) target::subtag-instance) + (%class-of-instance instance)) + (%svref dt %gf-dispatch-table-first-data)) + (%slot-ref (instance.slots instance) (%svref dt (1+ %gf-dispatch-table-first-data))) + (no-applicable-method (%gf-dispatch-table-gf dt) instance))) +(register-dcode-proto #'reader-constant-location-dcode *gf-proto-one-arg*) + +;;; Dcode for a GF whose methods are all reader-methods which access a +;;; slot in one or more classes which have multiple subclasses, all of +;;; which (by luck or design) have the same slot-definition location. +;;; The number of classes for which the method is applicable is +;;; potentially large, but all are subclasses of a single class +(defun reader-constant-location-inherited-from-single-class-dcode (dt instance) + (declare (optimize (speed 3) (safety 0))) + (let* ((defining-class-ordinal (%svref dt %gf-dispatch-table-first-data)) + (bits (let* ((wrapper + (if (eq (typecode instance) target::subtag-instance) + (instance.class-wrapper instance)))) + (when wrapper (or (%wrapper-cpl-bits wrapper) + (make-cpl-bits (%inited-class-cpl + (%wrapper-class wrapper)))))))) + (declare (fixnum defining-class-ordinal)) + (if (and bits + (< defining-class-ordinal (the fixnum (uvsize bits))) + (not (eql 0 (sbit bits defining-class-ordinal)))) + (%slot-ref (instance.slots instance) (%svref dt (1+ %gf-dispatch-table-first-data))) + (no-applicable-method (%gf-dispatch-table-gf dt) instance)))) +(register-dcode-proto #'reader-constant-location-inherited-from-single-class-dcode *gf-proto-one-arg*) + +;;; It may be faster to make individual functions that take their +;;; "parameters" (defining class ordinal, slot location) as constants. +;;; It may not be. Use *unique-reader-dcode-functions* to decide +;;; whether or not to do so. +(defun make-reader-constant-location-inherited-from-single-class-dcode + (defining-class-ordinal location gf) + (if *unique-reader-dcode-functions* + (let* ((gf-name (function-name gf))) + (values + (%make-function + `(slot-reader for ,gf-name) + `(lambda (instance) + (locally (declare (optimize (speed 3) (safety 0))) + (let* ((bits (let* ((wrapper + (if (eq (typecode instance) target::subtag-instance) + (instance.class-wrapper instance)))) + (when wrapper (or (%wrapper-cpl-bits wrapper) + (make-cpl-bits (%inited-class-cpl + (%wrapper-class wrapper)))))))) + (if (and bits + (< ,defining-class-ordinal (the fixnum (uvsize bits))) + (not (eql 0 (sbit bits ,defining-class-ordinal)))) + (%slot-ref (instance.slots instance) ,location) + (no-applicable-method (function ,gf-name) instance))))) + nil) + #'funcallable-trampoline)) + (let* ((dt (gf.dispatch-table gf))) + (setf (%svref dt %gf-dispatch-table-first-data) + defining-class-ordinal + (%svref dt (1+ %gf-dispatch-table-first-data)) + location) + (values + (dcode-for-gf gf #'reader-constant-location-inherited-from-single-class-dcode) + (cdr (assq #'reader-constant-location-inherited-from-single-class-dcode dcode-proto-alist)))))) + +;;; Dcode for a GF whose methods are all reader-methods which access a +;;; slot in one or more classes which have multiple subclasses, all of +;;; which (by luck or design) have the same slot-definition location. +;;; The number of classes is for which the method is applicable is +;;; large, but all are subclasses of one of a (small) set of defining classes. +(defun reader-constant-location-inherited-from-multiple-classes-dcode (dt instance) + (declare (optimize (speed 3) (safety 0))) + (let* ((wrapper (if (eq (typecode instance) target::subtag-instance) + (instance.class-wrapper instance))) + (bits (if wrapper (or (%wrapper-cpl-bits wrapper) + (make-cpl-bits (%inited-class-cpl (%wrapper-class wrapper)))))) + (nbits (if bits (uvsize bits) 0))) + (declare (fixnum nbits)) + (if (dolist (ordinal (%svref dt %gf-dispatch-table-first-data)) + (declare (fixnum ordinal)) + (when (and (< ordinal nbits) + (not (eql 0 (sbit bits ordinal)))) + (return t))) + (%slot-ref (instance.slots instance) (%svref dt (1+ %gf-dispatch-table-first-data))) + (no-applicable-method (%gf-dispatch-table-gf dt) instance)))) +(register-dcode-proto #'reader-constant-location-inherited-from-multiple-classes-dcode *gf-proto-one-arg*) + + +;;; Similar to the case above, but we use an alist to map classes +;;; to their non-constant locations. +(defun reader-variable-location-dcode (dt instance) + (declare (optimize (speed 3) (safety 0))) + (let* ((alist (%svref dt %gf-dispatch-table-first-data)) + (location (cdr + (assq + (if (eq (typecode instance) target::subtag-instance) + (%class-of-instance instance)) + alist)))) + (if location + (%slot-ref (instance.slots instance) location) + (no-applicable-method (%gf-dispatch-table-gf dt) instance)))) +(register-dcode-proto #'reader-variable-location-dcode *gf-proto-one-arg*) + +(defun class-and-slot-location-alist (classes slot-name) + (let* ((alist nil)) + (labels ((add-class (c) + (unless (assq c alist) + (let* ((slots (class-slots c))) + (unless slots + (finalize-inheritance c) + (setq slots (class-slots c))) + (push (cons c (slot-definition-location (find-slotd slot-name slots))) alist)) + (dolist (sub (class-direct-subclasses c)) + (add-class sub))))) + (dolist (class classes) (add-class class)) + ;; Building the alist the way that we have should often approximate + ;; this ordering; the idea is that leaf classes are more likely to + ;; be instantiated than non-leaves. + (sort alist (lambda (c1 c2) + (< (length (class-direct-subclasses c1)) + (length (class-direct-subclasses c2)))) + :key #'car)))) + +;;; Return a list of all classes in CLASS-LIST that aren't subclasses +;;; of any other class in the list. +(defun remove-subclasses-from-class-list (class-list) + (if (null (cdr class-list)) + class-list + (collect ((unique)) + (dolist (class class-list (unique)) + (when (dolist (other class-list t) + (unless (eq class other) + (when (subtypep class other) (return nil)))) + (unique class)))))) + + +;;; Try to replace gf dispatch with something faster in f. +(defun %snap-reader-method (f &key (redefinable t)) + (when (slot-boundp f 'methods) + (let* ((methods (generic-function-methods f))) + (when (and methods + (every (lambda (m) (eq (class-of m) *standard-reader-method-class*)) methods) + (every (lambda (m) (subtypep (class-of (car (method-specializers m))) *standard-class-class*)) methods) + (every (lambda (m) (null (method-qualifiers m))) methods)) + (let* ((m0 (car methods)) + (name (slot-definition-name (accessor-method-slot-definition m0)))) + (when (every (lambda (m) + (eq name (slot-definition-name (accessor-method-slot-definition m)))) + (cdr methods)) + ;; All methods are *STANDARD-READER-METHODS* that + ;; access the same slot name. Build an alist of + ;; mapping all subclasses of all classes on which those + ;; methods are specialized to the effective slot's + ;; location in that subclass. + (let* ((classes (mapcar #'(lambda (m) (car (method-specializers m))) + methods)) + (alist (class-and-slot-location-alist classes name)) + (loc (cdar alist)) + (dt (gf.dispatch-table f))) + ;; Only try to handle the case where all slots have + ;; :allocation :instance (and all locations - the CDRs + ;; of the alist pairs - are small, positive fixnums. + (when (every (lambda (pair) (typep (cdr pair) 'fixnum)) alist) + (when redefinable + (loop for (c . nil) in alist + do (note-class-dependent c f))) + (clear-gf-dispatch-table dt) + (setf (%gf-dispatch-table-argnum dt) -1) ;mark as non-standard + (cond ((null (cdr alist)) + ;; Method is only applicable to a single class. + (destructuring-bind (class . location) (car alist) + (setf (%svref dt %gf-dispatch-table-first-data) (%class.own-wrapper class) + (%svref dt (1+ %gf-dispatch-table-first-data)) location + (gf.dcode f) (dcode-for-gf f #'singleton-reader-dcode)))) + ((dolist (other (cdr alist) t) + (unless (eq (cdr other) loc) + (return))) + ;; All classes have the slot in the same location, + ;; by luck or design. + (cond + ((< (length alist) 10) + ;; Only a small number of classes, just do MEMQ + (setf (%svref dt %gf-dispatch-table-first-data) + (mapcar #'car alist) + (%svref dt (1+ %gf-dispatch-table-first-data)) + loc + (gf.dcode f) (dcode-for-gf f #'reader-constant-location-dcode))) + ((null (cdr (setq classes (remove-subclasses-from-class-list classes)))) + ;; Lots of classes, all subclasses of a single class + (multiple-value-bind (dcode trampoline) + (make-reader-constant-location-inherited-from-single-class-dcode (%class-ordinal (car classes)) loc f) + (setf (gf.dcode f) dcode) + (replace-function-code f trampoline))) + (t + ;; Multple classes. We should probably check + ;; to see they're disjoint + (setf (%svref dt %gf-dispatch-table-first-data) + (mapcar #'%class-ordinal classes) + (%svref dt (1+ %gf-dispatch-table-first-data)) + loc + (gf.dcode f) + (dcode-for-gf f #'reader-constant-location-inherited-from-multiple-classes-dcode))))) + (t + ;; Multiple classes; the slot's location varies. + (setf (%svref dt %gf-dispatch-table-first-data) + alist + + (gf.dcode f) (dcode-for-gf f #'reader-variable-location-dcode)))))))))))) + +;;; Hack-o-rama: GF has nothing but primary methods, first (and only non-T) +;;; specializers are all EQL specializers whose objects are symbols. +;;; The effective method applicable for each symbol is stored on the +;;; plist of the symbol under a property EQ to the dispatch table (which +;;; is mostly ignored, otherwise.) +(defun %%1st-arg-eql-method-hack-dcode (dt args) + (let* ((sym (if (listp args) (car args)(%lexpr-ref args (%lexpr-count args) 0))) + (mf (if (symbolp sym) (get sym dt)))) + (if mf + (if (listp args) + (apply mf args) + (%apply-lexpr-tail-wise mf args)) + ;;; Let %%1st-arg-dcode deal with it. + (%%1st-arg-dcode dt args)))) +(register-dcode-proto #'%%1st-arg-eql-method-hack-dcode *gf-proto*) + +(defun %%1st-two-arg-eql-method-hack-dcode (dt arg1 arg2) + (let* ((mf (if (typep arg1 'symbol) (get arg1 dt)))) + (if mf + (funcall mf arg1 arg2) + (%%1st-two-arg-dcode dt arg1 arg2)))) +(register-dcode-proto #'%%1st-two-arg-eql-method-hack-dcode *gf-proto-two-arg*) + +(defun %%one-arg-eql-method-hack-dcode (dt arg) + (let* ((mf (if (typep arg 'symbol) (get arg dt)))) + (if mf + (funcall mf arg)))) +(register-dcode-proto #'%%one-arg-eql-method-hack-dcode *gf-proto-one-arg*) + +(defun install-eql-method-hack-dcode (gf) + (let* ((bits (inner-lfun-bits gf)) + (nreq (ldb $lfbits-numreq bits)) + (other-args? (or (not (eql 0 (ldb $lfbits-numopt bits))) + (logbitp $lfbits-rest-bit bits) + (logbitp $lfbits-restv-bit bits) + (logbitp $lfbits-keys-bit bits) + (logbitp $lfbits-aok-bit bits)))) + (setf (%gf-dcode gf) + (dcode-for-gf gf + (cond ((and (eql nreq 1) (null other-args?)) + #'%%one-arg-eql-method-hack-dcode) + ((and (eql nreq 2) (null other-args?)) + #'%%1st-two-arg-eql-method-hack-dcode) + (t + #'%%1st-arg-eql-method-hack-dcode)))))) + +(defun maybe-hack-eql-methods (gf) + (let* ((methods (generic-function-methods gf))) + (when (and methods + (every #'(lambda (method) + (let* ((specializers (method-specializers method)) + (first (car specializers))) + (and (typep first 'eql-specializer) + (typep (eql-specializer-object first) 'symbol) + (dolist (s (cdr specializers) t) + (unless (eq s *t-class*) + (return nil))) + (null (cdr (compute-applicable-methods gf (cons (eql-specializer-object first) (make-list (length (cdr specializers)))))))))) + methods)) + (let* ((dt (%gf-dispatch-table gf))) + (dolist (m methods) + (let* ((sym (eql-specializer-object (car (method-specializers m)))) + (f (method-function m))) + (setf (get sym dt) f))) + (install-eql-method-hack-dcode gf) + t)))) + + + + +;;; Return a list of :after methods for INITIALIZE-INSTANCE on the +;;; class's prototype, and a boolean that's true if no other qualified +;;; methods are defined and at most one primary one. +(defun initialize-instance-after-methods (proto class) + (let* ((method-list (compute-method-list (sort-methods + (compute-applicable-methods #'initialize-instance (list proto)) + (list (class-precedence-list class)))))) + (if (atom method-list) + (values nil t) + (if (and (null (car method-list)) + (null (cdddr method-list))) + (values (cadr method-list) t) + ;; :around or :before methods, or more than one primary method, give up + (values nil nil))))) + +(defparameter *typecheck-slots-in-optimized-make-instance* t) + + +;;; Return a lambda form or NIL. +(defun make-instantiate-lambda-for-class-cell (cell) + (let* ((class (class-cell-class cell)) + (after-methods nil)) + (when (and (typep class 'standard-class) + (progn (unless (class-finalized-p class) + (finalize-inheritance class)) + t) + (null (cdr (compute-applicable-methods #'allocate-instance (list class)))) + (let* ((proto (class-prototype class))) + (and (multiple-value-bind (afters ok) + (initialize-instance-after-methods proto class) + (when ok + (setq after-methods afters) + t)) + (null (cdr (compute-applicable-methods #'shared-initialize (list proto t))))))) + (let* ((slotds (sort (copy-list (class-slots class)) + #'(lambda (x y) + (if (consp x) x (if (consp y) y (< x y)))) + :key #'slot-definition-location)) + (default-initargs (class-default-initargs class))) + (collect ((keys) + (binds) + (class-binds) + (ignorable) + (class-slot-inits) + (after-method-forms) + (forms)) + (flet ((generate-type-check (form type &optional spvar) + (if (or (null *typecheck-slots-in-optimized-make-instance*) + (eq type t) + (and (quoted-form-p type) (eq (cadr type) t))) + form + (if spvar + `(if ,spvar + (require-type ,form ',type) + ,form) + `(require-type ,form ',type))))) + (dolist (slot slotds) + (let* ((initargs (slot-definition-initargs slot)) + (initfunction (slot-definition-initfunction slot)) + (initform (slot-definition-initform slot)) + (location (slot-definition-location slot)) + (location-var nil) + (class-init-p nil) + (one-initarg-p (null (cdr initargs))) + (name (slot-definition-name slot)) + (type (slot-definition-type slot))) + (when (consp location) + (setq location-var (gensym "LOCATION"))) + (when initfunction + (setq initform + (if (self-evaluating-p initform) + initform + `(funcall ,initfunction)))) + (cond ((null initargs) + (let ((initial-value-form + (if initfunction + (generate-type-check initform type) + `(%slot-unbound-marker)))) + (if location-var + (when initfunction + (setq class-init-p t) + (class-slot-inits + `(when (eq (%slot-unbound-marker) (cdr ,location-var)) + (setf (cdr ,location-var) ,initial-value-form)))) + (forms initial-value-form)))) + (t (collect ((cond-clauses)) + (let ((last-cond-clause nil)) + (dolist (initarg initargs) + (let* ((spvar nil) + (name (if one-initarg-p + name + (gensym (string name)))) + (initial-value-form + (if (and initfunction + one-initarg-p + (null location-var)) + initform + (progn + (when initarg + (setq spvar (make-symbol + (concatenate + 'string + (string initarg) + "-P")))) + (and one-initarg-p + (null location-var) + (if initfunction + initform + `(%slot-unbound-marker)))))) + (default (assq initarg default-initargs)) + (default-value-form nil)) + (when spvar (ignorable spvar)) + (when default + (destructuring-bind (form function) + (cdr default) + (setq default-value-form + (if (or (quoted-form-p form) + (self-evaluating-p form)) + form + `(funcall ,function))))) + (keys (list* + (list initarg name) + (if (and default one-initarg-p (null location-var)) + default-value-form + initial-value-form) + (if spvar (list spvar)))) + (if one-initarg-p + (if location-var + (progn + (setq class-init-p t) + (class-slot-inits + `(if ,spvar + (setf (cdr ,location-var) + ,(generate-type-check + name type)) + ,(if default + `(setf (cdr ,location-var) + ,(generate-type-check + default type)) + (when initfunction + `(when (eq (%slot-unbound-marker) + (cdr ,location-var)) + (setf (cdr ,location-var) + ,(generate-type-check + initform type)))))))) + (forms `,(generate-type-check name type spvar))) + (progn (cond-clauses `(,spvar ,name)) + (when (and default (null last-cond-clause)) + (setq last-cond-clause + `(t ,default))))))) + (when (cond-clauses) + (when last-cond-clause + (cond-clauses last-cond-clause)) + (cond ((null location-var) + (unless last-cond-clause + (cond-clauses `(t ,initform))) + (forms (generate-type-check + `(cond ,@(cond-clauses)) + type))) + (t + (let ((initform-p-var + (unless last-cond-clause + (make-symbol "INITFORM-P"))) + (value-var (make-symbol "VALUE"))) + (unless last-cond-clause + (cond-clauses + `(t (setq ,initform-p-var t) + ,(if initfunction + initform + `(%slot-unbound-marker))))) + (setq class-init-p t) + (class-slot-inits + `(let* (,@(and initform-p-var + (list `(,initform-p-var nil))) + (,value-var + ,(generate-type-check + `(cond ,@(cond-clauses)) type))) + (when + ,(if initform-p-var + `(or (null ,initform-p-var) + (and (eq (cdr ,location-var) + (%slot-unbound-marker)) + (not (eq ,value-var + (%slot-unbound-marker))))) + t) + (setf (cdr ,location-var) ,value-var)))))))))))) + (when class-init-p + (class-binds `(,location-var + (load-time-value + (slot-definition-location ',slot)))))))) + (let* ((cell (make-symbol "CLASS-CELL")) + (args (make-symbol "ARGS")) + (slots (make-symbol "SLOTS")) + (instance (make-symbol "INSTANCE"))) + (dolist (after after-methods) + (after-method-forms `(apply ,(method-function after) ,instance ,args))) + (when after-methods + (after-method-forms instance)) + (binds `(,slots (gvector :slot-vector nil ,@(forms)))) + (binds `(,instance (gvector :instance 0 (class-cell-extra ,cell) ,slots))) + `(lambda (,cell ,@(when after-methods `(&rest ,args)) &key ,@(keys) ,@(when after-methods '(&allow-other-keys))) + (declare (ignorable ,@(ignorable))) + ,@(when after-methods `((declare (dynamic-extent ,args)))) + (let (,@(class-binds)) + ,@(class-slot-inits)) + (let* (,@(binds)) + (setf (instance.hash ,instance) (strip-tag-to-fixnum ,instance) + (%svref ,slots 0) ,instance) + ,@(after-method-forms))))))))) + +(defun optimize-make-instance-for-class-cell (cell) + (init-class-cell-instantiator cell) + (let* ((lambda (make-instantiate-lambda-for-class-cell cell))) + (when lambda + (setf (class-cell-instantiate cell) (compile nil lambda) + (class-cell-extra cell) (%class.own-wrapper + (class-cell-class cell))) + t))) + +(defun optimize-make-instance-for-class-name (class-name) + (optimize-make-instance-for-class-cell (find-class-cell class-name t))) + +(defun optimize-named-class-make-instance-methods () + (maphash (lambda (class-name class-cell) + (handler-case (optimize-make-instance-for-class-cell class-cell) + (error (c) + (warn "error optimizing make-instance for ~s:~&~a" + class-name c)))) + %find-classes%)) + +;; Redefined from bootstrapping verison in l1-clos-boot.lisp +;; Remove the make-instance optimization if the user is adding +;; a method on initialize-instance, allocate-instance, or shared-initialize +(defun maybe-remove-make-instance-optimization (gfn method) + (when (or (eq gfn #'allocate-instance) + (eq gfn #'initialize-instance) + (eq gfn #'shared-initialize)) + (let ((specializer (car (method-specializers method)))) + (when (typep specializer 'class) + (labels ((clear (class) + (pessimize-make-instance-for-class-name (class-name class)) + (dolist (sub (%class-direct-subclasses class)) + (clear sub)))) + (clear specializer)))))) + +;;; Iterate over all known GFs; try to optimize their dcode in cases +;;; involving reader methods. + +(defun snap-reader-methods (&key known-sealed-world + (check-conflicts t) + (optimize-make-instance t)) + (declare (ignore check-conflicts) + (ignore known-sealed-world)) + (when optimize-make-instance + (optimize-named-class-make-instance-methods)) + (let* ((ngf 0) + (nwin 0)) + (dolist (f (population.data %all-gfs%)) + (incf ngf) + (when (%snap-reader-method f) + (incf nwin))) + (values ngf nwin 0))) + +(defun register-non-dt-dcode-function (f) + (flet ((symbol-or-function-name (x) + (etypecase x + (symbol x) + (function (function-name x))))) + (let* ((already (member (symbol-or-function-name f) *non-dt-dcode-functions* :key #'symbol-or-function-name))) + (if already + (setf (car already) f) + (push f *non-dt-dcode-functions*)) + f))) + +(defun pessimize-clos () + ;; Undo MAKE-INSTANCE optimization + (maphash (lambda (class-name class-cell) + (declare (ignore class-name)) + (init-class-cell-instantiator class-cell)) + %find-classes%) + ;; Un-snap reader methods, undo other GF optimizations. + (dolist (f (population-data %all-gfs%)) + (let* ((dt (%gf-dispatch-table f))) + (clear-gf-dispatch-table dt) + (compute-dcode f)))) + +;;; If there's a single method (with standard method combination) on +;;; GF and all of that method's arguments are specialized to the T +;;; class - and if the method doesn't accept &key or do any +;;; next-method things - we can just have the generic function call +;;; the method-function +(defun dcode-for-universally-applicable-singleton (gf) + (when (eq (generic-function-method-combination gf) + *standard-method-combination*) + (let* ((methods (generic-function-methods gf)) + (method (car methods))) + (when (and method + (null (cdr methods)) + (null (method-qualifiers method)) + (not (logtest (logior (ash 1 $lfbits-keys-bit) + (ash 1 $lfbits-nextmeth-bit)) + (lfun-bits (method-function method)))) + (dolist (spec (method-specializers method) t) + (unless (eq spec *t-class*) + (return nil)))) + (method-function method))))) + +(register-non-dt-dcode-function #'dcode-for-universally-applicable-singleton) Index: /branches/new-random/level-1/l1-dcode.lisp =================================================================== --- /branches/new-random/level-1/l1-dcode.lisp (revision 13309) +++ /branches/new-random/level-1/l1-dcode.lisp (revision 13309) @@ -0,0 +1,1962 @@ +;;;-*-Mode: LISP; Package: CCL -*- +;;; +;;; Copyright (C) 2009 Clozure Associates +;;; Copyright (C) 1994-2001 Digitool, Inc +;;; This file is part of Clozure CL. +;;; +;;; Clozure CL is licensed under the terms of the Lisp Lesser GNU Public +;;; License , known as the LLGPL and distributed with Clozure CL as the +;;; file "LICENSE". The LLGPL consists of a preamble and the LGPL, +;;; which is distributed with Clozure CL as the file "LGPL". Where these +;;; conflict, the preamble takes precedence. +;;; +;;; Clozure CL is referenced in the preamble as the "LIBRARY." +;;; +;;; The LLGPL is also available online at +;;; http://opensource.franz.com/preamble.html + + +(in-package "CCL") + + + + + + +(defun %make-gf-instance (class &key + name + (method-combination *standard-method-combination* mcomb-p) + (method-class *standard-method-class* mclass-p) + declarations + (lambda-list nil ll-p) + (argument-precedence-order nil apo-p) + &allow-other-keys) + (when mcomb-p + (unless (typep method-combination 'method-combination) + (report-bad-arg method-combination 'method-combination))) + (when mclass-p + (if (symbolp method-class) + (setq method-class (find-class method-class))) + (unless (subtypep method-class *method-class*) + (error "~s is not a subtype of ~s." method-class *method-class*))) + (when declarations + (unless (list-length declarations) + (error "~s is not a proper list" declarations))) + ;; Fix APO, lambda-list + (if apo-p + (if (not ll-p) + (error "Cannot specify ~s without specifying ~s" :argument-precedence-order + :lambda-list))) + (let* ((gf (%allocate-gf-instance class))) + (setf (sgf.name gf) name + (sgf.method-combination gf) method-combination + (sgf.methods gf) nil + (sgf.method-class gf) method-class + (sgf.decls gf) declarations + (sgf.%lambda-list gf) :unspecified + (sgf.dependents gf) nil) + (when ll-p + (if apo-p + (set-gf-arg-info gf :lambda-list lambda-list + :argument-precedence-order argument-precedence-order) + (set-gf-arg-info gf :lambda-list lambda-list))) + gf)) + +(defun gf-arg-info-valid-p (gf) + (let* ((bits (lfun-bits gf))) + (declare (fixnum bits)) + (not (and (logbitp $lfbits-aok-bit bits) + (not (logbitp $lfbits-keys-bit bits)))))) + +;;; Derive a GF lambda list from the method's lambda list. +(defun flatten-method-lambda-list (lambda-list) + (collect ((ll)) + (dolist (x lambda-list (ll)) + (if (atom x) + (if (eq x '&aux) + (return (ll)) + (ll x)) + (ll (car x)))))) + +(defun %maybe-compute-gf-lambda-list (gf method) + (let* ((gf-ll (sgf.%lambda-list gf))) + (if (eq gf-ll :unspecified) + (and method + (let* ((method-lambda-list (%method-lambda-list method)) + (method-has-&key (member '&key method-lambda-list)) + (method-has-&allow-other-keys + (member '&allow-other-keys method-lambda-list))) + (if method-has-&key + (nconc (ldiff method-lambda-list (cdr method-has-&key)) + (if method-has-&allow-other-keys + '(&allow-other-keys))) + (flatten-method-lambda-list method-lambda-list)))) + gf-ll))) + + +;;; Borrowed from PCL, sort of. We can encode required/optional/restp/keyp +;;; information in the gf's lfun-bits +(defun set-gf-arg-info (gf &key new-method (lambda-list nil lambda-list-p) + (argument-precedence-order nil apo-p)) + (let* ((methods (%gf-methods gf)) + (dt (%gf-dispatch-table gf)) + (gf-lfun-bits (lfun-bits gf)) + (first-method-p (and new-method (null methods)))) + (declare (fixnum gf-lfun-bits)) + (unless lambda-list-p + (setq lambda-list + (%maybe-compute-gf-lambda-list gf (or (car (last methods)) + new-method)))) + (when (or lambda-list-p + (and first-method-p + (eq (%gf-%lambda-list gf) :unspecified))) + (multiple-value-bind (newbits keyvect) + (encode-lambda-list lambda-list t) + (declare (fixnum newbits)) + (when (and methods (not first-method-p)) + (unless (and (= (ldb $lfbits-numreq gf-lfun-bits) + (ldb $lfbits-numreq newbits)) + (= (ldb $lfbits-numopt gf-lfun-bits) + (ldb $lfbits-numopt newbits)) + (eq (or (logbitp $lfbits-keys-bit gf-lfun-bits) + (logbitp $lfbits-rest-bit gf-lfun-bits) + (logbitp $lfbits-restv-bit gf-lfun-bits)) + (or (logbitp $lfbits-keys-bit newbits) + (logbitp $lfbits-rest-bit newbits) + (logbitp $lfbits-restv-bit newbits)))) + (cerror (format nil + "Remove ~d method~:p from the generic-function and ~ + change its lambda list." + (length (%gf-methods gf))) + "New lambda list of generic function ~s is not congruent ~ + with lambda lists of existing methods.~%~ + Generic-function's : ~s~%~ + Method's lambda-list : ~s~%" + gf lambda-list (%method-lambda-list (car methods))) + (loop + (let ((methods (%gf-methods gf))) + (if methods + (remove-method gf (car methods)) + (return)))) + (%set-defgeneric-keys gf nil))) + (when lambda-list-p + (setf (%gf-%lambda-list gf) lambda-list + (%gf-dispatch-table-keyvect dt) keyvect)) + (when (and apo-p lambda-list-p) + (let* ((old-precedence-list (%gf-dispatch-table-precedence-list dt))) + (setf (%gf-dispatch-table-precedence-list dt) + (canonicalize-argument-precedence-order + argument-precedence-order + (required-lambda-list-args lambda-list))) + (unless (equal old-precedence-list + (%gf-dispatch-table-precedence-list dt)) + (clear-gf-dispatch-table dt)))) + (lfun-bits gf (logior (ash 1 $lfbits-gfn-bit) + (logand $lfbits-args-mask newbits))))) + (when new-method + (check-defmethod-congruency gf new-method)))) + +(defun %gf-name (gf &optional (new-name nil new-name-p)) + (let* ((old-name (%standard-generic-function-instance-location-access + gf sgf.name))) + (if new-name-p + (setf (sgf.name gf) new-name)) + (unless (eq old-name (%slot-unbound-marker)) + old-name))) + + + + +(defun make-n+1th-arg-combined-method (methods gf argnum) + (let ((table (make-gf-dispatch-table))) + (setf (%gf-dispatch-table-methods table) methods + (%gf-dispatch-table-argnum table) (%i+ 1 argnum)) + (let ((self (%cons-combined-method gf table #'%%nth-arg-dcode))) ; << + (setf (%gf-dispatch-table-gf table) self) + self))) + +;;; Bring the generic function to the smallest possible size by removing +;;; any cached recomputable info. Currently this means clearing out the +;;; combined methods from the dispatch table. + +(defun clear-gf-cache (gf) + #-bccl (unless t (typep gf 'standard-generic-function) + (report-bad-arg gf 'standard-generic-function)) + (let ((dt (%gf-dispatch-table gf))) + (if (eq (%gf-dispatch-table-size dt) *min-gf-dispatch-table-size*) + (clear-gf-dispatch-table dt) + (let ((new (make-gf-dispatch-table))) + (setf (%gf-dispatch-table-methods new) (%gf-dispatch-table-methods dt)) + (setf (%gf-dispatch-table-precedence-list new) + (%gf-dispatch-table-precedence-list dt)) + (setf (%gf-dispatch-table-gf new) gf) + (setf (%gf-dispatch-table-keyvect new) + (%gf-dispatch-table-keyvect dt)) + (setf (%gf-dispatch-table-argnum new) (%gf-dispatch-table-argnum dt)) + (setf (%gf-dispatch-table gf) new))))) + +(defun %gf-dispatch-table-store-conditional (dt index new) + "Returns T if the new value can be stored in DT at INDEX, replacing a NIL. + Returns NIL - without storing anything - if the value already in DT + at INDEX is non-NIL at the time of the store." + (let ((offset (+ (ash (%i+ index %gf-dispatch-table-first-data) + target::word-shift) + target::misc-data-offset))) + (or (%store-node-conditional offset dt nil new) + (%store-node-conditional offset dt *gf-dispatch-bug* new)))) + +(defun grow-gf-dispatch-table (gf-or-cm wrapper table-entry &optional obsolete-wrappers-p) + ;; Grow the table associated with gf and insert table-entry as the value for + ;; wrapper. Wrapper is a class-wrapper. Assumes that it is not obsolete. + (let* ((dt (if (generic-function-p gf-or-cm) + (%gf-dispatch-table gf-or-cm) + (%combined-method-methods gf-or-cm))) + (size (%gf-dispatch-table-size dt)) + (new-size (if obsolete-wrappers-p + size + (%i+ size size))) + new-dt) + (if (> new-size *max-gf-dispatch-table-size*) + (progn + (setq new-dt (clear-gf-dispatch-table dt) + *gf-dt-ovf-cnt* (%i+ *gf-dt-ovf-cnt* 1))) + (progn + (setq new-dt (make-gf-dispatch-table new-size)) + (setf (%gf-dispatch-table-methods new-dt) (%gf-dispatch-table-methods dt) + (%gf-dispatch-table-precedence-list new-dt) (%gf-dispatch-table-precedence-list dt) + (%gf-dispatch-table-keyvect new-dt) (%gf-dispatch-table-keyvect dt) + (%gf-dispatch-table-gf new-dt) gf-or-cm + (%gf-dispatch-table-argnum new-dt) (%gf-dispatch-table-argnum dt)) + (let ((i 0) index w cm) + (dotimes (j (%ilsr 1 (%gf-dispatch-table-size dt))) + (declare (fixnum j)) + (unless (or (null (setq w (%gf-dispatch-table-ref dt i))) + (eql 0 (%wrapper-hash-index w)) + (no-applicable-method-cm-p + (setq cm (%gf-dispatch-table-ref dt (%i+ i 1))))) + (setq index (find-gf-dispatch-table-index new-dt w t)) + (setf (%gf-dispatch-table-ref new-dt index) w) + (setf (%gf-dispatch-table-ref new-dt (%i+ index 1)) cm)) + (setq i (%i+ i 2)))))) + (let ((index (find-gf-dispatch-table-index new-dt wrapper t))) + (setf (%gf-dispatch-table-ref new-dt index) wrapper) + (setf (%gf-dispatch-table-ref new-dt (%i+ index 1)) table-entry)) + (if (generic-function-p gf-or-cm) + (setf (%gf-dispatch-table gf-or-cm) new-dt) + (setf (%combined-method-methods gf-or-cm) new-dt)))) + + +(defun inner-lfun-bits (function &optional value) + (lfun-bits (closure-function function) value)) + + + +;;; probably want to use alists vs. hash-tables initially + + +;;; only used if error - well not really +(defun collect-lexpr-args (args first &optional last) + (if (listp args) + (subseq args first (or last (length args))) + (let ((res nil)) + (when (not last)(setq last (%lexpr-count args))) + (dotimes (i (- last first)) + (setq res (push (%lexpr-ref args last (+ first i)) res))) + (nreverse res)))) + + + + +(defmacro with-list-from-lexpr ((list lexpr) &body body) + (let ((len (gensym))) + `(let* ((,len (%lexpr-count ,lexpr)) + (,list (make-list ,len))) + (declare (dynamic-extent ,list) (fixnum ,len)) + (do* ((i 0 (1+ i)) + (ls ,list (cdr ls))) + ((= i ,len) ,list) + (declare (fixnum i) (list ls)) + (declare (optimize (speed 3)(safety 0))) + (%rplaca ls (%lexpr-ref ,lexpr ,len i))) + ,@body))) + + + +(defmacro %standard-instance-p (i) + `(eq (typecode ,i) ,(type-keyword-code :instance))) + + + +(declaim (inline %find-1st-arg-combined-method)) +(declaim (inline %find-nth-arg-combined-method)) + + + + +(defun %find-1st-arg-combined-method (dt arg) + (let ((wrapper (instance-class-wrapper arg))) + (when (eql 0 (%wrapper-hash-index wrapper)) + (update-obsolete-instance arg) + (setq wrapper (instance-class-wrapper arg))) + (let* ((mask (%gf-dispatch-table-mask dt)) + (index (%ilsl 1 (%ilogand mask (%wrapper-hash-index wrapper)))) + table-wrapper flag) + (declare (fixnum index mask)) + (loop + (if (eq (setq table-wrapper (%gf-dispatch-table-ref dt index)) wrapper) + (return (%gf-dispatch-table-ref dt (the fixnum (1+ index)))) + (progn + (when (null (%gf-dispatch-table-ref dt (the fixnum (1+ index)))) + (if (or (neq table-wrapper (%unbound-marker)) + (eql 0 flag)) + (without-interrupts ; why? + (return (1st-arg-combined-method-trap (%gf-dispatch-table-gf dt) wrapper arg))) ; the only difference? + (setq flag 0 index -2))) + (setq index (+ 2 index)))))))) + +;;; for calls from outside - e.g. stream-reader +(defun find-1st-arg-combined-method (gf arg) + (declare (optimize (speed 3)(safety 0))) + (%find-1st-arg-combined-method (%gf-dispatch-table gf) arg)) + + +;;; more PC - it it possible one needs to go round more than once? - +;;; seems unlikely +(defun %find-nth-arg-combined-method (dt arg args) + (declare (optimize (speed 3)(safety 0))) + (let ((wrapper (instance-class-wrapper arg))) + (when (eql 0 (%wrapper-hash-index wrapper)) + (update-obsolete-instance arg) + (setq wrapper (instance-class-wrapper arg))) + (let* ((mask (%gf-dispatch-table-mask dt)) + (index (%ilsl 1 (%ilogand mask (%wrapper-hash-index wrapper)))) + table-wrapper flag) + (declare (fixnum index mask)) + (loop + (if (eq (setq table-wrapper (%gf-dispatch-table-ref dt index)) wrapper) + (return (%gf-dispatch-table-ref dt (the fixnum (1+ index)))) + (progn + (when (null (%gf-dispatch-table-ref dt (the fixnum (1+ index)))) + (if (or (neq table-wrapper (%unbound-marker)) + (eql 0 flag)) + (without-interrupts ; why? + (let ((gf (%gf-dispatch-table-gf dt))) + (if (listp args) + (return (nth-arg-combined-method-trap-0 gf dt wrapper args)) + (with-list-from-lexpr (args-list args) + (return (nth-arg-combined-method-trap-0 gf dt wrapper args-list)))))) + (setq flag 0 index -2))) + (setq index (+ 2 index)))))))) + + + + +;;;;;;;;;;;;;;;;;;;;;;;;;;; Generic functions and methods ;;;;;;;;;;;;;;;;;;;; +(defun %class-cpl (class) + (if (%standard-instance-p class) + (%class.cpl class) + (or + (and (typep class 'macptr) + (let* ((slots (foreign-slots-vector class))) + (and slots (%slot-ref slots %class.cpl)))) + (error "Can't determine CPL of class ~s" class)))) + + +(defun standard-method-p (thing) + (when (%standard-instance-p thing) + (let* ((cpl (%class-cpl (%wrapper-class (instance.class-wrapper thing)))) + (smc *standard-method-class*)) + (dolist (c cpl) + (if (eq c smc)(return t)))))) + + + +(defun %method-function-p (thing) + (when (functionp thing) + (let ((bits (lfun-bits thing))) + (declare (fixnum bits)) + (logbitp $lfbits-method-bit bits)))) + + + + +(setf (type-predicate 'standard-generic-function) 'standard-generic-function-p) +(setf (type-predicate 'combined-method) 'combined-method-p) + +(setf (type-predicate 'standard-method) 'standard-method-p) + +;; Maybe we shouldn't make this a real type... +(setf (type-predicate 'method-function) '%method-function-p) + + +(defvar %all-gfs% (%cons-population nil)) + + +(eval-when (:compile-toplevel :execute) +(defconstant $lfbits-numinh-mask (logior (dpb -1 $lfbits-numinh 0) + (%ilsl $lfbits-nonnullenv-bit 1))) +) + + +#+ppc-target +(defvar *fi-trampoline-code* (uvref #'funcallable-trampoline 0)) + + +#+ppc-target +(defvar *unset-fin-code* (uvref #'unset-fin-trampoline 0)) + + + +#+ppc-target +(defvar *gf-proto-code* (uvref *gf-proto* 0)) + +;;; The "early" version of %ALLOCATE-GF-INSTANCE. +(setf (fdefinition '%allocate-gf-instance) + #'(lambda (class) + (declare (ignorable class)) + (setq class *standard-generic-function-class*) + (let* ((wrapper (%class.own-wrapper class)) + (len (length #.(%wrapper-instance-slots (class-own-wrapper + *standard-generic-function-class*)))) + (dt (make-gf-dispatch-table)) + (slots (allocate-typed-vector :slot-vector (1+ len) (%slot-unbound-marker))) + (fn #+ppc-target + (gvector :function + *gf-proto-code* + wrapper + slots + dt + #'%%0-arg-dcode + 0 + (%ilogior (%ilsl $lfbits-gfn-bit 1) + (%ilogand $lfbits-args-mask 0))) + #+x86-target + (%clone-x86-function *gf-proto* + wrapper + slots + dt + #'%%0-arg-dcode + 0 + (%ilogior (%ilsl $lfbits-gfn-bit 1) + (%ilogand $lfbits-args-mask 0))))) + (setf ;(gf.hash fn) (strip-tag-to-fixnum fn) + (slot-vector.instance slots) fn + (%gf-dispatch-table-gf dt) fn) + (push fn (population.data %all-gfs%)) + fn))) + + + + + + + + + +(defparameter *gf-proto-one-arg* #'gag-one-arg) +(defparameter *gf-proto-two-arg* #'gag-two-arg) + + + + +#+ppc-target +(defvar *cm-proto-code* (uvref *cm-proto* 0)) + +(defun %cons-combined-method (gf thing dcode) + ;; set bits and name = gf + #+ppc-target + (gvector :function + *cm-proto-code* + thing + dcode + gf + (%ilogior (%ilsl $lfbits-cm-bit 1) + (%ilogand $lfbits-args-mask (lfun-bits gf)))) + #+x86-target + (%clone-x86-function *cm-proto* + thing + dcode + gf + (%ilogior (%ilsl $lfbits-cm-bit 1) + (%ilogand $lfbits-args-mask (lfun-bits gf))))) + +(defun %gf-dispatch-table (gf) + ;(require-type gf 'standard-generic-function) + (gf.dispatch-table gf)) + +(defun %gf-dcode (gf) + ;(require-type gf 'standard-generic-function) + (gf.dcode gf)) + +(defun %set-gf-dcode (gf dcode) + (let ((gf (require-type gf 'funcallable-standard-object)) + (dcode (require-type dcode 'function))) + (replace-function-code gf (or (cdr (assq dcode dcode-proto-alist)) + #'funcallable-trampoline)) + (setf (gf.dcode gf) dcode))) + +(defun %set-gf-dispatch-table (gf val) + (setf (gf.dispatch-table gf) val)) + +(defun %combined-method-methods (cm) + ;(require-type cm 'combined-method) + (combined-method.thing cm)) + +(defun %combined-method-dcode (cm) + ;(require-type cm 'combined-method) + (combined-method.dcode cm)) + +(defun %set-combined-method-methods (cm val) + (setf (combined-method.thing cm) val)) + +(defun %set-combined-method-dcode (cm val) + (setf (combined-method.dcode cm) val)) + +(declaim (inline funcallable-instance-p)) +(defun funcallable-instance-p (thing) + (when (typep thing 'function) + (let ((bits (lfun-bits-known-function thing))) + (declare (fixnum bits)) + (eq (ash 1 $lfbits-gfn-bit) + (logand bits (logior (ash 1 $lfbits-gfn-bit) + (ash 1 $lfbits-method-bit))))))) + +(setf (type-predicate 'funcallable-standard-object) 'funcallable-instance-p) + +(defstatic *generic-function-class-wrapper* nil) +(defstatic *standard-generic-function-class-wrapper* nil) + +(defun generic-function-p (thing) + (and (typep thing 'funcallable-standard-object) + (let* ((wrapper (gf.instance.class-wrapper thing))) + ;; In practice, many generic-functions are standard-generic-functions. + (or (eq *standard-generic-function-class-wrapper* wrapper) + (eq *generic-function-class-wrapper* wrapper) + (let* ((bits (or (%wrapper-cpl-bits wrapper) + (make-cpl-bits (%inited-class-cpl (%wrapper-class wrapper))))) + (ordinal (%wrapper-class-ordinal *generic-function-class-wrapper*))) + (and bits ordinal + (locally (declare (simple-bit-vector bits) + (fixnum ordinal) + (optimize (speed 3) (safety 0))) + (and (< ordinal (length bits)) + (eql 1 (sbit bits ordinal)))))))))) + + +(defun standard-generic-function-p (thing) + (and (typep thing 'function) + (let ((bits (lfun-bits-known-function thing))) + (declare (fixnum bits)) + (eq (ash 1 $lfbits-gfn-bit) + (logand bits (logior (ash 1 $lfbits-gfn-bit) + (ash 1 $lfbits-method-bit))))) + (or (eq (%class.own-wrapper *standard-generic-function-class*) + (gf.instance.class-wrapper thing)) + (memq *standard-generic-function-class* + (%inited-class-cpl (class-of thing)))))) + + +(defun combined-method-p (thing) + (when (functionp thing) + (let ((bits (lfun-bits-known-function thing))) + (declare (fixnum bits)) + (eq (ash 1 $lfbits-cm-bit) + (logand bits + (logior (ash 1 $lfbits-cm-bit) + (ash 1 $lfbits-method-bit))))))) + +(setf (type-predicate 'generic-function) 'generic-function-p) + +(setf (type-predicate 'standard-generic-function) 'standard-generic-function-p) +(setf (type-predicate 'funcallable-standard-object) 'funcallable-instance-p) +(setf (type-predicate 'combined-method) 'combined-method-p) + + + +;;; A generic-function looks like: +;;; +;;; header | trampoline | dispatch-table | dcode | name | bits +;;; %svref : 0 1 2 3 4 +;;; +;;; The trampoline is *gf-proto*'s code vector. +;;; The dispatch-table and dcode are sort of settable closed-over variables. + +(defsetf %gf-dispatch-table %set-gf-dispatch-table) + +(defun %gf-methods (gf) + (sgf.methods gf)) + +(defun %gf-precedence-list (gf) + (%gf-dispatch-table-precedence-list (%gf-dispatch-table gf))) + +(defun %gf-%lambda-list (gf) + (sgf.%lambda-list gf)) + +(defun (setf %gf-%lambda-list) (new gf) + (setf (sgf.%lambda-list gf) new)) + +;;; Returns INSTANCE if it is either a standard instance of a +;;; standard gf, else nil. +(defun %maybe-gf-instance (instance) + (if (or (standard-generic-function-p instance) + (%standard-instance-p instance)) + instance)) + +(defsetf %gf-dcode %set-gf-dcode) + +(defun %gf-method-class (gf) + (sgf.method-class gf)) + + +(defun %gf-method-combination (gf) + (sgf.method-combination gf)) + +; need setters too + +(defsetf %combined-method-methods %set-combined-method-methods) + +(defparameter *min-gf-dispatch-table-size* 2 + "The minimum size of a generic-function dispatch table") + +(defun make-gf-dispatch-table (&optional (size *min-gf-dispatch-table-size*)) + (when (<= size 0) (report-bad-arg size '(integer 1))) + (setq size (%imax (%ilsl (%i- (integer-length (%i+ size size -1)) + 1) + 1) ; next power of 2 + *min-gf-dispatch-table-size*)) + (let ((res (%cons-gf-dispatch-table size))) + (declare (optimize (speed 3) (safety 0))) + (setf (%gf-dispatch-table-mask res) (%i- (%ilsr 1 size) 1) + (%gf-dispatch-table-argnum res) 0 + (%gf-dispatch-table-ref res size) (%unbound-marker)) + res)) + +;;; I wanted this to be faster - I didn't +(defun clear-gf-dispatch-table (dt) + (let ((i %gf-dispatch-table-first-data)) + (dotimes (j (%gf-dispatch-table-size dt)) + (declare (fixnum j)) + (setf (%svref dt i) nil + i (%i+ i 1))) + (setf (%svref dt i) (%unbound-marker)) ; paranoia... + (setf (svref dt (%i+ 1 i)) nil)) + dt) + + +; Remove all combined-methods from the world +(defun clear-all-gf-caches () + (dolist (f (population-data %all-gfs%)) + (clear-gf-cache f)) + (clrhash *combined-methods*) + nil) + + +;;; Searches for an empty slot in dt at the hash-index for wrapper. +;;; Returns nil if the table was full. +(defun find-gf-dispatch-table-index (dt wrapper &optional skip-full-check?) + (let ((contains-obsolete-wrappers-p nil) + (mask (%gf-dispatch-table-mask dt))) + (declare (fixnum mask)) + (unless skip-full-check? + (let* ((size (1+ mask)) + (max-count (- size (the fixnum (ash (the fixnum (+ size 3)) -2)))) + (index 0) + (count 0)) + (declare (fixnum size max-count index count)) + (dotimes (i size) + (declare (fixnum i)) + (let ((wrapper (%gf-dispatch-table-ref dt index))) + (if wrapper + (if (eql 0 (%wrapper-hash-index wrapper)) + (setf contains-obsolete-wrappers-p t + (%gf-dispatch-table-ref dt index) *obsolete-wrapper* + (%gf-dispatch-table-ref dt (1+ index)) *gf-dispatch-bug*) + (setq count (%i+ count 1))))) + (setq index (%i+ index 2))) + (when (> count max-count) + (return-from find-gf-dispatch-table-index (values nil contains-obsolete-wrappers-p))))) + (let* ((index (ash (logand mask (%wrapper-hash-index wrapper)) 1)) + (flag nil) + table-wrapper) + (values + (loop + (while (and (neq wrapper + (setq table-wrapper (%gf-dispatch-table-ref dt index))) + (%gf-dispatch-table-ref dt (1+ index)) + (neq 0 (%wrapper-hash-index table-wrapper))) + (setq index (%i+ index 2))) + (if (eq (%unbound-marker) table-wrapper) + (if flag + (return nil) ; table full + (setq flag 1 + index 0)) + (return index))) + contains-obsolete-wrappers-p)))) + + +(defvar *obsolete-wrapper* #(obsolete-wrapper 0)) +(defvar *gf-dispatch-bug* + #'(lambda (&rest rest) + (declare (ignore rest)) + (error "Generic-function dispatch bug!"))) + + +;;; This maximum is necessary because of the 32 bit arithmetic in +;;; find-gf-dispatch-table-index. +(defparameter *max-gf-dispatch-table-size* (expt 2 16)) +(defvar *gf-dt-ovf-cnt* 0) ; overflow count + +(defvar *no-applicable-method-hash* nil) + + +(let* ((eql-specializers-lock (make-lock)) + (eql-specializers-hash (make-hash-table :test #'eql))) + (defun intern-eql-specializer (object) + (with-lock-grabbed (eql-specializers-lock) + (or (gethash object eql-specializers-hash) + (setf (gethash object eql-specializers-hash) + (make-instance 'eql-specializer :object object)))))) + + +(setq *no-applicable-method-hash* (make-hash-table :test 'eq :size 0 :weak :key)) + + +(defun make-no-applicable-method-function (gf) + (if *no-applicable-method-hash* + (progn + (or (gethash gf *no-applicable-method-hash*)) + (setf (gethash gf *no-applicable-method-hash*) + (%cons-no-applicable-method gf))) + (%cons-no-applicable-method gf))) + +(defun %cons-no-applicable-method (gf) + (%cons-combined-method gf gf #'%%no-applicable-method)) + +; Returns true if F is a combined-method that calls no-applicable-method +(defun no-applicable-method-cm-p (f) + (and (typep f 'combined-method) + (eq '%%no-applicable-method + (function-name (%combined-method-dcode f))))) + + +(defun %%no-applicable-method (gf args) + (if (listp args) + (apply #'no-applicable-method gf args) + (%apply-lexpr #'no-applicable-method gf args ))) + +;;; if obsolete-wrappers-p is true, will rehash instead of grow. +;;; It would be better to do the rehash in place, but I'm lazy today. + + +(defun arg-wrapper (arg) + (or (standard-object-p arg) + (%class.own-wrapper (class-of arg)) + (error "~a has no wrapper" arg))) + +;;;;;;;;;;;;;;;;;;;;;;;;; generic-function dcode ;;;;;;;;;;;;;;;;;;;;;;;;;;; + +;; dcode functions using other than *gf-proto* +(defparameter dcode-proto-alist ()) + +(defun register-dcode-proto (dcode proto) + (let ((a (assoc dcode dcode-proto-alist))) + (if a + (setf (cdr a) proto) + (push (cons dcode proto) dcode-proto-alist)))) + + +;;; Simple case for generic-functions with no specializers +;;; Why anyone would want to do this I can't imagine. + +(defun %%0-arg-dcode (dispatch-table args) ; need to get gf from table + (let ((method (or (%gf-dispatch-table-ref dispatch-table 1) + (0-arg-combined-method-trap + (%gf-dispatch-table-gf dispatch-table))))) + (if (not (listp args)) + (progn + (%apply-lexpr-tail-wise method args)) + (apply method args)))) + +(register-dcode-proto #'%%0-arg-dcode *gf-proto*) + +(defun dcode-too-few-args (arg-count cm-or-gf) + (error (make-condition 'too-few-arguments + :nargs arg-count + :fn (combined-method-gf cm-or-gf)))) + + + +(defun %%1st-arg-dcode (dt args) + ;(declare (dynamic-extent args)) + (if (not (listp args)) + (let* ((args-len (%lexpr-count args))) + (if (neq 0 args-len) + (let ((method (%find-1st-arg-combined-method dt (%lexpr-ref args args-len 0)))) + (%apply-lexpr-tail-wise method args)) + (dcode-too-few-args 0 (%gf-dispatch-table-gf dt)))) + (let* () ; happens if traced + (when (null args) (dcode-too-few-args 0 (%gf-dispatch-table-gf dt))) + (let ((method (%find-1st-arg-combined-method dt (%car args)))) + (apply method args))))) +(register-dcode-proto #'%%1st-arg-dcode *gf-proto*) + +(defun %%one-arg-dcode (dt arg) + (let ((method (%find-1st-arg-combined-method dt arg))) + (funcall method arg))) +(register-dcode-proto #'%%one-arg-dcode *gf-proto-one-arg*) + +;;; two args - specialized on first +(defun %%1st-two-arg-dcode (dt arg1 arg2) + (let ((method (%find-1st-arg-combined-method dt arg1))) + (funcall method arg1 arg2))) +(register-dcode-proto #'%%1st-two-arg-dcode *gf-proto-two-arg*) + + +;;; arg is dispatch-table and argnum is in the dispatch table +(defun %%nth-arg-dcode (dt args) + (if (listp args) + (let* ((args-len (list-length args)) + (argnum (%gf-dispatch-table-argnum dt))) + (declare (fixnum args-len argnum)) + (when (>= argnum args-len) (dcode-too-few-args args-len (%gf-dispatch-table-gf dt))) + (let ((method (%find-nth-arg-combined-method dt (nth argnum args) args))) + (apply method args))) + (let* ((args-len (%lexpr-count args)) + (argnum (%gf-dispatch-table-argnum dt))) + (declare (fixnum args-len argnum)) + (when (>= argnum args-len) (dcode-too-few-args args-len (%gf-dispatch-table-gf dt))) + (let ((method (%find-nth-arg-combined-method dt (%lexpr-ref args args-len argnum) args))) + (%apply-lexpr-tail-wise method args))))) +(register-dcode-proto #'%%nth-arg-dcode *gf-proto*) + +(defun 0-arg-combined-method-trap (gf) + (let* ((methods (%gf-methods gf)) + (mc (%gf-method-combination gf)) + (cm (if (eq mc *standard-method-combination*) + (make-standard-combined-method methods nil gf) + (compute-effective-method-function + gf + mc + (sort-methods (copy-list methods) nil))))) + (setf (%gf-dispatch-table-ref (%gf-dispatch-table gf) 1) cm) + cm)) + +(defun compute-effective-method-function (gf mc methods) + (if methods + (compute-effective-method gf mc methods) + (make-no-applicable-method-function gf))) + +(defun 1st-arg-combined-method-trap (gf wrapper arg) + ;; Here when we can't find the method in the dispatch table. + ;; Compute it and add it to the table. This code will remain in Lisp. + (let ((table (%gf-dispatch-table gf)) + (combined-method (compute-1st-arg-combined-method gf arg wrapper))) + (multiple-value-bind (index obsolete-wrappers-p) + (find-gf-dispatch-table-index table wrapper) + (if index + (if (%gf-dispatch-table-store-conditional table (%i+ index 1) combined-method) + (setf (%gf-dispatch-table-ref table index) wrapper)) + (grow-gf-dispatch-table gf wrapper combined-method obsolete-wrappers-p))) + combined-method)) + +(defvar *cpl-classes* nil) + +(defun %inited-class-cpl (class &optional initialize-can-fail) + (or (%class-cpl class) + (if (memq class *cpl-classes*) + (compute-cpl class) + (let ((*cpl-classes* (cons class *cpl-classes*))) + (declare (dynamic-extent *cpl-classes*)) + (update-class class initialize-can-fail) + (%class-cpl class))))) + + +(defun compute-1st-arg-combined-method (gf arg &optional + (wrapper (arg-wrapper arg))) + (let* ((methods (%gf-dispatch-table-methods (%gf-dispatch-table gf))) + (cpl (%inited-class-cpl (%wrapper-class wrapper))) + (method-combination (%gf-method-combination gf)) + applicable-methods eql-methods specializer) + (dolist (method methods) + (setq specializer (%car (%method.specializers method))) + (if (typep specializer 'eql-specializer) + (when (cpl-memq (%wrapper-class (arg-wrapper (eql-specializer-object specializer))) cpl) + (push method eql-methods)) + (when (cpl-memq specializer cpl) + (push method applicable-methods)))) + (if (null eql-methods) + (if (eq method-combination *standard-method-combination*) + (make-standard-combined-method applicable-methods (list cpl) gf) + (compute-effective-method-function + gf + method-combination + (sort-methods applicable-methods + (list cpl) + (%gf-precedence-list gf)))) + (make-eql-combined-method + eql-methods applicable-methods (list cpl) gf 0 nil method-combination)))) + + + +(defvar *combined-methods* (make-hash-table :test 'equal :weak :value)) + +(defun gethash-combined-method (key) + (gethash key *combined-methods*)) + +(defun puthash-combined-method (key value) + (setf (gethash key *combined-methods*) value)) + +;;; Some statistics on the hash table above +(defvar *returned-combined-methods* 0) +(defvar *consed-combined-methods* 0) + +;;; Assumes methods are already sorted if cpls is nil +(defun make-standard-combined-method (methods cpls gf &optional + (ok-if-no-primaries (null methods))) + (unless (null cpls) + (setq methods (sort-methods + methods cpls (%gf-precedence-list (combined-method-gf gf))))) + (let* ((keywords (compute-allowable-keywords-vector gf methods)) + (combined-method (make-standard-combined-method-internal + methods gf keywords ok-if-no-primaries))) + (if (and keywords methods) + (make-keyword-checking-combined-method gf combined-method keywords) + combined-method))) + + +;;; Initialized below after the functions exist. +(defvar *clos-initialization-functions* nil) + +;;; Returns NIL if all keywords allowed, or a vector of the allowable ones. +(defun compute-allowable-keywords-vector (gf methods) + (setq gf (combined-method-gf gf)) + (unless (memq gf *clos-initialization-functions*) + (let* ((gbits (inner-lfun-bits gf)) + (&key-mentioned-p (logbitp $lfbits-keys-bit gbits))) + (unless (or (logbitp $lfbits-aok-bit gbits) + (dolist (method methods) + (let ((mbits (lfun-bits (%method.function method)))) + (when (logbitp $lfbits-keys-bit mbits) + (setq &key-mentioned-p t) + (if (logbitp $lfbits-aok-bit mbits) + (return t))))) + (not &key-mentioned-p)) + (let (keys) + (flet ((adjoin-keys (keyvect keys) + (when keyvect + (dovector (key keyvect) (pushnew key keys))) + keys)) + (when (logbitp $lfbits-keys-bit gbits) + (setq keys (adjoin-keys (%defgeneric-keys gf) keys))) + (dolist (method methods) + (let ((f (%inner-method-function method))) + (when (logbitp $lfbits-keys-bit (lfun-bits f)) + (setq keys (adjoin-keys (lfun-keyvect f) keys)))))) + (apply #'vector keys)))))) + + +(defun make-keyword-checking-combined-method (gf combined-method keyvect) + (let* ((bits (inner-lfun-bits gf)) + (numreq (ldb $lfbits-numreq bits)) + (key-index (+ numreq (ldb $lfbits-numopt bits)))) + (%cons-combined-method + gf + (vector key-index keyvect combined-method) + #'%%check-keywords))) + + + +(defun odd-keys-error (varg l) + (let ((gf (combined-method-gf (%svref varg 2)))) + (signal-program-error "Odd number of keyword args to ~s~%keyargs: ~s" gf l))) + + +(defun bad-key-error (key varg l) + (let* ((keys (%svref varg 1)) + (gf (combined-method-gf (%svref varg 2))) + (*print-array* t) + (*print-readably* t) + (readable-keys (format nil "~s" keys))) + (signal-program-error "Bad keyword ~s to ~s.~%keyargs: ~s~%allowable keys are ~a." key gf l readable-keys))) + +; vector arg is (vector key-index keyvect combined-method) ; the next combined method + +(defun %%check-keywords (vector-arg args) + (flet ((do-it (vector-arg args) + (let* ((args-len (length args)) + (keyvect (%svref vector-arg 1)) + (keyvect-len (length keyvect)) + (key-index (%svref vector-arg 0))) + ; vector arg is (vector key-index keyvect combined-method) ; the next combined method + (declare (fixnum args-len key-index keyvect-len)) + (when (>= args-len key-index) + (let* ((keys-in (- args-len key-index))) ; actually * 2 + (declare (fixnum key-index keys-in keyvect-len)) + (when (logbitp 0 keys-in) (odd-keys-error vector-arg (collect-lexpr-args args key-index args-len))) + (unless (%cadr (%pl-search (nthcdr key-index args) :allow-other-keys)) + (do ((i key-index (+ i 2)) + (kargs (nthcdr key-index args) (cddr kargs))) + ((eq i args-len)) + (declare (fixnum i)) + (let ((key (car kargs))) + (when (not (or (eq key :allow-other-keys) + (dotimes (i keyvect-len nil) + (if (eq key (%svref keyvect i)) + (return t))))) + (bad-key-error key vector-arg (collect-lexpr-args args key-index args-len)) + )))))) + (let ((method (%svref vector-arg 2))) + ; magic here ?? not needed + (apply method args))))) + (if (listp args) + (do-it vector-arg args) + (with-list-from-lexpr (args-list args) + (do-it vector-arg args-list))))) + + + + + + +;;; called from %%call-next-method-with-args - its the key-or-init-fn +;;; called from call-next-method-with-args - just check the blooming keys +;;; dont invoke any methods - maybe use x%%check-keywords with last vector elt nil +; means dont call any methods - but need the gf or method for error message +(defun x-%%check-keywords (vector-arg ARGS) + ;(declare (dynamic-extent args)) + ; vector arg is (vector key-index keyvect unused) + (let* ((ARGS-LEN (length args)) + (keyvect (%svref vector-arg 1)) + (keyvect-len (length keyvect)) + (key-index (%svref vector-arg 0)) + (keys-in (- args-len key-index)) + aok) ; actually * 2 + (declare (fixnum args-len key-index keys-in keyvect-len)) + + (when (logbitp 0 keys-in) (odd-keys-error vector-arg (collect-lexpr-args args key-index args-len))) + (do ((i key-index (+ i 2)) + (kargs (nthcdr key-index args) (cddr kargs))) + ((eq i args-len)) + (declare (fixnum i)) + (when aok (return)) + (let ((key (car kargs))) + (when (and (eq key :allow-other-keys) + (cadr kargs)) + (return)) + (when (not (dotimes (i keyvect-len nil) + (if (eq key (%svref keyvect i)) + (return t)))) + ; not found - is :allow-other-keys t in rest of user args + (when (not (do ((remargs kargs (cddr remargs))) + ((null remargs) nil) + (when (and (eq (car remargs) :allow-other-keys) + (cadr remargs)) + (setq aok t) + (return t)))) + (bad-key-error key vector-arg + (collect-lexpr-args args key-index args-len)))))))) +#| ; testing +(setq keyvect #(:a :b )) +(setq foo (make-array 3)) +(setf (aref foo 0) keyvect (aref foo 1) 2) +(setf (aref foo 2)(method window-close (window))) +( %%check-keywords 1 2 :a 3 :c 4 foo) +( %%check-keywords 1 2 :a 3 :b 4 :d foo) +|# + + + + + +;;; Map an effective-method to it's generic-function. +;;; This is only used for effective-method's which are not combined-method's +;;; (e.g. those created by non-STANDARD method-combination) +(defvar *effective-method-gfs* (make-hash-table :test 'eq :weak :key)) + + +(defun get-combined-method (method-list gf) + (let ((cm (gethash-combined-method method-list))) + (when cm + (setq gf (combined-method-gf gf)) + (if (combined-method-p cm) + (and (eq (combined-method-gf cm) gf) cm) + (and (eq (gethash cm *effective-method-gfs*) gf) cm))))) + +(defun put-combined-method (method-list cm gf) + (unless (%method-function-p cm) ; don't bother with non-combined methods + (puthash-combined-method method-list cm) + (unless (combined-method-p cm) + (setf (gethash cm *effective-method-gfs*) (combined-method-gf gf)))) + cm) + +(defun make-standard-combined-method-internal (methods gf &optional + keywords + (ok-if-no-primaries + (null methods))) + (let ((method-list (and methods (compute-method-list methods nil)))) + (if method-list ; no applicable primary methods + (if (atom method-list) + (%method.function method-list) ; can jump right to the method-function + (progn + (incf *returned-combined-methods*) ; dont need this + (if (contains-call-next-method-with-args-p method-list) + (make-cnm-combined-method gf methods method-list keywords) + (or (get-combined-method method-list gf) + (progn + (incf *consed-combined-methods*) ; dont need this + (puthash-combined-method + method-list + (%cons-combined-method + gf method-list #'%%standard-combined-method-dcode))))))) + (if ok-if-no-primaries + (make-no-applicable-method-function (combined-method-gf gf)) + (no-applicable-primary-method gf methods))))) + +; Initialized after the initialization (generic) functions exist. +(defvar *initialization-functions-alist* nil) + +;;; This could be in-line above, but I was getting confused. + +;;; ok +(defun make-cnm-combined-method (gf methods method-list keywords) + (setq gf (combined-method-gf gf)) + (let ((key (cons methods method-list))) + (or (get-combined-method key gf) + (let* (key-or-init-arg + key-or-init-fn) + (if keywords + (let* ((bits (inner-lfun-bits gf)) + (numreq (ldb $lfbits-numreq bits)) + (key-index (+ numreq (ldb $lfbits-numopt bits)))) + (setq key-or-init-arg (vector key-index keywords gf)) + (setq key-or-init-fn #'x-%%check-keywords)) + (let ((init-cell (assq gf *initialization-functions-alist*))) + (when init-cell + (setq key-or-init-arg init-cell) + (setq key-or-init-fn #'%%cnm-with-args-check-initargs)))) + (incf *consed-combined-methods*) + (let* ((vect (vector gf methods key-or-init-arg key-or-init-fn method-list)) + (self (%cons-combined-method + gf vect #'%%cnm-with-args-combined-method-dcode))) + ;(setf (svref vect 4) self) + (puthash-combined-method ; if testing 1 2 3 dont put in our real table + key + self)))))) + + +(defparameter *check-call-next-method-with-args* t) + +(defun contains-call-next-method-with-args-p (method-list) + (when *check-call-next-method-with-args* + (let ((methods method-list) + method) + (loop + (setq method (pop methods)) + (unless methods (return nil)) + (unless (listp method) + (if (logbitp $lfbits-nextmeth-with-args-bit + (lfun-bits (%method.function method))) + (return t))))))) + +;;; The METHODS arg is a sorted list of applicable methods. Returns +;;; the method-list expected by +;;; %%before-and-after-combined-method-dcode or a single method, or +;;; NIL if there are no applicable primaries +(defun compute-method-list (methods &optional (sub-dispatch? t)) + (let (arounds befores primaries afters qs) + (dolist (m methods) + (setq qs (%method.qualifiers m)) + (if qs + (if (cdr qs) + (%invalid-method-error + m "Multiple method qualifiers not allowed in ~s method combination" + 'standard) + (case (car qs) + (:before (push m befores)) + (:after (push m afters)) + (:around (push m arounds)) + (t (%invalid-method-error m "~s is not one of ~s, ~s, and ~s." + (car qs) :before :after :around)))) + (push m primaries))) + (setq primaries (nreverse primaries) + arounds (nreverse arounds) + befores (nreverse befores)) + (unless sub-dispatch? + (setq primaries (nremove-uncallable-next-methods primaries) + arounds (nremove-uncallable-next-methods arounds))) + (flet ((next-method-bit-p (method) + (logbitp $lfbits-nextmeth-bit + (lfun-bits (%method.function method))))) + (unless (null primaries) ; return NIL if no applicable primary methods + (when (and arounds + (not sub-dispatch?) + (not (next-method-bit-p (car (last arounds))))) + ;; Arounds don't call-next-method, can't get to befores, + ;; afters, or primaries + (setq primaries arounds + arounds nil + befores nil + afters nil)) + (if (and (null befores) (null afters) + (progn + (when arounds + (setq primaries (nconc arounds primaries) + arounds nil) + (unless sub-dispatch? + (setq primaries (nremove-uncallable-next-methods primaries)))) + t) + (null (cdr primaries)) + (not (next-method-bit-p (car primaries)))) + (car primaries) ; single method, no call-next-method + (let ((method-list primaries)) + (if (or befores afters) + (setq method-list (cons befores (cons afters method-list)))) + (nconc arounds method-list))))))) + + + +(defun %invalid-method-error (method format-string &rest format-args) + (error "~s is an invalid method.~%~?" method format-string format-args)) + +(defun %method-combination-error (format-string &rest args) + (apply #'error format-string args)) + + + +(defun combined-method-gf (gf-or-cm) + (let ((gf gf-or-cm)) + (while (combined-method-p gf) + (setq gf (lfun-name gf))) + gf)) + + +(defun nth-arg-combined-method-trap-0 (gf-or-cm table wrapper args) + (let* ((argnum (%gf-dispatch-table-argnum table)) + (arg (nth argnum args))) + (nth-arg-combined-method-trap gf-or-cm table argnum args arg wrapper))) + + +(defun nth-arg-combined-method-trap (gf-or-cm table argnum args &optional + (arg (nth-or-gf-error + argnum args gf-or-cm)) + (wrapper (arg-wrapper arg))) + ;; Here when we can't find the method in the dispatch table. + ;; Compute it and add it to the table. This code will remain in Lisp. + (multiple-value-bind (combined-method sub-dispatch?) + (compute-nth-arg-combined-method + gf-or-cm (%gf-dispatch-table-methods table) argnum args + wrapper) + (multiple-value-bind (index obsolete-wrappers-p) + (find-gf-dispatch-table-index table wrapper) + (if index + (if (%gf-dispatch-table-store-conditional table (%i+ index 1) combined-method) + (setf (%gf-dispatch-table-ref table index) wrapper)) + (grow-gf-dispatch-table gf-or-cm wrapper combined-method obsolete-wrappers-p))) + (if sub-dispatch? + (let ((table (%combined-method-methods combined-method))) + (nth-arg-combined-method-trap + combined-method + table + (%gf-dispatch-table-argnum table) + args)) + combined-method))) + +;;; Returns (values combined-method sub-dispatch?) +;;; If sub-dispatch? is true, need to compute a combined-method on the +;;; next arg. +(defun compute-nth-arg-combined-method (gf methods argnum args &optional + (wrapper (arg-wrapper + (nth-or-gf-error + argnum args gf)))) + (let* ((cpl (%inited-class-cpl (%wrapper-class wrapper))) + (real-gf (combined-method-gf gf)) + (mc (%gf-method-combination real-gf)) + (standard-mc? (eq mc *standard-method-combination*)) + applicable-methods eql-methods specializers specializer sub-dispatch?) + (dolist (method methods) + ;;(require-type method 'standard-method) ; for debugging. + (setq specializers (nthcdr argnum (%method.specializers method)) + specializer (%car specializers)) + (when (if (typep specializer 'eql-specializer) + (when (cpl-memq (%wrapper-class + (arg-wrapper (eql-specializer-object specializer))) cpl) + (push method eql-methods)) + (when (cpl-memq specializer cpl) + (push method applicable-methods))) + (if (contains-non-t-specializer? (%cdr specializers)) + (setq sub-dispatch? t)))) + (if (or eql-methods applicable-methods) + (if (or (not standard-mc?) + (contains-primary-method? applicable-methods) + (contains-primary-method? eql-methods)) + (let ((cpls (args-cpls args))) + (if eql-methods + (make-eql-combined-method + eql-methods applicable-methods cpls gf argnum sub-dispatch? mc) + (if sub-dispatch? + (values (make-n+1th-arg-combined-method applicable-methods gf argnum) + t) + (if standard-mc? + (make-standard-combined-method applicable-methods cpls gf) + (compute-effective-method-function + real-gf mc (sort-methods applicable-methods + (args-cpls args) + (%gf-precedence-list real-gf))))))) + (no-applicable-primary-method + real-gf + (sort-methods (append eql-methods applicable-methods) + (args-cpls args) + (%gf-precedence-list real-gf)))) + (make-no-applicable-method-function real-gf)))) + +(defun nth-or-gf-error (n l gf) + (declare (fixnum n)) + (do* ((i 0 (1+ i)) + (l l (cdr l))) + ((null l) (dcode-too-few-args i gf)) + (declare (fixnum i)) + (if (= i n) + (return (car l))))) + +(defun contains-non-t-specializer? (specializer-list) + (dolist (s specializer-list nil) + (unless (eq *t-class* s) + (return t)))) + +(defun contains-primary-method? (method-list) + (dolist (m method-list nil) + (if (null (%method.qualifiers m)) + (return t)))) + +(defun args-cpls (args &aux res) + (dolist (arg args) + (push (%inited-class-cpl (%wrapper-class (arg-wrapper arg))) res)) + (nreverse res)) + + +(defun compute-eql-combined-method-hash-table-threshold (&optional (iters 1000000) (max 200)) + (flet ((time-assq (cnt iters) + (let ((alist (loop for i from 1 to cnt collect (cons i i))) + (start-time (get-internal-run-time)) + (j 0) + res) + (declare (fixnum j)) + (dotimes (i iters) + (declare (fixnum i)) + (setq res (cdr (assq j alist))) + (when (>= (incf j) cnt) (setq j 0))) + (values (- (get-internal-run-time) start-time) res))) + (time-hash (cnt iters) + (let ((hash (make-hash-table :test 'eq)) + start-time + (j 0) + res) + (declare (fixnum j)) + (dotimes (i cnt) + (setf (gethash i hash) i)) + (assert-hash-table-readonly hash) + (setq start-time (get-internal-run-time)) + (dotimes (i iters) + (declare (fixnum i)) + (setq res (gethash i hash)) + (when (>= (incf j) cnt) (setq j 0))) + (values (- (get-internal-run-time) start-time) res)))) + (dotimes (i max) + (let ((time-assq (time-assq i iters)) + (time-hash (time-hash i iters))) + (format t "i: ~d, assq: ~d, hash: ~d~%" i time-assq time-hash) + (when (> time-assq time-hash) (return i)))))) + +;; Value computed on a dual-core 2.4 GHz AMD Opteron running FC3 +;; This isn't the result of compute-eql-combined-method-hash-table-threshold, +;; it's the value at which assq takes 3/4 the time of hash, which weights +;; towards the worst case of the eql method, not the average for uniform inputs. +(defparameter *eql-combined-method-hash-table-threshold* 45) + +;;; A vector might be a little faster than an alist, but the hash table case +;;; will speed up large numbers of methods. +(defun make-eql-combined-method (eql-methods methods cpls gf argnum sub-dispatch? &optional + (method-combination *standard-method-combination*)) + (let ((eql-ms (copy-list eql-methods)) + (precedence-list (%gf-precedence-list (combined-method-gf gf))) + (standard-mc? (eq method-combination *standard-method-combination*)) + (real-gf (combined-method-gf gf)) + eql-method-alist + (can-use-eq? t)) + (unless sub-dispatch? + (setq methods (sort-methods methods cpls precedence-list))) + (while eql-ms + (let ((eql-element (eql-specializer-object (nth argnum (%method.specializers (car eql-ms))))) + (this-element-methods eql-ms) + cell last-cell) + (if (or (and (numberp eql-element) (not (fixnump eql-element))) + (macptrp eql-element)) + (setq can-use-eq? nil)) + (setf eql-ms (%cdr eql-ms) + (%cdr this-element-methods) nil + cell eql-ms) + (while cell + (if (eql eql-element + (eql-specializer-object (nth argnum (%method.specializers (car cell))))) + (let ((cell-save cell)) + (if last-cell + (setf (%cdr last-cell) (cdr cell)) + (setq eql-ms (cdr eql-ms))) + (setf cell (cdr cell) + (%cdr cell-save) this-element-methods + this-element-methods cell-save)) + (setq last-cell cell + cell (cdr cell)))) + (let* ((sorted-methods + (sort-methods (nreconc (copy-list this-element-methods) + (copy-list methods)) + cpls + precedence-list)) + (method-list (and standard-mc? (compute-method-list sorted-methods sub-dispatch?)))) + (when (or (not standard-mc?) + (memq method-list this-element-methods) + (and (consp method-list) + (labels ((member-anywhere (tem mlist) + (member tem mlist + :test #'(lambda (tem el) + (if (listp el) + (member-anywhere tem el) + (member el tem)))))) + (member-anywhere this-element-methods method-list)))) + ; Do EQL comparison only if the EQL methods can run + ; (e.g. does not come after a primary method that does not call-next-method) + (push (cons eql-element + (if sub-dispatch? + (make-n+1th-arg-combined-method + sorted-methods gf argnum) + (if standard-mc? + (make-standard-combined-method sorted-methods nil gf) + (compute-effective-method-function + real-gf method-combination sorted-methods)))) + eql-method-alist))))) + ;;eql-method-alist has (element . combined-method) pairs. + ;;for now, we're going to use assq or assoc + (let ((default-method (if sub-dispatch? + (make-n+1th-arg-combined-method + methods gf argnum) + (if standard-mc? + (make-standard-combined-method methods nil gf t) + (compute-effective-method-function + real-gf method-combination methods))))) + (if eql-method-alist + (if (> (length eql-method-alist) *eql-combined-method-hash-table-threshold*) + (let ((hash (make-hash-table :test (if can-use-eq? 'eq 'eql)))) + (dolist (pair eql-method-alist) + (setf (gethash (car pair) hash) (cdr pair))) + (assert-hash-table-readonly hash) + (%cons-combined-method + gf (cons argnum (cons hash default-method)) + #'%%hash-table-combined-method-dcode)) + (%cons-combined-method + gf (cons argnum (cons eql-method-alist default-method)) + (if can-use-eq? + #'%%assq-combined-method-dcode + #'%%assoc-combined-method-dcode))) + default-method)))) + + +(defun %%assq-combined-method-dcode (stuff args) + ;; stuff is (argnum eql-method-list . default-method) + ;(declare (dynamic-extent args)) + (if (listp args) + (let* ((args-len (list-length args)) + (argnum (car stuff))) + (when (>= argnum args-len)(signal-program-error "Too few args to ~s." (%method-gf (cddr stuff)))) + (let* ((arg (nth argnum args)) + (thing (assq arg (cadr stuff)))) ; are these things methods or method-functions? - fns + (if thing + (apply (cdr thing) args) + (apply (cddr stuff) args)))) + (let* ((args-len (%lexpr-count args)) + (argnum (car stuff))) + (when (>= argnum args-len)(signal-program-error "Too few args to ~s." (%method-gf (cddr stuff)))) + (let* ((arg (%lexpr-ref args args-len argnum)) + (thing (assq arg (cadr stuff)))) + (if thing + (%apply-lexpr (cdr thing) args) + (%apply-lexpr (cddr stuff) args)))))) + + +(DEFun %%assoc-combined-method-dcode (stuff args) + ;; stuff is (argnum eql-method-list . default-method) + ;(declare (dynamic-extent args)) + (if (listp args) + (let* ((args-len (list-length args)) + (argnum (car stuff))) + (when (>= argnum args-len)(signal-program-error "Too few args to ~s." (%method-gf (cddr stuff)))) + (let* ((arg (nth argnum args)) + (thing (assoc arg (cadr stuff)))) ; are these things methods or method-functions? + (if thing + (apply (cdr thing) args) + (apply (cddr stuff) args)))) + (let* ((args-len (%lexpr-count args)) + (argnum (car stuff))) + (when (>= argnum args-len)(signal-program-error "Too few args to ~s." (%method-gf (cddr stuff)))) + (let* ((arg (%lexpr-ref args args-len argnum)) + (thing (assoc arg (cadr stuff)))) ; are these things methods or method-functions? + (if thing + (%apply-lexpr (cdr thing) args) + (%apply-lexpr (cddr stuff) args)))))) + + + +(defun %%hash-table-combined-method-dcode (stuff args) + ;; stuff is (argnum eql-hash-table . default-method) + ;(declare (dynamic-extent args)) + (if (listp args) + (let* ((args-len (list-length args)) + (argnum (car stuff))) + (when (>= argnum args-len)(signal-program-error "Too few args to ~s." (%method-gf (cddr stuff)))) + (let* ((arg (nth argnum args))) + (apply (gethash arg (cadr stuff) (cddr stuff)) args))) + (let* ((args-len (%lexpr-count args)) + (argnum (car stuff))) + (when (>= argnum args-len)(signal-program-error "Too few args to ~s." (%method-gf (cddr stuff)))) + (let* ((arg (%lexpr-ref args args-len argnum))) + (%apply-lexpr (gethash arg (cadr stuff) (cddr stuff)) args))))) + + +;;; Assumes the two methods have the same number of specializers and +;;; that each specializer of each method is in the corresponding +;;; element of cpls (e.g. cpls is a list of the cpl's for the classes +;;; of args for which both method1 & method2 are applicable. +(defun %method< (method1 method2 cpls) + (let ((s1s (%method.specializers method1)) + (s2s (%method.specializers method2)) + s1 s2 cpl) + (loop + (if (null s1s) + (return (method-qualifiers< method1 method2))) + (setq s1 (%pop s1s) + s2 (%pop s2s) + cpl (%pop cpls)) + (cond ((typep s1 'eql-specializer) + (unless (eq s1 s2) + (return t))) + ((typep s2 'eql-specializer) (return nil)) + ((eq s1 s2)) + (t (return (%i< (cpl-index s1 cpl) (cpl-index s2 cpl)))))))) + +(defun %simple-method< (method1 method2 cpl) + (let ((s1 (%car (%method.specializers method1))) + (s2 (%car (%method.specializers method2)))) + (cond ((typep s1 'eql-specializer) + (if (eq s1 s2) + (method-qualifiers< method1 method2) + t)) + ((typep s2 'eql-specializer) nil) + ((eq s1 s2) (method-qualifiers< method1 method2)) + (t (%i< (cpl-index s1 cpl) (cpl-index s2 cpl)))))) + +; Sort methods with argument-precedence-order +(defun %hairy-method< (method1 method2 cpls apo) + (let ((s1s (%method.specializers method1)) + (s2s (%method.specializers method2)) + s1 s2 cpl index) + (loop + (if (null apo) + (return (method-qualifiers< method1 method2))) + (setq index (pop apo)) + (setq s1 (nth index s1s) + s2 (nth index s2s) + cpl (nth index cpls)) + (cond ((typep s1 'eql-specializer) + (unless (eq s1 s2) + (return t))) + ((typep s2 'eql-specializer) (return nil)) + ((eq s1 s2)) + (t (return (%i< (cpl-index s1 cpl) (cpl-index s2 cpl)))))))) + +; This can matter if the user removes & reinstalls methods between +; invoking a generic-function and doing call-next-method with args. +; Hence, we need a truly canonical sort order for the methods +; (or a smarter comparison than EQUAL in %%cnm-with-args-check-methods). +(defun method-qualifiers< (method1 method2) + (labels ((qualifier-list< (ql1 ql2 &aux q1 q2) + (cond ((null ql1) (not (null ql2))) + ((null ql2) nil) + ((eq (setq q1 (car ql1)) (setq q2 (car ql2))) + (qualifier-list< (cdr ql1) (cdr ql2))) + ((string-lessp q1 q2) t) + ; This isn't entirely correct. + ; two qualifiers with the same pname in different packages + ; are not comparable here. + ; Unfortunately, users can change package names, hence, + ; comparing the package names doesn't work either. + (t nil)))) + (qualifier-list< (%method.qualifiers method1) (%method.qualifiers method2)))) + +(defun sort-methods (methods cpls &optional apo) + (cond ((null cpls) methods) + ((null (%cdr cpls)) + (setq cpls (%car cpls)) + (flet ((simple-sort-fn (m1 m2) + (%simple-method< m1 m2 cpls))) + (declare (dynamic-extent #'simple-sort-fn)) + (%sort-list-no-key methods #'simple-sort-fn))) + ((null apo) ; no unusual argument-precedence-order + (flet ((sort-fn (m1 m2) + (%method< m1 m2 cpls))) + (declare (dynamic-extent #'sort-fn)) + (%sort-list-no-key methods #'sort-fn))) + (t ; I guess some people are just plain rude + (flet ((hairy-sort-fn (m1 m2) + (%hairy-method< m1 m2 cpls apo))) + (declare (dynamic-extent #'hairy-sort-fn)) + (%sort-list-no-key methods #'hairy-sort-fn))))) + +(defun nremove-uncallable-next-methods (methods) + (do ((m methods (%cdr m)) + mbits) + ((null m)) + (setq mbits (lfun-bits (%method.function (%car m)))) + (unless (logbitp $lfbits-nextmeth-bit mbits) + (setf (%cdr m) nil) + (return))) + methods) + + +(defun cpl-index (superclass cpl) + ;; This will be table lookup later. Also we'll prelookup the tables + ;; in compute-1st-arg-combined-methods above. + (locally (declare (optimize (speed 3)(safety 0))) + (do ((i 0 (%i+ i 1)) + (cpl cpl (%cdr cpl))) + ((null cpl) nil) + (if (eq superclass (%car cpl)) + (return i))))) + +(defun cpl-memq (superclass cpl) + (locally (declare (optimize (speed 3)(safety 0))) + (do ((cpl cpl (%cdr cpl))) + ((null cpl) nil) + (if (eq superclass (%car cpl)) + (return cpl))))) + +;;; Combined method interpretation + + +;;; magic is a list of (cnm-cm (methods) . args) cnm-cm is the +;;; argument checker for call-next-method-with-args or nil could make +;;; it be a cons as a flag that magic has been heap consed - done +;;; could also switch car and cadr if we do &lexpr business then if +;;; cddr is lexpr-p (aka (not listp)) thats the clue also would need +;;; to do lexpr-apply or apply depending on the state. + + +(defun %%standard-combined-method-dcode (methods args) + ;; combined-methods as made by make-combined-method are in methods + ;; args are as put there by the caller of the gf. + (let* ((car-meths (car methods)) + (cell-2 (cons methods args)) + (magic (cons nil cell-2))) + ;; i.e. magic is nil methods . args + (declare (dynamic-extent magic) + (dynamic-extent cell-2)) + (if (listp car-meths) + (%%before-and-after-combined-method-dcode magic) + (progn + (if (not (cdr methods)) + (%rplaca (cdr magic) car-meths) + (%rplaca (cdr magic) (cdr methods))) + ; so maybe its a combined-method ?? - no + (apply-with-method-context magic (%method.function car-meths) args))))) + +;;; args is list, old-args may be lexpr +(defun cmp-args-old-args (args old-args numreq) + (declare (optimize (speed 3)(safety 0))) + (if (listp old-args) + (do ((newl args (cdr newl)) + (oldl old-args (cdr oldl)) + (i 0 (1+ i))) + ((eql i numreq) t) + (when (neq (car newl)(car oldl))(return nil))) + (let ((len (%lexpr-count old-args))) + (do ((newl args (cdr newl)) + (i 0 (1+ i))) + ((eql i numreq) t) + (when (neq (car newl)(%lexpr-ref old-args len i))(return nil)))))) + + +; called from call-next-method-with-args with magic supplied and 1st time around with not +(defun %%cnm-with-args-combined-method-dcode (thing args &optional magic) ; was &rest args + ;(declare (dynamic-extent args)) + ; now thing is vector of gf orig methods, arg for key or initarg check, key or initarg fnction + ; and our job is to do all the arg checking + (let () + ;; THING is nil in next-method calls for non-standard method combination. To enable + ;; checking in that case, would need to change %%call-method* to store a vector in (car magic). + (when (and magic thing) + (flet ((do-it (thing args) + (let* ((args-len (length args)) + (gf (svref thing 0)) ; could get this from a method + (numreq (ldb $lfbits-numreq (inner-lfun-bits gf))) + (next-methods (cadr magic))) + ;(when (null self)(error "Next method with args context error")) + (when (neq 0 numreq) + ; oh screw it - old-args may be lexpr too + (let ((old-args (cddr magic))) + (when (< args-len numreq) (signal-program-error "Too few args to ~S" gf)) + (when (null (cmp-args-old-args args old-args numreq)) + ; required args not eq - usually true, we expect + (let ((new-methods (%compute-applicable-methods* gf args)) + (old-methods (svref thing 1))) + (when (not (equal new-methods old-methods)) + (error '"Applicable-methods changed in call-next-method.~%~ + Should be: ~s~%Was: ~s~%Next-methods: ~s" + old-methods new-methods next-methods)))))) + (let ((key-or-init-fn (svref thing 3))) + (when key-or-init-fn + ; was apply + (funcall key-or-init-fn (svref thing 2) args)))))) + (if (listp args) + (do-it thing args) + (with-list-from-lexpr (args-list args) + (do-it thing args-list))))) + ; ok done checking - lets do it + (let* ((methods (if magic (cadr magic)(svref thing 4))) ;<< was 5 this is nil unless cnm with args + ; was if magic + (car-meths (car methods)) + (cell-2 (cons methods args)) + (magic (cons thing cell-2))) + (declare (dynamic-extent magic cell-2)) + ; i.e. magic is thing methods . args + ;(%rplaca magic thing) + ;(setf (cadr magic) methods) + ;(%rplaca (cdr magic) methods) + ;(setf (cddr magic) args) + ;(%rplacd (cdr magic) args) + (if (listp car-meths) + (progn + (%%before-and-after-combined-method-dcode magic)) + (progn + (if (not (cdr methods)) + (%rplaca (cdr magic) car-meths) + (%rplaca (cdr magic) (cdr methods))) + ; so maybe its a combined-method ?? - no + (apply-with-method-context magic (%method.function car-meths) args)))))) + + + +;;; here if car of methods is listp. methods = (befores afters . primaries) +(defun %%before-and-after-combined-method-dcode (magic) + (declare (list magic)) + (let* ((methods (cadr magic)) + (befores (car methods)) + (cdr-meths (cdr methods)) + (primaries (cdr cdr-meths)) + (afters (car cdr-meths)) + (args (cddr magic))) + (declare (list befores afters primaries)) + (when befores + (dolist (method befores) + (rplaca (cdr magic) method) + (apply-with-method-context magic (%method.function method) args))) + (let* ((cdr (cdr primaries)) + (method-function (%method.function (car primaries)))) ; guaranteed non nil? + (rplaca (cdr magic) (if (null cdr)(car primaries) cdr)) + (if (null afters) + (apply-with-method-context magic method-function args) ; tail call if possible + (multiple-value-prog1 + (apply-with-method-context magic method-function args) + (dolist (method afters) + (rplaca (cdr magic) method) + (apply-with-method-context magic (%method.function method) args))))))) + + +; This is called by the compiler expansion of next-method-p +; I think there's a bug going around... LAP fever! I'm immune +(defun %next-method-p (magic) + (let ((methods (%cadr magic))) + (consp methods))) + + +(defun %call-next-method (magic &rest args) ; if args supplied they are new ones + (declare (dynamic-extent args)) + (if args + (apply #'%call-next-method-with-args magic args) + (let* ((next-methods (%cadr magic))) ; don't get this closed magic stuff + (if (not (consp next-methods)) + ( %no-next-method magic) + (let ((args (%cddr magic))) ; get original args + ;The unwind-protect is needed in case some hacker in his/her wisdom decides to: + ; (defmethod foo (x) (catch 'foo (call-next-method)) (call-next-method)) + ; where the next-method throws to 'foo. + ; The alternative is to make a new magic var with args + ; actually not that fancy (call-next-method)(call-next-method) is same problem + (let () + (unwind-protect + (if (listp (car next-methods)) + ( %%before-and-after-combined-method-dcode magic) + (let ((cdr (cdr next-methods))) + (rplaca (cdr magic)(if (not cdr)(car next-methods) cdr)) + (let ((method-function (%method.function (car next-methods)))) + (apply-with-method-context magic method-function args)))) + (rplaca (cdr magic) next-methods)))))))) + +;; Note: we need to change the compiler to call this when it can prove that +;; call-next-method cannot be called a second time. I believe thats done. + + +(defun %tail-call-next-method (magic) + (let* ((next-methods (%cadr magic)) ; or make it car + (args (%cddr magic))) ; get original args + (if (not (consp next-methods)) ; or consp? + ( %no-next-method magic) + (if (listp (car next-methods)) + ( %%before-and-after-combined-method-dcode magic) + (let ((cdr (cdr next-methods))) + (rplaca (cdr magic) (if (not cdr)(car next-methods) cdr)) + (apply-with-method-context magic (%method.function (car next-methods)) args)))))) + +;;; may be simpler to blow another cell so magic looks like +;;; (cnm-cm/nil next-methods . args) - done +;;; and also use first cell to mean heap-consed if itsa cons + +(defun %call-next-method-with-args (magic &rest args) + (declare (dynamic-extent args)) + (if (null args) + (%call-next-method magic) + (let* ((methods (%cadr magic))) + (if (not (consp methods)) + (%no-next-method magic) + (let* ((cnm-cm (car magic))) + ; a combined method + (when (consp cnm-cm)(setq cnm-cm (car cnm-cm))) + ; could just put the vector in car magic & no self needed in vector? + (let ((the-vect cnm-cm)) ; << + (funcall #'%%cnm-with-args-combined-method-dcode ;(%combined-method-dcode cnm-cm) + the-vect + args + magic))))))) + + + +; called from x%%call-next-method-with-args - its the key-or-init-fn +(defun %%cnm-with-args-check-initargs (init-cell args) + ; here we forget the lexpr idea because it wants to cdr + ;(declare (dynamic-extent args)) + (let* ((rest (cdr args)) + (first-arg (car args))) + (declare (list rest)) + (let* ((initargs rest) + (init-function (car init-cell)) + (instance (cond ((eq init-function #'update-instance-for-different-class) + (setq initargs (cdr rest)) + (car rest)) + ((eq init-function #'shared-initialize) + (setq initargs (cdr rest)) + first-arg) + ((eq init-function #'update-instance-for-redefined-class) + (setq initargs (%cdddr rest)) + first-arg) + (t first-arg))) + (class (class-of instance)) + bad-initarg) + (dolist (functions (cdr init-cell) + (error "Bad initarg: ~s to call-next-method for ~s~%on ~s" + bad-initarg instance (car init-cell))) + (multiple-value-bind + (errorp bad-key) + (if (eq (car functions) #'initialize-instance) + (apply #'check-initargs instance class initargs nil + #'initialize-instance #'allocate-instance #'shared-initialize + nil) + (apply #'check-initargs instance class initargs nil functions)) + (if errorp + (unless bad-initarg (setq bad-initarg bad-key)) + (return t))))))) + + + +(defun %no-next-method (magic) + (let* ((method (%cadr magic))) + (if (consp method) (setq method (car method))) + (unless (typep method 'standard-method) + (error "call-next-method called outside of generic-function dispatch context.~@ + Usually indicates an error in a define-method-combination form.")) + (let ((args (cddr magic)) + (gf (%method.gf method))) + (if (listp args) + (apply #'no-next-method gf method args) + (%apply-lexpr #'no-next-method gf method args))))) + + + + +;;; This makes a consed version of the magic first arg to a method. +;;; Called when someone closes over the magic arg. (i.e. does (george +;;; #'call-next-method)) + +(defun %cons-magic-next-method-arg (magic) + ; car is a cons as a flag that its already heap-consed! - else cnm-cm or nil + (if (consp (car magic)) + magic + (list* (list (car magic)) + (if (consp (%cadr magic)) + (copy-list (%cadr magic)) ; is this copy needed - probably not + (cadr magic)) + (let ((args (%cddr magic))) + (if (listp args) + (copy-list args) + (let* ((len (%lexpr-count args)) + (l (make-list len))) + (do ((i 0 (1+ i)) + (list l (cdr list))) + ((null list)) + (%rplaca list (%lexpr-ref args len i))) + l)))))) + + +; Support CALL-METHOD in DEFINE-METHOD-COMBINATION +(defun %%call-method* (method next-methods args) + (let* ((method-function (%method.function method)) + (bits (lfun-bits method-function))) + (declare (fixnum bits)) + (if (not (and (logbitp $lfbits-nextmeth-bit bits) + (logbitp $lfbits-method-bit bits))) + (if (listp args) + (apply method-function args) + (%apply-lexpr method-function args)) + (let* ((cell-2 (cons next-methods args)) + (magic (cons nil cell-2))) + (declare (dynamic-extent magic) + (dynamic-extent cell-2)) + (if (null next-methods) + (%rplaca (cdr magic) method)) + (apply-with-method-context magic method-function args))))) + +; Error checking version for user's to call +(defun %call-method* (method next-methods args) + (let* ((method-function (%method.function method)) + (bits (lfun-bits method-function))) + (declare (fixnum bits)) + (if (not (and (logbitp $lfbits-nextmeth-bit bits) + (logbitp $lfbits-method-bit bits))) + (progn + (require-type method 'standard-method) + (if (listp args) + (apply method-function args) + (%apply-lexpr method-function args))) + (progn + (do* ((list next-methods (cdr list))) + ((null list)) + (when (not (listp list)) + (%err-disp $XIMPROPERLIST next-methods)) + (when (not (standard-method-p (car list))) + (report-bad-arg (car list) 'standard-method))) + (let* ((cell-2 (cons next-methods args)) + (magic (cons nil cell-2))) + (declare (dynamic-extent magic) + (dynamic-extent cell-2)) + (if (null next-methods) + (%rplaca (cdr magic) method)) + (apply-with-method-context magic method-function args)))))) + + + Index: /branches/new-random/level-1/l1-error-signal.lisp =================================================================== --- /branches/new-random/level-1/l1-error-signal.lisp (revision 13309) +++ /branches/new-random/level-1/l1-error-signal.lisp (revision 13309) @@ -0,0 +1,158 @@ +;;;-*-Mode: LISP; Package: CCL -*- +;;; +;;; Copyright (C) 2009 Clozure Associates +;;; Copyright (C) 1994-2001 Digitool, Inc +;;; This file is part of Clozure CL. +;;; +;;; Clozure CL is licensed under the terms of the Lisp Lesser GNU Public +;;; License , known as the LLGPL and distributed with Clozure CL as the +;;; file "LICENSE". The LLGPL consists of a preamble and the LGPL, +;;; which is distributed with Clozure CL as the file "LGPL". Where these +;;; conflict, the preamble takes precedence. +;;; +;;; Clozure CL is referenced in the preamble as the "LIBRARY." +;;; +;;; The LLGPL is also available online at +;;; http://opensource.franz.com/preamble.html + +(in-package "CCL") + +(defun %kernel-restart (error-type &rest args) + (%kernel-restart-internal error-type args (%get-frame-ptr))) + +(defun %kernel-restart-internal (error-type args frame-ptr) + ;(declare (dynamic-extent args)) + (dolist (f *kernel-restarts* (%err-disp-internal error-type args frame-ptr)) + (when (eq (car f) error-type) + (return (apply (cdr f) frame-ptr args))))) + +;;; this is the def of %err-disp. +;;; Yup. That was my first guess. +(defun %err-disp (err-num &rest errargs) + (%err-disp-internal err-num errargs (%get-frame-ptr))) + +(defun %errno-disp (errno &rest errargs) + (%errno-disp-internal errno errargs (%get-frame-ptr))) + +#+windows-target +(defun %windows-error-disp (errno &rest errargs) + (%err-disp-common errno 0 (%windows-error-string errno) errargs (%get-frame-ptr))) + +(defun %errno-disp-internal (errno errargs frame-ptr) + (declare (fixnum errno)) + (let* ((err-type (max (ash errno -16) 0)) + (errno (%word-to-int errno)) + (error-string (%strerror errno)) + (format-string (if errargs + (format nil "~a : ~a" error-string "~s") + error-string))) + (%err-disp-common nil err-type format-string errargs frame-ptr))) + + +(defun %err-disp-internal (err-num errargs frame-ptr) + (declare (fixnum err-num)) + ;;; The compiler (finally !) won't tail-apply error. But we kind of + ;;; expect it to ... + (let* ((err-typ (max (ash err-num -16) 0)) + (err-num (%word-to-int err-num)) + (format-string (%rsc-string err-num))) + (%err-disp-common err-num err-typ format-string errargs frame-ptr))) + +(defparameter *foreign-error-condition-recognizers* ()) + + +(defun %err-disp-common (err-num err-typ format-string errargs frame-ptr) + (let* ((condition-name (or (uvref *simple-error-types* err-typ) + (%cdr (assq err-num *kernel-simple-error-classes*))))) + ;;(dbg format-string) + (if condition-name + (funcall '%error + (case condition-name + (type-error + (if (cdr errargs) + (make-condition condition-name + :format-control format-string + :datum (car errargs) + :expected-type (%type-error-type (cadr errargs))) + (make-condition condition-name + :format-control format-string + :datum (car errargs)))) + (improper-list (make-condition condition-name + :datum (car errargs))) + (simple-file-error (make-condition condition-name + :pathname (car errargs) + :error-type format-string + :format-arguments (cdr errargs))) + (undefined-function (make-condition condition-name + :name (car errargs))) + (call-special-operator-or-macro + (make-condition condition-name + :name (car errargs) + :function-arguments (cadr errargs))) + (sequence-index-type-error + (make-sequence-index-type-error (car errargs) (cadr errargs))) + (cant-construct-arglist + (make-condition condition-name + :datum (car errargs) + :format-control format-string)) + (array-element-type-error + (let* ((array (cadr errargs))) + (make-condition condition-name + :format-control format-string + :datum (car errargs) + :expected-type (array-element-type array) + :array array))) + + (t (make-condition condition-name + :format-control format-string + :format-arguments errargs))) + nil + frame-ptr) + (let* ((cond nil)) + (if (and (eql err-num $XFOREIGNEXCEPTION) + (dolist (recog *foreign-error-condition-recognizers*) + (let* ((c (funcall recog (car errargs)))) + (when c (return (setq cond c)))))) + (funcall '%error cond nil frame-ptr) + (funcall '%error format-string errargs frame-ptr)))))) + +(defun error (condition &rest args) + "Invoke the signal facility on a condition formed from DATUM and ARGUMENTS. + If the condition is not handled, the debugger is invoked." + #| + #+ppc-target + (with-pstrs ((pstr (if (stringp condition) condition "Error"))) + (#_DebugStr pstr)) + |# + (%error condition args (%get-frame-ptr))) + +(defun cerror (cont-string condition &rest args) + (let* ((fp (%get-frame-ptr))) + (restart-case (%error condition (if (condition-p condition) nil args) fp) + (continue () + :report (lambda (stream) + (apply #'format stream cont-string args)) + nil)))) + +(defun %error (condition args error-pointer) + (setq *error-reentry-count* 0) + (setq condition (condition-arg condition args 'simple-error)) + (signal condition) + (unless *interactive-streams-initialized* + (bug (format nil "Error during early application initialization:~% +~a" condition)) + (#_exit #-windows-target #$EX_SOFTWARE #+windows-target #$EXIT_FAILURE)) + (application-error *application* condition error-pointer) + (application-error + *application* + (condition-arg "~s returned. It shouldn't.~%If it returns again, I'll throw to toplevel." + '(application-error) 'simple-error) + error-pointer) + (toplevel)) + +(defun make-sequence-index-type-error (idx sequence) + (let* ((upper (length sequence))) + (make-condition 'sequence-index-type-error + :datum idx + :sequence sequence + :expected-type `(integer 0 (,upper))))) Index: /branches/new-random/level-1/l1-error-system.lisp =================================================================== --- /branches/new-random/level-1/l1-error-system.lisp (revision 13309) +++ /branches/new-random/level-1/l1-error-system.lisp (revision 13309) @@ -0,0 +1,1329 @@ +;;;-*-Mode: LISP; Package: CCL -*- +;;; +;;; Copyright (C) 2009 Clozure Associates +;;; Copyright (C) 1994-2001 Digitool, Inc +;;; This file is part of Clozure CL. +;;; +;;; Clozure CL is licensed under the terms of the Lisp Lesser GNU Public +;;; License , known as the LLGPL and distributed with Clozure CL as the +;;; file "LICENSE". The LLGPL consists of a preamble and the LGPL, +;;; which is distributed with Clozure CL as the file "LGPL". Where these +;;; conflict, the preamble takes precedence. +;;; +;;; Clozure CL is referenced in the preamble as the "LIBRARY." +;;; +;;; The LLGPL is also available online at +;;; http://opensource.franz.com/preamble.html + + +;;; This file contains the error/condition system. Functions that +;;; signal/handle errors are defined later. + +(in-package "CCL") + +;;;*********************************** +;;; Error System +;;;*********************************** + +(defclass condition () ()) +(defclass warning (condition) ()) +(defclass serious-condition (condition) ()) +(defclass error (serious-condition) ()) + +(define-condition simple-condition (condition) + ((format-control :initarg :format-control + :reader simple-condition-format-control) + (format-arguments :initarg :format-arguments + :initform nil + :reader simple-condition-format-arguments)) + (:report (lambda (c stream) ;; If this were a method, slot value might be faster someday. Accessors always faster ? + ;; And of course it's terribly important that this be as fast as humanly possible... + ;Use accessors because they're documented and users can specialize them. + (apply #'format stream (simple-condition-format-control c) + (simple-condition-format-arguments c))))) + + +(define-condition storage-condition (serious-condition) ()) + +(define-condition thread-condition (serious-condition) ()) + +(define-condition process-reset (thread-condition) + ((kill :initarg :kill :initform nil :reader process-reset-kill))) + + +(define-condition print-not-readable (error) + ((object :initarg :object :reader print-not-readable-object) + (stream :initarg :stream :reader print-not-readable-stream)) + (:report (lambda (c stream) + (let* ((*print-readably* nil)) + (format stream "Attempt to print object ~S on stream ~S ." + (print-not-readable-object c) + (print-not-readable-stream c)))))) + +(define-condition simple-warning (simple-condition warning) ()) + +(define-condition compiler-warning (warning) + ((function-name :initarg :function-name :initform nil :accessor compiler-warning-function-name) + (source-note :initarg :source-note :initform nil :accessor compiler-warning-source-note) + (warning-type :initarg :warning-type :reader compiler-warning-warning-type) + (args :initarg :args :reader compiler-warning-args) + (nrefs :initform () :accessor compiler-warning-nrefs)) + (:report report-compiler-warning)) + +;; Backward compatibility +(defmethod compiler-warning-file-name ((w compiler-warning)) + (source-note-filename (compiler-warning-source-note w))) + +(define-condition style-warning (compiler-warning) + ((warning-type :initform :unsure) + (args :initform nil))) +(define-condition undefined-reference (style-warning) ()) +(define-condition undefined-type-reference (undefined-reference) ()) +(define-condition undefined-function-reference (undefined-reference) ()) +(define-condition macro-used-before-definition (compiler-warning) ()) +(define-condition invalid-type-warning (style-warning) ()) +(define-condition invalid-arguments (style-warning) ()) +(define-condition invalid-arguments-global (style-warning) ()) +(define-condition undefined-keyword-reference (undefined-reference invalid-arguments) ()) + +(define-condition simple-error (simple-condition error) ()) + +(define-condition simple-storage-condition (simple-condition storage-condition) ()) +(define-condition stack-overflow-condition (simple-storage-condition) ()) + +(define-condition invalid-memory-access (storage-condition) + ((address :initarg :address) + (write-p :initform nil :initarg :write-p)) + (:report (lambda (c s) + (with-slots (address write-p) c + (format s "Fault during ~a memory address #x~x" (if write-p "write to" "read of") address))))) + +(define-condition invalid-memory-operation (storage-condition) + () + (:report (lambda (c s) + (declare (ignore c)) + (format s "Invalid memory operation.")))) + +(define-condition write-to-watched-object (storage-condition) + ((object :initform nil :initarg :object + :reader write-to-watched-object-object) + (offset :initarg :offset + :reader write-to-watched-object-offset) + (instruction :initarg :instruction + :reader write-to-watched-object-instruction)) + (:report report-write-to-watched-object)) + +(defun report-write-to-watched-object (c s) + (with-slots (object offset instruction) c + (cond + ((uvectorp object) + (let* ((count (uvsize object)) + (nbytes (if (ivectorp object) + (subtag-bytes (typecode object) count) + (* count target::node-size))) + (bytes-per-element (/ nbytes count)) + (offset (- offset target::misc-data-offset)) + (index (/ offset bytes-per-element))) + (format s "Write to watched uvector ~s at " object) + (if (fixnump index) + (format s "index ~s" index) + (format s "an apparently unaligned byte offset ~s" offset)))) + ((consp object) + (format s "Write to ~a watched cons cell ~s" + (cond + ((= offset target::cons.cdr) "the CDR of") + ((= offset target::cons.car) "the CAR of") + (t + (format nil "an apparently unaligned byte offset (~s) into" + offset))) + object)) + (t + (format s "Write to a strange object ~s at byte offset ~s" + object offset))) + (when instruction + (format s "~&Faulting instruction: ~s" instruction)))) + +(define-condition type-error (error) + ((datum :initarg :datum) + (expected-type :initarg :expected-type :reader type-error-expected-type) + (format-control :initarg :format-control :initform (%rsc-string $xwrongtype) :reader type-error-format-control)) + (:report (lambda (c s) + (format s (type-error-format-control c) + (type-error-datum c) + (type-error-expected-type c))))) + +(define-condition bad-slot-type (type-error) + ((slot-definition :initform nil :initarg :slot-definition) + (instance :initform nil :initarg :instance)) + (:report (lambda (c s) + (format s "The value ~s can not be used to set the value of the slot ~s in ~s, because it is not of type ~s. " + (type-error-datum c) + (slot-definition-name (slot-value c 'slot-definition)) + (slot-value c 'instance) + (type-error-expected-type c))))) + +(define-condition bad-slot-type-from-initform (bad-slot-type) + () + (:report (lambda (c s) + (let* ((slotd (slot-value c 'slot-definition))) + (format s "The value ~s, derived from the initform ~s, can not be used to set the value of the slot ~s in ~s, because it is not of type ~s. " + (type-error-datum c) + (slot-definition-initform slotd) + (slot-definition-name slotd) + (slot-value c 'instance) + (type-error-expected-type c)))))) + +(define-condition bad-slot-type-from-initarg (bad-slot-type) + ((initarg-name :initarg :initarg-name)) + (:report (lambda (c s) + (let* ((slotd (slot-value c 'slot-definition))) + (format s "The value ~s, derived from the initarg ~s, can not be used to set the value of the slot ~s in ~s, because it is not of type ~s. " + (type-error-datum c) + (slot-value c 'initarg-name) + (slot-definition-name slotd) + (slot-value c 'instance) + (type-error-expected-type c)))))) + + +(define-condition improper-list (type-error) + ((expected-type :initform '(satisfies proper-list-p) :reader type-error-expected-type))) + +(define-condition cant-construct-arglist (improper-list) + ()) + + +(let* ((magic-token '("Unbound"))) + (defmethod type-error-datum ((c type-error)) + (let* ((datum-slot (slot-value c 'datum))) + (if (eq magic-token datum-slot) + (%unbound-marker-8) + datum-slot))) + +; do we need this + (defun signal-type-error (datum expected &optional (format-string (%rsc-string $xwrongtype))) + (let ((error #'error)) + (funcall error (make-condition 'type-error + :format-control format-string + :datum (if (eq datum (%unbound-marker-8)) magic-token datum) + :expected-type (%type-error-type expected))))) +) + + +(define-condition sequence-index-type-error (type-error) + ((sequence :initarg :sequence)) + (:report (lambda (c s) + (format s "~s is not a valid sequence index for ~s" + (type-error-datum c) + (slot-value c 'sequence))))) + + +;;; This is admittedly sleazy; ANSI CL requires TYPE-ERRORs to be +;;; signalled in cases where a type-specifier is not of an appropriate +;;; subtype. The sleazy part is whether it's right to overload TYPE-ERROR +;;; like this. + +(define-condition invalid-subtype-error (type-error) + () + (:report (lambda (c s) + (format s "The type specifier ~S is not determinably a subtype of the type ~S" + (type-error-datum c) + (type-error-expected-type c))))) + +(define-condition simple-type-error (simple-condition type-error) ()) + +(define-condition array-element-type-error (simple-type-error) + ((array :initarg :array :reader array-element-type-error-array)) + (:report (lambda (c s) + (format s (simple-condition-format-control c) + (type-error-datum c) + (array-element-type-error-array c))))) + + + + + +(define-condition program-error (error) ()) +(define-condition simple-program-error (simple-condition program-error) + ((context :initarg :context :reader simple-program-error-context :initform nil))) + +(define-condition invalid-type-specifier (program-error) + ((typespec :initarg :typespec :reader invalid-type-specifier-typespec)) + (:report (lambda (c s) + (with-slots (typespec) c + (format s "Invalid type specifier: ~s ." typespec))))) + +(defun signal-program-error (string &rest args) + (let* ((e #'error)) + (funcall e + (make-condition 'simple-program-error + :format-control (if (fixnump string) (%rsc-string string) string) + :format-arguments args)))) + +(define-condition simple-destructuring-error (simple-program-error) ()) + +(define-condition wrong-number-of-arguments (program-error) + ((nargs :initform nil + :initarg :nargs :reader wrong-number-of-arguments-nargs) + (fn :initform nil :initarg :fn :reader wrong-number-of-arguments-fn)) + (:report report-argument-mismatch)) + +(define-condition too-many-arguments (wrong-number-of-arguments) ()) + +(define-condition too-few-arguments (wrong-number-of-arguments) ()) + +(defun report-argument-mismatch (c s) + (let* ((nargs-provided (wrong-number-of-arguments-nargs c)) + (fn (wrong-number-of-arguments-fn c)) + (too-many (typep c 'too-many-arguments))) + (multiple-value-bind (min max scaled-nargs) + (min-max-actual-args fn nargs-provided) + (if (not min) + (progn + (format s "Function ~s called with too ~a arguments. " + fn + (if too-many + "many" + "few"))) + (if too-many + (format s "Too many arguments in call to ~s:~&~d argument~:p provided, at most ~d accepted. " fn scaled-nargs max) + (format s "Too few arguments in call to ~s:~&~d argument~:p provided, at least ~d required. " fn scaled-nargs min)))))) + + + +(define-condition compile-time-program-error (simple-program-error) + nil ;((context :initarg :context :reader compile-time-program-error-context)) + (:report + (lambda (c s) + (format s "While compiling ~a :~%~a" + (simple-program-error-context c) + (apply #'format nil (simple-condition-format-control c) (simple-condition-format-arguments c)))))) + + + +;;; Miscellaneous error during compilation (caused by macroexpansion, transforms, compile-time evaluation, etc.) +;;; NOT program-errors. +(define-condition compile-time-error (simple-error) + ((context :initarg :context :reader compile-time-error-context)) + (:report + (lambda (c s) + (format s "While compiling ~a :~%~a" + (compile-time-error-context c) + (format nil "~a" c))))) + +(define-condition control-error (error) ()) + +(define-condition cant-throw-error (control-error) + ((tag :initarg :tag)) + (:report (lambda (c s) + (format s "Can't throw to tag ~s" (slot-value c 'tag))))) + +(define-condition inactive-restart (control-error) + ((restart-name :initarg :restart-name)) + (:report (lambda (c s) + (format s "Restart ~s is not active" (slot-value c 'restart-name))))) + +(define-condition lock-protocol-error (control-error) + ((lock :initarg :lock))) + +(define-condition not-lock-owner (lock-protocol-error) + () + (:report (lambda (c s) + (format s "Current process ~s does not own lock ~s" + *current-process* (slot-value c 'lock))))) + +(define-condition not-locked (lock-protocol-error) + () + (:report (lambda (c s) + (format s "Lock ~s isn't locked." (slot-value c 'lock))))) + +(define-condition deadlock (lock-protocol-error) + () + (:report (lambda (c s) + (format s "Requested operation on ~s would cause deadlock." (slot-value c 'lock))))) + +(define-condition package-error (error) + ((package :initarg :package :reader package-error-package))) +(define-condition no-such-package (package-error) + () + (:report (lambda (c s) (format s (%rsc-string $xnopkg) (package-error-package c))))) +(define-condition unintern-conflict-error (package-error) + ((sym-to-unintern :initarg :sym) + (conflicting-syms :initarg :conflicts)) + (:report (lambda (c s) + (format s (%rsc-string $xunintc) (slot-value c 'sym-to-unintern) (package-error-package c) (slot-value c 'conflicting-syms))))) + +(define-condition import-conflict-error (package-error) + ((imported-sym :initarg :imported-sym) + (conflicting-sym :initarg :conflicting-sym) + (conflict-external-p :initarg :conflict-external)) + (:report (lambda (c s) + (format s (%rsc-string (if (slot-value c 'conflict-external-p) $ximprtcx $ximprtc)) + (slot-value c 'imported-sym) + (package-error-package c) + (slot-value c 'conflicting-sym))))) + +(define-condition use-package-conflict-error (package-error) + ((package-to-use :initarg :package-to-use) + (conflicts :initarg :conflicts) + (external-p :initarg :external-p)) + (:report (lambda (c s) + (format s (%rsc-string (if (slot-value c 'external-p) $xusecX $xusec)) + (slot-value c 'package-to-use) + (package-error-package c) + (slot-value c 'conflicts))))) + +(define-condition export-conflict-error (package-error) + ((conflicts :initarg :conflicts)) + (:report + (lambda (c s) + (format s "Name conflict~p detected by ~A :" (length (slot-value c 'conflicts)) 'export) + (let* ((package (package-error-package c))) + (dolist (conflict (slot-value c 'conflicts)) + (destructuring-bind (inherited-p sym-to-export using-package conflicting-sym) conflict + (format s "~&~A'ing ~S from ~S would cause a name conflict with ~&~ + the ~a symbol ~S in the package ~s, which uses ~S." + 'export + sym-to-export + package + (if inherited-p "inherited" "present") + conflicting-sym + using-package + package))))))) + +(define-condition export-requires-import (package-error) + ((to-be-imported :initarg :to-be-imported)) + (:report + (lambda (c s) + (let* ((p (package-error-package c))) + (format s "The following symbols need to be imported to ~S before they can be exported ~& from that package:~%~s:" p (slot-value c 'to-be-imported)))))) + + +(define-condition package-name-conflict-error (package-error simple-error) ()) + +(define-condition package-is-used-by (package-error) + ((using-packages :initarg :using-packages)) + (:report (lambda (c s) + (format s "~S is used by ~S" (package-error-package c) + (slot-value c 'using-packages))))) + +(define-condition symbol-name-not-accessible (package-error) + ((symbol-name :initarg :symbol-name)) + (:report (lambda (c s) + (format s "No aymbol named ~S is accessible in package ~s" + (slot-value c 'symbol-name) + (package-error-package c))))) + +(define-condition stream-error (error) + ((stream :initarg :stream :reader stream-error-stream))) + +(defun stream-error-context (condition) + (let* ((stream (stream-error-stream condition))) + (with-output-to-string (s) + (format s "on ~s" stream) + (let* ((pos (ignore-errors (stream-position stream)))) + (when pos + (format s ", near position ~d" pos))) + (let* ((surrounding (stream-surrounding-characters stream))) + (when surrounding + (format s ", within ~s" surrounding)))))) + +(define-condition parse-error (error) ()) +(define-condition parse-integer-not-integer-string (parse-error) + ((string :initarg :string)) + (:report (lambda (c s) + (format s "Not an integer string: ~s" (slot-value c 'string))))) + +(define-condition reader-error (parse-error stream-error) ()) +(define-condition end-of-file (stream-error) () + (:report (lambda (c s) + (format s "Unexpected end of file ~a" (stream-error-context c))))) + +(define-condition io-timeout (stream-error) + ()) + +(define-condition input-timeout (io-timeout) + () + (:report (lambda (c s) + (format s "Input timeout on ~s" (stream-error-stream c))))) +(define-condition output-timeout (io-timeout) + () + (:report (lambda (c s) + (format s "Output timeout on ~s" (stream-error-stream c))))) +(define-condition communication-deadline-expired (io-timeout) + () + (:report (lambda (c s) + (format s "Communication deadline timeout on ~s" (stream-error-stream c))))) + + + + +(define-condition impossible-number (reader-error) + ((token :initarg :token :reader impossible-number-token) + (condition :initarg :condition :reader impossible-number-condition)) + (:report (lambda (c s) + (format s "Condition of type ~s raised ~&while trying to parse numeric token ~s ~&~s" + (type-of (impossible-number-condition c)) + (impossible-number-token c) + (stream-error-context c))))) + + + +(define-condition simple-stream-error (stream-error simple-condition) () + (:report (lambda (c s) + (format s "~a : ~&~a" (stream-error-context c) + (apply #'format + nil + (simple-condition-format-control c) + (simple-condition-format-arguments c)))))) + + + + +(define-condition file-error (error) + ((pathname :initarg :pathname :initform "" :reader file-error-pathname) + (error-type :initarg :error-type :initform "File error on file ~S")) + (:report (lambda (c s) + (format s (slot-value c 'error-type) + (file-error-pathname c))))) + +(define-condition simple-file-error (simple-condition file-error) + () + (:report (lambda (c s) + (apply #'format s (slot-value c 'error-type) + (file-error-pathname c) + (simple-condition-format-arguments c))))) + + +(define-condition namestring-parse-error (error) + ((complaint :reader namestring-parse-error-complaint :initarg :complaint) + (arguments :reader namestring-parse-error-arguments :initarg :arguments + :initform nil) + (namestring :reader namestring-parse-error-namestring :initarg :namestring) + (offset :reader namestring-parse-error-offset :initarg :offset)) + (:report (lambda (condition stream) + (format stream "Parse error in namestring: ~?~% ~A~% ~V@T^" + (namestring-parse-error-complaint condition) + (namestring-parse-error-arguments condition) + (namestring-parse-error-namestring condition) + (namestring-parse-error-offset condition))))) + +(define-condition cell-error (error) + ((name :initarg :name :reader cell-error-name) + (error-type :initarg :error-type :initform "Cell error" :reader cell-error-type)) + (:report (lambda (c s) (format s "~A: ~S" (cell-error-type c) (cell-error-name c))))) + +(define-condition unbound-variable (cell-error) + ((error-type :initform "Unbound variable"))) + +(define-condition undefined-function (cell-error) + ((error-type :initform "Undefined function"))) +(define-condition undefined-function-call (control-error undefined-function) + ((function-arguments :initarg :function-arguments :reader undefined-function-call-arguments)) + (:report (lambda (c s) (format s "Undefined function ~S called with arguments ~:S ." + (cell-error-name c) + (undefined-function-call-arguments c))))) + +(define-condition call-special-operator-or-macro (undefined-function-call) + () + (:report (lambda (c s) (format s "Special operator or global macro-function ~s can't be FUNCALLed or APPLYed" (cell-error-name c))))) + + +(define-condition unbound-slot (cell-error) + ((instance :initarg :instance :accessor unbound-slot-instance)) + (:report (lambda (c s) (format s "Slot ~s is unbound in ~s" + (cell-error-name c) + (unbound-slot-instance c))))) + + +(define-condition arithmetic-error (error) + ((operation :initform nil :initarg :operation :reader arithmetic-error-operation) + (operands :initform nil :initarg :operands :reader arithmetic-error-operands) + (status :initform nil :initarg :status :reader arithmetic-error-status)) + (:report (lambda (c s) + (format s "~S detected" (type-of c)) + (let* ((operands (arithmetic-error-operands c))) + (when operands + (format s "~&performing ~A on ~:S" + (arithmetic-error-operation c) + operands)))))) + +(define-condition division-by-zero (arithmetic-error) ()) + +(define-condition floating-point-underflow (arithmetic-error) ()) +(define-condition floating-point-overflow (arithmetic-error) ()) +(define-condition floating-point-inexact (arithmetic-error) ()) +(define-condition floating-point-invalid-operation (arithmetic-error) ()) + +(define-condition compiler-bug (simple-error) + () + (:report (lambda (c stream) + (format stream "Compiler bug or inconsistency:~%") + (apply #'format stream (simple-condition-format-control c) + (simple-condition-format-arguments c))))) + +(define-condition external-process-creation-failure (serious-condition) + ((proc :initarg :proc)) + (:report (lambda (c stream) + (with-slots (proc) c + (let* ((code (external-process-%exit-code proc))) + (format stream "Fork failed in ~s: ~a. " proc (if (eql code -1) "random lisp error" (%strerror code)))))))) + + +(defun restartp (thing) + (istruct-typep thing 'restart)) +(setf (type-predicate 'restart) 'restartp) + +(defmethod print-object ((restart restart) stream) + (let ((report (%restart-report restart))) + (cond ((or *print-escape* (null report)) + (print-unreadable-object (restart stream :identity t) + (format stream "~S ~S" + 'restart (%restart-name restart)))) + ((stringp report) + (write-string report stream)) + (t + (funcall report stream))))) + +(defun %make-restart (name action report interactive test) + (%cons-restart name action report interactive test)) + +(defun make-restart (vector name action-function &key report-function interactive-function test-function) + (unless vector (setq vector (%cons-restart nil nil nil nil nil))) + (setf (%restart-name vector) name + (%restart-action vector) (require-type action-function 'function) + (%restart-report vector) (if report-function (require-type report-function 'function)) + (%restart-interactive vector) (if interactive-function (require-type interactive-function 'function)) + (%restart-test vector) (if test-function (require-type test-function 'function))) + vector) + +(defun restart-name (restart) + "Return the name of the given restart object." + (%restart-name (require-type restart 'restart))) + +(defun applicable-restart-p (restart condition) + (let* ((pair (if condition (assq restart *condition-restarts*))) + (test (%restart-test restart))) + (and (or (null pair) (eq (%cdr pair) condition)) + (or (null test) (funcall test condition))))) + +(defun compute-restarts (&optional condition &aux restarts) + "Return a list of all the currently active restarts ordered from most + recently established to less recently established. If CONDITION is + specified, then only restarts associated with CONDITION (or with no + condition) will be returned." + (dolist (cluster %restarts% (nreverse restarts)) + (dolist (restart cluster) + (when (applicable-restart-p restart condition) + (push restart restarts))))) + +(defun find-restart (name &optional condition) + "Return the first active restart named NAME. If NAME names a + restart, the restart is returned if it is currently active. If no such + restart is found, NIL is returned. It is an error to supply NIL as a + name. If CONDITION is specified and not NIL, then only restarts + associated with that condition (or with no condition) will be + returned." + (dolist (cluster %restarts%) + (dolist (restart cluster) + (when (and (or (eq restart name) (eq (restart-name restart) name)) + (applicable-restart-p restart condition)) + (return-from find-restart restart))))) + +(defun %active-restart (name) + (dolist (cluster %restarts%) + (dolist (restart cluster) + (let* ((rname (%restart-name restart)) + (rtest (%restart-test restart))) + (when (and (or (eq restart name) (eq rname name)) + (or (null rtest) (funcall rtest nil))) + (return-from %active-restart (values restart cluster)))))) + (error 'inactive-restart :restart-name name)) + +(defun invoke-restart (restart &rest values) + "Calls the function associated with the given restart, passing any given + arguments. If the argument restart is not a restart or a currently active + non-nil restart name, then a CONTROL-ERROR is signalled." + (multiple-value-bind (restart tag) (%active-restart restart) + (let ((fn (%restart-action restart))) + (cond ((null fn) ; simple restart + (unless (null values) (%err-disp $xtminps)) + (throw tag nil)) + ((fixnump fn) ; restart case + (throw tag (cons fn values))) + ((functionp fn) ; restart bind + (apply fn values)) + (t ; with-simple-restart + (throw tag (values nil t))))))) + +(defun invoke-restart-no-return (restart) + (invoke-restart restart) + (error 'restart-failure :restart restart)) + +(defun invoke-restart-interactively (restart) + "Calls the function associated with the given restart, prompting for any + necessary arguments. If the argument restart is not a restart or a + currently active non-NIL restart name, then a CONTROL-ERROR is signalled." + (let* ((restart (find-restart restart))) + (format *error-output* "~&Invoking restart: ~a~&" restart) + (let* ((argfn (%restart-interactive restart)) + (values (when argfn (funcall argfn)))) + (apply #'invoke-restart restart values)))) + + + +(defun maybe-invoke-restart (restart value condition) + (let ((restart (find-restart restart condition))) + (when restart (invoke-restart restart value)))) + +(defun use-value (value &optional condition) + "Transfer control and VALUE to a restart named USE-VALUE, or return NIL if + none exists." + (maybe-invoke-restart 'use-value value condition)) + +(defun store-value (value &optional condition) + "Transfer control and VALUE to a restart named STORE-VALUE, or return NIL if + none exists." + (maybe-invoke-restart 'store-value value condition)) + +(defun condition-arg (thing args type) + (cond ((condition-p thing) (if args (%err-disp $xtminps) thing)) + ((symbolp thing) (apply #'make-condition thing args)) + (t (make-condition type :format-control thing :format-arguments args)))) + +(defun make-condition (name &rest init-list) + "Make an instance of a condition object using the specified initargs." + (declare (dynamic-extent init-list)) + (if (subtypep name 'condition) + (apply #'make-instance name init-list) + (let ((class (if (classp name) + name + (find-class name)))) ;; elicit an error if no such class + (unless (class-finalized-p class) + (finalize-inheritance class)) ;; elicit an error if forward refs. + (error "~S is not a condition class" class)))) + +(defmethod print-object ((c condition) stream) + (if *print-escape* + (call-next-method) + (report-condition c stream))) + +(defmethod report-condition ((c condition) stream) + (princ (cond ((typep c 'error) "Error ") + ((typep c 'warning) "Warning ") + (t "Condition ")) + stream) + ;Here should dump all slots or something. For now... + (let ((*print-escape* t)) + (print-object c stream))) + +(defun signal-simple-condition (class-name format-string &rest args) + (let ((e #'error)) ; Never-tail-call. + (funcall e (make-condition class-name :format-control format-string :format-arguments args)))) + +(defun signal-simple-program-error (format-string &rest args) + (apply #'signal-simple-condition 'simple-program-error format-string args)) + +;;getting the function name for error functions. + + +(defun %last-fn-on-stack (&optional (number 0) (s (%get-frame-ptr))) + (let* ((fn nil)) + (let ((p s)) + (dotimes (i number) + (declare (fixnum i)) + (unless (setq p (parent-frame p nil)) + (return))) + (do* ((i number (1+ i))) + ((null p)) + (if (setq fn (cfp-lfun p)) + (return (values fn i)) + (setq p (parent-frame p nil))))))) + +(defun %err-fn-name (lfun) + "given an lfun returns the name or the string \"Unknown\"" + (if (lfunp lfun) (or (lfun-name lfun) lfun) + (or lfun "Unknown"))) + +(defun %real-err-fn-name (error-pointer) + (multiple-value-bind (fn p) (%last-fn-on-stack 0 error-pointer) + (let ((name (%err-fn-name fn))) + (if (and (memq name '( call-check-regs)) p) + (%err-fn-name (%last-fn-on-stack (1+ p) error-pointer)) + name)))) + + +;; Some simple restarts for simple error conditions. Callable from the kernel. + +(defun find-unique-homonyms (name &optional (test (constantly t))) + (delete-duplicates + (loop + with symbol = (if (consp name) (second name) name) + with pname = (symbol-name symbol) + for package in (list-all-packages) + for other-package-symbol = (find-symbol pname package) + for canditate = (and other-package-symbol + (neq other-package-symbol symbol) + (if (consp name) + (list (first name) other-package-symbol) + other-package-symbol)) + when (and canditate + (funcall test canditate)) + collect canditate) + :test #'equal)) + +(def-kernel-restart $xvunbnd %default-unbound-variable-restarts (frame-ptr cell-name) + (unless *level-1-loaded* + (dbg cell-name)) ; user should never see this. + (let ((condition (make-condition 'unbound-variable :name cell-name)) + (other-variables (find-unique-homonyms cell-name (lambda (name) + (and (not (keywordp name)) + (boundp name)))))) + (flet ((new-value () + (catch-cancel + (return-from new-value + (list (read-from-string + (get-string-from-user + (format nil "New value for ~s : " cell-name)))))) + (continue condition))) ; force error again if cancelled, var still not set. + (restart-case (%error condition nil frame-ptr) + (continue () + :report (lambda (s) (format s "Retry getting the value of ~S." cell-name)) + (symbol-value cell-name)) + (use-homonym (homonym) + :test (lambda (c) (and (or (null c) (eq c condition)) other-variables)) + :report (lambda (s) + (if (= 1 (length other-variables)) + (format s "Use the value of ~s this time." (first other-variables)) + (format s "Use one of the homonyms ~{~S or ~} this time." other-variables))) + :interactive (lambda () + (if (= 1 (length other-variables)) + other-variables + (select-item-from-list other-variables :window-title "Select homonym to use"))) + (symbol-value homonym)) + (use-value (value) + :interactive new-value + :report (lambda (s) (format s "Specify a value of ~S to use this time." cell-name)) + value) + (store-value (value) + :interactive new-value + :report (lambda (s) (format s "Specify a value of ~S to store and use." cell-name)) + (setf (symbol-value cell-name) value)))))) + +(def-kernel-restart $xnopkg %default-no-package-restart (frame-ptr package-name) + (or (and *autoload-lisp-package* + (or (string-equal package-name "LISP") + (string-equal package-name "USER")) + (progn + (require "LISP-PACKAGE") + (find-package package-name))) + (let* ((alias (or (%cdr (assoc package-name '(("LISP" . "COMMON-LISP") + ("USER" . "CL-USER")) + :test #'string-equal)) + (if (packagep *package*) (package-name *package*)))) + (condition (make-condition 'no-such-package :package package-name))) + (flet ((try-again (p) + (or (find-package p) (%kernel-restart $xnopkg p)))) + (restart-case + (restart-case (%error condition nil frame-ptr) + (continue () + :report (lambda (s) (format s "Retry finding package with name ~S." package-name)) + (try-again package-name)) + (use-value (value) + :interactive (lambda () (block nil + (catch-cancel + (return (list (get-string-from-user + "Find package named : ")))) + (continue condition))) + :report (lambda (s) (format s "Find specified package instead of ~S ." package-name)) + (try-again value)) + (make-nickname () + :report (lambda (s) (format s "Make ~S be a nickname for package ~S." package-name alias)) + (let ((p (try-again alias))) + (push package-name (cdr (pkg.names p))) + p))) + (require-lisp-package () + :test (lambda (c) + (and (eq c condition) + (or (string-equal package-name "LISP") (string-equal package-name "USER")))) + :report (lambda (s) + (format s "(require :lisp-package) and retry finding package ~s" + package-name)) + (require "LISP-PACKAGE") + (try-again package-name))))))) + +(def-kernel-restart $xunintc unintern-conflict-restarts (frame-ptr sym package conflicts) + (let ((condition (make-condition 'unintern-conflict-error :package package :sym sym :conflicts conflicts))) + (restart-case (%error condition nil frame-ptr) + (continue () + :report (lambda (s) (format s "Try again to unintern ~s from ~s" sym package)) + (unintern sym package)) + (do-shadowing-import (ssym) + :report (lambda (s) (format s "SHADOWING-IMPORT one of ~S in ~S." conflicts package)) + :interactive (lambda () + (block nil + (catch-cancel + (return (select-item-from-list conflicts + :window-title + (format nil "Shadowing-import one of the following in ~s" package) + :table-print-function #'prin1))) + (continue condition))) + (shadowing-import (list ssym) package))))) + + +(def-kernel-restart $xusec blub (frame-ptr package-to-use using-package conflicts) + (resolve-use-package-conflict-error frame-ptr package-to-use using-package conflicts nil)) + +(def-kernel-restart $xusecX blub (frame-ptr package-to-use using-package conflicts) + (resolve-use-package-conflict-error frame-ptr package-to-use using-package conflicts t)) + +(defun resolve-use-package-conflict-error (frame-ptr package-to-use using-package conflicts external-p) + (let ((condition (make-condition 'use-package-conflict-error + :package using-package + :package-to-use package-to-use + :conflicts conflicts + :external-p external-p))) + (flet ((external-test (&rest ignore) (declare (ignore ignore)) external-p) + (present-test (&rest ignore) (declare (ignore ignore)) (not external-p))) + (declare (dynamic-extent #'present-test #'external-test)) + (restart-case (%error condition nil frame-ptr) + (continue () + :report (lambda (s) (format s "Try again to use ~s in ~s" package-to-use using-package))) + (resolve-by-shadowing-import (&rest shadowing-imports) + :test external-test + :interactive (lambda () + (mapcar #'(lambda (pair) + (block nil + (catch-cancel + (return (car (select-item-from-list pair + :window-title + (format nil "Shadowing-import one of the following in ~s" using-package) + :table-print-function #'prin1)))) + (continue condition))) + conflicts)) + :report (lambda (s) (format s "SHADOWING-IMPORT one of each pair of conflicting symbols.")) + (shadowing-import shadowing-imports using-package)) + (unintern-all () + :test present-test + :report (lambda (s) (format s "UNINTERN all conflicting symbols from ~S" using-package)) + (dolist (c conflicts) + (unintern (car c) using-package))) + (shadow-all () + :test present-test + :report (lambda (s) (format s "SHADOW all conflicting symbols in ~S" using-package)) + (dolist (c conflicts) + (shadow-1 using-package (car c)))) + (resolve-by-unintern-or-shadow (&rest dispositions) + :test present-test + :interactive (lambda () + (mapcar #'(lambda (pair) + (let* ((present-sym (car pair))) + (block nil + (catch-cancel + (return (car (select-item-from-list (list 'shadow 'unintern) + :window-title + (format nil "SHADOW ~S in, or UNINTERN ~S from ~S" + present-sym + present-sym + using-package) + :table-print-function #'prin1))) + (continue condition))))) + conflicts)) + :report (lambda (s) (format s "SHADOW or UNINTERN the conflicting symbols in ~S." using-package)) + (dolist (d dispositions) + (let* ((sym (car (pop conflicts)))) + (if (eq d 'shadow) + (shadow-1 using-package sym) + (unintern sym using-package))))))))) + + +(defun resolve-export-conflicts (conflicts package) + (let* ((first-inherited (caar conflicts)) + (all-same (dolist (conflict (cdr conflicts) t) + (unless (eq (car conflict) first-inherited) (return nil)))) + (all-inherited (and all-same first-inherited)) + (all-present (and all-same (not first-inherited))) + (condition (make-condition 'export-conflict-error + :conflicts conflicts + :package package))) + (flet ((check-again () + (let* ((remaining-conflicts (check-export-conflicts (mapcar #'cadr conflicts) package))) + (if remaining-conflicts (resolve-export-conflicts remaining-conflicts package))))) + (restart-case (%error condition nil (%get-frame-ptr)) + (resolve-all-by-shadowing-import-inherited + () + :test (lambda (&rest ignore) (declare (ignore ignore)) all-inherited) + :report (lambda (s) (format s "SHADOWING-IMPORT all conflicting inherited symbol(s) in using package(s).")) + (dolist (conflict conflicts (check-again)) + (destructuring-bind (using-package inherited-sym) (cddr conflict) + (shadowing-import-1 using-package inherited-sym)))) + (resolve-all-by-shadowing-import-exported + () + :test (lambda (&rest ignore) (declare (ignore ignore)) all-inherited) + :report (lambda (s) (format s "SHADOWING-IMPORT all conflicting symbol(s) to be exported in using package(s).")) + (dolist (conflict conflicts (check-again)) + (destructuring-bind (exported-sym using-package ignore) (cdr conflict) + (declare (ignore ignore)) + (shadowing-import-1 using-package exported-sym)))) + (resolve-all-by-uninterning-present + () + :test (lambda (&rest ignore) (declare (ignore ignore)) all-present) + :report (lambda (s) (format s "UNINTERN all present conflicting symbol(s) in using package(s).")) + (dolist (conflict conflicts (check-again)) + (destructuring-bind (using-package inherited-sym) (cddr conflict) + (unintern inherited-sym using-package)))) + (resolve-all-by-shadowing-present + () + :test (lambda (&rest ignore) (declare (ignore ignore)) all-present) + :report (lambda (s) (format s "SHADOW all present conflicting symbol(s) in using package(s).")) + (dolist (conflict conflicts (check-again)) + (destructuring-bind (using-package inherited-sym) (cddr conflict) + (shadow-1 using-package inherited-sym)))) + (review-and-resolve + (dispositions) + :report (lambda (s) (format s "Review each name conflict and resolve individually.")) + :interactive (lambda () + (let* ((disp nil)) + (block b + (catch-cancel + (dolist (conflict conflicts (return-from b (list disp))) + (destructuring-bind (inherited-p exported-sym using-package conflicting-sym) conflict + (let* ((syms (list exported-sym conflicting-sym))) + (if inherited-p + (push (list 'shadowing-import + (select-item-from-list syms + :window-title + (format nil "Shadowing-import one of the following in ~s" using-package) + :table-print-function #'prin1) + using-package) + disp) + (let* ((selection (car (select-item-from-list syms + :window-title + (format nil "Shadow ~S or unintern ~s in ~s" + exported-sym + conflicting-sym using-package) + :table-print-function #'prin1)))) + (push (if (eq selection 'exported-sym) + (list 'shadow (list exported-sym) using-package) + (list 'unintern conflicting-sym using-package)) + disp))))))) + nil))) + (dolist (disp dispositions (check-again)) + (apply (car disp) (cdr disp)))))))) + + +(def-kernel-restart $xwrongtype default-require-type-restarts (frame-ptr value typespec) + (setq typespec (%type-error-type typespec)) + (let ((condition (make-condition 'type-error + :datum value + :expected-type typespec))) + (restart-case (%error condition nil frame-ptr) + (use-value (newval) + :report (lambda (s) + (format s "Use a new value of type ~s instead of ~s." typespec value)) + :interactive (lambda () + (format *query-io* "~&New value of type ~S :" typespec) + (list (read *query-io*))) + (require-type newval typespec))))) + +(def-kernel-restart $xudfcall default-undefined-function-call-restarts (frame-ptr function-name args) + (unless *level-1-loaded* + (dbg function-name)) ; user should never see this + (let ((condition (make-condition 'undefined-function-call + :name function-name + :function-arguments args)) + (other-functions (find-unique-homonyms function-name #'fboundp))) + (restart-case (%error condition nil frame-ptr) + (continue () + :report (lambda (s) (format s "Retry applying ~S to ~S." function-name args)) + (apply function-name args)) + (use-homonym (function-name) + :test (lambda (c) (and (or (null c) (eq c condition)) other-functions)) + :report (lambda (s) + (if (= 1 (length other-functions)) + (format s "Apply ~s to ~S this time." (first other-functions) args) + (format s "Apply one of ~{~S or ~} to ~S this time." + other-functions args))) + :interactive (lambda () + (if (= 1 (length other-functions)) + other-functions + (select-item-from-list other-functions :window-title "Select homonym to use"))) + (apply (fdefinition function-name) args)) + (use-value (function) + :interactive (lambda () + (format *query-io* "Function to apply instead of ~s :" function-name) + (let ((f (read *query-io*))) + (unless (symbolp f) (setq f (eval f))) ; almost-the-right-thing (tm) + (list (coerce f 'function)))) + :report (lambda (s) (format s "Apply specified function to ~S this time." args)) + (apply function args)) + (store-value (function) + :interactive (lambda () + (format *query-io* "Function to apply as new definition of ~s :" function-name) + (let ((f (read *query-io*))) + (unless (symbolp f) (setq f (eval f))) ; almost-the-right-thing (tm) + (list (coerce f 'function)))) + :report (lambda (s) (format s "Specify a function to use as the definition of ~S." function-name)) + (apply (setf (symbol-function function-name) function) args))))) + + + +(defun %check-type (value typespec placename typename) + (let ((condition (make-condition 'type-error + :datum value + :expected-type typespec))) + (if typename + (setf (slot-value condition 'format-control) + (format nil "value ~~S is not ~A (~~S)." typename))) + (restart-case (%error condition nil (%get-frame-ptr)) + (store-value (newval) + :report (lambda (s) + (format s "Assign a new value of type ~a to ~s" typespec placename)) + :interactive (lambda () + (format *query-io* "~&New value for ~S :" placename) + (list (eval (read)))) + newval)))) + + +; This has to be defined fairly early (assuming, of course, that it "has" to be defined at all ... + +(defun ensure-value-of-type (value typespec placename &optional typename) + (tagbody + again + (unless (typep value typespec) + (let ((condition (make-condition 'type-error + :datum value + :expected-type typespec))) + (if typename + (setf (slot-value condition 'format-control) + (format nil "value ~~S is not ~A (~~S)." typename))) + (restart-case (%error condition nil (%get-frame-ptr)) + (store-value (newval) + :report (lambda (s) + (format s "Assign a new value of type ~a to ~s" typespec placename)) + :interactive (lambda () + (format *query-io* "~&New value for ~S :" placename) + (list (eval (read)))) + (setq value newval) + (go again)))))) + value) + +;;;The Error Function + +(defparameter *kernel-simple-error-classes* + (list (cons $xcalltoofew 'simple-destructuring-error) + (cons $xcalltoomany 'simple-destructuring-error) + (cons $xstkover 'stack-overflow-condition) + (cons $xmemfull 'simple-storage-condition) + (cons $xwrongtype 'type-error) ; this one needs 2 args + (cons $xdivzro 'division-by-zero) + (cons $xflovfl 'floating-point-overflow) + (cons $xfunbnd 'undefined-function) + (cons $xbadkeys 'simple-program-error) + (cons $xcallnomatch 'simple-program-error) + (cons $xnotfun 'call-special-operator-or-macro) + (cons $xaccessnth 'sequence-index-type-error) + (cons $ximproperlist 'improper-list) + (cons $xnospread 'cant-construct-arglist) + (cons $xnotelt 'array-element-type-error) + )) + + +(defparameter *simple-error-types* + (vector nil 'simple-program-error 'simple-file-error)) + +(defconstant $pgm-err #x10000) + + + + +(defparameter %type-error-typespecs% + #(array + bignum + fixnum + character + integer + list + number + sequence + simple-string + simple-vector + string + symbol + macptr + real + cons + unsigned-byte + (integer 2 36) + float + rational + ratio + short-float + double-float + complex + vector + simple-base-string + function + (unsigned-byte 16) + (unsigned-byte 8) + (unsigned-byte 32) + (signed-byte 32) + (signed-byte 16) + (signed-byte 8) + base-char + bit + (unsigned-byte 24) ; (integer 0 (array-total-size-limit)) + (unsigned-byte 64) + (signed-byte 64) + (unsigned-byte 56) + (simple-array double-float (* *)) + (simple-array single-float (* *)) + (mod #x110000) + (array * (* *)) ;2d array + (array * (* * *)) ;3d array + (array t) + (array bit) + (array (signed-byte 8)) + (array (unsigned-byte 8)) + (array (signed-byte 16)) + (array (unsigned-byte 16)) + (array (signed-byte 32)) + (array (unsigned-byte 32)) + (array (signed-byte 64)) + (array (unsigned-byte 64)) + (array fixnum) + (array single-float) + (array double-float) + (array character) + (array t (* *)) + (array bit (* *)) + (array (signed-byte 8) (* *)) + (array (unsigned-byte 8) (* *)) + (array (signed-byte 16) (* *)) + (array (unsigned-byte 16) (* *)) + (array (signed-byte 32) (* *)) + (array (unsigned-byte 32) (* *)) + (array (signed-byte 64) (* *)) + (array (unsigned-byte 64) (* *)) + (array fixnum (* *)) + (array single-float (* *)) + (array double-float (* *)) + (array character (* *)) + (simple-array t (* *)) + (simple-array bit (* *)) + (simple-array (signed-byte 8) (* *)) + (simple-array (unsigned-byte 8) (* *)) + (simple-array (signed-byte 16) (* *)) + (simple-array (unsigned-byte 16) (* *)) + (simple-array (signed-byte 32) (* *)) + (simple-array (unsigned-byte 32) (* *)) + (simple-array (signed-byte 64) (* *)) + (simple-array (unsigned-byte 64) (* *)) + (simple-array fixnum (* *)) + (simple-array character (* *)) + (array t (* * *)) + (array bit (* * *)) + (array (signed-byte 8) (* * *)) + (array (unsigned-byte 8) (* * *)) + (array (signed-byte 16) (* * *)) + (array (unsigned-byte 16) (* * *)) + (array (signed-byte 32) (* * *)) + (array (unsigned-byte 32) (* * *)) + (array (signed-byte 64) (* * *)) + (array (unsigned-byte 64) (* * *)) + (array fixnum (* * *)) + (array single-float (* * *)) + (array double-float (* * *)) + (array character (* * *)) + (simple-array t (* * *)) + (simple-array bit (* * *)) + (simple-array (signed-byte 8) (* * *)) + (simple-array (unsigned-byte 8) (* * *)) + (simple-array (signed-byte 16) (* * *)) + (simple-array (unsigned-byte 16) (* * *)) + (simple-array (signed-byte 32) (* * *)) + (simple-array (unsigned-byte 32) (* * *)) + (simple-array (signed-byte 64) (* * *)) + (simple-array (unsigned-byte 64) (* * *)) + (simple-array fixnum (* * *)) + (simple-array single-float (* * *)) + (simple-array double-float (* * *)) + (simple-array character (* * *)) + + (vector t) + bit-vector + (vector (signed-byte 8)) + (vector (unsigned-byte 8)) + (vector (signed-byte 16)) + (vector (unsigned-byte 16)) + (vector (signed-byte 32)) + (vector (unsigned-byte 32)) + (vector (signed-byte 64)) + (vector (unsigned-byte 64)) + (vector fixnum) + (vector single-float) + (vector double-float) + + )) + + +(defun %type-error-type (type) + (if (fixnump type) + (svref %type-error-typespecs% type) + type)) + +(defun %typespec-id (typespec) + (flet ((type-equivalent (t1 t2) (ignore-errors (and (subtypep t1 t2) (subtypep t2 t1))))) + (position typespec %type-error-typespecs% :test #'type-equivalent))) + + +(defmethod condition-p ((x t)) nil) +(defmethod condition-p ((x condition)) t) + + + +(let* ((globals ())) + + (defun %check-error-globals () + (let ((vars ()) + (valfs ()) + (oldvals ())) + (dolist (g globals (values vars valfs oldvals)) + (destructuring-bind (sym predicate newvalf) g + (let* ((boundp (boundp sym)) + (oldval (if boundp (symbol-value sym) (%unbound-marker-8)))) + (unless (and boundp (funcall predicate oldval)) + (push sym vars) + (push oldval oldvals) + (push newvalf valfs))))))) + + (defun check-error-global (sym checkfn newvalfn) + (setq sym (require-type sym 'symbol) + checkfn (require-type checkfn 'function) + newvalfn (require-type newvalfn 'function)) + (let ((found (assq sym globals))) + (if found + (setf (cadr found) checkfn (caddr found) newvalfn) + (push (list sym checkfn newvalfn) globals)) + sym)) +) + +(check-error-global '*package* #'packagep #'(lambda () (find-package "CL-USER"))) + + +(flet ((io-stream-p (x) (and (streamp x) (eq (stream-direction x) :io))) + (input-stream-p (x) (and (streamp x) (input-stream-p x))) + (output-stream-p (x) (and (streamp x) (output-stream-p x))) + (default-terminal-io () (make-echoing-two-way-stream *stdin* *stdout*)) + (terminal-io () *terminal-io*) + (standard-output () *standard-output*)) + + ;; Note that order matters. These need to come out of %check-error-globals with + ;; *terminal-io* first and *trace-output* last + (check-error-global '*terminal-io* #'io-stream-p #'default-terminal-io) + (check-error-global '*query-io* #'io-stream-p #'terminal-io) + (check-error-global '*debug-io* #'io-stream-p #'terminal-io) + (check-error-global '*standard-input* #'input-stream-p #'terminal-io) + (check-error-global '*standard-output* #'output-stream-p #'terminal-io) + (check-error-global '*error-output* #'output-stream-p #'standard-output) + (check-error-global '*trace-output* #'output-stream-p #'standard-output)) + Index: /branches/new-random/level-1/l1-events.lisp =================================================================== --- /branches/new-random/level-1/l1-events.lisp (revision 13309) +++ /branches/new-random/level-1/l1-events.lisp (revision 13309) @@ -0,0 +1,268 @@ +;;;-*-Mode: LISP; Package: CCL -*- +;;; +;;; Copyright (C) 2009 Clozure Associates +;;; Copyright (C) 1994-2001 Digitool, Inc +;;; This file is part of Clozure CL. +;;; +;;; Clozure CL is licensed under the terms of the Lisp Lesser GNU Public +;;; License , known as the LLGPL and distributed with Clozure CL as the +;;; file "LICENSE". The LLGPL consists of a preamble and the LGPL, +;;; which is distributed with Clozure CL as the file "LGPL". Where these +;;; conflict, the preamble takes precedence. +;;; +;;; Clozure CL is referenced in the preamble as the "LIBRARY." +;;; +;;; The LLGPL is also available online at +;;; http://opensource.franz.com/preamble.html + +(in-package "CCL") + +(defvar *inhibit-abort* nil) + +;;; If any bits in the *periodic-task-mask* are set in the +;;; ptaskstate.flags word of a periodic task, it will not be run +(defvar *periodic-task-mask* 0) + +(defmethod print-object ((p periodic-task) stream) + (print-unreadable-object (p stream :type t :identity t) + (format stream "~s ~d" + (ptask.name p) + (ptaskstate.interval (ptask.state p))))) + +(defvar *periodic-task-lock* (make-lock)) + +(defun find-named-periodic-task (name) + (dolist (task *%periodic-tasks%*) + (when (eq name (ptask.name task)) + (return task)))) + +(defun %install-periodic-task (name function interval &optional + (flags 0) + (privatedata (%null-ptr))) + (with-lock-grabbed (*periodic-task-lock*) + (let* ((already (find-named-periodic-task name)) + (state (if already (ptask.state already) + (%istruct 'ptaskstate 0 0 0 0))) + (task (or already (%istruct 'periodic-task state name nil)))) + (setf (ptask.function task) function) + (setf (ptaskstate.interval state) interval + (ptaskstate.flags state ) flags + (ptaskstate.privatedata state) privatedata + (ptaskstate.nexttick state) (+ (get-tick-count) interval)) + (unless already (push task *%periodic-tasks%*)) + (let* ((interval-in-seconds (/ interval (float *ticks-per-second*)))) + (if (< interval-in-seconds *periodic-task-interval*) + (set-periodic-task-interval interval-in-seconds))) + task))) + +(defmacro with-periodic-task-mask ((mask) &body body) + (let ((thunk (gensym))) + `(let ((,thunk #'(lambda () ,@body))) + (funcall-with-periodic-task-mask ,mask ,thunk)))) + +(defvar *periodic-task-masks* nil) + +; All this hair is so that multiple processes can vote on the *periodic-task-mask* +(defun funcall-with-periodic-task-mask (mask thunk) + (let* ((cell (list mask))) + (declare (dynamic-extent cell)) + (flet ((logior-list (list) + (declare (type list list)) + (let ((res 0)) + (declare (fixnum res)) + (loop + (when (null list) (return res)) + (setq res (%ilogior res (pop list))))))) + (declare (inline logior-list)) + (unwind-protect + (progn + (without-interrupts + (setf (cdr cell) *periodic-task-masks* + *periodic-task-masks* cell) + (setq *periodic-task-mask* (logior-list *periodic-task-masks*)) +) + (funcall thunk)) + (without-interrupts + (let* ((first *periodic-task-masks*) + (this first) + (last nil)) + (declare (type cons first this last)) + (loop + (when (eq this cell) + (if last + (setf (cdr last) (cdr this)) + (pop first)) + (return (setq *periodic-task-masks* first))) + (setq last this + this (cdr this)))) + (setq *periodic-task-mask* (logior-list *periodic-task-masks*))))))) + +(defparameter *invoke-debugger-hook-on-interrupt* nil) + +(define-condition interrupt-signal-condition (condition) () + (:report "interrupt signal")) + +(defun force-break-in-listener (p) + (process-interrupt p + #'(lambda () + (multiple-value-bind (vars inits old-vals) (%check-error-globals) + (progv vars old-vals + (mapcar (lambda (v f) (set v (funcall f))) vars inits) + (let ((condition (make-condition 'interrupt-signal-condition)) + (*top-error-frame* (%current-exception-frame))) + (ignoring-without-interrupts + (when *invoke-debugger-hook-on-interrupt* + (let* ((hook *debugger-hook*) + (*debugger-hook* nil)) + (when hook + (funcall hook condition hook)))) + (%break-in-frame *top-error-frame* condition) + (clear-input *terminal-io*)))))))) + +(defglobal *quit-interrupt-hook* nil) + +(defun force-async-quit (signum) + (when *quit-interrupt-hook* + (multiple-value-bind (req opt restp) (function-args *quit-interrupt-hook*) + (if (and (= req 0) (= opt 0) (not restp)) + (funcall *quit-interrupt-hook*) + (funcall *quit-interrupt-hook* signum)))) + ;; Exit by resignalling, as per http://www.cons.org/cracauer/sigint.html + (quit #'(lambda () + (ff-call (%kernel-import target::kernel-import-lisp-sigexit) :signed signum) + ;; Shouldn't get here + (#__exit 143)))) + +(defstatic *running-periodic-tasks* nil) + +(defun cmain () + (thread-handle-interrupts)) + + +(defvar *select-interactive-process-hook* nil) + +(defun select-interactive-abort-process () + (flet ((maybe-proc (proc) (and proc (process-active-p proc) proc))) + (or (maybe-proc (and *select-interactive-process-hook* + (funcall *select-interactive-process-hook*))) + (maybe-proc *interactive-abort-process*) + (let* ((sr (input-stream-shared-resource *terminal-input*))) + (when sr + (or (maybe-proc (shared-resource-current-owner sr)) + (maybe-proc (shared-resource-primary-owner sr)))))))) + +(defun handle-gc-hooks () + (let ((bits *gc-event-status-bits*)) + (declare (fixnum bits)) + (cond ((logbitp $gc-postgc-pending-bit bits) + (setq *gc-event-status-bits* + (logand (lognot (ash 1 $gc-postgc-pending-bit)) + bits)) + (let ((f *post-gc-hook*)) + (when (functionp f) (funcall f))))))) + +(defconstant $user-interrupt-break 1) +(defconstant $user-interrupt-quit 2) + +(defun housekeeping () + (progn + (handle-gc-hooks) + (unless *inhibit-abort* + (let* ((id (pending-user-interrupt)) + (kind (logand #xFF id))) + (cond ((eql kind $user-interrupt-quit) + ;; Try to use a process that has a shot at reporting any problems + ;; in case of bugs in user hook. + (let* ((proc (or (select-interactive-abort-process) + *initial-process*)) + (signum (ash id -8))) + (process-interrupt proc #'force-async-quit signum))) + ((eql kind $user-interrupt-break) + (let* ((proc (select-interactive-abort-process))) + (if proc + (force-break-in-listener proc))))))) + (flet ((maybe-run-periodic-task (task) + (let ((now (get-tick-count)) + (state (ptask.state task))) + (when (and (>= (- now (ptaskstate.nexttick state)) + 0) + (eql 0 (logand (the fixnum (ptaskstate.flags state)) + (the fixnum *periodic-task-mask*)))) + (setf (ptaskstate.nexttick state) + (+ now (ptaskstate.interval state))) + (funcall (ptask.function task)))))) + (let ((event-dispatch-task *event-dispatch-task*)) + (maybe-run-periodic-task event-dispatch-task) + (with-lock-grabbed (*periodic-task-lock*) + (bitclrf $gc-allow-stack-overflows-bit *gc-event-status-bits*) + (unless *running-periodic-tasks* + (let-globally ((*running-periodic-tasks* t)) + (dolist (task *%periodic-tasks%*) + (unless (eq task event-dispatch-task) + (maybe-run-periodic-task task)))))))))) + + +(defun %remove-periodic-task (name) + (with-lock-grabbed (*periodic-task-lock*) + (let ((task (find-named-periodic-task name))) + (when task + (if (setq *%periodic-tasks%* (delete task *%periodic-tasks%*)) + (let* ((min-ticks target::target-most-positive-fixnum)) + (dolist (other *%periodic-tasks%* + (set-periodic-task-interval (/ min-ticks (float *ticks-per-second*)))) + (let* ((other-ticks + (ptaskstate.interval (ptask.state other)))) + (if (< other-ticks min-ticks) + (setq min-ticks other-ticks))))) + (set-periodic-task-interval 1))) + task))) + + +(defun auto-flush-interactive-streams () + (with-lock-grabbed (*auto-flush-streams-lock*) + (dolist (s *auto-flush-streams*) + (when (open-stream-p s) + (if (or (typep s 'basic-stream) + (typep s 'buffered-io-stream-mixin)) + (if (ioblock-outbuf-lock (stream-ioblock s t)) + (force-output s))) + (force-output s))))) + +(defun add-auto-flush-stream (s) + (with-lock-grabbed (*auto-flush-streams-lock*) + (when (typep s 'output-stream) + (pushnew s *auto-flush-streams*)))) + +(defun remove-auto-flush-stream (s) + (with-lock-grabbed (*auto-flush-streams-lock*) + (setq *auto-flush-streams* (delete s *auto-flush-streams*)))) + +; Is it really necessary to keep this guy in a special variable ? +(defloadvar *event-dispatch-task* + (%install-periodic-task + 'auto-flush-interactive-streams + 'auto-flush-interactive-streams + 33 + (+ $ptask_draw-flag $ptask_event-dispatch-flag))) + + +(defun event-ticks () + (let ((task *event-dispatch-task*)) + (when task (ptaskstate.interval (ptask.state task))))) + +(defun set-event-ticks (n) + (setq n (require-type n '(integer 0 32767))) ; Why this weird limit ? + (let ((task *event-dispatch-task*)) + (when task (setf (ptaskstate.interval (ptask.state task)) n)))) + +;; Making the *initial-process* quit will cause an exit(), +;; though it might be nicer if all processes were shut down +;; in an orderly manner first. This is the not-so-nice way +;; of quitting ... +(defun %quit () + (quit)) + + + +; end of L1-events.lisp + Index: /branches/new-random/level-1/l1-files.lisp =================================================================== --- /branches/new-random/level-1/l1-files.lisp (revision 13309) +++ /branches/new-random/level-1/l1-files.lisp (revision 13309) @@ -0,0 +1,1478 @@ +;;;-*-Mode: LISP; Package: CCL -*- +;;; +;;; Copyright (C) 1994-2001 Digitool, Inc +;;; Portions copyright (C) 2001-2009 Clozure Associates +;;; This file is part of Clozure CL. +;;; +;;; Clozure CL is licensed under the terms of the Lisp Lesser GNU Public +;;; License , known as the LLGPL and distributed with Clozure CL as the +;;; file "LICENSE". The LLGPL consists of a preamble and the LGPL, +;;; which is distributed with Clozure CL as the file "LGPL". Where these +;;; conflict, the preamble takes precedence. +;;; +;;; Clozure CL is referenced in the preamble as the "LIBRARY." +;;; +;;; The LLGPL is also available online at +;;; http://opensource.franz.com/preamble.html + +;; L1-files.lisp - Object oriented file stuff + +(in-package "CCL") + +(defconstant $paramErr -50) ; put this with the rest when we find the rest + +(defconstant pathname-case-type '(member :common :local :studly)) +(defconstant pathname-arg-type '(or string pathname stream)) + +(defmacro signal-file-error (err-num &optional pathname &rest args) + `(%signal-file-error ,err-num + ,@(if pathname (list pathname)) + ,@(if args args))) + +(defun %signal-file-error (err-num &optional pathname args) + (declare (fixnum err-num)) + (let* ((err-code (logior (ash 2 16) (the fixnum (logand #xffff (the fixnum err-num)))))) + (funcall (if (< err-num 0) '%errno-disp '%err-disp) + err-code + pathname + args))) + + +(defvar %logical-host-translations% '()) +(defvar *load-pathname* nil + "the defaulted pathname that LOAD is currently loading") +(defvar *load-truename* nil + "the TRUENAME of the file that LOAD is currently loading") + + +(defparameter *default-pathname-defaults* + (let* ((hide-from-compile-file (%cons-pathname nil nil nil))) + hide-from-compile-file)) + +;Right now, the only way it's used is that an explicit ";" expands into it. +;Used to merge with it before going to ROM. Might be worth to bring that back, +;it doesn't hurt anything if you don't set it. +;(defparameter *working-directory* (%cons-pathname nil nil nil)) + +;These come in useful... We should use them consistently and then document them, +;thereby earning the eternal gratitude of any users who find themselves with a +;ton of "foo.CL" files... +(defparameter *.fasl-pathname* + (%cons-pathname nil nil + #.(pathname-type + (backend-target-fasl-pathname *target-backend*)))) + +(defparameter *.lisp-pathname* (%cons-pathname nil nil "lisp")) + +(defun if-exists (if-exists filename &optional (prompt "Create ...")) + (case if-exists + (:error (signal-file-error (- #$EEXIST) filename)) + ((:dialog) (overwrite-dialog filename prompt)) + ((nil) nil) + ((:ignored :overwrite :append :supersede :rename-and-delete :new-version :rename) filename) + (t (report-bad-arg if-exists '(member :error :dialog nil :ignored :overwrite :append :supersede :rename-and-delete))))) + +(defun if-does-not-exist (if-does-not-exist filename) + (case if-does-not-exist + (:error (signal-file-error (- #$ENOENT) filename)) ; (%err-disp $err-no-file filename)) + (:create filename) + ((nil) (return-from if-does-not-exist nil)) + (t (report-bad-arg if-does-not-exist '(member :error :create nil))))) + + +(defun native-translated-namestring (path) + (let ((name (translated-namestring path))) + ;; Check that no quoted /'s + (when (%path-mem-last-quoted "/" name) + (signal-file-error $xbadfilenamechar name #\/)) + ;; Check that no unquoted wildcards. + (when (%path-mem-last "*" name) + (signal-file-error $xillwild name)) + (namestring-unquote name))) + +(defun native-untranslated-namestring (path) + (let ((name (namestring (translate-logical-pathname path)))) + ;; Check that no quoted /'s + (when (%path-mem-last-quoted "/" name) + (signal-file-error $xbadfilenamechar name #\/)) + ;; Check that no unquoted wildcards. + (when (%path-mem-last "*" name) + (signal-file-error $xillwild name)) + (namestring-unquote name))) + +;; Reverse of above, take native namestring and make a Lisp pathname. +(defun native-to-pathname (name) + (pathname (%path-std-quotes name nil + #+windows-target "*;" + #-windows-target "*;:"))) + +(defun native-to-directory-pathname (name) + #+windows-target + (let* ((len (length name))) + (when (and (> len 1) (not (or (eql (schar name (1- len)) #\/) + (eql (schar name (1- len)) #\\)))) + (setq name (%str-cat name "/"))) + (string-to-pathname name)) + #-windows-target + (make-directory-pathname :device nil :directory (%path-std-quotes name nil "*;:"))) + +;;; Make a pathname which names the specified directory; use +;;; explict :NAME, :TYPE, and :VERSION components of NIL. +(defun make-directory-pathname (&key host device directory) + (make-pathname :host host + :device device + :directory directory + :name nil + :type nil + :version nil)) + + +(defun namestring-unquote (name) + #+(and windows-target bogus) + (when (and (> (length name) 1) + (eql (schar name 1) #\|)) + (setq name (subseq name 0)) + (setf (schar name 1) #\:)) + (let ((esc *pathname-escape-character*)) + (if (position esc name) + (multiple-value-bind (sstr start end) (get-sstring name) + (let ((result (make-string (%i- end start) :element-type 'base-char)) + (dest 0)) + (loop + (let ((pos (or (position esc sstr :start start :end end) end))) + (while (%i< start pos) + (setf (%schar result dest) (%schar sstr start) + start (%i+ start 1) + dest (%i+ dest 1))) + (when (eq pos end) + (return nil)) + (setq start (%i+ pos 1)))) + (shrink-vector result dest))) + name))) + +(defun translated-namestring (path) + (namestring (translate-logical-pathname (merge-pathnames path)))) + + +(defun truename (path) + "Return the pathname for the actual file described by PATHNAME. + An error of type FILE-ERROR is signalled if no such file exists, + or the pathname is wild. + + Under Unix, the TRUENAME of a broken symlink is considered to be + the name of the broken symlink itself." + (or (probe-file path) + (signal-file-error $err-no-file path))) + +(defun check-pathname-not-wild (path) + (when (wild-pathname-p path) + (error 'file-error :error-type "Inappropriate use of wild pathname ~s" + :pathname path)) + path) + +(defun probe-file (path) + "Return a pathname which is the truename of the file if it exists, or NIL + otherwise. An error of type FILE-ERROR is signaled if pathname is wild." + (check-pathname-not-wild path) + (let* ((native (native-translated-namestring path)) + (realpath (%realpath native)) + (kind (if realpath (%unix-file-kind realpath)))) + ;; Darwin's #_realpath will happily return non-nil for + ;; files that don't exist. I don't think that + ;; %UNIX-FILE-KIND would do so. + (when kind + (if (eq kind :directory) + (unless (eq (aref realpath (1- (length realpath))) #\/) + (setq realpath (%str-cat realpath "/")))) + (if realpath + (native-to-pathname realpath) + nil)))) + +(defun cwd (path) + (multiple-value-bind (realpath kind) (%probe-file-x (native-translated-namestring path)) + (if kind + (if (eq kind :directory) + (let* ((error (%chdir realpath))) + (if (eql error 0) + (mac-default-directory) + (signal-file-error error path))) + (error "~S is not a directory pathname." path)) + (error "Invalid pathname : ~s." path)))) + +(defun create-file (path &key (if-exists :error) (create-directory t)) + (let* ((p (%create-file path :if-exists if-exists + :create-directory create-directory))) + (and p + (native-to-pathname p)))) + +(defun %create-file (path &key + (if-exists :error) + (create-directory t)) + (when create-directory + (create-directory path)) + (when (directory-pathname-p path) + (return-from %create-file (probe-file-x path))) + (assert (or (eql if-exists :overwrite) + (null if-exists) + (eq if-exists :error) + (not (probe-file path))) () + "~s ~s not implemented yet" :if-exists if-exists) + (let* ((unix-name (native-translated-namestring path)) + (fd (fd-open unix-name (logior #$O_WRONLY #$O_CREAT #$O_TRUNC + (if (or (null if-exists) + (eq if-exists :error)) + #$O_EXCL + 0))))) + (if (< fd 0) + (if (and (null if-exists) + (eql fd (- #$EEXIST))) + (return-from %create-file nil) + (signal-file-error fd path)) + (fd-close fd)) + (%realpath unix-name))) + + +;; The following assumptions are deeply embedded in all our pathname code: +;; (1) Non-logical pathname host is always :unspecific. +;; (2) Logical pathname host is never :unspecific. +;; (3) Logical pathname host can however be NIL, e.g. "foo;bar;baz". + +(defun %pathname-host (pathname) + (if (logical-pathname-p pathname) + (%logical-pathname-host pathname) + :unspecific)) + +(defun %pathname-version (pathname) + (if (logical-pathname-p pathname) + (%logical-pathname-version pathname) + (%physical-pathname-version pathname))) + + + +(fset 'pathname-host (nfunction bootstrapping-pathname-host ; redefined later in this file + (lambda (thing) + (declare (ignore thing)) + :unspecific))) + +(fset 'pathname-version (nfunction bootstrapping-pathname-version ; redefined later in this file + (lambda (thing) + (declare (ignore thing)) + nil))) + +(defmethod print-object ((pathname pathname) stream) + (let ((flags (if (logical-pathname-p pathname) 4 + (%i+ (if (eq (%pathname-type pathname) ':unspecific) 1 0) + (if (equal (%pathname-name pathname) "") 2 0)))) + (name (namestring pathname))) + (if (and (not *print-readably*) (not *print-escape*)) + (write-string name stream) + (progn + (format stream (if (or *print-escape* (eql flags 0)) "#P" "#~DP") flags) + (write-escaped-string name stream #\"))))) + + +(defun mac-default-directory () + (let* ((native-name (current-directory-name)) + (len (length native-name))) + (declare (fixnum len)) + (when (and (> len 1) + (not (eq #\/ (schar native-name (1- len))))) + (setq native-name (%str-cat native-name "/"))) + (native-to-pathname native-name))) + + + + +;;; I thought I wanted to call this from elsewhere but perhaps not +(defun absolute-directory-list (dirlist) + ; just make relative absolute and remove ups where possible + (when (or (null dirlist) (eq (car dirlist) :relative)) + (let ((default (mac-default-directory)) default-dir) + (when default + (setq default-dir (%pathname-directory default)) + (when default-dir + (setq dirlist (append default-dir (cdr dirlist))))))) + (when (memq :up dirlist) + (setq dirlist (remove-up (copy-list dirlist)))) + dirlist) + +; destructively mungs dir +(defun remove-up (dir) + (setq dir (delete "." dir :test #'string=)) + (let ((n 0) + (last nil) + (sub dir) + has-abs kept-up) + ;; from %std-directory-component we get dir with :relative/:absolute stripped + (when (memq :up dir) + (when (memq (car dir) '(:relative :absolute)) + (setq sub (cdr dir) n 1 has-abs t)) + (do () ((null sub)) + (cond ((eq (car sub) :up) + (cond ((or (eq n 0) + (and (stringp last)(string= last "**")) + (eq last :wild-inferiors) + kept-up + (and has-abs (eq n 1))) + ;; up after "**" stays, initial :up stays, how bout 2 :ups + (setq kept-up t) + ) + ((eq n 1) (setq dir (cddr dir) kept-up nil n -1)) + (t (rplacd (nthcdr (- n 2) dir) (cdr sub)) + (setq n (- n 2) kept-up nil)))) + (t (setq kept-up nil))) + (setq last (car sub) + n (1+ n) + sub (cdr sub)))) + dir)) + +(defun namestring (path) + "Construct the full (name)string form of the pathname." + (%str-cat (device-namestring path) + (host-namestring path) + (directory-namestring path) + (file-namestring path))) + +(defun device-namestring (path) + (let* ((device (pathname-device path))) + (if (and device (not (eq device :unspecific))) + (%str-cat device ":") + ""))) + +(defun host-namestring (path) + "Return a string representation of the name of the host in the pathname." + (let ((host (pathname-host path))) + (if (and host (neq host :unspecific)) (%str-cat host ":") ""))) + +(defun directory-namestring (path) + "Return a string representation of the directories used in the pathname." + (%directory-list-namestring (pathname-directory path) + (neq (pathname-host path) :unspecific))) + +(defun ensure-directory-namestring (string) + (namestring (ensure-directory-pathname string))) + +(defun ensure-directory-pathname (pathname) + (let ((path (pathname pathname))) + (if (directory-pathname-p path) + path + (cons-pathname (append (or (pathname-directory path) + ;; This makes sure "ccl:foo" maps to "ccl:foo;" (not + ;; "ccl:;foo;"), but "foo" maps to "foo/" (not "/foo/"). + (if (eq (pathname-host path) :unspecific) + '(:relative) + '(:absolute))) + ;; Don't use file-namestring, because that + ;; includes the version for logical names. + (list (file-namestring-from-parts + (pathname-name path) + (pathname-type path) + nil))) + nil nil (pathname-host path))))) + +(defun %directory-list-namestring (list &optional logical-p) + (if (null list) + "" + (let ((len (if (eq (car list) (if logical-p :relative :absolute)) 1 0)) + + result) + (declare (fixnum len)(optimize (speed 3)(safety 0))) + (dolist (s (%cdr list)) + (case s + (:wild (setq len (+ len 2))) + (:wild-inferiors (setq len (+ len 3))) + (:up (setq len (+ len 3))) + (t ;This assumes that special chars in dir components are escaped, + ;otherwise would have to pre-scan for escapes here. + (setq len (+ len 1 (length s)))))) + (setq result + (make-string len)) + (let ((i 0) + (sep (if logical-p #\; #\/))) + (declare (fixnum i)) + (when (eq (%car list) (if logical-p :relative :absolute)) + (setf (%schar result 0) sep) + (setq i 1)) + (dolist (s (%cdr list)) + (case s + (:wild (setq s "*")) + (:wild-inferiors (setq s "**")) + ;; There is no :up in logical pathnames, so this must be native + (:up (setq s ".."))) + (let ((len (length s))) + (declare (fixnum len)) + (move-string-bytes s result 0 i len) + (setq i (+ i len))) + (setf (%schar result i) sep) + (setq i (1+ i)))) + result))) + +(defun file-namestring (path) + "Return a string representation of the name used in the pathname." + (let* ((path (pathname path)) + (name (pathname-name path)) + (type (pathname-type path)) + (version (if (typep path 'logical-pathname) (pathname-version path)))) + (file-namestring-from-parts name type version))) + +(defun file-namestring-from-parts (name type version) + (when (eq version :unspecific) (setq version nil)) + (when (eq type :unspecific) (setq type nil)) + (%str-cat (case name + ((nil :unspecific) "") + (:wild "*") + (t (%path-std-quotes name "*;:" "."))) + (if (or type version) + (%str-cat (case type + ((nil) ".") + (:wild ".*") + (t (%str-cat "." (%path-std-quotes type "*;:" ".")))) + (case version + ((nil) "") + (:newest ".newest") + (:wild ".*") + (t (%str-cat "." (if (fixnump version) + (%integer-to-string version) + version))))) + ""))) + +(defun enough-namestring (path &optional (defaults *default-pathname-defaults*)) + "Return an abbreviated pathname sufficent to identify the pathname relative + to the defaults." + (if (null defaults) + (namestring path) + (let* ((dir (pathname-directory path)) + (nam (pathname-name path)) + (typ (pathname-type path)) + (ver (pathname-version path)) + (host (pathname-host path)) + (logical-p (neq host :unspecific)) + (default-dir (pathname-directory defaults))) + ;; enough-host-namestring + (setq host (if (and host + (neq host :unspecific) + (not (equalp host (pathname-host defaults)))) + (%str-cat host ":") + "")) + ;; enough-directory-namestring + (cond ((equalp dir default-dir) + (setq dir '(:relative))) + ((and dir default-dir + (eq (car dir) :absolute) (eq (car default-dir) :absolute)) + ;; maybe make it relative to defaults + (do ((p1 (cdr dir) (cdr p1)) + (p2 (cdr default-dir) (cdr p2))) + ((or (null p2) (null p1) (not (equalp (car p1) (car p2)))) + (when (and (null p2) (or t (neq p1 (cdr dir)))) + (setq dir (cons :relative p1))))))) + (setq dir (%directory-list-namestring dir logical-p)) + ;; enough-file-namestring + (when (or (equalp ver (pathname-version defaults)) + (not logical-p)) + (setq ver nil)) + (when (and (null ver) (equalp typ (pathname-type defaults))) + (setq typ nil)) + (when (and (null typ) (equalp nam (pathname-name defaults))) + (setq nam nil)) + (setq nam (file-namestring-from-parts nam typ ver)) + (%str-cat host dir nam)))) + +(defun cons-pathname (dir name type &optional host version device) + (if (neq host :unspecific) + (%cons-logical-pathname dir name type host version) + (%cons-pathname dir name type version device))) + +(defun pathname (path) + "Convert thing (a pathname, string or stream) into a pathname." + (etypecase path + (pathname path) + (stream (%path-from-stream path)) + (string (string-to-pathname path)))) + +(defun %path-from-stream (stream) + (or (pathname (stream-filename stream)) + (error "Can't determine pathname of ~S ." stream))) ; ??? + +;Like (pathname stream) except returns NIL rather than error when there's no +;filename associated with the stream. +(defun stream-pathname (stream &aux (path (stream-filename stream))) + (when path (pathname path))) + +(defun get-pathname-sstring (string &optional (start 0) (end (length string))) + #-windows-target + (get-sstring string start end) + #+windows-target + (multiple-value-bind (sstr start end) + (get-sstring string start end) + (declare (fixnum start end) + (simple-string sstr)) + (if (do* ((i start (1+ i))) + ((= i end)) + (declare (fixnum i)) + (when (eql (schar sstr i) #\\) + (return t))) + (let* ((len (- end start)) + (new (make-string len))) + (declare (fixnum len) (simple-string new)) + (dotimes (i len) + (let* ((ch (schar sstr start))) + (if (eql ch #\\) + (setf (schar new i) #\/) + (setf (schar new i) ch))) + (incf start)) + (values new 0 len)) + (values sstr start end)))) + +(defun string-to-pathname (string &optional (start 0) (end (length string)) + (reference-host nil) + (defaults *default-pathname-defaults*)) + (require-type reference-host '(or null string)) + (multiple-value-bind (sstr start end) (get-pathname-sstring string start end) + #-windows-target + (if (and (> end start) + (eql (schar sstr start) #\~)) + (setq sstr (tilde-expand (subseq sstr start end)) + start 0 + end (length sstr))) + (let (directory name type host version device (start-pos start) (end-pos end) has-slashes) + (multiple-value-setq (host start-pos has-slashes) (pathname-host-sstr sstr start-pos end-pos)) + (cond ((and host (neq host :unspecific)) + (when (and reference-host (not (string-equal reference-host host))) + (error "Host in ~S does not match requested host ~S" + (%substr sstr start end) reference-host))) + ((or reference-host + (and defaults + (neq (setq reference-host (pathname-host defaults)) :unspecific))) + ;;If either a reference-host is specified or defaults is a logical pathname + ;; then the string must be interpreted as a logical pathname. + (when has-slashes + (error "Illegal logical namestring ~S" (%substr sstr start end))) + (setq host reference-host))) + #+windows-target + (when (and (eq host :unspecific) + (eql start-pos 0) + (eql (position #\: sstr) 1)) + (let* ((ch (schar sstr 0))) + (when (and (alpha-char-p ch) + (standard-char-p ch)) + (setq device (make-string 1 :initial-element ch) + start-pos 2)))) + (multiple-value-setq (directory start-pos) (pathname-directory-sstr sstr start-pos end-pos host)) + (unless (eq host :unspecific) + (multiple-value-setq (version end-pos) (pathname-version-sstr sstr start-pos end-pos))) + (multiple-value-setq (type end-pos) (pathname-type-sstr sstr start-pos end-pos)) + ;; now everything else is the name + (unless (eq start-pos end-pos) + (setq name (%std-name-component (%substr sstr start-pos end-pos)))) + (if (eq host :unspecific) + (%cons-pathname directory name type (if name :newest) device) + (%cons-logical-pathname directory name type host version))))) + +(defun parse-namestring (thing &optional host (defaults *default-pathname-defaults*) + &key (start 0) end junk-allowed) + (declare (ignore junk-allowed)) + (unless (typep thing 'string) + (let* ((path (pathname thing)) + (pathname-host (pathname-host path))) + (when (and host pathname-host + (or (eq pathname-host :unspecific) ;physical + (not (string-equal host pathname-host)))) + (error "Host in ~S does not match requested host ~S" path host)) + (return-from parse-namestring (values path start)))) + (when host + (verify-logical-host-name host)) + (setq end (check-sequence-bounds thing start end)) + (values (string-to-pathname thing start end host defaults) end)) + + + +(defun %std-device-component (device host) + (when (and (or (null host) (eq host :unspecific)) + (and device (not (eq device :unspecific)))) + #+windows-target + (unless (and (typep device 'string) + (eql (length device) 1) + (alpha-char-p (char device 0)) + (standard-char-p (char device 0))) + (error "Invalid pathname device ~s" device)) + device)) + +(defun make-pathname (&key (host nil host-p) + (device nil device-p) + (directory nil directory-p) + (name nil name-p) + (type nil type-p) + (version nil version-p) + (defaults nil defaults-p) case + &aux path) + "Makes a new pathname from the component arguments. Note that host is +a host-structure or string." + (when case (setq case (require-type case pathname-case-type))) + (if (null host-p) + (let ((defaulted-defaults (if defaults-p defaults *default-pathname-defaults*))) + (setq host (if defaulted-defaults + (pathname-host defaulted-defaults) + :unspecific))) + (unless host (setq host :unspecific))) + (if directory-p + (setq directory (%std-directory-component directory host))) + (if (and defaults (not directory-p)) + (setq directory (pathname-directory defaults))) + (if (and defaults (not device-p)) + (setq device (pathname-device defaults))) + (setq device (%std-device-component device host)) + (setq name + (if name-p + (%std-name-component name) + (and defaults (pathname-name defaults)))) + (setq type + (if type-p + (%std-type-component type) + (and defaults (pathname-type defaults)))) + (setq version (if version-p + (%logical-version-component version) + (if name-p + nil + (and defaults (pathname-version defaults))))) + (setq path + (if (eq host :unspecific) + (%cons-pathname directory name type version device) + (%cons-logical-pathname + (or directory + (unless directory-p '(:absolute))) + name type host version))) + (when (and (eq (car directory) :absolute) + (member (cadr directory) '(:up :back))) + (error 'simple-file-error :pathname path :error-type "Second element of absolute directory component in ~s is ~s" :format-arguments (list (cadr directory)))) + (let* ((after-wif (cadr (member :wild-inferiors directory)))) + (when (member after-wif '(:up :back)) + (error 'simple-file-error :pathname path :error-type "Directory component in ~s contains :WILD-INFERIORS followed by ~s" :format-arguments (list after-wif)))) + + (when (and case (neq case :local)) + (setf (%pathname-directory path) (%reverse-component-case (%pathname-directory path) case) + (%pathname-name path) (%reverse-component-case (%pathname-name path) case) + (%pathname-type path) (%reverse-component-case (%pathname-type path) case))) + path) + +;;; In portable CL, if the :directory argument to make pathname is a +;;; string, it should be the name of a top-level directory and should +;;; not contain any punctuation characters such as "/" or ";". In +;;; MCL a string :directory argument with slashes or semi-colons will +;;; be parsed as a directory in the obvious way. +(defun %std-directory-component (directory host) + (cond ((null directory) nil) + ((eq directory :wild) '(:absolute :wild-inferiors)) + ((stringp directory) (%directory-string-list directory 0 (length directory) host)) + ((listp directory) + ;Standardize the directory list, taking care not to cons if nothing + ;needs to be changed. + (let ((names (%cdr directory)) (new-names ())) + (do ((nn names (%cdr nn))) + ((null nn) (setq new-names (if new-names (nreverse new-names) names))) + (let* ((name (car nn)) + (new-name (%std-directory-part name))) + (unless (eq name new-name) + (unless new-names + (do ((new-nn names (%cdr new-nn))) + ((eq new-nn nn)) + (push (%car new-nn) new-names)))) + (when (or new-names (neq name new-name)) + (push new-name new-names)))) + (when (memq :up (or new-names names)) + (setq new-names (remove-up (copy-list (or new-names names))))) + (ecase (%car directory) + (:relative + (cond (new-names ; Just (:relative) is the same as NIL. - no it isnt + (if (eq new-names names) + directory + (cons ':relative new-names))) + (t directory))) + (:absolute + (cond ((null new-names) directory) ; But just (:absolute) IS the same as NIL + ((eq new-names names) directory) + (t (cons ':absolute new-names))))))) + (t (report-bad-arg directory '(or string list (member :wild)))))) + +(defun %std-directory-part (name) + (case name + ((:wild :wild-inferiors :up) name) + (:back :up) + (t (cond ((string= name "*") :wild) + ((string= name "**") :wild-inferiors) + ((string= name "..") :up) + (t (%path-std-quotes name "/:;*" "/:;")))))) + +; this will allow creation of garbage pathname "foo:bar;bas:" do we care? +(defun merge-pathnames (path &optional (defaults *default-pathname-defaults*) + (default-version :newest)) + "Construct a filled in pathname by completing the unspecified components + from the defaults." + ;(declare (ignore default-version)) + (when (not (pathnamep path))(setq path (pathname path))) + (when (and defaults (not (pathnamep defaults)))(setq defaults (pathname defaults))) + (let* ((path-dir (pathname-directory path)) + (path-host (pathname-host path)) + (path-name (pathname-name path)) + (path-type (pathname-type path)) + (path-device (pathname-device path)) + (default-dir (and defaults (pathname-directory defaults))) + (default-host (and defaults (pathname-host defaults))) + (default-device (and defaults (pathname-device defaults))) + ; take host from defaults iff path-dir is logical or absent - huh? + (host (cond ((or (null path-host) ; added 7/96 + (and (eq path-host :unspecific) + (or (null path-dir) + (null (cdr path-dir)) + (and (eq :relative (car path-dir)) + (not (memq default-host '(nil :unspecific))))))) + + default-host) + (t path-host))) + (dir (cond ((null path-dir) default-dir) + ((null default-dir) path-dir) + ((eq (car path-dir) ':relative) + (let ((the-dir (append default-dir (%cdr path-dir)))) + (when (memq ':up the-dir)(setq the-dir (remove-up (copy-list the-dir)))) + the-dir)) + (t path-dir))) + (nam (or path-name + (and defaults (pathname-name defaults)))) + (typ (or path-type + (and defaults (pathname-type defaults)))) + (version (or (pathname-version path) + (cond ((not path-name) + (or (and defaults (pathname-version defaults)) + default-version)) + (t default-version)))) + (device (or path-device default-device))) + (if (and (pathnamep path) + (eq dir (%pathname-directory path)) + (eq nam path-name) + (eq typ (%pathname-type path)) + (eq host path-host) + (eq device path-device) + (eq version (pathname-version path))) + path + (cons-pathname dir nam typ host version device)))) + +(defun directory-pathname-p (path) + (let ((name (pathname-name path))(type (pathname-type path))) + (and (or (null name) (eq name :unspecific) (%izerop (length name))) + (or (null type) (eq type :unspecific))))) + +;In CCL, a pathname is logical if and only if pathname-host is not :unspecific. +(defun pathname-host (thing &key case) + "Return PATHNAME's host." + (when (streamp thing)(setq thing (%path-from-stream thing))) + (when case (setq case (require-type case pathname-case-type))) + (let ((name + (typecase thing + (logical-pathname (%logical-pathname-host thing)) + (pathname :unspecific) + (string (multiple-value-bind (sstr start end) (get-pathname-sstring thing) + (pathname-host-sstr sstr start end))) + (t (report-bad-arg thing pathname-arg-type))))) + (if (and case (neq case :local)) + (progn + (when (and (eq case :common) (neq name :unspecific)) (setq case :logical)) + (%reverse-component-case name case)) + name))) + +(defun pathname-host-sstr (sstr start end &optional no-check) + ;; A pathname with any (unescaped) /'s is always a physical pathname. + ;; Otherwise, if the pathname has either a : or a ;, then it's always logical. + ;; Otherwise, it's probably physical. + ;; Return :unspecific for physical, host string or nil for a logical. + (let* ((slash (%path-mem "/" sstr start end)) + (pos (and (not slash) (%path-mem ":;" sstr start end))) + (pos-char (and pos (%schar sstr pos))) + (host (and (eql pos-char #\:) (%substr sstr start pos)))) + (cond (host + (unless (or no-check (logical-host-p host)) + (error "~S is not a defined logical host" host)) + (values host (%i+ pos 1) nil)) + ((eql pos-char #\;) ; logical pathname with missing host + (values nil start nil)) + (t ;else a physical pathname. + (values :unspecific start slash))))) + + +(defun pathname-device (thing &key case) + "Return PATHNAME's device." + (declare (ignore case)) + (let* ((p (pathname thing))) + (etypecase p + (logical-pathname :unspecific) + (pathname (%physical-pathname-device p))))) + + + +;A directory is either NIL or a (possibly wildcarded) string ending in "/" or ";" +;Quoted /'s are allowed at this stage, though will get an error when go to the +;filesystem. +(defun pathname-directory (path &key case) + "Return PATHNAME's directory." + (when (streamp path) (setq path (%path-from-stream path))) + (when case (setq case (require-type case pathname-case-type))) + (let* ((logical-p nil) + (names (typecase path + (logical-pathname (setq logical-p t) (%pathname-directory path)) + (pathname (%pathname-directory path)) + (string + (multiple-value-bind (sstr start end) (get-pathname-sstring path) + (multiple-value-bind (host pos2) (pathname-host-sstr sstr start end) + (unless (eq host :unspecific) (setq logical-p t)) + #+windows-target + (unless logical-p + (if (and (> end 1) + (eql (schar sstr 1) #\:)) + (setq pos2 2))) + (pathname-directory-sstr sstr pos2 end host)))) + (t (report-bad-arg path pathname-arg-type))))) + (if (and case (neq case :local)) + (progn + (when (and (eq case :common) logical-p) (setq case :logical)) + (%reverse-component-case names case)) + names))) + +;; Must match pathname-directory-end below +(defun pathname-directory-sstr (sstr start end host) + (if (and (eq host :unspecific) + (> end start) + (eql (schar sstr start) #\~)) + (setq sstr (tilde-expand (subseq sstr start end)) + start 0 + end (length sstr))) + (let ((pos (%path-mem-last (if (eq host :unspecific) "/" ";") sstr start end))) + (if pos + (values + (%directory-string-list sstr start (setq pos (%i+ pos 1)) host) + pos) + (values (and (neq host :unspecific) + (neq start end) + '(:absolute)) + start)))) + +;; Must match pathname-directory-sstr above +(defun pathname-directory-end (sstr start end) + (multiple-value-bind (host pos2) (pathname-host-sstr sstr start end) + (let ((pos (%path-mem-last (if (eq host :unspecific) "/" ";") sstr pos2 end))) + (if pos + (values (%i+ pos 1) host) + (values pos2 host))))) + +(defun %directory-string-list (sstr start &optional (end (length sstr)) host) + ;; Should use host to split by / vs. ; but for now suport both for either host, + ;; like the mac version. It means that ';' has to be quoted in unix pathnames. + (declare (ignore host)) + ;This must cons up a fresh list, %expand-logical-directory rplacd's it. + (labels ((std-part (sstr start end) + (%std-directory-part (if (and (eq start 0) (eq end (length sstr))) + sstr (%substr sstr start end)))) + (split (sstr start end) + (unless (eql start end) + (let ((pos (%path-mem "/;" sstr start end))) + (if (eq pos start) + (split sstr (%i+ start 1) end) ;; treat multiple ////'s as one. + (cons (std-part sstr start (or pos end)) + (when pos + (split sstr (%i+ pos 1) end)))))))) + (unless (eq start end) + (let* ((slash-pos (%path-mem "/" sstr start end)) + (semi-pos (%path-mem ";" sstr start end)) + (pos (or slash-pos semi-pos))) + ; this never did anything sensible but did not signal an error + (when (and slash-pos semi-pos) + (error "Illegal directory string ~s" (%substr sstr start end))) + (if (null pos) + (list :relative (std-part sstr start end)) + (let ((pos-char (%schar sstr pos))) + (cons (if (eq pos start) + (if (eq pos-char #\/) ':absolute ':relative) + (if (eq pos-char #\/) ':relative ':absolute)) + (split sstr start end)))))))) + +(defun pathname-version (path) + "Return PATHNAME's version." + (when (streamp path) (setq path (%path-from-stream path))) + (typecase path + (logical-pathname (%logical-pathname-version path)) + (pathname (%physical-pathname-version path)) + (string + (multiple-value-bind (sstr start end) (get-pathname-sstring path) + (multiple-value-bind (newstart host) (pathname-directory-end sstr start end) + (if (eq host :unspecific) + nil + (values (pathname-version-sstr sstr newstart end)))))) + (t (report-bad-arg path pathname-arg-type)))) + +(defun pathname-version-sstr (sstr start end) + (declare (fixnum start end)) + (let ((pos (%path-mem-last "." sstr start end))) + (if (and pos (%i> pos start) (%path-mem "." sstr start (%i- pos 1))) + (values (%std-version-component (%substr sstr (%i+ pos 1) end)) pos) + (values nil end)))) + +(defun %std-version-component (v) + (cond ((or (null v) (eq v :unspecific)) v) + ((eq v :wild) "*") + ((string= v "") :unspecific) + ((string-equal v "newest") :newest) + ((every #'digit-char-p v) (parse-integer v)) + (t (%path-std-quotes v "./:;*" "./:;")))) + + +;A name is either NIL or a (possibly wildcarded, possibly empty) string. +;Quoted /'s are allowed at this stage, though will get an error if go to the +;filesystem. +(defun pathname-name (path &key case) + "Return PATHNAME's name." + (when (streamp path) (setq path (%path-from-stream path))) + (when case (setq case (require-type case pathname-case-type))) + (let* ((logical-p nil) + (name (typecase path + (logical-pathname (setq logical-p t) (%pathname-name path)) + (pathname (%pathname-name path)) + (string + (multiple-value-bind (sstr start end) (get-pathname-sstring path) + (multiple-value-bind (newstart host) (pathname-directory-end sstr start end) + (setq start newstart) + (unless (eq host :unspecific) + (setq logical-p t) + (setq end (nth-value 1 (pathname-version-sstr sstr start end)))) + ;; TODO: -->> Need to make an exception so that ".emacs" is name with no type. + ;; -->> Need to make an exception so that foo/.. is a directory pathname, + ;; for native. + (setq end (or (%path-mem-last "." sstr start end) end));; strip off type + (unless (eq start end) + (%std-name-component (%substr sstr start end)))))) + (t (report-bad-arg path pathname-arg-type))))) + (if (and case (neq case :local)) + (progn + (when (and (eq case :common) logical-p) (setq case :logical)) + (%reverse-component-case name case)) + name))) + +(defun %std-name-component (name) + (cond ((or (null name) (eq name :unspecific) (eq name :wild)) name) + ((equal name "*") :wild) + (t (%path-std-quotes name "/:;*" "/:;")))) + +;A type is either NIL or a (possibly wildcarded, possibly empty) string. +;Quoted :'s are allowed at this stage, though will get an error if go to the +;filesystem. +(defun pathname-type (path &key case) + "Return PATHNAME's type." + (when (streamp path) (setq path (%path-from-stream path))) + (when case (setq case (require-type case pathname-case-type))) + (let* ((logical-p nil) + (name (typecase path + (logical-pathname (setq logical-p t) (%pathname-type path)) + (pathname (%pathname-type path)) + (string + (multiple-value-bind (sstr start end) (get-pathname-sstring path) + (multiple-value-bind (newstart host) (pathname-directory-end sstr start end) + (setq start newstart) + (unless (eq host :unspecific) + (setq logical-p t) + (setq end (nth-value 1 (pathname-version-sstr sstr start end)))) + ;; TODO: -->> Need to make an exception so that ".emacs" is name with no type. + ;; -->> Need to make an exception so that foo/.. is a directory pathname, + ;; for native. + (pathname-type-sstr sstr start end)))) + (t (report-bad-arg path pathname-arg-type))))) + (if (and case (neq case :local)) + (progn + (when (and (eq case :common) logical-p) (setq case :logical)) + (%reverse-component-case name case)) + name))) + +; assumes dir & version if any has been stripped away +(defun pathname-type-sstr (sstr start end) + (let ((pos (%path-mem-last "." sstr start end))) + (if pos + (values (%std-type-component (%substr sstr (%i+ 1 pos) end)) pos) + (values nil end)))) + +(defun %std-type-component (type) + (cond ((or (null type) (eq type :unspecific) (eq type :wild)) type) + ((equal type "*") :wild) + (t (%path-std-quotes type "./:;*" "./:;")))) + +(defun %std-name-and-type (native) + (let* ((end (length native)) + (pos (position #\. native :from-end t)) + (type (and pos + (%path-std-quotes (%substr native (%i+ 1 pos) end) + nil "/:;*"))) + (name (unless (eq (or pos end) 0) + (%path-std-quotes (if pos (%substr native 0 pos) native) + nil "/:;*")))) + (values name type))) + +(defun %reverse-component-case (name case) + (cond ((not (stringp name)) + (if (listp name) + (mapcar #'(lambda (name) (%reverse-component-case name case)) name) + name)) + #+advanced-studlification-feature + ((eq case :studly) (string-studlify name)) + ((eq case :logical) + (if (every #'(lambda (ch) (not (lower-case-p ch))) name) + name + (string-upcase name))) + (t ; like %read-idiocy but non-destructive - need it be? + (let ((which nil) + (len (length name))) + (dotimes (i len) + (let ((c (%schar name i))) + (if (alpha-char-p c) + (if (upper-case-p c) + (progn + (when (eq which :lower)(return-from %reverse-component-case name)) + (setq which :upper)) + (progn + (when (eq which :upper)(return-from %reverse-component-case name)) + (setq which :lower)))))) + (case which + (:lower (string-upcase name)) + (:upper (string-downcase name)) + (t name)))))) + +;;;;;;; String-with-quotes utilities +(defun %path-mem-last-quoted (chars sstr &optional (start 0) (end (length sstr))) + (while (%i< start end) + (when (and (%%str-member (%schar sstr (setq end (%i- end 1))) chars) + (%path-quoted-p sstr end start)) + (return-from %path-mem-last-quoted end)))) + +(defun %path-mem-last (chars sstr &optional (start 0) (end (length sstr))) + (while (%i< start end) + (when (and (%%str-member (%schar sstr (setq end (%i- end 1))) chars) + (not (%path-quoted-p sstr end start))) + (return-from %path-mem-last end)))) + +(defun %path-mem (chars sstr &optional (start 0) (end (length sstr))) + (let ((one-char (when (eq (length chars) 1) (%schar chars 0)))) + (while (%i< start end) + (let ((char (%schar sstr start))) + (when (if one-char (eq char one-char)(%%str-member char chars)) + (return-from %path-mem start)) + (when (eq char *pathname-escape-character*) + (setq start (%i+ start 1))) + (setq start (%i+ start 1)))))) + +; these for \: meaning this aint a logical host. Only legal for top level dir + +(defun %path-unquote-one-quoted (chars sstr &optional (start 0)(end (length sstr))) + (let ((pos (%path-mem-last-quoted chars sstr start end))) + (when (and pos (neq pos 1)) + (cond ((or (%path-mem chars sstr start (1- pos)) + (%path-mem-last-quoted chars sstr start (1- pos))) + nil) + (t (%str-cat (%substr sstr start (1- pos))(%substr sstr pos end))))))) + +(defun %path-one-quoted-p (chars sstr &optional (start 0)(end (length sstr))) + (let ((pos (%path-mem-last-quoted chars sstr start end))) + (when (and pos (neq pos 1)) + (not (or (%path-mem-last-quoted chars sstr start (1- pos)) + (%path-mem chars sstr start (1- pos))))))) + +(defun %path-quoted-p (sstr pos start &aux (esc *pathname-escape-character*) (q nil)) + (while (and (%i> pos start) (eq (%schar sstr (setq pos (%i- pos 1))) esc)) + (setq q (not q))) + q) + + + +;Standardize pathname quoting, so can do EQUAL. +;; Subtle point: when keep-quoted is NIL, arg is assumed native, +;; and therefore escape characters are made quoted. +;; if keep-quoted is not NIL, e.g. if it's "", arg is assumed +;; to be escaped already, so escape chars are interpreted as quotes. +;; Note that this can't be used to remove quotes because it +;; always keeps the escape character quoted. +(defun %path-std-quotes (arg keep-quoted make-quoted) + (when (symbolp arg) + (error "Invalid pathname component ~S" arg)) + (let* ((str arg) + (esc *pathname-escape-character*) + (end (length str)) + res-str char) + (multiple-value-bind (sstr start)(array-data-and-offset str) + (setq end (+ start end)) + (let ((i start)) + (until (eq i end) + (setq char (%schar sstr i)) + (cond ((or (%%str-member char make-quoted) + (and (null keep-quoted) (eq char esc))) + (unless res-str + (setq res-str (make-array (%i- end start) + :element-type (array-element-type sstr) + :adjustable t :fill-pointer 0)) + (do ((j start (%i+ j 1))) ((eq j i)) + (vector-push-extend (%schar sstr j) res-str))) + (vector-push-extend esc res-str)) + ((neq char esc) nil) + ((eq (setq i (%i+ i 1)) end) + (error "Malformed pathname component string ~S" str)) + ((or (eq (setq char (%schar sstr i)) esc) + (%%str-member char keep-quoted)) + (when res-str (vector-push-extend esc res-str))) + (t + (unless res-str + (setq res-str (make-array (%i- end start) + :element-type (array-element-type sstr) + :adjustable t :fill-pointer 0)) + (do ((j start (%i+ j 1)) (end (%i- i 1))) ((eq j end)) + (vector-push-extend (%schar sstr j) res-str))))) + (when res-str (vector-push-extend char res-str)) + (setq i (%i+ i 1))) + (ensure-simple-string (or res-str str)))))) + + + +(defun %%str-member (char string) + (locally (declare (optimize (speed 3)(safety 0))) + (dotimes (i (the fixnum (length string))) + (when (eq (%schar string i) char) + (return i))))) + + +(defun file-write-date (path) + "Return file's creation date, or NIL if it doesn't exist. + An error of type file-error is signaled if file is a wild pathname" + (%file-write-date (native-translated-namestring path))) + +(defun file-author (path) + "Return the file author as a string, or NIL if the author cannot be + determined. Signal an error of type FILE-ERROR if FILE doesn't exist, + or FILE is a wild pathname." + (%file-author (native-translated-namestring path))) + +(defun touch (path) + (if (not (probe-file path)) + (progn + (ensure-directories-exist path) + (if (or (pathname-name path) + (pathname-type path)) + (create-file path))) + (%utimes (native-translated-namestring path))) + t) + + +;-_-_-_-_-_-_-_-_-_-_-_-_-_-_-_-_-_-_-_-_-_-_-_-_-_-_-_-_-_-_-_-_-_-_-_-_-_-_-_-_-_-_ +; load, require, provide + +(defun find-load-file (file-name) + (let ((full-name (full-pathname file-name :no-error nil)) + (kind nil)) + (when full-name + (let ((file-type (pathname-type full-name)) + (merged (pathname (merge-pathnames file-name)))) + (if (and file-type (neq file-type :unspecific)) + (values (probe-file full-name) merged (if (eq (pathname-host file-name) :unspecific) full-name file-name)) + (let* ((source (merge-pathnames file-name *.lisp-pathname*)) + (fasl (merge-pathnames file-name *.fasl-pathname*)) + (true-source (probe-file source)) + (true-fasl (probe-file fasl))) + (cond (true-source + (if (and true-fasl + (> (file-write-date true-fasl) + (file-write-date true-source))) + (values true-fasl merged source) + (values true-source merged source))) + (true-fasl + (values true-fasl merged fasl)) + ((and (multiple-value-setq (full-name kind) + (let* ((realpath (%realpath (native-translated-namestring full-name)))) + (if realpath + (%probe-file-x realpath )))) + (eq kind :file)) + (values full-name merged file-name))))))))) + + + + + +(defun load (file-name &key (verbose *load-verbose*) + (print *load-print*) + (if-does-not-exist :error) + (external-format :default)) + "Load the file given by FILESPEC into the Lisp environment, returning + T on success. + + Extension: :PRINT :SOURCE means print source as well as value" + (loop + (restart-case + (return (%load file-name verbose print if-does-not-exist external-format)) + (retry-load () + :report (lambda (stream) (format stream "Retry loading ~s" file-name))) + (skip-load () + :report (lambda (stream) (format stream "Skip loading ~s" file-name)) + (return nil)) + (load-other () + :report (lambda (stream) (format stream "Load other file instead of ~s" file-name)) + (return + (load (choose-file-dialog) + :verbose verbose + :print print + :if-does-not-exist if-does-not-exist)))))) + + +(defun %load (file-name verbose print if-does-not-exist external-format) + (let ((*load-pathname* file-name) + (*load-truename* file-name) + (source-file file-name) + ;; Don't bind these: let OPTIMIZE proclamations/declamations + ;; persist, unless debugging. + #| + (*nx-speed* *nx-speed*) + (*nx-space* *nx-space*) + (*nx-safety* *nx-safety*) + (*nx-debug* *nx-debug*) + (*nx-cspeed* *nx-cspeed*) + |# + ) + (declare (special *load-pathname* *load-truename*)) + (when (typep file-name 'string-input-stream) + (when verbose + (format t "~&;Loading from stream ~S..." file-name) + (force-output)) + (let ((*package* *package*) + (*readtable* *readtable*)) + (load-from-stream file-name print)) + (return-from %load file-name)) + (unless (streamp file-name) + (multiple-value-setq (*load-truename* *load-pathname* source-file) + (find-load-file (merge-pathnames file-name))) + (when (not *load-truename*) + (return-from %load (if if-does-not-exist + (signal-file-error $err-no-file file-name)))) + (setq file-name *load-truename*)) + (let* ((*package* *package*) + (*readtable* *readtable*) + (*loading-files* (cons file-name (specialv *loading-files*))) + ;;reset by fasload to logical name stored in the file + (*loading-file-source-file* (namestring source-file)) + (*loading-toplevel-location* nil)) + (declare (special *loading-files* *loading-file-source-file*)) + (when verbose + (format t "~&;Loading ~S..." *load-pathname*) + (force-output)) + (cond ((fasl-file-p file-name) + (let ((*fasload-print* print) + (restart-setup nil) + (restart-source nil) + (restart-fasl nil)) + (declare (special *fasload-print*)) + (flet ((restart-test (c) + (unless restart-setup + (setq restart-setup t) + (let ((source *loading-file-source-file*) + (fasl *load-pathname*)) + (when (and (not (typep c 'file-error)) + source + fasl + (setq source (probe-file source)) + (setq fasl (probe-file fasl)) + (not (equalp source fasl))) + (setq restart-fasl (namestring *load-pathname*) + restart-source *loading-file-source-file*)))) + (not (null restart-fasl))) + (fname (p) + #-versioned-file-system + (namestring (make-pathname :version :unspecific :defaults p)) + #+versioned-file-system + (namestring p))) + (restart-case (multiple-value-bind (winp err) + (%fasload (native-translated-namestring file-name)) + (if (not winp) + (%err-disp err))) + (load-source + () + :test restart-test + :report (lambda (s) + (format s "Load ~s instead of ~s" + (fname restart-source) (fname restart-fasl))) + (%load source-file verbose print if-does-not-exist external-format)) + (recompile + () + :test restart-test + :report (lambda (s) + (let ((*print-circle* NIL)) + (format s + (if (equalp + restart-source + (make-pathname :type (pathname-type *.lisp-pathname*) + :defaults restart-fasl)) + "Compile ~s and then load ~s again" + "Compile ~s into ~s then load ~:*~s again") + (fname restart-source) (fname restart-fasl)))) + (compile-file restart-source :output-file restart-fasl) + (%load restart-fasl verbose print if-does-not-exist external-format)))))) + (t + (with-open-file (stream file-name + :element-type 'base-char + :external-format external-format) + (load-from-stream stream print)))))) + file-name) + +(defun load-from-stream (stream print &aux (eof-val (list ())) val) + (with-compilation-unit (:override nil) ; try this for included files + (let ((env (new-lexical-environment (new-definition-environment 'eval))) + ;; source note map to use with any compilations. + (*nx-source-note-map* (and *save-source-locations* + (make-hash-table :test #'eq :shared nil))) + (*loading-toplevel-location* nil)) + (%rplacd (defenv.type (lexenv.parent-env env)) *outstanding-deferred-warnings*) + (loop + (multiple-value-setq (val *loading-toplevel-location*) + (read-recording-source stream + :eofval eof-val + :file-name *loading-file-source-file* + :map *nx-source-note-map* + :save-source-text (neq *save-source-locations* :no-text))) + (when (eq eof-val val) + (return)) + (when (eq print :source) (format t "~&Source: ~S~%" val)) + (setq val (cheap-eval-in-environment val env)) + (when print + (format t "~&~A~S~%" (if (eq print :source) "Value: " "") val)))))) + +(defun include (filename) + (load + (if (null *loading-files*) + filename + (merge-pathnames filename (directory-namestring (car *loading-files*)))))) + +(%fhave '%include #'include) + +(defun delete-file (path) + "Delete the specified FILE." + (let* ((namestring (native-translated-namestring path))) + (when (%realpath namestring) + (let* ((err (%delete-file namestring))) + (or (eql 0 err) (signal-file-error err path)))))) + +(defvar *known-backends* ()) + +(defun fasl-file-p (pathname) + (let* ((type (pathname-type pathname))) + (or (and (null *known-backends*) + (equal type (pathname-type *.fasl-pathname*))) + (dolist (b *known-backends*) + (when (equal type (pathname-type (backend-target-fasl-pathname b))) + (return t))) + (ignore-errors + (with-open-file (f pathname + :direction :input + :element-type '(unsigned-byte 8)) + ;; Assume that (potential) FASL files start with #xFF00 (big-endian), + ;; and that source files don't. + (and (eql (read-byte f nil nil) #xff) + (eql (read-byte f nil nil) #x00))))))) + +(defun provide (module) + "Adds a new module name to *MODULES* indicating that it has been loaded. + Module-name is a string designator" + (pushnew (string module) *modules* :test #'string=) + module) + +(defparameter *loading-modules* () "Internal. Prevents circularity") +(defparameter *module-provider-functions* '(module-provide-search-path module-provide-asdf) + "A list of functions called by REQUIRE to satisfy an unmet dependency. +Each function receives a module name as a single argument; if the function knows how to load that module, it should do so, add the module's name as a string to *MODULES* (perhaps by calling PROVIDE) and return non-NIL." + ) + +(defun module-provide-search-path (module) + ;; (format *debug-io* "trying module-provide-search-path~%") + (let* ((module-name (string module)) + (pathname (find-module-pathnames module-name))) + (when pathname + (if (consp pathname) + (dolist (path pathname) (load path)) + (load pathname)) + (provide module)))) + +(defun require (module &optional pathname) + "Loads a module, unless it already has been loaded. PATHNAMES, if supplied, + is a designator for a list of pathnames to be loaded if the module + needs to be. If PATHNAMES is not supplied, functions from the list + *MODULE-PROVIDER-FUNCTIONS* are called in order with MODULE-NAME + as an argument, until one of them returns non-NIL. User code is + responsible for calling PROVIDE to indicate a successful load of the + module." + (let* ((str (string module)) + (original-modules (copy-list *modules*))) + (unless (or (member str *modules* :test #'string=) + (member str *loading-modules* :test #'string=)) + ;; The check of (and binding of) *LOADING-MODULES* is a + ;; traditional defense against circularity. (Another + ;; defense is not having circularity, of course.) The + ;; effect is that if something's in the process of being + ;; REQUIREd and it's REQUIREd again (transitively), + ;; the inner REQUIRE is a no-op. + (let ((*loading-modules* (cons str *loading-modules*))) + (if pathname + (dolist (path (if (atom pathname) (list pathname) pathname)) + (load path)) + (unless (some (lambda (p) (funcall p module)) + *module-provider-functions*) + (error "Module ~A was not provided by any function on ~S." module '*module-provider-functions*))))) + (values module + (set-difference *modules* original-modules)))) + +(defun find-module-pathnames (module) + "Returns the file or list of files making up the module" + (let ((mod-path (make-pathname :name (string-downcase module) :defaults nil)) path) + (dolist (path-cand *module-search-path* nil) + (let ((mod-cand (merge-pathnames mod-path path-cand))) + (if (wild-pathname-p path-cand) + (let* ((untyped-p (member (pathname-type mod-cand) '(nil :unspecific))) + (matches (if untyped-p + (or (directory (merge-pathnames mod-cand *.lisp-pathname*)) + (directory (merge-pathnames mod-cand *.fasl-pathname*))) + (directory mod-cand)))) + (when (and matches (null (cdr matches))) + (return (if untyped-p + (make-pathname :type nil :defaults (car matches)) + (car matches))))) + (when (setq path (find-load-file (merge-pathnames mod-path path-cand))) + (return path))))))) + +(defun module-provide-asdf (module) + (let* ((asdf-package (find-package "ASDF"))) + (when asdf-package + (let* ((verbose-out (find-symbol "*VERBOSE-OUT*" asdf-package)) + (find-system (find-symbol "FIND-SYSTEM" asdf-package)) + (operate (find-symbol "OPERATE" asdf-package)) + (load-op (find-symbol "LOAD-OP" asdf-package))) + (when (and verbose-out find-system operate load-op) + (progv (list verbose-out) (list (make-broadcast-stream)) + (let* ((system (funcall find-system module nil))) + (when system + (funcall operate load-op module) + t)))))))) + +(defun wild-pathname-p (pathname &optional field-key) + "Predicate for determining whether pathname contains any wildcards." + (flet ((wild-p (name) (or (eq name :wild) + (eq name :wild-inferiors) + (and (stringp name) (%path-mem "*" name))))) + (case field-key + ((nil) + (or (some #'wild-p (pathname-directory pathname)) + (wild-p (pathname-name pathname)) + (wild-p (pathname-type pathname)) + (wild-p (pathname-version pathname)))) + (:host nil) + (:device nil) + (:directory (some #'wild-p (pathname-directory pathname))) + (:name (wild-p (pathname-name pathname))) + (:type (wild-p (pathname-type pathname))) + (:version (wild-p (pathname-version pathname))) + (t (wild-pathname-p pathname + (require-type field-key + '(member nil :host :device + :directory :name :type :version))))))) Index: /branches/new-random/level-1/l1-format.lisp =================================================================== --- /branches/new-random/level-1/l1-format.lisp (revision 13309) +++ /branches/new-random/level-1/l1-format.lisp (revision 13309) @@ -0,0 +1,444 @@ +;;;-*-Mode: LISP; Package: CCL -*- +;;; +;;; Copyright (C) 2009 Clozure Associates +;;; Copyright (C) 1994-2001 Digitool, Inc +;;; This file is part of Clozure CL. +;;; +;;; Clozure CL is licensed under the terms of the Lisp Lesser GNU Public +;;; License , known as the LLGPL and distributed with Clozure CL as the +;;; file "LICENSE". The LLGPL consists of a preamble and the LGPL, +;;; which is distributed with Clozure CL as the file "LGPL". Where these +;;; conflict, the preamble takes precedence. +;;; +;;; Clozure CL is referenced in the preamble as the "LIBRARY." +;;; +;;; The LLGPL is also available online at +;;; http://opensource.franz.com/preamble.html + +;; L1-format.lisp +; +; This file contains the definition for SUB-FORMAT, the dispatching part +; of FORMAT. It also contains an interim definition for FORMAT and a few +; incompletely implemented directives. + +(in-package "CCL") + +(eval-when (eval compile #-bccl load) ;Load-time as well so CCL can use it. + (defmacro defformat (char name &rest def) + `(progn + (add-format-char ,char (nfunction ,name (lambda . ,def))) + ',name)) + ) + +(defparameter *format-char-table* (let* ((x (make-array 128 :initial-element nil))) x)) + +(defun add-format-char (char def) + (unless (and (characterp char) (%i< (%char-code char) 128)) + (report-bad-arg char 'standard-char)) + (setf (svref *format-char-table* (%char-code (char-upcase char))) def)) + +(proclaim '(special *format-original-arguments* ;For ~* + *format-arguments* ;For pop-format-arg + *format-control-string* ;For ~?, ~{ + *format-index* + *format-length* + *format-pprint* ;~I,~W,~_,~:T seen? + *format-justification-semi* ;~<..~:;..~> seen? + )) + +(defun pop-format-arg (&aux (args *format-arguments*)) + (if (null args) + (format-error "Missing argument")) + (progn + (setq *format-arguments* (cdr args)) + (%car args))) + +;SUB-FORMAT parses (a range of) the control string, finding the directives +;and applying them to their parameters. +;Implicit arguments to SUB-FORMAT: *format-control-string*, *format-arguments*, +;*format-original-arguments*, *standard-output*, *format-char-table* +;*format-control-string* must be a simple string. +;Directive functions' arglist should be (colon-p atsign-p &rest params) +;In addition when the directive is called, *format-index* and *format-length* +;are bound to start and end pos (in *format-control-string*) of the rest of the +; control string. The directive may modify *format-index*, but not +; *format-control-string* and *format-length*, before returning. + +(defun sub-format (stream *format-index* *format-length* &aux char) + (prog* ((string (require-type *format-control-string* 'simple-string)) + (length *format-length*) + (i *format-index*) + (lastpos i)) + (declare (fixnum i length lastpos) (type simple-string string)) + (go START) + EOF-ERROR + (setq *format-index* *format-length*) + (format-error "Premature end of control string") + START + (do* () + ((= i length) (unless (= i lastpos) + (write-string string stream :start lastpos :end i))) + (setq char (schar string i) i (1+ i)) + (when (eq char #\~) + (let* ((limit (the fixnum (1- i)))) + (unless (= limit lastpos) + (write-simple-string string stream lastpos limit))) + (let ((params nil) (fn) (colon nil) (atsign nil)) + (block nil + (tagbody + NEXT + (if (= i length) (go EOF-ERROR)) + (setq char (schar string i) i (1+ i)) + (cond ((eq char #\#) + (push (list-length *format-arguments*) params)) + ((eq char #\') + (if (= i length) (go EOF-ERROR)) + (push (schar string i) params) + (incf i)) + ((eq char #\,) + (push nil params) + (go NEXT)) + ((or (eq char #\V) (eq char #\v)) + (push (pop-format-arg) params)) + ((or (eq char #\-) (eq char #\+) (digit-char-p char)) + (let ((start (%i- i 1)) n) + (loop + (when (= i length) (go EOF-ERROR)) + (unless (digit-char-p (schar string i)) (return)) + (incf i)) + (when (null (setq n (%parse-number-token string start i))) + (setq *format-index* i) + (format-error "Illegal parameter")) + (push n params))) + (t (return))) + (if (= i length) (go EOF-ERROR)) + (setq char (schar string i) i (1+ i)) + (when (neq char #\,) (return)) + (go NEXT))) + (cond ((eq char #\:) + (if (= i length) (go EOF-ERROR)) + (setq colon t char (schar string i) i (1+ i)) + (when (eq char #\@) + (if (= i length) (go EOF-ERROR)) + (setq atsign t char (schar string i) i (1+ i)))) + ((eq char #\@) + (if (= i length) (go EOF-ERROR)) + (setq atsign t char (schar string i) i (1+ i)) + (when (eq char #\:) + (if (= i length) (go EOF-ERROR)) + (setq colon t char (schar string i) i (1+ i))))) + (setq *format-index* (%i- i 1)) + (if (setq fn (svref *format-char-table* (%char-code (char-upcase char)))) + (apply fn stream colon atsign (nreverse params)) + (format-error "Unknown directive")) + (setq i (%i+ *format-index* 1) + lastpos i)))))) + + +#|| +(eval-when (load) + ;The non-consing version. +(defun sub-format (stream *format-index* *format-length*) + (declare (special *format-index* *format-length*)) + (old-lap-inline (stream) + (preserve_regs #(asave0 asave1 dsave0 dsave1 dsave2)) + (defreg Control-string asave0 Index dsave0 Length dsave1 NumParams dsave2 Stream asave1) + (move.l acc Stream) + (move.l (special *format-index*) Index) ; *format-index* + (move.l (special *format-length*) Length) ; *format-length* + (specref *format-control-string*) + (move.l acc Control-string) + + ;Make sure everything is in bounds, so don't have to worry about + ;boxing, bounds checking, etc. +start + (movereg Control-string arg_z) + (jsr_subprim $sp-length) + (ccall <= '0 Index Length acc) + (cmp.l nilreg acc) + (beq done) + (move.l Index db) + (loop# + (if# (eq Length Index) + (cmp.l db Index) + (beq done) + (ccall 'stream-write-string Stream Control-string db Index) + (bra done)) + (move.l Index da) + (getint da) + (move.l ($ $t_imm_char 0) acc) + (move.b (Control-string da.l $v_data) acc) + (add.l (fixnum 1) Index) + (cmp.b ($ #\~) acc) + (beq tilde)) + +nextchar + (if# (eq Length Index) + (move.l '"Premature end of format control string" arg_z) + (add.w ($ 4) sp) ; flush internal bsr. + (bra error)) + (move.l Index da) + (getint da) + (move.b (Control-string da.l $v_data) acc) + (add.l (fixnum 1) Index) + (if# (and (ge (cmp.b ($ #\a) acc)) (le (cmp.b ($ #\z) acc))) + (sub.b ($ 32) acc)) + (rts) + +tilde + (move.l Index da) + (sub.l (fixnum 1) da) + (if# (not (eq da db)) + (ccall 'stream-write-string Stream Control-string db da)) + (vpush Stream) + (vpush nilreg) ;assume no : + (vpush nilreg) ;assume no @ + (move.l (fixnum 3) NumParams) +do-param + (bsr nextchar) + (if# (or (eq (cmp.b ($ #\+) acc)) + (eq (cmp.b ($ #\-) acc)) + (and (ge (cmp.b ($ #\0) acc)) (le (cmp.b ($ #\9) acc)))) + (move.l Index da) + (sub.l (fixnum 1) da) + (vpush da) + (prog# + (bsr nextchar) + (until# (or (lt (cmp.b ($ #\0) acc)) (gt (cmp.b ($ #\9) acc))))) + (sub.l (fixnum 1) Index) ;unread the non-digit char + (ccall %parse-number-token Control-string vsp@+ Index) + (cmp.l nilreg acc) + (bne push-param) + (move.l '"Illegal format parameter" arg_z) + (bra error)) + + (if# (eq (cmp.b ($ #\#) acc)) + (move.l (special *format-arguments*) acc) + (jsr_subprim $sp-length) + (bra push-param)) + + (if# (eq (cmp.b ($ #\') acc)) + (bsr nextchar) + (move.l ($ $t_imm_char 0) acc) + (move.b (Control-string da.l $v_data) acc) ;Get the non-uppercased version... + (swap acc) + (bra push-param)) + + (if# (eq (cmp.b ($ #\,) acc)) + (sub.l (fixnum 1) Index) ;Re-read the comma. + (move.l nilreg acc) + (bra push-param)) + + (if# (eq (cmp.b ($ #\V) acc)) + (ccall 'pop-format-arg) + ;(bra push-param) + push-param + (vpush acc) + (add.l (fixnum 1) NumParams) + (bsr nextchar) + (cmp.b ($ #\,) acc) + (beq do-param)) + + (move.l NumParams nargs) + (vscale.l nargs) + (cmp.b ($ #\:) acc) + (if# eq + (bsr nextchar) + (cmp.b ($ #\@) acc) + (bne @a) + (move.l (a5 $t) (vsp nargs.w -12)) + else# + (cmp.b ($ #\@) acc) + (bne @b) + (move.l (a5 $t) (vsp nargs.w -12)) + (bsr nextchar) + (cmp.b ($ #\:) acc) + (bne @b)) + (bsr nextchar) +@a (move.l (a5 $t) (vsp nargs.w -8)) +@b (moveq 127 da) + (and.w acc da) + (bif (ne (cmp.b da acc)) nofun) + (lsl.w 2 da) + (move.l (special *format-char-table*) atemp0) + (move.l (atemp0 da.w $v_data) atemp0) + (cmp.l atemp0 nilreg) + (beq nofun) + (move.l Index da) + (sub.l (fixnum 1) da) + (move.l da (special *format-index*)) + (move.l NumParams nargs) + (vscale.l nargs) ; at least 3 args. + (movem.l vsp@+ #(arg_z arg_y arg_x)) + (jsr_subprim $sp-funcall) + (specref '*format-index*) + (add.l (fixnum 1) acc) + (move.l acc Index) + (bra start) + +nofun + (move.l '"Unknown format directive" acc) +error + (move.l Index (special *format-index*)) + (fsymevalapply 'format-error 1) + +done + (restore_regs) + )) +) ;end of eval-when (load) + +||# + +;;;Interim definitions + +;;;This function is shadowed by CCL in order to use ~{ to print error messages. +(fset 'format + (nlambda bootstrapping-format (stream control-string &rest format-arguments) + (declare (dynamic-extent format-arguments)) + (block format + (when (null stream) + (return-from format + (with-output-to-string (x) + (apply #'format x control-string format-arguments)))) + (if (eq stream t) + (setq stream *standard-output*) + (unless (streamp stream) (report-bad-arg stream 'stream))) + (if (functionp control-string) + (apply control-string stream format-arguments) + (progn + (setq control-string (ensure-simple-string control-string)) + (let* ((*format-original-arguments* format-arguments) + (*format-arguments* format-arguments) + (*format-control-string* control-string)) + (catch 'format-escape + (sub-format stream 0 (length control-string))) + nil)))))) + +(fset 'format-error + (nlambda bootstrapping-format-error (&rest args) + (format t "~&FORMAT error at position ~A in control string ~S " + *format-index* *format-control-string*) + (apply #'error args))) + +(defun format-no-flags (colon atsign) + (cond ((and colon atsign) + (format-error "Flags not allowed")) + (colon + (format-error ": flag not allowed")) + (atsign + (format-error "@ flag not allowed")))) + +;Redefined later +(defformat #\A format-a (stream colon atsign) + (declare (ignore colon atsign)) + (princ (pop-format-arg) stream)) + +;Redefined later +(defformat #\S format-s (stream colon atsign) + (declare (ignore colon atsign)) + (prin1 (pop-format-arg) stream)) + +;Redefined later +(defformat #\^ format-escape (stream colon atsign) + (declare (ignore stream colon atsign)) + (throw 'format-escape t)) + +;Final version +(defformat #\% format-% (stream colon atsign &optional repeat-count) + (format-no-flags colon atsign) + (cond ((or (not repeat-count) + (and (fixnump repeat-count) + (> repeat-count -1))) + (dotimes (i (or repeat-count 1)) (declare (fixnum i)) (terpri stream))) + (t (format-error "Bad repeat-count.")))) + +;Final version +(defformat #\& format-& (stream colon atsign &optional repeat-count) + (format-no-flags colon atsign) + (cond ((or (not repeat-count) + (and (fixnump repeat-count) + (> repeat-count -1))) + (unless (eq repeat-count 0) + (fresh-line stream) + (dotimes (i (1- (or repeat-count 1))) (declare (fixnum i)) (terpri stream)))) + (t (format-error "Bad repeat-count.")))) + +;Final version +(defformat #\~ format-~ (stream colon atsign &optional repeat-count) + (format-no-flags colon atsign) + (cond ((or (not repeat-count) + (and (fixnump repeat-count) + (> repeat-count -1))) + (dotimes (i (or repeat-count 1)) (declare (fixnum i)) (write-char #\~ stream))) + (t (format-error "Bad repeat-count.")))) + +;Final version +(defformat #\P format-p (stream colon atsign) + (when colon + (let ((end *format-arguments*) (list *format-original-arguments*)) + (tagbody loop + (if list + (when (neq (cdr list) end) + (setq list (%cdr list)) + (go loop)) + (format-error "No previous argument"))) + (setq *format-arguments* list))) + (%write-string (if (eq (pop-format-arg) 1) + (if atsign "y" "") + (if atsign "ies" "s")) + stream)) + +;Final version +(defformat #\* format-* (stream colon atsign &optional count) + (declare (ignore stream)(special *circularity-hash-table*)) + (let* ((orig *format-original-arguments*) + (where (- (list-length orig) ; will error if args circular + (list-length *format-arguments*))) + (to (if atsign + (progn + (format-no-flags colon nil) + (or count 0)) ; absolute + (progn + (when (null count)(setq count 1)) + (when colon (setq count (- count))) + (%i+ where count)))) + (args (nthcdr-no-overflow to orig))) + ; avoid bogus circularity indication + (when (and nil (consp args) (<= to where) *circularity-hash-table*) + ; copy only from to thru where in case some real shared structure + (let ((l args) new) + (dotimes (i (1+ (- where to))) + (declare (fixnum i)) + (push (car l) new) + (setq l (cdr l))) + (setq args (nreconc new (nthcdr (1+ where) orig))))) ;(copy-list args))) + (setq *format-arguments* args))) + +; Redefined later. +(defformat #\Newline format-newline (&rest ignore) + (declare (ignore ignore)) + (do* ((i *format-index* (1+ i)) + (s *format-control-string*) + (n *format-length*)) + ((or (= i n) + (not (whitespacep (schar s i)))) + (setq *format-index* (1- i))))) + +(defun nthcdr-no-overflow (count list) + (if (or (> count (list-length list)) (< count 0)) + (format-error "non-existent target for ~*") + (nthcdr count list))) + +;Redefined later +(defformat #\X format-x (stream colon atsign) + (declare (ignore colon atsign)) + (let* ((*print-base* 16.) + (*print-radix* nil)) + (prin1 (pop-format-arg) stream))) + +;Redefined later +(defformat #\D format-d (stream colon atsign &rest ignore) + (declare (ignore colon atsign ignore)) + (let* ((*print-base* 10.) + (*print-radix* nil)) + (prin1 (pop-format-arg) stream))) Index: /branches/new-random/level-1/l1-init.lisp =================================================================== --- /branches/new-random/level-1/l1-init.lisp (revision 13309) +++ /branches/new-random/level-1/l1-init.lisp (revision 13309) @@ -0,0 +1,329 @@ +;;;-*-Mode: LISP; Package: CCL -*- +;;; +;;; Copyright (C) 2009 Clozure Associates +;;; Copyright (C) 1994-2001 Digitool, Inc +;;; This file is part of Clozure CL. +;;; +;;; Clozure CL is licensed under the terms of the Lisp Lesser GNU Public +;;; License , known as the LLGPL and distributed with Clozure CL as the +;;; file "LICENSE". The LLGPL consists of a preamble and the LGPL, +;;; which is distributed with Clozure CL as the file "LGPL". Where these +;;; conflict, the preamble takes precedence. +;;; +;;; Clozure CL is referenced in the preamble as the "LIBRARY." +;;; +;;; The LLGPL is also available online at +;;; http://opensource.franz.com/preamble.html + +(in-package "CCL") + +(eval-when (:compile-toplevel :execute :load-toplevel) + +(defconstant most-positive-short-float (make-short-float-from-fixnums (1- (ash 1 23)) 254 0)) +(defconstant most-negative-short-float (make-short-float-from-fixnums (1- (ash 1 23)) 254 -1)) +(defconstant most-positive-single-float (make-short-float-from-fixnums (1- (ash 1 23)) 254 0)) +(defconstant most-negative-single-float (make-short-float-from-fixnums (1- (ash 1 23)) 254 -1)) + + +(defconstant least-positive-short-float (make-short-float-from-fixnums 1 0 0)) +(defconstant least-negative-short-float (make-short-float-from-fixnums 1 0 -1)) +(defconstant least-positive-single-float (make-short-float-from-fixnums 1 0 0)) +(defconstant least-negative-single-float (make-short-float-from-fixnums 1 0 -1)) + +(defconstant short-float-epsilon (make-short-float-from-fixnums 1 103 0)) +(defconstant short-float-negative-epsilon (make-short-float-from-fixnums 1 102 0)) +(defconstant single-float-epsilon (make-short-float-from-fixnums 1 103 0)) +(defconstant single-float-negative-epsilon (make-short-float-from-fixnums 1 102 0)) + +(defconstant least-positive-normalized-short-float (make-short-float-from-fixnums 1 1 0)) +(defconstant least-negative-normalized-short-float (make-short-float-from-fixnums 1 1 -1)) +(defconstant least-positive-normalized-single-float (make-short-float-from-fixnums 1 1 0)) +(defconstant least-negative-normalized-single-float (make-short-float-from-fixnums 1 1 -1)) + +(let ((bigfloat (make-float-from-fixnums #x1ffffff #xfffffff #x7fe 0))) + ; do it this way if you want to be able to compile before reading floats works + (defconstant most-positive-double-float bigfloat) + (defconstant most-positive-long-float bigfloat) + ) + +(let ((littleposfloat (make-float-from-fixnums 0 1 0 0 ))) + (defconstant least-positive-double-float littleposfloat) + (defconstant least-positive-long-float littleposfloat) + ) + +(let ((littlenegfloat (make-float-from-fixnums 0 1 0 -1))) + (defconstant least-negative-double-float littlenegfloat) + (defconstant least-negative-long-float littlenegfloat) + ) + +(let ((bignegfloat (make-float-from-fixnums #x1ffffff #xfffffff #x7fe -1))) + (defconstant most-negative-double-float bignegfloat) + (defconstant most-negative-long-float bignegfloat) + ) + +(let ((eps (make-float-from-fixnums #x1000000 1 #x3ca 0))) ;was wrong + (defconstant double-float-epsilon eps) + (defconstant long-float-epsilon eps) + ) + +(let ((eps- (make-float-from-fixnums #x1000000 1 #x3c9 1))) + (defconstant double-float-negative-epsilon eps-) + (defconstant long-float-negative-epsilon eps-) + ) + +(let ((norm (make-float-from-fixnums 0 0 1 0))) + (defconstant least-positive-normalized-double-float norm) + (defconstant least-positive-normalized-long-float norm) + ) + +(let ((norm- (make-float-from-fixnums 0 0 1 -1))) + (defconstant least-negative-normalized-double-float norm-) + (defconstant least-negative-normalized-long-float norm-) + ) + +(defconstant pi (make-float-from-fixnums #x921fb5 #x4442d18 #x400 0)) + +) + + + +(defconstant boole-clr 0 + "Boole function op, makes BOOLE return 0.") +(defconstant boole-set 1 + "Boole function op, makes BOOLE return -1.") +(defconstant boole-1 2 + "Boole function op, makes BOOLE return integer1.") +(defconstant boole-2 3 + "Boole function op, makes BOOLE return integer2.") +(defconstant boole-c1 4 + "Boole function op, makes BOOLE return complement of integer1.") +(defconstant boole-c2 5 + "Boole function op, makes BOOLE return complement of integer2.") +(defconstant boole-and 6 + "Boole function op, makes BOOLE return logand of integer1 and integer2.") +(defconstant boole-ior 7 + "Boole function op, makes BOOLE return logior of integer1 and integer2.") +(defconstant boole-xor 8 + "Boole function op, makes BOOLE return logxor of integer1 and integer2.") +(defconstant boole-eqv 9 + "Boole function op, makes BOOLE return logeqv of integer1 and integer2.") +(defconstant boole-nand 10 + "Boole function op, makes BOOLE return log nand of integer1 and integer2.") +(defconstant boole-nor 11 + "Boole function op, makes BOOLE return lognor of integer1 and integer2.") +(defconstant boole-andc1 12 + "Boole function op, makes BOOLE return logandc1 of integer1 and integer2.") +(defconstant boole-andc2 13 + "Boole function op, makes BOOLE return logandc2 of integer1 and integer2.") +(defconstant boole-orc1 14 + "Boole function op, makes BOOLE return logorc1 of integer1 and integer2.") +(defconstant boole-orc2 15 + "Boole function op, makes BOOLE return logorc2 of integer1 and integer2.") + + + +(defconstant internal-time-units-per-second #+64-bit-target 1000000 #-64-bit-target 1000 + "The number of internal time units that fit into a second. See + GET-INTERNAL-REAL-TIME and GET-INTERNAL-RUN-TIME.") + +(defconstant char-code-limit #.(arch::target-char-code-limit + (backend-target-arch *target-backend*)) + "the upper exclusive bound on values produced by CHAR-CODE") + +(defconstant array-rank-limit (floor #x8000 target::node-size) + "the exclusive upper bound on the rank of an array") +(defconstant multiple-values-limit 200 + "The exclusive upper bound on the number of multiple VALUES that you can + return.") +(defconstant lambda-parameters-limit (floor #x8000 target::node-size) + "The exclusive upper bound on the number of parameters which may be specifed + in a given lambda list. This is actually the limit on required and &OPTIONAL + parameters. With &KEY and &AUX you can get more.") +(defconstant call-arguments-limit (floor #x8000 target::node-size) + "The exclusive upper bound on the number of arguments which may be passed + to a function, including &REST args." +) + +; Currently, vectors can be at most (expt 2 22) bytes, and +; the largest element (double-float or long-float) is 8 bytes: +#| to get largest element size... +(apply #'max (mapcar #'(lambda (type) + (%vect-byte-size (make-array 1 :element-type type))) + *cl-types*)) +|# + +(defconstant array-dimension-limit array-total-size-limit + "the exclusive upper bound on any given dimension of an array") + +(defconstant most-positive-fixnum target::target-most-positive-fixnum + "the fixnum closest in value to positive infinity") +(defconstant most-negative-fixnum target::target-most-negative-fixnum + "the fixnum closest in value to negative infinity") + + +(defconstant lambda-list-keywords + '(&OPTIONAL &REST &AUX &KEY &ALLOW-OTHER-KEYS &BODY &ENVIRONMENT &WHOLE) + "symbols which are magical in a lambda list") + +(defstatic *type-system-initialized* nil) + +(defparameter %toplevel-catch% ':toplevel) + +(defvar *read-default-float-format* 'single-float) + +(defvar *read-suppress* nil + "Suppress most interpreting in the reader when T.") + +(defvar *read-base* 10. + "the radix that Lisp reads numbers in") + + +(defparameter *warn-if-redefine-kernel* nil + "When true, attempts to redefine (via DEFUN or DEFMETHOD) functions and +methods that are marked as being predefined signal continuable errors.") + +(defvar *next-screen-context-lines* 2 "Number of lines to show of old screen + after a scroll-up or scroll-down.") + +(defparameter *compiling-file* nil + "Name of outermost file being compiled or NIL if not compiling a file.") + +(defvar *eval-fn-name* nil) + + +(defvar *compile-definitions* t + "When non-NIL and the evaluator's lexical environment contains no + lexical entities, causes FUNCTION and NFUNCTION forms to be compiled.") +#| +(defvar *fast-eval* () + "If non-nil, compile-and-call any forms which would be expensive to evaluate.") +|# +(defvar *declaration-handlers* ()) + + +(defvar *lisp-system-pointer-functions* nil) +(defvar *lisp-user-pointer-functions* nil) +(defvar *lisp-cleanup-functions* nil) ; list of (0-arg) functions to call before quitting Lisp +(defvar *lisp-startup-functions* nil) ; list of funs to call after startup. +(defvar %lisp-system-fixups% nil) + + +(setf (*%saved-method-var%*) nil) + +; The GC expects these to be NIL or a function of no args +(defvar *pre-gc-hook* nil) +(defvar *post-gc-hook* nil) + +; These are used by add-gc-hook, delete-gc-hook +(defvar *pre-gc-hook-list* nil) +(defvar *post-gc-hook-list* nil) + +(defvar *backtrace-dialogs* nil) +;(defvar *stepper-running* nil) +(defparameter *last-mouse-down-time* 0) +(defparameter *last-mouse-down-position* 0) + +(defvar %handlers% ()) + + +#| +(defvar %restarts% (list (list (%cons-restart 'abort + #'(lambda (&rest ignore) + (declare (ignore ignore)) + (throw :toplevel nil)) + "Restart the toplevel loop." + nil + nil)))) +|# + +(defvar %restarts% nil) + +(defvar ccl::*kernel-restarts* nil) +(defvar *condition-restarts* nil "explicit mapping between c & r") +(declaim (list %handlers% %restarts% ccl::*kernel-restarts* *condition-restarts*)) + + + + +(defparameter *%periodic-tasks%* nil) +(defparameter *dribble-stream* nil) + +(defconstant *keyword-package* *keyword-package*) +(defconstant *common-lisp-package* *common-lisp-package*) +(defconstant *ccl-package* *ccl-package*) + +(defparameter *load-print* nil "the default for the :PRINT argument to LOAD") +(defparameter *loading-files* nil) +(defparameter *break-level* 0) +(defparameter *last-break-level* 0) +(defparameter *warn-if-redefine* nil) +(defvar *record-source-file*) ; set in l1-utils. +(defparameter *level-1-loaded* nil) ; set t by l1-boot +(defparameter *save-definitions* nil) +(defparameter *save-local-symbols* t) +(defparameter *save-source-locations* T + "Controls whether source location information is saved, both for definitions (names) and +in function objects. + +If NIL we don't store any source locations (other than the filename if *record-source-file* is non-NIL). + +If T we store as much source location information as we have available. + +If :NO-TEXT we don't store a copy of the original source text. This is a space optimization useful +for compiling files that are not expected to change.") + +(defparameter *record-pc-mapping* t "True to record pc -> source mapping (but only if +*save-source-locations* is also true)") + +(defvar *modules* nil + "This is a list of module names that have been loaded into Lisp so far. + The names are case sensitive strings. It is used by PROVIDE and REQUIRE.") + + + + + +(defparameter *eof-value* (cons nil nil)) + +(defvar *gc-event-status-bits*) ; also initialized by kernel + +(defparameter *top-listener* nil) + + + + + + + +(defvar *listener-indent* nil) + +(defparameter *autoload-lisp-package* nil) ; Make 'em suffer +(defparameter *apropos-case-sensitive-p* nil) + +(defloadvar *total-gc-microseconds* (let* ((timeval-size + #.(%foreign-type-or-record-size + :timeval :bytes)) + (p (malloc (* 5 timeval-size)))) + (#_memset p 0 (* 5 timeval-size)) + p)) + + +(defloadvar *total-bytes-freed* (let* ((p (malloc 8))) + (setf (%get-long p 0) 0 + (%get-long p 4) 0) + p)) + + + +(defvar *terminal-character-encoding-name* nil + "NIL (implying :ISO-8859-1), or a keyword which names a defined +character encoding to be used for *TERMINAL-IO* and other predefined +initial streams. The value of *TERMINAL-CHARACTER-ENCODING-NAME* +persists across calls to SAVE-APPLICATION; it can be specified via +the command-line argument --terminal-encoding (-K)") + + +(defconstant +null-ptr+ (%null-ptr)) + +;;; end of L1-init.lisp + Index: /branches/new-random/level-1/l1-io.lisp =================================================================== --- /branches/new-random/level-1/l1-io.lisp (revision 13309) +++ /branches/new-random/level-1/l1-io.lisp (revision 13309) @@ -0,0 +1,1968 @@ +;;; -*- Mode: LISP; Package: CCL -*- +;;; +;;; Copyright (C) 2009 Clozure Associates +;;; Copyright (C) 1994-2001 Digitool, Inc +;;; This file is part of Clozure CL. +;;; +;;; Clozure CL is licensed under the terms of the Lisp Lesser GNU Public +;;; License , known as the LLGPL and distributed with Clozure CL as the +;;; file "LICENSE". The LLGPL consists of a preamble and the LGPL, +;;; which is distributed with Clozure CL as the file "LGPL". Where these +;;; conflict, the preamble takes precedence. +;;; +;;; Clozure CL is referenced in the preamble as the "LIBRARY." +;;; +;;; The LLGPL is also available online at +;;; http://opensource.franz.com/preamble.html + +;; L1-io.lisp + +(in-package "CCL") + +(setf (fdefinition '%new-ptr) (fdefinition '%new-gcable-ptr)) + + +;;;; ====================================================================== +;;;; Standard CL IO frobs + + +(declaim (inline %real-print-stream)) +(defun %real-print-stream (&optional (stream nil)) + (cond ((null stream) + *standard-output*) + ((eq stream t) + *terminal-io*) + (t stream))) + +;;; OK, EOFP isn't CL ... +(defun eofp (&optional (stream *standard-input*)) + (stream-eofp stream)) + +(defun force-output (&optional stream) + (stream-force-output (%real-print-stream stream)) + nil) + +(defun listen (&optional (stream *standard-input*)) + (let* ((stream (designated-input-stream stream))) + (stream-listen stream))) + +(defun fresh-line (&optional (output-stream *standard-output*)) + "Output #\Newline only if the OUTPUT-STREAM is not already at the +start of a line. Return T if #\Newline needed." + (stream-fresh-line (%real-print-stream output-stream))) + +(defun column (&optional stream) + (let* ((stream (%real-print-stream stream))) + (stream-line-column stream))) + +(defun clear-input (&optional input-stream) + "Clear any available input from INPUT-STREAM." + (stream-clear-input (designated-input-stream input-stream)) + nil) + +(defun write-char (char &optional (output-stream nil)) + "Output CHAR to OUTPUT-STREAM." + (let* ((stream (%real-print-stream output-stream))) + (if (typep stream 'basic-stream) + (let* ((ioblock (basic-stream-ioblock stream))) + (funcall (ioblock-write-char-function ioblock) ioblock char)) + (stream-write-char stream char)) + char)) + +(defun write-string (string &optional output-stream &key (start 0 start-p) + (end nil end-p)) + "Write the characters of the subsequence of STRING bounded by START +and END to OUTPUT-STREAM." + (let* ((stream (%real-print-stream output-stream))) + (if (typep stream 'basic-stream) + (let* ((ioblock (basic-stream-ioblock stream))) + (with-ioblock-output-locked (ioblock) + (if (and (typep string 'simple-string) + (not start-p) (not end-p)) + (funcall (ioblock-write-simple-string-function ioblock) + ioblock string 0 (length string)) + (progn + (setq end (check-sequence-bounds string start end)) + (locally (declare (fixnum start end)) + (multiple-value-bind (arr offset) + (if (typep string 'simple-string) + (values string 0) + (array-data-and-offset (require-type string 'string))) + (unless (eql 0 offset) + (incf start offset) + (incf end offset)) + (funcall (ioblock-write-simple-string-function ioblock) + ioblock arr start (the fixnum (- end start))))))))) + (if (and (not start-p) (not end-p)) + (stream-write-string stream string) + (stream-write-string stream string start end))) + string)) + +(defun write-simple-string (string output-stream start end) + "Write the characters of the subsequence of simple-string STRING bounded by START +and END to OUTPUT-STREAM." + (let* ((stream (%real-print-stream output-stream)) + (string (the simple-string string))) ;; typecheck at high safety. + (if (typep stream 'basic-stream) + (let* ((ioblock (basic-stream-ioblock stream)) + (start (or start 0))) + (with-ioblock-output-locked (ioblock) + (if (and (eq start 0) (null end)) + (funcall (ioblock-write-simple-string-function ioblock) + ioblock string 0 (length string)) + (let* ((end (check-sequence-bounds string start end))) + (funcall (ioblock-write-simple-string-function ioblock) + ioblock string start (%i- end start)))))) + (if (and (not start) (not end)) + (stream-write-string stream string) + (stream-write-string stream string start (or end (length string))))) + string)) + +(defun write-line (string &optional output-stream + &key (start 0) (end (length string))) + "Write the characters of the subsequence of STRING bounded by START +and END to OUTPUT-STREAM then output a #\Newline at end." + (write-string string output-stream :start start :end end) + (terpri output-stream) + string) + +(defun terpri (&optional (stream *standard-output*)) + (let* ((stream (%real-print-stream stream))) + (if (typep stream 'basic-stream) + (let* ((ioblock (basic-stream-ioblock stream))) + (funcall (ioblock-write-char-function ioblock) ioblock #\newline)) + (stream-write-char stream #\newline)) + nil)) + +;;;; ---------------------------------------------------------------------- + + + +;;;; ====================================================================== +;;;; The Lisp Printer + + +;; coral extensions +(defvar *print-abbreviate-quote* t + "Non-NIL means that the normal lisp printer -- +not just the pretty-printer -- should print +lists whose first element is QUOTE or FUNCTION specially. +This variable is not part of standard Common Lisp.") + +(defvar *print-structure* t + "Non-NIL means that lisp structures should be printed using +\"#S(...)\" syntax. if nil, structures are printed using \"#<...>\". +This variable is not part of standard Common Lisp.") + +;; things Richard Mlynarik likes. +(defvar *print-simple-vector* nil + "Non-NIL means that simple-vectors whose length is less than +the value of this variable are printed even if *PRINT-ARRAY* is false. +this variable is not part of standard Common Lisp.") + +(defvar *print-simple-bit-vector* nil + "Non-NIL means that simple-bit-vectors whose length is less than +the value of this variable are printed even if *PRINT-ARRAY* is false. +This variable is not part of standard Common Lisp.") + +(defvar *print-string-length* nil + "Non-NIL means that strings longer than this are printed +using abbreviated # syntax. +This variable is not part of standard Common Lisp.") + +(defvar *print-escape* t + "Non-NIL means that the lisp printer should -attempt- to output +expressions `readably.' When NIL the attempts to produce output +which is a little more human-readable (for example, pathnames +are represented by the characters of their namestring.)") + +(defvar *print-pretty* nil + "Non-NIL means that the lisp printer should insert extra +indentation and newlines to make output more readable and `prettier.'") + +(defvar *print-base* 10. + "The output base for integers and rationals. +Must be an integer between 2 and 36.") + +(defvar *print-radix* nil + "Non-NIL means that the lisp printer will explicitly indicate +the output radix (see *PRINT-BASE*) which is used to print +integers and rational numbers.") + +(defvar *print-level* nil + "Specifies the depth at which printing of lisp expressions +should be truncated. NIL means that no such truncation should occur. +Truncation is indicated by printing \"#\" instead of the +representation of the too-deeply-nested structure. +See also *PRINT-LENGTH*") + +(defvar *print-length* nil + "Specifies the length at which printing of lisp expressions +should be truncated. NIL means that no such truncation should occur. +truncation is indicated by printing \"...\" instead of the +rest of the overly-long list or vector. +See also *PRINT-LEVEL*") + +(defvar *print-circle* nil + "Non-NIL means that the lisp printer should attempt to detect +circular structures, indicating them by using \"#n=\" and \"#n#\" syntax. +If this variable is false then an attempt to +output circular structure may cause unbounded output.") + +(defvar *print-case* ':upcase + "Specifies the alphabetic case in which symbols should +be printed. Possible values include :UPCASE, :DOWNCASE and :CAPITALIZE") ; and :StuDLy + +(defvar *print-array* t + "Non-NIL means that arrays should be printed using \"#(...)\" or +\"=#nA(...)\" syntax to show their contents. +If NIL, arrays other than strings are printed using \"#<...>\". +See also the (non-Common Lisp) variables *PRINT-SIMPLE-VECTOR* +and *PRINT-SIMPLE-BIT-VECTOR*") + +(defvar *print-gensym* t + "Non-NIL means that symbols with no home package should be +printed using \"#:\" syntax. NIL means no prefix is printed.") + +(defvar *print-readably* nil + "Non-NIL means that attempts to print unreadable objects + signal PRINT-NOT-READABLE errors. NIL doesn't.") + +(defvar *PRINT-RIGHT-MARGIN* nil + "+#/NIL the right margin for pretty printing") + +(defvar *PRINT-MISER-WIDTH* 40. + "+#/NIL miser format starts when there is less than this width left") + +(defvar *PRINT-LINES* nil + "+#/NIL truncates printing after # lines") + +(defvar *DEFAULT-RIGHT-MARGIN* 70 + "Controls default line length; Must be a non-negative integer") + +(defvar *PRINT-PPRINT-DISPATCH* nil) ; We have to support this. + +(defvar *xp-current-object* nil) ; from xp + +(defvar *circularity-hash-table* nil) ; ditto + +(defvar *current-level* nil) + +(defvar *current-length* nil) ; must be nil at top level + +(defvar *print-catch-errors* nil) + +;;;; ====================================================================== + +(defclass xp-stream (output-stream) + (xp-structure)) + +(defun %write-string (string stream) + (if (characterp string) + (stream-write-char stream string) + (stream-write-entire-string stream string))) + + +;; *print-simple-vector* +;; *print-simple-bit-vector* +;; *print-string-length* +;; for things like *print-level* which must [no longer] be integers > 0 +(defun get-*print-frob* (symbol + &optional (nil-means target::target-most-positive-fixnum) + (t-means nil)) + (declare (type symbol symbol)) + (let ((value (symbol-value symbol))) + (when *print-readably* + (case symbol + ((*print-length* *print-level* *print-lines* *print-string-length*) + (setq value nil)) + ((*print-escape* *print-gensym* *print-array* *print-simple-vector* + *print-simple-bit-vector*) + (setq value t)) + (t nil))) + (cond ((null value) + nil-means) + ((and (integerp value)) ; (> value 0)) + (min (max value -1) value target::target-most-positive-fixnum)) + ((and t-means (eq value 't)) + t-means) + (t + (setf (symbol-value symbol) nil) + (error "~s had illegal value ~s. reset to ~s" + symbol value 'nil))))) + + +(defun pp-newline (stream kind) + (case kind + ((:newline) + (fresh-line stream)) + ((:unconditional :mandatory) + (stream-write-char stream #\Newline)) + (t nil))) + + +(defun pp-space (stream &optional (newline-kind ':fill)) + (stream-write-char stream #\space) + (pp-newline stream newline-kind)) + +(defun pp-start-block (stream &optional prefix) + (cond ((null prefix)) + ((characterp prefix) + (stream-write-char stream prefix)) + ((stringp prefix) + (%write-string prefix stream)) + (t (report-bad-arg prefix '(or character string (eql nil)))))) + + +(defun pp-end-block (stream &optional suffix) + (cond ((null suffix)) + ((characterp suffix) + (stream-write-char stream suffix)) + ((stringp suffix) + (%write-string suffix stream)) + (t (report-bad-arg suffix '(or character string (eql nil)))))) + + +#| +(defmethod pp-set-indentation ((stream stream) kind n) + (declare (ignore kind n)) + nil) +|# + + +;;;; ====================================================================== +;; list-kludge is so that we can simultaneously detect shared list tails +;; and avoid printing lists as (foo . (bar . (baz . nil))) +;; if non-nil, it is the remaining *print-length* and object is +;; a list tail + + + +(defmethod write-internal-1 ((stream t) object level list-kludge) + (declare (type fixnum level) (type (or null fixnum) list-kludge)) + ;;>> Anybody passing in list-kludge had better be internal to the lisp printer. + ;(if list-kludge (error "Internal printer error")) + (let ((circle *print-circle*) + (pretty *print-pretty*)) + (cond ((or pretty circle) + ; what about this level stuff?? + ; most peculiar + (maybe-initiate-xp-printing + #'(lambda (s o) (write+ o s)) stream object)) + ((not list-kludge) + (write-a-frob object stream level list-kludge)) + ((null object)) + (t + (stream-write-char stream #\space) + (when (not (consp object)) + (stream-write-char stream #\.) + (stream-write-char stream #\space)) + (write-a-frob object stream level list-kludge))))) + + + +(defmethod write-internal-1 ((stream xp-stream) object level list-kludge) + (when level + (setq *current-level* (if (and *print-level* (not *print-readably*)) + (- *print-level* level) + 0))) + (write+ object (slot-value stream 'xp-structure) list-kludge)) + + +(defvar *inside-printer-error* nil) + +(defvar *signal-printing-errors* nil) +(queue-fixup (setq *signal-printing-errors* t)) + +(defun write-internal (stream object level list-kludge) + (if (bogus-thing-p object) + (print-unreadable-object + (object stream) + (princ (%str-cat "BOGUS object @ #x" (%integer-to-string (%address-of object) 16.)) + stream)) + (progn + (flet ((handler (condition) + (declare (ignore condition)) + (unless *signal-printing-errors* + (return-from write-internal + (let ((*print-pretty* nil) + (*print-circle* nil)) + (if *inside-printer-error* + (when (eql 1 (incf *inside-printer-error*)) + (%write-string "#)) + (let ((*inside-printer-error* 0)) + ; using format here considered harmful. + (%write-string "#)))))))) + (declare (dynamic-extent #'handler)) + (handler-bind + ((error #'handler)) + (write-internal-1 stream object level list-kludge))) + object))) + + +;;;; ====================================================================== +;;;; internals of write-internal + +;; bd common-lisp (and lisp machine) printer depth counts +;; count from 0 upto *print-level* instead of from +;; *print-level* down to 0 (which this printer sensibly does.) +(defun backtranslate-level (level) + (let ((print-level (get-*print-frob* '*print-level*))) + (if (not (and level print-level)) + target::target-most-positive-fixnum + (if (> level print-level) + ;; wtf! + 1 + (- print-level level))))) + +; so we can print-circle for print-object methods. +(defvar %current-write-level% nil) +(defvar %current-write-stream% nil) +(defun %current-write-level% (stream &optional decrement?) + (if (eq stream %current-write-stream%) + (if decrement? (1- %current-write-level%) %current-write-level%) + (get-*print-frob* '*print-level*))) + +;;>> Some notes: +;;>> CL defining print-object to be a multmethod dispatching on +;;>> both the object and the stream just can't work +;;>> There are a couple of reasons: +;;>> - CL wants *print-circle* structure to be automatically detected +;;>> This means that there must be a printing pre-pass to some stream +;;>> other than the one specified by the user, which means that any +;;>> print-object method which specialises on its second argument is +;;>> going to lose big. + +;;>> - CL wants *print-level* truncation to happen automatically +;;>> and doesn't pass a level argument to print-object (as it should) +;;>> This means that the current level must be associated with the +;;>> stream in some fashion. The quicky kludge Bill uses here +;;>> (binding a special variable) loses for +;;>> + Entering a break loop whilst printing to a stream +;;>> (Should start level from (get-*print-level*) again) +;;>> + Performing output to more than one stream in an interleaved fashion +;;>> (Say a print-object method which writes to *trace-output*) +;;>> The solution, again, is to actually call the print-object methods +;;>> on a write-aux-stream, where that stream is responsible for +;;>> doing *print-level* truncation. +;;>> - BTW The select-method-order should be (stream object) to even have +;;>> a chance of winning. Not that it could win in any case, for the above reasons. +;;>> It isn't that much work to change the printer to always use an +;;>> automatically-level-truncating write-aux-stream +;;>> It is a pity that CL is so BD. +;;>> + +(defun write-a-frob (object stream level list-kludge) + (declare (type stream stream) (type fixnum level) + (type (or null fixnum) list-kludge)) + (cond ((not list-kludge) + (let ((%current-write-stream% stream) ;>> SIGH + (%current-write-level% level)) + (print-object object stream))) + ((%i< list-kludge 1) + ;; *print-length* truncation + (stream-write-entire-string stream "...")) + ((not (consp object)) + (write-a-frob object stream level nil)) + (t + (write-internal stream (%car object) level nil) + ;;>> must do a tail-call!! + (write-internal-1 stream (%cdr object) level (if (consp (%cdr object)) + (%i- list-kludge 1) + list-kludge))))) + +(defmethod print-object :around ((object t) stream) + (if *print-catch-errors* + (handler-case (call-next-method) + (error () (write-string "#" stream))) + (call-next-method))) + +(defmethod print-object ((object t) stream) + (let ((level (%current-write-level% stream)) ; what an abortion. This should be an ARGUMENT! + (%type (%type-of object))) + (declare (type symbol %type) + (type fixnum level)) + (flet ((depth (stream v) + (declare (type fixnum v) (type stream stream)) + (when (%i<= v 0) + ;; *print-level* truncation + (stream-write-entire-string stream "#") + t))) + (cond + ((eq %type 'cons) + (unless (depth stream level) + (write-a-cons object stream level))) + ;; Don't do *print-level* truncation for anything between + ;; here and the (depth ...) case. + ((or (eq %type 'symbol) + (null object)) + (write-a-symbol object stream)) + ((or (stringp object) + (bit-vector-p object)) + (cond ((or (not (stringp object)) + (%i> (length (the string object)) + (get-*print-frob* '*print-string-length*))) + (write-an-array object stream level)) + ((or *print-escape* *print-readably*) + (write-escaped-string object stream)) + (t + (%write-string object stream)))) + ((and (eq %type 'structure) + (not (null (ccl::struct-def object))) + (null (cdr (sd-slots (ccl::struct-def object))))) + ;; else fall through to write-a-uvector + (write-a-structure object stream level)) + ((depth stream level)) + ((eq %type 'package) + (write-a-package object stream)) + ((eq %type 'macptr) + (write-a-macptr object stream)) + ((eq %type 'dead-macptr) + (write-a-dead-macptr object stream)) + ((eq %type 'internal-structure) + (write-an-istruct object stream level)) + ((and (eq %type 'structure) + (not (null (ccl::struct-def object)))) + ;; else fall through to write-a-uvector + (if (and *print-pretty* *print-structure*) + (let ((*current-level* (if (and *print-level* (not *print-readably*)) + (- *print-level* level) + 0))) + (pretty-structure stream object)) + (write-a-structure object stream level))) + ((functionp object) + (write-a-function object stream level)) + ((arrayp object) + (cond ((or (not (stringp object)) + (%i> (length (the string object)) + (get-*print-frob* '*print-string-length*))) + (write-an-array object stream level)) + ((or *print-escape* *print-readably*) + (write-escaped-string object stream)) + (t + (%write-string object stream)))) + + ; whazzat + ((uvectorp object) + (write-a-uvector object stream level)) + (t + (print-unreadable-object (object stream) + (let* ((address (%address-of object))) + (cond ((eq object (%unbound-marker-8)) + (%write-string "Unbound" stream)) + ((eq object (%slot-unbound-marker)) + (%write-string "Slot-Unbound" stream)) + (t + (cond + (t + (%write-string "Unprintable " stream) + (write-a-symbol %type stream) + (%write-string " : " stream))) + (%write-address address stream)))))))) + nil)) + +(defun write-a-dead-macptr (macptr stream) + (print-unreadable-object (macptr stream) + (%write-string "A Dead Mac Pointer" stream))) + + +;;;; ====================================================================== +;;;; Powerful, wonderful tools for printing unreadable objects. + +(defun print-not-readable-error (object stream) + (error (make-condition 'print-not-readable :object object :stream stream))) + +; Start writing an unreadable OBJECT on STREAM, error out if *PRINT-READABLY* is true. +(defun write-unreadable-start (object stream) + (if *print-readably* + (print-not-readable-error object stream) + (pp-start-block stream "#<"))) + +(defun %print-unreadable-object (object stream type id thunk) + (cond ((null stream) (setq stream *standard-output*)) + ((eq stream t) (setq stream *terminal-io*))) + (write-unreadable-start object stream) + (when type + (princ (type-of object) stream)) + (when thunk + (when type (stream-write-char stream #\space)) + (funcall thunk)) + (if id + (%write-address object stream #\>) + (pp-end-block stream ">")) + nil) + +;;;; ====================================================================== +;;;; internals of internals of write-internal + +(defmethod print-object ((char character) stream &aux name) + (cond ((or *print-escape* *print-readably*) ;print #\ for read-ability + (stream-write-char stream #\#) + (stream-write-char stream #\\) + (if (and (or (eql char #\newline) + (not (standard-char-p char))) + (setq name (char-name char))) + (%write-string name stream) + (stream-write-char stream char))) + (t + (stream-write-char stream char)))) + +(defun get-*print-base* () + (let ((base *print-base*)) + (unless (and (fixnump base) + (%i< 1 base) (%i< base 37.)) + (setq *print-base* 10.) + (error "~S had illegal value ~S. Reset to ~S" + '*print-base* base 10)) + base)) + +(defun write-radix (base stream) + (stream-write-char stream #\#) + (case base + (2 (stream-write-char stream #\b)) + (8 (stream-write-char stream #\o)) + (16 (stream-write-char stream #\x)) + (t (%pr-integer base 10. stream) + (stream-write-char stream #\r)))) + +(defun write-an-integer (num stream + &optional (base (get-*print-base*)) + (print-radix *print-radix*)) + (when (and print-radix (not (eq base 10))) + (write-radix base stream)) + (%pr-integer num base stream) + (when (and print-radix (eq base 10)) + (stream-write-char stream #\.))) + +(defmethod print-object ((num integer) stream) + (write-an-integer num stream)) + +(defun %write-address (object stream &optional foo) + (if foo (pp-space stream)) + (write-an-integer (if (integerp object) object (%address-of object)) stream 16. t) + (if foo (pp-end-block stream foo))) + +(defmethod print-object ((num ratio) stream) + (let ((base (get-*print-base*))) + ;;>> What to do when for *print-radix* and *print-base* = 10? + (when (and *print-radix* (not (eq base 10))) + (write-radix base stream)) + (%pr-integer (numerator num) base stream) + (stream-write-char stream #\/) + (%pr-integer (denominator num) base stream))) + +;;>> Doesn't do *print-level* truncation +(defmethod print-object ((c complex) stream) + (pp-start-block stream "#C(") + (print-object (realpart c) stream) + (pp-space stream) + (print-object (imagpart c) stream) + (pp-end-block stream #\))) + +(defmethod print-object ((float float) stream) + (print-a-float float stream)) + +(defun float-exponent-char (float) + (if (case *read-default-float-format* + (single-float (typep float 'single-float)) + (double-float (typep float 'double-float)) + (t (typep float *read-default-float-format*))) + #\E + (if (typep float 'double-float) + #\D + #\S))) + +(defun default-float-p (float) + (case *read-default-float-format* + (single-float (typep float 'single-float)) + (double-float (typep float 'double-float)) + (t (typep float *read-default-float-format*)))) + + +(defun print-a-nan (float stream) + (if (infinity-p float) + (output-float-infinity float stream) + (output-float-nan float stream))) + +(defun output-float-infinity (x stream) + (declare (float x) (stream stream)) + (format stream "~:[-~;~]1~c++0" + (plusp x) + (if (typep x *read-default-float-format*) + #\E + (typecase x + (double-float #\D) + (single-float #\S))))) + +(defun output-float-nan (x stream) + (declare (float x) (stream stream)) + (format stream "1~c+-0 #| not-a-number |#" + (if (typep x *read-default-float-format*) + #\E + (etypecase x + (double-float #\D) + (single-float #\S))))) + + +;; nanning => recursive from print-a-nan - don't check again +(defun print-a-float (float stream &optional exp-p nanning) + (let ((strlen 0) (exponent-char (float-exponent-char float))) + (declare (fixnum strlen)) + (setq stream (%real-print-stream stream)) + (if (and (not nanning)(nan-or-infinity-p float)) + (print-a-nan float stream) + (multiple-value-bind (string before-pt #|after-pt|#) + (flonum-to-string float) + (declare (fixnum before-pt #|after-pt|#)) + (setq strlen (length string)) + (when (minusp (float-sign float)) + (stream-write-char stream #\-)) + (cond + ((and (not exp-p) (zerop strlen)) + (stream-write-entire-string stream "0.0")) + ((and (> before-pt 0)(<= before-pt 7)(not exp-p)) + (cond ((> strlen before-pt) + (write-string string stream :start 0 :end before-pt) + (stream-write-char stream #\.) + (write-string string stream :start before-pt :end strlen)) + (t ; 0's after + (stream-write-entire-string stream string) + (dotimes (i (- before-pt strlen)) + (stream-write-char stream #\0)) + (stream-write-entire-string stream ".0")))) + ((and (> before-pt -3)(<= before-pt 0)(not exp-p)) + (stream-write-entire-string stream "0.") + (dotimes (i (- before-pt)) + (stream-write-char stream #\0)) + (stream-write-entire-string stream string)) + (t + (setq exp-p t) + (stream-write-char stream (if (> strlen 0)(char string 0) #\0)) + (stream-write-char stream #\.) + (if (> strlen 1) + (write-string string stream :start 1 :end strlen) + (stream-write-char stream #\0)) + (stream-write-char stream exponent-char) + (when (and exp-p (not (minusp (1- before-pt)))) + (stream-write-char stream #\+)) + (let ((*print-base* 10) + (*print-radix* nil)) + (princ (1- before-pt) stream)))) + (when (and (not exp-p) + (not (default-float-p float))) + (stream-write-char stream exponent-char) + (stream-write-char stream #\0)))))) + +;;>> Doesn't do *print-level* truncation +(defmethod print-object ((class class) stream) + (print-unreadable-object (class stream) + (print-object (class-name (class-of class)) stream) + (pp-space stream) + (print-object (class-name class) stream))) + + +(defmethod print-object ((value-cell value-cell) stream) + (print-unreadable-object (value-cell stream :type t :identity t) + (prin1 (uvref value-cell target::value-cell.value-cell) stream))) + +;(defun symbol-begins-with-vowel-p (sym) +; (and (symbolp sym) +; (not (%izerop (%str-length (setq sym (symbol-name sym))))) +; (%str-member (schar sym 0) "AEIOU"))) + +;;;; ---------------------------------------------------------------------- +;;;; CLOSsage + +(defmethod print-object ((instance standard-object) stream) + (if (%i<= %current-write-level% 0) ; *print-level* truncation + (stream-write-entire-string stream "#") + (print-unreadable-object (instance stream :identity t) + (let* ((class (class-of instance)) + (class-name (class-name class))) + (cond ((not (and (symbolp class-name) + (eq class (find-class class-name nil)))) + (%write-string "An instance of" stream) + (pp-space stream) + (print-object class stream)) + (t + (write-a-symbol class-name stream))))))) + +(defmethod print-object ((method standard-method) stream) + (print-method method stream (%class.name (class-of method)))) + +(defmethod print-object ((method-function method-function) stream) + (let ((method (%method-function-method method-function))) + (if (typep method 'standard-method) + (print-method (%method-function-method method-function) + stream + (%class.name (class-of method-function))) + (call-next-method)))) + + + +(defun print-method (method stream type-string) + (print-unreadable-object (method stream) + (let ((name (%method-name method)) + (qualifiers (%method-qualifiers method)) + (specializers (mapcar #'(lambda (specializer) + (if (typep specializer 'eql-specializer) + (list 'eql + (eql-specializer-object specializer)) + (or (class-name specializer) + specializer))) + (%method-specializers method))) + (level-1 (%i- %current-write-level% 1))) + (cond + ((< level-1 0) + ;; *print-level* truncation + (stream-write-entire-string stream "#")) + (t + (prin1 type-string stream) + (pp-space stream) + (write-internal stream name level-1 nil) + (pp-space stream) + (when qualifiers + (write-internal stream (if (cdr qualifiers) qualifiers (car qualifiers)) + level-1 nil) + (pp-space stream)) + (write-internal stream specializers level-1 nil)))))) + +;; Need this stub or we'll get the standard-object method +(defmethod print-object ((gf standard-generic-function) stream) + (write-a-function gf stream (%current-write-level% stream))) + +;; This shouldn't ever happen, but if it does, don't want the standard-object method +(defmethod print-object ((mo metaobject) stream) + (print-unreadable-object (mo stream :type t :identity t))) + +(defmethod print-object ((cm combined-method) stream) + (print-unreadable-object (cm stream :identity t) + (%write-string "Combined-Method" stream) + (pp-space stream) + (let ((name (function-name cm))) + (if (and (functionp name) (function-is-current-definition? name)) + (setq name (function-name name))) + (write-internal stream name (%current-write-level% stream) nil)))) + +(defun print-specializer-names (specializers stream) + (flet ((print-specializer (spec stream) + (write-1 (if (typep spec 'class) (%class.name spec) spec) stream))) + (pp-start-block stream #$) + (if (atom specializers) + (print-specializer specializers stream) + (progn (print-specializer (car specializers) stream) + (dolist (spec (cdr specializers)) + (pp-space stream) + (print-specializer spec stream)))) + (pp-end-block stream #$))) + + +;;;; ---------------------------------------------------------------------- + +(defun write-a-cons (cons stream level) + (declare (type cons cons) (type stream stream) (type fixnum level)) + (let ((print-length (get-*print-frob* '*print-length*)) + (level-1 (%i- level 1)) + (head (%car cons)) + (tail (%cdr cons))) + (declare (type fixnum print-length) (type fixnum level-1)) + (unless (and *print-abbreviate-quote* + (write-abbreviate-quote head tail stream level-1)) + (progn + (pp-start-block stream #$) + (if (= print-length 0) + (%write-string "..." stream) + (progn + (write-internal stream head level-1 nil) + (write-internal stream tail level-1 + (if (atom tail) + print-length + (%i- print-length 1))))) + (pp-end-block stream #$))))) + +;;;; hack for quote and backquote + +;; for debugging +;(setq *backquote-expand* nil) + +(defvar *backquote-hack* (list '*backquote-hack*)) ;uid +(defun write-abbreviate-quote (head tail stream level-1) + (declare (type stream stream) (type fixnum level-1)) + (when (symbolp head) + (cond ((or (eq head 'quote) (eq head 'function)) + (when (and (consp tail) + (null (%cdr tail))) + (%write-string (if (eq head 'function) "#'" "'") stream) + (write-internal stream (%car tail) level-1 nil) + t)) + ((eq head 'backquote-expander) + (when (and (consp tail) + (consp (cdr tail)) + (consp (cddr tail)) + (consp (cdddr tail)) + (null (cddddr tail))) + (let ((tail tail)) + (set (%car tail) + *backquote-hack*) ;, + (set (%car (setq tail (%cdr tail))) + *backquote-hack*) ;,. + (set (%car (setq tail (%cdr tail))) + *backquote-hack*) ;,@ + (stream-write-char stream #\`) + (write-internal stream (%cadr tail) level-1 nil) + t))) + ((and (boundp head) + (eq (symbol-value head) *backquote-hack*)) + ;;",foo" = (#:|,| . foo) + (stream-write-char stream #\,) + (let* ((n (symbol-name head)) + (l (length n))) + (declare (type simple-string n) (type fixnum l)) + ;; possibilities are #:|`,| #:|,.| and #:|,@| + (if (eql l 3) + (stream-write-char stream (schar n 2))) + (write-internal stream tail level-1 nil) + t)) + (t nil)))) + +(eval-when (compile eval) +(defmacro %char-needs-escape-p (char escape &rest losers) + (setq losers (remove-duplicates (cons escape losers))) + (setq char (require-type char 'symbol)) + (dolist (c losers) + (unless (or (characterp c) (symbolp c)) (report-bad-arg c '(or character symbol)))) + (cond ((null (cdr losers)) + `(eq ,char ,escape)) + ((and (every #'characterp losers) + ;(every #'string-char-p losers) + (%i> (length losers) 2)) + `(%str-member ,char ,(concatenate 'string losers))) + (t + `(or ,@(mapcar #'(lambda (e) `(eq ,char ,e)) + losers))))) + +(defmacro %write-escaped-char (stream char escape &rest losers) + `(progn + (when (%char-needs-escape-p ,char ,escape ,@losers) + (stream-write-char ,stream ,escape)) + (stream-write-char ,stream ,char))) +) + +(defun write-escaped-string (string stream &optional (delim #\")) + (declare (type string string) (type character delim) + (type stream stream)) + (write-char delim stream) + (do* ((limit (length string)) + (i 0 (1+ i))) + ((= i limit)) + (declare (type fixnum limit) (type fixnum i)) + (let* ((char (char string i)) + (needs-escape? (%char-needs-escape-p char #\\ delim))) + (if needs-escape? + (write-char #\\ stream)) + (write-char char stream))) + (write-char delim stream)) + + +;;;; ---------------------------------------------------------------------- +;;;; printing symbols + +(defun get-*print-case* () + (let ((case *print-case*)) + (unless (or (eq case ':upcase) (eq case ':downcase) + (eq case ':capitalize) (eq case ':studly)) + (setq *print-case* ':upcase) + (error "~S had illegal value ~S. Reset to ~S" + '*print-case* case ':upcase)) + case)) + +(defun write-a-symbol (symbol stream) + (declare (type symbol symbol) (type stream stream)) + (let ((case (get-*print-case*)) + (name (symbol-name symbol)) + (package (symbol-package symbol))) + (declare (type simple-string name)) + (when (or *print-readably* *print-escape*) + (cond ((keywordp symbol) + (stream-write-char stream #\:)) + ((null package) + (when (or *print-readably* *print-gensym*) + (stream-write-char stream #\#) + (stream-write-char stream #\:))) + (t + (multiple-value-bind (s flag) + (find-symbol name *package*) + (unless (and flag (eq s symbol)) + (multiple-value-setq (s flag) + (find-symbol name package)) + (unless (and flag (eq s symbol)) + (%write-string "#|symbol not found in home package!!|#" + stream)) + (write-pname (package-name package) case stream) + (stream-write-char stream #\:) + (unless (eq flag ':external) + (stream-write-char stream #\:))))))) + (write-pname name case stream))) + + + +(defun write-pname (name case stream) + (declare (type simple-string name) (stream stream) + (optimize (speed 3)(safety 0))) + (let* ((readtable *readtable*) + (readcase (readtable-case (if *print-readably* + %initial-readtable% + readtable))) + (escape? (or *print-readably* *print-escape*))) + (flet ((slashify? (char) + (declare (type character char)) + (and escape? + (if (alpha-char-p char) + (if (eq readcase :upcase) + (lower-case-p char) ; _tolower + (if (eq readcase :downcase) + (upper-case-p char))) + ; should be using readtable here - but (get-macro-character #\|) is nil + (not (%str-member + char + "!$%&*0123456789.<=>?@[]^_{}~+-/"))))) + (single-case-p (name) + (let ((sofar nil)) + (dotimes (i (length name) sofar) + (declare (type fixnum i)) + (declare (type simple-string name)) + (let* ((c (schar name i)) + (c-case (if (upper-case-p c) + :upcase + (if (lower-case-p c) + :downcase)))) + (when c-case + (if sofar + (if (neq sofar c-case) + (return nil)) + (setq sofar c-case)))))))) + (declare (dynamic-extent #'slashify? #'single-case-p)) + (block alice + (let ((len (length name)) + (slash-count 0) + (last-slash-pos 0)) + (declare (type fixnum len) + (type fixnum slash-count last-slash-pos)) + (when escape? + (when (or (%izerop len) + ;; if more than a few \, just use |...| + (and (not (memq readcase '(:invert :preserve))) ; these never slashify alpha-p + (let ((m (max (floor len 4) 2))) + (dotimes (i (the fixnum len) nil) + (declare (type fixnum i)) + (when (slashify? (schar name i)) + (setq slash-count (%i+ slash-count 1)) + (when (or (eql slash-count m) + (eq i (1+ last-slash-pos))) + (return t)) + (setq last-slash-pos i))))) + ;; or could be read as a number + (%parse-number-token name 0 len *print-base*) + ;; or symbol consisting entirely of .'s + (dotimes (i len t) + (declare (fixnum i)) + (unless (eql (schar name i) #\.) + (return nil)))) + (return-from alice + (write-escaped-string name stream #\|)))) + (case readcase + (:preserve (return-from alice (write-string name stream :start 0 :end len))) + (:invert (return-from alice + (cond ((single-case-p name)(write-perverted-string name stream len :invert)) + (t (write-string name stream :start 0 :end len))))) + (t + (when (eql slash-count 0) + (return-from alice + (cond ((eq readcase case) + (write-string name stream :start 0 :end len)) + (t (write-perverted-string name stream len case))))))) + (let* ((outbuf-len (+ len len)) + (outbuf-ptr -1) + (outbuf (make-string outbuf-len))) + (declare (fixnum outbuf-ptr outbuf-len) + (dynamic-extent outbuf) + (simple-string outbuf)) + (dotimes (pos (the fixnum len)) + (declare (type fixnum pos)) + (let* ((char (schar name pos)) + (slashify? (cond ((eql slash-count 0) + nil) + ((eql slash-count 1) + (eql pos last-slash-pos)) + (t + (slashify? char))))) + (declare (type character char)) + (when slashify? + (setq slash-count (%i- slash-count 1)) + (setf (schar outbuf (incf outbuf-ptr)) #\\)) + (setf (schar outbuf (incf outbuf-ptr)) char))) + (write-string outbuf stream :start 0 :end (1+ outbuf-ptr)))))))) + +#| +(defun write-studly-string (string stream) + (declare (type string string) (stream stream)) + (let* ((offset 0) + (end (length string)) + (pool *pname-buffer*) + (outbuf-ptr -1) + (outbuf (pool.data pool))) + (declare (fixnum offset end outbuf-ptr)) + (setf (pool.data pool) nil) + (unless (and outbuf (>= (length outbuf) end)) + (setq outbuf (make-array end :element-type 'character))) + (do ((i 0 (%i+ i 1))) + ((%i>= i end)) + (declare (type fixnum i)) + (setq offset (%i+ offset (char-int (char string i))))) + (do ((i 0 (%i+ i 1))) + ((%i>= i end)) + (declare (type fixnum i)) + (let ((c (char string i))) + (declare (type character c)) + (cond ((not (and (%i< (%ilogand2 + (%i+ (char-int c) offset) + 15.) + 6.) + (alpha-char-p c)))) + ((upper-case-p c) + (setq c (char-downcase c))) + (t + (setq c (char-upcase c)))) + (setf (schar outbuf (incf outbuf-ptr)) c))) + (write-string outbuf stream :start 0 :end end) + (setf (pool.data pool) outbuf))) +|# + +(defun write-perverted-string (string stream end type) + ; type :invert :upcase :downcase :capitalize or :studly + (declare (fixnum end)) + (let* ((readtable *readtable*) + (readcase (readtable-case readtable)) + (outbuf-ptr -1) + (outbuf (make-string end)) + (word-start t) + (offset 0)) + (declare (fixnum offset outbuf-ptr) + (dynamic-extent outbuf)) + (when (eq type :studly) + (do ((i 0 (%i+ i 1))) + ((%i>= i end)) + (declare (type fixnum i)) + (setq offset (%i+ offset (char-int (char string i)))))) + (do ((i 0 (%i+ i 1))) + ((%i>= i end)) + (declare (type fixnum i)) + (let ((c (char string i))) + (declare (type character c)) + (cond ((alpha-char-p c) + (case type + (:studly + (cond ((not (%i< (%ilogand2 + (%i+ (char-int c) offset) + 15.) + 6.))) + ((upper-case-p c) + (setq c (char-downcase c))) + (t + (setq c (char-upcase c))))) + (:invert + (setq c (if (upper-case-p c)(char-downcase c)(char-upcase c)))) + (:upcase + (setq c (char-upcase c))) + (:downcase + (setq c (char-downcase c))) + (:capitalize (setq c (cond (word-start + (setq word-start nil) + (if (eq readcase :upcase) + c + (char-upcase c))) + (t + (if (eq readcase :upcase) + (char-downcase c) + c))))))) + ((digit-char-p c)(setq word-start nil)) + (t (setq word-start t))) + (setf (schar outbuf (incf outbuf-ptr)) c))) + (write-string outbuf stream :start 0 :end end))) + + +;;;; ---------------------------------------------------------------------- +;;;; printing arrays + +;; *print-array* +;; *print-simple-vector* +;; *print-simple-bit-vector* +;; *print-string-length* + +(defun array-readably-printable-p (array) + (let ((dims (array-dimensions array))) + (and (eq (array-element-type array) t) + (let ((zero (position 0 dims)) + (number (position 0 dims + :test (complement #'eql) + :from-end t))) + (or (null zero) (null number) (> zero number)))))) + +(defun write-an-array (array stream level) + (declare (type array array) (type stream stream) (type fixnum level)) + (let* ((rank (array-rank array)) + (vector? (eql rank 1)) + (simple? (simple-array-p array)) + (simple-vector? (simple-vector-p array)) + ;; non-*print-string-length*-truncated strings are printed by + ;; write-a-frob + (string? (stringp array)) + (bit-vector? (bit-vector-p array)) + (fill-pointer? (array-has-fill-pointer-p array)) + (adjustable? (adjustable-array-p array)) + (displaced? (displaced-array-p array)) + (total-size (array-total-size array)) + (length (and vector? (length array))) + (print-length (get-*print-frob* '*print-length*)) + (print-array (get-*print-frob* '*print-array* nil t))) + (declare (type fixnum rank) (type fixnum total-size) + (type fixnum print-length)) + (unless + (cond (string? + nil) + ((and bit-vector? print-array) + (stream-write-char stream #\#) (stream-write-char stream #\*) + (do ((i 0 (%i+ i 1)) + (l print-length (%i- l 1))) + (nil) + (declare (type fixnum i) (type fixnum l)) + (cond ((eql i length) + (return)) + (t + (stream-write-char stream (if (eql (bit array i) 0) #\0 #\1))))) + t) + ((and *print-readably* + (not (array-readably-printable-p array))) + nil) + ((and *print-pretty* print-array) + (let ((*current-level* (if (and *print-level* (not *print-readably*)) + (- *print-level* level) + 0))) + (pretty-array stream array)) + t) + (vector? + (when (or print-array + (and simple-vector? + (%i<= length (get-*print-frob* + '*print-simple-vector* + 0 + target::target-most-positive-fixnum)))) + (pp-start-block stream "#(") + (do ((i 0 (%i+ i 1)) + (l print-length (%i- l 1))) + (nil) + (declare (type fixnum i) (type fixnum l)) + (cond ((eql i length) + (return)) + ((eql l 0) + ;; can't use write-abbreviation since there is + ;; no `object' for the abbreviation to represent + (unless (eql i 0) (pp-space stream)) + (%write-string "..." stream) + (return)) + (t (unless (eql i 0) (pp-space stream)) + (write-internal stream (aref array i) (%i- level 1) nil)))) + (pp-end-block stream #\)) + t)) + ((and print-array (not fill-pointer?)) + (let ((rank (array-rank array))) + (stream-write-char stream #\#) + (%pr-integer rank 10. stream) + (stream-write-char stream #\A) + (if (eql rank 0) + (write-internal stream (aref array) (%i- level 1) nil) + (multiple-value-bind (array-data offset) + (array-data-and-offset array) + (write-array-elements-1 + stream level + array-data offset + (array-dimensions array))))) + t) + (t + ;; fall through -- print randomly + nil)) + ;; print array using #<...> + (print-unreadable-object (array stream) + (if vector? + (progn + (write-a-symbol (cond (simple-vector? + 'simple-vector) + (string? + (if simple? 'simple-string 'string)) + (bit-vector? + (if simple? 'simple-bit-vector 'bit-vector)) + (t 'vector)) + stream) + (pp-space stream) + (%pr-integer total-size 10. stream) + (when fill-pointer? + (let ((fill-pointer (fill-pointer array))) + (declare (fixnum fill-pointer)) + (pp-space stream) + (%write-string "fill-pointer" stream) + (unless (eql fill-pointer total-size) + (stream-write-char stream #\space) + (%pr-integer fill-pointer 10. stream))))) + (progn + (write-a-symbol 'array stream) + (pp-space stream) + (if (eql rank 0) (%write-string "0-dimensional" stream)) + (dotimes (i (the fixnum rank)) + (unless (eql i 0) (stream-write-char stream #\x)) + (%pr-integer (array-dimension array i) 10. stream)))) + (let ((type (array-element-type array))) + (unless (or simple-vector? string? bit-vector? ; already written "#" + level nil))) + (cond (simple? + (unless (or simple-vector? string? bit-vector?) + ;; already written "# length 20)) + (flet ((foo (stream string start end) + (declare (type fixnum start) (type fixnum end) + (type string string)) + (do ((i start (%i+ i 1))) + ((%i>= i end)) + (let ((c (char string i))) + (declare (type character c)) + (if (not (graphic-char-p c)) + (return) + (%write-escaped-char stream c #\\ #\")))))) + #|(%write-string " \"" stream)|# (pp-space stream) + (foo stream array 0 12) + (%write-string "..." stream) + (foo stream array (%i- length 6) length) + #|(stream-write-char stream #\")|#)))))) + +(defun write-array-elements-1 (stream level + array-data offset + dimensions) + (declare (type stream stream) (type fixnum level) + (type vector array-data) (type fixnum offset) + (type list dimensions)) + (block written + (let ((tail (%cdr dimensions)) + (print-length (get-*print-frob* '*print-length*)) + (level-1 (%i- level 1)) + (limit (%car dimensions)) + (step 1)) + (when (and (null tail) + (%i> level-1 0) + (or (bit-vector-p array-data) + (and (stringp array-data) + (%i<= limit print-length)))) + (return-from written + ;;>> cons cons. I was lazy. + ;;>> Should code a loop to write the elements instead + (write-an-array (%make-displaced-array + ;; dimensions displaced-to + limit array-data + ;; fill-pointer adjustable + nil nil + ;; displaced-index-offset + offset) + stream level-1))) + (pp-start-block stream #$) + (dolist (e tail) (setq step (%i* e step))) + (do* ((o offset (%i+ o step)) + (i 0 (1+ i))) + (nil) + (declare (type fixnum o) (type fixnum i) (type fixnum limit) + (type fixnum step) (type fixnum print-length) + (type fixnum level-1)) + (cond ((eql i print-length) + (%write-string " ..." stream) + (return)) + ((eql i limit) + (return)) + ((= i 0)) + (t + (pp-space stream (if (null tail) ':fill ':linear)))) + (cond ((null tail) + (write-internal stream (aref array-data o) level-1 nil)) + ((eql level-1 0) + ;; can't use write-abbreviation since this doesn't really + ;; abbreviate a single object + (stream-write-char stream #\#)) + (t + (write-array-elements-1 stream level-1 + array-data o tail)))) + (pp-end-block stream #$)))) + +;;;; ---------------------------------------------------------------------- + +; A "0" in the sd-print-function => inherit from superclass. +(defun structure-print-function (class) + (let* ((pf (ccl::sd-print-function class)) + (supers (cdr (sd-superclasses class)))) + (do* () + ((neq pf 0) pf) + (if supers + (setq pf (sd-print-function (gethash (pop supers) %defstructs%))) + (return))))) + +(defun write-a-structure (object stream level) + (declare (type stream stream) (type fixnum level)) + (let* ((class (ccl::struct-def object)) ;;guaranteed non-NIL if this function is called + (pf (structure-print-function class))) + (cond (pf + (if (consp pf) + (funcall (%car pf) object stream) + (funcall pf + object stream (backtranslate-level level)))) + ((and (not *print-structure*) (not *print-readably*)) + (print-unreadable-object (object stream :identity t) + (write-a-symbol (ccl::sd-name class) stream))) + (t + (let ((level-1 (ccl::%i- level 1)) + (slots (cdr (ccl::sd-slots class))) + (print-length (get-*print-frob* '*print-length*))) + (declare (type fixnum level-1) (type list slots)) + (%write-string "#S(" stream) + (if (%i> print-length 0) + (write-a-symbol (ccl::sd-name class) stream) + (progn (%write-string "...)" stream) + (return-from write-a-structure))) + (when (and slots (%i> print-length 1)) + (pp-start-block stream #\Space)) + (do ((l (%i- print-length 1) (%i- l 2)) + (first? t) + (print-case (get-*print-case*))) + (nil) + (declare (type fixnum l)) + (cond ((null slots) + (return)) + ((%i< l 1) + ;; Note write-abbreviation since it isn't abbreviating an object + (%write-string " ..." stream) + (return))) + (let* ((slot (prog1 (%car slots) + (setq slots (%cdr slots)))) + (symbol (ccl::ssd-name slot))) + (when (symbolp symbol) + (if first? + (setq first? nil) + (pp-space stream ':linear)) + (stream-write-char stream #\:) + (write-pname (symbol-name symbol) print-case stream) + (cond ((%i> l 1) + (pp-space stream) + (write-internal stream (uvref object (ccl::ssd-offset slot)) + level-1 nil)) + (t (%write-string " ..." stream) + (return))))))) + (pp-end-block stream #\)))))) + +(%fhave 'encapsulated-function-name ;(fn) ;Redefined in encapsulate + (qlfun bootstrapping-encapsulated-function-name (fn) + (declare (ignore fn)) + nil)) + + +(%fhave '%traced-p ;(fn) ;Redefined in encapsulate + (qlfun bootstrapping-%traced-p (fn) + (declare (ignore fn)) + nil)) + +(%fhave '%advised-p ;(fn) ;Redefined in encapsulate + (qlfun bootstrapping-%advised-p (fn) + (declare (ignore fn)) + nil)) + + + +(defun write-a-function (lfun stream level) ; screwed up + (print-unreadable-object (lfun stream :identity t) + (let* ((name (function-name lfun)) + ; actually combined-method has its oun print-object method and doesn't get here. + ; standard-generic-function has a print-object method that just calls this. + (gf-or-cm (or (standard-generic-function-p lfun) (combined-method-p lfun)))) + (cond ((and (not (compiled-function-p lfun)) + (not gf-or-cm)) + ; i.e. closures + (write-internal stream (%type-of lfun) level nil) + (when name + (pp-space stream) + (write-internal stream name (%i- level 1) nil))) + ((not name) + (%lfun-name-string lfun stream t)) + (t + (if gf-or-cm + (write-internal stream (class-name (class-of lfun)) level nil) + (%write-string (cond ((typep lfun 'method-function) + "Compiled Method-function") + (t "Compiled-function")) + stream)) + (stream-write-char stream #\space) + (write-internal stream name (%i- level 1) nil) + (cond ((and (symbolp name) (eq lfun (macro-function name))) + (%write-string " Macroexpander" stream)) ;What better? + ((not (function-is-current-definition? lfun)) + ;;>> Nice if it could print (Traced), (Internal), (Superseded), etc + (cond ((%traced-p name) + (%write-string " (Traced Original) " stream)) + ((%advised-p name) + (%write-string " (Advised Original) " stream)) + (t (%write-string " (Non-Global) " stream)))))))))) + + +(defun function-is-current-definition? (function) + (let ((name (function-name function))) + (and name + (valid-function-name-p name) + (eq function (fboundp name))))) + +;; outputs to stream or returns a string. Barf! +;; Making not matters not worse ... +(defun %lfun-name-string (lfun &optional stream suppress-address) + (unless (functionp lfun) (report-bad-arg lfun 'function)) + (if (null stream) + (with-output-to-string (s) (%lfun-name-string lfun s)) + (let ((name (function-name lfun))) + (if name + (prin1 name stream) + (let* ((fnaddr (%address-of lfun)) + (kernel-function-p (kernel-function-p lfun))) + (%write-string (if kernel-function-p + "Internal " "Anonymous ") + stream) + (if (standard-generic-function-p lfun) + (prin1 (class-name (class-of lfun)) stream) + (%write-string "Function" stream)) + (unless suppress-address + (stream-write-char stream #\ ) + (write-an-integer fnaddr + stream 16. t))))))) + + +;;;; ---------------------------------------------------------------------- + +(defun write-a-package (pkg stream) + (print-unreadable-object (pkg stream) + (if (null (pkg.names pkg)) + (%write-string "Deleted Package" stream) + (progn + (%write-string "Package " stream) + (write-escaped-string (package-name pkg) stream))))) + + + +(defun write-a-macptr (macptr stream) + (let* ((null (%null-ptr-p macptr))) + (print-unreadable-object (macptr stream) + (if null + (progn + (%write-string "A Null Foreign Pointer" stream)) + (progn + (pp-start-block stream "A Foreign Pointer") + (%write-macptr-allocation-info macptr stream) + (stream-write-char stream #\ ) + (%write-macptr-type-info macptr stream) + (write-an-integer (%ptr-to-int macptr) stream 16. t)))))) + +(defun %macptr-allocation-string (macptr) + (if (or (on-any-csp-stack macptr) + (on-any-tsp-stack macptr)) + "[stack-allocated]" + (if (eql (uvsize macptr) target::xmacptr.element-count) + "[gcable]"))) + +(defun %write-macptr-allocation-info (macptr stream) + (let* ((s (%macptr-allocation-string macptr))) + (if s (format stream " ~a" s)))) + +(defun %write-macptr-type-info (macptr stream) + (let* ((ordinal (%macptr-type macptr))) + (unless (eql 0 ordinal) + (let* ((type (gethash ordinal (ftd-ordinal-types *target-ftd*))) + (form + (if (typep type 'foreign-record-type) + `(:* (,(foreign-record-type-kind type) + ,(foreign-record-type-name type))) + `(:* ,(unparse-foreign-type type))))) + (when form (format stream "~s " form)))))) + + + +; This special-casing for wrappers is cheaper than consing a class +(defun write-an-istruct (istruct stream level) + (let* ((type (istruct-cell-name (uvref istruct 0))) + (wrapper-p (eq type 'class-wrapper))) + (print-unreadable-object (istruct stream :identity t) + (write-internal stream type (%i- level 1) nil) + (when wrapper-p + (pp-space stream) + (print-object (class-name (%wrapper-class istruct)) stream))))) + +(defun write-a-uvector (uvec stream level) + (declare (ignore level)) + (print-unreadable-object (uvec stream :identity t :type t))) + + +(defmethod print-object ((slotdef slot-definition) stream) + (print-unreadable-object (slotdef stream :identity t :type t) + (format stream "for ~a slot ~s" + (string-downcase (slot-definition-allocation slotdef)) + (standard-slot-definition.name slotdef)))) + +(defmethod print-object ((spec eql-specializer) stream) + (print-unreadable-object (spec stream :identity t :type t) + (format stream "~s" (if (slot-boundp spec 'object) + (eql-specializer-object spec) + "")))) + + +(defmethod print-object ((slot-id slot-id) stream) + (print-unreadable-object (slot-id stream :identity t :type t) + (format stream "for ~s/~d" + (slot-id.name slot-id) + (slot-id.index slot-id)))) + +#+x86-target +(defmethod print-object ((tra tagged-return-address) stream) + (print-unreadable-object (tra stream :identity t :type t) + (let* ((f (%return-address-function tra)) + (offset (if f (%return-address-offset tra)))) + (when offset + (format stream "in function ") + (%lfun-name-string f stream) + (format stream " (+~d)" offset))))) + +#+x8664-target +(defmethod print-object ((sv symbol-vector) stream) + (print-unreadable-object (sv stream :identity t :type t) + (format stream "for ~s" (%symptr->symbol (%symvector->symptr sv))))) + +#+x8664-target +(defmethod print-object ((fv function-vector) stream) + (print-unreadable-object (fv stream :identity t :type t) + (format stream "for ") + (%lfun-name-string (%function-vector-to-function fv) stream))) + +(defmethod print-object ((c class-cell) stream) + (print-unreadable-object (c stream :type t :identity t) + (format stream "for ~s" (class-cell-name c)))) + + + +;;; ====================================================================== + + +(defun real-print-stream (&optional (stream nil)) + (cond ((null stream) + *standard-output*) + ((eq stream t) + *terminal-io*) + ((streamp stream) + stream) + ;; This never gets called because streamp is true for xp-structure... + ((istruct-typep stream 'xp-structure) + (get-xp-stream stream)) + (t + (report-bad-arg stream '(or stream (member nil t)))))) + +(defun write-1 (object stream &optional levels-left) + (setq stream (%real-print-stream stream)) + (when (not levels-left) + (setq levels-left + (if *current-level* + (if *print-level* + (- *print-level* *current-level*) + target::target-most-positive-fixnum) + (%current-write-level% stream t)))) + (cond + ((< levels-left 0) + ;; *print-level* truncation + (stream-write-entire-string stream "#")) + (t (write-internal stream + object + (min levels-left target::target-most-positive-fixnum) + nil))) + object) + +;;;; ---------------------------------------------------------------------- +;;;; User-level interface to the printer + + +(defun write (object + &key (stream *standard-output*) + (escape *print-escape*) + (radix *print-radix*) + (base *print-base*) + (circle *print-circle*) + (pretty *print-pretty*) + (level *print-level*) + (length *print-length*) + (case *print-case*) + (gensym *print-gensym*) + (array *print-array*) + (readably *print-readably*) + (right-margin *print-right-margin*) + (miser-width *print-miser-width*) + (lines *print-lines*) + (pprint-dispatch *print-pprint-dispatch*) + ;;>> Do I really want to add these to WRITE?? + (structure *print-structure*) + (simple-vector *print-simple-vector*) + (simple-bit-vector *print-simple-bit-vector*) + (string-length *print-string-length*)) + "Output OBJECT to the specified stream, defaulting to *STANDARD-OUTPUT*" + (let ((*print-escape* escape) + (*print-radix* radix) + (*print-base* base) + (*print-circle* circle) + (*print-pretty* pretty) + (*print-level* level) + (*print-length* length) + (*print-case* case) + (*print-gensym* gensym) + (*print-array* array) + (*print-readably* readably) + (*print-right-margin* right-margin) + (*print-miser-width* miser-width) + (*print-lines* lines) + (*print-pprint-dispatch* pprint-dispatch) + ;;>> Do I really want to add these to WRITE?? + (*print-structure* structure) + (*print-simple-vector* simple-vector) + (*print-simple-bit-vector* simple-bit-vector) + (*print-string-length* string-length)) + (write-1 object stream))) + +(defun write-to-string (object + &key (escape *print-escape*) + (radix *print-radix*) + (base *print-base*) + (circle *print-circle*) + (pretty *print-pretty*) + (level *print-level*) + (length *print-length*) + (case *print-case*) + (gensym *print-gensym*) + (array *print-array*) + (readably *print-readably*) + (right-margin *print-right-margin*) + (miser-width *print-miser-width*) + (lines *print-lines*) + (pprint-dispatch *print-pprint-dispatch*) + ;;>> Do I really want to add these to WRITE?? + (structure *print-structure*) + (simple-vector *print-simple-vector*) + (simple-bit-vector *print-simple-bit-vector*) + (string-length *print-string-length*)) + "Return the printed representation of OBJECT as a string." + (let ((*print-escape* escape) + (*print-radix* radix) + (*print-base* base) + (*print-circle* circle) + (*print-pretty* pretty) + (*print-level* level) + (*print-length* length) + (*print-case* case) + (*print-gensym* gensym) + (*print-array* array) + ;; I didn't really wan't to add these, but I had to. + (*print-readably* readably) + (*print-right-margin* right-margin) + (*print-miser-width* miser-width) + (*print-lines* lines) + (*print-pprint-dispatch* pprint-dispatch) + ;;>> Do I really want to add these to WRITE?? + (*print-structure* structure) + (*print-simple-vector* simple-vector) + (*print-simple-bit-vector* simple-bit-vector) + (*print-string-length* string-length)) + (with-output-to-string (stream) + (write-1 object stream)))) + +(defun prin1-to-string (object) + "Return the printed representation of OBJECT as a string with + slashification on." + (with-output-to-string (s) + (prin1 object s))) + +(defun princ-to-string (object) + "Return the printed representation of OBJECT as a string with + slashification off." + (with-output-to-string (s) + (princ object s))) + +(defun prin1 (object &optional stream) + "Output a mostly READable printed representation of OBJECT on the specified + STREAM." + (let ((*print-escape* t)) + (write-1 object stream))) + +(defun princ (object &optional stream) + "Output an aesthetic but not necessarily READable printed representation + of OBJECT on the specified STREAM." + (let ((*print-escape* nil) + (*print-readably* nil)) + (write-1 object stream))) + +(defun print (object &optional stream) + "Output a newline, the mostly READable printed representation of OBJECT, and + space to the specified STREAM." + (terpri stream) + (let ((*print-escape* t)) + (write-1 object stream)) + (write-char #\Space stream) + object) + +; redefined by pprint module if loaded +(defun pprint (object &optional stream) + (print object stream) + nil) ; pprint returns nil + + +(defun read-sequence (seq stream &key (start 0) end) + "Destructively modify SEQ by reading elements from STREAM. + That part of SEQ bounded by START and END is destructively modified by + copying successive elements into it from STREAM. If the end of file + for STREAM is reached before copying all elements of the subsequence, + then the extra elements near the end of sequence are not updated, and + the index of the next element is returned." + (setq end (check-sequence-bounds seq start end)) + (locally (declare (fixnum start end)) + (if (= start end) + start + (seq-dispatch + seq + (+ start (the fixnum (stream-read-list + stream + (nthcdr start seq) + (the fixnum (- end start))))) + (multiple-value-bind (vector offset) (array-data-and-offset seq) + (declare (fixnum offset)) + (- + (stream-read-vector + stream + vector + (the fixnum (+ offset start)) + (the fixnum (+ offset end))) + offset)))))) + + + +(defun write-sequence (seq stream &key (start 0) end) + "Write the elements of SEQ bounded by START and END to STREAM." + (setq end (check-sequence-bounds seq start end)) + (locally (declare (fixnum start end)) + (seq-dispatch + seq + (stream-write-list stream (nthcdr start seq) (the fixnum (- end start))) + (multiple-value-bind (vector offset) (array-data-and-offset seq) + (stream-write-vector + stream + vector + (the fixnum (+ offset start)) + (the fixnum (+ offset end)))))) + seq) + +(defpackage "GRAY" + (:use) + (:import-from "CCL" + "FUNDAMENTAL-STREAM" + "FUNDAMENTAL-INPUT-STREAM" + "FUNDAMENTAL-OUTPUT-STREAM" + "FUNDAMENTAL-CHARACTER-STREAM" + "FUNDAMENTAL-CHARACTER-INPUT-STREAM" + "FUNDAMENTAL-CHARACTER-OUTPUT-STREAM" + "FUNDAMENTAL-BINARY-STREAM" + "FUNDAMENTAL-BINARY-INPUT-STREAM" + "FUNDAMENTAL-BINARY-OUTPUT-STREAM" + + "STREAM-READ-CHAR" + "STREAM-UNREAD-CHAR" + "STREAM-READ-CHAR-NO-HANG" + "STREAM-PEEK-CHAR" + "STREAM-LISTEN" + "STREAM-READ-LINE" + "STREAM-CLEAR-INPUT" + + "STREAM-WRITE-CHAR" + "STREAM-LINE-COLUMN" + "STREAM-START-LINE-P" + "STREAM-WRITE-STRING" + "STREAM-TERPRI" + "STREAM-FRESH-LINE" + "STREAM-FORCE-OUTPUT" + "STREAM-FINISH-OUTPUT" + "STREAM-CLEAR-OUTPUT" + "STREAM-ADVANCE-TO-COLUMN" + + "STREAM-READ-BYTE" + "STREAM-WRITE-BYTE" + ) + (:export + "FUNDAMENTAL-STREAM" + "FUNDAMENTAL-INPUT-STREAM" + "FUNDAMENTAL-OUTPUT-STREAM" + "FUNDAMENTAL-CHARACTER-STREAM" + "FUNDAMENTAL-CHARACTER-INPUT-STREAM" + "FUNDAMENTAL-CHARACTER-OUTPUT-STREAM" + "FUNDAMENTAL-BINARY-STREAM" + "FUNDAMENTAL-BINARY-INPUT-STREAM" + "FUNDAMENTAL-BINARY-OUTPUT-STREAM" + + "STREAM-READ-CHAR" + "STREAM-UNREAD-CHAR" + "STREAM-READ-CHAR-NO-HANG" + "STREAM-PEEK-CHAR" + "STREAM-LISTEN" + "STREAM-READ-LINE" + "STREAM-CLEAR-INPUT" + + "STREAM-WRITE-CHAR" + "STREAM-LINE-COLUMN" + "STREAM-START-LINE-P" + "STREAM-WRITE-STRING" + "STREAM-TERPRI" + "STREAM-FRESH-LINE" + "STREAM-FORCE-OUTPUT" + "STREAM-FINISH-OUTPUT" + "STREAM-CLEAR-OUTPUT" + "STREAM-ADVANCE-TO-COLUMN" + + "STREAM-READ-BYTE" + "STREAM-WRITE-BYTE" +)) + + Index: /branches/new-random/level-1/l1-lisp-threads.lisp =================================================================== --- /branches/new-random/level-1/l1-lisp-threads.lisp (revision 13309) +++ /branches/new-random/level-1/l1-lisp-threads.lisp (revision 13309) @@ -0,0 +1,1116 @@ +;;; -*- Mode: LISP; Package: CCL -*- +;;; +;;; Copyright (C) 2009 Clozure Associates +;;; Copyright (C) 1994-2001 Digitool, Inc +;;; This file is part of Clozure CL. +;;; +;;; Clozure CL is licensed under the terms of the Lisp Lesser GNU Public +;;; License , known as the LLGPL and distributed with Clozure CL as the +;;; file "LICENSE". The LLGPL consists of a preamble and the LGPL, +;;; which is distributed with Clozure CL as the file "LGPL". Where these +;;; conflict, the preamble takes precedence. +;;; +;;; Clozure CL is referenced in the preamble as the "LIBRARY." +;;; +;;; The LLGPL is also available online at +;;; http://opensource.franz.com/preamble.html + +;; l1-lisp-threads.lisp + +(in-package "CCL") + +(defvar *bind-io-control-vars-per-process* nil + "If true, bind I/O control variables per process") + + + +(defun lisp-thread-p (thing) + (istruct-typep thing 'lisp-thread)) + +(setf (type-predicate 'lisp-thread) 'lisp-thread-p) + +(defloadvar *ticks-per-second* + #+windows-target 1000 + #-windows-target + (#_sysconf #$_SC_CLK_TCK)) + +(defloadvar *ns-per-tick* + (floor 1000000000 *ticks-per-second*)) + +#-windows-target +(defun %nanosleep (seconds nanoseconds) + (with-process-whostate ("Sleep") + (rlet ((a :timespec) + (b :timespec)) + (setf (pref a :timespec.tv_sec) seconds + (pref a :timespec.tv_nsec) nanoseconds) + (let* ((aptr a) + (bptr b)) + (loop + (let* ((result + (external-call #+darwin-target "_nanosleep" + #-darwin-target "nanosleep" + :address aptr + :address bptr + :signed-fullword))) + (declare (type (signed-byte 32) result)) + (if (and (< result 0) + (eql (%get-errno) (- #$EINTR))) + ;; x86-64 Leopard bug. + (let* ((asec (pref aptr :timespec.tv_sec)) + (bsec (pref bptr :timespec.tv_sec))) + (if (and (>= bsec 0) + (or (< bsec asec) + (and (= bsec asec) + (< (pref bptr :timespec.tv_nsec) + (pref aptr :timespec.tv_nsec))))) + (psetq aptr bptr bptr aptr) + (return))) + (return)))))))) + + +(defun timeval->ticks (tv) + (+ (* *ticks-per-second* (pref tv :timeval.tv_sec)) + (round (pref tv :timeval.tv_usec) (floor 1000000 *ticks-per-second*)))) + + +(defun gettimeofday (ptimeval &optional ptz) + (int-errno-ffcall (%kernel-import target::kernel-import-lisp-gettimeofday) + :address ptimeval + :address (or ptz (%null-ptr)) + :int)) + +(defloadvar *lisp-start-timeval* + (progn + (let* ((r (make-record :timeval))) + (gettimeofday r) + r))) + + +(defloadvar *internal-real-time-session-seconds* nil) + + +(defun get-internal-real-time () + "Return the real time in the internal time format. (See + INTERNAL-TIME-UNITS-PER-SECOND.) This is useful for finding elapsed time." + (rlet ((tv :timeval)) + (gettimeofday tv) + (let* ((units (truncate (the fixnum (pref tv :timeval.tv_usec)) (/ 1000000 internal-time-units-per-second))) + (initial *internal-real-time-session-seconds*)) + (if initial + (locally + (declare (type (unsigned-byte 32) initial)) + (+ (* internal-time-units-per-second + (the (unsigned-byte 32) + (- (the (unsigned-byte 32) (pref tv :timeval.tv_sec)) + initial))) + units)) + (progn + (setq *internal-real-time-session-seconds* + (pref tv :timeval.tv_sec)) + units))))) + +(defun get-tick-count () + (values (floor (get-internal-real-time) + (floor internal-time-units-per-second + *ticks-per-second*)))) + + + + +(defun %kernel-global-offset (name-or-offset) + (if (fixnump name-or-offset) + name-or-offset + (target::%kernel-global name-or-offset))) + + +(defun %kernel-global-offset-form (name-or-offset-form) + (cond ((quoted-form-p name-or-offset-form) + `(%target-kernel-global ,name-or-offset-form)) + ((fixnump name-or-offset-form) + name-or-offset-form) + (t `(%target-kernel-global ',name-or-offset-form)))) + + + +(defmacro %set-kernel-global (name-or-offset new-value) + `(%set-kernel-global-from-offset + ,(%kernel-global-offset-form name-or-offset) + ,new-value)) + + + +; The number of bytes in a consing (or stack) area +(defun %area-size (area) + (ash (- (%fixnum-ref area target::area.high) + (%fixnum-ref area target::area.low)) + target::fixnumshift)) + +(defun %stack-area-usable-size (area) + (ash (- (%fixnum-ref area target::area.high) + (%fixnum-ref area target::area.softlimit)) + target::fixnum-shift)) + +(defun %cons-lisp-thread (name &optional tcr) + (%istruct 'lisp-thread + tcr + name + 0 + 0 + 0 + nil + nil + (make-lock) + nil + :reset + (make-lock))) + +(defvar *current-lisp-thread* + (%cons-lisp-thread "Initial" (%current-tcr))) + +(defstatic *initial-lisp-thread* *current-lisp-thread*) + +(defun thread-change-state (thread oldstate newstate) + (with-lock-grabbed ((lisp-thread.state-change-lock thread)) + (when (eq (lisp-thread.state thread) oldstate) + (setf (lisp-thread.state thread) newstate)))) + +(thread-change-state *initial-lisp-thread* :reset :run) + +(defun thread-state (thread) + (with-lock-grabbed ((lisp-thread.state-change-lock thread)) + (lisp-thread.state thread))) + +(defun thread-make-startup-function (thread tcr) + #'(lambda () + (thread-change-state thread :reset :run) + (let* ((*current-lisp-thread* thread) + (initial-function (lisp-thread.initial-function.args thread))) + (tcr-clear-preset-state tcr) + (%set-tcr-toplevel-function tcr nil) + (setf (interrupt-level) 0) + (apply (car initial-function) (cdr initial-function)) + (cleanup-thread-tcr thread tcr)))) + +(defun init-thread-from-tcr (tcr thread) + (let* ((cs-area (%fixnum-ref tcr target::tcr.cs-area)) + (vs-area (%fixnum-ref tcr target::tcr.vs-area)) + (ts-area (%fixnum-ref tcr target::tcr.ts-area))) + (when (or (zerop cs-area) + (zerop vs-area) + (zerop ts-area)) + (error "Can't allocate new thread")) + (setf (lisp-thread.tcr thread) tcr + (lisp-thread.cs-size thread) + (%stack-area-usable-size cs-area) + (lisp-thread.vs-size thread) + (%stack-area-usable-size vs-area) + (lisp-thread.ts-size thread) + (%stack-area-usable-size ts-area) + (lisp-thread.startup-function thread) + (thread-make-startup-function thread tcr))) + (thread-change-state thread :exit :reset) + thread) + +(defun default-allocation-quantum () + (ash 1 (%get-kernel-global 'default-allocation-quantum))) + +(defun new-lisp-thread-from-tcr (tcr name) + (let* ((thread (%cons-lisp-thread name tcr))) + (init-thread-from-tcr tcr thread) + (push thread (population-data *lisp-thread-population*)) + thread)) + +(def-ccl-pointers initial-thread () + (init-thread-from-tcr (%current-tcr) *initial-lisp-thread*)) + +(defmethod print-object ((thread lisp-thread) stream) + (print-unreadable-object (thread stream :type t :identity t) + (format stream "~a" (lisp-thread.name thread)) + (let* ((tcr (lisp-thread.tcr thread))) + (if (and tcr (not (eql 0 tcr))) + (format stream " [tcr @ #x~x]" (ash tcr target::fixnumshift)))))) + + +(defvar *lisp-thread-population* + (%cons-population (list *initial-lisp-thread*) $population_weak-list nil)) + + + + + +(defparameter *default-control-stack-size* + #+32-bit-target (ash 1 20) + #+64-bit-target (ash 2 20)) +(defparameter *default-value-stack-size* + #+32-bit-target (ash 1 20) + #+64-bit-target (ash 2 20)) +(defparameter *default-temp-stack-size* + #+32-bit-target (ash 1 19) + #+64-bit-target (ash 2 19)) + + +(defstatic *initial-listener-default-control-stack-size* *default-control-stack-size*) +(defstatic *initial-listener-default-value-stack-size* *default-value-stack-size*) +(defstatic *initial-listener-default-temp-stack-size* *default-temp-stack-size*) + + +(def-ccl-pointers listener-stack-sizes () + (let* ((size (%get-kernel-global 'stack-size))) ; set by --thread-stack-size + (declare (fixnum size)) + (when (> size 0) + (setq *initial-listener-default-control-stack-size* size + *initial-listener-default-value-stack-size* size + *initial-listener-default-temp-stack-size* (floor size 2))))) + + +(defmacro with-area-macptr ((var area) &body body) + `(with-macptrs (,var) + (%setf-macptr-to-object ,var ,area) + ,@body)) + + +(defun gc-area.return-sp (area) + (%fixnum-ref area target::area.gc-count)) + + +(defun (setf gc-area.return-sp) (return-sp area) + (setf (%fixnum-ref area target::area.gc-count) return-sp)) + + + +(defun shutdown-lisp-threads () + ) + +(defun %current-xp () + (let ((xframe (%fixnum-ref (%current-tcr) target::tcr.xframe))) + (when (eql xframe 0) + (error "No current exception frame")) + (%fixnum-ref xframe + (get-field-offset :xframe-list.this)))) + +(defun new-tcr (cs-size vs-size ts-size) + (let* ((tcr (macptr->fixnum + (ff-call + (%kernel-import target::kernel-import-newthread) + #+64-bit-target :unsigned-doubleword + #+32-bit-target :unsigned-fullword cs-size + #+64-bit-target :unsigned-doubleword + #+32-bit-target :unsigned-fullword vs-size + #+64-bit-target :unsigned-doubleword + #+32-bit-target :unsigned-fullword ts-size + :address)))) + (declare (fixnum tcr)) + (if (zerop tcr) + (error "Can't create thread") + tcr))) + +(defun new-thread (name cstack-size vstack-size tstack-size) + (new-lisp-thread-from-tcr (new-tcr cstack-size vstack-size tstack-size) name)) + +(defun new-tcr-for-thread (thread) + (let* ((tcr (new-tcr + (lisp-thread.cs-size thread) + (lisp-thread.vs-size thread) + (lisp-thread.ts-size thread)))) + (setf (lisp-thread.tcr thread) tcr + (lisp-thread.startup-function thread) + (thread-make-startup-function thread tcr)) + (thread-change-state thread :exit :reset) + tcr)) + + + + + +(defconstant cstack-hardprot (ash 100 10)) +(defconstant cstack-softprot (ash 100 10)) + + + +(defun tcr-flags (tcr) + (%fixnum-ref tcr target::tcr.flags)) + + + +(defun %tcr-frame-ptr (tcr) + (with-macptrs (p) + (%setf-macptr-to-object p tcr) + (%fixnum-from-macptr + (ff-call (%kernel-import target::kernel-import-tcr-frame-ptr) + :address p + :address)))) + +(defun thread-exhausted-p (thread) + (or (null thread) + (null (lisp-thread.tcr thread)))) + +(defun thread-total-run-time (thread) + (unless (thread-exhausted-p thread) + nil)) + +(defun %tcr-interrupt (tcr) + ;; The other thread's interrupt-pending flag might get cleared + ;; right after we look and see it set, but since this is called + ;; with the lock on the thread's interrupt queue held, the + ;; pending interrupt won't have been taken yet. + ;; When a thread dies, it should try to clear its interrupt-pending + ;; flag. + (if (eql 0 (%fixnum-ref tcr target::tcr.interrupt-pending)) + (%%tcr-interrupt tcr) + 0)) + + + + + + +(defun thread-interrupt (thread process function &rest args) + (with-lock-grabbed ((lisp-thread.state-change-lock thread)) + (case (lisp-thread.state thread) + (:run + (with-lock-grabbed ((lisp-thread.interrupt-lock thread)) + (let ((tcr (lisp-thread.tcr thread))) + (when tcr + (push (cons function args) + (lisp-thread.interrupt-functions thread)) + (eql 0 (%tcr-interrupt tcr)))))) + (:reset + ;; Preset the thread with a function that'll return to the :reset + ;; state + (let* ((pif (process-initial-form process)) + (pif-f (car pif)) + (pif-args (cdr pif))) + (process-preset process #'(lambda () + (%rplaca pif pif-f) + (%rplacd pif pif-args) + (apply function args) + ;; If function returns normally, + ;; return to the reset state + (%process-reset nil))) + (thread-enable thread (process-termination-semaphore process) (1- (integer-length (process-allocation-quantum process))) 0) + t))))) + +(defun thread-handle-interrupts () + (let* ((thread *current-lisp-thread*)) + (with-process-whostate ("Active") + (loop + (let* ((f (with-lock-grabbed ((lisp-thread.interrupt-lock thread)) + (pop (lisp-thread.interrupt-functions thread))))) + (if f + (apply (car f) (cdr f)) + (return))))))) + + + +(defun thread-preset (thread function &rest args) + (setf (lisp-thread.initial-function.args thread) + (cons function args))) + +(defun thread-enable (thread termination-semaphore allocation-quantum &optional (timeout (* 60 60 24))) + (let* ((tcr (or (lisp-thread.tcr thread) (new-tcr-for-thread thread)))) + (with-macptrs (s) + (%setf-macptr-to-object s (%fixnum-ref tcr target::tcr.reset-completion)) + (when (%timed-wait-on-semaphore-ptr s timeout nil) + (%set-tcr-toplevel-function + tcr + (lisp-thread.startup-function thread)) + (%activate-tcr tcr termination-semaphore allocation-quantum) + thread)))) + + +(defun cleanup-thread-tcr (thread tcr) + (let* ((flags (%fixnum-ref tcr target::tcr.flags))) + (declare (fixnum flags)) + (if (logbitp arch::tcr-flag-bit-awaiting-preset flags) + (thread-change-state thread :run :reset) + (progn + (thread-change-state thread :run :exit) + (setf (lisp-thread.tcr thread) nil))))) + +(defun kill-lisp-thread (thread) + (unless (eq thread *initial-lisp-thread*) + (let* ((tcr (lisp-thread.tcr thread))) + (when tcr + (setf (lisp-thread.tcr thread) nil + (lisp-thread.state thread) :exit) + (%kill-tcr tcr))))) + +;;; This returns the underlying pthread, whatever that is, as an +;;; unsigned integer. +(defun lisp-thread-os-thread (thread) + (with-macptrs (tcrp) + (%setf-macptr-to-object tcrp (lisp-thread.tcr thread)) + (unless (%null-ptr-p tcrp) + (let* ((natural (%get-natural tcrp target::tcr.osid))) + (unless (zerop natural) natural))))) + + + +;;; This returns something lower-level than the pthread, if that +;;; concept makes sense. On current versions of Linux, it returns +;;; the pid of the clone()d process; on Darwin, it returns a Mach +;;; thread. On some (near)future version of Linux, the concept +;;; may not apply. +;;; The future is here: on Linux systems using NPTL, this returns +;;; exactly the same thing that (getpid) does. +;;; This should probably be retired; even if it does something +;;; interesting, is the value it returns useful ? + +(defun lisp-thread-native-thread (thread) + (with-macptrs (tcrp) + (%setf-macptr-to-object tcrp (lisp-thread.tcr thread)) + (unless (%null-ptr-p tcrp) + (#+32-bit-target %get-unsigned-long + #+64-bit-target %%get-unsigned-longlong tcrp target::tcr.native-thread-id)))) + +(defun lisp-thread-suspend-count (thread) + (with-macptrs (tcrp) + (%setf-macptr-to-object tcrp (lisp-thread.tcr thread)) + (unless (%null-ptr-p tcrp) + (#+32-bit-target %get-unsigned-long + #+64-bit-target %%get-unsigned-longlong tcrp target::tcr.suspend-count)))) + +(defun tcr-clear-preset-state (tcr) + (let* ((flags (%fixnum-ref tcr target::tcr.flags))) + (declare (fixnum flags)) + (setf (%fixnum-ref tcr target::tcr.flags) + (bitclr arch::tcr-flag-bit-awaiting-preset flags)))) + +(defun tcr-set-preset-state (tcr) + (let* ((flags (%fixnum-ref tcr target::tcr.flags))) + (declare (fixnum flags)) + (setf (%fixnum-ref tcr target::tcr.flags) + (bitset arch::tcr-flag-bit-awaiting-preset flags)))) + +;;; This doesn't quite activate the thread; see PROCESS-TCR-ENABLE. +(defun %activate-tcr (tcr termination-semaphore allocation-quantum) + (declare (ignore termination-semaphore)) + (if (and tcr (not (eql 0 tcr))) + (with-macptrs (tcrp) + (%setf-macptr-to-object tcrp tcr) + (setf (%get-natural tcrp target::tcr.log2-allocation-quantum) + (or allocation-quantum (default-allocation-quantum))) + t))) + +(defvar *canonical-error-value* + '(*canonical-error-value*)) + + +(defun symbol-value-in-tcr (sym tcr) + (if (eq tcr (%current-tcr)) + (%sym-value sym) + (unwind-protect + (progn + (%suspend-tcr tcr) + (let* ((loc (%tcr-binding-location tcr sym))) + (if loc + (%fixnum-ref loc) + (%sym-global-value sym)))) + (%resume-tcr tcr)))) + +(defun (setf symbol-value-in-tcr) (value sym tcr) + (if (eq tcr (%current-tcr)) + (%set-sym-value sym value) + (unwind-protect + (progn + (%suspend-tcr tcr) + (let* ((loc (%tcr-binding-location tcr sym))) + (if loc + (setf (%fixnum-ref loc) value) + (%set-sym-global-value sym value)))) + (%resume-tcr tcr)))) + +;;; Backtrace support +;;; + + + +(defmacro do-db-links ((db-link &optional var value) &body body) + (let ((thunk (gensym)) + (var-var (or var (gensym))) + (value-var (or value (gensym)))) + `(block nil + (let ((,thunk #'(lambda (,db-link ,var-var ,value-var) + (declare (ignorable ,db-link)) + ,@(unless var (list `(declare (ignore ,var-var)))) + ,@(unless value (list `(declare (ignore ,value-var)))) + ,@body))) + (declare (dynamic-extent ,thunk)) + (map-db-links ,thunk))))) + + + + +(defun map-db-links (f) + (without-interrupts + (let ((db-link (%current-db-link))) + (loop + (when (eql 0 db-link) (return)) + (funcall f db-link (%fixnum-ref db-link (* 1 target::node-size)) (%fixnum-ref db-link (* 2 target::node-size))) + (setq db-link (%fixnum-ref db-link)))))) + +(defun %get-frame-ptr () + (%current-frame-ptr)) + +(defun %current-exception-frame () + #+ppc-target *fake-stack-frames* + #+x86-target (or (let* ((xcf (%current-xcf))) + (if xcf + (%%frame-backlink xcf))) + (%current-frame-ptr))) + + + + + +(defun next-catch (catch) + (let ((next-catch (uvref catch target::catch-frame.link-cell))) + (unless (eql next-catch 0) next-catch))) + + + + +; @@@ this needs to load early so errors can work +(defun next-lisp-frame (p context) + (let ((frame p)) + (loop + (let ((parent (%frame-backlink frame context))) + (multiple-value-bind (lisp-frame-p bos-p) (lisp-frame-p parent context) + (if lisp-frame-p + (return parent) + (if bos-p + (return nil)))) + (setq frame parent))))) + +(defun parent-frame (p context) + (loop + (let ((parent (next-lisp-frame p context))) + (when (or (null parent) + (not (catch-csp-p parent context))) + (return parent)) + (setq p parent)))) + + + + + +(defun last-frame-ptr (&optional context origin) + (let* ((current (or origin + (if context (bt.current context) (%current-frame-ptr)))) + (last current)) + (loop + (setq current (parent-frame current context)) + (if current + (setq last current) + (return last))))) + + + +(defun child-frame (p context ) + (let* ((current (if context (bt.current context) (%current-frame-ptr))) + (last nil)) + (loop + (when (null current) + (return nil)) + (when (eq current p) (return last)) + (setq last current + current (parent-frame current context))))) + + + + + +; This returns the current head of the db-link chain. +(defun db-link (&optional context) + (if context + (bt.db-link context) + (%fixnum-ref (%current-tcr) target::tcr.db-link))) + +(defun previous-db-link (db-link start ) + (declare (fixnum db-link start)) + (let ((prev nil)) + (loop + (when (or (eql db-link start) (eql 0 start)) + (return prev)) + (setq prev start + start (%fixnum-ref start 0))))) + +(defun count-db-links-in-frame (vsp parent-vsp &optional context) + (declare (fixnum vsp parent-vsp)) + (let ((db (db-link context)) + (count 0) + (first nil) + (last nil)) + (declare (fixnum db count)) + (loop + (cond ((eql db 0) + (return (values count (or first 0) (or last 0)))) + ((and (>= db vsp) (< db parent-vsp)) + (unless first (setq first db)) + (setq last db) + (incf count))) + (setq db (%fixnum-ref db))))) + +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; +;;; +;;; bogus-thing-p support +;;; + +(defun %ptr-in-area-p (ptr area) + (declare (optimize (speed 3) (safety 0)) (fixnum ptr area)) ; lie, maybe + (and (<= (the fixnum (%fixnum-ref area target::area.low)) ptr) + (> (the fixnum (%fixnum-ref area target::area.high)) ptr))) + +(defun %active-area (area active) + (or (do ((a area (%fixnum-ref a target::area.older))) + ((eql a 0)) + (when (%ptr-in-area-p active a) + (return a))) + (do ((a (%fixnum-ref area target::area.younger) (%fixnum-ref a target::area.younger))) + ((eql a 0)) + (when (%ptr-in-area-p active a) + (return a))))) + +(defun %ptr-to-vstack-p (tcr idx) + (%ptr-in-area-p idx (%fixnum-ref tcr target::tcr.vs-area))) + +(defun %on-tsp-stack (tcr object) + (%ptr-in-area-p object (%fixnum-ref tcr target::tcr.ts-area))) + +(defun %on-csp-stack (tcr object) + (%ptr-in-area-p object (%fixnum-ref tcr target::tcr.cs-area))) + +(defparameter *aux-tsp-ranges* ()) +(defparameter *aux-vsp-ranges* ()) +(defparameter *aux-csp-ranges* ()) + +(defun object-in-range-p (object range) + (declare (fixnum object)) + (when range + (destructuring-bind (active . high) range + (declare (fixnum active high)) + (and (< active object) + (< object high))))) + +(defun object-in-some-range (object ranges) + (dolist (r ranges) + (when (object-in-range-p object r) + (return t)))) + + +(defun on-any-tsp-stack (object) + (or (%on-tsp-stack (%current-tcr) object) + (object-in-some-range object *aux-tsp-ranges*))) + +(defun on-any-vstack (idx) + (or (%ptr-to-vstack-p (%current-tcr) idx) + (object-in-some-range idx *aux-vsp-ranges*))) + +(defun on-any-csp-stack (object) + (or (%on-csp-stack (%current-tcr) object) + (object-in-some-range object *aux-csp-ranges*))) + +;;; This MUST return either T or NIL. +(defun temporary-cons-p (x) + (and (consp x) + (not (null (or (on-any-vstack x) + (on-any-tsp-stack x)))))) + + + + + + + +(defun %value-cell-header-at-p (cur-vsp) + (eql target::value-cell-header (%fixnum-address-of (%fixnum-ref cur-vsp)))) + +(defun count-stack-consed-value-cells-in-frame (vsp parent-vsp) + (let ((cur-vsp vsp) + (count 0)) + (declare (fixnum cur-vsp count)) + (loop + (when (>= cur-vsp parent-vsp) (return)) + (when (and (evenp cur-vsp) (%value-cell-header-at-p cur-vsp)) + (incf count) + (incf cur-vsp)) ; don't need to check value after header + (incf cur-vsp)) + count)) + +;;; stack consed value cells are one of two forms: +;;; Well, they were of two forms. When they existed, that is. +;;; +;;; nil ; n-4 +;;; header ; n = even address (multiple of 8) +;;; value ; n+4 +;;; +;;; header ; n = even address (multiple of 8) +;;; value ; n+4 +;;; nil ; n+8 + +(defun in-stack-consed-value-cell-p (arg-vsp vsp parent-vsp) + (declare (fixnum arg-vsp vsp parent-vsp)) + (if (evenp arg-vsp) + (%value-cell-header-at-p arg-vsp) + (or (and (> arg-vsp vsp) + (%value-cell-header-at-p (the fixnum (1- arg-vsp)))) + (let ((next-vsp (1+ arg-vsp))) + (declare (fixnum next-vsp)) + (and (< next-vsp parent-vsp) + (%value-cell-header-at-p next-vsp)))))) + + + +(defun count-values-in-frame (p context &optional child) + (declare (ignore child)) + (multiple-value-bind (vsp parent-vsp) (vsp-limits p context) + (values + (- parent-vsp + vsp + (* 2 (count-db-links-in-frame vsp parent-vsp context)))))) + +(defun nth-value-in-frame-loc (sp n context lfun pc vsp parent-vsp) + (declare (fixnum sp)) + (setq n (require-type n 'fixnum)) + (unless (or (null vsp) (fixnump vsp)) + (setq vsp (require-type vsp '(or null fixnum)))) + (unless (or (null parent-vsp) (fixnump parent-vsp)) + (setq parent-vsp (require-type parent-vsp '(or null fixnum)))) + (unless (and vsp parent-vsp) + (multiple-value-setq (vsp parent-vsp) (vsp-limits sp context))) + (locally (declare (fixnum n vsp parent-vsp)) + (multiple-value-bind (db-count first-db last-db) + (count-db-links-in-frame vsp parent-vsp context) + (declare (ignore db-count)) + (declare (fixnum first-db last-db)) + (let ((arg-vsp (1- parent-vsp)) + (cnt n) + (phys-cell 0) + db-link-p) + (declare (fixnum arg-vsp cnt phys-cell)) + (loop + (if (eql (the fixnum (- arg-vsp 2)) last-db) + (setq db-link-p t + arg-vsp last-db + last-db (previous-db-link last-db first-db) + phys-cell (+ phys-cell 2)) + (setq db-link-p nil)) + (when (< (decf cnt) 0) + (return + (if db-link-p + (values (+ 2 arg-vsp) + :saved-special + (binding-index-symbol (%fixnum-ref (1+ arg-vsp)))) + (multiple-value-bind (type name) (find-local-name phys-cell lfun pc) + (values arg-vsp type name))))) + (incf phys-cell) + (when (< (decf arg-vsp) vsp) + (error "~d out of range" n))))))) + + + +(defun nth-value-in-frame (sp n context &optional lfun pc vsp parent-vsp) + (multiple-value-bind (loc type name) + (nth-value-in-frame-loc sp n context lfun pc vsp parent-vsp) + (let* ((val (%fixnum-ref loc))) + (when (and (eq type :saved-special) + (eq val (%no-thread-local-binding-marker)) + name) + (setq val (%sym-global-value name))) + (values val type name)))) + +(defun set-nth-value-in-frame (sp n context new-value &optional vsp parent-vsp) + (multiple-value-bind (loc type name) + (nth-value-in-frame-loc sp n context nil nil vsp parent-vsp) + (let* ((old-value (%fixnum-ref loc))) + (if (and (eq type :saved-special) + (eq old-value (%no-thread-local-binding-marker)) + name) + ;; Setting the (shallow-bound) value of the outermost + ;; thread-local binding of NAME. Hmm. + (%set-sym-global-value name new-value) + (setf (%fixnum-ref loc) new-value))))) + +(defun nth-raw-frame (n start-frame context) + (declare (fixnum n)) + (do* ((p start-frame (parent-frame p context)) + (i 0 (1+ i)) + (q (last-frame-ptr context))) + ((or (null p) (eq p q) (%stack< q p context))) + (declare (fixnum i)) + (if (= i n) + (return p)))) + +;;; True if the object is in one of the heap areas +(defun %in-consing-area-p (x area) + (declare (optimize (speed 3) (safety 0)) (fixnum x)) ; lie + (let* ((low (%fixnum-ref area target::area.low)) + (high (%fixnum-ref area target::area.high)) +) + (declare (fixnum low high)) + (and (<= low x) (< x high)))) + + + +(defun in-any-consing-area-p (x) + (do-consing-areas (area) + (when (%in-consing-area-p x area) + (return t)))) + + + + + + + + + +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; +;;; +;;; terminate-when-unreachable +;;; + +#| +Message-Id: +Mime-Version: 1.0 +Content-Type: text/plain; charset="us-ascii" +Date: Wed, 7 Feb 1996 10:32:55 -0500 +To: pmcldev@digitool.com +From: bitCraft@taconic.net (Bill St. Clair) +Subject: terminate-when-unreachable + +I propose that we add a general termination mechanism to PPC MCL. +We need it to properly terminate stack groups, it would be +a nicer way to do the termination for macptrs than the current +ad-hoc mechanism (which BTW is not yet part of PPC MCL), and +it is a nice addition to MCL. I don't think it's hard to make +the garbage collector support this, and I volunteer to do the +work unless Gary really wants to. + +I see two ways to support termination: + +1) Do termination for hash tables. This was our plan for + 2.0, but Gary got confused about how to mark the objects at + the right time (or so I remember). + +2) Resurrect weak alists (they're not part of the PPC garbage + collector) and add a termination bit to the population type. + This allows for termination of weak lists and weak alists, + though the termination mechanism really only needs termination + for a single weak alist. + +I prefer option 2, weak alists, since it avoids the overhead +necessary to grow and rehash a hash table. It also uses less space, +since a finalizeable hash table needs to allocate two cons cells +for each entry so that the finalization code has some place to +put the deleted entry. + +I propose the following interface (slightly modified from what +Apple Dylan provides): + +terminate-when-unreachable object &optional (function 'terminate) + When OBJECT becomes unreachable, funcall FUNCTION with OBJECT + as a single argument. Each call of terminate-when-unreachable + on a single (EQ) object registers a new termination function. + All will be called when the object becomes unreachable. + +terminate object [generic function] + The default termination function + +terminate (object t) [method] + The default method. Ignores object. Returns nil. + +drain-termination-queue [function] + Drain the termination queue. I.e. call the termination function + for every object that has become unreachable. + +*enable-automatic-termination* [variable] + If true, the default, drain-termination-queue will be automatically + called on the first event check after the garbage collector runs. + If you set this to false, you are responsible for calling + drain-termination-queue. + +cancel-terminate-when-unreachable object &optional function + Removes the effect of the last call to terminate-when-unreachable + for OBJECT & FUNCTION (both tested with EQ). Returns true if + it found a match (which it won't if the object has been moved + to the termination queue since terminate-when-unreachable was called). + If FUNCTION is NIL or unspecified, then it will not be used; the + last call to terminate-when-unreachable with the given OBJECT will + be undone. + +termination-function object + Return the function passed to the last call of terminate-when-unreachable + for OBJECT. Will be NIL if the object has been put in the + termination queue since terminate-when-unreachable was called. + +|# + + +(defstatic *termination-population* + (%cons-terminatable-alist)) + +(defstatic *termination-population-lock* (make-lock)) + + +(defvar *enable-automatic-termination* t) + +(defun terminate-when-unreachable (object &optional (function 'terminate)) + "The termination mechanism is a way to have the garbage collector run a +function right before an object is about to become garbage. It is very +similar to the finalization mechanism which Java has. It is not standard +Common Lisp, although other Lisp implementations have similar features. +It is useful when there is some sort of special cleanup, deallocation, +or releasing of resources which needs to happen when a certain object is +no longer being used." + (let ((new-cell (cons object function)) + (population *termination-population*)) + (without-interrupts + (with-lock-grabbed (*termination-population-lock*) + (atomic-push-uvector-cell population population.data new-cell))) + function)) + +(defmethod terminate ((object t)) + nil) + +(defun drain-termination-queue () + (with-lock-grabbed (*termination-population-lock*) + (let* ((population *termination-population*)) + (loop + (multiple-value-bind (cell existed) + (atomic-pop-uvector-cell population population.termination-list) + (if (not existed) + (return) + (funcall (cdr cell) (car cell)))))))) + +(defun cancel-terminate-when-unreachable (object &optional (function nil function-p)) + (let* ((found nil)) + (with-lock-grabbed (*termination-population-lock*) + ;; We don't really need to be very paranoid here. Nothing can + ;; be added to the termination queue while we hold the lock, + ;; and the GC can't splice anything out of the list while + ;; we hold a strong reference to that list. + (let* ((population *termination-population*) + (queue (population.data population))) + (do* ((prev nil spine) + (spine queue (cdr spine))) + ((null spine)) + (let* ((entry (car spine))) + (destructuring-bind (o . f) entry + (when (and (eq o object) + (or (null function-p) + (eq function f))) + (if prev + (setf (cdr prev) (cdr spine)) + (setf (population.data population) (cdr spine))) + (setq found t) + (return))))) + found)))) + + +(defun termination-function (object) + (without-interrupts + (with-lock-grabbed (*termination-population-lock*) + (cdr (assq object (population-data *termination-population*)))))) + +(defun do-automatic-termination () + (when *enable-automatic-termination* + (drain-termination-queue))) + +(queue-fixup + (add-gc-hook 'do-automatic-termination :post-gc)) + +;;; A callback to handle foreign thread preparation, initialization, +;;; and termination. +;;; "preparation" involves telling the kernel to reserve space for +;;; some initial thread-specific special bindings. The kernel +;;; needs to reserve this space on the foreign thread's vstack; +;;; it needs us to tell it how much space to reserve (enough +;;; for bindings of *current-thread*, *current-process*, and +;;; the default initial bindings of *PACKAGE*, etc.) +;;; +;;; "initialization" involves making those special bindings in +;;; the vstack space reserved by the kernel, and setting the +;;; values of *current-thread* and *current-process* to newly +;;; created values. +;;; +;;; "termination" involves removing the current thread and +;;; current process from the global thread/process lists. +;;; "preparation" and "initialization" happen when the foreign +;;; thread first tries to call lisp code. "termination" happens +;;; via the pthread thread-local-storage cleanup mechanism. +(defcallback %foreign-thread-control (:without-interrupts t :int param :int) + (declare (fixnum param)) + (cond ((< param 0) (%foreign-thread-prepare)) + ((= param 0) (%foreign-thread-initialize) 0) + (t (%foreign-thread-terminate) 0))) + + + +(defun %foreign-thread-prepare () + (let* ((initial-bindings (standard-initial-bindings))) + (%save-standard-binding-list initial-bindings) + (* 3 (+ 2 (length initial-bindings))))) + + +(defun %foreign-thread-initialize () + ;; Recover the initial-bindings alist. + (let* ((bsp (%saved-bindings-address)) + (initial-bindings (%fixnum-ref bsp ))) + (declare (fixnum bsp)) + ;; Um, this is a little more complicated now that we use + ;; thread-local shallow binding + (flet ((save-binding (new-value sym prev) + (let* ((idx (symbol-binding-index sym)) + (byte-idx (ash idx target::fixnum-shift)) + (binding-vector (%fixnum-ref (%current-tcr) target::tcr.tlb-pointer)) + (old-value (%fixnum-ref binding-vector byte-idx))) + (setf (%fixnum-ref binding-vector byte-idx) new-value + (%fixnum-ref bsp (ash -1 target::word-shift)) old-value + (%fixnum-ref bsp (ash -2 target::word-shift)) idx + (%fixnum-ref bsp (ash -3 target::word-shift)) prev + bsp (- bsp 3))))) + (save-binding nil '*current-lisp-thread* 0) + (save-binding nil '*current-process* bsp) + (dolist (pair initial-bindings) + (save-binding (funcall (cdr pair)) (car pair) bsp)) + ;; These may (or may not) be the most recent special bindings. + ;; If they are, just set the current tcr's db-link to point + ;; to BSP; if not, "append" them to the end of the current + ;; linked list. + (let* ((current-db-link (%fixnum-ref (%current-tcr) target::tcr.db-link))) + (declare (fixnum current-db-link)) + (if (zerop current-db-link) + (setf (%fixnum-ref (%current-tcr) target::tcr.db-link) bsp) + (do* ((binding current-db-link) + (next (%fixnum-ref binding 0) + (%fixnum-ref binding 0))) + () + (if (zerop next) + (return (setf (%fixnum-ref binding 0) bsp)) + (setq binding next))))) + ;; Ensure that pending unwind-protects (for WITHOUT-INTERRUPTS + ;; on the callback) don't try to unwind the binding stack beyond + ;; where it was just set. + (do* ((catch (%fixnum-ref (%current-tcr) target::tcr.catch-top) + (%fixnum-ref catch target::catch-frame.link))) + ((zerop catch)) + (declare (fixnum catch)) + (when (eql 0 (%fixnum-ref catch target::catch-frame.db-link)) + (setf (%fixnum-ref catch target::catch-frame.db-link) bsp))))) + (let* ((thread (new-lisp-thread-from-tcr (%current-tcr) "foreign"))) + (setq *current-lisp-thread* thread + *current-process* + (make-process "foreign" :thread thread) + *whostate* "Foreign thread callback"))) + +;;; Remove the foreign thread's lisp-thread and lisp process from +;;; the global lists. +(defun %foreign-thread-terminate () + (let* ((proc *current-process*)) + (when proc + (remove-from-all-processes proc) + (let* ((ts (process-termination-semaphore proc))) + (when ts (signal-semaphore ts)))))) + Index: /branches/new-random/level-1/l1-numbers.lisp =================================================================== --- /branches/new-random/level-1/l1-numbers.lisp (revision 13309) +++ /branches/new-random/level-1/l1-numbers.lisp (revision 13309) @@ -0,0 +1,917 @@ +;;-*-Mode: LISP; Package: CCL -*- +;;; +;;; Copyright (C) 2009 Clozure Associates +;;; Copyright (C) 1994-2001 Digitool, Inc +;;; This file is part of Clozure CL. +;;; +;;; Clozure CL is licensed under the terms of the Lisp Lesser GNU Public +;;; License , known as the LLGPL and distributed with Clozure CL as the +;;; file "LICENSE". The LLGPL consists of a preamble and the LGPL, +;;; which is distributed with Clozure CL as the file "LGPL". Where these +;;; conflict, the preamble takes precedence. +;;; +;;; Clozure CL is referenced in the preamble as the "LIBRARY." +;;; +;;; The LLGPL is also available online at +;;; http://opensource.franz.com/preamble.html + +(in-package "CCL") + +(eval-when (:compile-toplevel :execute) + (require "NUMBER-MACROS") +) + +(defun %parse-number-token (string &optional start end radix) + (if end (require-type end 'fixnum)(setq end (length string))) + (if start (require-type start 'fixnum)(setq start 0)) + (multiple-value-bind (string offset)(array-data-and-offset string) + (new-numtoken string (+ start offset)(- end start) (%validate-radix (or radix 10))))) + +(defun new-numtoken (string start len radix &optional no-rat no-sign) + (declare (fixnum start len radix)) + (if (eq 0 len) + nil + (let ((c (%scharcode string start)) + (nstart start) + (end (+ start len)) + (hic (if (<= radix 10) + (+ (char-code #\0) (1- radix)) + (+ (char-code #\A) (- radix 11)))) + dot dec dgt) + (declare (fixnum nstart end hic)) + (when (or (eq c (char-code #\+))(eq c (char-code #\-))) + (if no-sign + (return-from new-numtoken nil) + (setq nstart (1+ nstart)))) + (when (eq nstart end)(return-from new-numtoken nil)) ; just a sign + (do ((i nstart (1+ i))) + ((eq i end)) + (let () + (setq c (%scharcode string i)) + (cond + ((eq c (char-code #\.)) + (when dot (return-from new-numtoken nil)) + (setq dot t) + (when dec (return-from new-numtoken nil)) + (setq hic (char-code #\9))) + ((< c (char-code #\0)) + (when (and (eq c (char-code #\/))(not dot)(not no-rat)) + (let ((top (new-numtoken string start (- i start) radix))) + (when top + (let ((bottom (new-numtoken string (+ start i 1) (- len i 1) radix t t))) + (when bottom + (return-from new-numtoken (/ top bottom))))))) + (return-from new-numtoken nil)) + ((<= c (char-code #\9)) + (when (> c hic) + ; seen a decimal digit above base. + (setq dgt t))) + (t (when (>= c (char-code #\a))(setq c (- c 32))) + ;; don't care about *read-base* if float + (cond ((or (< c (char-code #\A))(> c hic)) + (when (and (neq i nstart) ; need some digits first + (memq c '#.(list (char-code #\E)(char-code #\F) + (char-code #\D)(char-code #\L) + (char-code #\S)))) + (return-from new-numtoken (parse-float string len start))) + (return-from new-numtoken nil)) + (t ; seen a "digit" in base that ain't decimal + (setq dec t))))))) + (when (and dot (or (and (neq nstart start)(eq len 2)) + (eq len 1))) ;. +. or -. + (return-from new-numtoken nil)) + (when dot + (if (eq c (char-code #\.)) + (progn (setq len (1- len) end (1- end)) + (when dec (return-from new-numtoken nil)) + ; make #o9. work (should it) + (setq radix 10 dgt nil)) + (return-from new-numtoken (parse-float string len start)))) + (when dgt (return-from new-numtoken nil)) ; so why didnt we quit at first sight of it? + ; and we ought to accumulate as we go until she gets too big - maybe + (cond (nil ;(or (and (eq radix 10)(< (- end nstart) 9))(and (eq radix 8)(< (- end nstart) 10))) + (let ((num 0)) + (declare (fixnum num)) + (do ((i nstart (1+ i))) + ((eq i end)) + (setq num (%i+ (%i* num radix)(%i- (%scharcode string i) (char-code #\0))))) + (if (eq (%scharcode string start) (char-code #\-)) (setq num (- num))) + num)) + (t (token2int string start len radix)))))) + + +;; Will Clingers number 1.448997445238699 +;; Doug Curries numbers 214748.3646, 1073741823/5000 +;; My number: 12. +;; Your number: + + + + + +(defun logand (&lexpr numbers) + "Return the bit-wise and of its arguments. Args must be integers." + (let* ((count (%lexpr-count numbers))) + (declare (fixnum count)) + (if (zerop count) + -1 + (let* ((n0 (%lisp-word-ref numbers count))) + (if (= count 1) + (require-type n0 'integer) + (do* ((i 1 (1+ i))) + ((= i count) n0) + (declare (fixnum i)) + (declare (optimize (speed 3) (safety 0))) + (setq n0 (logand (%lexpr-ref numbers count i) n0)))))))) + + +(defun logior (&lexpr numbers) + "Return the bit-wise or of its arguments. Args must be integers." + (let* ((count (%lexpr-count numbers))) + (declare (fixnum count)) + (if (zerop count) + 0 + (let* ((n0 (%lisp-word-ref numbers count))) + (if (= count 1) + (require-type n0 'integer) + (do* ((i 1 (1+ i))) + ((= i count) n0) + (declare (fixnum i)) + (declare (optimize (speed 3) (safety 0))) + (setq n0 (logior (%lexpr-ref numbers count i) n0)))))))) + +(defun logxor (&lexpr numbers) + "Return the bit-wise exclusive or of its arguments. Args must be integers." + (let* ((count (%lexpr-count numbers))) + (declare (fixnum count)) + (if (zerop count) + 0 + (let* ((n0 (%lisp-word-ref numbers count))) + (if (= count 1) + (require-type n0 'integer) + (do* ((i 1 (1+ i))) + ((= i count) n0) + (declare (fixnum i)) + (declare (optimize (speed 3) (safety 0))) + (setq n0 (logxor (%lexpr-ref numbers count i) n0)))))))) + +(defun logeqv (&lexpr numbers) + "Return the bit-wise equivalence of its arguments. Args must be integers." + (let* ((count (%lexpr-count numbers)) + (result (if (zerop count) + 0 + (let* ((n0 (%lisp-word-ref numbers count))) + (if (= count 1) + (require-type n0 'integer) + (do* ((i 1 (1+ i))) + ((= i count) n0) + (declare (fixnum i)) + (declare (optimize (speed 3) (safety 0))) + (setq n0 (logxor (%lexpr-ref numbers count i) n0)))))))) + (declare (fixnum count)) + (if (evenp count) + (lognot result) + result))) + + + + +(defun = (num &lexpr more) + "Return T if all of its arguments are numerically equal, NIL otherwise." + (let* ((count (%lexpr-count more))) + (declare (fixnum count)) + (if (zerop count) + (progn + (require-type num 'number) + t) + (dotimes (i count t) + (unless (=-2 (%lexpr-ref more count i) num) (return)))))) + +(defun /= (num &lexpr more) + "Return T if no two of its arguments are numerically equal, NIL otherwise." + (let* ((count (%lexpr-count more))) + (declare (fixnum count)) + (if (zerop count) + (progn + (require-type num 'number) + t) + (dotimes (i count t) + (declare (fixnum i)) + (do ((j i (1+ j))) + ((= j count)) + (declare (fixnum j)) + (when (=-2 num (%lexpr-ref more count j)) + (return-from /= nil))) + (setq num (%lexpr-ref more count i)))))) + +(defun - (num &lexpr more) + "Subtract the second and all subsequent arguments from the first; + or with one argument, negate the first argument." + (let* ((count (%lexpr-count more))) + (declare (fixnum count)) + (if (zerop count) + (- num) + (dotimes (i count num) + (setq num (--2 num (%lexpr-ref more count i))))))) + +(defun / (num &lexpr more) + "Divide the first argument by each of the following arguments, in turn. + With one argument, return reciprocal." + (let* ((count (%lexpr-count more))) + (declare (fixnum count)) + (if (zerop count) + (%quo-1 num) + (dotimes (i count num) + (setq num (/-2 num (%lexpr-ref more count i))))))) + +(defun + (&lexpr numbers) + "Return the sum of its arguments. With no args, returns 0." + (let* ((count (%lexpr-count numbers))) + (declare (fixnum count)) + (if (zerop count) + 0 + (let* ((n0 (%lisp-word-ref numbers count))) + (if (= count 1) + (require-type n0 'number) + (do* ((i 1 (1+ i))) + ((= i count) n0) + (declare (fixnum i)) + (setq n0 (+-2 (%lexpr-ref numbers count i) n0)))))))) + + + +(defun * (&lexpr numbers) + "Return the product of its arguments. With no args, returns 1." + (let* ((count (%lexpr-count numbers))) + (declare (fixnum count)) + (if (zerop count) + 1 + (let* ((n0 (%lisp-word-ref numbers count))) + (if (= count 1) + (require-type n0 'number) + (do* ((i 1 (1+ i))) + ((= i count) n0) + (declare (fixnum i)) + (declare (optimize (speed 3) (safety 0))) + (setq n0 (*-2 (%lexpr-ref numbers count i) n0)))))))) + + +(defun < (num &lexpr more) + "Return T if its arguments are in strictly increasing order, NIL otherwise." + (let* ((count (%lexpr-count more))) + (declare (fixnum count)) + (if (zerop count) + (progn + (require-type num 'real) + t) + (dotimes (i count t) + (declare (optimize (speed 3) (safety 0))) + (unless (< num (setq num (%lexpr-ref more count i))) + (return)))))) + +(defun <= (num &lexpr more) + "Return T if arguments are in strictly non-decreasing order, NIL otherwise." + (let* ((count (%lexpr-count more))) + (declare (fixnum count)) + (if (zerop count) + (progn + (require-type num 'real) + t) + (dotimes (i count t) + (declare (optimize (speed 3) (safety 0))) + (unless (<= num (setq num (%lexpr-ref more count i))) + (return)))))) + + +(defun > (num &lexpr more) + "Return T if its arguments are in strictly decreasing order, NIL otherwise." + (let* ((count (%lexpr-count more))) + (declare (fixnum count)) + (if (zerop count) + (progn + (require-type num 'real) + t) + (dotimes (i count t) + (declare (optimize (speed 3) (safety 0))) + (unless (> num (setq num (%lexpr-ref more count i))) + (return)))))) + +(defun >= (num &lexpr more) + "Return T if arguments are in strictly non-increasing order, NIL otherwise." + (let* ((count (%lexpr-count more))) + (declare (fixnum count)) + (if (zerop count) + (progn + (require-type num 'real) + t) + (dotimes (i count t) + (declare (optimize (speed 3) (safety 0))) + (unless (>= num (setq num (%lexpr-ref more count i))) + (return)))))) + +(defun max-2 (n0 n1) + (if (> n0 n1) n0 n1)) + +(defun max (num &lexpr more) + "Return the greatest of its arguments; among EQUALP greatest, return + the first." + (let* ((count (%lexpr-count more))) + (declare (fixnum count)) + (if (zerop count) + (require-type num 'real) + (dotimes (i count num) + (declare (optimize (speed 3) (safety 0))) + (setq num (max-2 (%lexpr-ref more count i) num)))))) + +(defun min-2 (n0 n1) + (if (< n0 n1) n0 n1)) + +(defun min (num &lexpr more) + "Return the least of its arguments; among EQUALP least, return + the first." + (let* ((count (%lexpr-count more))) + (declare (fixnum count)) + (if (zerop count) + (require-type num 'real) + (dotimes (i count num) + (declare (optimize (speed 3) (safety 0))) + (setq num (min-2 (%lexpr-ref more count i) num)))))) + + + +;Not CL. Used by transforms. +(defun deposit-byte (value size position integer) + (let ((mask (byte-mask size))) + (logior (ash (logand value mask) position) + (logandc1 (ash mask position) integer)))) + +(defun deposit-field (value bytespec integer) + "Return new integer with newbyte in specified position, newbyte is not right justified." + (if (> bytespec 0) + (logior (logandc1 bytespec integer) (logand bytespec value)) + (progn + (require-type value 'integer) + (require-type integer 'integer)))) + +;;;;;;;;;; Byte field functions ;;;;;;;;;;;;;;;; + +;;; Size = 0, position = 0 -> 0 +;;; size = 0, position > 0 -> -position +;;; else -> (ash (byte-mask size) position) +(defun byte (size position) + "Return a byte specifier which may be used by other byte functions + (e.g. LDB)." + (unless (and (typep size 'integer) + (>= size 0)) + (report-bad-arg size 'unsigned-byte)) + (unless (and (typep position 'integer) + (>= position 0)) + (report-bad-arg position 'unsigned-byte)) + (if (eql 0 size) + (if (eql 0 position) + 0 + (- position)) + (ash (byte-mask size) position))) + + + +(defun byte-size (bytespec) + "Return the size part of the byte specifier bytespec." + (if (> bytespec 0) + (logcount bytespec) + 0)) + +(defun ldb (bytespec integer) + "Extract the specified byte from integer, and right justify result." + (if (and (fixnump bytespec) (> (the fixnum bytespec) 0) (fixnump integer)) + (%ilsr (byte-position bytespec) (%ilogand bytespec integer)) + (let ((size (byte-size bytespec)) + (position (byte-position bytespec))) + (if (eql size 0) + (progn + (require-type integer 'integer) + 0) + (if (and (bignump integer) + (<= size (- (1- target::nbits-in-word) target::fixnumshift)) + (fixnump position)) + (%ldb-fixnum-from-bignum integer size position) + (ash (logand bytespec integer) (- position))))))) + +(defun mask-field (bytespec integer) + "Extract the specified byte from integer, but do not right justify result." + (if (>= bytespec 0) + (logand bytespec integer) + (logand integer 0))) + +(defun dpb (value bytespec integer) + "Return new integer with newbyte in specified position, newbyte is right justified." + (if (and (fixnump value) + (fixnump bytespec) + (> (the fixnum bytespec) 0) + (fixnump integer)) + (%ilogior (%ilogand bytespec (%ilsl (byte-position bytespec) value)) + (%ilogand (%ilognot bytespec) integer)) + (deposit-field (ash value (byte-position bytespec)) bytespec integer))) + +(defun ldb-test (bytespec integer) + "Return T if any of the specified bits in integer are 1's." + (if (> bytespec 0) + (logtest bytespec integer) + (progn + (require-type integer 'integer) + nil))) + +(defun %cons-random-state (seed-1 seed-2) + #+32-bit-target + (%istruct 'random-state seed-1 seed-2) + #+64-bit-target + (%istruct 'random-state (the fixnum (+ (the fixnum seed-2) + (the fixnum (ash (the fixnum seed-1) 16)))))) + +;;; random associated stuff except for the print-object method which +;;; is still in "lib;numbers.lisp" +(defun initialize-random-state (seed-1 seed-2) + (unless (and (fixnump seed-1) (%i<= 0 seed-1) (%i< seed-1 #x10000)) + (report-bad-arg seed-1 '(unsigned-byte 16))) + (unless (and (fixnump seed-2) (%i<= 0 seed-2) (%i< seed-2 #x10000)) + (report-bad-arg seed-2 '(unsigned-byte 16))) + (%cons-random-state seed-1 seed-2)) + +(defun make-random-state (&optional state) + "Make a random state object. If STATE is not supplied, return a copy + of the default random state. If STATE is a random state, then return a + copy of it. If STATE is T then return a random state generated from + the universal time." + (let* ((seed-1 0) + (seed-2 0)) + (if (eq state t) + (multiple-value-setq (seed-1 seed-2) (init-random-state-seeds)) + (progn + (setq state (require-type (or state *random-state*) 'random-state)) + #+32-bit-target + (setq seed-1 (random.seed-1 state) seed-2 (random.seed-2 state)) + #+64-bit-target + (let* ((seed (random.seed-1 state))) + (declare (type (unsigned-byte 32) seed)) + (setq seed-1 (ldb (byte 16 16) seed) + seed-2 (ldb (byte 16 0) seed))))) + (%cons-random-state seed-1 seed-2))) + +(defun random-state-p (thing) (istruct-typep thing 'random-state)) + +;;; transcendental stuff. Should go in level-0;l0-float +;;; but shleps don't work in level-0. Or do they ? +; Destructively set z to x^y and return z. +(defun %double-float-expt! (b e result) + (declare (double-float b e result)) + (with-stack-double-floats ((temp)) + (%setf-double-float temp (#_pow b e)) + (%df-check-exception-2 'expt b e (%ffi-exception-status)) + (%setf-double-float result TEMP))) + +#+(and 32-bit-target (not win32-target)) +(defun %single-float-expt! (b e result) + (declare (single-float b e result)) + (target::with-stack-short-floats ((temp)) + (%setf-short-float temp (#_powf b e)) + (%sf-check-exception-2 'expt b e (%ffi-exception-status)) + (%setf-short-float result TEMP))) + +#+win32-target +(defun %single-float-expt! (b e result) + (declare (single-float b e result)) + (with-stack-double-floats ((temp) (db b) (de e)) + (%setf-double-float temp (#_pow db de)) + (%df-check-exception-2 'expt b e (%ffi-exception-status)) + (%double-float->short-float temp result))) + +#+64-bit-target +(defun %single-float-expt (b e) + (declare (single-float b e)) + (let* ((result (#_powf b e))) + (%sf-check-exception-2 'expt b e (%ffi-exception-status)) + result)) + +(defun %double-float-sin! (n result) + (declare (double-float n result)) + (with-stack-double-floats ((temp)) + (%setf-double-float TEMP (#_sin n)) + (%df-check-exception-1 'sin n (%ffi-exception-status)) + (%setf-double-float result TEMP))) + +#+32-bit-target +(defun %single-float-sin! (n result) + (declare (single-float n result)) + (target::with-stack-short-floats ((temp)) + (%setf-short-float TEMP (#_sinf n)) + (%sf-check-exception-1 'sin n (%ffi-exception-status)) + (%setf-short-float result TEMP))) + +#+64-bit-target +(defun %single-float-sin (n) + (declare (single-float n)) + (let* ((result (#_sinf n))) + (%sf-check-exception-1 'sin n (%ffi-exception-status)) + result)) + +(defun %double-float-cos! (n result) + (declare (double-float n result)) + (with-stack-double-floats ((temp)) + (%setf-double-float TEMP (#_cos n)) + (%df-check-exception-1 'cos n (%ffi-exception-status)) + (%setf-double-float result TEMP))) + +#+32-bit-target +(defun %single-float-cos! (n result) + (declare (single-float n result)) + (target::with-stack-short-floats ((temp)) + (%setf-short-float TEMP (#_cosf n)) + (%sf-check-exception-1 'cos n (%ffi-exception-status)) + (%setf-short-float result TEMP))) + +#+64-bit-target +(defun %single-float-cos (n) + (declare (single-float n)) + (let* ((result (#_cosf n))) + (%sf-check-exception-1 'cos n (%ffi-exception-status)) + result)) + +(defun %double-float-acos! (n result) + (declare (double-float n result)) + (with-stack-double-floats ((temp)) + (%setf-double-float TEMP (#_acos n)) + (%df-check-exception-1 'acos n (%ffi-exception-status)) + (%setf-double-float result TEMP))) + +#+32-bit-target +(defun %single-float-acos! (n result) + (declare (single-float n result)) + (target::with-stack-short-floats ((temp)) + (%setf-short-float TEMP (#_acosf n)) + (%sf-check-exception-1 'acos n (%ffi-exception-status)) + (%setf-short-float result TEMP))) + +#+64-bit-target +(defun %single-float-acos (n) + (declare (single-float n)) + (let* ((result (#_acosf n))) + (%sf-check-exception-1 'acos n (%ffi-exception-status)) + result)) + +(defun %double-float-asin! (n result) + (declare (double-float n result)) + (with-stack-double-floats ((temp)) + (%setf-double-float TEMP (#_asin n)) + (%df-check-exception-1 'asin n (%ffi-exception-status)) + (%setf-double-float result TEMP))) + +#+32-bit-target +(defun %single-float-asin! (n result) + (declare (single-float n result)) + (target::with-stack-short-floats ((temp)) + (%setf-short-float TEMP (#_asinf n)) + (%sf-check-exception-1 'asin n (%ffi-exception-status)) + (%setf-short-float result TEMP))) + +#+64-bit-target +(defun %single-float-asin (n) + (declare (single-float n)) + (let* ((result (#_asinf n))) + (%sf-check-exception-1 'asin n (%ffi-exception-status)) + result)) + +(defun %double-float-cosh! (n result) + (declare (double-float n result)) + (with-stack-double-floats ((temp)) + (%setf-double-float TEMP (#_cosh n)) + (%df-check-exception-1 'cosh n (%ffi-exception-status)) + (%setf-double-float result TEMP))) + +#+32-bit-target +(defun %single-float-cosh! (n result) + (declare (single-float n result)) + (target::with-stack-short-floats ((temp)) + (%setf-short-float TEMP (external-call "coshf" :single-float n :single-float)) + (%sf-check-exception-1 'cosh n (%ffi-exception-status)) + (%setf-short-float result TEMP))) + +#+64-bit-target +(defun %single-float-cosh (n) + (declare (single-float n)) + (let* ((result (#_coshf n))) + (%sf-check-exception-1 'cosh n (%ffi-exception-status)) + result)) + +(defun %double-float-log! (n result) + (declare (double-float n result)) + (with-stack-double-floats ((temp)) + (%setf-double-float TEMP (#_log n)) + (%df-check-exception-1 'log n (%ffi-exception-status)) + (%setf-double-float result TEMP))) + +#+32-bit-target +(defun %single-float-log! (n result) + (declare (single-float n result)) + (target::with-stack-short-floats ((temp)) + (%setf-short-float TEMP (#_logf n)) + (%sf-check-exception-1 'log n (%ffi-exception-status)) + (%setf-short-float result TEMP))) + +#+64-bit-target +(defun %single-float-log (n) + (let* ((result (#_logf n))) + (%sf-check-exception-1 'log n (%ffi-exception-status)) + result)) + +(defun %double-float-tan! (n result) + (declare (double-float n result)) + (with-stack-double-floats ((temp)) + (%setf-double-float TEMP (#_tan n)) + (%df-check-exception-1 'tan n (%ffi-exception-status)) + (%setf-double-float result TEMP))) + +#+32-bit-target +(defun %single-float-tan! (n result) + (declare (single-float n result)) + (target::with-stack-short-floats ((temp)) + (%setf-short-float TEMP (#_tanf n)) + (%sf-check-exception-1 'tan n (%ffi-exception-status)) + (%setf-short-float result TEMP))) + +#+64-bit-target +(defun %single-float-tan (n) + (declare (single-float n)) + (let* ((result (#_tanf n))) + (%sf-check-exception-1 'tan n (%ffi-exception-status)) + result)) + +(defun %double-float-atan! (n result) + (declare (double-float n result)) + (with-stack-double-floats ((temp)) + (%setf-double-float TEMP (#_atan n)) + (%df-check-exception-1 'atan n (%ffi-exception-status)) + (%setf-double-float result TEMP))) + + +#+32-bit-target +(defun %single-float-atan! (n result) + (declare (single-float n result)) + (target::with-stack-short-floats ((temp)) + (%setf-short-float TEMP (#_atanf n)) + (%sf-check-exception-1 'atan n (%ffi-exception-status)) + (%setf-short-float result TEMP))) + +#+64-bit-target +(defun %single-float-atan (n) + (declare (single-float n)) + (let* ((temp (#_atanf n))) + (%sf-check-exception-1 'atan n (%ffi-exception-status)) + temp)) + +(defun %double-float-atan2! (x y result) + (declare (double-float x y result)) + (with-stack-double-floats ((temp)) + (%setf-double-float TEMP (#_atan2 x y)) + (%df-check-exception-2 'atan2 x y (%ffi-exception-status)) + (%setf-double-float result TEMP))) + +#+32-bit-target +(defun %single-float-atan2! (x y result) + (declare (single-float x y result)) + (target::with-stack-short-floats ((temp)) + (%setf-short-float TEMP (#_atan2f x y)) + (%sf-check-exception-2 'atan2 x y (%ffi-exception-status)) + (%setf-short-float result TEMP))) + +#+64-bit-target +(defun %single-float-atan2 (x y) + (declare (single-float x y)) + (let* ((result (#_atan2f x y))) + (%sf-check-exception-2 'atan2 x y (%ffi-exception-status)) + result)) + +(defun %double-float-exp! (n result) + (declare (double-float n result)) + (with-stack-double-floats ((temp)) + (%setf-double-float TEMP (#_exp n)) + (%df-check-exception-1 'exp n (%ffi-exception-status)) + (%setf-double-float result TEMP))) + +#+(and 32-bit-target (not windows target)) +(defun %single-float-exp! (n result) + (declare (single-float n result)) + (target::with-stack-short-floats ((temp)) + (%setf-short-float TEMP (#_expf n)) + (%sf-check-exception-1 'exp n (%ffi-exception-status)) + (%setf-short-float result TEMP))) + +#+(and 32-bit-target windows-target) +(defun %single-float-exp! (n result) + (declare (single-float n result)) + (target::with-stack-short-floats ((temp)) + (%setf-short-float TEMP (external-call "expf" :single-float n :single-float)) + (%sf-check-exception-1 'exp n (%ffi-exception-status)) + (%setf-short-float result TEMP))) + +#+64-bit-target +(defun %single-float-exp (n) + (declare (single-float n)) + (let* ((result (#_expf n))) + (%sf-check-exception-1 'exp n (%ffi-exception-status)) + result)) + +(defun %double-float-sinh! (n result) + (declare (double-float n result)) + (with-stack-double-floats ((temp)) + (%setf-double-float TEMP (#_sinh n)) + (%df-check-exception-1 'sinh n (%ffi-exception-status)) + (%setf-double-float result TEMP))) + +#+32-bit-target +(defun %single-float-sinh! (n result) + (declare (single-float n result)) + (target::with-stack-short-floats ((temp)) + (%setf-short-float TEMP (external-call "sinhf" :single-float n :single-float)) + (%sf-check-exception-1 'sinh n (%ffi-exception-status)) + (%setf-short-float result TEMP))) + +#+64-bit-target +(defun %single-float-sinh (n) + (declare (single-float n)) + (let* ((result (#_sinhf n))) + (%sf-check-exception-1 'sinh n (%ffi-exception-status)) + result)) + +(defun %double-float-tanh! (n result) + (declare (double-float n result)) + (with-stack-double-floats ((temp)) + (%setf-double-float TEMP (#_tanh n)) + (%df-check-exception-1 'tanh n (%ffi-exception-status)) + (%setf-double-float result TEMP))) + +#+32-bit-target +(defun %single-float-tanh! (n result) + (declare (single-float n result)) + (target::with-stack-short-floats ((temp)) + (%setf-short-float TEMP (external-call "tanhf" :single-float n :single-float)) + (%sf-check-exception-1 'tanh n (%ffi-exception-status)) + (%setf-short-float result TEMP))) + +#+64-bit-target +(defun %single-float-tanh (n) + (declare (single-float n)) + (let* ((result (#_tanhf n))) + (%sf-check-exception-1 'tanh n (%ffi-exception-status)) + result)) + +#+windows-target +(progn +(defun %double-float-asinh! (n result) + (declare (double-float n result)) + (with-stack-double-floats ((temp)) + (%setf-double-float TEMP (external-call "asinh" :double-float n :double-float)) + (%df-check-exception-1 'asinh n (%ffi-exception-status)) + (%setf-double-float result TEMP))) + +#+32-bit-target +(defun %single-float-asinh! (n result) + (declare (single-float n result)) + (target::with-stack-short-floats ((temp)) + (%setf-short-float TEMP (external-call "asinhf" :float n :float)) + (%sf-check-exception-1 'asinh n (%ffi-exception-status)) + (%setf-short-float result TEMP))) + +#+64-bit-target +(defun %single-float-asinh (n) + (declare (single-float n)) + (let* ((result (external-call "asinhf" :float n :float))) + (%sf-check-exception-1 'asinh n (%ffi-exception-status)) + result))) + +#-windows-target +(progn +(defun %double-float-asinh! (n result) + (declare (double-float n result)) + (with-stack-double-floats ((temp)) + (%setf-double-float TEMP (#_asinh n)) + (%df-check-exception-1 'asinh n (%ffi-exception-status)) + (%setf-double-float result TEMP))) + + +#+32-bit-target +(defun %single-float-asinh! (n result) + (declare (single-float n result)) + (target::with-stack-short-floats ((temp)) + (%setf-short-float TEMP (#_asinhf n)) + (%sf-check-exception-1 'asinh n (%ffi-exception-status)) + (%setf-short-float result TEMP))) + +#+64-bit-target +(defun %single-float-asinh (n) + (declare (single-float n)) + (let* ((result (#_asinhf n))) + (%sf-check-exception-1 'asinh n (%ffi-exception-status)) + result)) +) + +#+windows-target +(progn +(defun %double-float-acosh! (n result) + (declare (double-float n result)) + (with-stack-double-floats ((temp)) + (%setf-double-float TEMP (external-call "acosh" :double n :double)) + (%df-check-exception-1 'acosh n (%ffi-exception-status)) + (%setf-double-float result TEMP))) + +#+32-bit-target +(defun %single-float-acosh! (n result) + (declare (single-float n result)) + (target::with-stack-short-floats ((temp)) + (%setf-short-float TEMP (external-call "acoshf" :float n :float)) + (%sf-check-exception-1 'acosh n (%ffi-exception-status)) + (%setf-short-float result TEMP))) + +#+64-bit-target +(defun %single-float-acosh (n) + (declare (single-float n)) + (let* ((result (external-call "acoshf" :float n :float))) + (%sf-check-exception-1 'acosh n (%ffi-exception-status)) + result)) + +) + +#-windows-target +(progn +(defun %double-float-acosh! (n result) + (declare (double-float n result)) + (with-stack-double-floats ((temp)) + (%setf-double-float TEMP (#_acosh n)) + (%df-check-exception-1 'acosh n (%ffi-exception-status)) + (%setf-double-float result TEMP))) + +#+32-bit-target +(defun %single-float-acosh! (n result) + (declare (single-float n result)) + (target::with-stack-short-floats ((temp)) + (%setf-short-float TEMP (#_acoshf n)) + (%sf-check-exception-1 'acosh n (%ffi-exception-status)) + (%setf-short-float result TEMP))) + +#+64-bit-target +(defun %single-float-acosh (n) + (declare (single-float n)) + (let* ((result (#_acoshf n))) + (%sf-check-exception-1 'acosh n (%ffi-exception-status)) + result)) +) + +#+windows-target +(progn +(defun %double-float-atanh! (n result) + (declare (double-float n result)) + (with-stack-double-floats ((temp)) + (%setf-double-float TEMP (external-call "atanh" :double n :double)) + (%df-check-exception-1 'atanh n (%ffi-exception-status)) + (%setf-double-float result TEMP))) + +#+32-bit-target +(defun %single-float-atanh! (n result) + (declare (single-float n result)) + (target::with-stack-short-floats ((temp)) + (%setf-short-float TEMP (external-call "atanhf" :float n :float)) + (%sf-check-exception-1 'atanh n (%ffi-exception-status)) + (%setf-short-float result TEMP))) + +#+64-bit-target +(defun %single-float-atanh (n) + (declare (single-float n)) + (let* ((result (external-call "atanhf" :float n :float))) + (%sf-check-exception-1 'atanh n (%ffi-exception-status)) + result)) + +) + +#-windows-target +(progn +(defun %double-float-atanh! (n result) + (declare (double-float n result)) + (with-stack-double-floats ((temp)) + (%setf-double-float TEMP (#_atanh n)) + (%df-check-exception-1 'atanh n (%ffi-exception-status)) + (%setf-double-float result TEMP))) + +#+32-bit-target +(defun %single-float-atanh! (n result) + (declare (single-float n result)) + (target::with-stack-short-floats ((temp)) + (%setf-short-float TEMP (#_atanhf n)) + (%sf-check-exception-1 'atanh n (%ffi-exception-status)) + (%setf-short-float result TEMP))) + +#+64-bit-target +(defun %single-float-atanh (n) + (declare (single-float n)) + (let* ((result (#_atanhf n))) + (%sf-check-exception-1 'atanh n (%ffi-exception-status)) + result)) +) Index: /branches/new-random/level-1/l1-pathnames.lisp =================================================================== --- /branches/new-random/level-1/l1-pathnames.lisp (revision 13309) +++ /branches/new-random/level-1/l1-pathnames.lisp (revision 13309) @@ -0,0 +1,708 @@ +;;;-*-Mode: LISP; Package: CCL -*- +;;; +;;; Copyright (C) 1994-2001 Digitool, Inc +;;; Portions copyright (c) 2001-2009 Clozure Associates. +;;; This file is part of Clozure CL. +;;; +;;; Clozure CL is licensed under the terms of the Lisp Lesser GNU Public +;;; License , known as the LLGPL and distributed with Clozure CL as the +;;; file "LICENSE". The LLGPL consists of a preamble and the LGPL, +;;; which is distributed with Clozure CL as the file "LGPL". Where these +;;; conflict, the preamble takes precedence. +;;; +;;; Clozure CL is referenced in the preamble as the "LIBRARY." +;;; +;;; The LLGPL is also available online at +;;; http://opensource.franz.com/preamble.html + + + +;; L1-pathnames.lisp +;-_-_-_-_-_-_-_-_-_-_-_-_-_-_-_-_-_-_-_-_-_-_-_-_-_-_-_-_-_-_-_-_-_-_-_-_-_-_-_-_-_-_ +;ANSI CL logical pathnames + +(in-package "CCL") + +(defun heap-image-name () + (let* ((p (%null-ptr)) + (string (%get-utf-8-cstring (%get-kernel-global-ptr 'image-name p)))) + (declare (dynamic-extent p)) + #+windows-target (nbackslash-to-forward-slash string) + #+darwin-target (precompose-simple-string string) + #-(or windows-target darwin-target) string)) + +(defloadvar *heap-image-name* (heap-image-name)) + +(defloadvar *command-line-argument-list* + (let* ((argv (%null-ptr)) + (res ())) + (declare (dynamic-extent argv)) + (%get-kernel-global-ptr 'argv argv) + (do* ((i 0 (+ i target::node-size)) + (arg (%get-ptr argv i) (%get-ptr argv i))) + ((%null-ptr-p arg) (nreverse res)) + (declare (fixnum i)) + (push (%get-utf-8-cstring arg) res)))) + +;These are used by make-pathname +(defun %verify-logical-component (name type) + (when (and name (neq name :unspecific)) + (setq name (ensure-simple-string name)) + (when (or (eql 0 (length name)) + (%str-member *pathname-escape-character* name) ;; Hmm, why? + (%path-mem "/;" name)) + (error "Illegal logical pathname ~A component ~S" type name))) + name) + + +(defun verify-logical-host-name (host) + (or (and host + (%verify-logical-component host "host") + (%str-assoc host %logical-host-translations%) + host) + (host-error host))) + +(defun %logical-version-component (version) + (if (or (fixnump version) + (stringp version) + (memq version '(nil :wild :newest :unspecific))) + version + (require-type version '(or fixnum string (member nil :wild :newest :unspecific))))) + +(defun logical-pathname-translations (host) + "Return the (logical) host object argument's list of translations." + (setq host (verify-logical-host-name host)) + (let ((translations (%str-assoc host %logical-host-translations%))) + (unless translations (host-error host)) + (%cdr translations))) + +(defun logical-host-p (host) + (%str-assoc host %logical-host-translations%)) + +(defun host-error (host) ; supposed to be a type-error + (signal-type-error host '(satisfies logical-host-p) "~S is not a defined logical host")) + +(defun set-logical-pathname-translations (host list) + (setq host (%verify-logical-component host "host")) + (let ((old (%str-assoc host %logical-host-translations%)) + (new (let ((%logical-host-translations% (cons (list host) %logical-host-translations%))) + ;; Do this in the context when host is defined, so no errors. + (mapcar #'(lambda (trans) + (destructuring-bind (from to &rest ignored) trans + (declare (ignore ignored)) + (let ((from-path (parse-namestring from host)) + (to-path (pathname to))) + (list (require-type from-path 'logical-pathname) to-path)))) + list)))) + (if old + (progn (%rplaca old host) (%rplacd old new)) + (push (cons host new) %logical-host-translations%))) + list) + +(defsetf logical-pathname-translations set-logical-pathname-translations) + +;;; doesnt check if already there - adds at front +(defun add-logical-pathname-translation (host translation) + (let ((trans (%str-assoc host %logical-host-translations%))) + (if (not trans) + (set-logical-pathname-translations host (list translation)) + (let ((new (destructuring-bind (from to &rest ignored) translation + (declare (ignore ignored)) + (list (parse-namestring from host) (pathname to))))) + (rplacd trans (cons new (cdr trans))) + (cdr trans))))) + +(defun %component-match-p (name wild) + (if (or (eq name :unspecific)(eq name :wild)(eq name :wild-inferiors)(and (stringp name) (or (string= name "*")(string= name "**")))) + (setq name nil)) + (if (or (eq wild :unspecific)(eq wild :wild)(eq wild :wild-inferiors)(eq wild :newest)(and (stringp wild) (or (string= wild "*")(string= wild "**")))) + (setq wild nil)) + (cond ((null name) + (null wild)) + ((null wild) + t) + ((not (and (stringp name) (stringp wild))) + (eq name wild)) + (t (%path-str*= name wild)))) + +(defun translate-directory (source from to reversible &optional thost) + (declare (ignore thost)) ;; leftover from a mac kludge. + (let* ((result (translate-directory2 (cdr source)(cdr from)(cdr to) reversible)) + (relative-p (eq (car source) :relative))) + (cond ((and (not relative-p)(eq result (cdr source))) (or source (list :absolute))) + ((and (not relative-p)(eq result (cdr to))) to) + (t (cons (car (or to source from)) result))))) + + + +(defun translate-directory2 (source from to reversible) + ; we already know it matches + (let (result srest match tfirst trest twild) + (multiple-value-setq (tfirst trest twild) + (%split-ccdirectory to)) + (when (and to (not twild)) + (return-from translate-directory2 to)) + (multiple-value-bind (ffirst frest fwild) + (%split-ccdirectory from) + (setq srest (nthcdr (length ffirst) source)) + (cond ((eq fwild '**) + (setq match (nth-value 1 (%pathname-match-dir1 srest frest t))) + (cond ((eq twild '**) + (setq result (nconc tfirst match)) + (setq srest (nthcdr (length match) srest))) + (t (return-from translate-directory2 + (translate-directory2 source (nconc ffirst match frest) + to reversible))))) + ((eq twild '**) + (let ((length (length tfirst))) + (setq srest (nthcdr length source)) + (setq frest (nthcdr length from)) + (setq match (nth-value 1 (%pathname-match-dir1 srest trest t))) + (cond ((null match) + (setq result tfirst)) + (t (setq srest (nthcdr (setq length (length match)) srest)) + (setq frest (nthcdr length frest)) + (setq result (nconc tfirst match)))))) + (t + (cond ((null fwild) + ; to has a wild component e.g. *abc, from is not wild + ; by defintion source is also not wild + ; which random source component gets plugged in here?? + (setq srest (nthcdr (length tfirst) source)) + (setq frest (nthcdr (length tfirst) source)))) + (let ((part (translate-component + (car srest) (car frest)(car trest) reversible))) + (if (null part)(setq result tfirst) + (progn + (setq part (list part)) + (setq result (nconc tfirst part))))) + (setq srest (cdr srest) frest (cdr frest) trest (cdr trest)))) + (when trest + (let ((foo (translate-directory2 srest frest trest reversible))) + (when foo (setq result (nconc result foo)))))) + result)) + +; cc stands for cdr canonical +; ("abc" "**" "def" => ("abc") ("def") +; ("abc" "*de") => ("abc") ("*de") +(defun %split-ccdirectory (dir) + (let ((pos 0) (wildp nil)(rest dir)) + (dolist (e dir) + (case e + (:wild (setq wildp '*)) + (:wild-inferiors + (setq wildp '**) + (setq rest (cdr rest))) + (:up nil) + (t + (when (%path-mem "*" e) + (cond ((string= e "**") + (setq rest (cdr rest)) + (setq wildp '**)) + ((eql 1 (length (the string e))) + (setq wildp '*)) + (t (setq wildp t)))))) + (when wildp (return)) + (setq rest (cdr rest)) + (setq pos (%i+ 1 pos))) + (cond ((not wildp) + (values dir)) + (t (let (first) + (when rest (setq rest (copy-list rest))) + (dotimes (i pos) + (declare (fixnum i)) + (push (car dir) first) + (setq dir (cdr dir))) + (values (nreverse first) rest wildp)))))) + +; could avoid calling component-match-p by checking here maybe +; if "gazonk" "gaz*" "h*" => "honk" +; then "gazonk" "gaz*" "*" => "onk" or is it "gazonk" (per pg 625) +; I believe in symbolics land "gazonk" is a regular translation +; and "onk" is a reversible translation (achieved by not doing pg 625) AHH +; similarly is "a:" "a:**:" "**" Nil or "a:" +(defun translate-component (source from to &optional reversible) + (let ((orig-to to)) + (cond + ((and (consp source)(consp from)) ; source and from both logical + (setq source (cadr source) from (cadr from))) + ((or (consp source)(consp from)) ; or neither + #-bccl (error "Something non-kosher in translate pathname") + )) + (when (memq from '(:wild :wild-inferiors)) (setq from "*")) + (when (memq source '(:wild :wild-inferiors))(setq source "*")) + (when (memq to '(:wild :wild-inferiors))(setq to "*")) + (cond ((consp to)(setq to (cadr to)))) ;?? + (cond ((and (stringp to)(not (%path-mem "*" to))) + to) + ((and (or (not reversible)(not (stringp source))) ; << + (or (null to) + (and (stringp to)(or (string= to "**")(string= to "*"))))) + source) + ((eq to :unspecific) to) ; here we interpret :unspecific to mean don't want it + ((not (stringp source)) to) + (t + (let ((slen (length source)) srest match spos result (f2 nil) snextpos) + (multiple-value-bind (tfirst trest twild) + (%split-component to) + (cond ((and to (not twild))(return-from translate-component to))) + (multiple-value-bind (ffirst frest fwild) + (%split-component from) + (cond (fwild + (setq spos (if ffirst (length ffirst) 0)) ; start of source hunk + (if frest (setq f2 (%split-component frest))) + (setq snextpos (if f2 (%path-member f2 source spos) slen)) + (setq match (%substr source spos snextpos)) + (if frest (setq srest (%substr source snextpos slen))) + (setq result (if tfirst (%str-cat tfirst match) match)) + (when frest + (let ((foo (translate-component srest frest trest reversible))) + (when foo (setq result (%str-cat result foo)))))) + (t ; to is wild, from and source are not + (setq result (if tfirst (%str-cat tfirst source) source)) + (when trest (setq result (%str-cat result trest)))))) + (if (consp orig-to)(progn (error "shouldnt")(list :logical result)) result) ; 7/96 + )))))) + + +(defun %path-member (small big &optional (start 0)) + (let* ((end (length big)) + (s-end (length small)) + (s-start 1) + (c1 (%schar small 0)) + (pstart start)) + (if (%i> s-end end)(return-from %path-member nil)) + (when (eql c1 *pathname-escape-character*) + (setq c1 (%schar small 1)) + (setq s-start 2)) + (while (and (progn (if (eql (%schar big pstart) *pathname-escape-character*) + (setq pstart (%i+ pstart 1))) + T) + (%i< pstart end) + (neq (%schar big pstart) c1)) + (setq pstart (%i+ pstart 1))) + (if (neq c1 (%schar big pstart))(return-from %path-member nil)) + (setq start (%i+ pstart 1)) + (while (and (progn (if (eql (%schar big start) *pathname-escape-character*) + (setq start (%i+ 1 start))) + (if (eql (%schar small s-start) *pathname-escape-character*) + (setq s-start (%i+ 1 s-start))) + T) + (%i< start end) + (%i< s-start s-end) + (eql (%schar big start)(%schar small s-start))) + (setq start (%i+ start 1) s-start (%i+ s-start 1))) + (cond ((= (the fixnum s-start) (the fixnum s-end)) + pstart) + ((%i< start end) + (%path-member small big (%i+ 1 pstart))) + (T nil)))) + +(defun %split-component (thing &aux pos) + ;"ab*cd*" -> "ab" "cd*" + (if (or (not (typep thing 'string))(null (setq pos (%path-mem "*" thing)))) + (values thing nil nil) + (let* ((len (length thing))) + (declare (fixnum len)) + (values (if (%izerop pos) nil (%substr thing 0 pos)) + (cond ((eql len (%i+ pos 1)) nil) + (t + (when (eq (%schar thing (+ pos 1)) #\*) + (setq pos (+ pos 1))) + (cond ((eql len (%i+ pos 1)) nil) + (t (%substr thing (%i+ pos 1) len))))) + T)))) + +(defun translate-pathname (source from-wildname to-wildname &key reversible) + "Use the source pathname to translate the from-wildname's wild and + unspecified elements into a completed to-pathname based on the to-wildname." + (when (not (pathnamep source)) (setq source (pathname source))) + (flet ((translate-pathname-component-mismatch (component-name source from) + (error "~S components of source ~S and from-wildname ~S do not match" component-name source from))) + (let (r-host r-directory r-name r-type r-version s-host f-host t-host t-device) + (setq s-host (pathname-host source)) + (setq f-host (pathname-host from-wildname)) + (setq t-host (pathname-host to-wildname)) + (setq t-device (pathname-device to-wildname)) + (if (not (%host-component-match-p s-host f-host)) (translate-pathname-component-mismatch 'pathname-host source from-wildname)) + (setq r-host (translate-component s-host f-host t-host reversible)) + (let ((s-dir (%std-directory-component (pathname-directory source) s-host)) + (f-dir (%std-directory-component (pathname-directory from-wildname) f-host)) + (t-dir (%std-directory-component (pathname-directory to-wildname) t-host))) + (let ((match (%pathname-match-directory s-dir f-dir))) + (if (not match)(translate-pathname-component-mismatch 'pathname-directory source from-wildname)) + (setq r-directory (translate-directory s-dir f-dir t-dir reversible t-host)))) + (let ((s-name (pathname-name source)) + (f-name (pathname-name from-wildname)) + (t-name (pathname-name to-wildname))) + (if (not (%component-match-p s-name f-name))(translate-pathname-component-mismatch 'pathname-name source from-wildname)) + (setq r-name (translate-component s-name f-name t-name reversible))) + (let ((s-type (pathname-type source)) + (f-type (pathname-type from-wildname)) + (t-type (pathname-type to-wildname))) + (if (not (%component-match-p s-type f-type))(translate-pathname-component-mismatch 'pathname-component source from-wildname)) + (setq r-type (translate-component s-type f-type t-type reversible))) + (let ((s-version (pathname-version source)) + (f-version (pathname-version from-wildname)) + (t-version (pathname-version to-wildname))) + (if (not (%component-match-p s-version f-version)) (translate-pathname-component-mismatch 'pathname-version source from-wildname)) + (setq r-version (translate-component s-version f-version t-version reversible)) + ;(if (eq r-version :unspecific)(setq r-version nil)) + ) + (make-pathname :device t-device :host r-host :directory r-directory + :name r-name :type r-type :version r-version :defaults nil) + ))) + + + + +(defvar %empty-logical-pathname% (%cons-logical-pathname nil nil nil nil nil)) + +(defun logical-pathname-namestring-p (string) + (multiple-value-bind (sstr start end) (get-pathname-sstring string) + (let ((host (pathname-host-sstr sstr start end t))) + (and host (not (eq host :unspecific)))))) + + +;; This extends CL in that it allows a host-less pathname, like "foo;bar;baz". +(defun logical-pathname (thing &aux (path thing)) + "Converts the pathspec argument to a logical-pathname and returns it." + (when (typep path 'stream) (setq path (%path-from-stream path))) + (etypecase path + (logical-pathname path) + (pathname (report-bad-arg thing 'logical-pathname)) + (string + (multiple-value-bind (sstr start end) (get-sstring path) + ;; Prescan the host, to avoid unknown host errors. + (let ((host (pathname-host-sstr sstr start end t))) + (when (or (null host) (eq host :unspecific)) + (report-bad-arg path '(satisfies logical-pathname-namestring-p))) + (let ((%logical-host-translations% (cons (list host) %logical-host-translations%))) + (declare (special %logical-host-translations%)) + ;; By calling string-to-pathname with a logical pathname as default, we force + ;; parsing as a logical pathname. + (string-to-pathname sstr start end nil %empty-logical-pathname%))))))) + +(defun %host-component-match-p (path-host wild-host) + ;; Note that %component-match-p is case sensitive. Need a + ;; case-insensitive version for hosts. + ;; In addition, host components do not support wildcards. + (or (eq path-host wild-host) + (and (stringp path-host) + (stringp wild-host) + (string-equal path-host wild-host)))) + +(defun pathname-match-p (pathname wildname) + "Pathname matches the wildname template?" + (let ((path-host (pathname-host pathname)) + (wild-host (pathname-host wildname))) + (and + (%host-component-match-p path-host wild-host) + (%component-match-p (pathname-device pathname)(pathname-device wildname)) + (%pathname-match-directory + (%std-directory-component (pathname-directory pathname) path-host) + (%std-directory-component (pathname-directory wildname) wild-host)) + (%component-match-p (pathname-name pathname)(pathname-name wildname)) + (%component-match-p (pathname-type pathname)(pathname-type wildname)) + (%component-match-p (pathname-version pathname)(pathname-version wildname))))) + + +; expects canonicalized directory - how bout absolute vs. relative? +(defun %pathname-match-directory (path wild) + (cond ((equal path wild) t) + ; Don't allow matching absolute and relative, so that can have distinct + ; absolute and wild translations in logical-pathname-translations for + ; a host, and have them match separately. + ((and (consp path)(consp wild)(neq (car path) (car wild))) + nil) ; one absolute & one relative ?? + ((or ;(and (null wild) + ; (let ((dir (cadr path))) + ; (if (stringp dir)(string= dir "**")(eq dir :wild-inferiors)))) + (and (null (cddr wild)) + (let ((dir (cadr wild))) + (if (stringp dir)(string= dir "**")(eq dir :wild-inferiors)))))) + ((null path) + ;; Make missing dir match (:absolute) or (:relative) - is that right? + (null (cdr wild))) + ((null wild) + nil) + (t (%pathname-match-dir0 (cdr path)(cdr wild))))) + +; munch on tails path and wild +(defun %pathname-match-dir0 (path wild) + (flet ((only-wild (dir) + (when (null (cdr dir)) + (setq dir (car dir)) + (when (consp dir) (setq dir (cadr dir))) + (if (stringp dir)(string= dir "**")(eq dir :wild-inferiors))))) + (cond ((eq path wild) t) + ((only-wild wild) + t) + (t (let ((result t)) + (block nil + (while (and path wild) + (let ((pathstr (car path)) + (wildstr (car wild))) + ; allow logical to match physical today + ; because one of these days these logical things will disappear! + (when (consp pathstr)(setq pathstr (cadr pathstr))) + (when (consp wildstr)(setq wildstr (cadr wildstr))) + (case wildstr + (:wild (setq wildstr "*")) + (:wild-inferiors (setq wildstr "**"))) + (case pathstr + (:wild (setq pathstr "*")) + (:wild-inferiors (setq pathstr "**"))) + (if (or (memq wildstr '(:up :back))(memq pathstr '(:up :back))) ;; ????? <<<< + (when (neq pathstr wildstr)(setq result nil) (return-from nil)) + (when (not + (cond ((string= wildstr "**") + (setq result (%pathname-match-dir1 path (cdr wild))) + (return-from nil)) + ((%path-str*= pathstr wildstr)))) + (setq result nil) + (return-from nil))) + (setq wild (cdr wild) path (cdr path)))) + (when (and (or path wild)(not (only-wild wild))) + (setq result nil))) + result))))) + + + +; wild is stuff after a "**" - looking for what matches the ** in (path) +(defun %pathname-match-dir1 (path wild &optional cons-result) + (let ((match nil) pathstr wildstr) + (cond ((null wild) + (values T (if cons-result (mapcar #'(lambda (e) + (if (consp e)(cadr e) e)) + path)))) + ((%pathname-match-dir0 path wild)) ; ie ** matches nothing + (t + (prog nil + AGN + (setq pathstr (car path) wildstr (car wild)) + (when (consp pathstr)(setq pathstr (cadr pathstr))) + (when (consp wildstr)(setq wildstr (cadr wildstr))) + (case wildstr + (:wild (setq wildstr "*")) + (:wild-inferiors (setq wildstr "**"))) + (case pathstr + (:wild (setq pathstr "*")) + (:wild-inferiors (setq pathstr "**"))) + (until (or (not (consp path)) + (%path-str*= pathstr wildstr)) + (when cons-result (push pathstr match)) + (setq path (cdr path)) + (setq pathstr (car path)) + (when (consp pathstr)(setq pathstr (cadr pathstr)))) + ;; either got a match - w and path both have the thing we looked for + ;; or path is empty + (when (null path)(return nil)) + (let ((path1 (cdr path))(wild (cdr wild))) + (when (and (null path1)(null wild)) + (return (values t (when match (nreverse match))))) + (cond ((%pathname-match-dir0 path1 wild) ; is the rest happy too? + (return (values t (nreverse match)))) + (t (when cons-result (push pathstr match)) ; nope, let ** eat more + (setq path (cdr path)) + (go AGN))))))))) + +; three times bigger and 3 times slower - does it matter? +(defun %path-str*= (string pattern) + (multiple-value-bind (string s-start s-end) (get-sstring string) + (multiple-value-bind (pattern p-start p-end) (get-sstring pattern) + (path-str-sub pattern string p-start s-start p-end s-end)))) + +(defun path-str-sub (pattern str p-start s-start p-end s-end) + (declare (fixnum p-start s-start p-end s-end) + (type simple-base-string pattern str)) + (declare (optimize (speed 3)(safety 0))) + (let ((p (%scharcode pattern p-start)) + (esc (char-code *pathname-escape-character*))) + (cond + ((eq p (char-code #\*)) + ; starts with a * find what we looking for unless * is last in which case done + (loop ; lots of *'s same as one + (when (eq (%i+ 1 p-start) p-end) + (return-from path-str-sub t)) + (if (eq (%schar pattern (%i+ 1 p-start)) #\*) + (setq p-start (1+ p-start)) + (return))) + (let* ((next* (%path-mem "*" pattern (%i+ 1 p-start))) + (len (- (or next* p-end) (%i+ 1 p-start)))) + (loop + (when (> (+ s-start len) s-end)(return nil)) + (let ((res (find-str-pattern pattern str (%i+ 1 p-start) s-start (or next* p-end) s-end))) + (if (null res) + (return nil) + (if (null next*) + (if (eq res s-end) + (return t)) + (return (path-str-sub pattern str next* (+ s-start len) p-end s-end))))) + (setq s-start (1+ s-start))))) + (t (when (eq p esc) + (setq p-start (1+ p-start)) + (setq p (%scharcode pattern p-start))) + (let* ((next* (%path-mem "*" pattern (if (eq p (char-code #\*))(%i+ 1 p-start) p-start))) + (this-s-end (if next* (+ s-start (- next* p-start)) s-end))) + (if (> this-s-end s-end) + nil + (if (path-str-match-p pattern str p-start s-start (or next* p-end) this-s-end) + (if (null next*) + t + (path-str-sub pattern str next* this-s-end p-end s-end))))))))) + +; find match of pattern between start and end in str +; rets one past end of pattern in str or nil +(defun find-str-pattern (pattern str p-start s-start p-end s-end) + (declare (fixnum p-start s-start p-end s-end) + (type simple-base-string pattern str)) + (declare (optimize (speed 3)(safety 0))) + (let* ((first-p (%scharcode pattern p-start)) + (esc (char-code *pathname-escape-character*))) + (when (and (eq first-p esc) (not (eq (setq p-start (1+ p-start)) p-end))) + (setq first-p (%scharcode pattern p-start))) + (do* ((i s-start (1+ i)) + (last-i (%i- s-end (%i- p-end p-start)))) + ((> i last-i) nil) + (declare (fixnum i last-i)) + (let ((s (%scharcode str i))) + (when (eq first-p s) + (do* ((j (1+ i) (1+ j)) + (k (1+ p-start)(1+ k))) + ((>= k p-end) (return-from find-str-pattern j)) + (declare (fixnum j k)) + (let* ((p (%scharcode pattern k)) + (s (%scharcode str j))) + (when (and (eq p esc) (< (setq k (1+ k)) p-end)) + (setq p (%scharcode pattern k))) + (when (not (eq p s)) + (return))))))))) + + +(defun path-str-match-p (pattern str p-start s-start p-end s-end) + (declare (fixnum p-start s-start p-end s-end) + (type simple-base-string pattern str)) + (declare (optimize (speed 3)(safety 0))) + ;; does pattern match str between p-start p-end + (let ((esc (char-code *pathname-escape-character*))) + (loop + (when (eq p-start p-end) + (return (eq s-start s-end))) + (when (eq s-start s-end) + (return nil)) + (let ((p (%scharcode pattern p-start))) + (unless *case-sensitive-filesystem* + (setq p (%char-code-upcase p))) + (when (eq p esc) + (when (eq (setq p-start (1+ p-start)) p-end) + (return nil)) + (setq p (%scharcode pattern p-start)) + (unless *case-sensitive-filesystem* + (setq p (%char-code-upcase p)))) + (let* ((q (%scharcode str s-start))) + (unless *case-sensitive-filesystem* + (setq q (%char-code-upcase q))) + (unless (eq p q) + (return nil))) + (setq p-start (1+ p-start)) + (setq s-start (1+ s-start)))))) + + + +(defun ccl-directory () + (let* ((dirpath (getenv "CCL_DEFAULT_DIRECTORY"))) + (if dirpath + (native-to-directory-pathname dirpath) + (let* ((heap-image-path (%realpath (heap-image-name)))) + (make-pathname :directory (pathname-directory heap-image-path) + :device (pathname-device heap-image-path)))))) + +(defun user-homedir-pathname (&optional host) + "Return the home directory of the user as a pathname." + (declare (ignore host)) + (let* ((native + (ignore-errors + (truename + (native-to-directory-pathname (or #+ccl-0711 (getenv "HOME") + (get-user-home-dir (getuid)))))))) + (if (and native (eq :absolute (car (pathname-directory native)))) + native + ;; Another plausible choice here is + ;; #p"/tmp/.hidden-directory-of-some-irc-bot-in-eastern-europe/" + ;; Of course, that might already be the value of $HOME. Anyway, + ;; the user's home directory just contains "config files" (like + ;; SSH keys), and spoofing it can't hurt anything. + (make-pathname :directory '(:absolute) :defaults nil)))) + + + + +(defun translate-logical-pathname (pathname &key) + "Translate PATHNAME to a physical pathname, which is returned." + (setq pathname (pathname pathname)) + (let ((host (pathname-host pathname))) + (cond ((eq host :unspecific) pathname) + ((null host) (%cons-pathname (pathname-directory pathname) + (pathname-name pathname) + (pathname-type pathname) + (pathname-version pathname) + (pathname-device pathname))) + (t + (let ((rule (assoc pathname (logical-pathname-translations host) + :test #'pathname-match-p))) ; how can they match if hosts neq?? + (if rule + (translate-logical-pathname + (translate-pathname pathname (car rule) (cadr rule))) + (signal-file-error $xnotranslation pathname))))))) + +(defloadvar *user-homedir-pathname* (user-homedir-pathname)) + + +;;; Hide this from COMPILE-FILE, for obscure cross-compilation reasons + +(defun setup-initial-translations () + (setf (logical-pathname-translations "home") + `(("**;*.*" ,(merge-pathnames "**/*.*" (user-homedir-pathname))))) + + (setf (logical-pathname-translations "ccl") + `(("l1;**;*.*" "ccl:level-1;**;*.*") + ("l1f;**;*.*" "ccl:l1-fasls;**;*.*") + ("ccl;*.*" ,(merge-pathnames "*.*" (ccl-directory))) + ("**;*.*" ,(merge-pathnames "**/*.*" (ccl-directory)))))) + +(setup-initial-translations) + + +;;; Translate the pathname; if the directory component of the result +;;; is relative, make it absolute (relative to the current directory.) +(defun full-pathname (path &key (no-error t)) + (let* ((path (handler-case (translate-logical-pathname (merge-pathnames path)) + (error (condition) (if no-error + (return-from full-pathname nil) + (error condition))))) + (dir (%pathname-directory path))) + (if (eq (car dir) :absolute) + path + (cons-pathname (absolute-directory-list dir) + (%pathname-name path) + (%pathname-type path) + (pathname-host path) + (pathname-version path))))) + + + + +(defparameter *module-search-path* (list + (cons-pathname '(:absolute "bin") nil nil "ccl") + (cons-pathname '(:absolute "openmcl" "modules") nil nil "home") + (cons-pathname '(:absolute "lib") nil nil "ccl") + (cons-pathname '(:absolute "library") nil nil "ccl") + (cons-pathname '(:absolute "examples" :wild-inferiors) nil nil "ccl") + (cons-pathname '(:absolute "contrib" :wild-inferiors) nil nil "ccl") + (cons-pathname '(:absolute "tools") nil nil "ccl") + (cons-pathname '(:absolute "objc-bridge") nil nil "ccl") + (cons-pathname '(:absolute "cocoa-ide") nil nil "ccl")) + "Holds a list of pathnames to search for the file that has same name + as a module somebody is looking for.") + Index: /branches/new-random/level-1/l1-processes.lisp =================================================================== --- /branches/new-random/level-1/l1-processes.lisp (revision 13309) +++ /branches/new-random/level-1/l1-processes.lisp (revision 13309) @@ -0,0 +1,747 @@ +;;;-*- Mode: Lisp; Package: CCL -*- +;;; +;;; Copyright (C) 2009 Clozure Associates +;;; Copyright (C) 1994-2001 Digitool, Inc +;;; This file is part of Clozure CL. +;;; +;;; Clozure CL is licensed under the terms of the Lisp Lesser GNU Public +;;; License , known as the LLGPL and distributed with Clozure CL as the +;;; file "LICENSE". The LLGPL consists of a preamble and the LGPL, +;;; which is distributed with Clozure CL as the file "LGPL". Where these +;;; conflict, the preamble takes precedence. +;;; +;;; Clozure CL is referenced in the preamble as the "LIBRARY." +;;; +;;; The LLGPL is also available online at +;;; http://opensource.franz.com/preamble.html + + +;; L1-processes.lisp + +(cl:in-package "CCL") + + +(let* ((all-processes ()) + (shutdown-processes ()) + (all-processes-lock (make-lock))) + (defun add-to-all-processes (p) + (with-lock-grabbed (all-processes-lock) + (pushnew p all-processes :test #'eq) + p)) + (defun remove-from-all-processes (p) + (with-lock-grabbed (all-processes-lock) + (setq all-processes (delete p all-processes)) + t)) + (defun all-processes () + "Obtain a fresh list of all known Lisp threads." + (with-lock-grabbed (all-processes-lock) + (copy-list all-processes))) + (defun shutdown-processes () + (with-lock-grabbed (all-processes-lock) + (copy-list shutdown-processes))) + (defun %clear-shutdown-proceses () + (setq shutdown-processes nil)) + (defun add-to-shutdown-processes (p) + (with-lock-grabbed (all-processes-lock) + (pushnew p shutdown-processes :test #'eq)) + t) + (defun pop-shutdown-processes () + (with-lock-grabbed (all-processes-lock) + (pop shutdown-processes))) + (defun find-process (id) + (etypecase id + (process id) + (integer (with-lock-grabbed (all-processes-lock) + (find id all-processes + :key #'(lambda (p) + (process-serial-number p))))) + (string (with-lock-grabbed (all-processes-lock) + (find id all-processes + :key #'(lambda (p) + (process-name p)) + :test #'equal)))))) + + + +(defun not-in-current-process (p operation) + (if (eq p *current-process*) + (error "The current process (~s) can't perform the ~a operation on itself." + p operation))) + +(defun startup-shutdown-processes () + (let* ((p)) + (loop + (unless (setq p (pop-shutdown-processes)) (return)) + (new-tcr-for-thread (process-thread p)) + (%process-preset-internal p) + (process-enable p) + ))) + +;;; Done with a queue-fixup so that it will be the last thing +;;; that happens on startup. +(queue-fixup + (pushnew 'startup-shutdown-processes *lisp-system-pointer-functions*)) + + + + + + + +(defun wrap-initial-bindings (alist) + (mapcar #'(lambda (pair) + (destructuring-bind (symbol . valform) pair + (cons (require-type symbol 'symbol) + (cond ((symbolp valform) + (constantly (symbol-value valform))) + ((typep valform 'function) valform) + ((consp valform) + (if (eq (car valform) 'quote) + (constantly (cadr valform)) + #'(lambda () (apply (car valform) (cdr valform))))) + (t + (constantly valform)))))) + alist)) + + +(defun valid-allocation-quantum-p (x) + (and (>= x *host-page-size*) + (<= x (default-allocation-quantum)) + (= (logcount x) 1))) + + +(let* ((psn -1)) + (defun %new-psn () (incf psn))) + +(defclass process () + ((name :initform nil :initarg :name :accessor process-name) + (thread :initarg :thread :initform nil :accessor process-thread) + (initial-form :initform (cons nil nil) :reader process-initial-form) + (priority :initform 0 :initarg :priority :accessor process-priority) + (persistent :initform nil :initarg :persistent :reader process-persistent) + (splice :initform (cons nil nil) :accessor process-splice) + (initial-bindings :initform nil :initarg :initial-bindings + :accessor process-initial-bindings) + (serial-number :initform (%new-psn) :accessor process-serial-number) + (creation-time :initform (get-tick-count) :reader process-creation-time) + (total-run-time :initform nil :accessor %process-total-run-time) + (ui-object :initform (application-ui-object *application*) + :accessor process-ui-object) + (termination-semaphore :initform nil + :initarg :termination-semaphore + :accessor process-termination-semaphore + :type (or null semaphore)) + (allocation-quantum :initform (default-allocation-quantum) + :initarg :allocation-quantum + :reader process-allocation-quantum + :type (satisfies valid-allocation-quantum-p)) + (dribble-stream :initform nil) + (dribble-saved-terminal-io :initform nil) + (result :initform (cons nil nil) + :reader process-result)) + (:primary-p t)) + +(defparameter *print-process-whostate* t "make it optional") + +(defmethod print-object ((p process) s) + (print-unreadable-object (p s :type t :identity t) + (format s "~a(~d)" (process-name p) + (process-serial-number p)) + (when *print-process-whostate* + (format s " [~a]" (process-whostate p))))) + +(defvar *process-class* (find-class 'process)) + +(defun processp (p) + (memq *process-class* (class-precedence-list (class-of p)))) + +(set-type-predicate 'process 'processp) + +(defun make-process (name &key + thread + persistent + (priority 0) + (stack-size *default-control-stack-size*) + (vstack-size *default-value-stack-size*) + (tstack-size *default-temp-stack-size*) + (initial-bindings ()) + (use-standard-initial-bindings t) + (class (find-class 'process)) + (termination-semaphore ()) + (allocation-quantum (default-allocation-quantum))) + "Create and return a new process." + (let* ((p (make-instance + class + :name name + :priority priority + :persistent persistent + :initial-bindings (append (if use-standard-initial-bindings + (standard-initial-bindings)) + (wrap-initial-bindings + initial-bindings)) + :termination-semaphore (or termination-semaphore + (make-semaphore)) + :allocation-quantum allocation-quantum))) + (with-slots ((lisp-thread thread)) p + (unless lisp-thread + (setq lisp-thread + (or thread + (new-thread name stack-size vstack-size tstack-size))))) + (add-to-all-processes p) + (setf (car (process-splice p)) p) + p)) + + +(defstatic *initial-process* + (let* ((p (make-process + "Initial" + :thread *initial-lisp-thread* + :priority 0))) + p)) + + +(defvar *current-process* *initial-process* + "Bound in each process, to that process itself.") + +(defstatic *interactive-abort-process* *initial-process*) + + + + +(defun process-tcr (p) + (lisp-thread.tcr (process-thread p))) + + + +(defun process-exhausted-p (p) + (let* ((thread (process-thread p))) + (or (null thread) + (thread-exhausted-p thread)))) + +;;; This should be way more concerned about being correct and thread-safe +;;; than about being quick: it's generally only called while printing +;;; or debugging, and there are all kinds of subtle race conditions +;;; here. +(defun process-whostate (p) + "Return a string which describes the status of a specified process." + (let* ((ip *initial-process*)) + (cond ((eq p *current-process*) + (if (%tcr-binding-location (%current-tcr) '*whostate*) + *whostate* + (if (eq p ip) + "Active" + "Reset"))) + (t + (without-interrupts + (with-lock-grabbed (*kernel-exception-lock*) + (with-lock-grabbed (*kernel-tcr-area-lock*) + (let* ((tcr (process-tcr p))) + (if tcr + (unwind-protect + (let* ((loc nil)) + (%suspend-tcr tcr) + (setq loc (%tcr-binding-location tcr '*whostate*)) + (if loc + (%fixnum-ref loc) + (if (eq p ip) + "Active" + "Reset"))) + (%resume-tcr tcr)) + "Exhausted"))))))))) + +(defun (setf process-whostate) (new p) + (unless (process-exhausted-p p) + (setf (symbol-value-in-process '*whostate* p) new))) + + + +(defun process-total-run-time (p) + (or (%process-total-run-time p) + (thread-total-run-time (process-thread p)))) + + + + +(defun initial-bindings (alist) + (let* ((symbols ()) + (values ())) + (dolist (a alist (values (nreverse symbols) (nreverse values))) + (push (car a) symbols) + (push (funcall (cdr a)) values)))) + + + +(defun symbol-value-in-process (sym process) + (if (eq process *current-process*) + (symbol-value sym) + (let* ((val + (without-interrupts + (with-lock-grabbed (*kernel-exception-lock*) + (with-lock-grabbed (*kernel-tcr-area-lock*) + (let* ((tcr (process-tcr process))) + (if tcr + (symbol-value-in-tcr sym tcr) + (%sym-global-value sym)))))))) + (if (eq val (%unbound-marker)) + ;; This might want to be a CELL-ERROR. + (error "~S is unbound in ~S." sym process) + val)))) + +(defun (setf symbol-value-in-process) (value sym process) + (if (eq process *current-process*) + (setf (symbol-value sym) value) + (with-lock-grabbed (*kernel-exception-lock*) + (with-lock-grabbed (*kernel-tcr-area-lock*) + (let* ((tcr (process-tcr process))) + (if tcr + (setf (symbol-value-in-tcr sym tcr) value) + (%set-sym-global-value sym value))))))) + + +(defmethod process-enable ((p process) &optional (wait (* 60 60 24) wait-p)) + "Begin executing the initial function of a specified process." + (not-in-current-process p 'process-enable) + (when wait-p + (check-type wait (unsigned-byte 32))) + (unless (car (process-initial-form p)) + (error "Process ~s has not been preset. Use PROCESS-PRESET to preset the process." p)) + (let* ((thread (process-thread p))) + (do* ((total-wait wait (+ total-wait wait))) + ((thread-enable thread (process-termination-semaphore p) (1- (integer-length (process-allocation-quantum p))) wait) + (process-tcr-enable p (lisp-thread.tcr thread)) + p) + (cerror "Keep trying." + "Unable to enable process ~s; have been trying for ~s seconds." + p total-wait)))) + +(defmethod process-tcr-enable ((process process) tcr) + (when (and tcr (not (eql 0 tcr))) + (%signal-semaphore-ptr (%fixnum-ref-macptr tcr target::tcr.activate)) + )) + + + +(defun process-resume (p) + "Resume a specified process which had previously been suspended +by process-suspend." + (setq p (require-type p 'process)) + (let* ((tcr (process-tcr p))) + (and tcr (%resume-tcr tcr)))) + +(defun process-suspend (p) + "Suspend a specified process." + (setq p (require-type p 'process)) + (if (eq p *current-process*) + (error "Suspending the current process can't work. ~&(If the documentation claims otherwise, it's incorrect.)") + (let* ((tcr (process-tcr p))) + (and tcr (%suspend-tcr tcr))))) + +(defun process-suspend-count (p) + "Return the number of currently-pending suspensions applicable to +a given process." + (setq p (require-type p 'process)) + (let* ((thread (process-thread p))) + (if thread + (lisp-thread-suspend-count thread)))) + +(defun process-active-p (p) + (setq p (require-type p 'process)) + (and (eql 0 (process-suspend-count p)) + (not (process-exhausted-p p)))) + +;;; Used by process-run-function +(defmethod process-preset ((p process) function &rest args) + "Set the initial function and arguments of a specified process." + (let* ((f (require-type function 'function)) + (initial-form (process-initial-form p))) + (declare (type cons initial-form)) + (not-in-current-process p 'process-preset) + ; Not quite right ... + (rplaca initial-form f) + (rplacd initial-form args) + (%process-preset-internal p))) + +(defmethod %process-preset-internal ((process process)) + (let* ((initial-form (process-initial-form process)) + (thread (process-thread process))) + (declare (type cons initial-form)) + (thread-preset + thread + #'(lambda (process initial-form) + (let* ((*current-process* process)) + (add-to-all-processes process) + (multiple-value-bind (syms values) + (initial-bindings (process-initial-bindings process)) + (progv syms values + (setq *whostate* "Active") + (run-process-initial-form process initial-form))))) + process + initial-form) + process)) + + +(defun run-process-initial-form (process initial-form) + (let* ((exited nil) + (kill (handler-case + (restart-case + (let ((values + (multiple-value-list + (apply (car initial-form) + (cdr (the list initial-form))))) + (result (process-result process))) + (setf (cdr result) values + (car result) t) + (setq exited t) + nil) + (abort-break () :report "Reset this thread") + (abort () :report "Kill this thread" (setq exited t))) + (process-reset (condition) + (process-reset-kill condition))))) + ;; We either exited from the initial form normally, were told to + ;; exit prematurely, or are being reset and should enter the + ;; "awaiting preset" state. + (if (or kill exited) + (unless (eq kill :toplevel) + (process-initial-form-exited process (or kill t))) + (progn + (thread-change-state (process-thread process) :run :reset) + (tcr-set-preset-state (process-tcr process)))) + nil)) + +;;; Separated from run-process-initial-form just so I can change it easily. +(defun process-initial-form-exited (process kill) + (without-interrupts + (if (eq kill :shutdown) + (progn + (setq *whostate* "Shutdown") + (add-to-shutdown-processes process))) + (let* ((semaphore (process-termination-semaphore process))) + (when semaphore (signal-semaphore semaphore))) + (maybe-finish-process-kill process kill))) + +(defun maybe-finish-process-kill (process kill) + (when (and kill (neq kill :shutdown)) + (setf (process-whostate process) "Dead") + (remove-from-all-processes process) + (let ((thread (process-thread process))) + (unless (or (eq thread *current-lisp-thread*) + (thread-exhausted-p thread)) + (kill-lisp-thread thread)))) + nil) + + + + +(defun require-global-symbol (s &optional env) + (let* ((s (require-type s 'symbol)) + (bits (%symbol-bits s))) + (unless (or (logbitp $sym_vbit_global bits) + (let* ((defenv (if env (definition-environment env)))) + (if defenv + (eq :global (%cdr (assq s (defenv.specials defenv))))))) + (error "~s not defined with ~s" s 'defstatic)) + s)) + + +(defmethod print-object ((s lock) stream) + (print-unreadable-object (s stream :type t :identity t) + (let* ((val (uvref s target::lock._value-cell)) + (name (uvref s target::lock.name-cell))) + (when name + (format stream "~s " name)) + (if (typep val 'macptr) + (format stream "[ptr @ #x~x]" + (%ptr-to-int val)))))) + +(defun lockp (l) + (eq target::subtag-lock (typecode l))) + +(set-type-predicate 'lock 'lockp) + +(defun recursive-lock-p (l) + (and (eq target::subtag-lock (typecode l)) + (eq 'recursive-lock (%svref l target::lock.kind-cell)))) + +(defun read-write-lock-p (l) + (and (eq target::subtag-lock (typecode l)) + (eq 'read-write-lock (%svref l target::lock.kind-cell)))) + +(setf (type-predicate 'recursive-lock) 'recursive-lock-p + (type-predicate 'read-write-lock) 'read-write-lock-p) + + +(defun grab-lock (lock &optional flag) + "Wait until a given lock can be obtained, then obtain it." + (%lock-recursive-lock-object lock flag)) + +(defun release-lock (lock) + "Relinquish ownership of a given lock." + (%unlock-recursive-lock-object lock)) + +(defun try-lock (lock &optional flag) + "Obtain the given lock, but only if it is not necessary to wait for it." + (%try-recursive-lock-object lock flag)) + +(defun lock-acquisition-status (thing) + (if (istruct-typep thing 'lock-acquisition) + (lock-acquisition.status thing) + (report-bad-arg thing 'lock-acquisition))) + +(defun clear-lock-acquisition-status (thing) + (if (istruct-typep thing 'lock-acquisition) + (setf (lock-acquisition.status thing) nil) + (report-bad-arg thing 'lock-acquisition))) + +(defmethod print-object ((l lock-acquisition) stream) + (print-unreadable-object (l stream :type t :identity t) + (format stream "[status = ~s]" (lock-acquisition-status l)))) + +(defun semaphore-notification-status (thing) + (if (istruct-typep thing 'semaphore-notification) + (semaphore-notification.status thing) + (report-bad-arg thing 'semaphore-notification))) + +(defun clear-semaphore-notification-status (thing) + (if (istruct-typep thing 'semaphore-notification) + (setf (semaphore-notification.status thing) nil) + (report-bad-arg thing 'semaphore-notification))) + +(defmethod print-object ((l semaphore-notification) stream) + (print-unreadable-object (l stream :type t :identity t) + (format stream "[status = ~s]" (semaphore-notification-status l)))) + +(defun process-wait (whostate function &rest args) + "Causes the current lisp process (thread) to wait for a given +predicate to return true." + (declare (dynamic-extent args)) + (or (apply function args) + (with-process-whostate (whostate) + (loop + (when (apply function args) + (return)) + ;; Sleep for a tick + #-windows-target + (%nanosleep 0 *ns-per-tick*) + #+windows-target + (%windows-sleep 5))))) + + + +(defun process-wait-with-timeout (whostate time function &rest args) + "Cause the current thread to wait for a given predicate to return true, +or for a timeout to expire." + (declare (dynamic-extent args)) + (cond ((null time) (apply #'process-wait whostate function args) t) + (t (let* ((win nil) + (when (+ (get-tick-count) time)) + (f #'(lambda () (let ((val (apply function args))) + (if val + (setq win val) + (> (get-tick-count) when)))))) + (declare (dynamic-extent f)) + (process-wait whostate f) + win)))) + + +(defmethod process-interrupt ((process process) function &rest args) + "Arrange for the target process to invoke a specified function at +some point in the near future, and then return to what it was doing." + (let* ((p (require-type process 'process))) + (if (eq p *current-process*) + (progn + (apply function args) + t) + (thread-interrupt + (process-thread p) + process + #'apply + function args)))) + +(defmethod process-debug-condition ((p process) condition frame-pointer) + (declare (ignore condition frame-pointer))) + + + + +;;; This one is in the Symbolics documentation +(defun process-allow-schedule () + "Used for cooperative multitasking; probably never necessary." + (process-yield *current-process*)) + + +;;; something unique that users won't get their hands on +(defun process-reset-tag (process) + (process-splice process)) + +(defun process-run-function (name-or-keywords function &rest args) + "Create a process, preset it, and enable it." + (if (listp name-or-keywords) + (%process-run-function name-or-keywords function args) + (let ((keywords (list :name name-or-keywords))) + (declare (dynamic-extent keywords)) + (%process-run-function keywords function args)))) + +(defun %process-run-function (keywords function args) + (destructuring-bind (&key (name "Anonymous") + (priority 0) + (stack-size *default-control-stack-size*) + (vstack-size *default-value-stack-size*) + (tstack-size *default-temp-stack-size*) + (initial-bindings ()) + (persistent nil) + (use-standard-initial-bindings t) + (termination-semaphore nil) + (allocation-quantum (default-allocation-quantum))) + keywords + (setq priority (require-type priority 'fixnum)) + (let* ((process (make-process name + :priority priority + :stack-size stack-size + :vstack-size vstack-size + :tstack-size tstack-size + :persistent persistent + :use-standard-initial-bindings use-standard-initial-bindings + :initial-bindings initial-bindings + :termination-semaphore termination-semaphore + :allocation-quantum allocation-quantum))) + (process-preset process #'(lambda () (apply function args))) + (process-enable process) + process))) + +(defmethod process-reset ((process process) &optional kill) + "Cause a specified process to cleanly exit from any ongoing computation." + (setq process (require-type process 'process)) + (unless (memq kill '(nil :kill :shutdown)) + (setq kill (require-type kill '(member nil :kill :shutdown)))) + (if (eq process *current-process*) + (%process-reset kill) + (if (process-exhausted-p process) + (maybe-finish-process-kill process kill) + (progn + (process-interrupt process '%process-reset kill))))) + +(defmethod process-yield ((p process)) + #+windows-target (#_Sleep 0) + #-windows-target (#_sched_yield)) + + +(defun %process-reset (kill) + (signal 'process-reset :kill kill) + (maybe-finish-process-kill *current-process* kill)) + +;;; By default, it's just fine with the current process +;;; if the application/user wants to quit. +(defmethod process-verify-quit ((process process)) + t) + +(defmethod process-exit-application ((process process) thunk) + (when (eq process *initial-process*) + (with-standard-abort-handling "Exit Lisp" + (prepare-to-quit) + ;; We may have abruptly terminated a thread + ;; which owned the output lock on *STDOUT*. + ;; Don't block waiting on that lock if so. + (let* ((s *stdout*) + (lock (ioblock-outbuf-lock (basic-stream-ioblock s))) + (locked (make-lock-acquisition))) + (declare (dynamic-extent locked)) + (when (or (null lock) (%try-recursive-lock-object lock locked)) + (unwind-protect + (progn + (fresh-line s) + (finish-output s))) + (when (lock-acquisition.status locked) (release-lock lock))))) + (%set-toplevel thunk) + (toplevel))) + + + +(defmethod process-kill ((process process)) + "Cause a specified process to cleanly exit from any ongoing +computation, and then exit." + (and (process-interrupt process #'%process-reset :kill) + (setf (process-kill-issued process) t))) + +(defun process-abort (process &optional condition) + "Cause a specified process to process an abort condition, as if it +had invoked abort." + (process-interrupt process + #'(lambda () + (abort condition)))) + +(defmethod process-reset-and-enable ((process process)) + (not-in-current-process process 'process-reset-and-enable) + (process-reset process) + (process-enable process)) + +(defmethod process-kill-issued ((process process)) + (cdr (process-splice process))) + +(defmethod (setf process-kill-issued) (val (process process)) + (setf (cdr (process-splice process)) val)) + +(defun tcr->process (tcr) + (dolist (p (all-processes)) + (when (eq tcr (process-tcr p)) + (return p)))) + +(defun current-process-allocation-quantum () + (process-allocation-quantum *current-process*)) + +(defun (setf current-process-allocation-quantum) (new) + (if (valid-allocation-quantum-p new) + (with-macptrs (tcrp) + (%setf-macptr-to-object tcrp (%current-tcr)) + (setf (slot-value *current-process* 'allocation-quantum) new + (%get-natural tcrp target::tcr.log2-allocation-quantum) + (1- (integer-length new))) + new) + (report-bad-arg new '(satisfies valid-allocation-quantum-p)))) + + +(def-standard-initial-binding *backtrace-contexts* nil) + +(defmethod exit-interactive-process ((p process)) + (unless (eq p *initial-process*) + (when (eq p *current-process*) + (process-kill p)))) + +(defclass tty-listener (process) + ()) + +(defmethod exit-interactive-process ((p tty-listener)) + (when (eq p *current-process*) + (quit))) + +(defmethod process-stop-dribbling ((p process)) + (with-slots (dribble-stream dribble-saved-terminal-io) p + (when dribble-stream + (close dribble-stream) + (setq dribble-stream nil)) + (when dribble-saved-terminal-io + (setq *terminal-io* dribble-saved-terminal-io + dribble-saved-terminal-io nil)))) + +(defmethod process-dribble ((p process) path) + (with-slots (dribble-stream dribble-saved-terminal-io) p + (process-stop-dribbling p) + (when path + (let* ((in (two-way-stream-input-stream *terminal-io*)) + (out (two-way-stream-output-stream *terminal-io*)) + (f (open path :direction :output :if-exists :append + :if-does-not-exist :create))) + (without-interrupts + (setq dribble-stream f + dribble-saved-terminal-io *terminal-io* + *terminal-io* (make-echoing-two-way-stream + (make-echo-stream in f) + (make-broadcast-stream out f))))) + path))) + +(defmethod join-process ((p process) &key default) + (wait-on-semaphore (process-termination-semaphore p) nil "join-process") + (let ((result (process-result p))) + (cond ((car result) (values-list (cdr result))) + (t default)))) + + Index: /branches/new-random/level-1/l1-reader.lisp =================================================================== --- /branches/new-random/level-1/l1-reader.lisp (revision 13309) +++ /branches/new-random/level-1/l1-reader.lisp (revision 13309) @@ -0,0 +1,3336 @@ +;;;-*-Mode: LISP; Package: CCL -*- +;;; +;;; Copyright (C) 2009 Clozure Associates +;;; Copyright (C) 1994-2001 Digitool, Inc +;;; This file is part of Clozure CL. +;;; +;;; Clozure CL is licensed under the terms of the Lisp Lesser GNU Public +;;; License , known as the LLGPL and distributed with Clozure CL as the +;;; file "LICENSE". The LLGPL consists of a preamble and the LGPL, +;;; which is distributed with Clozure CL as the file "LGPL". Where these +;;; conflict, the preamble takes precedence. +;;; +;;; Clozure CL is referenced in the preamble as the "LIBRARY." +;;; +;;; The LLGPL is also available online at +;;; http://opensource.franz.com/preamble.html + +;;; READ and related functions. + +(in-package "CCL") + +(eval-when (:compile-toplevel :execute) + (defconstant readtable-case-keywords '((:upcase . 1) (:downcase . 2) (:preserve . 0) + (:invert . -1) (:studly . -2))) + (defmacro readtable-case-keywords () `',readtable-case-keywords)) + +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; + +(defmethod make-load-form ((ref package-ref) &optional env) + (declare (ignore env)) + `(register-package-ref ',(package-ref.name ref))) + +(defmethod print-object ((ref package-ref) stream) + (print-unreadable-object (ref stream :type t :identity t) + (format stream "for ~s [~s]" (package-ref.name ref) (package-ref.pkg ref)))) + +;;; Maps character names to characters +(defvar *name->char* (make-hash-table :test #'equalp)) +;;; Maps characters to (canonical) character names. +(defvar *char->name* (make-hash-table :test #'eql)) + +;;; This isn't thread-safe. If the user really wants to register character +;;; names from multiple threads, they should do their own locking. +(defun register-character-name (name char) + (setf (gethash name *name->char*) char) + (unless (gethash char *char->name*) + (setf (gethash char *char->name*) name))) + +(dolist (pair '( + ;; Standard character names + ("Newline" . #\012) ("Space" . #\040) + ;; Semi-standard character names + ("Rubout" . #\177) ("Page" . #\014) ("Tab" . #\011) + ("Backspace" . #\010) ("Return" . #\015) ("Linefeed" . #\012) + ;; Other character names. (When available, standard + ;; names should be used for printing in preference to + ;; any non-standard names.) + ("Null" . #\000) ("Nul" . #\000) + ("Bell" . #\007) ; ^G , used by Franz (and others with bells.) + ("Delete" . #\010) ("BS" . #\010) + ("LF" . #\012) + ("PageUp" . #\013) + ("PageDown" . #\014)("Formfeed" . #\014) ("FF" . #\014) + ("CR" . #\015) + ("Sub" . #\032) + ("ESC" . #\033) ("Escape" . #\033) ("Clear" . #\033) + ("Altmode" . #\033) ("ALT" . #\033) + ("Fs" . #\034) + ("Gs" . #\035) + ("Rs" . #\036) + ("Us" . #\037) + ("DEL" . #\177)("ForwardDelete" . #\177) + ("No-Break_Space" . #\u+00a0) + ("Inverted_Exclamation_Mark" . #\u+00a1) + ("Cent_Sign" . #\u+00a2) + ("Pound_Sign" . #\u+00a3) + ("Currency_Sign" . #\u+00a4) + ("Yen_Sign" . #\u+00a5) + ("Broken_Bar" . #\u+00a6) + ("Section_Sign" . #\u+00a7) + ("Diaeresis" . #\u+00a8) + ("Copyright_Sign" . #\u+00a9) + ("Feminine_Ordinal_Indicator" . #\u+00aa) + ("Left-Pointing_Double_Angle_Quotation_Mark" . #\u+00ab) + ("Not_Sign" . #\u+00ac) + ("Soft_Hyphen" . #\u+00ad) + ("Registered_Sign" . #\u+00ae) + ("Macron" . #\u+00af) + ("Degree_Sign" . #\u+00b0) + ("Plus-Minus_Sign" . #\u+00b1) + ("Superscript_Two" . #\u+00b2) + ("Superscript_Three" . #\u+00b3) + ("Acute_Accent" . #\u+00b4) + ("Micro_Sign" . #\u+00b5) + ("Pilcrow_Sign" . #\u+00b6) + ("Middle_Dot" . #\u+00b7) + ("Cedilla" . #\u+00b8) + ("Superscript_One" . #\u+00b9) + ("Masculine_Ordinal_Indicator" . #\u+00ba) + ("Right-Pointing_Double_Angle_Quotation_Mark" . #\u+00bb) + ("Vulgar_Fraction_One_Quarter" . #\u+00bc) + ("Vulgar_Fraction_One_Half" . #\u+00bd) + ("Vulgar_Fraction_Three_Quarters" . #\u+00be) + ("Inverted_Question_Mark" . #\u+00bf) + ("Latin_Capital_Letter_A_With_Grave" . #\u+00c0) + ("Latin_Capital_Letter_A_With_Acute" . #\u+00c1) + ("Latin_Capital_Letter_A_With_Circumflex" . #\u+00c2) + ("Latin_Capital_Letter_A_With_Tilde" . #\u+00c3) + ("Latin_Capital_Letter_A_With_Diaeresis" . #\u+00c4) + ("Latin_Capital_Letter_A_With_Ring_Above" . #\u+00c5) + ("Latin_Capital_Letter_Ae" . #\u+00c6) + ("Latin_Capital_Letter_C_With_Cedilla" . #\u+00c7) + ("Latin_Capital_Letter_E_With_Grave" . #\u+00c8) + ("Latin_Capital_Letter_E_With_Acute" . #\u+00c9) + ("Latin_Capital_Letter_E_With_Circumflex" . #\u+00ca) + ("Latin_Capital_Letter_E_With_Diaeresis" . #\u+00cb) + ("Latin_Capital_Letter_I_With_Grave" . #\u+00cc) + ("Latin_Capital_Letter_I_With_Acute" . #\u+00cd) + ("Latin_Capital_Letter_I_With_Circumflex" . #\u+00ce) + ("Latin_Capital_Letter_I_With_Diaeresis" . #\u+00cf) + ("Latin_Capital_Letter_Eth" . #\u+00d0) + ("Latin_Capital_Letter_N_With_Tilde" . #\u+00d1) + ("Latin_Capital_Letter_O_With_Grave" . #\u+00d2) + ("Latin_Capital_Letter_O_With_Acute" . #\u+00d3) + ("Latin_Capital_Letter_O_With_Circumflex" . #\u+00d4) + ("Latin_Capital_Letter_O_With_Tilde" . #\u+00d5) + ("Latin_Capital_Letter_O_With_Diaeresis" . #\u+00d6) + ("Multiplication_Sign" . #\u+00d7) + ("Latin_Capital_Letter_O_With_Stroke" . #\u+00d8) + ("Latin_Capital_Letter_U_With_Grave" . #\u+00d9) + ("Latin_Capital_Letter_U_With_Acute" . #\u+00da) + ("Latin_Capital_Letter_U_With_Circumflex" . #\u+00db) + ("Latin_Capital_Letter_U_With_Diaeresis" . #\u+00dc) + ("Latin_Capital_Letter_Y_With_Acute" . #\u+00dd) + ("Latin_Capital_Letter_Thorn" . #\u+00de) + ("Latin_Small_Letter_Sharp_S" . #\u+00df) + ("Latin_Small_Letter_A_With_Grave" . #\u+00e0) + ("Latin_Small_Letter_A_With_Acute" . #\u+00e1) + ("Latin_Small_Letter_A_With_Circumflex" . #\u+00e2) + ("Latin_Small_Letter_A_With_Tilde" . #\u+00e3) + ("Latin_Small_Letter_A_With_Diaeresis" . #\u+00e4) + ("Latin_Small_Letter_A_With_Ring_Above" . #\u+00e5) + ("Latin_Small_Letter_Ae" . #\u+00e6) + ("Latin_Small_Letter_C_With_Cedilla" . #\u+00e7) + ("Latin_Small_Letter_E_With_Grave" . #\u+00e8) + ("Latin_Small_Letter_E_With_Acute" . #\u+00e9) + ("Latin_Small_Letter_E_With_Circumflex" . #\u+00ea) + ("Latin_Small_Letter_E_With_Diaeresis" . #\u+00eb) + ("Latin_Small_Letter_I_With_Grave" . #\u+00ec) + ("Latin_Small_Letter_I_With_Acute" . #\u+00ed) + ("Latin_Small_Letter_I_With_Circumflex" . #\u+00ee) + ("Latin_Small_Letter_I_With_Diaeresis" . #\u+00ef) + ("Latin_Small_Letter_Eth" . #\u+00f0) + ("Latin_Small_Letter_N_With_Tilde" . #\u+00f1) + ("Latin_Small_Letter_O_With_Grave" . #\u+00f2) + ("Latin_Small_Letter_O_With_Acute" . #\u+00f3) + ("Latin_Small_Letter_O_With_Circumflex" . #\u+00f4) + ("Latin_Small_Letter_O_With_Tilde" . #\u+00f5) + ("Latin_Small_Letter_O_With_Diaeresis" . #\u+00f6) + ("Division_Sign" . #\u+00f7) + ("Latin_Small_Letter_O_With_Stroke" . #\u+00f8) + ("Latin_Small_Letter_U_With_Grave" . #\u+00f9) + ("Latin_Small_Letter_U_With_Acute" . #\u+00fa) + ("Latin_Small_Letter_U_With_Circumflex" . #\u+00fb) + ("Latin_Small_Letter_U_With_Diaeresis" . #\u+00fc) + ("Latin_Small_Letter_Y_With_Acute" . #\u+00fd) + ("Latin_Small_Letter_Thorn" . #\u+00fe) + ("Latin_Small_Letter_Y_With_Diaeresis" . #\u+00ff) + ("Latin_Capital_Letter_A_With_Macron" . #\u+0100) + ("Latin_Small_Letter_A_With_Macron" . #\u+0101) + ("Latin_Capital_Letter_A_With_Breve" . #\u+0102) + ("Latin_Small_Letter_A_With_Breve" . #\u+0103) + ("Latin_Capital_Letter_A_With_Ogonek" . #\u+0104) + ("Latin_Small_Letter_A_With_Ogonek" . #\u+0105) + ("Latin_Capital_Letter_C_With_Acute" . #\u+0106) + ("Latin_Small_Letter_C_With_Acute" . #\u+0107) + ("Latin_Capital_Letter_C_With_Circumflex" . #\u+0108) + ("Latin_Small_Letter_C_With_Circumflex" . #\u+0109) + ("Latin_Capital_Letter_C_With_Dot_Above" . #\u+010a) + ("Latin_Small_Letter_C_With_Dot_Above" . #\u+010b) + ("Latin_Capital_Letter_C_With_Caron" . #\u+010c) + ("Latin_Small_Letter_C_With_Caron" . #\u+010d) + ("Latin_Capital_Letter_D_With_Caron" . #\u+010e) + ("Latin_Small_Letter_D_With_Caron" . #\u+010f) + ("Latin_Capital_Letter_D_With_Stroke" . #\u+0110) + ("Latin_Small_Letter_D_With_Stroke" . #\u+0111) + ("Latin_Capital_Letter_E_With_Macron" . #\u+0112) + ("Latin_Small_Letter_E_With_Macron" . #\u+0113) + ("Latin_Capital_Letter_E_With_Breve" . #\u+0114) + ("Latin_Small_Letter_E_With_Breve" . #\u+0115) + ("Latin_Capital_Letter_E_With_Dot_Above" . #\u+0116) + ("Latin_Small_Letter_E_With_Dot_Above" . #\u+0117) + ("Latin_Capital_Letter_E_With_Ogonek" . #\u+0118) + ("Latin_Small_Letter_E_With_Ogonek" . #\u+0119) + ("Latin_Capital_Letter_E_With_Caron" . #\u+011a) + ("Latin_Small_Letter_E_With_Caron" . #\u+011b) + ("Latin_Capital_Letter_G_With_Circumflex" . #\u+011c) + ("Latin_Small_Letter_G_With_Circumflex" . #\u+011d) + ("Latin_Capital_Letter_G_With_Breve" . #\u+011e) + ("Latin_Small_Letter_G_With_Breve" . #\u+011f) + ("Latin_Capital_Letter_G_With_Dot_Above" . #\u+0120) + ("Latin_Small_Letter_G_With_Dot_Above" . #\u+0121) + ("Latin_Capital_Letter_G_With_Cedilla" . #\u+0122) + ("Latin_Small_Letter_G_With_Cedilla" . #\u+0123) + ("Latin_Capital_Letter_H_With_Circumflex" . #\u+0124) + ("Latin_Small_Letter_H_With_Circumflex" . #\u+0125) + ("Latin_Capital_Letter_H_With_Stroke" . #\u+0126) + ("Latin_Small_Letter_H_With_Stroke" . #\u+0127) + ("Latin_Capital_Letter_I_With_Tilde" . #\u+0128) + ("Latin_Small_Letter_I_With_Tilde" . #\u+0129) + ("Latin_Capital_Letter_I_With_Macron" . #\u+012a) + ("Latin_Small_Letter_I_With_Macron" . #\u+012b) + ("Latin_Capital_Letter_I_With_Breve" . #\u+012c) + ("Latin_Small_Letter_I_With_Breve" . #\u+012d) + ("Latin_Capital_Letter_I_With_Ogonek" . #\u+012e) + ("Latin_Small_Letter_I_With_Ogonek" . #\u+012f) + ("Latin_Capital_Letter_I_With_Dot_Above" . #\u+0130) + ("Latin_Small_Letter_Dotless_I" . #\u+0131) + ("Latin_Capital_Ligature_Ij" . #\u+0132) + ("Latin_Small_Ligature_Ij" . #\u+0133) + ("Latin_Capital_Letter_J_With_Circumflex" . #\u+0134) + ("Latin_Small_Letter_J_With_Circumflex" . #\u+0135) + ("Latin_Capital_Letter_K_With_Cedilla" . #\u+0136) + ("Latin_Small_Letter_K_With_Cedilla" . #\u+0137) + ("Latin_Small_Letter_Kra" . #\u+0138) + ("Latin_Capital_Letter_L_With_Acute" . #\u+0139) + ("Latin_Small_Letter_L_With_Acute" . #\u+013a) + ("Latin_Capital_Letter_L_With_Cedilla" . #\u+013b) + ("Latin_Small_Letter_L_With_Cedilla" . #\u+013c) + ("Latin_Capital_Letter_L_With_Caron" . #\u+013d) + ("Latin_Small_Letter_L_With_Caron" . #\u+013e) + ("Latin_Capital_Letter_L_With_Middle_Dot" . #\u+013f) + ("Latin_Small_Letter_L_With_Middle_Dot" . #\u+0140) + ("Latin_Capital_Letter_L_With_Stroke" . #\u+0141) + ("Latin_Small_Letter_L_With_Stroke" . #\u+0142) + ("Latin_Capital_Letter_N_With_Acute" . #\u+0143) + ("Latin_Small_Letter_N_With_Acute" . #\u+0144) + ("Latin_Capital_Letter_N_With_Cedilla" . #\u+0145) + ("Latin_Small_Letter_N_With_Cedilla" . #\u+0146) + ("Latin_Capital_Letter_N_With_Caron" . #\u+0147) + ("Latin_Small_Letter_N_With_Caron" . #\u+0148) + ("Latin_Small_Letter_N_Preceded_By_Apostrophe" . #\u+0149) + ("Latin_Capital_Letter_Eng" . #\u+014a) + ("Latin_Small_Letter_Eng" . #\u+014b) + ("Latin_Capital_Letter_O_With_Macron" . #\u+014c) + ("Latin_Small_Letter_O_With_Macron" . #\u+014d) + ("Latin_Capital_Letter_O_With_Breve" . #\u+014e) + ("Latin_Small_Letter_O_With_Breve" . #\u+014f) + ("Latin_Capital_Letter_O_With_Double_Acute" . #\u+0150) + ("Latin_Small_Letter_O_With_Double_Acute" . #\u+0151) + ("Latin_Capital_Ligature_Oe" . #\u+0152) + ("Latin_Small_Ligature_Oe" . #\u+0153) + ("Latin_Capital_Letter_R_With_Acute" . #\u+0154) + ("Latin_Small_Letter_R_With_Acute" . #\u+0155) + ("Latin_Capital_Letter_R_With_Cedilla" . #\u+0156) + ("Latin_Small_Letter_R_With_Cedilla" . #\u+0157) + ("Latin_Capital_Letter_R_With_Caron" . #\u+0158) + ("Latin_Small_Letter_R_With_Caron" . #\u+0159) + ("Latin_Capital_Letter_S_With_Acute" . #\u+015a) + ("Latin_Small_Letter_S_With_Acute" . #\u+015b) + ("Latin_Capital_Letter_S_With_Circumflex" . #\u+015c) + ("Latin_Small_Letter_S_With_Circumflex" . #\u+015d) + ("Latin_Capital_Letter_S_With_Cedilla" . #\u+015e) + ("Latin_Small_Letter_S_With_Cedilla" . #\u+015f) + ("Latin_Capital_Letter_S_With_Caron" . #\u+0160) + ("Latin_Small_Letter_S_With_Caron" . #\u+0161) + ("Latin_Capital_Letter_T_With_Cedilla" . #\u+0162) + ("Latin_Small_Letter_T_With_Cedilla" . #\u+0163) + ("Latin_Capital_Letter_T_With_Caron" . #\u+0164) + ("Latin_Small_Letter_T_With_Caron" . #\u+0165) + ("Latin_Capital_Letter_T_With_Stroke" . #\u+0166) + ("Latin_Small_Letter_T_With_Stroke" . #\u+0167) + ("Latin_Capital_Letter_U_With_Tilde" . #\u+0168) + ("Latin_Small_Letter_U_With_Tilde" . #\u+0169) + ("Latin_Capital_Letter_U_With_Macron" . #\u+016a) + ("Latin_Small_Letter_U_With_Macron" . #\u+016b) + ("Latin_Capital_Letter_U_With_Breve" . #\u+016c) + ("Latin_Small_Letter_U_With_Breve" . #\u+016d) + ("Latin_Capital_Letter_U_With_Ring_Above" . #\u+016e) + ("Latin_Small_Letter_U_With_Ring_Above" . #\u+016f) + ("Latin_Capital_Letter_U_With_Double_Acute" . #\u+0170) + ("Latin_Small_Letter_U_With_Double_Acute" . #\u+0171) + ("Latin_Capital_Letter_U_With_Ogonek" . #\u+0172) + ("Latin_Small_Letter_U_With_Ogonek" . #\u+0173) + ("Latin_Capital_Letter_W_With_Circumflex" . #\u+0174) + ("Latin_Small_Letter_W_With_Circumflex" . #\u+0175) + ("Latin_Capital_Letter_Y_With_Circumflex" . #\u+0176) + ("Latin_Small_Letter_Y_With_Circumflex" . #\u+0177) + ("Latin_Capital_Letter_Y_With_Diaeresis" . #\u+0178) + ("Latin_Capital_Letter_Z_With_Acute" . #\u+0179) + ("Latin_Small_Letter_Z_With_Acute" . #\u+017a) + ("Latin_Capital_Letter_Z_With_Dot_Above" . #\u+017b) + ("Latin_Small_Letter_Z_With_Dot_Above" . #\u+017c) + ("Latin_Capital_Letter_Z_With_Caron" . #\u+017d) + ("Latin_Small_Letter_Z_With_Caron" . #\u+017e) + ("Latin_Small_Letter_Long_S" . #\u+017f) + ("Latin_Small_Letter_B_With_Stroke" . #\u+0180) + ("Latin_Capital_Letter_B_With_Hook" . #\u+0181) + ("Latin_Capital_Letter_B_With_Topbar" . #\u+0182) + ("Latin_Small_Letter_B_With_Topbar" . #\u+0183) + ("Latin_Capital_Letter_Tone_Six" . #\u+0184) + ("Latin_Small_Letter_Tone_Six" . #\u+0185) + ("Latin_Capital_Letter_Open_O" . #\u+0186) + ("Latin_Capital_Letter_C_With_Hook" . #\u+0187) + ("Latin_Small_Letter_C_With_Hook" . #\u+0188) + ("Latin_Capital_Letter_African_D" . #\u+0189) + ("Latin_Capital_Letter_D_With_Hook" . #\u+018a) + ("Latin_Capital_Letter_D_With_Topbar" . #\u+018b) + ("Latin_Small_Letter_D_With_Topbar" . #\u+018c) + ("Latin_Small_Letter_Turned_Delta" . #\u+018d) + ("Latin_Capital_Letter_Reversed_E" . #\u+018e) + ("Latin_Capital_Letter_Schwa" . #\u+018f) + ("Latin_Capital_Letter_Open_E" . #\u+0190) + ("Latin_Capital_Letter_F_With_Hook" . #\u+0191) + ("Latin_Small_Letter_F_With_Hook" . #\u+0192) + ("Latin_Capital_Letter_G_With_Hook" . #\u+0193) + ("Latin_Capital_Letter_Gamma" . #\u+0194) + ("Latin_Small_Letter_Hv" . #\u+0195) + ("Latin_Capital_Letter_Iota" . #\u+0196) + ("Latin_Capital_Letter_I_With_Stroke" . #\u+0197) + ("Latin_Capital_Letter_K_With_Hook" . #\u+0198) + ("Latin_Small_Letter_K_With_Hook" . #\u+0199) + ("Latin_Small_Letter_L_With_Bar" . #\u+019a) + ("Latin_Small_Letter_Lambda_With_Stroke" . #\u+019b) + ("Latin_Capital_Letter_Turned_M" . #\u+019c) + ("Latin_Capital_Letter_N_With_Left_Hook" . #\u+019d) + ("Latin_Small_Letter_N_With_Long_Right_Leg" . #\u+019e) + ("Latin_Capital_Letter_O_With_Middle_Tilde" . #\u+019f) + ("Latin_Capital_Letter_O_With_Horn" . #\u+01a0) + ("Latin_Small_Letter_O_With_Horn" . #\u+01a1) + ("Latin_Capital_Letter_Oi" . #\u+01a2) + ("Latin_Small_Letter_Oi" . #\u+01a3) + ("Latin_Capital_Letter_P_With_Hook" . #\u+01a4) + ("Latin_Small_Letter_P_With_Hook" . #\u+01a5) + ("Latin_Letter_Yr" . #\u+01a6) + ("Latin_Capital_Letter_Tone_Two" . #\u+01a7) + ("Latin_Small_Letter_Tone_Two" . #\u+01a8) + ("Latin_Capital_Letter_Esh" . #\u+01a9) + ("Latin_Letter_Reversed_Esh_Loop" . #\u+01aa) + ("Latin_Small_Letter_T_With_Palatal_Hook" . #\u+01ab) + ("Latin_Capital_Letter_T_With_Hook" . #\u+01ac) + ("Latin_Small_Letter_T_With_Hook" . #\u+01ad) + ("Latin_Capital_Letter_T_With_Retroflex_Hook" . #\u+01ae) + ("Latin_Capital_Letter_U_With_Horn" . #\u+01af) + ("Latin_Small_Letter_U_With_Horn" . #\u+01b0) + ("Latin_Capital_Letter_Upsilon" . #\u+01b1) + ("Latin_Capital_Letter_V_With_Hook" . #\u+01b2) + ("Latin_Capital_Letter_Y_With_Hook" . #\u+01b3) + ("Latin_Small_Letter_Y_With_Hook" . #\u+01b4) + ("Latin_Capital_Letter_Z_With_Stroke" . #\u+01b5) + ("Latin_Small_Letter_Z_With_Stroke" . #\u+01b6) + ("Latin_Capital_Letter_Ezh" . #\u+01b7) + ("Latin_Capital_Letter_Ezh_Reversed" . #\u+01b8) + ("Latin_Small_Letter_Ezh_Reversed" . #\u+01b9) + ("Latin_Small_Letter_Ezh_With_Tail" . #\u+01ba) + ("Latin_Letter_Two_With_Stroke" . #\u+01bb) + ("Latin_Capital_Letter_Tone_Five" . #\u+01bc) + ("Latin_Small_Letter_Tone_Five" . #\u+01bd) + ("Latin_Letter_Inverted_Glottal_Stop_With_Stroke" . #\u+01be) + ("Latin_Letter_Wynn" . #\u+01bf) + ("Latin_Letter_Dental_Click" . #\u+01c0) + ("Latin_Letter_Lateral_Click" . #\u+01c1) + ("Latin_Letter_Alveolar_Click" . #\u+01c2) + ("Latin_Letter_Retroflex_Click" . #\u+01c3) + ("Latin_Capital_Letter_Dz_With_Caron" . #\u+01c4) + ("Latin_Capital_Letter_D_With_Small_Letter_Z_With_Caron" . #\u+01c5) + ("Latin_Small_Letter_Dz_With_Caron" . #\u+01c6) + ("Latin_Capital_Letter_Lj" . #\u+01c7) + ("Latin_Capital_Letter_L_With_Small_Letter_J" . #\u+01c8) + ("Latin_Small_Letter_Lj" . #\u+01c9) + ("Latin_Capital_Letter_Nj" . #\u+01ca) + ("Latin_Capital_Letter_N_With_Small_Letter_J" . #\u+01cb) + ("Latin_Small_Letter_Nj" . #\u+01cc) + ("Latin_Capital_Letter_A_With_Caron" . #\u+01cd) + ("Latin_Small_Letter_A_With_Caron" . #\u+01ce) + ("Latin_Capital_Letter_I_With_Caron" . #\u+01cf) + ("Latin_Small_Letter_I_With_Caron" . #\u+01d0) + ("Latin_Capital_Letter_O_With_Caron" . #\u+01d1) + ("Latin_Small_Letter_O_With_Caron" . #\u+01d2) + ("Latin_Capital_Letter_U_With_Caron" . #\u+01d3) + ("Latin_Small_Letter_U_With_Caron" . #\u+01d4) + ("Latin_Capital_Letter_U_With_Diaeresis_And_Macron" . #\u+01d5) + ("Latin_Small_Letter_U_With_Diaeresis_And_Macron" . #\u+01d6) + ("Latin_Capital_Letter_U_With_Diaeresis_And_Acute" . #\u+01d7) + ("Latin_Small_Letter_U_With_Diaeresis_And_Acute" . #\u+01d8) + ("Latin_Capital_Letter_U_With_Diaeresis_And_Caron" . #\u+01d9) + ("Latin_Small_Letter_U_With_Diaeresis_And_Caron" . #\u+01da) + ("Latin_Capital_Letter_U_With_Diaeresis_And_Grave" . #\u+01db) + ("Latin_Small_Letter_U_With_Diaeresis_And_Grave" . #\u+01dc) + ("Latin_Small_Letter_Turned_E" . #\u+01dd) + ("Latin_Capital_Letter_A_With_Diaeresis_And_Macron" . #\u+01de) + ("Latin_Small_Letter_A_With_Diaeresis_And_Macron" . #\u+01df) + ("Latin_Capital_Letter_A_With_Dot_Above_And_Macron" . #\u+01e0) + ("Latin_Small_Letter_A_With_Dot_Above_And_Macron" . #\u+01e1) + ("Latin_Capital_Letter_Ae_With_Macron" . #\u+01e2) + ("Latin_Small_Letter_Ae_With_Macron" . #\u+01e3) + ("Latin_Capital_Letter_G_With_Stroke" . #\u+01e4) + ("Latin_Small_Letter_G_With_Stroke" . #\u+01e5) + ("Latin_Capital_Letter_G_With_Caron" . #\u+01e6) + ("Latin_Small_Letter_G_With_Caron" . #\u+01e7) + ("Latin_Capital_Letter_K_With_Caron" . #\u+01e8) + ("Latin_Small_Letter_K_With_Caron" . #\u+01e9) + ("Latin_Capital_Letter_O_With_Ogonek" . #\u+01ea) + ("Latin_Small_Letter_O_With_Ogonek" . #\u+01eb) + ("Latin_Capital_Letter_O_With_Ogonek_And_Macron" . #\u+01ec) + ("Latin_Small_Letter_O_With_Ogonek_And_Macron" . #\u+01ed) + ("Latin_Capital_Letter_Ezh_With_Caron" . #\u+01ee) + ("Latin_Small_Letter_Ezh_With_Caron" . #\u+01ef) + ("Latin_Small_Letter_J_With_Caron" . #\u+01f0) + ("Latin_Capital_Letter_Dz" . #\u+01f1) + ("Latin_Capital_Letter_D_With_Small_Letter_Z" . #\u+01f2) + ("Latin_Small_Letter_Dz" . #\u+01f3) + ("Latin_Capital_Letter_G_With_Acute" . #\u+01f4) + ("Latin_Small_Letter_G_With_Acute" . #\u+01f5) + ("Latin_Capital_Letter_Hwair" . #\u+01f6) + ("Latin_Capital_Letter_Wynn" . #\u+01f7) + ("Latin_Capital_Letter_N_With_Grave" . #\u+01f8) + ("Latin_Small_Letter_N_With_Grave" . #\u+01f9) + ("Latin_Capital_Letter_A_With_Ring_Above_And_Acute" . #\u+01fa) + ("Latin_Small_Letter_A_With_Ring_Above_And_Acute" . #\u+01fb) + ("Latin_Capital_Letter_Ae_With_Acute" . #\u+01fc) + ("Latin_Small_Letter_Ae_With_Acute" . #\u+01fd) + ("Latin_Capital_Letter_O_With_Stroke_And_Acute" . #\u+01fe) + ("Latin_Small_Letter_O_With_Stroke_And_Acute" . #\u+01ff) + ("Latin_Capital_Letter_A_With_Double_Grave" . #\u+0200) + ("Latin_Small_Letter_A_With_Double_Grave" . #\u+0201) + ("Latin_Capital_Letter_A_With_Inverted_Breve" . #\u+0202) + ("Latin_Small_Letter_A_With_Inverted_Breve" . #\u+0203) + ("Latin_Capital_Letter_E_With_Double_Grave" . #\u+0204) + ("Latin_Small_Letter_E_With_Double_Grave" . #\u+0205) + ("Latin_Capital_Letter_E_With_Inverted_Breve" . #\u+0206) + ("Latin_Small_Letter_E_With_Inverted_Breve" . #\u+0207) + ("Latin_Capital_Letter_I_With_Double_Grave" . #\u+0208) + ("Latin_Small_Letter_I_With_Double_Grave" . #\u+0209) + ("Latin_Capital_Letter_I_With_Inverted_Breve" . #\u+020a) + ("Latin_Small_Letter_I_With_Inverted_Breve" . #\u+020b) + ("Latin_Capital_Letter_O_With_Double_Grave" . #\u+020c) + ("Latin_Small_Letter_O_With_Double_Grave" . #\u+020d) + ("Latin_Capital_Letter_O_With_Inverted_Breve" . #\u+020e) + ("Latin_Small_Letter_O_With_Inverted_Breve" . #\u+020f) + ("Latin_Capital_Letter_R_With_Double_Grave" . #\u+0210) + ("Latin_Small_Letter_R_With_Double_Grave" . #\u+0211) + ("Latin_Capital_Letter_R_With_Inverted_Breve" . #\u+0212) + ("Latin_Small_Letter_R_With_Inverted_Breve" . #\u+0213) + ("Latin_Capital_Letter_U_With_Double_Grave" . #\u+0214) + ("Latin_Small_Letter_U_With_Double_Grave" . #\u+0215) + ("Latin_Capital_Letter_U_With_Inverted_Breve" . #\u+0216) + ("Latin_Small_Letter_U_With_Inverted_Breve" . #\u+0217) + ("Latin_Capital_Letter_S_With_Comma_Below" . #\u+0218) + ("Latin_Small_Letter_S_With_Comma_Below" . #\u+0219) + ("Latin_Capital_Letter_T_With_Comma_Below" . #\u+021a) + ("Latin_Small_Letter_T_With_Comma_Below" . #\u+021b) + ("Latin_Capital_Letter_Yogh" . #\u+021c) + ("Latin_Small_Letter_Yogh" . #\u+021d) + ("Latin_Capital_Letter_H_With_Caron" . #\u+021e) + ("Latin_Small_Letter_H_With_Caron" . #\u+021f) + ("Latin_Capital_Letter_N_With_Long_Right_Leg" . #\u+0220) + ("Latin_Small_Letter_D_With_Curl" . #\u+0221) + ("Latin_Capital_Letter_Ou" . #\u+0222) + ("Latin_Small_Letter_Ou" . #\u+0223) + ("Latin_Capital_Letter_Z_With_Hook" . #\u+0224) + ("Latin_Small_Letter_Z_With_Hook" . #\u+0225) + ("Latin_Capital_Letter_A_With_Dot_Above" . #\u+0226) + ("Latin_Small_Letter_A_With_Dot_Above" . #\u+0227) + ("Latin_Capital_Letter_E_With_Cedilla" . #\u+0228) + ("Latin_Small_Letter_E_With_Cedilla" . #\u+0229) + ("Latin_Capital_Letter_O_With_Diaeresis_And_Macron" . #\u+022a) + ("Latin_Small_Letter_O_With_Diaeresis_And_Macron" . #\u+022b) + ("Latin_Capital_Letter_O_With_Tilde_And_Macron" . #\u+022c) + ("Latin_Small_Letter_O_With_Tilde_And_Macron" . #\u+022d) + ("Latin_Capital_Letter_O_With_Dot_Above" . #\u+022e) + ("Latin_Small_Letter_O_With_Dot_Above" . #\u+022f) + ("Latin_Capital_Letter_O_With_Dot_Above_And_Macron" . #\u+0230) + ("Latin_Small_Letter_O_With_Dot_Above_And_Macron" . #\u+0231) + ("Latin_Capital_Letter_Y_With_Macron" . #\u+0232) + ("Latin_Small_Letter_Y_With_Macron" . #\u+0233) + ("Latin_Small_Letter_L_With_Curl" . #\u+0234) + ("Latin_Small_Letter_N_With_Curl" . #\u+0235) + ("Latin_Small_Letter_T_With_Curl" . #\u+0236) + ("Latin_Small_Letter_Dotless_J" . #\u+0237) + ("Latin_Small_Letter_Db_Digraph" . #\u+0238) + ("Latin_Small_Letter_Qp_Digraph" . #\u+0239) + ("Latin_Capital_Letter_A_With_Stroke" . #\u+023a) + ("Latin_Capital_Letter_C_With_Stroke" . #\u+023b) + ("Latin_Small_Letter_C_With_Stroke" . #\u+023c) + ("Latin_Capital_Letter_L_With_Bar" . #\u+023d) + ("Latin_Capital_Letter_T_With_Diagonal_Stroke" . #\u+023e) + ("Latin_Small_Letter_S_With_Swash_Tail" . #\u+023f) + ("Latin_Small_Letter_Z_With_Swash_Tail" . #\u+0240) + ("Latin_Capital_Letter_Glottal_Stop" . #\u+0241) + ("Latin_Small_Letter_Glottal_Stop" . #\u+0242) + ("Latin_Capital_Letter_B_With_Stroke" . #\u+0243) + ("Latin_Capital_Letter_U_Bar" . #\u+0244) + ("Latin_Capital_Letter_Turned_V" . #\u+0245) + ("Latin_Capital_Letter_E_With_Stroke" . #\u+0246) + ("Latin_Small_Letter_E_With_Stroke" . #\u+0247) + ("Latin_Capital_Letter_J_With_Stroke" . #\u+0248) + ("Latin_Small_Letter_J_With_Stroke" . #\u+0249) + ("Latin_Capital_Letter_Small_Q_With_Hook_Tail" . #\u+024a) + ("Latin_Small_Letter_Q_With_Hook_Tail" . #\u+024b) + ("Latin_Capital_Letter_R_With_Stroke" . #\u+024c) + ("Latin_Small_Letter_R_With_Stroke" . #\u+024d) + ("Latin_Capital_Letter_Y_With_Stroke" . #\u+024e) + ("Latin_Small_Letter_Y_With_Stroke" . #\u+024f) + ("Latin_Small_Letter_Turned_A" . #\u+0250) + ("Latin_Small_Letter_Alpha" . #\u+0251) + ("Latin_Small_Letter_Turned_Alpha" . #\u+0252) + ("Latin_Small_Letter_B_With_Hook" . #\u+0253) + ("Latin_Small_Letter_Open_O" . #\u+0254) + ("Latin_Small_Letter_C_With_Curl" . #\u+0255) + ("Latin_Small_Letter_D_With_Tail" . #\u+0256) + ("Latin_Small_Letter_D_With_Hook" . #\u+0257) + ("Latin_Small_Letter_Reversed_E" . #\u+0258) + ("Latin_Small_Letter_Schwa" . #\u+0259) + ("Latin_Small_Letter_Schwa_With_Hook" . #\u+025a) + ("Latin_Small_Letter_Open_E" . #\u+025b) + ("Latin_Small_Letter_Reversed_Open_E" . #\u+025c) + ("Latin_Small_Letter_Reversed_Open_E_With_Hook" . #\u+025d) + ("Latin_Small_Letter_Closed_Reversed_Open_E" . #\u+025e) + ("Latin_Small_Letter_Dotless_J_With_Stroke" . #\u+025f) + ("Latin_Small_Letter_G_With_Hook" . #\u+0260) + ("Latin_Small_Letter_Script_G" . #\u+0261) + ("Latin_Letter_Small_Capital_G" . #\u+0262) + ("Latin_Small_Letter_Gamma" . #\u+0263) + ("Latin_Small_Letter_Rams_Horn" . #\u+0264) + ("Latin_Small_Letter_Turned_H" . #\u+0265) + ("Latin_Small_Letter_H_With_Hook" . #\u+0266) + ("Latin_Small_Letter_Heng_With_Hook" . #\u+0267) + ("Latin_Small_Letter_I_With_Stroke" . #\u+0268) + ("Latin_Small_Letter_Iota" . #\u+0269) + ("Latin_Letter_Small_Capital_I" . #\u+026a) + ("Latin_Small_Letter_L_With_Middle_Tilde" . #\u+026b) + ("Latin_Small_Letter_L_With_Belt" . #\u+026c) + ("Latin_Small_Letter_L_With_Retroflex_Hook" . #\u+026d) + ("Latin_Small_Letter_Lezh" . #\u+026e) + ("Latin_Small_Letter_Turned_M" . #\u+026f) + ("Latin_Small_Letter_Turned_M_With_Long_Leg" . #\u+0270) + ("Latin_Small_Letter_M_With_Hook" . #\u+0271) + ("Latin_Small_Letter_N_With_Left_Hook" . #\u+0272) + ("Latin_Small_Letter_N_With_Retroflex_Hook" . #\u+0273) + ("Latin_Letter_Small_Capital_N" . #\u+0274) + ("Latin_Small_Letter_Barred_O" . #\u+0275) + ("Latin_Letter_Small_Capital_Oe" . #\u+0276) + ("Latin_Small_Letter_Closed_Omega" . #\u+0277) + ("Latin_Small_Letter_Phi" . #\u+0278) + ("Latin_Small_Letter_Turned_R" . #\u+0279) + ("Latin_Small_Letter_Turned_R_With_Long_Leg" . #\u+027a) + ("Latin_Small_Letter_Turned_R_With_Hook" . #\u+027b) + ("Latin_Small_Letter_R_With_Long_Leg" . #\u+027c) + ("Latin_Small_Letter_R_With_Tail" . #\u+027d) + ("Latin_Small_Letter_R_With_Fishhook" . #\u+027e) + ("Latin_Small_Letter_Reversed_R_With_Fishhook" . #\u+027f) + ("Latin_Letter_Small_Capital_R" . #\u+0280) + ("Latin_Letter_Small_Capital_Inverted_R" . #\u+0281) + ("Latin_Small_Letter_S_With_Hook" . #\u+0282) + ("Latin_Small_Letter_Esh" . #\u+0283) + ("Latin_Small_Letter_Dotless_J_With_Stroke_And_Hook" . #\u+0284) + ("Latin_Small_Letter_Squat_Reversed_Esh" . #\u+0285) + ("Latin_Small_Letter_Esh_With_Curl" . #\u+0286) + ("Latin_Small_Letter_Turned_T" . #\u+0287) + ("Latin_Small_Letter_T_With_Retroflex_Hook" . #\u+0288) + ("Latin_Small_Letter_U_Bar" . #\u+0289) + ("Latin_Small_Letter_Upsilon" . #\u+028a) + ("Latin_Small_Letter_V_With_Hook" . #\u+028b) + ("Latin_Small_Letter_Turned_V" . #\u+028c) + ("Latin_Small_Letter_Turned_W" . #\u+028d) + ("Latin_Small_Letter_Turned_Y" . #\u+028e) + ("Latin_Letter_Small_Capital_Y" . #\u+028f) + ("Latin_Small_Letter_Z_With_Retroflex_Hook" . #\u+0290) + ("Latin_Small_Letter_Z_With_Curl" . #\u+0291) + ("Latin_Small_Letter_Ezh" . #\u+0292) + ("Latin_Small_Letter_Ezh_With_Curl" . #\u+0293) + ("Latin_Letter_Glottal_Stop" . #\u+0294) + ("Latin_Letter_Pharyngeal_Voiced_Fricative" . #\u+0295) + ("Latin_Letter_Inverted_Glottal_Stop" . #\u+0296) + ("Latin_Letter_Stretched_C" . #\u+0297) + ("Latin_Letter_Bilabial_Click" . #\u+0298) + ("Latin_Letter_Small_Capital_B" . #\u+0299) + ("Latin_Small_Letter_Closed_Open_E" . #\u+029a) + ("Latin_Letter_Small_Capital_G_With_Hook" . #\u+029b) + ("Latin_Letter_Small_Capital_H" . #\u+029c) + ("Latin_Small_Letter_J_With_Crossed-Tail" . #\u+029d) + ("Latin_Small_Letter_Turned_K" . #\u+029e) + ("Latin_Letter_Small_Capital_L" . #\u+029f) + ("Latin_Small_Letter_Q_With_Hook" . #\u+02a0) + ("Latin_Letter_Glottal_Stop_With_Stroke" . #\u+02a1) + ("Latin_Letter_Reversed_Glottal_Stop_With_Stroke" . #\u+02a2) + ("Latin_Small_Letter_Dz_Digraph" . #\u+02a3) + ("Latin_Small_Letter_Dezh_Digraph" . #\u+02a4) + ("Latin_Small_Letter_Dz_Digraph_With_Curl" . #\u+02a5) + ("Latin_Small_Letter_Ts_Digraph" . #\u+02a6) + ("Latin_Small_Letter_Tesh_Digraph" . #\u+02a7) + ("Latin_Small_Letter_Tc_Digraph_With_Curl" . #\u+02a8) + ("Latin_Small_Letter_Feng_Digraph" . #\u+02a9) + ("Latin_Small_Letter_Ls_Digraph" . #\u+02aa) + ("Latin_Small_Letter_Lz_Digraph" . #\u+02ab) + ("Latin_Letter_Bilabial_Percussive" . #\u+02ac) + ("Latin_Letter_Bidental_Percussive" . #\u+02ad) + ("Latin_Small_Letter_Turned_H_With_Fishhook" . #\u+02ae) + ("Latin_Small_Letter_Turned_H_With_Fishhook_And_Tail" . #\u+02af) + ("Modifier_Letter_Small_H" . #\u+02b0) + ("Modifier_Letter_Small_H_With_Hook" . #\u+02b1) + ("Modifier_Letter_Small_J" . #\u+02b2) + ("Modifier_Letter_Small_R" . #\u+02b3) + ("Modifier_Letter_Small_Turned_R" . #\u+02b4) + ("Modifier_Letter_Small_Turned_R_With_Hook" . #\u+02b5) + ("Modifier_Letter_Small_Capital_Inverted_R" . #\u+02b6) + ("Modifier_Letter_Small_W" . #\u+02b7) + ("Modifier_Letter_Small_Y" . #\u+02b8) + ("Modifier_Letter_Prime" . #\u+02b9) + ("Modifier_Letter_Double_Prime" . #\u+02ba) + ("Modifier_Letter_Turned_Comma" . #\u+02bb) + ("Modifier_Letter_Apostrophe" . #\u+02bc) + ("Modifier_Letter_Reversed_Comma" . #\u+02bd) + ("Modifier_Letter_Right_Half_Ring" . #\u+02be) + ("Modifier_Letter_Left_Half_Ring" . #\u+02bf) + ("Modifier_Letter_Glottal_Stop" . #\u+02c0) + ("Modifier_Letter_Reversed_Glottal_Stop" . #\u+02c1) + ("Modifier_Letter_Left_Arrowhead" . #\u+02c2) + ("Modifier_Letter_Right_Arrowhead" . #\u+02c3) + ("Modifier_Letter_Up_Arrowhead" . #\u+02c4) + ("Modifier_Letter_Down_Arrowhead" . #\u+02c5) + ("Modifier_Letter_Circumflex_Accent" . #\u+02c6) + ("Caron" . #\u+02c7) + ("Modifier_Letter_Vertical_Line" . #\u+02c8) + ("Modifier_Letter_Macron" . #\u+02c9) + ("Modifier_Letter_Acute_Accent" . #\u+02ca) + ("Modifier_Letter_Grave_Accent" . #\u+02cb) + ("Modifier_Letter_Low_Vertical_Line" . #\u+02cc) + ("Modifier_Letter_Low_Macron" . #\u+02cd) + ("Modifier_Letter_Low_Grave_Accent" . #\u+02ce) + ("Modifier_Letter_Low_Acute_Accent" . #\u+02cf) + ("Modifier_Letter_Triangular_Colon" . #\u+02d0) + ("Modifier_Letter_Half_Triangular_Colon" . #\u+02d1) + ("Modifier_Letter_Centred_Right_Half_Ring" . #\u+02d2) + ("Modifier_Letter_Centred_Left_Half_Ring" . #\u+02d3) + ("Modifier_Letter_Up_Tack" . #\u+02d4) + ("Modifier_Letter_Down_Tack" . #\u+02d5) + ("Modifier_Letter_Plus_Sign" . #\u+02d6) + ("Modifier_Letter_Minus_Sign" . #\u+02d7) + ("Breve" . #\u+02d8) + ("Dot_Above" . #\u+02d9) + ("Ring_Above" . #\u+02da) + ("Ogonek" . #\u+02db) + ("Small_Tilde" . #\u+02dc) + ("Double_Acute_Accent" . #\u+02dd) + ("Modifier_Letter_Rhotic_Hook" . #\u+02de) + ("Modifier_Letter_Cross_Accent" . #\u+02df) + ("Modifier_Letter_Small_Gamma" . #\u+02e0) + ("Modifier_Letter_Small_L" . #\u+02e1) + ("Modifier_Letter_Small_S" . #\u+02e2) + ("Modifier_Letter_Small_X" . #\u+02e3) + ("Modifier_Letter_Small_Reversed_Glottal_Stop" . #\u+02e4) + ("Modifier_Letter_Extra-High_Tone_Bar" . #\u+02e5) + ("Modifier_Letter_High_Tone_Bar" . #\u+02e6) + ("Modifier_Letter_Mid_Tone_Bar" . #\u+02e7) + ("Modifier_Letter_Low_Tone_Bar" . #\u+02e8) + ("Modifier_Letter_Extra-Low_Tone_Bar" . #\u+02e9) + ("Modifier_Letter_Yin_Departing_Tone_Mark" . #\u+02ea) + ("Modifier_Letter_Yang_Departing_Tone_Mark" . #\u+02eb) + ("Modifier_Letter_Voicing" . #\u+02ec) + ("Modifier_Letter_Unaspirated" . #\u+02ed) + ("Modifier_Letter_Double_Apostrophe" . #\u+02ee) + ("Modifier_Letter_Low_Down_Arrowhead" . #\u+02ef) + ("Modifier_Letter_Low_Up_Arrowhead" . #\u+02f0) + ("Modifier_Letter_Low_Left_Arrowhead" . #\u+02f1) + ("Modifier_Letter_Low_Right_Arrowhead" . #\u+02f2) + ("Modifier_Letter_Low_Ring" . #\u+02f3) + ("Modifier_Letter_Middle_Grave_Accent" . #\u+02f4) + ("Modifier_Letter_Middle_Double_Grave_Accent" . #\u+02f5) + ("Modifier_Letter_Middle_Double_Acute_Accent" . #\u+02f6) + ("Modifier_Letter_Low_Tilde" . #\u+02f7) + ("Modifier_Letter_Raised_Colon" . #\u+02f8) + ("Modifier_Letter_Begin_High_Tone" . #\u+02f9) + ("Modifier_Letter_End_High_Tone" . #\u+02fa) + ("Modifier_Letter_Begin_Low_Tone" . #\u+02fb) + ("Modifier_Letter_End_Low_Tone" . #\u+02fc) + ("Modifier_Letter_Shelf" . #\u+02fd) + ("Modifier_Letter_Open_Shelf" . #\u+02fe) + ("Modifier_Letter_Low_Left_Arrow" . #\u+02ff) + ("Combining_Grave_Accent" . #\u+0300) + ("Combining_Acute_Accent" . #\u+0301) + ("Combining_Circumflex_Accent" . #\u+0302) + ("Combining_Tilde" . #\u+0303) + ("Combining_Macron" . #\u+0304) + ("Combining_Overline" . #\u+0305) + ("Combining_Breve" . #\u+0306) + ("Combining_Dot_Above" . #\u+0307) + ("Combining_Diaeresis" . #\u+0308) + ("Combining_Hook_Above" . #\u+0309) + ("Combining_Ring_Above" . #\u+030a) + ("Combining_Double_Acute_Accent" . #\u+030b) + ("Combining_Caron" . #\u+030c) + ("Combining_Vertical_Line_Above" . #\u+030d) + ("Combining_Double_Vertical_Line_Above" . #\u+030e) + ("Combining_Double_Grave_Accent" . #\u+030f) + ("Combining_Candrabindu" . #\u+0310) + ("Combining_Inverted_Breve" . #\u+0311) + ("Combining_Turned_Comma_Above" . #\u+0312) + ("Combining_Comma_Above" . #\u+0313) + ("Combining_Reversed_Comma_Above" . #\u+0314) + ("Combining_Comma_Above_Right" . #\u+0315) + ("Combining_Grave_Accent_Below" . #\u+0316) + ("Combining_Acute_Accent_Below" . #\u+0317) + ("Combining_Left_Tack_Below" . #\u+0318) + ("Combining_Right_Tack_Below" . #\u+0319) + ("Combining_Left_Angle_Above" . #\u+031a) + ("Combining_Horn" . #\u+031b) + ("Combining_Left_Half_Ring_Below" . #\u+031c) + ("Combining_Up_Tack_Below" . #\u+031d) + ("Combining_Down_Tack_Below" . #\u+031e) + ("Combining_Plus_Sign_Below" . #\u+031f) + ("Combining_Minus_Sign_Below" . #\u+0320) + ("Combining_Palatalized_Hook_Below" . #\u+0321) + ("Combining_Retroflex_Hook_Below" . #\u+0322) + ("Combining_Dot_Below" . #\u+0323) + ("Combining_Diaeresis_Below" . #\u+0324) + ("Combining_Ring_Below" . #\u+0325) + ("Combining_Comma_Below" . #\u+0326) + ("Combining_Cedilla" . #\u+0327) + ("Combining_Ogonek" . #\u+0328) + ("Combining_Vertical_Line_Below" . #\u+0329) + ("Combining_Bridge_Below" . #\u+032a) + ("Combining_Inverted_Double_Arch_Below" . #\u+032b) + ("Combining_Caron_Below" . #\u+032c) + ("Combining_Circumflex_Accent_Below" . #\u+032d) + ("Combining_Breve_Below" . #\u+032e) + ("Combining_Inverted_Breve_Below" . #\u+032f) + ("Combining_Tilde_Below" . #\u+0330) + ("Combining_Macron_Below" . #\u+0331) + ("Combining_Low_Line" . #\u+0332) + ("Combining_Double_Low_Line" . #\u+0333) + ("Combining_Tilde_Overlay" . #\u+0334) + ("Combining_Short_Stroke_Overlay" . #\u+0335) + ("Combining_Long_Stroke_Overlay" . #\u+0336) + ("Combining_Short_Solidus_Overlay" . #\u+0337) + ("Combining_Long_Solidus_Overlay" . #\u+0338) + ("Combining_Right_Half_Ring_Below" . #\u+0339) + ("Combining_Inverted_Bridge_Below" . #\u+033a) + ("Combining_Square_Below" . #\u+033b) + ("Combining_Seagull_Below" . #\u+033c) + ("Combining_X_Above" . #\u+033d) + ("Combining_Vertical_Tilde" . #\u+033e) + ("Combining_Double_Overline" . #\u+033f) + ("Combining_Grave_Tone_Mark" . #\u+0340) + ("Combining_Acute_Tone_Mark" . #\u+0341) + ("Combining_Greek_Perispomeni" . #\u+0342) + ("Combining_Greek_Koronis" . #\u+0343) + ("Combining_Greek_Dialytika_Tonos" . #\u+0344) + ("Combining_Greek_Ypogegrammeni" . #\u+0345) + ("Combining_Bridge_Above" . #\u+0346) + ("Combining_Equals_Sign_Below" . #\u+0347) + ("Combining_Double_Vertical_Line_Below" . #\u+0348) + ("Combining_Left_Angle_Below" . #\u+0349) + ("Combining_Not_Tilde_Above" . #\u+034a) + ("Combining_Homothetic_Above" . #\u+034b) + ("Combining_Almost_Equal_To_Above" . #\u+034c) + ("Combining_Left_Right_Arrow_Below" . #\u+034d) + ("Combining_Upwards_Arrow_Below" . #\u+034e) + ("Combining_Grapheme_Joiner" . #\u+034f) + ("Combining_Right_Arrowhead_Above" . #\u+0350) + ("Combining_Left_Half_Ring_Above" . #\u+0351) + ("Combining_Fermata" . #\u+0352) + ("Combining_X_Below" . #\u+0353) + ("Combining_Left_Arrowhead_Below" . #\u+0354) + ("Combining_Right_Arrowhead_Below" . #\u+0355) + ("Combining_Right_Arrowhead_And_Up_Arrowhead_Below" . #\u+0356) + ("Combining_Right_Half_Ring_Above" . #\u+0357) + ("Combining_Dot_Above_Right" . #\u+0358) + ("Combining_Asterisk_Below" . #\u+0359) + ("Combining_Double_Ring_Below" . #\u+035a) + ("Combining_Zigzag_Above" . #\u+035b) + ("Combining_Double_Breve_Below" . #\u+035c) + ("Combining_Double_Breve" . #\u+035d) + ("Combining_Double_Macron" . #\u+035e) + ("Combining_Double_Macron_Below" . #\u+035f) + ("Combining_Double_Tilde" . #\u+0360) + ("Combining_Double_Inverted_Breve" . #\u+0361) + ("Combining_Double_Rightwards_Arrow_Below" . #\u+0362) + ("Combining_Latin_Small_Letter_A" . #\u+0363) + ("Combining_Latin_Small_Letter_E" . #\u+0364) + ("Combining_Latin_Small_Letter_I" . #\u+0365) + ("Combining_Latin_Small_Letter_O" . #\u+0366) + ("Combining_Latin_Small_Letter_U" . #\u+0367) + ("Combining_Latin_Small_Letter_C" . #\u+0368) + ("Combining_Latin_Small_Letter_D" . #\u+0369) + ("Combining_Latin_Small_Letter_H" . #\u+036a) + ("Combining_Latin_Small_Letter_M" . #\u+036b) + ("Combining_Latin_Small_Letter_R" . #\u+036c) + ("Combining_Latin_Small_Letter_T" . #\u+036d) + ("Combining_Latin_Small_Letter_V" . #\u+036e) + ("Combining_Latin_Small_Letter_X" . #\u+036f) + ("Greek_Numeral_Sign" . #\u+0374) + ("Greek_Lower_Numeral_Sign" . #\u+0375) + ("Greek_Ypogegrammeni" . #\u+037a) + ("Greek_Small_Reversed_Lunate_Sigma_Symbol" . #\u+037b) + ("Greek_Small_Dotted_Lunate_Sigma_Symbol" . #\u+037c) + ("Greek_Small_Reversed_Dotted_Lunate_Sigma_Symbol" . #\u+037d) + ("Greek_Question_Mark" . #\u+037e) + ("Greek_Tonos" . #\u+0384) + ("Greek_Dialytika_Tonos" . #\u+0385) + ("Greek_Capital_Letter_Alpha_With_Tonos" . #\u+0386) + ("Greek_Ano_Teleia" . #\u+0387) + ("Greek_Capital_Letter_Epsilon_With_Tonos" . #\u+0388) + ("Greek_Capital_Letter_Eta_With_Tonos" . #\u+0389) + ("Greek_Capital_Letter_Iota_With_Tonos" . #\u+038a) + ("Greek_Capital_Letter_Omicron_With_Tonos" . #\u+038c) + ("Greek_Capital_Letter_Upsilon_With_Tonos" . #\u+038e) + ("Greek_Capital_Letter_Omega_With_Tonos" . #\u+038f) + ("Greek_Small_Letter_Iota_With_Dialytika_And_Tonos" . #\u+0390) + ("Greek_Capital_Letter_Alpha" . #\u+0391) + ("Greek_Capital_Letter_Beta" . #\u+0392) + ("Greek_Capital_Letter_Gamma" . #\u+0393) + ("Greek_Capital_Letter_Delta" . #\u+0394) + ("Greek_Capital_Letter_Epsilon" . #\u+0395) + ("Greek_Capital_Letter_Zeta" . #\u+0396) + ("Greek_Capital_Letter_Eta" . #\u+0397) + ("Greek_Capital_Letter_Theta" . #\u+0398) + ("Greek_Capital_Letter_Iota" . #\u+0399) + ("Greek_Capital_Letter_Kappa" . #\u+039a) + ("Greek_Capital_Letter_Lamda" . #\u+039b) + ("Greek_Capital_Letter_Mu" . #\u+039c) + ("Greek_Capital_Letter_Nu" . #\u+039d) + ("Greek_Capital_Letter_Xi" . #\u+039e) + ("Greek_Capital_Letter_Omicron" . #\u+039f) + ("Greek_Capital_Letter_Pi" . #\u+03a0) + ("Greek_Capital_Letter_Rho" . #\u+03a1) + ("Greek_Capital_Letter_Sigma" . #\u+03a3) + ("Greek_Capital_Letter_Tau" . #\u+03a4) + ("Greek_Capital_Letter_Upsilon" . #\u+03a5) + ("Greek_Capital_Letter_Phi" . #\u+03a6) + ("Greek_Capital_Letter_Chi" . #\u+03a7) + ("Greek_Capital_Letter_Psi" . #\u+03a8) + ("Greek_Capital_Letter_Omega" . #\u+03a9) + ("Greek_Capital_Letter_Iota_With_Dialytika" . #\u+03aa) + ("Greek_Capital_Letter_Upsilon_With_Dialytika" . #\u+03ab) + ("Greek_Small_Letter_Alpha_With_Tonos" . #\u+03ac) + ("Greek_Small_Letter_Epsilon_With_Tonos" . #\u+03ad) + ("Greek_Small_Letter_Eta_With_Tonos" . #\u+03ae) + ("Greek_Small_Letter_Iota_With_Tonos" . #\u+03af) + ("Greek_Small_Letter_Upsilon_With_Dialytika_And_Tonos" . #\u+03b0) + ("Greek_Small_Letter_Alpha" . #\u+03b1) + ("Greek_Small_Letter_Beta" . #\u+03b2) + ("Greek_Small_Letter_Gamma" . #\u+03b3) + ("Greek_Small_Letter_Delta" . #\u+03b4) + ("Greek_Small_Letter_Epsilon" . #\u+03b5) + ("Greek_Small_Letter_Zeta" . #\u+03b6) + ("Greek_Small_Letter_Eta" . #\u+03b7) + ("Greek_Small_Letter_Theta" . #\u+03b8) + ("Greek_Small_Letter_Iota" . #\u+03b9) + ("Greek_Small_Letter_Kappa" . #\u+03ba) + ("Greek_Small_Letter_Lamda" . #\u+03bb) + ("Greek_Small_Letter_Mu" . #\u+03bc) + ("Greek_Small_Letter_Nu" . #\u+03bd) + ("Greek_Small_Letter_Xi" . #\u+03be) + ("Greek_Small_Letter_Omicron" . #\u+03bf) + ("Greek_Small_Letter_Pi" . #\u+03c0) + ("Greek_Small_Letter_Rho" . #\u+03c1) + ("Greek_Small_Letter_Final_Sigma" . #\u+03c2) + ("Greek_Small_Letter_Sigma" . #\u+03c3) + ("Greek_Small_Letter_Tau" . #\u+03c4) + ("Greek_Small_Letter_Upsilon" . #\u+03c5) + ("Greek_Small_Letter_Phi" . #\u+03c6) + ("Greek_Small_Letter_Chi" . #\u+03c7) + ("Greek_Small_Letter_Psi" . #\u+03c8) + ("Greek_Small_Letter_Omega" . #\u+03c9) + ("Greek_Small_Letter_Iota_With_Dialytika" . #\u+03ca) + ("Greek_Small_Letter_Upsilon_With_Dialytika" . #\u+03cb) + ("Greek_Small_Letter_Omicron_With_Tonos" . #\u+03cc) + ("Greek_Small_Letter_Upsilon_With_Tonos" . #\u+03cd) + ("Greek_Small_Letter_Omega_With_Tonos" . #\u+03ce) + ("Greek_Beta_Symbol" . #\u+03d0) + ("Greek_Theta_Symbol" . #\u+03d1) + ("Greek_Upsilon_With_Hook_Symbol" . #\u+03d2) + ("Greek_Upsilon_With_Acute_And_Hook_Symbol" . #\u+03d3) + ("Greek_Upsilon_With_Diaeresis_And_Hook_Symbol" . #\u+03d4) + ("Greek_Phi_Symbol" . #\u+03d5) + ("Greek_Pi_Symbol" . #\u+03d6) + ("Greek_Kai_Symbol" . #\u+03d7) + ("Greek_Letter_Archaic_Koppa" . #\u+03d8) + ("Greek_Small_Letter_Archaic_Koppa" . #\u+03d9) + ("Greek_Letter_Stigma" . #\u+03da) + ("Greek_Small_Letter_Stigma" . #\u+03db) + ("Greek_Letter_Digamma" . #\u+03dc) + ("Greek_Small_Letter_Digamma" . #\u+03dd) + ("Greek_Letter_Koppa" . #\u+03de) + ("Greek_Small_Letter_Koppa" . #\u+03df) + ("Greek_Letter_Sampi" . #\u+03e0) + ("Greek_Small_Letter_Sampi" . #\u+03e1) + ("Coptic_Capital_Letter_Shei" . #\u+03e2) + ("Coptic_Small_Letter_Shei" . #\u+03e3) + ("Coptic_Capital_Letter_Fei" . #\u+03e4) + ("Coptic_Small_Letter_Fei" . #\u+03e5) + ("Coptic_Capital_Letter_Khei" . #\u+03e6) + ("Coptic_Small_Letter_Khei" . #\u+03e7) + ("Coptic_Capital_Letter_Hori" . #\u+03e8) + ("Coptic_Small_Letter_Hori" . #\u+03e9) + ("Coptic_Capital_Letter_Gangia" . #\u+03ea) + ("Coptic_Small_Letter_Gangia" . #\u+03eb) + ("Coptic_Capital_Letter_Shima" . #\u+03ec) + ("Coptic_Small_Letter_Shima" . #\u+03ed) + ("Coptic_Capital_Letter_Dei" . #\u+03ee) + ("Coptic_Small_Letter_Dei" . #\u+03ef) + ("Greek_Kappa_Symbol" . #\u+03f0) + ("Greek_Rho_Symbol" . #\u+03f1) + ("Greek_Lunate_Sigma_Symbol" . #\u+03f2) + ("Greek_Letter_Yot" . #\u+03f3) + ("Greek_Capital_Theta_Symbol" . #\u+03f4) + ("Greek_Lunate_Epsilon_Symbol" . #\u+03f5) + ("Greek_Reversed_Lunate_Epsilon_Symbol" . #\u+03f6) + ("Greek_Capital_Letter_Sho" . #\u+03f7) + ("Greek_Small_Letter_Sho" . #\u+03f8) + ("Greek_Capital_Lunate_Sigma_Symbol" . #\u+03f9) + ("Greek_Capital_Letter_San" . #\u+03fa) + ("Greek_Small_Letter_San" . #\u+03fb) + ("Greek_Rho_With_Stroke_Symbol" . #\u+03fc) + ("Greek_Capital_Reversed_Lunate_Sigma_Symbol" . #\u+03fd) + ("Greek_Capital_Dotted_Lunate_Sigma_Symbol" . #\u+03fe) + ("Greek_Capital_Reversed_Dotted_Lunate_Sigma_Symbol" . #\u+03ff) + ("Cyrillic_Capital_Letter_Ie_With_Grave" . #\u+0400) + ("Cyrillic_Capital_Letter_Io" . #\u+0401) + ("Cyrillic_Capital_Letter_Dje" . #\u+0402) + ("Cyrillic_Capital_Letter_Gje" . #\u+0403) + ("Cyrillic_Capital_Letter_Ukrainian_Ie" . #\u+0404) + ("Cyrillic_Capital_Letter_Dze" . #\u+0405) + ("Cyrillic_Capital_Letter_Byelorussian-Ukrainian_I" . #\u+0406) + ("Cyrillic_Capital_Letter_Yi" . #\u+0407) + ("Cyrillic_Capital_Letter_Je" . #\u+0408) + ("Cyrillic_Capital_Letter_Lje" . #\u+0409) + ("Cyrillic_Capital_Letter_Nje" . #\u+040a) + ("Cyrillic_Capital_Letter_Tshe" . #\u+040b) + ("Cyrillic_Capital_Letter_Kje" . #\u+040c) + ("Cyrillic_Capital_Letter_I_With_Grave" . #\u+040d) + ("Cyrillic_Capital_Letter_Short_U" . #\u+040e) + ("Cyrillic_Capital_Letter_Dzhe" . #\u+040f) + ("Cyrillic_Capital_Letter_A" . #\u+0410) + ("Cyrillic_Capital_Letter_Be" . #\u+0411) + ("Cyrillic_Capital_Letter_Ve" . #\u+0412) + ("Cyrillic_Capital_Letter_Ghe" . #\u+0413) + ("Cyrillic_Capital_Letter_De" . #\u+0414) + ("Cyrillic_Capital_Letter_Ie" . #\u+0415) + ("Cyrillic_Capital_Letter_Zhe" . #\u+0416) + ("Cyrillic_Capital_Letter_Ze" . #\u+0417) + ("Cyrillic_Capital_Letter_I" . #\u+0418) + ("Cyrillic_Capital_Letter_Short_I" . #\u+0419) + ("Cyrillic_Capital_Letter_Ka" . #\u+041a) + ("Cyrillic_Capital_Letter_El" . #\u+041b) + ("Cyrillic_Capital_Letter_Em" . #\u+041c) + ("Cyrillic_Capital_Letter_En" . #\u+041d) + ("Cyrillic_Capital_Letter_O" . #\u+041e) + ("Cyrillic_Capital_Letter_Pe" . #\u+041f) + ("Cyrillic_Capital_Letter_Er" . #\u+0420) + ("Cyrillic_Capital_Letter_Es" . #\u+0421) + ("Cyrillic_Capital_Letter_Te" . #\u+0422) + ("Cyrillic_Capital_Letter_U" . #\u+0423) + ("Cyrillic_Capital_Letter_Ef" . #\u+0424) + ("Cyrillic_Capital_Letter_Ha" . #\u+0425) + ("Cyrillic_Capital_Letter_Tse" . #\u+0426) + ("Cyrillic_Capital_Letter_Che" . #\u+0427) + ("Cyrillic_Capital_Letter_Sha" . #\u+0428) + ("Cyrillic_Capital_Letter_Shcha" . #\u+0429) + ("Cyrillic_Capital_Letter_Hard_Sign" . #\u+042a) + ("Cyrillic_Capital_Letter_Yeru" . #\u+042b) + ("Cyrillic_Capital_Letter_Soft_Sign" . #\u+042c) + ("Cyrillic_Capital_Letter_E" . #\u+042d) + ("Cyrillic_Capital_Letter_Yu" . #\u+042e) + ("Cyrillic_Capital_Letter_Ya" . #\u+042f) + ("Cyrillic_Small_Letter_A" . #\u+0430) + ("Cyrillic_Small_Letter_Be" . #\u+0431) + ("Cyrillic_Small_Letter_Ve" . #\u+0432) + ("Cyrillic_Small_Letter_Ghe" . #\u+0433) + ("Cyrillic_Small_Letter_De" . #\u+0434) + ("Cyrillic_Small_Letter_Ie" . #\u+0435) + ("Cyrillic_Small_Letter_Zhe" . #\u+0436) + ("Cyrillic_Small_Letter_Ze" . #\u+0437) + ("Cyrillic_Small_Letter_I" . #\u+0438) + ("Cyrillic_Small_Letter_Short_I" . #\u+0439) + ("Cyrillic_Small_Letter_Ka" . #\u+043a) + ("Cyrillic_Small_Letter_El" . #\u+043b) + ("Cyrillic_Small_Letter_Em" . #\u+043c) + ("Cyrillic_Small_Letter_En" . #\u+043d) + ("Cyrillic_Small_Letter_O" . #\u+043e) + ("Cyrillic_Small_Letter_Pe" . #\u+043f) + ("Cyrillic_Small_Letter_Er" . #\u+0440) + ("Cyrillic_Small_Letter_Es" . #\u+0441) + ("Cyrillic_Small_Letter_Te" . #\u+0442) + ("Cyrillic_Small_Letter_U" . #\u+0443) + ("Cyrillic_Small_Letter_Ef" . #\u+0444) + ("Cyrillic_Small_Letter_Ha" . #\u+0445) + ("Cyrillic_Small_Letter_Tse" . #\u+0446) + ("Cyrillic_Small_Letter_Che" . #\u+0447) + ("Cyrillic_Small_Letter_Sha" . #\u+0448) + ("Cyrillic_Small_Letter_Shcha" . #\u+0449) + ("Cyrillic_Small_Letter_Hard_Sign" . #\u+044a) + ("Cyrillic_Small_Letter_Yeru" . #\u+044b) + ("Cyrillic_Small_Letter_Soft_Sign" . #\u+044c) + ("Cyrillic_Small_Letter_E" . #\u+044d) + ("Cyrillic_Small_Letter_Yu" . #\u+044e) + ("Cyrillic_Small_Letter_Ya" . #\u+044f) + ("Cyrillic_Small_Letter_Ie_With_Grave" . #\u+0450) + ("Cyrillic_Small_Letter_Io" . #\u+0451) + ("Cyrillic_Small_Letter_Dje" . #\u+0452) + ("Cyrillic_Small_Letter_Gje" . #\u+0453) + ("Cyrillic_Small_Letter_Ukrainian_Ie" . #\u+0454) + ("Cyrillic_Small_Letter_Dze" . #\u+0455) + ("Cyrillic_Small_Letter_Byelorussian-Ukrainian_I" . #\u+0456) + ("Cyrillic_Small_Letter_Yi" . #\u+0457) + ("Cyrillic_Small_Letter_Je" . #\u+0458) + ("Cyrillic_Small_Letter_Lje" . #\u+0459) + ("Cyrillic_Small_Letter_Nje" . #\u+045a) + ("Cyrillic_Small_Letter_Tshe" . #\u+045b) + ("Cyrillic_Small_Letter_Kje" . #\u+045c) + ("Cyrillic_Small_Letter_I_With_Grave" . #\u+045d) + ("Cyrillic_Small_Letter_Short_U" . #\u+045e) + ("Cyrillic_Small_Letter_Dzhe" . #\u+045f) + ("Cyrillic_Capital_Letter_Omega" . #\u+0460) + ("Cyrillic_Small_Letter_Omega" . #\u+0461) + ("Cyrillic_Capital_Letter_Yat" . #\u+0462) + ("Cyrillic_Small_Letter_Yat" . #\u+0463) + ("Cyrillic_Capital_Letter_Iotified_E" . #\u+0464) + ("Cyrillic_Small_Letter_Iotified_E" . #\u+0465) + ("Cyrillic_Capital_Letter_Little_Yus" . #\u+0466) + ("Cyrillic_Small_Letter_Little_Yus" . #\u+0467) + ("Cyrillic_Capital_Letter_Iotified_Little_Yus" . #\u+0468) + ("Cyrillic_Small_Letter_Iotified_Little_Yus" . #\u+0469) + ("Cyrillic_Capital_Letter_Big_Yus" . #\u+046a) + ("Cyrillic_Small_Letter_Big_Yus" . #\u+046b) + ("Cyrillic_Capital_Letter_Iotified_Big_Yus" . #\u+046c) + ("Cyrillic_Small_Letter_Iotified_Big_Yus" . #\u+046d) + ("Cyrillic_Capital_Letter_Ksi" . #\u+046e) + ("Cyrillic_Small_Letter_Ksi" . #\u+046f) + ("Cyrillic_Capital_Letter_Psi" . #\u+0470) + ("Cyrillic_Small_Letter_Psi" . #\u+0471) + ("Cyrillic_Capital_Letter_Fita" . #\u+0472) + ("Cyrillic_Small_Letter_Fita" . #\u+0473) + ("Cyrillic_Capital_Letter_Izhitsa" . #\u+0474) + ("Cyrillic_Small_Letter_Izhitsa" . #\u+0475) + ("Cyrillic_Capital_Letter_Izhitsa_With_Double_Grave_Accent" . #\u+0476) + ("Cyrillic_Small_Letter_Izhitsa_With_Double_Grave_Accent" . #\u+0477) + ("Cyrillic_Capital_Letter_Uk" . #\u+0478) + ("Cyrillic_Small_Letter_Uk" . #\u+0479) + ("Cyrillic_Capital_Letter_Round_Omega" . #\u+047a) + ("Cyrillic_Small_Letter_Round_Omega" . #\u+047b) + ("Cyrillic_Capital_Letter_Omega_With_Titlo" . #\u+047c) + ("Cyrillic_Small_Letter_Omega_With_Titlo" . #\u+047d) + ("Cyrillic_Capital_Letter_Ot" . #\u+047e) + ("Cyrillic_Small_Letter_Ot" . #\u+047f) + ("Cyrillic_Capital_Letter_Koppa" . #\u+0480) + ("Cyrillic_Small_Letter_Koppa" . #\u+0481) + ("Cyrillic_Thousands_Sign" . #\u+0482) + ("Combining_Cyrillic_Titlo" . #\u+0483) + ("Combining_Cyrillic_Palatalization" . #\u+0484) + ("Combining_Cyrillic_Dasia_Pneumata" . #\u+0485) + ("Combining_Cyrillic_Psili_Pneumata" . #\u+0486) + ("Combining_Cyrillic_Hundred_Thousands_Sign" . #\u+0488) + ("Combining_Cyrillic_Millions_Sign" . #\u+0489) + ("Cyrillic_Capital_Letter_Short_I_With_Tail" . #\u+048a) + ("Cyrillic_Small_Letter_Short_I_With_Tail" . #\u+048b) + ("Cyrillic_Capital_Letter_Semisoft_Sign" . #\u+048c) + ("Cyrillic_Small_Letter_Semisoft_Sign" . #\u+048d) + ("Cyrillic_Capital_Letter_Er_With_Tick" . #\u+048e) + ("Cyrillic_Small_Letter_Er_With_Tick" . #\u+048f) + ("Cyrillic_Capital_Letter_Ghe_With_Upturn" . #\u+0490) + ("Cyrillic_Small_Letter_Ghe_With_Upturn" . #\u+0491) + ("Cyrillic_Capital_Letter_Ghe_With_Stroke" . #\u+0492) + ("Cyrillic_Small_Letter_Ghe_With_Stroke" . #\u+0493) + ("Cyrillic_Capital_Letter_Ghe_With_Middle_Hook" . #\u+0494) + ("Cyrillic_Small_Letter_Ghe_With_Middle_Hook" . #\u+0495) + ("Cyrillic_Capital_Letter_Zhe_With_Descender" . #\u+0496) + ("Cyrillic_Small_Letter_Zhe_With_Descender" . #\u+0497) + ("Cyrillic_Capital_Letter_Ze_With_Descender" . #\u+0498) + ("Cyrillic_Small_Letter_Ze_With_Descender" . #\u+0499) + ("Cyrillic_Capital_Letter_Ka_With_Descender" . #\u+049a) + ("Cyrillic_Small_Letter_Ka_With_Descender" . #\u+049b) + ("Cyrillic_Capital_Letter_Ka_With_Vertical_Stroke" . #\u+049c) + ("Cyrillic_Small_Letter_Ka_With_Vertical_Stroke" . #\u+049d) + ("Cyrillic_Capital_Letter_Ka_With_Stroke" . #\u+049e) + ("Cyrillic_Small_Letter_Ka_With_Stroke" . #\u+049f) + ("Cyrillic_Capital_Letter_Bashkir_Ka" . #\u+04a0) + ("Cyrillic_Small_Letter_Bashkir_Ka" . #\u+04a1) + ("Cyrillic_Capital_Letter_En_With_Descender" . #\u+04a2) + ("Cyrillic_Small_Letter_En_With_Descender" . #\u+04a3) + ("Cyrillic_Capital_Ligature_En_Ghe" . #\u+04a4) + ("Cyrillic_Small_Ligature_En_Ghe" . #\u+04a5) + ("Cyrillic_Capital_Letter_Pe_With_Middle_Hook" . #\u+04a6) + ("Cyrillic_Small_Letter_Pe_With_Middle_Hook" . #\u+04a7) + ("Cyrillic_Capital_Letter_Abkhasian_Ha" . #\u+04a8) + ("Cyrillic_Small_Letter_Abkhasian_Ha" . #\u+04a9) + ("Cyrillic_Capital_Letter_Es_With_Descender" . #\u+04aa) + ("Cyrillic_Small_Letter_Es_With_Descender" . #\u+04ab) + ("Cyrillic_Capital_Letter_Te_With_Descender" . #\u+04ac) + ("Cyrillic_Small_Letter_Te_With_Descender" . #\u+04ad) + ("Cyrillic_Capital_Letter_Straight_U" . #\u+04ae) + ("Cyrillic_Small_Letter_Straight_U" . #\u+04af) + ("Cyrillic_Capital_Letter_Straight_U_With_Stroke" . #\u+04b0) + ("Cyrillic_Small_Letter_Straight_U_With_Stroke" . #\u+04b1) + ("Cyrillic_Capital_Letter_Ha_With_Descender" . #\u+04b2) + ("Cyrillic_Small_Letter_Ha_With_Descender" . #\u+04b3) + ("Cyrillic_Capital_Ligature_Te_Tse" . #\u+04b4) + ("Cyrillic_Small_Ligature_Te_Tse" . #\u+04b5) + ("Cyrillic_Capital_Letter_Che_With_Descender" . #\u+04b6) + ("Cyrillic_Small_Letter_Che_With_Descender" . #\u+04b7) + ("Cyrillic_Capital_Letter_Che_With_Vertical_Stroke" . #\u+04b8) + ("Cyrillic_Small_Letter_Che_With_Vertical_Stroke" . #\u+04b9) + ("Cyrillic_Capital_Letter_Shha" . #\u+04ba) + ("Cyrillic_Small_Letter_Shha" . #\u+04bb) + ("Cyrillic_Capital_Letter_Abkhasian_Che" . #\u+04bc) + ("Cyrillic_Small_Letter_Abkhasian_Che" . #\u+04bd) + ("Cyrillic_Capital_Letter_Abkhasian_Che_With_Descender" . #\u+04be) + ("Cyrillic_Small_Letter_Abkhasian_Che_With_Descender" . #\u+04bf) + ("Cyrillic_Letter_Palochka" . #\u+04c0) + ("Cyrillic_Capital_Letter_Zhe_With_Breve" . #\u+04c1) + ("Cyrillic_Small_Letter_Zhe_With_Breve" . #\u+04c2) + ("Cyrillic_Capital_Letter_Ka_With_Hook" . #\u+04c3) + ("Cyrillic_Small_Letter_Ka_With_Hook" . #\u+04c4) + ("Cyrillic_Capital_Letter_El_With_Tail" . #\u+04c5) + ("Cyrillic_Small_Letter_El_With_Tail" . #\u+04c6) + ("Cyrillic_Capital_Letter_En_With_Hook" . #\u+04c7) + ("Cyrillic_Small_Letter_En_With_Hook" . #\u+04c8) + ("Cyrillic_Capital_Letter_En_With_Tail" . #\u+04c9) + ("Cyrillic_Small_Letter_En_With_Tail" . #\u+04ca) + ("Cyrillic_Capital_Letter_Khakassian_Che" . #\u+04cb) + ("Cyrillic_Small_Letter_Khakassian_Che" . #\u+04cc) + ("Cyrillic_Capital_Letter_Em_With_Tail" . #\u+04cd) + ("Cyrillic_Small_Letter_Em_With_Tail" . #\u+04ce) + ("Cyrillic_Small_Letter_Palochka" . #\u+04cf) + ("Cyrillic_Capital_Letter_A_With_Breve" . #\u+04d0) + ("Cyrillic_Small_Letter_A_With_Breve" . #\u+04d1) + ("Cyrillic_Capital_Letter_A_With_Diaeresis" . #\u+04d2) + ("Cyrillic_Small_Letter_A_With_Diaeresis" . #\u+04d3) + ("Cyrillic_Capital_Ligature_A_Ie" . #\u+04d4) + ("Cyrillic_Small_Ligature_A_Ie" . #\u+04d5) + ("Cyrillic_Capital_Letter_Ie_With_Breve" . #\u+04d6) + ("Cyrillic_Small_Letter_Ie_With_Breve" . #\u+04d7) + ("Cyrillic_Capital_Letter_Schwa" . #\u+04d8) + ("Cyrillic_Small_Letter_Schwa" . #\u+04d9) + ("Cyrillic_Capital_Letter_Schwa_With_Diaeresis" . #\u+04da) + ("Cyrillic_Small_Letter_Schwa_With_Diaeresis" . #\u+04db) + ("Cyrillic_Capital_Letter_Zhe_With_Diaeresis" . #\u+04dc) + ("Cyrillic_Small_Letter_Zhe_With_Diaeresis" . #\u+04dd) + ("Cyrillic_Capital_Letter_Ze_With_Diaeresis" . #\u+04de) + ("Cyrillic_Small_Letter_Ze_With_Diaeresis" . #\u+04df) + ("Cyrillic_Capital_Letter_Abkhasian_Dze" . #\u+04e0) + ("Cyrillic_Small_Letter_Abkhasian_Dze" . #\u+04e1) + ("Cyrillic_Capital_Letter_I_With_Macron" . #\u+04e2) + ("Cyrillic_Small_Letter_I_With_Macron" . #\u+04e3) + ("Cyrillic_Capital_Letter_I_With_Diaeresis" . #\u+04e4) + ("Cyrillic_Small_Letter_I_With_Diaeresis" . #\u+04e5) + ("Cyrillic_Capital_Letter_O_With_Diaeresis" . #\u+04e6) + ("Cyrillic_Small_Letter_O_With_Diaeresis" . #\u+04e7) + ("Cyrillic_Capital_Letter_Barred_O" . #\u+04e8) + ("Cyrillic_Small_Letter_Barred_O" . #\u+04e9) + ("Cyrillic_Capital_Letter_Barred_O_With_Diaeresis" . #\u+04ea) + ("Cyrillic_Small_Letter_Barred_O_With_Diaeresis" . #\u+04eb) + ("Cyrillic_Capital_Letter_E_With_Diaeresis" . #\u+04ec) + ("Cyrillic_Small_Letter_E_With_Diaeresis" . #\u+04ed) + ("Cyrillic_Capital_Letter_U_With_Macron" . #\u+04ee) + ("Cyrillic_Small_Letter_U_With_Macron" . #\u+04ef) + ("Cyrillic_Capital_Letter_U_With_Diaeresis" . #\u+04f0) + ("Cyrillic_Small_Letter_U_With_Diaeresis" . #\u+04f1) + ("Cyrillic_Capital_Letter_U_With_Double_Acute" . #\u+04f2) + ("Cyrillic_Small_Letter_U_With_Double_Acute" . #\u+04f3) + ("Cyrillic_Capital_Letter_Che_With_Diaeresis" . #\u+04f4) + ("Cyrillic_Small_Letter_Che_With_Diaeresis" . #\u+04f5) + ("Cyrillic_Capital_Letter_Ghe_With_Descender" . #\u+04f6) + ("Cyrillic_Small_Letter_Ghe_With_Descender" . #\u+04f7) + ("Cyrillic_Capital_Letter_Yeru_With_Diaeresis" . #\u+04f8) + ("Cyrillic_Small_Letter_Yeru_With_Diaeresis" . #\u+04f9) + ("Cyrillic_Capital_Letter_Ghe_With_Stroke_And_Hook" . #\u+04fa) + ("Cyrillic_Small_Letter_Ghe_With_Stroke_And_Hook" . #\u+04fb) + ("Cyrillic_Capital_Letter_Ha_With_Hook" . #\u+04fc) + ("Cyrillic_Small_Letter_Ha_With_Hook" . #\u+04fd) + ("Cyrillic_Capital_Letter_Ha_With_Stroke" . #\u+04fe) + ("Cyrillic_Small_Letter_Ha_With_Stroke" . #\u+04ff) + ("Cyrillic_Capital_Letter_Komi_De" . #\u+0500) + ("Cyrillic_Small_Letter_Komi_De" . #\u+0501) + ("Cyrillic_Capital_Letter_Komi_Dje" . #\u+0502) + ("Cyrillic_Small_Letter_Komi_Dje" . #\u+0503) + ("Cyrillic_Capital_Letter_Komi_Zje" . #\u+0504) + ("Cyrillic_Small_Letter_Komi_Zje" . #\u+0505) + ("Cyrillic_Capital_Letter_Komi_Dzje" . #\u+0506) + ("Cyrillic_Small_Letter_Komi_Dzje" . #\u+0507) + ("Cyrillic_Capital_Letter_Komi_Lje" . #\u+0508) + ("Cyrillic_Small_Letter_Komi_Lje" . #\u+0509) + ("Cyrillic_Capital_Letter_Komi_Nje" . #\u+050a) + ("Cyrillic_Small_Letter_Komi_Nje" . #\u+050b) + ("Cyrillic_Capital_Letter_Komi_Sje" . #\u+050c) + ("Cyrillic_Small_Letter_Komi_Sje" . #\u+050d) + ("Cyrillic_Capital_Letter_Komi_Tje" . #\u+050e) + ("Cyrillic_Small_Letter_Komi_Tje" . #\u+050f) + ("Cyrillic_Capital_Letter_Reversed_Ze" . #\u+0510) + ("Cyrillic_Small_Letter_Reversed_Ze" . #\u+0511) + ("Cyrillic_Capital_Letter_El_With_Hook" . #\u+0512) + ("Cyrillic_Small_Letter_El_With_Hook" . #\u+0513) + ("Armenian_Capital_Letter_Ayb" . #\u+0531) + ("Armenian_Capital_Letter_Ben" . #\u+0532) + ("Armenian_Capital_Letter_Gim" . #\u+0533) + ("Armenian_Capital_Letter_Da" . #\u+0534) + ("Armenian_Capital_Letter_Ech" . #\u+0535) + ("Armenian_Capital_Letter_Za" . #\u+0536) + ("Armenian_Capital_Letter_Eh" . #\u+0537) + ("Armenian_Capital_Letter_Et" . #\u+0538) + ("Armenian_Capital_Letter_To" . #\u+0539) + ("Armenian_Capital_Letter_Zhe" . #\u+053a) + ("Armenian_Capital_Letter_Ini" . #\u+053b) + ("Armenian_Capital_Letter_Liwn" . #\u+053c) + ("Armenian_Capital_Letter_Xeh" . #\u+053d) + ("Armenian_Capital_Letter_Ca" . #\u+053e) + ("Armenian_Capital_Letter_Ken" . #\u+053f) + ("Armenian_Capital_Letter_Ho" . #\u+0540) + ("Armenian_Capital_Letter_Ja" . #\u+0541) + ("Armenian_Capital_Letter_Ghad" . #\u+0542) + ("Armenian_Capital_Letter_Cheh" . #\u+0543) + ("Armenian_Capital_Letter_Men" . #\u+0544) + ("Armenian_Capital_Letter_Yi" . #\u+0545) + ("Armenian_Capital_Letter_Now" . #\u+0546) + ("Armenian_Capital_Letter_Sha" . #\u+0547) + ("Armenian_Capital_Letter_Vo" . #\u+0548) + ("Armenian_Capital_Letter_Cha" . #\u+0549) + ("Armenian_Capital_Letter_Peh" . #\u+054a) + ("Armenian_Capital_Letter_Jheh" . #\u+054b) + ("Armenian_Capital_Letter_Ra" . #\u+054c) + ("Armenian_Capital_Letter_Seh" . #\u+054d) + ("Armenian_Capital_Letter_Vew" . #\u+054e) + ("Armenian_Capital_Letter_Tiwn" . #\u+054f) + ("Armenian_Capital_Letter_Reh" . #\u+0550) + ("Armenian_Capital_Letter_Co" . #\u+0551) + ("Armenian_Capital_Letter_Yiwn" . #\u+0552) + ("Armenian_Capital_Letter_Piwr" . #\u+0553) + ("Armenian_Capital_Letter_Keh" . #\u+0554) + ("Armenian_Capital_Letter_Oh" . #\u+0555) + ("Armenian_Capital_Letter_Feh" . #\u+0556) + ("Armenian_Modifier_Letter_Left_Half_Ring" . #\u+0559) + ("Armenian_Apostrophe" . #\u+055a) + ("Armenian_Emphasis_Mark" . #\u+055b) + ("Armenian_Exclamation_Mark" . #\u+055c) + ("Armenian_Comma" . #\u+055d) + ("Armenian_Question_Mark" . #\u+055e) + ("Armenian_Abbreviation_Mark" . #\u+055f) + ("Armenian_Small_Letter_Ayb" . #\u+0561) + ("Armenian_Small_Letter_Ben" . #\u+0562) + ("Armenian_Small_Letter_Gim" . #\u+0563) + ("Armenian_Small_Letter_Da" . #\u+0564) + ("Armenian_Small_Letter_Ech" . #\u+0565) + ("Armenian_Small_Letter_Za" . #\u+0566) + ("Armenian_Small_Letter_Eh" . #\u+0567) + ("Armenian_Small_Letter_Et" . #\u+0568) + ("Armenian_Small_Letter_To" . #\u+0569) + ("Armenian_Small_Letter_Zhe" . #\u+056a) + ("Armenian_Small_Letter_Ini" . #\u+056b) + ("Armenian_Small_Letter_Liwn" . #\u+056c) + ("Armenian_Small_Letter_Xeh" . #\u+056d) + ("Armenian_Small_Letter_Ca" . #\u+056e) + ("Armenian_Small_Letter_Ken" . #\u+056f) + ("Armenian_Small_Letter_Ho" . #\u+0570) + ("Armenian_Small_Letter_Ja" . #\u+0571) + ("Armenian_Small_Letter_Ghad" . #\u+0572) + ("Armenian_Small_Letter_Cheh" . #\u+0573) + ("Armenian_Small_Letter_Men" . #\u+0574) + ("Armenian_Small_Letter_Yi" . #\u+0575) + ("Armenian_Small_Letter_Now" . #\u+0576) + ("Armenian_Small_Letter_Sha" . #\u+0577) + ("Armenian_Small_Letter_Vo" . #\u+0578) + ("Armenian_Small_Letter_Cha" . #\u+0579) + ("Armenian_Small_Letter_Peh" . #\u+057a) + ("Armenian_Small_Letter_Jheh" . #\u+057b) + ("Armenian_Small_Letter_Ra" . #\u+057c) + ("Armenian_Small_Letter_Seh" . #\u+057d) + ("Armenian_Small_Letter_Vew" . #\u+057e) + ("Armenian_Small_Letter_Tiwn" . #\u+057f) + ("Armenian_Small_Letter_Reh" . #\u+0580) + ("Armenian_Small_Letter_Co" . #\u+0581) + ("Armenian_Small_Letter_Yiwn" . #\u+0582) + ("Armenian_Small_Letter_Piwr" . #\u+0583) + ("Armenian_Small_Letter_Keh" . #\u+0584) + ("Armenian_Small_Letter_Oh" . #\u+0585) + ("Armenian_Small_Letter_Feh" . #\u+0586) + ("Armenian_Small_Ligature_Ech_Yiwn" . #\u+0587) + ("Armenian_Full_Stop" . #\u+0589) + ("Armenian_Hyphen" . #\u+058a) + ("Hebrew_Accent_Etnahta" . #\u+0591) + ("Hebrew_Accent_Segol" . #\u+0592) + ("Hebrew_Accent_Shalshelet" . #\u+0593) + ("Hebrew_Accent_Zaqef_Qatan" . #\u+0594) + ("Hebrew_Accent_Zaqef_Gadol" . #\u+0595) + ("Hebrew_Accent_Tipeha" . #\u+0596) + ("Hebrew_Accent_Revia" . #\u+0597) + ("Hebrew_Accent_Zarqa" . #\u+0598) + ("Hebrew_Accent_Pashta" . #\u+0599) + ("Hebrew_Accent_Yetiv" . #\u+059a) + ("Hebrew_Accent_Tevir" . #\u+059b) + ("Hebrew_Accent_Geresh" . #\u+059c) + ("Hebrew_Accent_Geresh_Muqdam" . #\u+059d) + ("Hebrew_Accent_Gershayim" . #\u+059e) + ("Hebrew_Accent_Qarney_Para" . #\u+059f) + ("Hebrew_Accent_Telisha_Gedola" . #\u+05a0) + ("Hebrew_Accent_Pazer" . #\u+05a1) + ("Hebrew_Accent_Atnah_Hafukh" . #\u+05a2) + ("Hebrew_Accent_Munah" . #\u+05a3) + ("Hebrew_Accent_Mahapakh" . #\u+05a4) + ("Hebrew_Accent_Merkha" . #\u+05a5) + ("Hebrew_Accent_Merkha_Kefula" . #\u+05a6) + ("Hebrew_Accent_Darga" . #\u+05a7) + ("Hebrew_Accent_Qadma" . #\u+05a8) + ("Hebrew_Accent_Telisha_Qetana" . #\u+05a9) + ("Hebrew_Accent_Yerah_Ben_Yomo" . #\u+05aa) + ("Hebrew_Accent_Ole" . #\u+05ab) + ("Hebrew_Accent_Iluy" . #\u+05ac) + ("Hebrew_Accent_Dehi" . #\u+05ad) + ("Hebrew_Accent_Zinor" . #\u+05ae) + ("Hebrew_Mark_Masora_Circle" . #\u+05af) + ("Hebrew_Point_Sheva" . #\u+05b0) + ("Hebrew_Point_Hataf_Segol" . #\u+05b1) + ("Hebrew_Point_Hataf_Patah" . #\u+05b2) + ("Hebrew_Point_Hataf_Qamats" . #\u+05b3) + ("Hebrew_Point_Hiriq" . #\u+05b4) + ("Hebrew_Point_Tsere" . #\u+05b5) + ("Hebrew_Point_Segol" . #\u+05b6) + ("Hebrew_Point_Patah" . #\u+05b7) + ("Hebrew_Point_Qamats" . #\u+05b8) + ("Hebrew_Point_Holam" . #\u+05b9) + ("Hebrew_Point_Holam_Haser_For_Vav" . #\u+05ba) + ("Hebrew_Point_Qubuts" . #\u+05bb) + ("Hebrew_Point_Dagesh_Or_Mapiq" . #\u+05bc) + ("Hebrew_Point_Meteg" . #\u+05bd) + ("Hebrew_Punctuation_Maqaf" . #\u+05be) + ("Hebrew_Point_Rafe" . #\u+05bf) + ("Hebrew_Punctuation_Paseq" . #\u+05c0) + ("Hebrew_Point_Shin_Dot" . #\u+05c1) + ("Hebrew_Point_Sin_Dot" . #\u+05c2) + ("Hebrew_Punctuation_Sof_Pasuq" . #\u+05c3) + ("Hebrew_Mark_Upper_Dot" . #\u+05c4) + ("Hebrew_Mark_Lower_Dot" . #\u+05c5) + ("Hebrew_Punctuation_Nun_Hafukha" . #\u+05c6) + ("Hebrew_Point_Qamats_Qatan" . #\u+05c7) + ("Hebrew_Letter_Alef" . #\u+05d0) + ("Hebrew_Letter_Bet" . #\u+05d1) + ("Hebrew_Letter_Gimel" . #\u+05d2) + ("Hebrew_Letter_Dalet" . #\u+05d3) + ("Hebrew_Letter_He" . #\u+05d4) + ("Hebrew_Letter_Vav" . #\u+05d5) + ("Hebrew_Letter_Zayin" . #\u+05d6) + ("Hebrew_Letter_Het" . #\u+05d7) + ("Hebrew_Letter_Tet" . #\u+05d8) + ("Hebrew_Letter_Yod" . #\u+05d9) + ("Hebrew_Letter_Final_Kaf" . #\u+05da) + ("Hebrew_Letter_Kaf" . #\u+05db) + ("Hebrew_Letter_Lamed" . #\u+05dc) + ("Hebrew_Letter_Final_Mem" . #\u+05dd) + ("Hebrew_Letter_Mem" . #\u+05de) + ("Hebrew_Letter_Final_Nun" . #\u+05df) + ("Hebrew_Letter_Nun" . #\u+05e0) + ("Hebrew_Letter_Samekh" . #\u+05e1) + ("Hebrew_Letter_Ayin" . #\u+05e2) + ("Hebrew_Letter_Final_Pe" . #\u+05e3) + ("Hebrew_Letter_Pe" . #\u+05e4) + ("Hebrew_Letter_Final_Tsadi" . #\u+05e5) + ("Hebrew_Letter_Tsadi" . #\u+05e6) + ("Hebrew_Letter_Qof" . #\u+05e7) + ("Hebrew_Letter_Resh" . #\u+05e8) + ("Hebrew_Letter_Shin" . #\u+05e9) + ("Hebrew_Letter_Tav" . #\u+05ea) + ("Hebrew_Ligature_Yiddish_Double_Vav" . #\u+05f0) + ("Hebrew_Ligature_Yiddish_Vav_Yod" . #\u+05f1) + ("Hebrew_Ligature_Yiddish_Double_Yod" . #\u+05f2) + ("Hebrew_Punctuation_Geresh" . #\u+05f3) + ("Hebrew_Punctuation_Gershayim" . #\u+05f4) + ("Arabic_Number_Sign" . #\u+0600) + ("Arabic_Sign_Sanah" . #\u+0601) + ("Arabic_Footnote_Marker" . #\u+0602) + ("Arabic_Sign_Safha" . #\u+0603) + ("Afghani_Sign" . #\u+060b) + ("Arabic_Comma" . #\u+060c) + ("Arabic_Date_Separator" . #\u+060d) + ("Arabic_Poetic_Verse_Sign" . #\u+060e) + ("Arabic_Sign_Misra" . #\u+060f) + ("Arabic_Sign_Sallallahou_Alayhe_Wassallam" . #\u+0610) + ("Arabic_Sign_Alayhe_Assallam" . #\u+0611) + ("Arabic_Sign_Rahmatullah_Alayhe" . #\u+0612) + ("Arabic_Sign_Radi_Allahou_Anhu" . #\u+0613) + ("Arabic_Sign_Takhallus" . #\u+0614) + ("Arabic_Small_High_Tah" . #\u+0615) + ("Arabic_Semicolon" . #\u+061b) + ("Arabic_Triple_Dot_Punctuation_Mark" . #\u+061e) + ("Arabic_Question_Mark" . #\u+061f) + ("Arabic_Letter_Hamza" . #\u+0621) + ("Arabic_Letter_Alef_With_Madda_Above" . #\u+0622) + ("Arabic_Letter_Alef_With_Hamza_Above" . #\u+0623) + ("Arabic_Letter_Waw_With_Hamza_Above" . #\u+0624) + ("Arabic_Letter_Alef_With_Hamza_Below" . #\u+0625) + ("Arabic_Letter_Yeh_With_Hamza_Above" . #\u+0626) + ("Arabic_Letter_Alef" . #\u+0627) + ("Arabic_Letter_Beh" . #\u+0628) + ("Arabic_Letter_Teh_Marbuta" . #\u+0629) + ("Arabic_Letter_Teh" . #\u+062a) + ("Arabic_Letter_Theh" . #\u+062b) + ("Arabic_Letter_Jeem" . #\u+062c) + ("Arabic_Letter_Hah" . #\u+062d) + ("Arabic_Letter_Khah" . #\u+062e) + ("Arabic_Letter_Dal" . #\u+062f) + ("Arabic_Letter_Thal" . #\u+0630) + ("Arabic_Letter_Reh" . #\u+0631) + ("Arabic_Letter_Zain" . #\u+0632) + ("Arabic_Letter_Seen" . #\u+0633) + ("Arabic_Letter_Sheen" . #\u+0634) + ("Arabic_Letter_Sad" . #\u+0635) + ("Arabic_Letter_Dad" . #\u+0636) + ("Arabic_Letter_Tah" . #\u+0637) + ("Arabic_Letter_Zah" . #\u+0638) + ("Arabic_Letter_Ain" . #\u+0639) + ("Arabic_Letter_Ghain" . #\u+063a) + ("Arabic_Tatweel" . #\u+0640) + ("Arabic_Letter_Feh" . #\u+0641) + ("Arabic_Letter_Qaf" . #\u+0642) + ("Arabic_Letter_Kaf" . #\u+0643) + ("Arabic_Letter_Lam" . #\u+0644) + ("Arabic_Letter_Meem" . #\u+0645) + ("Arabic_Letter_Noon" . #\u+0646) + ("Arabic_Letter_Heh" . #\u+0647) + ("Arabic_Letter_Waw" . #\u+0648) + ("Arabic_Letter_Alef_Maksura" . #\u+0649) + ("Arabic_Letter_Yeh" . #\u+064a) + ("Arabic_Fathatan" . #\u+064b) + ("Arabic_Dammatan" . #\u+064c) + ("Arabic_Kasratan" . #\u+064d) + ("Arabic_Fatha" . #\u+064e) + ("Arabic_Damma" . #\u+064f) + ("Arabic_Kasra" . #\u+0650) + ("Arabic_Shadda" . #\u+0651) + ("Arabic_Sukun" . #\u+0652) + ("Arabic_Maddah_Above" . #\u+0653) + ("Arabic_Hamza_Above" . #\u+0654) + ("Arabic_Hamza_Below" . #\u+0655) + ("Arabic_Subscript_Alef" . #\u+0656) + ("Arabic_Inverted_Damma" . #\u+0657) + ("Arabic_Mark_Noon_Ghunna" . #\u+0658) + ("Arabic_Zwarakay" . #\u+0659) + ("Arabic_Vowel_Sign_Small_V_Above" . #\u+065a) + ("Arabic_Vowel_Sign_Inverted_Small_V_Above" . #\u+065b) + ("Arabic_Vowel_Sign_Dot_Below" . #\u+065c) + ("Arabic_Reversed_Damma" . #\u+065d) + ("Arabic_Fatha_With_Two_Dots" . #\u+065e) + ("Arabic-Indic_Digit_Zero" . #\u+0660) + ("Arabic-Indic_Digit_One" . #\u+0661) + ("Arabic-Indic_Digit_Two" . #\u+0662) + ("Arabic-Indic_Digit_Three" . #\u+0663) + ("Arabic-Indic_Digit_Four" . #\u+0664) + ("Arabic-Indic_Digit_Five" . #\u+0665) + ("Arabic-Indic_Digit_Six" . #\u+0666) + ("Arabic-Indic_Digit_Seven" . #\u+0667) + ("Arabic-Indic_Digit_Eight" . #\u+0668) + ("Arabic-Indic_Digit_Nine" . #\u+0669) + ("Arabic_Percent_Sign" . #\u+066a) + ("Arabic_Decimal_Separator" . #\u+066b) + ("Arabic_Thousands_Separator" . #\u+066c) + ("Arabic_Five_Pointed_Star" . #\u+066d) + ("Arabic_Letter_Dotless_Beh" . #\u+066e) + ("Arabic_Letter_Dotless_Qaf" . #\u+066f) + ("Arabic_Letter_Superscript_Alef" . #\u+0670) + ("Arabic_Letter_Alef_Wasla" . #\u+0671) + ("Arabic_Letter_Alef_With_Wavy_Hamza_Above" . #\u+0672) + ("Arabic_Letter_Alef_With_Wavy_Hamza_Below" . #\u+0673) + ("Arabic_Letter_High_Hamza" . #\u+0674) + ("Arabic_Letter_High_Hamza_Alef" . #\u+0675) + ("Arabic_Letter_High_Hamza_Waw" . #\u+0676) + ("Arabic_Letter_U_With_Hamza_Above" . #\u+0677) + ("Arabic_Letter_High_Hamza_Yeh" . #\u+0678) + ("Arabic_Letter_Tteh" . #\u+0679) + ("Arabic_Letter_Tteheh" . #\u+067a) + ("Arabic_Letter_Beeh" . #\u+067b) + ("Arabic_Letter_Teh_With_Ring" . #\u+067c) + ("Arabic_Letter_Teh_With_Three_Dots_Above_Downwards" . #\u+067d) + ("Arabic_Letter_Peh" . #\u+067e) + ("Arabic_Letter_Teheh" . #\u+067f) + ("Arabic_Letter_Beheh" . #\u+0680) + ("Arabic_Letter_Hah_With_Hamza_Above" . #\u+0681) + ("Arabic_Letter_Hah_With_Two_Dots_Vertical_Above" . #\u+0682) + ("Arabic_Letter_Nyeh" . #\u+0683) + ("Arabic_Letter_Dyeh" . #\u+0684) + ("Arabic_Letter_Hah_With_Three_Dots_Above" . #\u+0685) + ("Arabic_Letter_Tcheh" . #\u+0686) + ("Arabic_Letter_Tcheheh" . #\u+0687) + ("Arabic_Letter_Ddal" . #\u+0688) + ("Arabic_Letter_Dal_With_Ring" . #\u+0689) + ("Arabic_Letter_Dal_With_Dot_Below" . #\u+068a) + ("Arabic_Letter_Dal_With_Dot_Below_And_Small_Tah" . #\u+068b) + ("Arabic_Letter_Dahal" . #\u+068c) + ("Arabic_Letter_Ddahal" . #\u+068d) + ("Arabic_Letter_Dul" . #\u+068e) + ("Arabic_Letter_Dal_With_Three_Dots_Above_Downwards" . #\u+068f) + ("Arabic_Letter_Dal_With_Four_Dots_Above" . #\u+0690) + ("Arabic_Letter_Rreh" . #\u+0691) + ("Arabic_Letter_Reh_With_Small_V" . #\u+0692) + ("Arabic_Letter_Reh_With_Ring" . #\u+0693) + ("Arabic_Letter_Reh_With_Dot_Below" . #\u+0694) + ("Arabic_Letter_Reh_With_Small_V_Below" . #\u+0695) + ("Arabic_Letter_Reh_With_Dot_Below_And_Dot_Above" . #\u+0696) + ("Arabic_Letter_Reh_With_Two_Dots_Above" . #\u+0697) + ("Arabic_Letter_Jeh" . #\u+0698) + ("Arabic_Letter_Reh_With_Four_Dots_Above" . #\u+0699) + ("Arabic_Letter_Seen_With_Dot_Below_And_Dot_Above" . #\u+069a) + ("Arabic_Letter_Seen_With_Three_Dots_Below" . #\u+069b) + ("Arabic_Letter_Seen_With_Three_Dots_Below_And_Three_Dots_Above" . #\u+069c) + ("Arabic_Letter_Sad_With_Two_Dots_Below" . #\u+069d) + ("Arabic_Letter_Sad_With_Three_Dots_Above" . #\u+069e) + ("Arabic_Letter_Tah_With_Three_Dots_Above" . #\u+069f) + ("Arabic_Letter_Ain_With_Three_Dots_Above" . #\u+06a0) + ("Arabic_Letter_Dotless_Feh" . #\u+06a1) + ("Arabic_Letter_Feh_With_Dot_Moved_Below" . #\u+06a2) + ("Arabic_Letter_Feh_With_Dot_Below" . #\u+06a3) + ("Arabic_Letter_Veh" . #\u+06a4) + ("Arabic_Letter_Feh_With_Three_Dots_Below" . #\u+06a5) + ("Arabic_Letter_Peheh" . #\u+06a6) + ("Arabic_Letter_Qaf_With_Dot_Above" . #\u+06a7) + ("Arabic_Letter_Qaf_With_Three_Dots_Above" . #\u+06a8) + ("Arabic_Letter_Keheh" . #\u+06a9) + ("Arabic_Letter_Swash_Kaf" . #\u+06aa) + ("Arabic_Letter_Kaf_With_Ring" . #\u+06ab) + ("Arabic_Letter_Kaf_With_Dot_Above" . #\u+06ac) + ("Arabic_Letter_Ng" . #\u+06ad) + ("Arabic_Letter_Kaf_With_Three_Dots_Below" . #\u+06ae) + ("Arabic_Letter_Gaf" . #\u+06af) + ("Arabic_Letter_Gaf_With_Ring" . #\u+06b0) + ("Arabic_Letter_Ngoeh" . #\u+06b1) + ("Arabic_Letter_Gaf_With_Two_Dots_Below" . #\u+06b2) + ("Arabic_Letter_Gueh" . #\u+06b3) + ("Arabic_Letter_Gaf_With_Three_Dots_Above" . #\u+06b4) + ("Arabic_Letter_Lam_With_Small_V" . #\u+06b5) + ("Arabic_Letter_Lam_With_Dot_Above" . #\u+06b6) + ("Arabic_Letter_Lam_With_Three_Dots_Above" . #\u+06b7) + ("Arabic_Letter_Lam_With_Three_Dots_Below" . #\u+06b8) + ("Arabic_Letter_Noon_With_Dot_Below" . #\u+06b9) + ("Arabic_Letter_Noon_Ghunna" . #\u+06ba) + ("Arabic_Letter_Rnoon" . #\u+06bb) + ("Arabic_Letter_Noon_With_Ring" . #\u+06bc) + ("Arabic_Letter_Noon_With_Three_Dots_Above" . #\u+06bd) + ("Arabic_Letter_Heh_Doachashmee" . #\u+06be) + ("Arabic_Letter_Tcheh_With_Dot_Above" . #\u+06bf) + ("Arabic_Letter_Heh_With_Yeh_Above" . #\u+06c0) + ("Arabic_Letter_Heh_Goal" . #\u+06c1) + ("Arabic_Letter_Heh_Goal_With_Hamza_Above" . #\u+06c2) + ("Arabic_Letter_Teh_Marbuta_Goal" . #\u+06c3) + ("Arabic_Letter_Waw_With_Ring" . #\u+06c4) + ("Arabic_Letter_Kirghiz_Oe" . #\u+06c5) + ("Arabic_Letter_Oe" . #\u+06c6) + ("Arabic_Letter_U" . #\u+06c7) + ("Arabic_Letter_Yu" . #\u+06c8) + ("Arabic_Letter_Kirghiz_Yu" . #\u+06c9) + ("Arabic_Letter_Waw_With_Two_Dots_Above" . #\u+06ca) + ("Arabic_Letter_Ve" . #\u+06cb) + ("Arabic_Letter_Farsi_Yeh" . #\u+06cc) + ("Arabic_Letter_Yeh_With_Tail" . #\u+06cd) + ("Arabic_Letter_Yeh_With_Small_V" . #\u+06ce) + ("Arabic_Letter_Waw_With_Dot_Above" . #\u+06cf) + ("Arabic_Letter_E" . #\u+06d0) + ("Arabic_Letter_Yeh_With_Three_Dots_Below" . #\u+06d1) + ("Arabic_Letter_Yeh_Barree" . #\u+06d2) + ("Arabic_Letter_Yeh_Barree_With_Hamza_Above" . #\u+06d3) + ("Arabic_Full_Stop" . #\u+06d4) + ("Arabic_Letter_Ae" . #\u+06d5) + ("Arabic_Small_High_Ligature_Sad_With_Lam_With_Alef_Maksura" . #\u+06d6) + ("Arabic_Small_High_Ligature_Qaf_With_Lam_With_Alef_Maksura" . #\u+06d7) + ("Arabic_Small_High_Meem_Initial_Form" . #\u+06d8) + ("Arabic_Small_High_Lam_Alef" . #\u+06d9) + ("Arabic_Small_High_Jeem" . #\u+06da) + ("Arabic_Small_High_Three_Dots" . #\u+06db) + ("Arabic_Small_High_Seen" . #\u+06dc) + ("Arabic_End_Of_Ayah" . #\u+06dd) + ("Arabic_Start_Of_Rub_El_Hizb" . #\u+06de) + ("Arabic_Small_High_Rounded_Zero" . #\u+06df) + ("Arabic_Small_High_Upright_Rectangular_Zero" . #\u+06e0) + ("Arabic_Small_High_Dotless_Head_Of_Khah" . #\u+06e1) + ("Arabic_Small_High_Meem_Isolated_Form" . #\u+06e2) + ("Arabic_Small_Low_Seen" . #\u+06e3) + ("Arabic_Small_High_Madda" . #\u+06e4) + ("Arabic_Small_Waw" . #\u+06e5) + ("Arabic_Small_Yeh" . #\u+06e6) + ("Arabic_Small_High_Yeh" . #\u+06e7) + ("Arabic_Small_High_Noon" . #\u+06e8) + ("Arabic_Place_Of_Sajdah" . #\u+06e9) + ("Arabic_Empty_Centre_Low_Stop" . #\u+06ea) + ("Arabic_Empty_Centre_High_Stop" . #\u+06eb) + ("Arabic_Rounded_High_Stop_With_Filled_Centre" . #\u+06ec) + ("Arabic_Small_Low_Meem" . #\u+06ed) + ("Arabic_Letter_Dal_With_Inverted_V" . #\u+06ee) + ("Arabic_Letter_Reh_With_Inverted_V" . #\u+06ef) + ("Extended_Arabic-Indic_Digit_Zero" . #\u+06f0) + ("Extended_Arabic-Indic_Digit_One" . #\u+06f1) + ("Extended_Arabic-Indic_Digit_Two" . #\u+06f2) + ("Extended_Arabic-Indic_Digit_Three" . #\u+06f3) + ("Extended_Arabic-Indic_Digit_Four" . #\u+06f4) + ("Extended_Arabic-Indic_Digit_Five" . #\u+06f5) + ("Extended_Arabic-Indic_Digit_Six" . #\u+06f6) + ("Extended_Arabic-Indic_Digit_Seven" . #\u+06f7) + ("Extended_Arabic-Indic_Digit_Eight" . #\u+06f8) + ("Extended_Arabic-Indic_Digit_Nine" . #\u+06f9) + ("Arabic_Letter_Sheen_With_Dot_Below" . #\u+06fa) + ("Arabic_Letter_Dad_With_Dot_Below" . #\u+06fb) + ("Arabic_Letter_Ghain_With_Dot_Below" . #\u+06fc) + ("Arabic_Sign_Sindhi_Ampersand" . #\u+06fd) + ("Arabic_Sign_Sindhi_Postposition_Men" . #\u+06fe) + ("Arabic_Letter_Heh_With_Inverted_V" . #\u+06ff) + ("Syriac_End_Of_Paragraph" . #\u+0700) + ("Syriac_Supralinear_Full_Stop" . #\u+0701) + ("Syriac_Sublinear_Full_Stop" . #\u+0702) + ("Syriac_Supralinear_Colon" . #\u+0703) + ("Syriac_Sublinear_Colon" . #\u+0704) + ("Syriac_Horizontal_Colon" . #\u+0705) + ("Syriac_Colon_Skewed_Left" . #\u+0706) + ("Syriac_Colon_Skewed_Right" . #\u+0707) + ("Syriac_Supralinear_Colon_Skewed_Left" . #\u+0708) + ("Syriac_Sublinear_Colon_Skewed_Right" . #\u+0709) + ("Syriac_Contraction" . #\u+070a) + ("Syriac_Harklean_Obelus" . #\u+070b) + ("Syriac_Harklean_Metobelus" . #\u+070c) + ("Syriac_Harklean_Asteriscus" . #\u+070d) + ("Syriac_Abbreviation_Mark" . #\u+070f) + ("Syriac_Letter_Alaph" . #\u+0710) + ("Syriac_Letter_Superscript_Alaph" . #\u+0711) + ("Syriac_Letter_Beth" . #\u+0712) + ("Syriac_Letter_Gamal" . #\u+0713) + ("Syriac_Letter_Gamal_Garshuni" . #\u+0714) + ("Syriac_Letter_Dalath" . #\u+0715) + ("Syriac_Letter_Dotless_Dalath_Rish" . #\u+0716) + ("Syriac_Letter_He" . #\u+0717) + ("Syriac_Letter_Waw" . #\u+0718) + ("Syriac_Letter_Zain" . #\u+0719) + ("Syriac_Letter_Heth" . #\u+071a) + ("Syriac_Letter_Teth" . #\u+071b) + ("Syriac_Letter_Teth_Garshuni" . #\u+071c) + ("Syriac_Letter_Yudh" . #\u+071d) + ("Syriac_Letter_Yudh_He" . #\u+071e) + ("Syriac_Letter_Kaph" . #\u+071f) + ("Syriac_Letter_Lamadh" . #\u+0720) + ("Syriac_Letter_Mim" . #\u+0721) + ("Syriac_Letter_Nun" . #\u+0722) + ("Syriac_Letter_Semkath" . #\u+0723) + ("Syriac_Letter_Final_Semkath" . #\u+0724) + ("Syriac_Letter_E" . #\u+0725) + ("Syriac_Letter_Pe" . #\u+0726) + ("Syriac_Letter_Reversed_Pe" . #\u+0727) + ("Syriac_Letter_Sadhe" . #\u+0728) + ("Syriac_Letter_Qaph" . #\u+0729) + ("Syriac_Letter_Rish" . #\u+072a) + ("Syriac_Letter_Shin" . #\u+072b) + ("Syriac_Letter_Taw" . #\u+072c) + ("Syriac_Letter_Persian_Bheth" . #\u+072d) + ("Syriac_Letter_Persian_Ghamal" . #\u+072e) + ("Syriac_Letter_Persian_Dhalath" . #\u+072f) + ("Syriac_Pthaha_Above" . #\u+0730) + ("Syriac_Pthaha_Below" . #\u+0731) + ("Syriac_Pthaha_Dotted" . #\u+0732) + ("Syriac_Zqapha_Above" . #\u+0733) + ("Syriac_Zqapha_Below" . #\u+0734) + ("Syriac_Zqapha_Dotted" . #\u+0735) + ("Syriac_Rbasa_Above" . #\u+0736) + ("Syriac_Rbasa_Below" . #\u+0737) + ("Syriac_Dotted_Zlama_Horizontal" . #\u+0738) + ("Syriac_Dotted_Zlama_Angular" . #\u+0739) + ("Syriac_Hbasa_Above" . #\u+073a) + ("Syriac_Hbasa_Below" . #\u+073b) + ("Syriac_Hbasa-Esasa_Dotted" . #\u+073c) + ("Syriac_Esasa_Above" . #\u+073d) + ("Syriac_Esasa_Below" . #\u+073e) + ("Syriac_Rwaha" . #\u+073f) + ("Syriac_Feminine_Dot" . #\u+0740) + ("Syriac_Qushshaya" . #\u+0741) + ("Syriac_Rukkakha" . #\u+0742) + ("Syriac_Two_Vertical_Dots_Above" . #\u+0743) + ("Syriac_Two_Vertical_Dots_Below" . #\u+0744) + ("Syriac_Three_Dots_Above" . #\u+0745) + ("Syriac_Three_Dots_Below" . #\u+0746) + ("Syriac_Oblique_Line_Above" . #\u+0747) + ("Syriac_Oblique_Line_Below" . #\u+0748) + ("Syriac_Music" . #\u+0749) + ("Syriac_Barrekh" . #\u+074a) + ("Syriac_Letter_Sogdian_Zhain" . #\u+074d) + ("Syriac_Letter_Sogdian_Khaph" . #\u+074e) + ("Syriac_Letter_Sogdian_Fe" . #\u+074f) + ("Arabic_Letter_Beh_With_Three_Dots_Horizontally_Below" . #\u+0750) + ("Arabic_Letter_Beh_With_Dot_Below_And_Three_Dots_Above" . #\u+0751) + ("Arabic_Letter_Beh_With_Three_Dots_Pointing_Upwards_Below" . #\u+0752) + ("Arabic_Letter_Beh_With_Three_Dots_Pointing_Upwards_Below_And_Two_Dots_Above" . #\u+0753) + ("Arabic_Letter_Beh_With_Two_Dots_Below_And_Dot_Above" . #\u+0754) + ("Arabic_Letter_Beh_With_Inverted_Small_V_Below" . #\u+0755) + ("Arabic_Letter_Beh_With_Small_V" . #\u+0756) + ("Arabic_Letter_Hah_With_Two_Dots_Above" . #\u+0757) + ("Arabic_Letter_Hah_With_Three_Dots_Pointing_Upwards_Below" . #\u+0758) + ("Arabic_Letter_Dal_With_Two_Dots_Vertically_Below_And_Small_Tah" . #\u+0759) + ("Arabic_Letter_Dal_With_Inverted_Small_V_Below" . #\u+075a) + ("Arabic_Letter_Reh_With_Stroke" . #\u+075b) + ("Arabic_Letter_Seen_With_Four_Dots_Above" . #\u+075c) + ("Arabic_Letter_Ain_With_Two_Dots_Above" . #\u+075d) + ("Arabic_Letter_Ain_With_Three_Dots_Pointing_Downwards_Above" . #\u+075e) + ("Arabic_Letter_Ain_With_Two_Dots_Vertically_Above" . #\u+075f) + ("Arabic_Letter_Feh_With_Two_Dots_Below" . #\u+0760) + ("Arabic_Letter_Feh_With_Three_Dots_Pointing_Upwards_Below" . #\u+0761) + ("Arabic_Letter_Keheh_With_Dot_Above" . #\u+0762) + ("Arabic_Letter_Keheh_With_Three_Dots_Above" . #\u+0763) + ("Arabic_Letter_Keheh_With_Three_Dots_Pointing_Upwards_Below" . #\u+0764) + ("Arabic_Letter_Meem_With_Dot_Above" . #\u+0765) + ("Arabic_Letter_Meem_With_Dot_Below" . #\u+0766) + ("Arabic_Letter_Noon_With_Two_Dots_Below" . #\u+0767) + ("Arabic_Letter_Noon_With_Small_Tah" . #\u+0768) + ("Arabic_Letter_Noon_With_Small_V" . #\u+0769) + ("Arabic_Letter_Lam_With_Bar" . #\u+076a) + ("Arabic_Letter_Reh_With_Two_Dots_Vertically_Above" . #\u+076b) + ("Arabic_Letter_Reh_With_Hamza_Above" . #\u+076c) + ("Arabic_Letter_Seen_With_Two_Dots_Vertically_Above" . #\u+076d) + ("Thaana_Letter_Haa" . #\u+0780) + ("Thaana_Letter_Shaviyani" . #\u+0781) + ("Thaana_Letter_Noonu" . #\u+0782) + ("Thaana_Letter_Raa" . #\u+0783) + ("Thaana_Letter_Baa" . #\u+0784) + ("Thaana_Letter_Lhaviyani" . #\u+0785) + ("Thaana_Letter_Kaafu" . #\u+0786) + ("Thaana_Letter_Alifu" . #\u+0787) + ("Thaana_Letter_Vaavu" . #\u+0788) + ("Thaana_Letter_Meemu" . #\u+0789) + ("Thaana_Letter_Faafu" . #\u+078a) + ("Thaana_Letter_Dhaalu" . #\u+078b) + ("Thaana_Letter_Thaa" . #\u+078c) + ("Thaana_Letter_Laamu" . #\u+078d) + ("Thaana_Letter_Gaafu" . #\u+078e) + ("Thaana_Letter_Gnaviyani" . #\u+078f) + ("Thaana_Letter_Seenu" . #\u+0790) + ("Thaana_Letter_Daviyani" . #\u+0791) + ("Thaana_Letter_Zaviyani" . #\u+0792) + ("Thaana_Letter_Taviyani" . #\u+0793) + ("Thaana_Letter_Yaa" . #\u+0794) + ("Thaana_Letter_Paviyani" . #\u+0795) + ("Thaana_Letter_Javiyani" . #\u+0796) + ("Thaana_Letter_Chaviyani" . #\u+0797) + ("Thaana_Letter_Ttaa" . #\u+0798) + ("Thaana_Letter_Hhaa" . #\u+0799) + ("Thaana_Letter_Khaa" . #\u+079a) + ("Thaana_Letter_Thaalu" . #\u+079b) + ("Thaana_Letter_Zaa" . #\u+079c) + ("Thaana_Letter_Sheenu" . #\u+079d) + ("Thaana_Letter_Saadhu" . #\u+079e) + ("Thaana_Letter_Daadhu" . #\u+079f) + ("Thaana_Letter_To" . #\u+07a0) + ("Thaana_Letter_Zo" . #\u+07a1) + ("Thaana_Letter_Ainu" . #\u+07a2) + ("Thaana_Letter_Ghainu" . #\u+07a3) + ("Thaana_Letter_Qaafu" . #\u+07a4) + ("Thaana_Letter_Waavu" . #\u+07a5) + ("Thaana_Abafili" . #\u+07a6) + ("Thaana_Aabaafili" . #\u+07a7) + ("Thaana_Ibifili" . #\u+07a8) + ("Thaana_Eebeefili" . #\u+07a9) + ("Thaana_Ubufili" . #\u+07aa) + ("Thaana_Ooboofili" . #\u+07ab) + ("Thaana_Ebefili" . #\u+07ac) + ("Thaana_Eybeyfili" . #\u+07ad) + ("Thaana_Obofili" . #\u+07ae) + ("Thaana_Oaboafili" . #\u+07af) + ("Thaana_Sukun" . #\u+07b0) + ("Thaana_Letter_Naa" . #\u+07b1) + ("Nko_Digit_Zero" . #\u+07c0) + ("Nko_Digit_One" . #\u+07c1) + ("Nko_Digit_Two" . #\u+07c2) + ("Nko_Digit_Three" . #\u+07c3) + ("Nko_Digit_Four" . #\u+07c4) + ("Nko_Digit_Five" . #\u+07c5) + ("Nko_Digit_Six" . #\u+07c6) + ("Nko_Digit_Seven" . #\u+07c7) + ("Nko_Digit_Eight" . #\u+07c8) + ("Nko_Digit_Nine" . #\u+07c9) + ("Nko_Letter_A" . #\u+07ca) + ("Nko_Letter_Ee" . #\u+07cb) + ("Nko_Letter_I" . #\u+07cc) + ("Nko_Letter_E" . #\u+07cd) + ("Nko_Letter_U" . #\u+07ce) + ("Nko_Letter_Oo" . #\u+07cf) + ("Nko_Letter_O" . #\u+07d0) + ("Nko_Letter_Dagbasinna" . #\u+07d1) + ("Nko_Letter_N" . #\u+07d2) + ("Nko_Letter_Ba" . #\u+07d3) + ("Nko_Letter_Pa" . #\u+07d4) + ("Nko_Letter_Ta" . #\u+07d5) + ("Nko_Letter_Ja" . #\u+07d6) + ("Nko_Letter_Cha" . #\u+07d7) + ("Nko_Letter_Da" . #\u+07d8) + ("Nko_Letter_Ra" . #\u+07d9) + ("Nko_Letter_Rra" . #\u+07da) + ("Nko_Letter_Sa" . #\u+07db) + ("Nko_Letter_Gba" . #\u+07dc) + ("Nko_Letter_Fa" . #\u+07dd) + ("Nko_Letter_Ka" . #\u+07de) + ("Nko_Letter_La" . #\u+07df) + ("Nko_Letter_Na_Woloso" . #\u+07e0) + ("Nko_Letter_Ma" . #\u+07e1) + ("Nko_Letter_Nya" . #\u+07e2) + ("Nko_Letter_Na" . #\u+07e3) + ("Nko_Letter_Ha" . #\u+07e4) + ("Nko_Letter_Wa" . #\u+07e5) + ("Nko_Letter_Ya" . #\u+07e6) + ("Nko_Letter_Nya_Woloso" . #\u+07e7) + ("Nko_Letter_Jona_Ja" . #\u+07e8) + ("Nko_Letter_Jona_Cha" . #\u+07e9) + ("Nko_Letter_Jona_Ra" . #\u+07ea) + ("Nko_Combining_Short_High_Tone" . #\u+07eb) + ("Nko_Combining_Short_Low_Tone" . #\u+07ec) + ("Nko_Combining_Short_Rising_Tone" . #\u+07ed) + ("Nko_Combining_Long_Descending_Tone" . #\u+07ee) + ("Nko_Combining_Long_High_Tone" . #\u+07ef) + ("Nko_Combining_Long_Low_Tone" . #\u+07f0) + ("Nko_Combining_Long_Rising_Tone" . #\u+07f1) + ("Nko_Combining_Nasalization_Mark" . #\u+07f2) + ("Nko_Combining_Double_Dot_Above" . #\u+07f3) + ("Nko_High_Tone_Apostrophe" . #\u+07f4) + ("Nko_Low_Tone_Apostrophe" . #\u+07f5) + ("Nko_Symbol_Oo_Dennen" . #\u+07f6) + ("Nko_Symbol_Gbakurunen" . #\u+07f7) + ("Nko_Comma" . #\u+07f8) + ("Nko_Exclamation_Mark" . #\u+07f9) + ("Nko_Lajanyalan" . #\u+07fa) + ("Line_Separator" . #\u+2028) + ("Paragraph_Separator" . #\u+2029) + ("Replacement_Character" . #\u+fffd) + ("Skull_And_Crossbones" . #\u+2620))) + (destructuring-bind (name . char) pair + (register-character-name name char))) + + + +;;;(NAME-CHAR name) +;;;If name has an entry in the *NAME->CHAR*, return first such entry. +;;;Otherwise, if it consists of one char, return it. +;;;Otherwise, if it consists of two chars, the first of which is ^, +;;; return %code-char(c xor 64), where c is the uppercased second char. +;;;Otherwise, if it starts with the prefix "u+" or "U+" followed by +;;; hex digits, the number denoted by those hex digits is interpreted as the +;;; unicode code of the character; if this value is less than +;;; CHAR-CODE-LIMIT, CODE-CHAR of that value is returned. +;;;Otherwise, if it consists of octal digits, the number denoted by +;;; those octal digits is interpreted as per the U+ case above. +;;;Otherwise return NIL. + + +(defun name-char (name) + "Given an argument acceptable to STRING, NAME-CHAR returns a character + whose name is that string, if one exists. Otherwise, NIL is returned." + (if (characterp name) + name + (let* ((name (string name))) + (let* ((namelen (length name))) + (declare (fixnum namelen)) + (or (gethash name *name->char*) + (if (= namelen 1) + (char name 0) + (if (and (= namelen 2) (eq (char name 0) #\^)) + (let* ((c1 (char-code (char-upcase (char name 1))))) + (if (and (>= c1 64) (< c1 96)) + (code-char (the fixnum (logxor (the fixnum c1) #x40))))) + (let* ((n 0) + (start 1)) + (declare (fixnum start)) + (or + (if (and (> namelen 1) + (or (eql (char name 0) #\U) + (eql (char name 0) #\u)) + (or (= namelen 2) + (progn + (when (eql (char name 1) #\+) + (incf start)) + t))) + (do* ((i start (1+ i))) + ((= i namelen) (if (< n char-code-limit) + (code-char n))) + (declare (fixnum i)) + (let* ((pos (position (char-upcase (char name i)) + "0123456789ABCDEF"))) + (if pos + (setq n (logior (ash n 4) pos)) + (progn + (setq n 0) + (return)))))) + (dotimes (i namelen (if (< n char-code-limit) + (code-char n))) + (let* ((code (the fixnum (- (the fixnum (char-code (char name i))) + (char-code #\0))))) + (declare (fixnum code)) + (if (and (>= code 0) + (<= code 7)) + (setq n (logior code (the fixnum (ash n 3)))) + (return))))))))))))) + +(eval-when (:compile-toplevel :load-toplevel :execute) +(defconstant wsp #.(let ((str (make-string 6 :element-type 'base-char))) + (set-schar str 0 #\Space) + (set-schar str 1 #\^I) + (set-schar str 2 #\^L) + (set-schar str 3 #\^@) + (set-schar str 4 #\^J) + (set-schar str 5 (code-char #xa0)) + str)) + +(defconstant wsp&cr #.(let ((str (make-string 7 :element-type 'base-char))) + (set-schar str 0 #\Space) + (set-schar str 1 #\^M) + (set-schar str 2 #\^I) + (set-schar str 3 #\^L) + (set-schar str 4 #\^@) + (set-schar str 5 #\^J) + (set-schar str 0 #\Space) + (set-schar str 6 (code-char #xa0)) + str)) +) + +(defun whitespacep (char) + (eql $cht_wsp (%character-attribute char (rdtab.ttab *readtable*)))) + + + +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; +;; Readtables ;; +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; + +;;; Readtable = istructure with data [1] type-table and [2] macro-char-alist +;;; Type-table is a 256 byte ivector with a type byte for each char. +;;; macro-char-alist is a list of (char . defn). The defn is either a +;;; cons of (#'read-dispatch . macro-char-alist) for +;;; dispatch macros, or it is a function or a symbol to call for simple macros. + +(defun readtablep (object) (istruct-typep object 'readtable)) + +(defun readtable-arg (object) + (if (null object) (setq object *readtable*)) + (unless (istruct-typep object 'readtable) + (report-bad-arg object 'readtable)) + object) + +(eval-when (:compile-toplevel :execute) +(def-accessors %svref + token.string + token.ipos + token.opos + token.len +) + +(defmacro with-token-buffer ((name) &body body &environment env) + (multiple-value-bind (body decls) (parse-body body env nil) + `(let* ((,name (vector (%get-token-string 16) 0 0 16 nil))) + (declare (dynamic-extent ,name)) + (unwind-protect + (locally ,@decls ,@body) + (%return-token-string ,name))))) +) + +(defun read-dispatch (stream char) + (let* ((info (cdr (assq char (rdtab.alist *readtable*))))) + (with-token-buffer (tb) + (let* ((subchar nil) + (numarg nil)) + (loop + (if (digit-char-p (setq subchar (%read-char-no-eof stream))) + (%add-char-to-token subchar tb) + (return (setq subchar (char-upcase subchar) + numarg (%token-to-number tb 10))))) + (let* ((dispfun (cdr (assq subchar (cdr info))))) ; <== WAS char + (if dispfun + (funcall dispfun stream subchar numarg) + (signal-reader-error stream "Undefined character ~S in a ~S dispatch macro." subchar char))))))) + +;;; This -really- gets initialized later in the file +(defvar %standard-readtable% + (let* ((ttab (make-array 256 :element-type '(unsigned-byte 8))) + (macs `((#\# . (,#'read-dispatch)))) + (case :upcase)) + (dotimes (i 256) (declare (fixnum i))(uvset ttab i $cht_cnst)) + (dotimes (ch (1+ (char-code #\Space))) + (uvset ttab ch $cht_wsp)) + (uvset ttab #xa0 $cht_wsp) + (uvset ttab (char-code #\\) $cht_sesc) + (uvset ttab (char-code #\|) $cht_mesc) + (uvset ttab (char-code #\#) $cht_ntmac) + (uvset ttab (char-code #\Backspace) $cht_ill) + (uvset ttab (char-code #\Rubout) $cht_ill) + (%istruct 'readtable ttab macs case))) + +(defvar %initial-readtable%) +(setq *readtable* %standard-readtable%) +(def-standard-initial-binding *readtable* ) +(queue-fixup (setq %initial-readtable% (copy-readtable *readtable*))) + +(defun copy-readtable (&optional (from *readtable*) to) + (setq from (if from (readtable-arg from) %standard-readtable%)) + (setq to (if to + (readtable-arg to) + (%istruct 'readtable + (make-array 256 :element-type '(unsigned-byte 8)) + nil (rdtab.case from)))) + (setf (rdtab.alist to) (copy-tree (rdtab.alist from))) + (setf (rdtab.case to) (rdtab.case from)) + (let* ((fttab (rdtab.ttab from)) + (tttab (rdtab.ttab to))) + (%copy-ivector-to-ivector fttab 0 tttab 0 256)) + to) + +(declaim (inline %character-attribute)) + +(defun %character-attribute (char attrtab) + (declare (character char) + (type (simple-array (unsigned-byte 8) (256)) attrtab) + (optimize (speed 3) (safety 0))) + (let* ((code (char-code char))) + (declare (fixnum code)) + (if (< code 256) + (aref attrtab code) + ;; Should probably have an extension mechanism for things + ;; like NBS. + $cht_cnst))) + +;;; returns: (values attrib ), where +;;; = (char . fn), if terminating macro +;;; = (char . (fn . dispatch-alist)), if dispatching macro +;;; = nil otherwise + + +(defun %get-readtable-char (char &optional (readtable *readtable*)) + (setq char (require-type char 'character)) + (let* ((attr (%character-attribute char (rdtab.ttab readtable)))) + (declare (fixnum attr)) + (values attr (if (logbitp $cht_macbit attr) (assoc char (rdtab.alist readtable)))))) + + +(defun set-syntax-from-char (to-char from-char &optional to-readtable from-readtable) + "Causes the syntax of TO-CHAR to be the same as FROM-CHAR in the + optional readtable (defaults to the current readtable). The + FROM-TABLE defaults to the standard Lisp readtable when NIL." + (setq to-char (require-type to-char 'base-char)) + (setq from-char (require-type from-char 'base-char)) + (setq to-readtable (readtable-arg to-readtable)) + (setq from-readtable (readtable-arg (or from-readtable %initial-readtable%))) + (multiple-value-bind (from-attr from-info) (%get-readtable-char from-char from-readtable) + (let* ((new-tree (copy-tree (cdr from-info))) + (old-to-info (nth-value 1 (%get-readtable-char to-char to-readtable)))) + (without-interrupts + (if from-info + (if old-to-info + (setf (cdr old-to-info) new-tree) + (push (cons to-char new-tree) (rdtab.alist to-readtable))) + (if old-to-info + (setf (rdtab.alist to-readtable) (delq old-to-info (rdtab.alist to-readtable))))) + (if (and (= from-attr $cht_cnst) + (member to-char '(#\Newline #\Linefeed #\Page #\Return + #\Space #\Tab #\Backspace #\Rubout))) + (setf (uvref (rdtab.ttab to-readtable) (char-code to-char)) $cht_ill) + (setf (uvref (rdtab.ttab to-readtable) (char-code to-char)) from-attr))) + t))) + +(defun get-macro-character (char &optional readtable) + "Return the function associated with the specified CHAR which is a macro + character, or NIL if there is no such function. As a second value, return + T if CHAR is a macro character which is non-terminating, i.e. which can + be embedded in a symbol name." + (setq readtable (readtable-arg readtable)) + (multiple-value-bind (attr info) (%get-readtable-char char readtable) + (declare (fixnum attr) (list info)) + (let* ((def (cdr info))) + (values (if (consp def) (car def) def) + (= attr $cht_ntmac))))) + +(defun set-macro-character (char fn &optional non-terminating-p readtable) + "Causes CHAR to be a macro character which invokes FUNCTION when seen + by the reader. The NON-TERMINATINGP flag can be used to make the macro + character non-terminating, i.e. embeddable in a symbol name." + (setq char (require-type char 'base-char)) + (setq readtable (readtable-arg readtable)) + (when fn + (unless (or (symbolp fn) (functionp fn)) + (setq fn (require-type fn '(or symbol function))))) + (let* ((info (nth-value 1 (%get-readtable-char char readtable)))) + (declare (list info)) + (without-interrupts + (setf (uvref (rdtab.ttab readtable) (char-code char)) + (if (null fn) $cht_cnst (if non-terminating-p $cht_ntmac $cht_tmac))) + (if (and (null fn) info) + (setf (rdtab.alist readtable) (delete info (rdtab.alist readtable) :test #'eq)) + (if (null info) + (push (cons char fn) (rdtab.alist readtable)) + (let* ((def (cdr info))) + (if (atom def) + (setf (cdr info) fn) ; Non-dispatching + (setf (car def) fn)))))) ; Dispatching + t)) + +(defun readtable-case (readtable) + (unless (istruct-typep readtable 'readtable) + (report-bad-arg readtable 'readtable)) + (let* ((case (rdtab.case (readtable-arg readtable)))) + (if (symbolp case) + case + (%car (rassoc case (readtable-case-keywords) :test #'eq))))) + +(defun %set-readtable-case (readtable case) + (unless (istruct-typep readtable 'readtable) + (report-bad-arg readtable 'readtable)) + (check-type case (member :upcase :downcase :preserve :invert)) + (setf (rdtab.case (readtable-arg readtable)) case)) + +(defsetf readtable-case %set-readtable-case) + +(defun make-dispatch-macro-character (char &optional non-terminating-p readtable) + "Cause CHAR to become a dispatching macro character in readtable (which + defaults to the current readtable). If NON-TERMINATING-P, the char will + be non-terminating." + (setq readtable (readtable-arg readtable)) + (setq char (require-type char 'base-char)) + (let* ((info (nth-value 1 (%get-readtable-char char readtable)))) + (declare (list info)) + (without-interrupts + (setf (uvref (rdtab.ttab readtable) (char-code char)) + (if non-terminating-p $cht_ntmac $cht_tmac)) + (if info + (rplacd (cdr info) nil) + (push (cons char (cons #'read-dispatch nil)) (rdtab.alist readtable))))) + t) + +(defun get-dispatch-macro-character (disp-ch sub-ch &optional (readtable *readtable*)) + "Return the macro character function for SUB-CHAR under DISP-CHAR + or NIL if there is no associated function." + (setq readtable (readtable-arg (or readtable %initial-readtable%))) + (setq disp-ch (require-type disp-ch 'base-char)) + (setq sub-ch (char-upcase (require-type sub-ch 'base-char))) + (unless (digit-char-p sub-ch 10) + (let* ((def (cdr (nth-value 1 (%get-readtable-char disp-ch readtable))))) + (if (consp def) + (cdr (assq sub-ch (cdr def))) + (error "~A is not a dispatching macro character in ~s ." disp-ch readtable))))) + +(defun set-dispatch-macro-character (disp-ch sub-ch fn &optional readtable) + "Cause FUNCTION to be called whenever the reader reads DISP-CHAR + followed by SUB-CHAR." + (setq readtable (readtable-arg readtable)) + (setq disp-ch (require-type disp-ch 'base-char)) + (setq sub-ch (char-upcase (require-type sub-ch 'base-char))) + (when (digit-char-p sub-ch 10) + (error "subchar can't be a decimal digit - ~a ." sub-ch)) + (let* ((info (nth-value 1 (%get-readtable-char disp-ch readtable))) + (def (cdr info))) + (declare (list info)) + (unless (consp def) + (error "~A is not a dispatching macro character in ~s ." disp-ch readtable)) + (let* ((alist (cdr def)) + (pair (assq sub-ch alist))) + (if pair + (setf (cdr pair) fn) + (push (cons sub-ch fn) (cdr def)))) + t)) + + +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; +;; Reader ;; +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; + +(defvar *read-eval* t "When nil, #. signals an error.") +(defvar %read-objects% nil) +(defvar %keep-whitespace% nil) + + + + +(def-standard-initial-binding %token-strings% (%cons-pool nil)) + + +(defun %return-token-string (token) + (let* ((str (token.string token)) + (pool %token-strings%)) + (setf (token.string token) nil) + (without-interrupts + (setf (pool.data pool) + (cheap-cons str (pool.data pool)))))) + +;;;Look for an exact match, else create a simple-string. +(defun %get-token-string (len) + (declare (fixnum len)) + (without-interrupts + (do* ((pool %token-strings%) + (head (cons nil (pool.data pool))) + (prev head next) + (next (cdr prev) (cdr next))) + ((null next) + (make-string len :element-type 'base-char)) + (declare (dynamic-extent head) + (list head prev next)) + (let* ((s (car next))) + (when (= len (length s)) + (rplacd prev (cdr next)) + (setf (pool.data pool) (cdr head)) + (free-cons next) + (return s)))))) + +(defun %extend-token-string (token) + (let* ((old-string (token.string token)) + (old-length (token.len token))) + (declare (fixnum old-length)) + (let* ((new-length (the fixnum (ash old-length 1))) + (new-string (%get-token-string new-length))) + (dotimes (i old-length) + (setf (%schar new-string i) + (%schar old-string i))) + (%return-token-string token) + (setf (token.string token) new-string + (token.len token) new-length) + token))) + +(defun %add-char-to-token (char token) + (let* ((len (token.len token)) + (opos (token.opos token))) + (declare (fixnum len opos)) + (when (= opos len) + (%extend-token-string token)) + (setf (token.opos token) (the fixnum (1+ opos)) + (%schar (token.string token) opos) char))) + +(defun %string-from-token (token) + (let* ((opos (token.opos token)) + (ipos (token.ipos token)) + (tstr (token.string token)) + (len (the fixnum (- opos ipos))) + (string (make-string len :element-type 'base-char))) + (do* ((k 0 (1+ k)) + (i ipos (1+ i))) + ((= i opos) string) + (declare (fixnum i k)) + (setf (%schar string k) (%schar tstr i))))) + +(defun %next-token-char (token) + (let* ((ipos (token.ipos token))) + (declare (fixnum ipos)) + (when (< ipos (the fixnum (token.opos token))) + (setf (token.ipos token) (the fixnum (1+ ipos))) + (%schar (token.string token) ipos)))) + +(defun input-stream-arg (stream) + (cond ((null stream) *standard-input*) + ((eq stream t) *terminal-io*) + ;Otherwise, let ASK complain... + (t stream))) + +(defun %read-char-no-eof (stream) + (read-char stream)) + +(defun %next-char-and-attr (stream &optional (attrtab (rdtab.ttab *readtable*))) + (let* ((ch (read-char stream nil :eof))) + (if (eq ch :eof) + (values nil nil) + (values ch (%character-attribute ch attrtab))))) + +(defun %next-non-whitespace-char-and-attr (stream) + (let* ((attrtab (rdtab.ttab *readtable*))) + (loop + (multiple-value-bind (ch attr) (%next-char-and-attr stream attrtab) + (if (null ch) + (return (values nil nil)) + (unless (eql attr $cht_wsp) + (return (values ch attr)))))))) + +(defun %next-char-and-attr-no-eof (stream &optional (attrtab (rdtab.ttab *readtable*))) + (let* ((ch (%read-char-no-eof stream))) + (values ch (%character-attribute ch attrtab)))) + +(defun %next-non-whitespace-char-and-attr-no-eof (stream) + (let* ((attrtab (rdtab.ttab *readtable*))) + (loop + (multiple-value-bind (ch attr) (%next-char-and-attr-no-eof stream attrtab) + (declare (fixnum attr)) + (unless (= attr $cht_wsp) + (return (values ch attr))))))) + +;;; "escapes" is a list of escaped character positions, in reverse order +(defun %casify-token (token escapes) + (let* ((case (readtable-case *readtable*)) + (opos (token.opos token)) + (string (token.string token))) + (declare (fixnum opos)) + (if (and (null escapes) (eq case :upcase)) ; Most common case, pardon the pun + ; %strup is faster - boot probs tho + (dotimes (i opos) + (setf (%schar string i) (char-upcase (%schar string i)))) + (unless (eq case :preserve) + (when (eq case :invert) + (let* ((lower-seen nil) + (upper-seen nil)) + (do* ((i (1- opos) (1- i)) + (esclist escapes) + (nextesc (if esclist (pop esclist) -1))) + ((< i 0) (if upper-seen (unless lower-seen (setq case :downcase)) + (when lower-seen (setq case :upcase)))) + (declare (fixnum i nextesc)) + (if (= nextesc i) + (setq nextesc (if esclist (pop esclist) -1)) + (let* ((ch (%schar string i))) + (if (upper-case-p ch) + (setq upper-seen t) + (if (lower-case-p ch) + (setq lower-seen t)))))))) + (if (eq case :upcase) + (do* ((i (1- opos) (1- i)) + (nextesc (if escapes (pop escapes) -1))) + ((< i 0)) + (declare (fixnum i nextesc)) + (if (= nextesc i) + (setq nextesc (if escapes (pop escapes) -1)) + (setf (%schar string i) (char-upcase (%schar string i))))) + (if (eq case :downcase) + (do* ((i (1- opos) (1- i)) + (nextesc (if escapes (pop escapes) -1))) + ((< i 0)) + (declare (fixnum i nextesc)) + (if (= nextesc i) + (setq nextesc (if escapes (pop escapes) -1)) + (setf (%schar string i) (char-downcase (%schar string i))))))))))) + +;;; MCL's reader has historically treated ||:foo as a reference to the +;;; symbol FOO in the package which has the null string as its name. +;;; Some other implementations treat it as a keyword. This takes an +;;; argument indicating whether or not something was "seen" before the +;;; first colon was read, even if that thing caused no characters to +;;; be added to the token. + +(defun %token-package (token colonpos seenbeforecolon stream) + (if colonpos + (if (and (eql colonpos 0) (not seenbeforecolon)) + *keyword-package* + (let* ((string (token.string token))) + (or (%find-pkg string colonpos) + (signal-reader-error stream "Reference to unknown package ~s." (subseq string 0 colonpos))))) + *package*)) + +;;; Returns 4 values: reversed list of escaped character positions, +;;; explicit package (if unescaped ":" or "::") or nil, t iff any +;;; non-dot, non-escaped chars in token, and t if either no explicit +;;; package or "::" + +(defun %collect-xtoken (token stream 1stchar) + (let* ((escapes ()) + (nondots nil) + (explicit-package *read-suppress*) + (double-colon t) + (multi-escaped nil)) + (do* ((attrtab (rdtab.ttab *readtable*)) + (char 1stchar (read-char stream nil :eof ))) + ((eq char :eof)) + (flet ((add-note-escape-pos (char token escapes) + (push (token.opos token) escapes) + (%add-char-to-token char token) + escapes)) + (let* ((attr (%character-attribute char attrtab))) + (declare (fixnum attr)) + (when (or (= attr $cht_tmac) + (= attr $cht_wsp)) + (when (or (not (= attr $cht_wsp)) %keep-whitespace%) + (unread-char char stream)) + (return )) + (if (= attr $cht_ill) + (signal-reader-error stream "Illegal character ~S." char) + (if (= attr $cht_sesc) + (setq nondots t + escapes (add-note-escape-pos (%read-char-no-eof stream) token escapes)) + (if (= attr $cht_mesc) + (progn + (setq nondots t) + (loop + (multiple-value-bind (nextchar nextattr) (%next-char-and-attr-no-eof stream attrtab) + (declare (fixnum nextattr)) + (if (= nextattr $cht_mesc) + (return (setq multi-escaped t)) + (if (= nextattr $cht_sesc) + (setq escapes (add-note-escape-pos (%read-char-no-eof stream) token escapes)) + (setq escapes (add-note-escape-pos nextchar token escapes))))))) + (let* ((opos (token.opos token))) ; Add char to token, note 1st colonpos + (declare (fixnum opos)) + (if (and (eq char #\:) ; (package-delimiter-p char ?) + (not explicit-package)) + (let* ((nextch (%read-char-no-eof stream))) + (if (eq nextch #\:) + (setq double-colon t) + (progn + (unread-char nextch stream) + (setq double-colon nil))) + (%casify-token token escapes) + (setq explicit-package (%token-package token opos nondots stream) + nondots t + escapes nil) + (setf (token.opos token) 0)) + (progn + (unless (eq char #\.) (setq nondots t)) + (%add-char-to-token char token)))))))))) + (values (or escapes multi-escaped) (if *read-suppress* nil explicit-package) nondots double-colon))) + +(defun %validate-radix (radix) + (if (and (typep radix 'fixnum) + (>= (the fixnum radix) 2) + (<= (the fixnum radix) 36)) + radix + (progn + (check-type radix (integer 2 36)) + radix))) + +(defun %token-to-number (token radix &optional no-rat) + (new-numtoken (token.string token) (token.ipos token) (token.opos token) radix no-rat)) + +;;; If we're allowed to have a single "." in this context, DOT-OK is some distinguished +;;; value that's returned to the caller when exactly one dot is present. +(defun %parse-token (stream firstchar dot-ok) + (with-token-buffer (tb) + (multiple-value-bind (escapes explicit-package nondots double-colon) (%collect-xtoken tb stream firstchar) + (unless *read-suppress* + (let* ((string (token.string tb)) + (len (token.opos tb))) + (declare (fixnum len)) + (if (not nondots) + (if (= len 1) + (or dot-ok + (signal-reader-error stream "Dot context error in ~s." (%string-from-token tb))) + (signal-reader-error stream "Illegal symbol syntax in ~s." (%string-from-token tb))) + ;; Something other than a buffer full of dots. Thank god. + (let* ((num (if (null escapes) + (handler-case + (%token-to-number tb (%validate-radix *read-base*)) + (arithmetic-error (c) + (error 'impossible-number + :stream stream + :token (%string-from-token tb) + :condition c)))))) + (if (and num (not explicit-package)) + num + (if (and (zerop len) (null escapes)) + (%err-disp $XBADSYM) + (progn ; Muck with readtable case of extended token. + (%casify-token tb (unless (atom escapes) escapes)) + (let* ((pkg (or explicit-package *package*))) + (if (or double-colon (eq pkg *keyword-package*)) + (without-interrupts + (multiple-value-bind (symbol access internal-offset external-offset) + (%find-symbol string len pkg) + (if access + symbol + (%add-symbol (%string-from-token tb) pkg internal-offset external-offset)))) + (multiple-value-bind (found symbol) (%get-htab-symbol string len (pkg.etab pkg)) + (if found + symbol + (let* ((token (%string-from-token tb)) + (symbol (find-symbol token pkg))) + (with-simple-restart (continue + "~:[Create and use the internal symbol ~a::~a~;Use the internal symbol ~:*~s~]" + symbol (package-name pkg) token) + (%err-disp $XNOESYM token pkg)) + (or symbol (intern token pkg))))))))))))))))) + +#| +(defun %parse-token-test (string &key dot-ok (case (readtable-case *readtable*))) + (let* ((stream (make-string-input-stream string)) + (oldcase (readtable-case *readtable*))) + (unwind-protect + (progn + (setf (readtable-case *readtable*) case) + (%parse-token stream (read-char stream t) dot-ok)) + (setf (readtable-case *readtable*) oldcase)))) + +(%parse-token-test "ABC") +(%parse-token-test "TRAPS::_DEBUGGER") +(%parse-token-test "3.14159") +(ignore-errors (%parse-token-test "BAD-PACKAGE:WORSE-SYMBOL")) +(ignore-errors (%parse-token-test "CCL::")) +(%parse-token-test "TRAPS::_debugger" :case :preserve) +(%parse-token-test ":foo") +|# + +;;; firstchar must not be whitespace. +;;; People who think that there's so much overhead in all of +;;; this (multiple-value-list, etc.) should probably consider +;;; rewriting those parts of the CLOS and I/O code that make +;;; using things like READ-CHAR impractical... + +;;; mb: the reason multiple-value-list is used here is that we need to distunguish between the +;;; recursive parse call returning (values nil) and (values). +(defun %parse-expression (stream firstchar dot-ok) + (let* ((readtable *readtable*) + (attrtab (rdtab.ttab readtable)) + (attr (%character-attribute firstchar attrtab)) + (start-pos (stream-position stream))) + (declare (fixnum attr)) + (when (eql attr $cht_ill) + (signal-reader-error stream "Illegal character ~S." firstchar)) + (let* ((vals (multiple-value-list + (if (not (logbitp $cht_macbit attr)) + (%parse-token stream firstchar dot-ok) + (let* ((def (cdr (assq firstchar (rdtab.alist readtable))))) + (cond ((null def)) + ((atom def) + (funcall def stream firstchar)) + #+no ; include if %initial-readtable% broken (see above) + ((and (consp (car def)) + (eq (caar def) 'function)) + (funcall (cadar def) stream firstchar)) + ((functionp (car def)) + (funcall (car def) stream firstchar)) + (t (error "Bogus default dispatch fn: ~S" (car def)) nil)))))) + (end-pos (and start-pos (stream-position stream)))) + (declare (dynamic-extent vals) + (list vals)) + (if (null vals) + (values nil nil) + (destructuring-bind (form &optional nested-source-notes) + vals + ;; Can't really trust random reader macros to return source notes... + (unless (and (consp nested-source-notes) + (source-note-p (car nested-source-notes))) + (setq nested-source-notes nil)) + (values form + t + (and start-pos + (record-source-note :form form + :stream stream + :start-pos (1- start-pos) + :end-pos end-pos + :subform-notes nested-source-notes)))))))) + +#| +(defun %parse-expression-test (string) + (let* ((stream (make-string-input-stream string))) + (%parse-expression stream (read-char stream t) nil))) + +(%parse-expression-test ";hello") +(%parse-expression-test "#'cdr") +(%parse-expression-test "#+foo 1 2") + +|# + +(defun %read-list-expression (stream dot-ok &optional (termch #\))) + (loop + (let* ((firstch (%next-non-whitespace-char-and-attr-no-eof stream))) + (if (eq firstch termch) + (return (values nil nil nil)) + (multiple-value-bind (val val-p source-info) + (%parse-expression stream firstch dot-ok) + (if val-p + (return (values val t source-info)))))))) + +(defun read-list (stream &optional nodots (termch #\))) + (let* ((dot-ok (cons nil nil)) + (head (cons nil nil)) + (tail head) + (source-note-list nil)) + (declare (dynamic-extent dot-ok head) + (list head tail)) + (if nodots (setq dot-ok nil)) + (multiple-value-bind (firstform firstform-p firstform-source-note) + (%read-list-expression stream dot-ok termch) + (when firstform-source-note + (push firstform-source-note source-note-list)) + (when firstform-p + (if (and dot-ok (eq firstform dot-ok)) ; just read a dot + (signal-reader-error stream "Dot context error.")) + (rplacd tail (setq tail (cons firstform nil))) + (loop + (multiple-value-bind (nextform nextform-p nextform-source-note) + (%read-list-expression stream dot-ok termch) + (when nextform-source-note + (push nextform-source-note source-note-list)) + (if (not nextform-p) (return)) + (if (and dot-ok (eq nextform dot-ok)) ; just read a dot + (if (multiple-value-bind (lastform lastform-p lastform-source-note) + (%read-list-expression stream nil termch) + (when lastform-source-note + (push lastform-source-note source-note-list)) + (and lastform-p + (progn (rplacd tail lastform) + (not (nth-value 1 (%read-list-expression stream nil termch)))))) + (return) + (signal-reader-error stream "Dot context error.")) + (rplacd tail (setq tail (cons nextform nil)))))))) + (values (cdr head) source-note-list))) + +#| +(defun read-list-test (string &optional nodots) + (read-list (make-string-input-stream string) nodots)) + +(read-list-test ")") +(read-list-test "a b c)" t) +(read-list-test "a b ;hello +c)" t) + +|# + +(set-macro-character + #$ + #'(lambda (stream ignore) + (declare (ignore ignore)) + (read-list stream nil #$))) + +(set-macro-character + #\' + (nfunction |'-reader| + (lambda (stream ignore) + (declare (ignore ignore)) + (multiple-value-bind (form source-note) + (read-internal stream t nil t) + (values `(quote ,form) (and source-note (list source-note))))))) + +(defparameter *alternate-line-terminator* + #+darwin-target #\Return + #-darwin-target nil + "This variable is currently only used by the standard reader macro +function for #\; (single-line comments); that function reads successive +characters until EOF, a #\NewLine is read, or a character EQL to the value +of *alternate-line-terminator* is read. In Clozure CL for Darwin, the value +of this variable is initially #\Return ; in Clozure CL for other OSes, it's +initially NIL.") + +(set-macro-character + #\; + (nfunction |;-reader| + (lambda (stream ignore) + (declare (ignore ignore)) + (let* ((ch nil)) + (loop + (if (or (eq :eof (setq ch (read-char stream nil :eof))) + (eq ch #\NewLine) + (eq ch *alternate-line-terminator*)) + (return (values)))))))) + +(defun read-string (stream termch) + (with-token-buffer (tb) + (do* ((attrs (rdtab.ttab *readtable*)) + (ch (%read-char-no-eof stream) + (%read-char-no-eof stream))) + ((eq ch termch) + (%string-from-token tb)) + (if (= (the fixnum (%character-attribute ch attrs)) $CHT_SESC) + (setq ch (%read-char-no-eof stream))) + (%add-char-to-token ch tb)))) + +(set-macro-character #\" #'read-string) + +(defparameter *ignore-extra-close-parenthesis* nil) + +(set-macro-character + #\) + #'(lambda (stream ch) + (let* ((pos (if (typep stream 'file-stream) + (file-position stream)))) + (if *ignore-extra-close-parenthesis* + (warn "Ignoring extra \"~c\" ~@[near position ~d~] on ~s ." ch pos stream) + (signal-reader-error stream "Unmatched ')' ~@[near position ~d~]." pos))))) + + + + +(eval-when (:load-toplevel) ; But not when mousing around! + (make-dispatch-macro-character #\# t)) + + +(set-dispatch-macro-character + #\# + #\( + (nfunction + |#(-reader| + (lambda (stream subchar numarg) + (declare (ignore subchar)) + (if (or (null numarg) *read-suppress*) + (multiple-value-bind (lst notes) (read-list stream t) + (let* ((len (length lst)) + (vec (make-array len))) + (declare (list lst) (fixnum len) (simple-vector vec)) + (dotimes (i len) + (setf (svref vec i) (pop lst))) + (values vec notes))) + (locally + (declare (fixnum numarg)) + (do* ((vec (make-array numarg)) + (notes ()) + (lastform) + (i 0 (1+ i))) + ((multiple-value-bind (form form-p source-info) + (%read-list-expression stream nil) + (if form-p + (progn + (setq lastform form) + (when source-info (push source-info notes))) + (unless (= i numarg) + (if (= i 0) + (%err-disp $XARROOB -1 vec) + (do* ((j i (1+ j))) + ((= j numarg)) + (declare (fixnum j)) + (setf (svref vec j) lastform))))) + (not form-p)) + (values vec notes)) + (declare (fixnum i)) + (setf (svref vec i) lastform))))))) + +(defun %read-rational (stream subchar radix) + (declare (ignore subchar)) + (with-token-buffer (tb) + (multiple-value-bind (escapes xpackage) + (%collect-xtoken tb stream (%next-non-whitespace-char-and-attr-no-eof stream)) + (unless *read-suppress* + (let* ((val (%token-to-number tb radix))) + (or (and (null escapes) + (null xpackage) + (typep val 'rational) + val) + (%err-disp $xbadnum))))))) + +(defun require-numarg (subchar numarg) + (or numarg *read-suppress* + (error "Numeric argument required for #~A reader macro ." subchar))) + +(defun require-no-numarg (subchar numarg) + (if (and numarg (not *read-suppress*)) + (error "Spurious numeric argument in #~D~A reader macro ." numarg subchar))) + +(defun read-eval (stream subchar numarg) + (require-no-numarg subchar numarg) + (if *read-eval* + (let* ((exp (%read-list-expression stream nil))) + (unless *read-suppress* + (eval exp))) + (signal-reader-error stream "#. reader macro invoked when ~S is false ." + '*read-eval*))) + +(set-dispatch-macro-character + #\# + #\C + #'(lambda (stream char arg) + (require-no-numarg char arg ) + (multiple-value-bind (form note) (read-internal stream t nil t) + (values (unless *read-suppress* (apply #'complex form)) (and note (list note)))))) + +(set-dispatch-macro-character + #\# + #\. + #'read-eval) + +;;; Read a valid, non-numeric token string from stream; *READ-SUPPRESS* +;;; is known to be false. +(defun read-symbol-token (stream) + (multiple-value-bind (firstch attr) (%next-non-whitespace-char-and-attr-no-eof stream) + (declare (fixnum attr)) + (with-token-buffer (tb) + (if (or (= attr $CHT_ILL) + (logbitp $cht_macbit attr) + (multiple-value-bind (escapes explicit-package nondots) (%collect-xtoken tb stream firstch) + (declare (ignore nondots)) + (%casify-token tb (unless (atom escapes) escapes)) + (or explicit-package + (and (not escapes) + (%token-to-number tb (%validate-radix *read-base*)))))) + (%err-disp $XBADSYM) + (%string-from-token tb))))) + +(set-dispatch-macro-character + #\# + #\: + #'(lambda (stream subchar numarg) + (require-no-numarg subchar numarg) + (if (not *read-suppress*) + (make-symbol (read-symbol-token stream)) + (progn + (%read-list-expression stream nil) + nil)))) + +(set-dispatch-macro-character + #\# + #\b + #'(lambda (stream subchar numarg) + (require-no-numarg subchar numarg) + (%read-rational stream subchar 2))) + +(set-dispatch-macro-character + #\# + #\o + #'(lambda (stream subchar numarg) + (require-no-numarg subchar numarg) + (%read-rational stream subchar 8))) + +(set-dispatch-macro-character + #\# + #\x + #'(lambda (stream subchar numarg) + (require-no-numarg subchar numarg) + (%read-rational stream subchar 16))) + +(set-dispatch-macro-character + #\# + #\r + #'(lambda (stream subchar numarg) + (unless *read-suppress* + (require-numarg subchar numarg) + (check-type numarg (integer 2 36))) + (%read-rational stream subchar numarg))) + +(set-dispatch-macro-character + #\# + #\' + (nfunction |#'-reader| + (lambda (stream subchar numarg) + (require-no-numarg subchar numarg) + (multiple-value-bind (form note) (read-internal stream t nil t) + (values `(function ,form) (and note (list note))))))) + +(set-dispatch-macro-character + #\# + #\| + (nfunction |#\|-reader| + (lambda (stream subchar numarg) + (require-no-numarg subchar numarg) + (do* ((lastch nil ch) + (ch ) + (level 1)) + ((= level 0) (values)) + (declare (fixnum level)) + (setq ch (%read-char-no-eof stream)) + (if (and (eq ch #\|) + (eq lastch #\#)) + (progn + (setq ch nil) + (incf level)) + (if (and (eq ch #\#) + (eq lastch #\|)) + (progn + (setq ch nil) + (decf level)))))))) + +(defun %unreadable (stream description) + (signal-reader-error stream "~S encountered." description)) + +(set-dispatch-macro-character + #\# + #\< + #'(lambda (stream &rest ignore) + (declare (ignore ignore)) + (%unreadable stream "#<"))) + +(dolist (ch '(#\null #\tab #\linefeed #\page #\return #\space #\312)) + (set-dispatch-macro-character + #\# + ch + #'(lambda (stream &rest ignore) + (declare (ignore ignore)) + (%unreadable stream "#")))) + +(set-dispatch-macro-character + #\# + #\) + #'(lambda (stream &rest ignore) + (declare (ignore ignore)) + (%unreadable stream "#)"))) + +(set-dispatch-macro-character + #\# + #\\ + #'(lambda (stream subchar numarg) + (require-no-numarg subchar numarg) + (with-token-buffer (tb) + (%collect-xtoken tb stream #\\) + (unless *read-suppress* + (let* ((str (%string-from-token tb))) + (or (name-char str) + (error "Unknown character name - \"~a\" ." str))))))) + + + +;;;Since some built-in read macros used to use internal reader entry points +;;;for efficiency, we couldn't reliably offer a protocol for stream-dependent +;;;recursive reading. So recursive reads always get done via tyi's, and streams +;;;only get to intercept toplevel reads. +(defun read (&optional stream (eof-error-p t) eof-value recursive-p) + (declare (resident)) + ;; just return the first value of read-internal + (values (read-internal stream eof-error-p eof-value recursive-p))) + +(defun read-internal (stream eof-error-p eof-value recursive-p) + (setq stream (input-stream-arg stream)) + (if recursive-p + (%read-form stream (if eof-error-p 0) nil) + (let ((%read-objects% nil) (%keep-whitespace% nil)) + (%read-form stream (if eof-error-p 0) eof-value)))) + +(defun read-preserving-whitespace (&optional stream (eof-error-p t) eof-value recursive-p) + "Read from STREAM and return the value read, preserving any whitespace + that followed the object." + (setq stream (input-stream-arg stream)) + (values + (if recursive-p + (%read-form stream 0 nil) + (let ((%read-objects% nil) (%keep-whitespace% t)) + (%read-form stream (if eof-error-p 0) eof-value))))) + + +(defun read-delimited-list (char &optional stream recursive-p) + "Read Lisp values from INPUT-STREAM until the next character after a + value's representation is CHAR, and return the objects as a list." + (setq char (require-type char 'character)) + (setq stream (input-stream-arg stream)) + (values + (let ((%keep-whitespace% nil)) + (if recursive-p + (%read-form stream char nil) + (let ((%read-objects% nil)) + (%read-form stream char nil)))))) + +(defun read-conditional (stream subchar int) + (declare (ignore int)) + (cond ((eq subchar (read-feature stream)) + (multiple-value-bind (form note) (read-internal stream t nil t) + (values form (and note (list note))))) + (t (let* ((*read-suppress* t)) + (read stream t nil t) + (values))))) + +(defun read-feature (stream) + (let* ((f (let* ((*package* *keyword-package*)) + (read stream t nil t)))) + (labels ((eval-feature (form) + (cond ((atom form) + (member form *features*)) + ((eq (car form) :not) + (not (eval-feature (cadr form)))) + ((eq (car form) :and) + (dolist (subform (cdr form) t) + (unless (eval-feature subform) (return)))) + ((eq (car form) :or) + (dolist (subform (cdr form) nil) + (when (eval-feature subform) (return t)))) + (t (%err-disp $XRDFEATURE form))))) + (if (eval-feature f) #\+ #\-)))) + +(set-dispatch-macro-character #\# #\+ #'read-conditional) +(set-dispatch-macro-character #\# #\- #'read-conditional) + +(defun %read-form (stream arg eof-val) + "Read a lisp form from STREAM + +arg=0 : read form, error if eof +arg=nil : read form, eof-val if eof. +arg=char : read delimited list" + (declare (resident)) + (check-type *readtable* readtable) + (check-type *package* package) + (if (and arg (not (eq arg 0))) + (read-list stream nil arg) + (loop + (let* ((ch (%next-non-whitespace-char-and-attr stream))) + (if (null ch) + (if arg + (error 'end-of-file :stream stream) + (return eof-val)) + (multiple-value-bind (form form-p source-note) + (%parse-expression stream ch nil) + (when form-p + (return + (values (if *read-suppress* nil form) + source-note))))))))) + +;;;Until load backquote... +(set-macro-character #\` + #'(lambda (stream char) (declare (ignore stream)) (%err-disp $xbadmac char))) +(set-macro-character #\, (get-macro-character #\`)) + + + +(set-dispatch-macro-character #\# #\P + (qlfun |#P-reader| (stream char flags &aux (invalid-string "Invalid flags (~S) for pathname ~S")) + (declare (ignore char)) + (when (null flags) (setq flags 0)) + (unless (memq flags '(0 1 2 3 4)) + (unless *read-suppress* (report-bad-arg flags '(integer 0 4)))) + (multiple-value-bind (path note) (read-internal stream t nil t) + (unless *read-suppress* + (unless (stringp path) (report-bad-arg path 'string)) + (setq path (pathname path)) + (when (%ilogbitp 0 flags) + (when (%pathname-type path) (error invalid-string flags path)) + (setf (%pathname-type path) :unspecific)) + (when (%ilogbitp 1 flags) + (when (%pathname-name path) (error invalid-string flags path)) + (setf (%pathname-name path) "")) + (values path (and note (list note))))))) + + +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; + +(defstruct (source-note (:conc-name "SOURCE-NOTE.") (:constructor %make-source-note)) + ;; For an inner source form, the source-note of the outer source form. + ;; For outer source note, octets + source + filename + ;; start and end file positions (NOT characters positions) + file-range) + +(defun make-source-note (&key filename start-pos end-pos source) + (%make-source-note :filename filename + :file-range (encode-file-range start-pos end-pos) + :source source)) + +(defmethod print-object ((sn source-note) stream) + (print-unreadable-object (sn stream :type t :identity nil) + (print-source-note sn stream))) + +(defun print-source-note (sn stream) + (let* ((file (source-note-filename sn)) + (text (ignore-errors (source-note-text sn)))) + (when file + ;; Should fix this when record the name. + (when (eq (pathname-version file) :newest) + (setq file (namestring (make-pathname :version nil :defaults file))))) + (when text + (setq text (string-sans-most-whitespace text 121)) + (when (> (length text) 120) + (setq text (concatenate 'string (subseq text 0 120) "...")))) + (if file + (format stream "*~s:~s-~s ~s" file + (source-note-start-pos sn) (source-note-end-pos sn) + text) + (format stream "Interactive ~s" text)))) + +(defun source-note-filename (source) + (if (source-note-p source) + (source-note.filename source) + ;; else null or a pathname, as in record-source-file + source)) + +(defun (setf source-note-filename) (filename source-note) + (setf (source-note.filename (require-type source-note 'source-note)) filename)) + +;; Since source notes are optional, it simplifies a lot of code +;; to have these accessors allow NIL. + +(defun source-note-source (source-note) + (when source-note + (source-note.source (require-type source-note 'source-note)))) + +(defun source-note-file-range (source-note) + (when source-note + (source-note.file-range (require-type source-note 'source-note)))) + +(defun source-note-start-pos (source-note) + (let ((range (source-note-file-range source-note))) + (when range + (if (consp range) (car range) (ash range -14))))) + +(defun source-note-end-pos (source-note) + (let ((range (source-note-file-range source-note))) + (when range + (if (consp range) (cdr range) (+ (ash range -14) (logand range #x3FFF)))))) + +(defun encode-file-range (start-pos end-pos) + (let ((len (- end-pos start-pos))) + (if (< len (ash 1 14)) + (+ (ash start-pos 14) len) + (cons start-pos end-pos)))) + +(defun source-note-text (source-note &optional start end) + (when source-note + (let* ((source (source-note-source source-note)) + (start-pos (source-note-start-pos source-note)) + (end-pos (source-note-end-pos source-note)) + (start (or start start-pos)) + (end (or end end-pos))) + (etypecase source + (source-note + (assert (<= (source-note-start-pos source) start end (source-note-end-pos source))) + (source-note-text source start end)) + ((simple-array (unsigned-byte 8) (*)) + (decf start start-pos) + (decf end start-pos) + (assert (and (<= 0 start end (length source)))) + (decode-string-from-octets source :start start :end end :external-format :utf-8)) + (null source))))) + +(defun source-note-toplevel-note (source-note) + (when source-note + (loop for source = (source-note-source source-note) + while (source-note-p source) + do (setq source-note source)) + source-note)) + +(defvar *recording-source-streams* ()) + +(defun record-source-note (&key form stream start-pos end-pos subform-notes) + (let ((recording (assq stream *recording-source-streams*))) + (when (and recording (not *read-suppress*)) + (destructuring-bind (map file-name stream-offset) (cdr recording) + (let* ((prev (gethash form map)) + (note (make-source-note :filename file-name + :start-pos (+ stream-offset start-pos) + :end-pos (+ stream-offset end-pos)))) + (setf (gethash form map) + (cond ((null prev) note) + ((consp prev) (cons note prev)) + (t (list note prev)))) + (loop for subnote in subform-notes + do (when (source-note-source subnote) (error "Subnote ~s already owned?" subnote)) + do (setf (source-note.source subnote) note)) + note))))) + +(defun read-recording-source (stream &key eofval file-name start-offset map save-source-text) + "Read a top-level form, perhaps recording source locations. +If MAP is NIL, just reads a form as if by READ. +If MAP is non-NIL, returns a second value of a source-note object describing the form. +In addition, if MAP is a hash table, it gets filled with source-note's for all +non-atomic nested subforms." + (when (null start-offset) (setq start-offset 0)) + (typecase map + (null (values (read-internal stream nil eofval nil) nil)) + (hash-table + (let* ((stream (recording-input-stream stream)) + (recording (list stream map file-name start-offset)) + (*recording-source-streams* (cons recording *recording-source-streams*))) + (declare (dynamic-extent recording *recording-source-streams*)) + (multiple-value-bind (form source-note) (read-internal stream nil eofval nil) + (when (and source-note (not (eq form eofval))) + (assert (null (source-note-source source-note))) + (loop for form being the hash-key using (hash-value note) of map + do (cond ((eq note source-note) nil) + ;; Remove entries with multiple source notes, which can happen + ;; for atoms. If we can't tell which instance we mean, then we + ;; don't have useful source info. + ((listp note) (remhash form map)) + ((loop for p = note then (source-note-source p) while (source-note-p p) + thereis (eq p source-note)) + ;; Flatten the backpointers so each subnote points directly + ;; to the toplevel note. + (setf (source-note.source note) source-note)))) + (when save-source-text + (setf (source-note.source source-note) + (fetch-octets-from-stream stream + (- (source-note-start-pos source-note) + start-offset) + (- (source-note-end-pos source-note) + start-offset))))) + (values form source-note)))) + (T ;; not clear if this is ever useful + (let* ((start-pos (stream-position stream)) + (form (read-internal stream nil eofval nil)) + (end-pos (and start-pos (neq form eofval) (stream-position stream))) + (source-note (and end-pos + (make-source-note :filename file-name + :start-pos (+ start-offset start-pos) + :end-pos (+ start-offset end-pos))))) + (when (and source-note save-source-text) + (setf (source-note.source source-note) (fetch-octets-from-stream stream start-pos end-pos))) + (values form source-note))))) + +(defmethod fetch-octets-from-stream ((stream input-stream) start-offset end-offset) + ;; We basically want to read the bytes between two positions, but there is no + ;; direct interface for that. So we let the stream decode and then we re-encode. + ;; (Just as well, since otherwise we'd have to remember the file's encoding). + (declare (fixnum start-offset)) + (when (< start-offset end-offset) + (let* ((cur-pos (stream-position stream)) + (noctets (- end-offset start-offset)) + (vec (make-array noctets :element-type '(unsigned-byte 8))) + (index 0) + (crlfp (eq :crlf + (cdr (assoc (external-format-line-termination + (stream-external-format stream)) + *canonical-line-termination-conventions*))))) + (declare (type fixnum end-offset noctets index) + (type (simple-array (unsigned-byte 8) (*)) vec)) + (macrolet ((out (code) + `(progn + (setf (aref vec index) ,code) + (when (eql (incf index) noctets) (return))))) + (stream-position stream start-offset) + (loop + (let ((code (char-code (read-char stream)))) + (declare (fixnum code)) + (cond ((< code #x80) + (when (and crlfp (= code (char-code #\NewLine))) + (out (char-code #\Return))) + (out code)) + ((< code #x800) + (out (logior #xc0 (ldb (byte 5 6) code))) + (out (logior #x80 (ldb (byte 6 0) code)))) + ((< code #x10000) + (out (logior #xe0 (ldb (byte 4 12) code))) + (out (logior #x80 (ldb (byte 6 6) code))) + (out (logior #x80 (ldb (byte 6 0) code)))) + (t + (out (logior #xf0 (ldb (byte 3 18) code))) + (out (logior #xe0 (ldb (byte 6 12) code))) + (out (logior #x80 (ldb (byte 6 6) code))) + (out (logior #x80 (ldb (byte 6 0) code)))))))) + (stream-position stream cur-pos) + vec))) + +(defun ensure-source-note-text (source-note &key (if-does-not-exist nil)) + "Fetch source text from file if don't have it" + (setq if-does-not-exist (require-type if-does-not-exist '(member :error nil))) + (if source-note + (let ((source (source-note-source source-note)) + (filename (source-note-filename source-note))) + (etypecase source + (null + (if filename + (with-open-file (stream filename :if-does-not-exist if-does-not-exist) + (when stream + (let ((start (source-note-start-pos source-note)) + (end (source-note-end-pos source-note)) + (len (file-length stream))) + (if (<= end len) + (setf (source-note.source source-note) + (fetch-octets-from-stream stream start end)) + (when if-does-not-exist + (error 'simple-file-error :pathname filename + :error-type "File ~s changed since source info recorded")))))) + (when if-does-not-exist + (error "Missing source text in internative source note")))) + (source-note + (ensure-source-note-text source)) + ((simple-array (unsigned-byte 8) (*)) + source))) + (when if-does-not-exist + (error "Missing source note")))) + + +;; This can be called explicitly by macros that do more complicated transforms +(defun note-source-transformation (original new) + (nx-note-source-transformation original new)) + + +;;; Wrapper stream for recording source of non-random-access streams. +(defclass recording-character-input-stream (fundamental-stream character-input-stream) + ((input-stream :initarg :input-stream) + (string :initform (make-array 1024 :element-type 'character :fill-pointer 0 :adjustable t)))) + +(defmethod stream-element-type ((s recording-character-input-stream)) + (with-slots (input-stream) s + (stream-element-type input-stream))) + +(defmethod stream-read-char ((s recording-character-input-stream)) + (with-slots (input-stream string) s + (let ((char (stream-read-char input-stream))) + (when (and char (neq char :eof)) + (vector-push-extend char string)) + char))) + +(defmethod stream-read-char-no-hang ((s recording-character-input-stream)) + (with-slots (input-stream string) s + (let ((char (stream-read-char-no-hang input-stream))) + (when (and char (neq char :eof)) + (vector-push-extend char string)) + char))) + +(defmethod stream-peek-char ((s recording-character-input-stream)) + (with-slots (input-stream) s + (stream-peek-char input-stream))) + +(defmethod stream-listen ((s recording-character-input-stream)) + (with-slots (input-stream) s + (stream-listen input-stream))) + +(defmethod stream-read-line ((s recording-character-input-stream)) + (generic-read-line s)) + +(defmethod stream-read-list ((s recording-character-input-stream) list count) + (generic-character-read-list s list count)) + +(defmethod stream-read-vector ((s recording-character-input-stream) vector start end) + (generic-character-read-vector s vector start end)) + +(defmethod stream-unread-char ((s recording-character-input-stream) char) + (with-slots (input-stream string) s + (vector-pop string) ;; Error if no characters read since last reset. + (stream-unread-char input-stream char))) + +(defmethod stream-eofp ((s recording-character-input-stream)) + (with-slots (input-stream) s + (stream-eofp input-stream))) + +(defmethod stream-clear-input ((s recording-character-input-stream)) + (with-slots (input-stream) s + (stream-clear-input input-stream))) + +(defmethod stream-position ((s recording-character-input-stream) &optional newpos) + (with-slots (string) s + (unless newpos + (fill-pointer string)))) + +(defun recording-input-stream (stream) + (let ((pos (stream-position stream))) + (if (and pos (stream-position stream pos)) + stream + (make-instance 'recording-character-input-stream :input-stream stream)))) + +(defmethod fetch-octets-from-stream ((s recording-character-input-stream) start-offset end-offset) + (declare (fixnum start-offset end-offset)) + (with-slots (string) s + (when (< start-offset end-offset) + (let* ((sstring (array-data-and-offset string)) + (noctets (loop for i fixnum from start-offset below end-offset + as code fixnum = (%char-code (%schar sstring i)) + sum (cond ((< code #x80) 1) + ((< code #x800) 2) + ((< code #x10000) 3) + (t 4)) + of-type fixnum)) + (vec (make-array noctets :element-type '(unsigned-byte 8))) + (index 0)) + (declare (type fixnum noctets index) + (type simple-base-string sstring) + (type (simple-array (unsigned-byte 8) (*)) vec)) + (macrolet ((out (octet) `(progn + (setf (aref vec index) ,octet) + (incf index)))) + (loop for i fixnum from start-offset below end-offset + as code fixnum = (%char-code (%schar sstring i)) + do (cond ((< code #x80) + (out code)) + ((< code #x800) + (out (logior #xc0 (ldb (byte 5 6) code))) + (out (logior #x80 (ldb (byte 6 0) code)))) + ((< code #x10000) + (out (logior #xe0 (ldb (byte 4 12) code))) + (out (logior #x80 (ldb (byte 6 6) code))) + (out (logior #x80 (ldb (byte 6 0) code)))) + (t + (out (logior #xf0 (ldb (byte 3 18) code))) + (out (logior #xe0 (ldb (byte 6 12) code))) + (out (logior #x80 (ldb (byte 6 6) code))) + (out (logior #x80 (ldb (byte 6 0) code))))))) + (setf (fill-pointer string) 0) ;; reset + vec)))) + + + + +; end Index: /branches/new-random/level-1/l1-readloop-lds.lisp =================================================================== --- /branches/new-random/level-1/l1-readloop-lds.lisp (revision 13309) +++ /branches/new-random/level-1/l1-readloop-lds.lisp (revision 13309) @@ -0,0 +1,727 @@ +;;;-*-Mode: LISP; Package: CCL -*- +;;; +;;; Copyright (C) 2009 Clozure Associates +;;; Copyright (C) 1994-2001 Digitool, Inc +;;; This file is part of Clozure CL. +;;; +;;; Clozure CL is licensed under the terms of the Lisp Lesser GNU Public +;;; License , known as the LLGPL and distributed with Clozure CL as the +;;; file "LICENSE". The LLGPL consists of a preamble and the LGPL, +;;; which is distributed with Clozure CL as the file "LGPL". Where these +;;; conflict, the preamble takes precedence. +;;; +;;; Clozure CL is referenced in the preamble as the "LIBRARY." +;;; +;;; The LLGPL is also available online at +;;; http://opensource.franz.com/preamble.html + +; l1-readloop-lds.lisp + +(in-package "CCL") + + + +(defun toplevel-loop () + (loop + (if (eq (catch :toplevel + (read-loop :break-level 0 )) $xstkover) + (format t "~&;[Stacks reset due to overflow.]") + (when (eq *current-process* *initial-process*) + (toplevel))))) + + +(defvar *defined-toplevel-commands* ()) +(defvar *active-toplevel-commands* ()) + +(defun %define-toplevel-command (group-name key name fn doc args) + (let* ((group (or (assoc group-name *defined-toplevel-commands*) + (car (push (list group-name) + *defined-toplevel-commands*)))) + (pair (assoc key (cdr group) :test #'eq))) + (if pair + (rplacd pair (list* fn doc args)) + (push (cons key (list* fn doc args)) (cdr group)))) + name) + +(define-toplevel-command + :global y (&optional p) "Yield control of terminal-input to process +whose name or ID matches
, or to any process if
is null" + (%%yield-terminal-to (if p (find-process p)))) ;may be nil + + +(define-toplevel-command + :global kill (p) "Kill process whose name or ID matches
" + (let* ((proc (find-process p))) + (if proc + (process-kill proc)))) + +(define-toplevel-command + :global proc (&optional p) "Show information about specified process
/all processes" + (flet ((show-process-info (proc) + (format t "~&~d : ~a ~a ~20t[~a] " + (process-serial-number proc) + (if (eq proc *current-process*) + "->" + " ") + (process-name proc) + (process-whostate proc)) + (let* ((suspend-count (process-suspend-count proc))) + (if (and suspend-count (not (eql 0 suspend-count))) + (format t " (Suspended)"))) + (let* ((terminal-input-shared-resource + (if (typep *terminal-io* 'two-way-stream) + (input-stream-shared-resource + (two-way-stream-input-stream *terminal-io*))))) + (if (and terminal-input-shared-resource + (%shared-resource-requestor-p + terminal-input-shared-resource proc)) + (format t " (Requesting terminal input)"))) + (fresh-line))) + (if p + (let* ((proc (find-process p))) + (if (null proc) + (format t "~&;; not found - ~s" p) + (show-process-info proc))) + (dolist (proc (all-processes) (values)) + (show-process-info proc))))) + +(define-toplevel-command :global cd (dir) "Change to directory DIR" (setf (current-directory) dir) (toplevel-print (list (current-directory)))) + +(define-toplevel-command :global pwd () "Print the pathame of the current directory" (toplevel-print (list (current-directory)))) + + + +(defun list-restarts () + (format *debug-io* "~&> Type (:C ) to invoke one of the following restarts:") + (display-restarts)) + +(define-toplevel-command :break pop () "exit current break loop" (abort-break)) +(define-toplevel-command :break a () "exit current break loop" (abort-break)) +(define-toplevel-command :break go () "continue" (continue)) +(define-toplevel-command :break q () "return to toplevel" (toplevel)) +(define-toplevel-command :break r () "list restarts" (list-restarts)) + +(define-toplevel-command :break set (n frame value) "Set th item of frame to " + (let* ((frame-sp (nth-raw-frame frame *break-frame* nil))) + (if frame-sp + (toplevel-print (list (set-nth-value-in-frame frame-sp n nil value))) + (format *debug-io* "No frame with number ~D~%" frame)))) + +(define-toplevel-command :break nframes () + "print the number of stack frames accessible from this break loop" + (do* ((p *break-frame* (parent-frame p nil)) + (i 0 (1+ i)) + (last (last-frame-ptr))) + ((eql p last) (toplevel-print (list i))))) + +(define-toplevel-command :global ? () "help" + (format t "~&The following toplevel commands are available:") + (when *default-integer-command* + (format t "~& ~8Tthe same as (~s )" (car *default-integer-command*))) + (dolist (g *active-toplevel-commands*) + (dolist (c (cdr g)) + (let* ((command (car c)) + (doc (caddr c)) + (args (cdddr c))) + (if args + (format t "~& (~S~{ ~A~}) ~8T~A" command args doc) + (format t "~& ~S ~8T~A" command doc))))) + (format t "~&Any other form is evaluated and its results are printed out.")) + + +(define-toplevel-command :break b (&key start count show-frame-contents) "backtrace" + (when *break-frame* + (print-call-history :detailed-p show-frame-contents + :origin *break-frame* + :count count + :start-frame-number (or start 0)))) + +(define-toplevel-command :break c (&optional n) "Choose restart . If no , continue" + (if n + (select-restart n) + (continue))) + +(define-toplevel-command :break f (n) "Show backtrace frame " + (print-call-history :origin *break-frame* + :start-frame-number n + :count 1 + :detailed-p t)) + +(define-toplevel-command :break return-from-frame (i &rest values) "Return VALUES from the I'th stack frame" + (let* ((frame-sp (nth-raw-frame i *break-frame* nil))) + (if frame-sp + (apply #'return-from-frame frame-sp values)))) + +(define-toplevel-command :break apply-in-frame (i function &rest args) "Applies FUNCTION to ARGS in the execution context of the Ith stack frame" + (let* ((frame-sp (nth-raw-frame i *break-frame* nil))) + (if frame-sp + (apply-in-frame frame-sp function args)))) + + + +(define-toplevel-command :break raw (n) "Show raw contents of backtrace frame " + (print-call-history :origin *break-frame* + :start-frame-number n + :count 1 + :detailed-p :raw)) + +(define-toplevel-command :break v (n frame-number) "Return value in frame " + (let* ((frame-sp (nth-raw-frame frame-number *break-frame* nil))) + (if frame-sp + (toplevel-print (list (nth-value-in-frame frame-sp n nil)))))) + +(define-toplevel-command :break arg (name frame-number) "Return value of argument named in frame " + (let* ((frame-sp (nth-raw-frame frame-number *break-frame* nil))) + (when frame-sp + (multiple-value-bind (lfun pc) (cfp-lfun frame-sp) + (when (and lfun pc) + (let* ((unavailable (cons nil nil))) + (declare (dynamic-extent unavailable)) + (let* ((value (arg-value nil frame-sp lfun pc unavailable name))) + (if (eq value unavailable) + (format *debug-io* "~&;; Can't determine value of ~s in frame ~s." name frame-number) + (toplevel-print (list value)))))))))) + +(define-toplevel-command :break set-arg (name frame-number new) "Set value of argument named in frame to value ." + (let* ((frame-sp (nth-raw-frame frame-number *break-frame* nil))) + (when frame-sp + (multiple-value-bind (lfun pc) (cfp-lfun frame-sp) + (when (and lfun pc) + (or (set-arg-value nil frame-sp lfun pc name new) + (format *debug-io* "~&;; Can't change value of ~s in frame ~s." name frame-number))))))) + + +(define-toplevel-command :break local (name frame-number) "Return value of local denoted by in frame can either be a symbol - in which case the most recent +binding of that symbol is used - or an integer index into the frame's set of local bindings." + (let* ((frame-sp (nth-raw-frame frame-number *break-frame* nil))) + (when frame-sp + (multiple-value-bind (lfun pc) (cfp-lfun frame-sp) + (when (and lfun pc) + (let* ((unavailable (cons nil nil))) + (declare (dynamic-extent unavailable)) + (let* ((value (local-value nil frame-sp lfun pc unavailable name))) + (if (eq value unavailable) + (format *debug-io* "~&;; Can't determine value of ~s in frame ~s." name frame-number) + (toplevel-print (list value)))))))))) + +(define-toplevel-command :break set-local (name frame-number new) "Set value of argument denoted (see :LOCAL) in frame to value ." + (let* ((frame-sp (nth-raw-frame frame-number *break-frame* nil))) + (when frame-sp + (multiple-value-bind (lfun pc) (cfp-lfun frame-sp) + (when (and lfun pc) + (or (set-local-value nil frame-sp lfun pc name new) + (format *debug-io* "~&;; Can't change value of ~s in frame ~s." name frame-number))))))) + + +(define-toplevel-command :break form (frame-number) + "Return a form which looks like the call which established the stack frame identified by . This is only well-defined in certain cases: when the function is globally named and not a lexical closure and when it was compiled with *SAVE-LOCAL-SYMBOLS* in effect." + (let* ((form (dbg-form frame-number))) + (when form + (let* ((*print-level* *backtrace-print-level*) + (*print-length* *backtrace-print-length*)) + (toplevel-print (list form)))))) + +;;; Ordinarily, form follows function. +(define-toplevel-command :break function (frame-number) + "Returns the function invoked in backtrace frame . This may be useful for, e.g., disassembly" + (let* ((cfp (nth-raw-frame frame-number *break-frame* nil))) + (when (and cfp (not (catch-csp-p cfp nil))) + (let* ((function (cfp-lfun cfp))) + (when function + (toplevel-print (list function))))))) + + + + + + + +(defun %use-toplevel-commands (group-name) + ;; Push the whole group + (pushnew (assoc group-name *defined-toplevel-commands*) + *active-toplevel-commands* + :key #'(lambda (x) (car x)))) ; #'car not defined yet ... + +(%use-toplevel-commands :global) + +(defparameter *toplevel-commands-dwim* t + "If true, tries to interpret otherwise-erroneous toplevel expressions as commands. +In addition, will suppress standard error handling for expressions that look like +commands but aren't") + +(defvar *default-integer-command* nil + "If non-nil, should be (keyword min max)), causing integers between min and max to be + interpreted as (keyword integer)") + +(defun check-toplevel-command (form) + (when (and *default-integer-command* + (integerp form) + (<= (cadr *default-integer-command*) form (caddr *default-integer-command*))) + (setq form `(,(car *default-integer-command*) ,form))) + (let* ((cmd (if (consp form) (car form) form)) + (args (if (consp form) (cdr form)))) + (when (or (keywordp cmd) + (and *toplevel-commands-dwim* + (non-nil-symbol-p cmd) + (not (if (consp form) + (fboundp cmd) + (or (boundp cmd) + (nth-value 1 (gethash cmd *symbol-macros*))))) + ;; Use find-symbol so don't make unneeded keywords. + (setq cmd (find-symbol (symbol-name cmd) :keyword)))) + (when (eq cmd :help) (setq cmd :?)) + (flet ((run (cmd form) + (or (dolist (g *active-toplevel-commands*) + (let* ((pair (assoc cmd (cdr g)))) + (when pair + (apply (cadr pair) args) + (return t)))) + ;; Try to detect user mistyping a command + (when (and *toplevel-commands-dwim* + (if (consp form) + (and (keywordp (%car form)) (not (fboundp (%car form)))) + (keywordp form))) + (error "Unknown command ~s" cmd))))) + (declare (dynamic-extent #'run)) + (if *toplevel-commands-dwim* + (block nil + (handler-bind ((error (lambda (c) + (format t "~&~a" c) + (return t)))) + (run cmd form))) + (run cmd form)))))) + +(defparameter *quit-on-eof* nil) + +(defparameter *consecutive-eof-limit* 2 "max number of consecutive EOFs at a given break level, before we give up and abruptly exit.") + +(defmethod stream-eof-transient-p (stream) + (let ((fd (stream-device stream :input))) + (and fd (eof-transient-p fd)))) + +(defvar *save-interactive-source-locations* t) + +;;; This is the part common to toplevel loop and inner break loops. +(defun read-loop (&key (input-stream *standard-input*) + (output-stream *standard-output*) + (break-level *break-level*) + (prompt-function #'(lambda (stream) + (when (and *show-available-restarts* *break-condition*) + (list-restarts) + (setf *show-available-restarts* nil)) + (print-listener-prompt stream t)))) + (let* ((*break-level* break-level) + (*last-break-level* break-level) + (*loading-file-source-file* nil) + (*loading-toplevel-location* nil) + *in-read-loop* + *** ** * +++ ++ + /// // / - + (eof-value (cons nil nil)) + (eof-count 0) + (*show-available-restarts* (and *show-restarts-on-break* *break-condition*)) + (map (make-hash-table :test #'eq :shared nil))) + (declare (dynamic-extent eof-value)) + (loop + (restart-case + (catch :abort ;last resort... + (loop + (catch-cancel + (loop + (setq *in-read-loop* nil + *break-level* break-level) + (multiple-value-bind (form env print-result) + (toplevel-read :input-stream input-stream + :output-stream output-stream + :prompt-function prompt-function + :eof-value eof-value + :map (when *save-interactive-source-locations* + (clrhash map) + map)) + (if (eq form eof-value) + (progn + (when (> (incf eof-count) *consecutive-eof-limit*) + (#_ _exit 0)) + (if (and (not *batch-flag*) + (not *quit-on-eof*) + (stream-eof-transient-p input-stream)) + (progn + (stream-clear-input input-stream) + (abort-break)) + (exit-interactive-process *current-process*))) + (let ((*nx-source-note-map* (and *save-interactive-source-locations* map))) + (setq eof-count 0) + (or (check-toplevel-command form) + (let* ((values (toplevel-eval form env))) + (if print-result (toplevel-print values))))))))) + (format *terminal-io* "~&Cancelled"))) + (abort () :report (lambda (stream) + (if (eq break-level 0) + (format stream "Return to toplevel.") + (format stream "Return to break level ~D." break-level))) + #| ; Handled by interactive-abort + ; go up one more if abort occurred while awaiting/reading input + (when (and *in-read-loop* (neq break-level 0)) + (abort)) + |# + ) + (abort-break () + (unless (eq break-level 0) + (abort)))) + (clear-input input-stream) + (format output-stream "~%")))) + +;;; The first non-whitespace character available on INPUT-STREAM is a colon. +;;; Try to interpret the line as a colon command (or possibly just a keyword.) +(defun read-command-or-keyword (input-stream eof-value) + (let* ((line (read-line input-stream nil eof-value))) + (if (eq line eof-value) + eof-value + (let* ((in (make-string-input-stream line)) + (keyword (read in nil eof-value))) + (if (eq keyword eof-value) + eof-value + (if (not (keywordp keyword)) + keyword + (collect ((params)) + (loop + (let* ((param (read in nil eof-value))) + (if (eq param eof-value) + (return + (let* ((params (params))) + (if params + (cons keyword params) + keyword))) + (params (eval param)))))))))))) + +;;; Read a form from the specified stream. +(defun toplevel-read (&key (input-stream *standard-input*) + (output-stream *standard-output*) + (prompt-function #'print-listener-prompt) + (eof-value *eof-value*) + (map nil)) + (force-output output-stream) + (funcall prompt-function output-stream) + (read-toplevel-form input-stream :eof-value eof-value :map map)) + +(defvar *always-eval-user-defvars* nil) + +(defun process-single-selection (form) + (if (and *always-eval-user-defvars* + (listp form) (eq (car form) 'defvar) (cddr form)) + `(defparameter ,@(cdr form)) + form)) + +(defun toplevel-eval (form &optional env) + (destructuring-bind (vars . vals) (or env '(nil . nil)) + (progv vars vals + (setq +++ ++ ++ + + - - form) + (unwind-protect + (let* ((package *package*) + (values (multiple-value-list (cheap-eval-in-environment form nil)))) + (unless (eq package *package*) + ;; If changing a local value (e.g. buffer-local), not useful to notify app + ;; without more info. Perhaps should have a *source-context* that can send along? + (unless (member '*package* vars) + (application-ui-operation *application* :note-current-package *package*))) + values) + (loop for var in vars as pval on vals + do (setf (car pval) (symbol-value var))))))) + + +(defun toplevel-print (values &optional (out *standard-output*)) + (setq /// // // / / values) + (unless (eq (car values) (%unbound-marker)) + (setq *** ** ** * * (%car values))) + (when values + (fresh-line out) + (dolist (val values) (write val :stream out) (terpri out)))) + +(defparameter *listener-prompt-format* "~[?~:;~:*~d >~] ") + + +(defun print-listener-prompt (stream &optional (force t)) + (unless *quiet-flag* + (when (or force (neq *break-level* *last-break-level*)) + (let* ((*listener-indent* nil)) + (fresh-line stream) + (format stream *listener-prompt-format* *break-level*)) + (setq *last-break-level* *break-level*))) + (force-output stream)) + + +;;; Fairly crude default error-handlingbehavior, and a fairly crude mechanism +;;; for customizing it. + +(defvar *app-error-handler-mode* :quit + "one of :quit, :quit-quietly, :listener might be useful.") + +(defmethod application-error ((a application) condition error-pointer) + (case *app-error-handler-mode* + (:listener (break-loop-handle-error condition error-pointer)) + (:quit-quietly (quit -1)) + (:quit (format t "~&Fatal error in ~s : ~a" + (pathname-name (car *command-line-argument-list*)) + condition) + (quit -1)))) + +(defun make-application-error-handler (app mode) + (declare (ignore app)) + (setq *app-error-handler-mode* mode)) + + +; You may want to do this anyway even if your application +; does not otherwise wish to be a "lisp-development-system" +(defmethod application-error ((a lisp-development-system) condition error-pointer) + (break-loop-handle-error condition error-pointer)) + +(defun abnormal-application-exit () + (ignore-errors + (print-call-history) + (force-output *debug-io*) + (quit -1)) + (#__exit -1)) + +(defvar *top-error-frame* nil) + +(defun break-loop-handle-error (condition *top-error-frame*) + (multiple-value-bind (bogus-globals newvals oldvals) (%check-error-globals) + (dolist (x bogus-globals) + (set x (funcall (pop newvals)))) + (when (and *debugger-hook* *break-on-errors* (not *batch-flag*)) + (let ((hook *debugger-hook*) + (*debugger-hook* nil)) + (funcall hook condition hook))) + (%break-message "Error" condition) + (let* ((s *error-output*)) + (dolist (bogusness bogus-globals) + (let ((oldval (pop oldvals))) + (format s "~&; NOTE: ~S was " bogusness) + (if (eq oldval (%unbound-marker-8)) + (format s "unbound") + (format s "~s" oldval)) + (format s ", was reset to ~s ." (symbol-value bogusness))))) + (if (and *break-on-errors* (not *batch-flag*)) + (break-loop condition) + (if *batch-flag* + (abnormal-application-exit) + (abort))))) + +(defun break (&optional string &rest args) + "Print a message and invoke the debugger without allowing any possibility + of condition handling occurring." + (if *batch-flag* + (apply #'error (or string "BREAK invoked in batch mode") args) + (apply #'%break-in-frame (%get-frame-ptr) string args))) + +(defun %break-in-frame (fp &optional string &rest args) + (flet ((do-break-loop () + (let ((c (if (typep string 'condition) + string + (make-condition 'simple-condition + :format-control (or string "") + :format-arguments args)))) + (cbreak-loop "Break" "Return from BREAK." c fp)))) + (cond ((%i> *interrupt-level* -1) + (do-break-loop)) + (*break-loop-when-uninterruptable* + (format *error-output* "Break while interrupt-level less than zero; binding to 0 during break-loop.") + (let ((interrupt-level (interrupt-level))) + (unwind-protect + (progn + (setf (interrupt-level) 0) + (do-break-loop)) + (setf (interrupt-level) interrupt-level)))) + (t (format *error-output* "Break while interrupt-level less than zero; ignored."))))) + + +(defun invoke-debugger (condition &aux (*top-error-frame* (%get-frame-ptr))) + "Enter the debugger." + (let ((c (require-type condition 'condition))) + (when *debugger-hook* + (let ((hook *debugger-hook*) + (*debugger-hook* nil)) + (funcall hook c hook))) + (%break-message "Debug" c) + (break-loop c))) + +(defun %break-message (msg condition &optional (error-pointer *top-error-frame*) (prefixchar #\>)) + (let ((*print-circle* *error-print-circle*) + ;(*print-prett*y nil) + (*print-array* nil) + (*print-escape* t) + (*print-gensym* t) + (*print-length* *error-print-length*) + (*print-level* *error-print-level*) + (*print-lines* nil) + (*print-miser-width* nil) + (*print-readably* nil) + (*print-right-margin* nil) + (*signal-printing-errors* nil) + (s (make-indenting-string-output-stream prefixchar nil))) + (format s "~A ~A: " prefixchar msg) + (setf (indenting-string-output-stream-indent s) (column s)) + ;(format s "~A" condition) ; evil if circle + (report-condition condition s) + (if (not (and (typep condition 'simple-program-error) + (simple-program-error-context condition))) + (format *error-output* "~&~A~%~A While executing: ~S" + (get-output-stream-string s) prefixchar (%real-err-fn-name error-pointer)) + (format *error-output* "~&~A" + (get-output-stream-string s))) + (format *error-output* ", in process ~a(~d).~%" (process-name *current-process*) (process-serial-number *current-process*)) + (force-output *error-output*))) + ; returns NIL + +(defvar *break-hook* nil) + +(defun cbreak-loop (msg cont-string condition *top-error-frame*) + (let* ((*print-readably* nil) + (hook *break-hook*)) + (restart-case (progn + (when hook + (let ((*break-hook* nil)) + (funcall hook condition hook)) + (setq hook nil)) + (%break-message msg condition) + (when (and (eq (type-of condition) 'simple-condition) + (equal (simple-condition-format-control condition) "")) + (setq condition (make-condition 'simple-condition + :format-control "~a" + :format-arguments (list msg)))) + (break-loop condition)) + (continue () :report (lambda (stream) (write-string cont-string stream)))) + (unless hook + (fresh-line *error-output*)) + nil)) + +(defun warn (condition-or-format-string &rest args) + "Warn about a situation by signalling a condition formed by DATUM and + ARGUMENTS. While the condition is being signaled, a MUFFLE-WARNING restart + exists that causes WARN to immediately return NIL." + (when (typep condition-or-format-string 'condition) + (unless (typep condition-or-format-string 'warning) + (report-bad-arg condition-or-format-string 'warning)) + (when args + (error 'type-error :datum args :expected-type 'null + :format-control "Extra arguments in ~s."))) + (let ((fp (%get-frame-ptr)) + (c (require-type (condition-arg condition-or-format-string args 'simple-warning) 'warning))) + (when *break-on-warnings* + (cbreak-loop "Warning" "Signal the warning." c fp)) + (restart-case (signal c) + (muffle-warning () :report "Skip the warning" (return-from warn nil))) + (%break-message (if (typep c 'compiler-warning) "Compiler warning" "Warning") c fp #\;) + )) + +(declaim (notinline select-backtrace)) + +(defmacro new-backtrace-info (dialog youngest oldest tcr condition current fake db-link level) + (let* ((cond (gensym))) + `(let* ((,cond ,condition)) + (vector ,dialog ,youngest ,oldest ,tcr (cons nil (compute-restarts ,cond)) (%catch-top ,tcr) ,cond ,current ,fake ,db-link ,level)))) + +(defun select-backtrace () + (declare (notinline select-backtrace)) + ;(require 'new-backtrace) + (require :inspector) + (select-backtrace)) + +(defvar *break-condition* nil "condition argument to innermost break-loop.") +(defvar *break-frame* nil "frame-pointer arg to break-loop") +(defvar *break-loop-when-uninterruptable* t) +(defvar *show-restarts-on-break* #+ccl-0711 t #-ccl-0711 nil) +(defvar *show-available-restarts* nil) + +(defvar *error-reentry-count* 0) + +(defun funcall-with-error-reentry-detection (thunk) + (let* ((count *error-reentry-count*) + (*error-reentry-count* (1+ count))) + (cond ((eql count 0) (funcall thunk)) + ((eql count 1) (error "Error reporting error")) + (t (bug "Error reporting error"))))) + + + + +(defvar %last-continue% nil) +(defun break-loop (condition &optional (frame-pointer *top-error-frame*)) + "Never returns" + (let* ((%handlers% (last %handlers%)) ; firewall + (*break-frame* frame-pointer) + (*break-condition* condition) + (*compiling-file* nil) + (*backquote-stack* nil) + (continue (find-restart 'continue)) + (*continuablep* (unless (eq %last-continue% continue) continue)) + (%last-continue% continue) + (*standard-input* *debug-io*) + (*standard-output* *debug-io*) + (*signal-printing-errors* nil) + (*read-suppress* nil) + (*print-readably* nil) + (*default-integer-command* `(:c 0 ,(1- (length (compute-restarts condition))))) + (context (new-backtrace-info nil + frame-pointer + (if *backtrace-contexts* + (or (child-frame + (bt.youngest (car *backtrace-contexts*)) + nil) + (last-frame-ptr)) + (last-frame-ptr)) + (%current-tcr) + condition + (%current-frame-ptr) + #+ppc-target *fake-stack-frames* + #+x86-target (%current-frame-ptr) + (db-link) + (1+ *break-level*))) + (*backtrace-contexts* (cons context *backtrace-contexts*))) + (with-terminal-input + (with-toplevel-commands :break + (if *continuablep* + (let* ((*print-circle* *error-print-circle*) + (*print-level* *error-print-level*) + (*print-length* *error-print-length*) + ;(*print-pretty* nil) + (*print-array* nil)) + (format t (or (application-ui-operation *application* :break-options-string t) + "~&> Type :GO to continue, :POP to abort, :R for a list of available restarts.")) + (format t "~&> If continued: ~A~%" continue)) + (format t (or (application-ui-operation *application* :break-options-string nil) + "~&> Type :POP to abort, :R for a list of available restarts.~%"))) + (format t "~&> Type :? for other options.") + (terpri) + (force-output) + + (clear-input *debug-io*) + (setq *error-reentry-count* 0) ; succesfully reported error + (ignoring-without-interrupts + (unwind-protect + (progn + (application-ui-operation *application* + :enter-backtrace-context context) + (read-loop :break-level (1+ *break-level*) + :input-stream *debug-io* + :output-stream *debug-io*)) + (application-ui-operation *application* :exit-backtrace-context + context))))))) + + + +(defun display-restarts (&optional (condition *break-condition*)) + (loop + for restart in (compute-restarts condition) + for count upfrom 0 + do (format *debug-io* "~&~D. ~A" count restart) + finally (fresh-line *debug-io*))) + +(defun select-restart (n &optional (condition *break-condition*)) + (let* ((restarts (compute-restarts condition))) + (invoke-restart-interactively + (nth (require-type n `(integer 0 (,(length restarts)))) restarts)))) + + + + +; End of l1-readloop-lds.lisp Index: /branches/new-random/level-1/l1-readloop.lisp =================================================================== --- /branches/new-random/level-1/l1-readloop.lisp (revision 13309) +++ /branches/new-random/level-1/l1-readloop.lisp (revision 13309) @@ -0,0 +1,875 @@ +;;;-*-Mode: LISP; Package: CCL -*- +;;; +;;; Copyright (C) 2009 Clozure Associates +;;; Copyright (C) 1994-2001 Digitool, Inc +;;; This file is part of Clozure CL. +;;; +;;; Clozure CL is licensed under the terms of the Lisp Lesser GNU Public +;;; License , known as the LLGPL and distributed with Clozure CL as the +;;; file "LICENSE". The LLGPL consists of a preamble and the LGPL, +;;; which is distributed with Clozure CL as the file "LGPL". Where these +;;; conflict, the preamble takes precedence. +;;; +;;; Clozure CL is referenced in the preamble as the "LIBRARY." +;;; +;;; The LLGPL is also available online at +;;; http://opensource.franz.com/preamble.html + +(in-package "CCL") + +;L1-readloop.lisp + + +(defvar *break-on-signals* nil + "When (TYPEP condition *BREAK-ON-SIGNALS*) is true, then calls to SIGNAL will + enter the debugger prior to signalling that condition.") +(defvar *break-on-warnings* nil) +(defvar *break-on-errors* t "Not CL.") +(defvar *debugger-hook* nil + "This is either NIL or a function of two arguments, a condition and the value + of *DEBUGGER-HOOK*. This function can either handle the condition or return + which causes the standard debugger to execute. The system passes the value + of this variable to the function because it binds *DEBUGGER-HOOK* to NIL + around the invocation.") +(defvar *backtrace-on-break* nil) +(defvar *** nil + "the previous value of **") +(defvar ** nil + "the previous value of *") +(defvar * nil + "the value of the most recent top level EVAL") +(defvar /// nil + "the previous value of //") +(defvar // nil + "the previous value of /") +(defvar / nil + "a list of all the values returned by the most recent top level EVAL") +(defvar +++ nil + "the previous value of ++") +(defvar ++ nil + "the previous value of +") +(defvar + nil + "the value of the most recent top level READ") +(defvar - nil + "the form currently being evaluated") + +(defvar *continuablep* nil) +(defvar *in-read-loop* nil + "Is T if waiting for input in the read loop") + + +(defvar *did-startup* nil) + + + +(defmacro catch-cancel (&body body) + `(catch :cancel ,@body)) + +(defmacro throw-cancel (&optional value) + `(throw :cancel ,value)) + +;;; Throwing like this works in listeners and in the initial process. +;;; Can't easily tell if a process is a listener. Should be able to. +(defun toplevel () + (throw :toplevel nil)) + + +;;; It's not clear that this is the right behavior, but aborting CURRENT-PROCESS - +;;; when no one's sure just what CURRENT-PROCESS is - doesn't seem right either. +(defun interactive-abort () + (interactive-abort-in-process *current-process*)) + +(defun interactive-abort-in-process (p) + (if p (process-interrupt p + #'(lambda () + (unless *inhibit-abort* + (if *in-read-loop* + (abort-break) + (abort)) + ))))) + + +(defun abort (&optional condition) + "Transfer control to a restart named ABORT, signalling a CONTROL-ERROR if + none exists." + (invoke-restart-no-return (find-restart 'abort condition))) + +(defun continue (&optional condition) + "Transfer control to a restart named CONTINUE, or return NIL if none exists." + (let ((r (find-restart 'continue condition))) + (if r (invoke-restart r)))) + +(defun muffle-warning (&optional condition) + "Transfer control to a restart named MUFFLE-WARNING, signalling a + CONTROL-ERROR if none exists." + (invoke-restart-no-return (find-restart 'muffle-warning condition))) + +(defun abort-break () + (invoke-restart-no-return 'abort-break)) + + +(defun quit (&optional (exit 0) &key error-handler) + "exit must be either a (signed-byte 32) exit status or a function to call to exit lisp + error-handler can be a function of one argument, the condition, that will be called if an + error occurs while preparing to quit. The error handler should exit" + (if (or (null exit) (typep exit '(signed-byte 32))) + (setq exit (let ((exit-status (or exit 0))) + #'(lambda () (#__exit exit-status)))) + (unless (typep exit 'function) + (report-bad-arg exit '(or (signed-byte 32) function)))) + (let* ((ip *initial-process*) + (cp *current-process*)) + (when (process-verify-quit ip) + (process-interrupt ip + #'(lambda () + (handler-bind ((error (lambda (c) + (when error-handler + (funcall error-handler c))))) + (process-exit-application *current-process* + #'(lambda () + (%set-toplevel nil) + (funcall exit) ;; must exit + (bug "Exit function didn't exit")))))) + (unless (eq cp ip) + (process-kill cp))))) + + +(defloadvar *quitting* nil) + + +(defun prepare-to-quit (&optional part) + (let-globally ((*quitting* t)) + (when (or (null part) (eql 0 part)) + (dolist (f *lisp-cleanup-functions*) + (funcall f))) + (let* ((stragglers ())) + (dolist (p (all-processes)) + (unless (or (eq p *initial-process*) + (not (process-active-p p))) + (if (process-persistent p) + (process-reset p :shutdown) + (process-kill p)))) + (dolist (p (all-processes)) + (let* ((semaphore (process-termination-semaphore p))) + (when semaphore + (unless (eq p *initial-process*) + (unless (timed-wait-on-semaphore semaphore 0.05) + (push p stragglers)))))) + (dolist (p stragglers) + (let* ((semaphore (process-termination-semaphore p))) + (maybe-finish-process-kill p :kill) + (when semaphore + (timed-wait-on-semaphore semaphore 0.10))))) + (shutdown-lisp-threads) + (loop + (let* ((streams (open-file-streams))) + (when (null streams) (return)) + (let* ((ioblock (stream-ioblock (car streams) nil))) + (when ioblock + (setf (ioblock-inbuf-lock ioblock) nil + (ioblock-outbuf-lock ioblock) nil + (ioblock-owner ioblock) nil))) + (close (car streams)))) + (setf (interrupt-level) -1) ; can't abort after this + ) + ;; Didn't abort, so really quitting. + (setq *quitting* t)) + + +(defun signal (condition &rest args) + "Invokes the signal facility on a condition formed from DATUM and + ARGUMENTS. If the condition is not handled, NIL is returned. If + (TYPEP condition *BREAK-ON-SIGNALS*) is true, the debugger is invoked + before any signalling is done." + (setq condition (condition-arg condition args 'simple-condition)) + (let* ((*break-on-signals* *break-on-signals*)) + (let* ((old-bos *break-on-signals*)) + (when (unknown-ctype-p (let* ((*break-on-signals* nil)) (specifier-type old-bos))) + (setq *break-on-signals* nil) + (warn "~S : Ignoring invalid type specifier ~s." '*break-on-signals* old-bos))) + + (when (typep condition *break-on-signals*) + (let ((*break-on-signals* nil)) + (cbreak-loop "Signal" "Signal the condition." condition (%get-frame-ptr))))) + (let ((%handlers% %handlers%)) + (while %handlers% + (do* ((tag (pop %handlers%)) (handlers tag (cddr handlers))) + ((null handlers)) + (when (typep condition (car handlers)) + (let ((fn (cadr handlers))) + (cond ((null fn) (throw tag condition)) + ((fixnump fn) (throw tag (cons fn condition))) + (t (funcall fn condition))))))))) + +(defvar *error-print-circle* nil) ; reset to T when we actually can print-circle + + + +;;;*********************************** +;;;Mini-evaluator +;;;*********************************** + +(defun new-lexical-environment (&optional parent) + (%istruct 'lexical-environment parent nil nil nil nil nil nil)) + +(defmethod make-load-form ((e lexical-environment) &optional env) + (declare (ignore env)) + nil) + +(defun new-definition-environment (&optional (type 'compile-file)) + (%istruct 'definition-environment (list type) nil nil nil nil nil nil nil nil nil nil nil nil )) + +(defun definition-environment (env &optional clean-only &aux parent) + (if (and env (not (istruct-typep env 'lexical-environment))) (report-bad-arg env 'lexical-environment)) + (do* () + ((or (null env) + (listp (setq parent (lexenv.parent-env env))) + (and clean-only (or (lexenv.variables env) (lexenv.functions env))))) + (setq env parent)) + (if (consp parent) + env)) + +(defvar *symbol-macros* (make-hash-table :test #'eq)) + +(defun %define-symbol-macro (name expansion) + (if (or (constant-symbol-p name) + (proclaimed-special-p name)) + (signal-program-error "Symbol ~s already globally defined as a ~A" + name (if (constant-symbol-p name) + 'constant + 'variable))) + (setf (gethash name *symbol-macros*) expansion) + name) + +(defvar *macroexpand-hook* 'funcall + "The value of this variable must be a designator for a function that can + take three arguments, a macro expander function, the macro form to be + expanded, and the lexical environment to expand in. The function should + return the expanded form. This function is called by MACROEXPAND-1 + whenever a runtime expansion is needed. Initially this is set to + FUNCALL.") ; Should be #'funcall. +;(queue-fixup (setq *macroexpand-hook* #'funcall)) ; No it shouldn't. + +(defun %symbol-macroexpand-1 (sym env) + (flet ((expand-it (expansion) + (funcall *macroexpand-hook* + (constantly expansion) + sym + env))) + (if (and env (not (istruct-typep env 'lexical-environment))) + (report-bad-arg env 'lexical-environment)) + (do* ((env env (lexenv.parent-env env))) + ((null env)) + (if (istruct-typep env 'definition-environment) + (let* ((info (assq sym (defenv.symbol-macros env)))) + (if info + (return-from %symbol-macroexpand-1 (values (expand-it (cdr info)) t)) + (return))) + (let* ((vars (lexenv.variables env))) + (dolist (vdecl (lexenv.vdecls env)) + (if (and (eq (car vdecl) sym) + (eq (cadr vdecl) 'special)) + (return-from %symbol-macroexpand-1 (values sym nil)))) + (when (consp vars) + (let* ((info (dolist (var vars) + (if (eq (var-name var) sym) + (return var))))) + (when info + (if (and (consp (setq info (var-expansion info))) + (eq (%car info) :symbol-macro)) + (return-from %symbol-macroexpand-1 (values (expand-it (%cdr info)) t)) + (return-from %symbol-macroexpand-1 (values sym nil))))))))) + ;; Look it up globally. + (multiple-value-bind (expansion win) (gethash sym *symbol-macros*) + (if win (values (expand-it expansion) t) (values sym nil))))) + +(defun macroexpand-all (form &optional (env (new-lexical-environment))) + "Recursivly expand all macros in FORM." + (flet ((mexpand (forms env) + (mapcar (lambda (form) (macroexpand-all form env)) forms))) + (macrolet ((destructuring-bind-body (binds form &body body) + (if (eql '&body (first (last binds))) + (let ((&body (gensym "&BODY"))) + `(destructuring-bind ,(append (butlast binds) (list '&body &body)) + ,form + (multiple-value-bind (body decls) + (parse-body ,&body env nil) + ,@body))) + `(destructuring-bind ,binds ,form ,@body)))) + (multiple-value-bind (expansion win) + (macroexpand-1 form env) + (if win + (macroexpand-all expansion env) + (if (atom form) + form + (case (first form) + (macrolet + (destructuring-bind-body (macros &body) (rest form) + (setf env (augment-environment env + :macro (mapcar (lambda (macro) + (destructuring-bind + (name arglist &body body) + macro + (list name (enclose (parse-macro name arglist body env))))) + macros) + :declare (decl-specs-from-declarations decls))) + (let ((body (mexpand body env))) + (if decls + `(locally ,@decls ,@body) + `(progn ,@body))))) + (symbol-macrolet + (destructuring-bind-body (symbol-macros &body) (rest form) + (setf env (augment-environment env :symbol-macro symbol-macros :declare (decl-specs-from-declarations decls))) + (let ((body (mexpand body env))) + (if decls + `(locally ,@decls ,@body) + `(progn ,@body))))) + ((let let* compiler-let) + (destructuring-bind-body (bindings &body) (rest form) + `(,(first form) + ,(mapcar (lambda (binding) + + (if (listp binding) + (list (first binding) (macroexpand-all (second binding) env)) + binding)) + bindings) + ,@decls + ,@(mexpand body env)))) + ((flet labels) + (destructuring-bind-body (bindings &body) (rest form) + (let ((augmented-env + (augment-environment env :function (mapcar #'car bindings)))) + `(,(first form) + ,(mapcar (lambda (binding) + (list* (first binding) + (cdr (macroexpand-all `(lambda ,@(rest binding)) + (if (eq (first form) 'labels) + augmented-env + env))))) + bindings) + ,@decls + ,@(mexpand body augmented-env))))) + (nfunction (list* 'nfunction (second form) (macroexpand-all (third form) env))) + (function + (if (and (consp (second form)) + (eql 'lambda (first (second form)))) + (destructuring-bind (lambda arglist &body body&decls) + (second form) + (declare (ignore lambda)) + (multiple-value-bind (body decls) + (parse-body body&decls env) + `(lambda ,arglist ,@decls ,@(mexpand body env)))) + form)) + ((eval-when the locally block return-from) + (list* (first form) (second form) (mexpand (cddr form) env))) + (setq + `(setq ,@(loop for (name value) on (rest form) by #'cddr + collect name + collect (macroexpand-all value env)))) + ((go quote) form) + ((fbind with-c-frame with-variable-c-frame ppc-lap-function) + (error "Unable to macroexpand ~S." form)) + ((catch if load-time-value multiple-value-call multiple-value-prog1 progn + progv tagbody throw unwind-protect) + (cons (first form) (mexpand (rest form) env))) + (t + ;; need to check that (first form) is either fboundp or a local function... + (cons (first form) (mexpand (rest form) env)))))))))) + +(defun macroexpand-1 (form &optional env &aux fn) + "If form is a macro (or symbol macro), expand it once. Return two values, + the expanded form and a T-or-NIL flag indicating whether the form was, in + fact, a macro. ENV is the lexical environment to expand in, which defaults + to the null environment." + (declare (resident)) + (if (and (consp form) + (symbolp (%car form))) + (if (setq fn (macro-function (%car form) env)) + (values (funcall *macroexpand-hook* fn form env) t) + (values form nil)) + (if (and form (symbolp form)) + (%symbol-macroexpand-1 form env) + (values form nil)))) + +(defun macroexpand (form &optional env) + "Repetitively call MACROEXPAND-1 until the form can no longer be expanded. + Returns the final resultant form, and T if it was expanded. ENV is the + lexical environment to expand in, or NIL (the default) for the null + environment." + (declare (resident)) + (multiple-value-bind (new win) (macroexpand-1 form env) + (do* ((won-at-least-once win)) + ((null win) (values new won-at-least-once)) + (multiple-value-setq (new win) (macroexpand-1 new env))))) + +(defun %symbol-macroexpand (form env &aux win won) + ; Keep expanding until no longer a symbol-macro or no longer a symbol. + (loop + (unless (and form (symbolp form)) (return)) + (multiple-value-setq (form win) (macroexpand-1 form env)) + (if win (setq won t) (return))) + (values form won)) + +(defun retain-lambda-expression (name lambda-expression env) + (if (and (let* ((lambda-list (cadr lambda-expression))) + (and (not (memq '&lap lambda-list)) + (not (memq '&method lambda-list)) + (not (memq '&lexpr lambda-list)))) + (nx-declared-inline-p name env) + (not (gethash name *nx1-alphatizers*)) + ; A toplevel definition defined inside a (symbol-)macrolet should + ; be inlineable. It isn't; call DEFINITION-ENVIRONMENT with a + ; "clean-only" argument to ensure that there are no lexically + ; bound macros or symbol-macros. + (definition-environment env t)) + lambda-expression)) + + +(defun %cons-def-info (type &optional lfbits keyvect data specializers qualifiers) + (ecase type + (defun nil) + (defmacro (setq data '(macro) lfbits nil)) ;; some code assumes lfbits=nil + (defgeneric (setq data (list :methods) lfbits (logior (ash 1 $lfbits-gfn-bit) lfbits))) + (defmethod (setq data (list :methods + (%cons-def-info-method lfbits keyvect qualifiers specializers)) + lfbits (logandc2 lfbits (ash 1 $lfbits-aok-bit)) + keyvect nil)) + (deftype (setq data '(type) lfbits (cons nil *loading-file-source-file*)))) + (vector lfbits keyvect *loading-file-source-file* data)) + +(defun def-info.lfbits (def-info) + (and def-info + (let ((lfbits (svref def-info 0))) + (if (consp lfbits) (%car lfbits) lfbits)))) + +(defun def-info.keyvect (def-info) + (and def-info (svref def-info 1))) + +(defun def-info.file (def-info) + (and def-info (svref def-info 2))) + +(defun def-info.lambda (def-info) + (and def-info + (let ((data (svref def-info 3))) + (and (eq (car data) 'lambda) data)))) + +(defun def-info.methods (def-info) + (and def-info + (let ((data (svref def-info 3))) + (and (eq (car data) :methods) (%cdr data))))) + +(defun %cons-def-info-method (lfbits keyvect qualifiers specializers) + (cons (cons (and keyvect + (if (logbitp $lfbits-aok-bit lfbits) + (and (not (logbitp $lfbits-rest-bit lfbits)) + (list keyvect)) + keyvect)) + *loading-file-source-file*) + (cons qualifiers specializers))) + +(defun def-info-method.keyvect (def-info-method) + (let ((kv (caar def-info-method))) + (if (listp kv) + (values (car kv) t) + (values kv nil)))) + +(defun def-info-method.file (def-info-method) + (cdar def-info-method)) + +(defun def-info-with-new-methods (def-info new-bits new-methods) + (if (and (eq new-methods (def-info.methods def-info)) + (eql new-bits (def-info.lfbits def-info))) + def-info + (let ((new (copy-seq def-info)) + (old-bits (svref def-info 0))) + (setf (svref new 0) (if (consp old-bits) (cons new-bits (cdr old-bits)) old-bits)) + (setf (svref new 3) (cons :methods new-methods)) + new))) + +(defun def-info.macro-p (def-info) + (let ((data (and def-info (svref def-info 3)))) + (eq (car data) 'macro))) + +(defun def-info.function-p (def-info) + (not (and def-info (eq (car (svref def-info 3)) 'type)))) + +(defun def-info.function-type (def-info) + (if (null def-info) + nil ;; ftype only, for the purposes here, is same as nothing. + (let ((data (svref def-info 3))) + (ecase (car data) + ((nil lambda) 'defun) + (:methods 'defgeneric) + (macro 'defmacro) + (ftype nil) + (type nil))))) + +(defun def-info.deftype (def-info) + (and def-info + (let ((bits (svref def-info 0))) + ;; bits or (bits . type-source-file) + (and (consp bits) bits)))) + +(defun def-info.deftype-type (def-info) + ;; 'class (for defclass/defstruct) or 'macro (for deftype et. al.) + (and def-info + (consp (svref def-info 0)) + (svref def-info 1))) + +(defparameter *one-arg-defun-def-info* (%cons-def-info 'defun (encode-lambda-list '(x)))) + +(defvar *compiler-warn-on-duplicate-definitions* t) + +(defun combine-deftype-infos (name def-info old-deftype new-deftype) + (when (or new-deftype old-deftype) + (when (and old-deftype new-deftype *compiler-warn-on-duplicate-definitions*) + (nx1-whine :duplicate-definition + `(type ,name) + (cdr old-deftype) + (cdr new-deftype))) + (let ((target (if new-deftype + (or (cdr new-deftype) (cdr old-deftype)) + (cdr old-deftype))) + (target-deftype (def-info.deftype def-info))) + (unless (and target-deftype (eq (cdr target-deftype) target)) + (setq def-info (copy-seq (or def-info '#(nil nil nil (ftype))))) + (setf (svref def-info 0) (cons (def-info.lfbits def-info) target))))) + def-info) + +#+debug +(defun describe-def-info (def-info) + (list :lfbits (def-info.lfbits def-info) + :keyvect (def-info.keyvect def-info) + :macro-p (def-info.macro-p def-info) + :function-p (def-info.function-p def-info) + :lambda (and (def-info.function-p def-info) (def-info.lambda def-info)) + :methods (and (def-info.function-p def-info) (def-info.methods def-info)) + :function-type (def-info.function-type def-info) + :deftype (def-info.deftype def-info) + :deftype-type (def-info.deftype-type def-info))) + +(defun combine-gf-def-infos (name old-info new-info) + (let* ((old-bits (def-info.lfbits old-info)) + (new-bits (def-info.lfbits new-info)) + (old-methods (def-info.methods old-info)) + (new-methods (def-info.methods new-info))) + (when (and (logbitp $lfbits-gfn-bit old-bits) (logbitp $lfbits-gfn-bit new-bits)) + (when *compiler-warn-on-duplicate-definitions* + (nx1-whine :duplicate-definition + name + (def-info.file old-info) + (def-info.file new-info))) + (return-from combine-gf-def-infos new-info)) + (unless (congruent-lfbits-p old-bits new-bits) + (if (logbitp $lfbits-gfn-bit new-bits) + ;; A defgeneric, incongruent with previously defined methods + (nx1-whine :incongruent-gf-lambda-list name) + ;; A defmethod incongruent with previously defined explicit or implicit generic + (nx1-whine :incongruent-method-lambda-list + (if new-methods `(:method ,@(cadar new-methods) ,name ,(cddar new-methods)) name) + name)) + ;; Perhaps once this happens, should just mark it somehow to not complain again + (return-from combine-gf-def-infos + (if (logbitp $lfbits-gfn-bit old-bits) old-info new-info))) + (loop for new-method in new-methods + as old = (member (cdr new-method) old-methods :test #'equal :key #'cdr) + do (when old + (when *compiler-warn-on-duplicate-definitions* + (nx1-whine :duplicate-definition + `(:method ,@(cadr new-method) ,name ,(cddr new-method)) + (def-info-method.file (car old)) + (def-info-method.file new-method))) + (setq old-methods (remove (car old) old-methods :test #'eq))) + do (push new-method old-methods)) + (cond ((logbitp $lfbits-gfn-bit new-bits) + ;; If adding a defgeneric, use its info. + (setq old-info new-info old-bits new-bits)) + ((not (logbitp $lfbits-gfn-bit old-bits)) + ;; If no defgeneric (yet?) just remember whether any method has &key + (setq old-bits (logior old-bits (logand new-bits (ash 1 $lfbits-keys-bit)))))) + ;; Check that all methods implement defgeneric keys + (let ((gfkeys (and (logbitp $lfbits-gfn-bit old-bits) (def-info.keyvect old-info)))) + (when (> (length gfkeys) 0) + (loop for minfo in old-methods + do (multiple-value-bind (mkeys aok) (def-info-method.keyvect minfo) + (when (and mkeys + (not aok) + (setq mkeys (loop for gk across gfkeys + unless (find gk mkeys) collect gk))) + (nx1-whine :gf-keys-not-accepted + `(:method ,@(cadr minfo) ,name ,(cddr minfo)) + mkeys)))))) + (def-info-with-new-methods old-info old-bits old-methods))) + +(defun combine-definition-infos (name old-info new-info) + (let ((old-type (def-info.function-type old-info)) + (old-deftype (def-info.deftype old-info)) + (new-type (def-info.function-type new-info)) + (new-deftype (def-info.deftype new-info))) + (cond ((and (eq old-type 'defgeneric) (eq new-type 'defgeneric)) + (setq new-info (combine-gf-def-infos name old-info new-info))) + ((or (eq (or old-type 'defun) (or new-type 'defun)) + (eq (or old-type 'defgeneric) (or new-type 'defgeneric))) + (when (and old-type new-type *compiler-warn-on-duplicate-definitions*) + (nx1-whine :duplicate-definition name (def-info.file old-info) (def-info.file new-info))) + (unless new-info (setq new-info old-info))) + (t + (when (and (def-info.function-p old-info) (def-info.function-p new-info) + *compiler-warn-on-duplicate-definitions*) + (apply #'nx1-whine :duplicate-definition + name + (def-info.file old-info) + (def-info.file new-info) + (cond ((eq old-type 'defmacro) '("macro" "function")) + ((eq new-type 'defmacro) '("function" "macro")) + ((eq old-type 'defgeneric) '("generic function" "function")) + (t '("function" "generic function"))))) + (unless new-type (setq new-info old-info)))) + (combine-deftype-infos name new-info old-deftype new-deftype))) + +(defun record-definition-info (name info env) + (let* ((definition-env (definition-environment env))) + (if definition-env + (let* ((defs (defenv.defined definition-env)) + (already (if (listp defs) (assq name defs) (gethash name defs)))) + (if already + (setf (%cdr already) (combine-definition-infos name (%cdr already) info)) + (let ((outer (loop for defer = (cdr (defenv.type definition-env)) + then (deferred-warnings.parent defer) + while (typep defer 'deferred-warnings) + thereis (gethash name (deferred-warnings.defs defer))))) + (when outer + (setq info (combine-definition-infos name (%cdr outer) info))) + (let ((new (cons name info))) + (if (listp defs) + (setf (defenv.defined definition-env) (cons new defs)) + (setf (gethash name defs) new))))) + info)))) + +(defun record-function-info (name info env) + (record-definition-info name info env)) + +;;; This is different from AUGMENT-ENVIRONMENT. +(defun note-function-info (name lambda-expression env) + (let* ((info nil) + (name (maybe-setf-function-name name))) + (when (lambda-expression-p lambda-expression) + (multiple-value-bind (lfbits keyvect) (encode-lambda-list (cadr lambda-expression) t) + (setq info (%cons-def-info 'defun lfbits keyvect + (retain-lambda-expression name lambda-expression env))))) + (record-function-info name info env)) + name) + +(defun note-type-info (name kind env) + (record-definition-info name (%cons-def-info 'deftype nil kind) env)) + + +; And this is different from FUNCTION-INFORMATION. +(defun retrieve-environment-function-info (name env) + (let ((defenv (definition-environment env))) + (when defenv + (let* ((defs (defenv.defined defenv)) + (sym (maybe-setf-function-name name)) + (info (if (listp defs) (assq sym defs) (gethash sym defs)))) + (and info (def-info.function-p (cdr info)) info))))) + +;;; Must differ from -something-, but not sure what ... +(defun note-variable-info (name info env) + (let ((definition-env (definition-environment env))) + (if definition-env (push (cons name info) (defenv.specials definition-env))) + name)) + +(defun compile-file-environment-p (env) + (let ((defenv (definition-environment env))) + (and defenv (eq 'compile-file (car (defenv.type defenv)))))) + +;; This is EVAL. +(defun cheap-eval (form) + ;; Don't record source locations for explicit calls to EVAL. + (let ((*nx-source-note-map* nil)) + (cheap-eval-in-environment form nil))) + +; used by nfcomp too +; Should preserve order of decl-specs; it sometimes matters. +(defun decl-specs-from-declarations (declarations) + (let ((decl-specs nil)) + (dolist (declaration declarations decl-specs) + ;(unless (eq (car declaration) 'declare) (say "what")) + (dolist (decl-spec (cdr declaration)) + (setq decl-specs (nconc decl-specs (list decl-spec))))))) + +(defun cheap-eval-macroexpand-1 (form env) + (multiple-value-bind (new win) (macroexpand-1 form env) + (when win + (note-source-transformation form new)) + (values new win))) + +(defun cheap-eval-transform (original new) + (note-source-transformation original new) + new) + +(defun cheap-eval-function (name lambda env) + (multiple-value-bind (lfun warnings) + (compile-named-function lambda + :name name + :env env + :function-note *loading-toplevel-location* + :keep-lambda *save-definitions* + :keep-symbols *save-local-symbols* + :source-notes *nx-source-note-map*) + (signal-or-defer-warnings warnings env) + lfun)) + +(fset 'nx-source-note (nlambda bootstrapping-source-note (form) (declare (ignore form)) nil)) + +(defun cheap-eval-in-environment (form env &aux sym) + (declare (resident)) + ;; records source locations if *nx-source-note-map* is bound by caller + (setq *loading-toplevel-location* (or (nx-source-note form) *loading-toplevel-location*)) + (flet ((progn-in-env (body&decls parse-env base-env) + (multiple-value-bind (body decls) (parse-body body&decls parse-env) + (setq base-env (augment-environment base-env :declare (decl-specs-from-declarations decls))) + (loop with default-location = *loading-toplevel-location* + while (cdr body) as form = (pop body) + do (cheap-eval-in-environment form base-env) + do (setq *loading-toplevel-location* default-location)) + (cheap-eval-in-environment (car body) base-env)))) + (if form + (cond ((symbolp form) + (multiple-value-bind (expansion win) (cheap-eval-macroexpand-1 form env) + (if win + (cheap-eval-in-environment expansion env) + (let* ((defenv (definition-environment env)) + (constant (if defenv (assq form (defenv.constants defenv)))) + (constval (%cdr constant))) + (if constant + (if (neq (%unbound-marker-8) constval) + constval + (error "Can't determine value of constant symbol ~s" form)) + (if (constant-symbol-p form) + (%sym-global-value form) + (symbol-value form))))))) + ((atom form) form) + ((eq (setq sym (%car form)) 'quote) + (verify-arg-count form 1 1) + (%cadr form)) + ((eq sym 'function) + (verify-arg-count form 1 1) + (cond ((symbolp (setq sym (%cadr form))) + (multiple-value-bind (kind local-p) + (function-information sym env) + (if (and local-p (eq kind :macro)) + (error "~s can't be used to reference lexically defined macro ~S" 'function sym))) + (%function sym)) + ((setf-function-name-p sym) + (multiple-value-bind (kind local-p) + (function-information sym env) + (if (and local-p (eq kind :macro)) + (error "~s can't be used to reference lexically defined macro ~S" 'function sym))) + (%function (setf-function-name (%cadr sym)))) + (t (cheap-eval-function nil sym env)))) + ((eq sym 'nfunction) + (verify-arg-count form 2 2) + (cheap-eval-function (%cadr form) (%caddr form) env)) + ((eq sym 'progn) (progn-in-env (%cdr form) env env)) + ((eq sym 'setq) + (if (not (%ilogbitp 0 (list-length form))) + (verify-arg-count form 0 0)) ;Invoke a "Too many args" error. + (let* ((sym nil) + (val nil) + (original form)) + (while (setq form (%cdr form)) + (setq sym (require-type (pop form) 'symbol)) + (multiple-value-bind (expansion expanded) + (cheap-eval-macroexpand-1 sym env) + (if expanded + (setq val (cheap-eval-in-environment + (cheap-eval-transform original `(setf ,expansion ,(%car form))) + env)) + (set sym (setq val (cheap-eval-in-environment (%car form) env)))))) + val)) + ((eq sym 'eval-when) + (destructuring-bind (when . body) (%cdr form) + (when (or (memq 'eval when) (memq :execute when)) (progn-in-env body env env)))) + ((eq sym 'if) + (destructuring-bind (test true &optional false) (%cdr form) + (setq test (let ((*loading-toplevel-location* *loading-toplevel-location*)) + (cheap-eval-in-environment test env))) + (cheap-eval-in-environment (if test true false) env))) + ((eq sym 'locally) (progn-in-env (%cdr form) env env)) + ((eq sym 'symbol-macrolet) + (multiple-value-bind (body decls) (parse-body (cddr form) env) + (progn-in-env body env (augment-environment env :symbol-macro (cadr form) :declare (decl-specs-from-declarations decls))))) + ((eq sym 'macrolet) + (let ((temp-env (augment-environment env + :macro + (mapcar #'(lambda (m) + (destructuring-bind (name arglist &body body) m + (list name (enclose (parse-macro name arglist body env) + env)))) + (cadr form))))) + (progn-in-env (cddr form) temp-env temp-env))) + ((and (symbolp sym) + (compiler-special-form-p sym) + (not (functionp (fboundp sym)))) + (if (eq sym 'unwind-protect) + (destructuring-bind (protected-form . cleanup-forms) (cdr form) + (unwind-protect + (let ((*loading-toplevel-location* *loading-toplevel-location*)) + (cheap-eval-in-environment protected-form env)) + (progn-in-env cleanup-forms env env))) + (let ((fn (cheap-eval-function nil (cheap-eval-transform form `(lambda () (progn ,form))) env))) + (funcall fn)))) + ((and (symbolp sym) (macro-function sym env)) + (cheap-eval-in-environment (cheap-eval-macroexpand-1 form env) env)) + ((or (symbolp sym) + (and (consp sym) (eq (%car sym) 'lambda))) + (let ((args nil) (form-location *loading-toplevel-location*)) + (dolist (elt (%cdr form)) + (push (cheap-eval-in-environment elt env) args) + (setq *loading-toplevel-location* form-location)) + (apply #'call-check-regs (if (symbolp sym) sym (cheap-eval-function nil sym env)) + (nreverse args)))) + (t (signal-simple-condition 'simple-program-error "Car of ~S is not a function name or lambda-expression." form)))))) + + +(%fhave 'eval #'cheap-eval) + + + + +(defun call-check-regs (fn &rest args) + (declare (dynamic-extent args) + (optimize (debug 3))) ; don't use any saved registers + (let ((old-regs (multiple-value-list (get-saved-register-values)))) + (declare (dynamic-extent old-regs)) + (multiple-value-prog1 (apply fn args) + (let* ((new-regs (multiple-value-list (get-saved-register-values))) + (new-regs-tail new-regs)) + (declare (dynamic-extent new-regs)) + (unless (dolist (old-reg old-regs t) + (unless (eq old-reg (car new-regs-tail)) + (return nil)) + (pop new-regs-tail)) + (apply 'error "Registers clobbered applying ~s to ~s~%~@{~a sb: ~s, Was: ~s~%~}" + fn args + (mapcan 'list + (let ((res nil)) + (dotimes (i (length old-regs)) + (push (format nil "save~d" i) res)) + (nreverse res)) + old-regs + new-regs))))))) + + + + + +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; +;; Stack frame accessors. + +; Kinda scant, wouldn't you say ? + + +;end of L1-readloop.lisp + Index: /branches/new-random/level-1/l1-sockets.lisp =================================================================== --- /branches/new-random/level-1/l1-sockets.lisp (revision 13309) +++ /branches/new-random/level-1/l1-sockets.lisp (revision 13309) @@ -0,0 +1,1510 @@ +;;;-*- Mode: Lisp; Package: CCL -*- +;;; +;;; Copyright (C) 2001-2009 Clozure Associates +;;; This file is part of Clozure CL. +;;; +;;; Clozure CL is licensed under the terms of the Lisp Lesser GNU Public +;;; License , known as the LLGPL and distributed with Clozure CL as the +;;; file "LICENSE". The LLGPL consists of a preamble and the LGPL, +;;; which is distributed with Clozure CL as the file "LGPL". Where these +;;; conflict, the preamble takes precedence. +;;; +;;; Clozure CL is referenced in the preamble as the "LIBRARY." +;;; +;;; The LLGPL is also available online at +;;; http://opensource.franz.com/preamble.html + +(in-package "CCL") + + + +;;; basic socket API +(eval-when (:compile-toplevel :load-toplevel :execute) + (export '(MAKE-SOCKET + ACCEPT-CONNECTION + DOTTED-TO-IPADDR + IPADDR-TO-DOTTED + IPADDR-TO-HOSTNAME + LOOKUP-HOSTNAME + LOOKUP-PORT + ;;with-pending-connect + RECEIVE-FROM + SEND-TO + SHUTDOWN + ;;socket-control + SOCKET-OS-FD + REMOTE-HOST + REMOTE-PORT + REMOTE-FILENAME + LOCAL-HOST + LOCAL-PORT + LOCAL-FILENAME + SOCKET-ADDRESS-FAMILY + SOCKET-CONNECT + SOCKET-FORMAT + SOCKET-TYPE + SOCKET-ERROR + SOCKET-ERROR-CODE + SOCKET-ERROR-IDENTIFIER + SOCKET-ERROR-SITUATION + WITH-OPEN-SOCKET)) + #+windows-target + (defmacro check-winsock-error (form) + (let* ((val (gensym))) + `(let* ((,val ,form)) + (if (< ,val 0) + (%get-winsock-error) + ,val)))) + (defmacro check-socket-error (form) + #+windows-target `(check-winsock-error ,form) + #-windows-target `(int-errno-call ,form)) + ) + + +#+windows-target +(defun %get-winsock-error () + (- (#_WSAGetLastError))) + +;;; The PPC is big-endian (uses network byte order), which makes +;;; things like #_htonl and #_htonl no-ops. These functions aren't +;;; necessarily defined as functions in some header files (I'm sure +;;; that that either complies with or violates some C standard), and +;;; it doesn't seem to make much sense to fight that to do ff-calls +;;; to a couple of identity functions. + +#+big-endian-target +(progn + (defmacro HTONL (x) x) + (defmacro HTONS (x) x) + (defmacro NTOHL (x) x) + (defmacro NTOHS (x) x)) + +#+little-endian-target +(progn + (declaim (inline %bswap32 %bswap16)) + (defun %bswap32 (x) + (declare (type (unsigned-byte 32) x)) + (%swap-u32 x)) + (defun %bswap16 (x) + (declare (type (unsigned-byte 16) x)) + (%swap-u16 x)) + (defmacro HTONL (x) `(%bswap32 ,x)) + (defmacro HTONS (x) `(%bswap16 ,x)) + (defmacro NTOHL (x) `(%bswap32 ,x)) + (defmacro NTOHS (x) `(%bswap16 ,x))) + +(defparameter *default-socket-character-encoding* + nil) + +(defmethod default-character-encoding ((domain (eql :socket))) + *default-socket-character-encoding*) + + +;;; On some (hypothetical) little-endian platform, we might want to +;;; define HTONL and HTONS to actually swap bytes around. + +(defpackage "OPENMCL-SOCKET" + (:use "CL") + (:import-from "CCL" + "MAKE-SOCKET" + "ACCEPT-CONNECTION" + "DOTTED-TO-IPADDR" + "IPADDR-TO-DOTTED" + "IPADDR-TO-HOSTNAME" + "LOOKUP-HOSTNAME" + "LOOKUP-PORT" + ;;with-pending-connect + "RECEIVE-FROM" + "SEND-TO" + "SHUTDOWN" + ;;socket-control + "SOCKET-OS-FD" + "REMOTE-HOST" + "REMOTE-PORT" + "REMOTE-FILENAME" + "LOCAL-HOST" + "LOCAL-PORT" + "LOCAL-FILENAME" + "SOCKET-ADDRESS-FAMILY" + "SOCKET-CONNECT" + "SOCKET-FORMAT" + "SOCKET-TYPE" + "SOCKET-ERROR" + "SOCKET-ERROR-CODE" + "SOCKET-ERROR-IDENTIFIER" + "SOCKET-ERROR-SITUATION" + "WITH-OPEN-SOCKET") + (:export "MAKE-SOCKET" + "ACCEPT-CONNECTION" + "DOTTED-TO-IPADDR" + "IPADDR-TO-DOTTED" + "IPADDR-TO-HOSTNAME" + "LOOKUP-HOSTNAME" + "LOOKUP-PORT" + ;;with-pending-connect + "RECEIVE-FROM" + "SEND-TO" + "SHUTDOWN" + ;;socket-control + "SOCKET-OS-FD" + "REMOTE-HOST" + "REMOTE-PORT" + "REMOTE-FILENAME" + "LOCAL-HOST" + "LOCAL-PORT" + "LOCAL-FILENAME" + "SOCKET-ADDRESS-FAMILY" + "SOCKET-CONNECT" + "SOCKET-FORMAT" + "SOCKET-TYPE" + "SOCKET-ERROR" + "SOCKET-ERROR-CODE" + "SOCKET-ERROR-IDENTIFIER" + "SOCKET-ERROR-SITUATION" + "WITH-OPEN-SOCKET")) + + + +(define-condition socket-error (simple-stream-error) + ((code :initarg :code :reader socket-error-code) + (identifier :initform :unknown :initarg :identifier :reader socket-error-identifier) + (Situation :initarg :situation :reader socket-error-situation))) + +(define-condition socket-creation-error (simple-error) + ((code :initarg :code :reader socket-creation-error-code) + (identifier :initform :unknown :initarg :identifier :reader socket-creation-error-identifier) + (situation :initarg :situation :reader socket-creation-error-situation))) + +(defvar *socket-error-identifiers* + #-windows-target + (list #$EADDRINUSE :address-in-use + #$ECONNABORTED :connection-aborted + #$ENOBUFS :no-buffer-space + #$ENOMEM :no-buffer-space + #$ENFILE :no-buffer-space + #$ETIMEDOUT :connection-timed-out + #$ECONNREFUSED :connection-refused + #$ENETUNREACH :host-unreachable + #$EHOSTUNREACH :host-unreachable + #$EHOSTDOWN :host-down + #$ENETDOWN :network-down + #$EADDRNOTAVAIL :address-not-available + #$ENETRESET :network-reset + #$ECONNRESET :connection-reset + #$ESHUTDOWN :shutdown + #$EACCES :access-denied + #$EPERM :access-denied) + #+windows-target + (list #$WSAEADDRINUSE :address-in-use + #$WSAECONNABORTED :connection-aborted + #$WSAENOBUFS :no-buffer-space + #$ENOMEM :no-buffer-space + #$ENFILE :no-buffer-space + #$WSAETIMEDOUT :connection-timed-out + #$WSAECONNREFUSED :connection-refused + #$WSAENETUNREACH :host-unreachable + #$WSAEHOSTUNREACH :host-unreachable + #$WSAEHOSTDOWN :host-down + #$WSAENETDOWN :network-down + #$WSAEADDRNOTAVAIL :address-not-available + #$WSAENETRESET :network-reset + #$WSAECONNRESET :connection-reset + #$WSAESHUTDOWN :shutdown + #$EACCES :access-denied + #$EPERM :access-denied) + ) + + +(declaim (inline socket-call)) +(defun socket-call (stream where res) + (if (< res 0) + (socket-error stream where res) + res)) + +#-windows-target +(defun %gai-strerror (errno) + (let* ((err (abs errno)) + (p (#_gai_strerror err))) + (if (%null-ptr-p p) + (format nil "Unknown nameserver error ~d" err) + (%get-cstring p)))) + + + +(defun socket-error (stream where errno &optional nameserver-p) + "Creates and signals (via error) one of two socket error +conditions, based on the state of the arguments." + #+windows-target (declare (ignore nameserver-p)) + (when (< errno 0) + (setq errno (- errno))) + (if stream + (error (make-condition 'socket-error + :stream stream + :code errno + :identifier (getf *socket-error-identifiers* errno :unknown) + :situation where + ;; TODO: this is a constant arg, there is a way to put this + ;; in the class definition, just need to remember how... + :format-control "~a (error #~d) during ~a" + :format-arguments (list + #+windows-target + (%windows-error-string errno) + #-windows-target + (if nameserver-p + (%gai-strerror errno) + (%strerror errno)) + errno where))) + (error (make-condition 'socket-creation-error + :code errno + :identifier (getf *socket-error-identifiers* errno :unknown) + :situation where + ;; TODO: this is a constant arg, there is a way to put this + ;; in the class definition, just need to remember how... + :format-control "~a (error #~d) during socket creation or nameserver operation in ~a" + :format-arguments (list + #+windows-target + (%windows-error-string errno) + #-windows-target + (if nameserver-p + (%gai-strerror errno) + (%strerror errno)) + errno where))))) + + + +;; If true, this will try to allow other cooperative processes to run +;; while socket io is happening. Since CCL threads are preemptively +;; scheduled, this isn't particularly meaningful. +(defvar *multiprocessing-socket-io* nil) + +(defclass socket () + ()) + +(defmacro with-open-socket ((var . args) &body body + &aux (socket (make-symbol "socket")) + (done (make-symbol "done"))) + "Execute body with var bound to the result of applying make-socket to +make-socket-args. The socket gets closed on exit." + `(let (,socket ,done) + (unwind-protect + (multiple-value-prog1 + (let ((,var (setq ,socket (make-socket ,@args)))) + ,@body) + (setq ,done t)) + (when ,socket (close ,socket :abort (not ,done)))))) + +(defgeneric socket-address-family (socket) + (:documentation "Return :internet or :file, as appropriate.")) + +(defclass ip-socket (socket) + ()) + +(defmethod socket-address-family ((socket ip-socket)) :internet) + +(defclass file-socket (socket) + ()) + +(defmethod socket-address-family ((socket file-socket)) :file) + +(defclass tcp-socket (ip-socket) + ()) + +(defgeneric socket-type (socket) + (:documentation + "Return :stream for tcp-stream and listener-socket, and :datagram +for udp-socket.")) + +(defmethod socket-type ((socket tcp-socket)) :stream) + +(defclass stream-file-socket (file-socket) + ()) + +(defmethod socket-type ((socket stream-file-socket)) :stream) + + +;;; An active TCP socket is an honest-to-goodness stream. +(defclass tcp-stream (tcp-socket) + ()) + +(defclass fundamental-tcp-stream (tcp-stream + fd-stream + buffered-binary-io-stream-mixin + buffered-character-io-stream-mixin) + ()) + +(make-built-in-class 'basic-tcp-stream + 'tcp-stream + 'basic-binary-io-stream + 'basic-character-io-stream) + +(defgeneric socket-connect (stream) + (:documentation + "Return :active for tcp-stream, :passive for listener-socket, and NIL +for udp-socket")) + +(defmethod socket-connect ((stream tcp-stream)) :active) + +(defgeneric socket-format (stream) + (:documentation + "Return the socket format as specified by the :format argument to +make-socket.")) + +(defmethod socket-format ((stream tcp-stream)) + (if (eq (stream-element-type stream) 'character) + :text + ;; Should distinguish between :binary and :bivalent, but hardly + ;; seems worth carrying around an extra slot just for that. + :bivalent)) + +(defmethod socket-device ((stream tcp-stream)) + (let ((ioblock (stream-ioblock stream nil))) + (and ioblock (ioblock-device ioblock)))) + +(defmethod select-stream-class ((class tcp-stream) in-p out-p char-p) + (declare (ignore char-p)) ; TODO: is there any real reason to care about this? + ;; Yes, in general. There is. + (assert (and in-p out-p) () "Non-bidirectional tcp stream?") + 'fundamental-tcp-stream) + +(defmethod map-to-basic-stream-class-name ((name (eql 'tcp-stream))) + 'basic-tcp-stream) + +(defmethod select-stream-class ((s (eql 'basic-tcp-stream)) in-p out-p char-p) + (declare (ignore char-p)) + (assert (and in-p out-p) () "Non-bidirectional tcp stream?") + 'basic-tcp-stream) + +;;; A FILE-SOCKET-STREAM is also honest. To goodness. +(defclass file-socket-stream (stream-file-socket) + ()) + +(defclass fundamental-file-socket-stream (file-socket-stream + fd-stream + buffered-binary-io-stream-mixin + buffered-character-io-stream-mixin) + ()) + +(make-built-in-class 'basic-file-socket-stream + 'file-socket-stream + 'basic-binary-io-stream + 'basic-character-io-stream) + + +(defmethod map-to-basic-stream-class-name ((name (eql 'file-socket-stream))) + 'basic-file-socket-stream) + +(defmethod select-stream-class ((class file-socket-stream) in-p out-p char-p) + (declare (ignore char-p)) ; TODO: is there any real reason to care about this? + (assert (and in-p out-p) () "Non-bidirectional file-socket stream?") + 'fundamental-file-socket-stream) + +(defmethod select-stream-class ((s (eql 'basic-file-socket-stream)) in-p out-p char-p) + (declare (ignore char-p)) + (assert (and in-p out-p) () "Non-bidirectional file-socket stream?") + 'basic-file-socket-stream) + +(defclass unconnected-socket (socket) + ((device :initarg :device :accessor socket-device) + (keys :initarg :keys :reader socket-keys))) + +(defmethod socket-format ((socket unconnected-socket)) + (or (getf (socket-keys socket) :format) :text)) + +(defgeneric close (socket &key abort) + (:documentation + "The close generic function can be applied to sockets. It releases the +operating system resources associated with the socket.")) + +(defmethod close ((socket unconnected-socket) &key abort) + (declare (ignore abort)) + (when (socket-device socket) + (fd-close (socket-device socket)) + (setf (socket-device socket) nil) + t)) + +;; A passive tcp socket just generates connection streams +(defclass listener-socket (tcp-socket unconnected-socket) ()) + +(defmethod SOCKET-CONNECT ((stream listener-socket)) :passive) + +(defclass file-listener-socket (stream-file-socket unconnected-socket) ()) + +(defmethod SOCKET-CONNECT ((stream file-listener-socket)) :passive) + +;;; A FILE-LISTENER-SOCKET should try to delete the filesystem +;;; entity when closing. + +#-windows-target +(defmethod close :before ((s file-listener-socket) &key abort) + (declare (ignore abort)) + (let* ((path (local-socket-filename (socket-device s) s))) + (when path (%delete-file path)))) + + +;; A udp socket just sends and receives packets. +(defclass udp-socket (ip-socket unconnected-socket) ()) + +(defmethod socket-type ((stream udp-socket)) :datagram) +(defmethod socket-connect ((stream udp-socket)) nil) + +(defgeneric socket-os-fd (socket) + (:documentation + "Return the native OS's representation of the socket, or NIL if the +socket is closed. On Unix, this is the Unix 'file descriptor', a small +non-negative integer. Note that it is rather dangerous to mess around +with tcp-stream fd's, as there is all sorts of buffering and asynchronous +I/O going on above the OS level. listener-socket and udp-socket fd's are +safer to mess with directly as there is less magic going on.")) + +;; Returns nil for closed stream... +(defmethod socket-os-fd ((socket socket)) + (socket-device socket)) + +;; Returns nil for closed stream +(defun local-socket-info (fd type socket) + (and fd + (rlet ((sockaddr :sockaddr_in) + (namelen :signed)) + (setf (pref namelen :signed) (record-length :sockaddr_in)) + (socket-call socket "getsockname" (c_getsockname fd sockaddr namelen)) + (when (= #$AF_INET (pref sockaddr :sockaddr_in.sin_family)) + (ecase type + (:host (ntohl (pref sockaddr + #-(or solaris-target windows-target) :sockaddr_in.sin_addr.s_addr + #+(or solaris-target windows-target) #>sockaddr_in.sin_addr.S_un.S_addr))) + (:port (ntohs (pref sockaddr :sockaddr_in.sin_port)))))))) + +#-windows-target +(defun path-from-unix-address (addr) + (when (= #$AF_UNIX (pref addr :sockaddr_un.sun_family)) + #+darwin-target + (%str-from-ptr (pref addr :sockaddr_un.sun_path) + (- (pref addr :sockaddr_un.sun_len) 2)) + #-darwin-target + (%get-cstring (pref addr :sockaddr_un.sun_path)))) + +#-windows-target +(defun local-socket-filename (fd socket) + (and fd + (rlet ((addr :sockaddr_un) + (namelen :signed)) + (setf (pref namelen :signed) (record-length :sockaddr_un)) + (socket-call socket "getsockname" (c_getsockname fd addr namelen)) + (path-from-unix-address addr)))) + +(defmacro with-if ((var expr) &body body) + `(let ((,var ,expr)) + (if ,var + (progn + ,@body)))) + +(defun remote-socket-info (socket type) + (with-if (fd (socket-device socket)) + (rlet ((sockaddr :sockaddr_in) + (namelen :signed)) + (setf (pref namelen :signed) (record-length :sockaddr_in)) + (let ((err (c_getpeername fd sockaddr namelen))) + (cond ((eql err (- #+windows-target #$WSAENOTCONN #-windows-target #$ENOTCONN)) nil) + ((< err 0) (socket-error socket "getpeername" err)) + (t + (when (= #$AF_INET (pref sockaddr :sockaddr_in.sin_family)) + (ecase type + (:host (ntohl (pref sockaddr + #-(or solaris-target windows-target) :sockaddr_in.sin_addr.s_addr + #+(or solaris-target windows-target) #>sockaddr_in.sin_addr.S_un.S_addr))) + (:port (ntohs (pref sockaddr :sockaddr_in.sin_port))))))))))) + +#-windows-target +(defun remote-socket-filename (socket) + (with-if (fd (socket-device socket)) + (rlet ((addr :sockaddr_un) + (namelen :signed)) + (setf (pref namelen :signed) (record-length :sockaddr_un)) + (let* ((err (c_getsockname fd addr namelen))) + (cond ((eql err (- #$ENOTCONN)) nil) + ((< err 0) (socket-error socket "getpeername" err)) + (t (path-from-unix-address addr))))))) + +(defgeneric local-port (socket) + (:documentation "Return the local port number.")) + +(defmethod local-port ((socket socket)) + (local-socket-info (socket-device socket) :port socket)) + +(defgeneric local-host (socket) + (:documentation + "Return 32-bit unsigned IP address of the local host.")) + +(defmethod local-host ((socket socket)) + (local-socket-info (socket-device socket) :host socket)) + +#-windows-target +(defmethod local-filename ((socket socket)) + (local-socket-filename (socket-device socket) socket)) + +(defgeneric remote-host (socket) + (:documentation + "Return the 32-bit unsigned IP address of the remote host, or NIL if +the socket is not connected.")) + +;; Returns NIL if socket is not connected +(defmethod remote-host ((socket socket)) + (remote-socket-info socket :host)) + +(defgeneric remote-port (socket) + (:documentation + "Return the remote port number, or NIL if the socket is not connected.")) + +(defmethod remote-port ((socket socket)) + (remote-socket-info socket :port)) + +#-windows-target +(defmethod remote-filename ((socket socket)) + (remote-socket-filename socket)) + +(defun set-socket-fd-blocking (fd block-flag) + #+windows-target + (rlet ((argp :u_long (if block-flag 0 1))) + (#_ioctlsocket fd #$FIONBIO argp)) + #-windows-target + (if block-flag + (fd-clear-flag fd #$O_NONBLOCK) + (fd-set-flag fd #$O_NONBLOCK))) + +(defun get-socket-fd-blocking (fd) + "returns T iff socket is in blocking mode" + #+windows-target (declare (ignore fd)) + #+windows-target t + #-windows-target + (not (logtest #$O_NONBLOCK (fd-get-flags fd)))) + +(defun set-socket-options (fd-or-socket &key + keepalive + reuse-address + nodelay + broadcast + linger + address-family + local-port + local-host + local-filename + type + connect + out-of-band-inline + &allow-other-keys) + ;; see man socket(7) tcp(7) ip(7) + (multiple-value-bind (socket fd) (etypecase fd-or-socket + (socket (values fd-or-socket (socket-device fd-or-socket))) + (integer (values nil fd-or-socket))) + + (if (null address-family) + (setq address-family :internet)) + (when keepalive + (int-setsockopt fd #$SOL_SOCKET #$SO_KEEPALIVE 1)) + (when reuse-address + (int-setsockopt fd #$SOL_SOCKET #$SO_REUSEADDR 1)) + (when broadcast + (int-setsockopt fd #$SOL_SOCKET #$SO_BROADCAST 1)) + (when out-of-band-inline + (int-setsockopt fd #$SOL_SOCKET #$SO_OOBINLINE 1)) + (when (eq address-family :internet) + (when (eq type :stream) + (rlet ((plinger :linger)) + (setf (pref plinger :linger.l_onoff) (if linger 1 0) + (pref plinger :linger.l_linger) (or linger 0)) + (socket-call socket "setsockopt" + (c_setsockopt fd #$SOL_SOCKET #$SO_LINGER + plinger (record-length :linger))))) + (when nodelay + (int-setsockopt fd + #+linux-target #$SOL_TCP + #-linux-target #$IPPROTO_TCP + #$TCP_NODELAY 1)) + (when (or local-port local-host) + (let* ((proto (if (eq type :stream) "tcp" "udp")) + (port-n (if local-port (port-as-inet-port local-port proto) 0)) + (host-n (if local-host (host-as-inet-host local-host) #$INADDR_ANY))) + ;; Darwin includes the SIN_ZERO field of the sockaddr_in when + ;; comparing the requested address to the addresses of configured + ;; interfaces (as if the zeros were somehow part of either address.) + ;; "rletz" zeros out the stack-allocated structure, so those zeros + ;; will be 0. + (rletz ((sockaddr :sockaddr_in)) + (setf (pref sockaddr :sockaddr_in.sin_family) #$AF_INET + (pref sockaddr :sockaddr_in.sin_port) port-n + (pref sockaddr + #-(or solaris-target windows-target) :sockaddr_in.sin_addr.s_addr + #+(or solaris-target windows-target) #>sockaddr_in.sin_addr.S_un.S_addr + ) host-n) + (socket-call socket "bind" (c_bind fd sockaddr (record-length :sockaddr_in))))))) + (when (and (eq address-family :file) + (eq connect :passive) + local-filename) + #+windows-target (error "can't create file socket on Windows") + #-windows-target (bind-unix-socket fd local-filename)))) + +;; I hope the inline declaration makes the &rest/apply's go away... +(declaim (inline make-ip-socket)) +(defun make-ip-socket (&rest keys &key type &allow-other-keys) + (declare (dynamic-extent keys)) + (ecase type + ((nil :stream) (apply #'make-tcp-socket keys)) + ((:datagram) (apply #'make-udp-socket keys)))) + +(declaim (inline make-file-socket)) +(defun make-file-socket (&rest keys &key type &allow-other-keys) + (declare (dynamic-extent keys)) + (ecase type + ((nil :stream) (apply #'make-stream-file-socket keys)) + (:datagram (apply #'make-datagram-file-socket keys)))) + +(defun make-socket (&rest keys + &key address-family + ;; List all keys here just for error checking... + ;; &allow-other-keys + type connect remote-host remote-port eol format + keepalive reuse-address nodelay broadcast linger + local-port local-host backlog class out-of-band-inline + local-filename remote-filename sharing basic + external-format (auto-close t) + connect-timeout input-timeout output-timeout deadline + fd) + "Create and return a new socket." + (declare (dynamic-extent keys)) + (declare (ignore type connect remote-host remote-port eol format + keepalive reuse-address nodelay broadcast linger + local-port local-host backlog class out-of-band-inline + local-filename remote-filename sharing basic external-format + auto-close connect-timeout input-timeout output-timeout deadline fd)) + (ecase address-family + ((:file) (apply #'make-file-socket keys)) + ((nil :internet) (apply #'make-ip-socket keys)))) + + + +(defun make-udp-socket (&rest keys &key (fd -1) &allow-other-keys) + (unwind-protect + (let (socket) + (when (< fd 0) + (setq fd (socket-call nil "socket" + (c_socket #$AF_INET #$SOCK_DGRAM #$IPPROTO_UDP)))) + (apply #'set-socket-options fd keys) + (setq socket (make-instance 'udp-socket + :device fd + :keys keys)) + (setq fd -1) + socket) + (unless (< fd 0) + (fd-close fd)))) + +(defun make-tcp-socket (&rest keys &key connect (fd -1) &allow-other-keys) + (unwind-protect + (let (socket) + (when (< fd 0) + (setq fd (socket-call nil "socket" + (c_socket #$AF_INET #$SOCK_STREAM #$IPPROTO_TCP)))) + (apply #'set-socket-options fd keys) + (setq socket + (ecase connect + ((nil :active) (apply #'make-tcp-stream-socket fd keys)) + ((:passive) (apply #'make-tcp-listener-socket fd keys)))) + (setq fd -1) + socket) + (unless (< fd 0) + (fd-close fd)))) + +(defun make-stream-file-socket (&rest keys &key connect (fd -1) &allow-other-keys) + (unwind-protect + (let (socket) + (when (< fd 0) + (setq fd (socket-call nil "socket" (c_socket #$PF_UNIX #$SOCK_STREAM 0)))) + (apply #'set-socket-options fd keys) + (setq socket + (ecase connect + ((nil :active) (apply #'make-file-stream-socket fd keys)) + ((:passive) (apply #'make-file-listener-socket fd keys)))) + (setq fd -1) + socket) + (unless (< fd 0) + (fd-close fd)))) + +(defun make-datagram-file-socket (&rest keys) + (declare (ignore keys)) + (error "Datagram file sockets aren't implemented.")) + + +(defun %socket-connect (fd addr addrlen &optional timeout-in-milliseconds) + (let* ((err (c_connect fd addr addrlen timeout-in-milliseconds))) + (declare (fixnum err)) + (unless (eql err 0) (fd-close fd) (socket-error nil "connect" err)))) + +(defun inet-connect (fd host-n port-n &optional timeout-in-milliseconds) + (rlet ((sockaddr :sockaddr_in)) + (setf (pref sockaddr :sockaddr_in.sin_family) #$AF_INET + (pref sockaddr :sockaddr_in.sin_port) port-n + (pref sockaddr + #-(or solaris-target windows-target) :sockaddr_in.sin_addr.s_addr + #+(or solaris-target windows-target) #>sockaddr_in.sin_addr.S_un.S_addr + ) host-n) + (%socket-connect fd sockaddr (record-length :sockaddr_in) timeout-in-milliseconds))) + +#-windows-target +(defun file-socket-connect (fd remote-filename) + (rletz ((sockaddr :sockaddr_un)) + (init-unix-sockaddr sockaddr remote-filename) + (%socket-connect fd sockaddr (record-length :sockaddr_un)))) + +#+windows-target +(defun file-socket-connect (fd remote-filename) + (declare (ignore fd)) + (error "Can't create file socket to ~s on Windows" remote-filename)) + +(defun make-tcp-stream-socket (fd &rest keys + &key remote-host + remote-port + connect-timeout + deadline + &allow-other-keys) + (let* ((timeout-in-milliseconds + (if deadline + (max (round (- deadline (get-internal-real-time)) + (/ internal-time-units-per-second 1000)) + 0) + (if connect-timeout + (round (* connect-timeout 1000)))))) + (inet-connect fd + (host-as-inet-host remote-host) + (port-as-inet-port remote-port "tcp") + timeout-in-milliseconds) + (apply #'make-tcp-stream fd keys))) + +(defun make-file-stream-socket (fd &rest keys + &key remote-filename + &allow-other-keys) + (file-socket-connect fd remote-filename) + (apply #'make-file-socket-stream fd keys)) + + +(defun make-tcp-stream (fd + &key (format :bivalent) + external-format + (class 'tcp-stream) + sharing + (basic t) + (auto-close t) + input-timeout + output-timeout + deadline + &allow-other-keys) + (let* ((external-format (normalize-external-format :socket external-format))) + (let ((element-type (ecase format + ((nil :text) 'character) + ((:binary :bivalent) '(unsigned-byte 8))))) + ;; TODO: check out fd-stream-advance, -listen, -eofp, -force-output, -close + ;; See if should specialize any of 'em. + (make-fd-stream fd + :class class + :direction :io + :element-type element-type + :sharing sharing + :character-p (not (eq format :binary)) + :encoding (external-format-character-encoding external-format) + :line-termination (external-format-line-termination external-format) + :basic basic + :auto-close auto-close + :input-timeout input-timeout + :output-timeout output-timeout + :deadline deadline)))) + +(defun make-file-socket-stream (fd + &key (format :bivalent) + external-format + (class 'file-socket-stream) + sharing + basic + (auto-close t) + input-timeout + output-timeout + deadline + &allow-other-keys) + (let* ((external-format (normalize-external-format :socket external-format))) + + (let ((element-type (ecase format + ((nil :text) 'character) + ((:binary :bivalent) '(unsigned-byte 8))))) + ;; TODO: check out fd-stream-advance, -listen, -eofp, -force-output, -close + ;; See if should specialize any of 'em. + (make-fd-stream fd + :class class + :direction :io + :element-type element-type + :encoding (external-format-character-encoding external-format) + :line-termination (external-format-line-termination external-format) + :sharing sharing + :character-p (not (eq format :binary)) + :basic basic + :auto-close auto-close + :input-timeout input-timeout + :output-timeout output-timeout + :deadline deadline)))) + +(defun make-tcp-listener-socket (fd &rest keys &key backlog &allow-other-keys) + (socket-call nil "listen" (c_listen fd (or backlog 5))) + (make-instance 'listener-socket + :device fd + :keys keys)) + +(defun make-file-listener-socket (fd &rest keys &key backlog &allow-other-keys) + (socket-call nil "listen" (c_listen fd (or backlog 5))) + (make-instance 'file-listener-socket + :device fd + :keys keys)) + +(defun socket-accept (fd wait) + (flet ((_accept (fd async) + (let ((res (c_accept fd (%null-ptr) (%null-ptr)))) + (declare (fixnum res)) + ;; See the inscrutable note under ERROR HANDLING in + ;; man accept(2). This is my best guess at what they mean... + (if (and async (< res 0) + #+windows-target + (= res #$WSAEWOULDBLOCK) + #-windows-target + (or (eql res (- #$ENETDOWN)) + (eql res (- #+linux-target #$EPROTO + #-linux-target #$EPROTOTYPE)) + (eql res (- #$ENOPROTOOPT)) + (eql res (- #$EHOSTDOWN)) + (eql res (- #+linux-target #$ENONET + #-linux-target #$ENETDOWN)) + (eql res (- #$EHOSTUNREACH)) + (eql res (- #$EOPNOTSUPP)) + (eql res (- #$ENETUNREACH)))) + (- #$EAGAIN) + res)))) + (cond (wait + (with-eagain fd :input + (_accept fd *multiprocessing-socket-io*))) + (*multiprocessing-socket-io* + (_accept fd t)) + (t + (let ((was-blocking (get-socket-fd-blocking fd))) + (unwind-protect + (progn + (set-socket-fd-blocking fd nil) + (_accept fd t)) + (set-socket-fd-blocking fd was-blocking))))))) + +(defun accept-socket-connection (socket wait stream-create-function &optional stream-args) + (let ((listen-fd (socket-device socket)) + (fd -1)) + (unwind-protect + (let ((keys (append stream-args (socket-keys socket)))) + (setq fd (socket-accept listen-fd wait)) + (cond ((>= fd 0) + (prog1 (apply stream-create-function fd keys) + (setq fd -1))) + ((eql fd (- #$EAGAIN)) nil) + (t (socket-error socket "accept" fd)))) + (when (>= fd 0) + (fd-close fd))))) + +(defgeneric accept-connection (socket &key wait stream-args) + (:documentation + "Extract the first connection on the queue of pending connections, +accept it (i.e. complete the connection startup protocol) and return a new +tcp-stream or file-socket-stream representing the newly established +connection. The tcp stream inherits any properties of the listener socket +that are relevant (e.g. :keepalive, :nodelay, etc.) Additional arguments +may be specified using STREAM-ARGS. The original listener +socket continues to be open listening for more connections, so you can call +accept-connection on it again.")) + +(defmethod accept-connection ((socket listener-socket) &key (wait t) stream-args) + (accept-socket-connection socket wait #'make-tcp-stream stream-args)) + +(defmethod accept-connection ((socket file-listener-socket) &key (wait t) stream-args) + (accept-socket-connection socket wait #'make-file-socket-stream stream-args)) + +(defun verify-socket-buffer (buf offset size) + (unless offset (setq offset 0)) + (unless (<= (+ offset size) (length buf)) + (report-bad-arg size `(integer 0 ,(- (length buf) offset)))) + (multiple-value-bind (arr start) (array-data-and-offset buf) + (setq buf arr offset (+ offset start))) + ;; TODO: maybe should allow any raw vector + (let ((subtype (typecode buf))) + (unless #+ppc32-target (and (<= ppc32::min-8-bit-ivector-subtag subtype) + (<= subtype ppc32::max-8-bit-ivector-subtag)) + #+ppc64-target (= (the fixnum (logand subtype ppc64::fulltagmask)) + ppc64::ivector-class-8-bit) + #+x8632-target (and (<= x8632::min-8-bit-ivector-subtag subtype) + (<= subtype x8632::max-8-bit-ivector-subtag)) + #+x8664-target (and (>= subtype x8664::min-8-bit-ivector-subtag) + (<= subtype x8664::max-8-bit-ivector-subtag)) + (report-bad-arg buf `(or (array character) + (array (unsigned-byte 8)) + (array (signed-byte 8)))))) + (values buf offset)) + +(defmethod send-to ((socket udp-socket) msg size + &key remote-host remote-port offset) + "Send a UDP packet over a socket." + (let ((fd (socket-device socket))) + (multiple-value-setq (msg offset) (verify-socket-buffer msg offset size)) + (unless remote-host + (setq remote-host (or (getf (socket-keys socket) :remote-host) + (remote-socket-info socket :host)))) + (unless remote-port + (setq remote-port (or (getf (socket-keys socket) :remote-port) + (remote-socket-info socket :port)))) + (rlet ((sockaddr :sockaddr_in)) + (setf (pref sockaddr :sockaddr_in.sin_family) #$AF_INET) + (setf (pref sockaddr + #-(or solaris-target windows-target) :sockaddr_in.sin_addr.s_addr + #+(or solaris-target windows-target) #>sockaddr_in.sin_addr.S_un.S_addr) + (if remote-host (host-as-inet-host remote-host) #$INADDR_ANY)) + (setf (pref sockaddr :sockaddr_in.sin_port) + (if remote-port (port-as-inet-port remote-port "udp") 0)) + (%stack-block ((bufptr size)) + (%copy-ivector-to-ptr msg offset bufptr 0 size) + (socket-call socket "sendto" + (with-eagain fd :output + (c_sendto fd bufptr size 0 sockaddr (record-length :sockaddr_in)))))))) + +(defmethod receive-from ((socket udp-socket) size &key buffer extract offset) + "Read a UDP packet from a socket. If no packets are available, wait for +a packet to arrive. Returns four values: + The buffer with the data + The number of bytes read + The 32-bit unsigned IP address of the sender of the data + The port number of the sender of the data." + (let ((fd (socket-device socket)) + (vec-offset offset) + (vec buffer) + (ret-size -1)) + (when vec + (multiple-value-setq (vec vec-offset) + (verify-socket-buffer vec vec-offset size))) + (rlet ((sockaddr :sockaddr_in) + (namelen :signed)) + (setf (pref sockaddr :sockaddr_in.sin_family) #$AF_INET) + (setf (pref sockaddr + #-(or solaris-target windows-target) :sockaddr_in.sin_addr.s_addr + #+(or solaris-target windows-target) #>sockaddr_in.sin_addr.S_un.S_addr) + #$INADDR_ANY) + (setf (pref sockaddr :sockaddr_in.sin_port) 0) + (setf (pref namelen :signed) (record-length :sockaddr_in)) + (%stack-block ((bufptr size)) + (setq ret-size (socket-call socket "recvfrom" + (with-eagain fd :input + (c_recvfrom fd bufptr size 0 sockaddr namelen)))) + (unless vec + (setq vec (make-array ret-size + :element-type + (ecase (socket-format socket) + ((:text) 'base-char) + ((:binary :bivalent) '(unsigned-byte 8)))) + vec-offset 0)) + (%copy-ptr-to-ivector bufptr 0 vec vec-offset ret-size)) + (values (cond ((null buffer) + vec) + ((or (not extract) + (and (eql 0 (or offset 0)) + (eql ret-size (length buffer)))) + buffer) + (t + (subseq vec vec-offset (+ vec-offset ret-size)))) + ret-size + (ntohl (pref sockaddr + #-(or solaris-target windows-target) :sockaddr_in.sin_addr.s_addr + #+(or solaris-target windows-target) #>sockaddr_in.sin_addr.S_un.S_addr)) + (ntohs (pref sockaddr :sockaddr_in.sin_port)))))) + +(defgeneric shutdown (socket &key direction) + (:documentation + "Shut down part of a bidirectional connection. This is useful if e.g. +you need to read responses after sending an end-of-file signal.")) + +(defmethod shutdown (socket &key direction) + ;; TODO: should we ignore ENOTCONN error? (at least make sure it + ;; is a distinct, catchable error type). + (let ((fd (socket-device socket))) + (socket-call socket "shutdown" + (c_shutdown fd (ecase direction + (:input 0) + (:output 1)))))) + +;; Accepts port as specified by user, returns port number in network byte +;; order. Protocol should be one of "tcp" or "udp". Error if not known. +(defun port-as-inet-port (port proto) + (or (etypecase port + (fixnum (htons port)) + (string (_getservbyname port proto)) + (symbol (_getservbyname (string-downcase (symbol-name port)) proto))) + (socket-error nil "getservbyname" (- #$ENOENT)))) + +(defun lookup-port (port proto) + "Find the port number for the specified port and protocol." + (if (fixnump port) + port + (ntohs (port-as-inet-port port proto)))) + +;; Accepts host as specified by user, returns host number in network byte +;; order. +(defun host-as-inet-host (host) + (etypecase host + (integer (htonl host)) + (string (or (and (every #'(lambda (c) (position c ".0123456789")) host) + (_inet_aton host)) + (multiple-value-bind (addr err) (c_gethostbyname host) + (or addr + (socket-error nil "gethostbyname" err t))))))) + + +(defun dotted-to-ipaddr (name &key (errorp t)) + "Convert a dotted-string representation of a host address to a 32-bit +unsigned IP address." + (let ((addr (_inet_aton name))) + (if addr (ntohl addr) + (and errorp (error "Invalid dotted address ~s" name))))) + +(defun lookup-hostname (host) + "Convert a host spec in any of the acceptable formats into a 32-bit +unsigned IP address." + (if (typep host 'integer) + host + (ntohl (host-as-inet-host host)))) + +(defun ipaddr-to-dotted (addr &key values) + "Convert a 32-bit unsigned IP address into octets." + (let* ((a (ldb (byte 8 24) addr)) + (b (ldb (byte 8 16) addr)) + (c (ldb (byte 8 8) addr)) + (d (ldb (byte 8 0) addr))) + (if values + (values a b c d) + (format nil "~d.~d.~d.~d" a b c d)))) + +(defun ipaddr-to-hostname (ipaddr &key ignore-cache) + "Convert a 32-bit unsigned IP address into a host name string." + (declare (ignore ignore-cache)) + (multiple-value-bind (name err) (c_gethostbyaddr (htonl ipaddr)) + (or name (socket-error nil "gethostbyaddr" err t)))) + + + +(defun int-getsockopt (socket level optname) + (rlet ((valptr :signed) + (vallen :signed)) + (setf (pref vallen :signed) 4) + (let* ((err (c_getsockopt socket level optname valptr vallen))) + (if (and (eql 0 err) + (eql 4 (pref vallen :signed))) + (pref valptr :signed) + (socket-error socket "getsockopt" err))))) + +(defun timeval-setsockopt (socket level optname timeout) + (multiple-value-bind (seconds micros) + (microseconds timeout) + (rlet ((valptr :timeval :tv_sec seconds :tv_usec micros)) + (socket-call socket "setsockopt" + (c_setsockopt socket level optname valptr (record-length :timeval)))))) + +(defun int-setsockopt (socket level optname optval) + (rlet ((valptr :signed)) + (setf (pref valptr :signed) optval) + (socket-call socket "setsockopt" + (c_setsockopt socket level optname valptr (record-length :signed))))) + + + + +(defun c_gethostbyaddr (addr-in-net-byte-order) + (rletZ ((sin #>sockaddr_in)) + (setf (pref sin :sockaddr_in.sin_family) #$AF_INET + (pref sin + #+(or windows-target solaris-target) #>sockaddr_in.sin_addr.S_un.S_addr + #-(or windows-target solaris-target) #>sockaddr_in.sin_addr.s_addr) addr-in-net-byte-order) + #+darwin-target (setf (pref sin :sockaddr_in.sin_len) (record-length :sockaddr_in)) + (%stack-block ((namep #$NI_MAXHOST)) + (let* ((err (#_getnameinfo sin (record-length #>sockaddr_in) namep #$NI_MAXHOST (%null-ptr) 0 #$NI_NAMEREQD))) + (if (eql 0 err) + (%get-cstring namep) + (values nil err)))))) + +(defun c_gethostbyname (name) + (with-cstrs ((name (string name))) + (rletZ ((hints #>addrinfo) + (results :address)) + (setf (pref hints #>addrinfo.ai_family) #$AF_INET) + (let* ((err (#_getaddrinfo name (%null-ptr) hints results))) + (if (eql 0 err) + (let* ((info (pref results :address)) + (sin (pref info #>addrinfo.ai_addr))) + (prog1 + #+(or windows-target solaris-target) + (pref sin #>sockaddr_in.sin_addr.S_un.S_addr) + #-(or windows-target solaris-target) + (pref sin #>sockaddr_in.sin_addr.s_addr) + (#_freeaddrinfo info))) + (values nil err)))))) + + + + + +(defun _getservbyname (name proto) + (with-cstrs ((name (string name)) + (proto (string proto))) + (let* ((servent-ptr (%null-ptr))) + (declare (dynamic-extent servent-ptr)) + (%setf-macptr servent-ptr (#_getservbyname name proto)) + (unless (%null-ptr-p servent-ptr) + (pref servent-ptr :servent.s_port))))) + +(defun _inet_aton (string) + (with-cstrs ((name string)) + #-windows-target + (rlet ((addr :in_addr)) + (let* ((result #+freebsd-target (#___inet_aton name addr) + #-freebsd-target (#_inet_aton name addr))) + (unless (eql result 0) + (pref addr + #-solaris-target :in_addr.s_addr + #+solaris-target #>in_addr.S_un.S_addr + )))) + #+windows-target + (rlet ((addr :sockaddr_in) + (addrlenp :int (record-length :sockaddr_in))) + (setf (pref addr :sockaddr_in.sin_family) #$AF_INET) + (when (zerop (#_WSAStringToAddressA name #$AF_INET (%null-ptr) addr addrlenp)) + (pref addr #>sockaddr_in.sin_addr.S_un.S_addr))))) + +(defun c_socket_1 (domain type protocol) + #-windows-target (int-errno-call (#_socket domain type protocol)) + #+windows-target (let* ((handle (#_socket domain type protocol))) + (if (< handle 0) + (%get-winsock-error) + handle))) + + + +(defun c_socket (domain type protocol) + (let* ((fd (c_socket_1 domain type protocol))) + (when (or (eql fd (- #$EMFILE)) + (eql fd (- #$ENFILE))) + (gc) + (drain-termination-queue) + (setq fd (c_socket_1 domain type protocol))) + fd)) + + +#-windows-target +(defun init-unix-sockaddr (addr path) + (macrolet ((sockaddr_un-path-len () + (/ (ensure-foreign-type-bits + (foreign-record-field-type + (%find-foreign-record-type-field + (parse-foreign-type '(:struct :sockaddr_un)) :sun_path))) + 8))) + (let* ((name (native-translated-namestring path)) + (namelen (length name)) + (pathlen (sockaddr_un-path-len)) + (copylen (min (1- pathlen) namelen))) + (setf (pref addr :sockaddr_un.sun_family) #$AF_UNIX) + (let* ((sun-path (pref addr :sockaddr_un.sun_path))) + (dotimes (i copylen) + (setf (%get-unsigned-byte sun-path i) + (let* ((code (char-code (schar name i)))) + (if (> code 255) + (char-code #\Sub) + code)))))))) + +#-windows-target +(defun bind-unix-socket (socketfd path) + (rletz ((addr :sockaddr_un)) + (init-unix-sockaddr addr path) + (socket-call + nil + "bind" + (c_bind socketfd + addr + (+ 2 + (#_strlen + (pref addr :sockaddr_un.sun_path))))))) + + +(defun c_bind (sockfd sockaddr addrlen) + (check-socket-error (#_bind sockfd sockaddr addrlen))) + + +#+windows-target +(defun windows-connect-wait (sockfd timeout-in-milliseconds) + (if (and timeout-in-milliseconds + (< timeout-in-milliseconds 0)) + (setq timeout-in-milliseconds nil)) + (rlet ((writefds :fd_set) + (exceptfds :fd_set) + (tv :timeval :tv_sec 0 :tv_usec 0)) + (fd-zero writefds) + (fd-zero exceptfds) + (fd-set sockfd writefds) + (fd-set sockfd exceptfds) + (when timeout-in-milliseconds + (multiple-value-bind (seconds milliseconds) + (floor timeout-in-milliseconds 1000) + (setf (pref tv :timeval.tv_sec) seconds + (pref tv :timeval.tv_usec) (* 1000 milliseconds)))) + (> (#_select 1 (%null-ptr) writefds exceptfds (if timeout-in-milliseconds tv (%null-ptr))) 0))) + + +;;; If attempts to connnect are interrupted, we basically have to +;;; wait in #_select (or the equivalent). There's a good rant +;;; about these issues in: +;;; +(defun c_connect (sockfd addr len &optional timeout-in-milliseconds) + (let* ((was-blocking (get-socket-fd-blocking sockfd))) + (unwind-protect + (progn + (set-socket-fd-blocking sockfd nil) + (let* ((err (check-socket-error (#_connect sockfd addr len)))) + (cond ((or (eql err (- #+windows-target #$WSAEINPROGRESS + + #-windows-target #$EINPROGRESS)) + #+windows-target (eql err (- #$WSAEWOULDBLOCK)) + (eql err (- #$EINTR))) + (if + #+windows-target (windows-connect-wait sockfd timeout-in-milliseconds) + #-windows-target (process-output-wait sockfd timeout-in-milliseconds) + (- (int-getsockopt sockfd #$SOL_SOCKET #$SO_ERROR)) + (- #+windows-target #$WSAETIMEDOUT #-windows-target #$ETIMEDOUT))) + (t err)))) + (set-socket-fd-blocking sockfd was-blocking)))) + +(defun c_listen (sockfd backlog) + (check-socket-error (#_listen sockfd backlog))) + +(defun c_accept (sockfd addrp addrlenp) + (ignoring-eintr + (check-socket-error (#_accept sockfd addrp addrlenp)))) + +(defun c_getsockname (sockfd addrp addrlenp) + (check-socket-error (#_getsockname sockfd addrp addrlenp))) + +(defun c_getpeername (sockfd addrp addrlenp) + (check-socket-error (#_getpeername sockfd addrp addrlenp))) + +#-windows-target +(defun c_socketpair (domain type protocol socketsptr) + (check-socket-error (#_socketpair domain type protocol socketsptr))) + + +(defun c_sendto (sockfd msgptr len flags addrp addrlen) + (ignoring-eintr (check-socket-error (#_sendto sockfd msgptr len flags addrp addrlen)))) + +(defun c_recvfrom (sockfd bufptr len flags addrp addrlenp) + (ignoring-eintr (check-socket-error (#_recvfrom sockfd bufptr len flags addrp addrlenp)))) + +(defun c_shutdown (sockfd how) + (check-socket-error (#_shutdown sockfd how))) + +(defun c_setsockopt (sockfd level optname optvalp optlen) + (check-socket-error (#_setsockopt sockfd level optname optvalp optlen))) + +(defun c_getsockopt (sockfd level optname optvalp optlenp) + (check-socket-error (#_getsockopt sockfd level optname optvalp optlenp))) + +#-windows-target +(defun c_sendmsg (sockfd msghdrp flags) + (check-socket-error (#_sendmsg sockfd msghdrp flags))) + +#-windows-target +(defun c_recvmsg (sockfd msghdrp flags) + (check-socket-error (#_recvmsg sockfd msghdrp flags))) + + +;;; Return a list of currently configured interfaces, a la ifconfig. +(defstruct ip-interface + name + addr + netmask + flags + address-family) + +(defun dump-buffer (p n) + (dotimes (i n (progn (terpri) (terpri))) + (unless (logtest i 15) + (format t "~&~8,'0x: " (%ptr-to-int (%inc-ptr p i)))) + (format t " ~2,'0x" (%get-byte p i)))) + +#-(or windows-target solaris-target) +(defun %get-ip-interfaces () + (rlet ((p :address (%null-ptr))) + (if (zerop (#_getifaddrs p)) + (unwind-protect + (do* ((q (%get-ptr p) (pref q :ifaddrs.ifa_next)) + (res ())) + ((%null-ptr-p q) (nreverse res)) + (let* ((addr (pref q :ifaddrs.ifa_addr))) + (when (and (not (%null-ptr-p addr)) + (eql (pref addr :sockaddr.sa_family) #$AF_INET)) + (push (make-ip-interface + :name (%get-cstring (pref q :ifaddrs.ifa_name)) + :addr (ntohl (pref addr :sockaddr_in.sin_addr.s_addr)) + :netmask (ntohl + (pref (pref q :ifaddrs.ifa_netmask) + :sockaddr_in.sin_addr.s_addr)) + :flags (pref q :ifaddrs.ifa_flags) + :address-family #$AF_INET) + res)))) + (#_freeifaddrs (pref p :address)))))) + +#+solaris-target +(progn + ;;; Interface translator has trouble with a lot of ioctl constants. + (eval-when (:compile-toplevel :execute) + (defconstant os::|SIOCGLIFNUM| #xc00c6982) + (defconstant os::|SIOCGLIFCONF| #xc01069a5) + (defconstant os::|SIOCGLIFADDR| #xc0786971) + (defconstant os::|SIOCGLIFFLAGS| #xc0786975) + (defconstant os::|SIOCGLIFNETMASK| #xc078697d) + ) + +(defun %get-ip-interfaces () + (let* ((sock (c_socket #$AF_INET #$SOCK_DGRAM #$IPPROTO_UDP)) + (res nil)) + (when (>= sock 0) + (unwind-protect + (let* ((flags (logior #$LIFC_NOXMIT #$LIFC_TEMPORARY #$LIFC_ALLZONES)) + (ninterfaces (rlet ((lifnum :lifnum + :lifn_flags flags + :lifn_family #$AF_INET + :lifn_count 0)) + (#_ioctl sock os::SIOCGLIFNUM :address lifnum) + (pref lifnum :lifnum.lifn_count)))) + (declare (fixnum ninterfaces)) + (when (> ninterfaces 0) + (let* ((bufsize (* ninterfaces (record-length :lifreq)))) + (%stack-block ((buf bufsize :clear t)) + (rlet ((lifc :lifconf + :lifc_family #$AF_INET + :lifc_flags flags + :lifc_len bufsize + :lifc_lifcu.lifcu_buf buf)) + (when (>= (#_ioctl sock os::SIOCGLIFCONF :address lifc) 0) + (do* ((i 0 (1+ i)) + (p (pref lifc :lifconf.lifc_lifcu.lifcu_buf) + (%inc-ptr p (record-length :lifreq)))) + ((= i ninterfaces)) + (let* ((name (%get-cstring (pref p :lifreq.lifr_name))) + (address-family (pref p :lifreq.lifr_lifru.lifru_addr.ss_family)) + (if-flags nil) + (address nil) + (netmask nil)) + (if (>= (#_ioctl sock os::SIOCGLIFFLAGS :address p) + 0) + (setq if-flags (pref p :lifreq.lifr_lifru.lifru_flags))) + (if (>= (#_ioctl sock os::SIOCGLIFADDR :address p) + 0) + (setq address (pref + (pref p :lifreq.lifr_lifru.lifru_addr) + #>sockaddr_in.sin_addr.S_un.S_addr))) + (if (>= (#_ioctl sock os::SIOCGLIFNETMASK :address p) + 0) + (setq netmask (pref + (pref p :lifreq.lifr_lifru.lifru_subnet) + #>sockaddr_in.sin_addr.S_un.S_addr))) + + (push (make-ip-interface + :name name + :addr (ntohl address) + :netmask (ntohl netmask) + :flags if-flags + :address-family address-family) + res))))))))) + (fd-close sock))) + res)) +) + + + + +#+windows-target +(defun %get-ip-interfaces () + (let* ((socket (#_socket #$AF_INET #$SOCK_DGRAM #$IPPROTO_IP))) + (unwind-protect + (rlet ((realoutlen #>DWORD 0)) + (do* ((reservedlen (* 4 (record-length #>INTERFACE_INFO)) + (* 2 reservedlen))) + () + (%stack-block ((buf reservedlen)) + (unless (eql 0 (#_WSAIoctl + socket + #$SIO_GET_INTERFACE_LIST + (%null-ptr) + 0 + buf + reservedlen + realoutlen + (%null-ptr) + (%null-ptr))) + (return)) + (let* ((noutbytes (pref realoutlen #>DWORD))) + (when (< noutbytes reservedlen) + (let* ((interfaces nil)) + (do* ((offset 0 (+ offset (record-length #>INTERFACE_INFO))) + (nameidx 0 (1+ nameidx))) + ((>= offset noutbytes)) + (with-macptrs ((p (%inc-ptr buf offset))) + (push (make-ip-interface + :name (format nil "ip~d" nameidx) + :addr (ntohl + (pref (pref p #>INTERFACE_INFO.iiAddress) + #>sockaddr_gen.AddressIn.sin_addr.S_un.S_addr)) + :netmask (ntohl + (pref (pref p #>INTERFACE_INFO.iiNetmask) + #>sockaddr_gen.AddressIn.sin_addr.S_un.S_addr)) + :flags (pref p #>INTERFACE_INFO.iiFlags) + :address-family #$AF_INET) + interfaces))) + (return interfaces))))))) + (#_closesocket socket)))) + + + + +(defloadvar *ip-interfaces* ()) + +(defun ip-interfaces () + (or *ip-interfaces* + (setq *ip-interfaces* (%get-ip-interfaces)))) + +;;; This should presumably happen after a configuration change. +;;; How do we detect a configuration change ? +(defun %reset-ip-interfaces () + (setq *ip-interfaces* ())) + +;;; Return the first non-loopback interface that's up and whose address +;;; family is #$AF_INET. If no such interface exists, return +;;; the loopback interface. +(defun primary-ip-interface () + (let* ((ifaces (ip-interfaces))) + (or (find-if #'(lambda (i) + (and (eq #$AF_INET (ip-interface-address-family i)) + (ip-interface-addr i) + (let* ((flags (ip-interface-flags i))) + (and (not (logtest #$IFF_LOOPBACK flags)) + (logtest #$IFF_UP flags))))) + ifaces) + (car ifaces)))) + +(defun primary-ip-interface-address () + (let* ((iface (primary-ip-interface))) + (if iface + (ip-interface-addr iface) + (error "Can't determine primary IP interface")))) + + +(defmethod stream-io-error ((stream socket) errno where) + (socket-error stream where errno)) Index: /branches/new-random/level-1/l1-sort.lisp =================================================================== --- /branches/new-random/level-1/l1-sort.lisp (revision 13309) +++ /branches/new-random/level-1/l1-sort.lisp (revision 13309) @@ -0,0 +1,167 @@ +;;;-*-Mode: LISP; Package: CCL -*- +;;; +;;; Copyright (C) 2009 Clozure Associates +;;; Copyright (C) 1994-2001 Digitool, Inc +;;; This file is part of Clozure CL. +;;; +;;; Clozure CL is licensed under the terms of the Lisp Lesser GNU Public +;;; License , known as the LLGPL and distributed with Clozure CL as the +;;; file "LICENSE". The LLGPL consists of a preamble and the LGPL, +;;; which is distributed with Clozure CL as the file "LGPL". Where these +;;; conflict, the preamble takes precedence. +;;; +;;; Clozure CL is referenced in the preamble as the "LIBRARY." +;;; +;;; The LLGPL is also available online at +;;; http://opensource.franz.com/preamble.html + +;;; Low-level list sorting routines. Used by CLOS and SORT. + +(in-package "CCL") + +(eval-when (:compile-toplevel :execute) + +(defmacro apply-key (key value) + `(if ,key + (funcall ,key ,value) + ,value)) + +) + +;; A macro to make predicate & key into lfuns, or maybe NIL. +(defmacro canonicalize-pred-and-key (&optional (pred 'pred) (key 'key)) + `(progn (setq ,pred (coerce-to-function ,pred)) + (unless (null ,key) + (setq ,key (coerce-to-function ,key)) + (if (eq ,key #'identity) (setq ,key nil))))) + + +(defun final-cons (p) + (do* ((drag p lead) + (lead (cdr p) (cdr lead))) + ((null lead) + drag))) + +;;; modified to return a pointer to the end of the result +;;; and to not cons header each time its called. +;;; It destructively merges list-1 with list-2. In the resulting +;;; list, elements of list-2 are guaranteed to come after equal elements +;;; of list-1. +(defun merge-lists* (list-1 list-2 pred key) + (declare (optimize (speed 3) (safety 0))) + (if (null key) + (merge-lists*-no-key list-1 list-2 pred) + (cond ((null list-1) + (values list-2 (final-cons list-2))) + ((null list-2) + (values list-1 (final-cons list-1))) + (t (let* ((result (cons nil nil)) + (P result) ; P points to last cell of result + (key-1 (apply-key key (car list-1))) + (key-2 (apply-key key (car list-2)))) + (declare (dynamic-extent result)) + (declare (type list p)) + (loop + (cond ((funcall pred key-2 key-1) + (rplacd P list-2) ; append the lesser list to last cell of + (setq P (cdr P)) ; result. Note: test must bo done for + (pop list-2) ; list-2 < list-1 so merge will be + (unless list-2 ; stable for list-1 + (rplacd P list-1) + (return (values (cdr result) (final-cons p)))) + (setq key-2 (apply-key key (car list-2)))) + (T (rplacd P list-1) + (setq P (cdr P)) + (pop list-1) + (unless list-1 + (rplacd P list-2) + (return (values (cdr result) (final-cons p)))) + (setq key-1 (apply-key key (car list-1))))))))))) + +(defun merge-lists*-no-key (list-1 list-2 pred) + (declare (optimize (speed 3) (safety 0))) + (cond ((null list-1) + (values list-2 (final-cons list-2))) + ((null list-2) + (values list-1 (final-cons list-1))) + (t (let* ((result (cons nil nil)) + (P result) ; P points to last cell of result + (key-1 (car list-1)) + (key-2 (car list-2))) + (declare (dynamic-extent result)) + (declare (type list p)) + (loop + (cond ((funcall pred key-2 key-1) + (rplacd P list-2) ; append the lesser list to last cell of + (setq P (cdr P)) ; result. Note: test must bo done for + (pop list-2) ; list-2 < list-1 so merge will be + (unless list-2 ; stable for list-1 + (rplacd P list-1) + (return (values (cdr result) (final-cons p)))) + (setq key-2 (car list-2))) + (T (rplacd P list-1) + (setq P (cdr P)) + (pop list-1) + (unless list-1 + (rplacd P list-2) + (return (values (cdr result) (final-cons p)))) + (setq key-1 (car list-1))))))))) + +(defun sort-list (list pred key) + (canonicalize-pred-and-key pred key) + (let ((head (cons nil list)) ; head holds on to everything + (n 1) ; bottom-up size of lists to be merged + unsorted ; unsorted is the remaining list to be + ; broken into n size lists and merged + list-1 ; list-1 is one length n list to be merged + last) ; last points to the last visited cell + (declare (fixnum n)) + (declare (dynamic-extent head)) + (loop + ;; start collecting runs of n at the first element + (setf unsorted (cdr head)) + ;; tack on the first merge of two n-runs to the head holder + (setf last head) + (let ((n-1 (1- n))) + (declare (fixnum n-1)) + (loop + (setf list-1 unsorted) + (let ((temp (nthcdr n-1 list-1)) + list-2) + (cond (temp + ;; there are enough elements for a second run + (setf list-2 (cdr temp)) + (setf (cdr temp) nil) + (setf temp (nthcdr n-1 list-2)) + (cond (temp + (setf unsorted (cdr temp)) + (setf (cdr temp) nil)) + ;; the second run goes off the end of the list + (t (setf unsorted nil))) + (multiple-value-bind (merged-head merged-last) + (merge-lists* list-1 list-2 pred key) + (setf (cdr last) merged-head) + (setf last merged-last)) + (if (null unsorted) (return))) + ;; if there is only one run, then tack it on to the end + (t (setf (cdr last) list-1) + (return))))) + (setf n (ash n 1)) ; (+ n n) + ;; If the inner loop only executed once, then there were only enough + ;; elements for two runs given n, so all the elements have been merged + ;; into one list. This may waste one outer iteration to realize. + (if (eq list-1 (cdr head)) + (return list-1)))))) + + +;; The no-key version of %sort-list +;; list had better be a list. +;; pred had better be functionp. +(defun %sort-list-no-key (list pred) + (sort-list list pred nil)) + +(defun sort-list-error () + (error "List arg to SORT not a proper list")) + + + Index: /branches/new-random/level-1/l1-streams.lisp =================================================================== --- /branches/new-random/level-1/l1-streams.lisp (revision 13309) +++ /branches/new-random/level-1/l1-streams.lisp (revision 13309) @@ -0,0 +1,6075 @@ +;;;-*-Mode: LISP; Package: CCL -*- +;;; +;;; Copyright (C) 1994-2001 Digitool, Inc +;;; Portions copyright (C) 2001-2009 Clozure Associates +;;; This file is part of Clozure CL. +;;; +;;; Clozure CL is licensed under the terms of the Lisp Lesser GNU Public +;;; License , known as the LLGPL and distributed with Clozure CL as the +;;; file "LICENSE". The LLGPL consists of a preamble and the LGPL, +;;; which is distributed with Clozure CL as the file "LGPL". Where these +;;; conflict, the preamble takes precedence. +;;; +;;; Clozure CL is referenced in the preamble as the "LIBRARY." +;;; +;;; The LLGPL is also available online at +;;; http://opensource.franz.com/preamble.html + +(in-package "CCL") + +;;; + +(defclass stream () + ()) + + +(defclass input-stream (stream) + ()) + + +(defclass output-stream (stream) ()) + +(defmethod stream-direction ((s stream)) + ) + +(defmethod stream-domain ((s stream)) + t) + + +(defmethod stream-direction ((s input-stream)) + (if (typep s 'output-stream) + :io + :input)) + +(defmethod stream-direction ((s output-stream)) + (if (typep s 'input-stream) + :io + :output)) + +(defun check-io-timeout (timeout) + (when timeout + (require-type timeout '(real 0 1000000)))) + +(defmethod stream-input-timeout ((s input-stream)) + nil) + +(defmethod (setf input-stream-timeout) (new (s input-stream)) + (check-io-timeout new)) + +(defmethod stream-output-timeout ((s output-stream)) + nil) + +(defmethod (setf stream-output-timeout) (new (s output-stream)) + (check-io-timeout new)) + +;;; Try to return a string containing characters that're near the +;;; stream's current position, if that makes sense. Return NIL +;;; if it doesn't make sense. +;;; Some things (SOCKET-ERRORs) are signaled as STREAM-ERRORs +;;; whose STREAM args aren't streams. That's wrong, but +;;; defining this method on T keeps things from blowing up worse. +(defmethod stream-surrounding-characters ((s t)) + (declare (ignore s)) + nil) + + +;;; The "direction" argument only helps us dispatch on two-way streams: +;;; it's legal to ask for the :output device of a stream that's only open +;;; for input, and one might get a non-null answer in that case. +(defmethod stream-device ((s stream) direction) + (declare (ignore direction))) + +;;; Some generic stream functions: +(defmethod stream-length ((x t) &optional new) + (declare (ignore new)) + (report-bad-arg x 'stream)) + +(defmethod stream-position ((x t) &optional new) + (declare (ignore new)) + (report-bad-arg x 'stream)) + +(defmethod stream-element-type ((x t)) + (report-bad-arg x 'stream)) + +(defmethod stream-force-output ((x t)) + (report-bad-arg x 'stream)) + +(defmethod stream-position ((s stream) &optional newpos) + (declare (ignore newpos))) + +;;; For input streams: + +;; From Shannon Spires, slightly modified. +(defun generic-read-line (s) + (let* ((str (make-array 20 :element-type 'base-char + :adjustable t :fill-pointer 0)) + (eof nil)) + (do* ((ch (read-char s nil :eof) (read-char s nil :eof))) + ((or (eq ch #\newline) (setq eof (eq ch :eof))) + (values (ensure-simple-string str) eof)) + (vector-push-extend ch str)))) + +(defun generic-character-read-list (stream list count) + (declare (fixnum count)) + (do* ((tail list (cdr tail)) + (i 0 (1+ i))) + ((= i count) count) + (declare (fixnum i)) + (let* ((ch (read-char stream nil :eof))) + (if (eq ch :eof) + (return i) + (rplaca tail ch))))) + +(defun generic-binary-read-list (stream list count) + (declare (fixnum count)) + (do* ((tail list (cdr tail)) + (i 0 (1+ i))) + ((= i count) count) + (declare (fixnum i)) + (let* ((ch (stream-read-byte stream))) + (if (eq ch :eof) + (return i) + (rplaca tail ch))))) + +(defun generic-character-read-vector (stream vector start end) + (declare (fixnum start end)) + (do* ((i start (1+ i))) + ((= i end) end) + (declare (fixnum i)) + (let* ((ch (stream-read-char stream))) + (if (eq ch :eof) + (return i) + (setf (uvref vector i) ch))))) + +(defun generic-binary-read-vector (stream vector start end) + (declare (fixnum start end)) + (do* ((i start (1+ i))) + ((= i end) end) + (declare (fixnum i)) + (let* ((byte (stream-read-byte stream))) + (if (eq byte :eof) + (return i) + (setf (uvref vector i) byte))))) + + +;;; For output streams: + +(defun generic-advance-to-column (s col) + (let* ((current (column s))) + (unless (null current) + (when (< current col) + (do* ((i current (1+ i))) + ((= i col)) + (write-char #\Space s))) + t))) + + + +(defun generic-stream-write-string (stream string start end) + (setq end (check-sequence-bounds string start end)) + (locally (declare (fixnum start end)) + (multiple-value-bind (vect offset) (array-data-and-offset string) + (declare (fixnum offset)) + (unless (zerop offset) + (incf start offset) + (incf end offset)) + (do* ((i start (1+ i))) + ((= i end) string) + (declare (fixnum i)) + (write-char (schar vect i) stream))))) + + + + + + + + + + + + + +(defstatic *heap-ivectors* ()) +(defvar *heap-ivector-lock* (make-lock)) + + + +(defun %make-heap-ivector (subtype size-in-bytes size-in-elts) + (with-macptrs ((ptr (malloc (+ size-in-bytes + #+32-bit-target (+ 4 2 7) ; 4 for header, 2 for delta, 7 for round up + #+64-bit-target (+ 8 2 15) ; 8 for header, 2 for delta, 15 for round up + )))) + (let ((vect (fudge-heap-pointer ptr subtype size-in-elts)) + (p (%null-ptr))) + (%vect-data-to-macptr vect p) + (with-lock-grabbed (*heap-ivector-lock*) + (push vect *heap-ivectors*)) + (values vect p)))) + +(defun %heap-ivector-p (v) + (with-lock-grabbed (*heap-ivector-lock*) + (not (null (member v *heap-ivectors* :test #'eq))))) + + +(defun dispose-heap-ivector (v) + (if (%heap-ivector-p v) + (with-macptrs (p) + (with-lock-grabbed (*heap-ivector-lock*) + (setq *heap-ivectors* (delq v *heap-ivectors*))) + (%%make-disposable p v) + (free p)))) + +(defun %dispose-heap-ivector (v) + (dispose-heap-ivector v)) + +(defun make-heap-ivector (element-count element-type) + (require-type element-count `(unsigned-byte ,(- target::nbits-in-word + target::num-subtag-bits))) + (let* ((subtag (ccl::element-type-subtype element-type))) + (unless + #+ppc32-target + (= (logand subtag ppc32::fulltagmask) + ppc32::fulltag-immheader) + #+ppc64-target + (= (logand subtag ppc64::lowtagmask) + ppc64::lowtag-immheader) + #+x8632-target + (= (logand subtag x8632::fulltagmask) + x8632::fulltag-immheader) + #+x8664-target + (logbitp (the (mod 16) (logand subtag x8664::fulltagmask)) + (logior (ash 1 x8664::fulltag-immheader-0) + (ash 1 x8664::fulltag-immheader-1) + (ash 1 x8664::fulltag-immheader-2))) + (error "~s is not an ivector subtype." element-type)) + (let* ((size-in-octets (ccl::subtag-bytes subtag element-count))) + (multiple-value-bind (pointer vector) + (ccl::%make-heap-ivector subtag size-in-octets element-count) + (values pointer vector size-in-octets))))) + + + + + + + + + +(defvar *elements-per-buffer* 2048) ; default buffer size for file io + +(defmethod streamp ((x t)) + nil) + +(defmethod streamp ((x stream)) + t) + +(defmethod stream-io-error ((stream stream) error-number context) + (error 'simple-stream-error :stream stream + :format-control (format nil "~a during ~a" + (%strerror error-number) context))) + + + +(defmethod stream-write-char ((stream stream) char) + (declare (ignore char)) + (error "stream ~S is not capable of output" stream)) + +(defun stream-write-entire-string (stream string) + (stream-write-string stream string)) + + +(defmethod stream-read-char ((x t)) + (report-bad-arg x 'stream)) + +(defmethod stream-read-char ((stream stream)) + (error "~s is not capable of input" stream)) + +(defmethod stream-unread-char ((x t) char) + (declare (ignore char)) + (report-bad-arg x 'stream)) + +(defmethod stream-unread-char ((stream stream) char) + (declare (ignore char)) + (error "stream ~S is not capable of input" stream)) + + + +(defmethod stream-force-output ((stream output-stream)) nil) +(defmethod stream-maybe-force-output ((stream stream)) + (stream-force-output stream)) + +(defmethod stream-finish-output ((stream output-stream)) nil) + + + +(defmethod stream-clear-output ((stream output-stream)) nil) + +(defmethod close ((stream stream) &key abort) + (declare (ignore abort)) + (open-stream-p stream)) + +(defmethod close-for-termination ((stream stream) abort) + (close stream :abort abort)) + + +(defmethod open-stream-p ((x t)) + (report-bad-arg x 'stream)) + +(defmethod open-stream-p ((stream stream)) + t) + +(defmethod stream-external-format ((x t)) + (report-bad-arg x 'stream)) + +(defmethod stream-external-format ((s stream)) + nil) + + +(defmethod (setf stream-external-format) (new (s t)) + (normalize-external-format (stream-domain s) new) + (report-bad-arg s 'stream)) + + + + +(defmethod stream-fresh-line ((stream output-stream)) + (terpri stream) + t) + +(defmethod stream-line-length ((stream stream)) + "This is meant to be shadowed by particular kinds of streams, + esp those associated with windows." + 80) + +(defmethod interactive-stream-p ((x t)) + (report-bad-arg x 'stream)) + +(defmethod interactive-stream-p ((stream stream)) nil) + +(defmethod stream-clear-input ((x t)) + (report-bad-arg x 'input-stream)) + +(defmethod stream-clear-input ((stream input-stream)) nil) + +(defmethod stream-listen ((stream input-stream)) + (not (eofp stream))) + +(defmethod stream-filename ((stream stream)) + (report-bad-arg stream 'file-stream)) + + + + + +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; + +;;; For input streams, the IO-BUFFER-COUNT field denotes the number +;;; of elements read from the underlying input source (e.g., the +;;; file system.) For output streams, it's the high-water mark of +;;; elements output to the buffer. + +(defstruct io-buffer + ;; This type is too complex during bootstrapping. + (buffer nil #|:type (or (simple-array * (*)) null)|#) + (bufptr nil :type (or macptr null)) + (size 0 :type fixnum) ; size (in octets) of buffer + (idx 0 :type fixnum) ; index of next element + (count 0 :type fixnum) ; count of active elements + (limit 0 :type fixnum) ; size (in elements) of buffer + (translate nil) ; newline-translation + ) + +(defmethod print-object ((buf io-buffer) out) + (print-unreadable-object (buf out :identity t :type t) + (let* ((buffer (io-buffer-buffer buf))) + (when buffer (format out " ~s " (array-element-type buffer)))) + (format out "~d/~d/~d" + (io-buffer-idx buf) + (io-buffer-count buf) + (io-buffer-limit buf)))) + +(defstruct ioblock + stream ; the stream being buffered + untyi-char ; nil or last value passed to + ; stream-unread-char + (inbuf nil :type (or null io-buffer)) + (outbuf nil :type (or null io-buffer)) + (element-type 'character) + (element-shift 0 :type fixnum) ;element shift count + (charpos 0 :type (or null fixnum)) ;position of cursor + (device -1 :type (or null fixnum)) ;file descriptor + (advance-function 'ioblock-advance) + (listen-function 'ioblock-listen) + (eofp-function 'ioblock-eofp) + (force-output-function 'ioblock-force-output) + (close-function 'ioblock-close) + (inbuf-lock nil) + (eof nil) + (interactive nil) + (dirty nil) + (outbuf-lock nil) + (owner nil) + (read-char-function 'ioblock-no-char-input) + (read-byte-function 'ioblock-no-binary-input) + (write-byte-function 'ioblock-no-binary-output) + (write-char-function 'ioblock-no-char-output) + (encoding nil) + (pending-byte-order-mark nil) + (decode-literal-code-unit-limit 256) + (encode-output-function nil) + (decode-input-function nil) + (read-char-when-locked-function 'ioblock-no-char-input) + (write-simple-string-function 'ioblock-no-char-output) + (character-read-vector-function 'ioblock-no-char-input) + (read-line-function 'ioblock-no-char-input) + (write-char-when-locked-function 'ioblock-no-char-output) + (read-byte-when-locked-function 'ioblock-no-binary-input) + (write-byte-when-locked-function 'ioblock-no-binary-output) + (peek-char-function 'ioblock-no-char-input) + (native-byte-order t) + (read-char-without-translation-when-locked-function 'ioblock-no-char-input) + (write-char-without-translation-when-locked-function 'iblock-no-char-output) + (sharing nil) + (line-termination nil) + (unread-char-function 'ioblock-no-char-input) + (encode-literal-char-code-limit 256) + (input-timeout nil) + (output-timeout nil) + (deadline nil)) + + +;;; Functions on ioblocks. So far, we aren't saying anything +;;; about how streams use them. + +(defun ioblock-no-binary-input (ioblock &rest otters) + (declare (ignore otters)) + (report-bad-arg (ioblock-stream ioblock) '(and binary-stream input-stream))) + +(defun ioblock-no-binary-output (ioblock &rest others) + (declare (ignore others)) + (report-bad-arg (ioblock-stream ioblock) '(and binary-stream output-stream))) + +(defun ioblock-no-char-input (ioblock &rest others) + (declare (ignore others)) + (report-bad-arg (ioblock-stream ioblock) '(and character-stream input-stream))) + +(defun ioblock-no-char-output (ioblock &rest others) + (declare (ignore others)) + (report-bad-arg (ioblock-stream ioblock) '(and character-stream output-stream))) + + +(defun ioblock-octets-to-elements (ioblock octets) + (let* ((shift (ioblock-element-shift ioblock))) + (declare (fixnum shift)) + (if (zerop shift) + octets + (ash octets (- shift))))) + +(defun ioblock-elements-to-octets (ioblock elements) + (let* ((shift (ioblock-element-shift ioblock))) + (declare (fixnum shift)) + (if (zerop shift) + elements + (ash elements shift)))) + + + +;;; ioblock must really be an ioblock or you will crash +;;; Also: the expression "ioblock" is evaluated multiple times. + +(declaim (inline check-ioblock-owner)) +(defun check-ioblock-owner (ioblock) + (declare (optimize (speed 3))) + (let* ((owner (ioblock-owner ioblock))) + (if owner + (or (eq owner *current-process*) + (conditional-store (ioblock-owner ioblock) 0 *current-process*) + (error "Stream ~s is private to ~s" (ioblock-stream ioblock) owner))))) + + + +(declaim (inline %ioblock-advance)) +(defun %ioblock-advance (ioblock read-p) + (funcall (ioblock-advance-function ioblock) + (ioblock-stream ioblock) + ioblock + read-p)) + + +(defun %ioblock-surrounding-characters (ioblock) + (let* ((inbuf (ioblock-inbuf ioblock))) + (when inbuf + (let* ((encoding (or (ioblock-encoding ioblock) + (get-character-encoding nil))) + (size (ash (character-encoding-code-unit-size encoding) -3)) + (buffer (io-buffer-buffer inbuf)) + (idx (io-buffer-idx inbuf)) + (count (io-buffer-count inbuf))) + (unless (= count 0) + (let* ((start (max (- idx (* 10 size)) 0)) + (end (min (+ idx (* 10 size)) count)) + (string (make-string (funcall (character-encoding-length-of-vector-encoding-function encoding) buffer start end)))) + (funcall (character-encoding-vector-decode-function encoding) + buffer + start + (- end start) + string) + (if (position #\Replacement_Character string) + (string-trim (string #\Replacement_Character) string) + string))))))) + + + + +(defun %bivalent-ioblock-read-u8-byte (ioblock) + (declare (optimize (speed 3) (safety 0))) + (setf (ioblock-untyi-char ioblock) nil) + (let* ((buf (ioblock-inbuf ioblock)) + (idx (io-buffer-idx buf)) + (limit (io-buffer-count buf))) + (declare (fixnum idx limit)) + (when (= idx limit) + (unless (%ioblock-advance ioblock t) + (return-from %bivalent-ioblock-read-u8-byte :eof)) + (setq idx (io-buffer-idx buf) + limit (io-buffer-count buf))) + (setf (io-buffer-idx buf) (the fixnum (1+ idx))) + (aref (the (simple-array (unsigned-byte 8) (*)) + (io-buffer-buffer buf)) idx))) + + +(declaim (inline %ioblock-read-u8-byte)) +(defun %ioblock-read-u8-byte (ioblock) + (declare (optimize (speed 3) (safety 0))) + (let* ((buf (ioblock-inbuf ioblock)) + (idx (io-buffer-idx buf)) + (limit (io-buffer-count buf))) + (declare (fixnum idx limit)) + (when (= idx limit) + (unless (%ioblock-advance ioblock t) + (return-from %ioblock-read-u8-byte :eof)) + (setq idx (io-buffer-idx buf))) + (setf (io-buffer-idx buf) (the fixnum (1+ idx))) + (aref (the (simple-array (unsigned-byte 8) (*)) + (io-buffer-buffer buf)) idx))) + +(declaim (inline %ioblock-read-u8-code-unit)) +(defun %ioblock-read-u8-code-unit (ioblock) + (declare (optimize (speed 3) (safety 0))) + (let* ((buf (ioblock-inbuf ioblock)) + (idx (io-buffer-idx buf)) + (limit (io-buffer-count buf))) + (declare (fixnum idx limit)) + (when (= idx limit) + (unless (%ioblock-advance ioblock t) + (return-from %ioblock-read-u8-code-unit :eof)) + (setq idx (io-buffer-idx buf) + limit (io-buffer-count buf))) + (setf (io-buffer-idx buf) (the fixnum (1+ idx))) + (aref (the (simple-array (unsigned-byte 8) (*)) + (io-buffer-buffer buf)) idx))) + +(declaim (inline %ioblock-read-s8-byte)) +(defun %ioblock-read-s8-byte (ioblock) + (declare (optimize (speed 3) (safety 0))) + (let* ((buf (ioblock-inbuf ioblock)) + (idx (io-buffer-idx buf)) + (limit (io-buffer-count buf))) + (declare (fixnum idx limit)) + (when (= idx limit) + (unless (%ioblock-advance ioblock t) + (return-from %ioblock-read-s8-byte :eof)) + (setq idx (io-buffer-idx buf) + limit (io-buffer-count buf))) + (setf (io-buffer-idx buf) (the fixnum (1+ idx))) + (aref (the (simple-array (signed-byte 8) (*)) + (io-buffer-buffer buf)) idx))) + +(defun %private-ioblock-read-s8-byte (ioblock) + (declare (optimize (speed 3) (safety 0))) + (check-ioblock-owner ioblock) + (%ioblock-read-s8-byte ioblock)) + +(defun %locked-ioblock-read-s8-byte (ioblock) + (declare (optimize (speed 3) (safety 0))) + (with-ioblock-input-lock-grabbed (ioblock) + (%ioblock-read-s8-byte ioblock))) + + +(declaim (inline %ioblock-read-u16-byte)) +(defun %ioblock-read-u16-byte (ioblock) + (declare (optimize (speed 3) (safety 0))) + (let* ((buf (ioblock-inbuf ioblock)) + (idx (io-buffer-idx buf)) + (limit (io-buffer-count buf))) + (declare (fixnum idx limit)) + (when (= idx limit) + (unless (%ioblock-advance ioblock t) + (return-from %ioblock-read-u16-byte :eof)) + (setq idx (io-buffer-idx buf) + limit (io-buffer-count buf))) + (setf (io-buffer-idx buf) (the fixnum (1+ idx))) + (aref (the (simple-array (unsigned-byte 16) (*)) + (io-buffer-buffer buf)) idx))) + +(defun %private-ioblock-read-u16-byte (ioblock) + (declare (optimize (speed 3) (safety 0))) + (check-ioblock-owner ioblock) + (%ioblock-read-u16-byte ioblock)) + +(defun %locked-ioblock-read-u16-byte (ioblock) + (declare (optimize (speed 3) (safety 0))) + (with-ioblock-input-lock-grabbed (ioblock) + (%ioblock-read-u16-byte ioblock))) + +(declaim (inline %ioblock-read-s16-byte)) +(defun %ioblock-read-s16-byte (ioblock) + (declare (optimize (speed 3) (safety 0))) + (let* ((buf (ioblock-inbuf ioblock)) + (idx (io-buffer-idx buf)) + (limit (io-buffer-count buf))) + (declare (fixnum idx limit)) + (when (= idx limit) + (unless (%ioblock-advance ioblock t) + (return-from %ioblock-read-s16-byte :eof)) + (setq idx (io-buffer-idx buf) + limit (io-buffer-count buf))) + (setf (io-buffer-idx buf) (the fixnum (1+ idx))) + (aref (the (simple-array (signed-byte 16) (*)) + (io-buffer-buffer buf)) idx))) + +(defun %private-ioblock-read-s16-byte (ioblock) + (declare (optimize (speed 3) (safety 0))) + (check-ioblock-owner ioblock) + (%ioblock-read-s16-byte ioblock)) + +(defun %locked-ioblock-read-s16-byte (ioblock) + (declare (optimize (speed 3) (safety 0))) + (with-ioblock-input-lock-grabbed (ioblock) + (%ioblock-read-s16-byte ioblock))) + + +(declaim (inline %ioblock-read-u32-byte)) +(defun %ioblock-read-u32-byte (ioblock) + (declare (optimize (speed 3) (safety 0))) + (let* ((buf (ioblock-inbuf ioblock)) + (idx (io-buffer-idx buf)) + (limit (io-buffer-count buf))) + (declare (fixnum idx limit)) + (when (= idx limit) + (unless (%ioblock-advance ioblock t) + (return-from %ioblock-read-u32-byte :eof)) + (setq idx (io-buffer-idx buf) + limit (io-buffer-count buf))) + (setf (io-buffer-idx buf) (the fixnum (1+ idx))) + (aref (the (simple-array (unsigned-byte 32) (*)) + (io-buffer-buffer buf)) idx))) + +(defun %private-ioblock-read-u32-byte (ioblock) + (check-ioblock-owner ioblock) + (%ioblock-read-u32-byte ioblock)) + +(defun %locked-ioblock-read-u32-byte (ioblock) + (with-ioblock-input-lock-grabbed (ioblock) + (%ioblock-read-u32-byte ioblock))) + +(declaim (inline %ioblock-read-s32-byte)) +(defun %ioblock-read-s32-byte (ioblock) + (declare (optimize (speed 3) (safety 0))) + (let* ((buf (ioblock-inbuf ioblock)) + (idx (io-buffer-idx buf)) + (limit (io-buffer-count buf))) + (declare (fixnum idx limit)) + (when (= idx limit) + (unless (%ioblock-advance ioblock t) + (return-from %ioblock-read-s32-byte :eof)) + (setq idx (io-buffer-idx buf) + limit (io-buffer-count buf))) + (setf (io-buffer-idx buf) (the fixnum (1+ idx))) + (aref (the (simple-array (signed-byte 32) (*)) + (io-buffer-buffer buf)) idx))) + +(defun %private-ioblock-read-s32-byte (ioblock) + (check-ioblock-owner ioblock) + (%ioblock-read-s32-byte ioblock)) + +(defun %locked-ioblock-read-s32-byte (ioblock) + (with-ioblock-input-lock-grabbed (ioblock) + (%ioblock-read-s32-byte ioblock))) + +#+64-bit-target +(progn +(declaim (inline %ioblock-read-u64-byte)) +(defun %ioblock-read-u64-byte (ioblock) + (declare (optimize (speed 3) (safety 0))) + (let* ((buf (ioblock-inbuf ioblock)) + (idx (io-buffer-idx buf)) + (limit (io-buffer-count buf))) + (declare (fixnum idx limit)) + (when (= idx limit) + (unless (%ioblock-advance ioblock t) + (return-from %ioblock-read-u64-byte :eof)) + (setq idx (io-buffer-idx buf) + limit (io-buffer-count buf))) + (setf (io-buffer-idx buf) (the fixnum (1+ idx))) + (aref (the (simple-array (unsigned-byte 64) (*)) + (io-buffer-buffer buf)) idx))) + +(defun %private-ioblock-read-u64-byte (ioblock) + (declare (optimize (speed 3) (safety 0))) + (check-ioblock-owner ioblock) + (%ioblock-read-u64-byte ioblock)) + +(defun %locked-ioblock-read-u64-byte (ioblock) + (declare (optimize (speed 3) (safety 0))) + (with-ioblock-input-lock-grabbed (ioblock) + (%ioblock-read-u64-byte ioblock))) + +(defun %ioblock-read-s64-byte (ioblock) + (declare (optimize (speed 3) (safety 0))) + (let* ((buf (ioblock-inbuf ioblock)) + (idx (io-buffer-idx buf)) + (limit (io-buffer-count buf))) + (declare (fixnum idx limit)) + (when (= idx limit) + (unless (%ioblock-advance ioblock t) + (return-from %ioblock-read-s64-byte :eof)) + (setq idx (io-buffer-idx buf) + limit (io-buffer-count buf))) + (setf (io-buffer-idx buf) (the fixnum (1+ idx))) + (aref (the (simple-array (signed-byte 64) (*)) + (io-buffer-buffer buf)) idx))) + +(defun %private-ioblock-read-s64-byte (ioblock) + (declare (optimize (speed 3) (safety 0))) + (check-ioblock-owner ioblock) + (%ioblock-read-s64-byte ioblock)) + +(defun %locked-ioblock-read-s64-byte (ioblock) + (declare (optimize (speed 3) (safety 0))) + (with-ioblock-input-lock-grabbed (ioblock) + (%ioblock-read-s64-byte ioblock))) +) + + +;;; Read a 16-bit code element from a stream with element-type +;;; (UNSIGNED-BYTE 8), in native byte-order. + +(declaim (inline %ioblock-read-u16-code-unit)) +(defun %ioblock-read-u16-code-unit (ioblock) + (declare (optimize (speed 3) (safety 0))) + (let* ((buf (ioblock-inbuf ioblock)) + (idx (io-buffer-idx buf)) + (limit (io-buffer-count buf)) + (vector (io-buffer-buffer buf))) + (declare (fixnum idx limit) + (type (simple-array (unsigned-byte 8) (*)) vector)) + (if (<= (the fixnum (+ idx 2)) limit) + (let* ((b0 (aref vector idx)) + (b1 (aref vector (the fixnum (1+ idx))))) + (declare (type (unsigned-byte 8) b0 b1)) + (setf (io-buffer-idx buf) (the fixnum (+ idx 2))) + #+big-endian-target + (logior (the (unsigned-byte 16) (ash b0 8)) b1) + #+little-endian-target + (logior (the (unsigned-byte 16) (ash b1 8)) b0)) + (if (< idx limit) + (let* ((b0 (aref vector idx)) + (n (%ioblock-advance ioblock t))) + (declare (type (unsigned-byte 8) b0)) + (if (null n) + :eof + (let* ((b1 (aref vector 0))) + (declare (type (unsigned-byte 8) b1)) + (setf (io-buffer-idx buf) 1) + #+big-endian-target + (logior (the (unsigned-byte 16) (ash b0 8)) b1) + #+little-endian-target + (logior (the (unsigned-byte 16) (ash b1 8)) b0)))) + (let* ((n (%ioblock-advance ioblock t))) + (if (null n) + :eof + (if (eql n 1) + (progn + (setf (io-buffer-idx buf) 1) + :eof) + (let* ((b0 (aref vector 0)) + (b1 (aref vector 1))) + (declare (type (unsigned-byte 8) b0 b1)) + (setf (io-buffer-idx buf) 2) + #+big-endian-target + (logior (the (unsigned-byte 16) (ash b0 8)) b1) + #+little-endian-target + (logior (the (unsigned-byte 16) (ash b1 8)) b0))))))))) + +(declaim (inline %ioblock-read-swapped-u16-code-unit)) +(defun %ioblock-read-swapped-u16-code-unit (ioblock) + (declare (optimize (speed 3) (safety 0))) + (let* ((buf (ioblock-inbuf ioblock)) + (idx (io-buffer-idx buf)) + (limit (io-buffer-count buf)) + (vector (io-buffer-buffer buf))) + (declare (fixnum idx limit) + (type (simple-array (unsigned-byte 8) (*)) vector)) + (if (<= (the fixnum (+ idx 2)) limit) + (let* ((b0 (aref vector idx)) + (b1 (aref vector (the fixnum (1+ idx))))) + (declare (type (unsigned-byte 8) b0 b1)) + (setf (io-buffer-idx buf) (the fixnum (+ idx 2))) + #+little-endian-target + (logior (the (unsigned-byte 16) (ash b0 8)) b1) + #+big-endian-target + (logior (the (unsigned-byte 16) (ash b1 8)) b0)) + (if (< idx limit) + (let* ((b0 (aref vector idx)) + (n (%ioblock-advance ioblock t))) + (declare (type (unsigned-byte 8) b0)) + (if (null n) + :eof + (let* ((b1 (aref vector 0))) + (declare (type (unsigned-byte 8) b1)) + (setf (io-buffer-idx buf) 1) + #+little-endian-target + (logior (the (unsigned-byte 16) (ash b0 8)) b1) + #+big-endian-target + (logior (the (unsigned-byte 16) (ash b1 8)) b0)))) + (let* ((n (%ioblock-advance ioblock t))) + (if (null n) + :eof + (if (eql n 1) + (progn + (setf (io-buffer-idx buf) 1) + :eof) + (let* ((b0 (aref vector 0)) + (b1 (aref vector 1))) + (declare (type (unsigned-byte 8) b0 b1)) + (setf (io-buffer-idx buf) 2) + #+little-endian-target + (logior (the (unsigned-byte 16) (ash b0 8)) b1) + #+big-endian-target + (logior (the (unsigned-byte 16) (ash b1 8)) b0))))))))) + + +(declaim (inline %ioblock-read-u32-code-unit)) +(defun %ioblock-read-u32-code-unit (ioblock) + (declare (optimize (speed 3) (safety 0))) + (let* ((buf (ioblock-inbuf ioblock)) + (idx (io-buffer-idx buf)) + (limit (io-buffer-count buf)) + (vector (io-buffer-buffer buf))) + (declare (fixnum idx limit) + (type (simple-array (unsigned-byte 8) (*)) vector)) + (cond ((<= (the fixnum (+ idx 4)) limit) + (let* ((b0 (aref vector idx)) + (b1 (aref vector (the fixnum (1+ idx)))) + (b2 (aref vector (the fixnum (+ idx 2)))) + (b3 (aref vector (the fixnum (+ idx 3))))) + (declare (type (unsigned-byte 8) b0 b1 b2 b3)) + (setf (io-buffer-idx buf) (the fixnum (+ idx 4))) + #+big-endian-target + (logior (the (unsigned-byte 32) (ash b0 24)) + (the (unsigned-byte 24) (ash b1 16)) + (the (unsigned-byte 16) (ash b2 8)) + b3) + #+little-endian-target + (logior (the (unsigned-byte 32) (ash b3 24)) + (the (unsigned-byte 24) (ash b2 16)) + (the (unsigned-byte 16) (ash b1 8)) + b0))) + ((= (the fixnum (+ idx 3)) limit) + (let* ((b0 (aref vector idx)) + (b1 (aref vector (the fixnum (1+ idx)))) + (b2 (aref vector (the fixnum (+ idx 2)))) + (n (%ioblock-advance ioblock t))) + (declare (type (unsigned-byte 8) b0 b1 b2)) + (if (null n) + :eof + (let* ((b3 (aref vector 0))) + (declare (type (unsigned-byte 8) b3)) + (setf (io-buffer-idx buf) 1) + #+big-endian-target + (logior (the (unsigned-byte 32) (ash b0 24)) + (the (unsigned-byte 24) (ash b1 16)) + (the (unsigned-byte 16) (ash b2 8)) + b3) + #+little-endian-target + (logior (the (unsigned-byte 32) (ash b3 24)) + (the (unsigned-byte 24) (ash b2 16)) + (the (unsigned-byte 16) (ash b1 8)) + b0))))) + ((= (the fixnum (+ idx 2)) limit) + (let* ((b0 (aref vector idx)) + (b1 (aref vector (the fixnum (1+ idx)))) + (n (%ioblock-advance ioblock t))) + (declare (type (unsigned-byte 8) b0 b1)) + (if (null n) + :eof + (if (eql n 1) + (progn + (setf (io-buffer-idx buf) 1) + :eof) + (let* ((b2 (aref vector 0)) + (b3 (aref vector 1))) + (declare (type (unsigned-byte 8) b2 b3)) + (setf (io-buffer-idx buf) 2) + #+big-endian-target + (logior (the (unsigned-byte 32) (ash b0 24)) + (the (unsigned-byte 24) (ash b1 16)) + (the (unsigned-byte 16) (ash b2 8)) + b3) + #+little-endian-target + (logior (the (unsigned-byte 32) (ash b3 24)) + (the (unsigned-byte 24) (ash b2 16)) + (the (unsigned-byte 16) (ash b1 8)) + b0)))))) + ((= (the fixnum (1+ idx)) limit) + (let* ((b0 (aref vector idx)) + (n (%ioblock-advance ioblock t))) + (declare (type (unsigned-byte 8) b0)) + (if (null n) + :eof + (if (< n 3) + (progn + (setf (io-buffer-idx buf) n) + :eof) + (let* ((b1 (aref vector 0)) + (b2 (aref vector 1)) + (b3 (aref vector 2))) + (setf (io-buffer-idx buf) 3) + #+big-endian-target + (logior (the (unsigned-byte 32) (ash b0 24)) + (the (unsigned-byte 24) (ash b1 16)) + (the (unsigned-byte 16) (ash b2 8)) + b3) + #+little-endian-target + (logior (the (unsigned-byte 32) (ash b3 24)) + (the (unsigned-byte 24) (ash b2 16)) + (the (unsigned-byte 16) (ash b1 8)) + b0)))))) + (t + (let* ((n (%ioblock-advance ioblock t))) + (if (null n) + :eof + (if (< n 4) + (progn + (setf (io-buffer-idx buf) n) + :eof) + (let* ((b0 (aref vector 0)) + (b1 (aref vector 1)) + (b2 (aref vector 2)) + (b3 (aref vector 3))) + (declare (type (unsigned-byte 8) b0 b1 b2 b3)) + (setf (io-buffer-idx buf) 4) + #+big-endian-target + (logior (the (unsigned-byte 32) (ash b0 24)) + (the (unsigned-byte 24) (ash b1 16)) + (the (unsigned-byte 16) (ash b2 8)) + b3) + #+little-endian-target + (logior (the (unsigned-byte 32) (ash b3 24)) + (the (unsigned-byte 24) (ash b2 16)) + (the (unsigned-byte 16) (ash b1 8)) + b0))))))))) + +(declaim (inline %ioblock-read-swapped-u32-code-unit)) +(defun %ioblock-read-swapped-u32-code-unit (ioblock) + (declare (optimize (speed 3) (safety 0))) + (let* ((buf (ioblock-inbuf ioblock)) + (idx (io-buffer-idx buf)) + (limit (io-buffer-count buf)) + (vector (io-buffer-buffer buf))) + (declare (fixnum idx limit) + (type (simple-array (unsigned-byte 8) (*)) vector)) + (cond ((<= (the fixnum (+ idx 4)) limit) + (let* ((b0 (aref vector idx)) + (b1 (aref vector (the fixnum (1+ idx)))) + (b2 (aref vector (the fixnum (+ idx 2)))) + (b3 (aref vector (the fixnum (+ idx 3))))) + (declare (type (unsigned-byte 8) b0 b1 b2 b3)) + (setf (io-buffer-idx buf) (the fixnum (+ idx 4))) + #+little-endian-target + (logior (the (unsigned-byte 32) (ash b0 24)) + (the (unsigned-byte 24) (ash b1 16)) + (the (unsigned-byte 16) (ash b2 8)) + b3) + #+big-endian-target + (logior (the (unsigned-byte 32) (ash b3 24)) + (the (unsigned-byte 24) (ash b2 16)) + (the (unsigned-byte 16) (ash b1 8)) + b0))) + ((= (the fixnum (+ idx 3)) limit) + (let* ((b0 (aref vector idx)) + (b1 (aref vector (the fixnum (1+ idx)))) + (b2 (aref vector (the fixnum (+ idx 2)))) + (n (%ioblock-advance ioblock t))) + (declare (type (unsigned-byte 8) b0 b1 b2)) + (if (null n) + :eof + (let* ((b3 (aref vector 0))) + (declare (type (unsigned-byte 8) b3)) + (setf (io-buffer-idx buf) 1) + #+little-endian-target + (logior (the (unsigned-byte 32) (ash b0 24)) + (the (unsigned-byte 24) (ash b1 16)) + (the (unsigned-byte 16) (ash b2 8)) + b3) + #+big-endian-target + (logior (the (unsigned-byte 32) (ash b3 24)) + (the (unsigned-byte 24) (ash b2 16)) + (the (unsigned-byte 16) (ash b1 8)) + b0))))) + ((= (the fixnum (+ idx 2)) limit) + (let* ((b0 (aref vector idx)) + (b1 (aref vector (the fixnum (1+ idx)))) + (n (%ioblock-advance ioblock t))) + (declare (type (unsigned-byte 8) b0 b1)) + (if (null n) + :eof + (if (eql n 1) + (progn + (setf (io-buffer-idx buf) 1) + :eof) + (let* ((b2 (aref vector 0)) + (b3 (aref vector 1))) + (declare (type (unsigned-byte 8) b2 b3)) + (setf (io-buffer-idx buf) 2) + #+little-endian-target + (logior (the (unsigned-byte 32) (ash b0 24)) + (the (unsigned-byte 24) (ash b1 16)) + (the (unsigned-byte 16) (ash b2 8)) + b3) + #+big-endian-target + (logior (the (unsigned-byte 32) (ash b3 24)) + (the (unsigned-byte 24) (ash b2 16)) + (the (unsigned-byte 16) (ash b1 8)) + b0)))))) + ((= (the fixnum (1+ idx)) limit) + (let* ((b0 (aref vector idx)) + (n (%ioblock-advance ioblock t))) + (declare (type (unsigned-byte 8) b0)) + (if (null n) + :eof + (if (< n 3) + (progn + (setf (io-buffer-idx buf) n) + :eof) + (let* ((b1 (aref vector 0)) + (b2 (aref vector 1)) + (b3 (aref vector 2))) + (setf (io-buffer-idx buf) 3) + #+little-endian-target + (logior (the (unsigned-byte 32) (ash b0 24)) + (the (unsigned-byte 24) (ash b1 16)) + (the (unsigned-byte 16) (ash b2 8)) + b3) + #+big-endian-target + (logior (the (unsigned-byte 32) (ash b3 24)) + (the (unsigned-byte 24) (ash b2 16)) + (the (unsigned-byte 16) (ash b1 8)) + b0)))))) + (t + (let* ((n (%ioblock-advance ioblock t))) + (if (null n) + :eof + (if (< n 4) + (progn + (setf (io-buffer-idx buf) n) + :eof) + (let* ((b0 (aref vector 0)) + (b1 (aref vector 1)) + (b2 (aref vector 2)) + (b3 (aref vector 3))) + (declare (type (unsigned-byte 8) b0 b1 b2 b3)) + (setf (io-buffer-idx buf) 4) + #+little-endian-target + (logior (the (unsigned-byte 32) (ash b0 24)) + (the (unsigned-byte 24) (ash b1 16)) + (the (unsigned-byte 16) (ash b2 8)) + b3) + #+big-endian-target + (logior (the (unsigned-byte 32) (ash b3 24)) + (the (unsigned-byte 24) (ash b2 16)) + (the (unsigned-byte 16) (ash b1 8)) + b0))))))))) + + +(defun %bivalent-private-ioblock-read-u8-byte (ioblock) + (declare (optimize (speed 3) (safety 0))) + (check-ioblock-owner ioblock) + (setf (ioblock-untyi-char ioblock) nil) + (let* ((buf (ioblock-inbuf ioblock)) + (idx (io-buffer-idx buf)) + (limit (io-buffer-count buf))) + (declare (fixnum idx limit)) + (when (= idx limit) + (unless (%ioblock-advance ioblock t) + (return-from %bivalent-private-ioblock-read-u8-byte :eof)) + (setq idx (io-buffer-idx buf) + limit (io-buffer-count buf))) + (setf (io-buffer-idx buf) (the fixnum (1+ idx))) + (aref (the (simple-array (unsigned-byte 8) (*)) + (io-buffer-buffer buf)) idx))) + +(defun %private-ioblock-read-u8-byte (ioblock) + (declare (optimize (speed 3) (safety 0))) + (check-ioblock-owner ioblock) + (%ioblock-read-u8-byte ioblock)) + +(defun %bivalent-locked-ioblock-read-u8-byte (ioblock) + (declare (optimize (speed 3) (safety 0))) + (with-ioblock-input-lock-grabbed (ioblock) + (setf (ioblock-untyi-char ioblock) nil) + (let* ((buf (ioblock-inbuf ioblock)) + (idx (io-buffer-idx buf)) + (limit (io-buffer-count buf))) + (declare (fixnum idx limit)) + (when (= idx limit) + (unless (%ioblock-advance ioblock t) + (return-from %bivalent-locked-ioblock-read-u8-byte :eof)) + (setq idx (io-buffer-idx buf) + limit (io-buffer-count buf))) + (setf (io-buffer-idx buf) (the fixnum (1+ idx))) + (aref (the (simple-array (unsigned-byte 8) (*)) + (io-buffer-buffer buf)) idx)))) + +(defun %locked-ioblock-read-u8-byte (ioblock) + (declare (optimize (speed 3) (safety 0))) + (with-ioblock-input-lock-grabbed (ioblock) + (%ioblock-read-u8-byte ioblock))) + +(defun %general-ioblock-read-byte (ioblock) + (declare (optimize (speed 3) (safety 0))) + (with-ioblock-input-locked (ioblock) + (let* ((buf (ioblock-inbuf ioblock)) + (idx (io-buffer-idx buf)) + (limit (io-buffer-count buf))) + (declare (fixnum idx limit)) + (when (= idx limit) + (unless (%ioblock-advance ioblock t) + (return-from %general-ioblock-read-byte :eof)) + (setq idx (io-buffer-idx buf) + limit (io-buffer-count buf))) + (setf (io-buffer-idx buf) (the fixnum (1+ idx))) + (uvref (io-buffer-buffer buf) idx)))) + + +(declaim (inline %ioblock-tyi)) +(defun %ioblock-tyi (ioblock) + (declare (optimize (speed 3) (safety 0))) + (let* ((ch (ioblock-untyi-char ioblock))) + (if ch + (prog1 ch + (setf (ioblock-untyi-char ioblock) nil)) + (let* ((buf (ioblock-inbuf ioblock)) + (idx (io-buffer-idx buf)) + (limit (io-buffer-count buf))) + (declare (fixnum idx limit)) + (when (= idx limit) + (unless (%ioblock-advance ioblock t) + (return-from %ioblock-tyi :eof)) + (setq idx 0)) + (setf (io-buffer-idx buf) (the fixnum (1+ idx))) + (%code-char (aref (the (simple-array (unsigned-byte 8) (*)) + (io-buffer-buffer buf)) idx)))))) + +(defun %private-ioblock-tyi (ioblock) + (declare (optimize (speed 3) (safety 0))) + (check-ioblock-owner ioblock) + (%ioblock-tyi ioblock)) + +(defun %locked-ioblock-tyi (ioblock) + (declare (optimize (speed 3) (safety 0))) + (with-ioblock-input-lock-grabbed (ioblock) + (%ioblock-tyi ioblock))) + +;;; Read a character composed of one or more 8-bit code-units. +(declaim (inline %ioblock-read-u8-encoded-char)) +(defun %ioblock-read-u8-encoded-char (ioblock) + (declare (optimize (speed 3) (safety 0))) + (let* ((ch (ioblock-untyi-char ioblock))) + (if ch + (prog1 ch + (setf (ioblock-untyi-char ioblock) nil)) + (let* ((1st-unit (%ioblock-read-u8-code-unit ioblock))) + (if (eq 1st-unit :eof) + 1st-unit + (locally + (declare (type (unsigned-byte 8) 1st-unit)) + (if (< 1st-unit + (the (mod #x110000) (ioblock-decode-literal-code-unit-limit ioblock))) + (%code-char 1st-unit) + (funcall (ioblock-decode-input-function ioblock) + 1st-unit + #'%ioblock-read-u8-code-unit + ioblock)))))))) + +(defun %private-ioblock-read-u8-encoded-char (ioblock) + (declare (optimize (speed 3) (safety 0))) + (check-ioblock-owner ioblock) + (%ioblock-read-u8-encoded-char ioblock)) + +(defun %locked-ioblock-read-u8-encoded-char (ioblock) + (declare (optimize (speed 3) (safety 0))) + (with-ioblock-input-lock-grabbed (ioblock) + (%ioblock-read-u8-encoded-char ioblock))) + +(declaim (inline %ioblock-read-u16-encoded-char)) +(defun %ioblock-read-u16-encoded-char (ioblock) + (declare (optimize (speed 3) (safety 0))) + (let* ((ch (ioblock-untyi-char ioblock))) + (if ch + (prog1 ch + (setf (ioblock-untyi-char ioblock) nil)) + (let* ((1st-unit (%ioblock-read-u16-code-unit ioblock))) + (if (eq 1st-unit :eof) + 1st-unit + (locally + (declare (type (unsigned-byte 16) 1st-unit)) + (if (< 1st-unit + (the (mod #x110000) (ioblock-decode-literal-code-unit-limit ioblock))) + (code-char 1st-unit) + (funcall (ioblock-decode-input-function ioblock) + 1st-unit + #'%ioblock-read-u16-code-unit + ioblock)))))))) + +(defun %private-ioblock-read-u16-encoded-char (ioblock) + (declare (optimize (speed 3) (safety 0))) + (check-ioblock-owner ioblock) + (%ioblock-read-u16-encoded-char ioblock)) + +(defun %locked-ioblock-read-u16-encoded-char (ioblock) + (declare (optimize (speed 3) (safety 0))) + (with-ioblock-input-lock-grabbed (ioblock) + (%ioblock-read-u16-encoded-char ioblock))) + +(declaim (inline %ioblock-read-swapped-u16-encoded-char)) +(defun %ioblock-read-swapped-u16-encoded-char (ioblock) + (declare (optimize (speed 3) (safety 0))) + (let* ((ch (ioblock-untyi-char ioblock))) + (if ch + (prog1 ch + (setf (ioblock-untyi-char ioblock) nil)) + (let* ((1st-unit (%ioblock-read-swapped-u16-code-unit ioblock))) + (if (eq 1st-unit :eof) + 1st-unit + (locally + (declare (type (unsigned-byte 16) 1st-unit)) + (if (< 1st-unit + (the (mod #x110000) (ioblock-decode-literal-code-unit-limit ioblock))) + (code-char 1st-unit) + (funcall (ioblock-decode-input-function ioblock) + 1st-unit + #'%ioblock-read-swapped-u16-code-unit + ioblock)))))))) + +(defun %private-ioblock-read-swapped-u16-encoded-char (ioblock) + (declare (optimize (speed 3) (safety 0))) + (check-ioblock-owner ioblock) + (%ioblock-read-swapped-u16-encoded-char ioblock)) + +(defun %locked-ioblock-read-swapped-u16-encoded-char (ioblock) + (declare (optimize (speed 3) (safety 0))) + (with-ioblock-input-lock-grabbed (ioblock) + (%ioblock-read-swapped-u16-encoded-char ioblock))) + +(declaim (inline %ioblock-read-u32-encoded-char)) +(defun %ioblock-read-u32-encoded-char (ioblock) + (declare (optimize (speed 3) (safety 0))) + (let* ((ch (ioblock-untyi-char ioblock))) + (if ch + (prog1 ch + (setf (ioblock-untyi-char ioblock) nil)) + (let* ((1st-unit (%ioblock-read-u32-code-unit ioblock))) + (if (eq 1st-unit :eof) + 1st-unit + (locally + (declare (type (unsigned-byte 16) 1st-unit)) + (if (< 1st-unit + (the (mod #x110000) (ioblock-decode-literal-code-unit-limit ioblock))) + (code-char 1st-unit) + (funcall (ioblock-decode-input-function ioblock) + 1st-unit + #'%ioblock-read-u32-code-unit + ioblock)))))))) + +(defun %private-ioblock-read-u32-encoded-char (ioblock) + (declare (optimize (speed 3) (safety 0))) + (check-ioblock-owner ioblock) + (%ioblock-read-u32-encoded-char ioblock)) + +(defun %locked-ioblock-read-u32-encoded-char (ioblock) + (declare (optimize (speed 3) (safety 0))) + (with-ioblock-input-lock-grabbed (ioblock) + (%ioblock-read-u32-encoded-char ioblock))) + +(declaim (inline %ioblock-read-swapped-u32-encoded-char)) +(defun %ioblock-read-swapped-u32-encoded-char (ioblock) + (declare (optimize (speed 3) (safety 0))) + (let* ((ch (ioblock-untyi-char ioblock))) + (if ch + (prog1 ch + (setf (ioblock-untyi-char ioblock) nil)) + (let* ((1st-unit (%ioblock-read-swapped-u32-code-unit ioblock))) + (if (eq 1st-unit :eof) + 1st-unit + (locally + (declare (type (unsigned-byte 16) 1st-unit)) + (if (< 1st-unit + (the (mod #x110000) (ioblock-decode-literal-code-unit-limit ioblock))) + (code-char 1st-unit) + (funcall (ioblock-decode-input-function ioblock) + 1st-unit + #'%ioblock-read-swapped-u32-code-unit + ioblock)))))))) + +(defun %private-ioblock-read-swapped-u32-encoded-char (ioblock) + (declare (optimize (speed 3) (safety 0))) + (check-ioblock-owner ioblock) + (%ioblock-read-swapped-u32-encoded-char ioblock)) + +(defun %locked-ioblock-read-swapped-u32-encoded-char (ioblock) + (declare (optimize (speed 3) (safety 0))) + (with-ioblock-input-lock-grabbed (ioblock) + (%ioblock-read-swapped-u32-encoded-char ioblock))) + +(declaim (inline %ioblock-tyi-no-hang)) +(defun %ioblock-tyi-no-hang (ioblock) + (declare (optimize (speed 3) (safety 0))) + (if (ioblock-untyi-char ioblock) + (prog1 (ioblock-untyi-char ioblock) + (setf (ioblock-untyi-char ioblock) nil)) + (let* ((buf (ioblock-inbuf ioblock)) + (idx (io-buffer-idx buf)) + (limit (io-buffer-count buf))) + (declare (fixnum idx limit)) + (when (= idx limit) + (unless (%ioblock-advance ioblock nil) + (return-from %ioblock-tyi-no-hang (if (ioblock-eof ioblock) :eof)))) + (funcall (ioblock-read-char-when-locked-function ioblock) ioblock)))) + +;;; :iso-8859-1 only. +(defun %ioblock-peek-char (ioblock) + (or (ioblock-untyi-char ioblock) + (let* ((buf (ioblock-inbuf ioblock)) + (idx (io-buffer-idx buf)) + (limit (io-buffer-count buf))) + (declare (fixnum idx limit)) + (when (= idx limit) + (unless (%ioblock-advance ioblock t) + (return-from %ioblock-peek-char :eof)) + (setq idx (io-buffer-idx buf) + limit (io-buffer-count buf))) + (%code-char (aref (the (simple-array (unsigned-byte 8) (*)) (io-buffer-buffer buf)) idx))))) + +(defun %encoded-ioblock-peek-char (ioblock) + (or (ioblock-untyi-char ioblock) + (let* ((ch (funcall (ioblock-read-char-when-locked-function ioblock) ioblock))) + (unless (eq ch :eof) + (setf (ioblock-untyi-char ioblock) ch)) + ch))) + + + + +(defun %ioblock-clear-input (ioblock) + (let* ((buf (ioblock-inbuf ioblock))) + (setf (io-buffer-count buf) 0 + (io-buffer-idx buf) 0 + (ioblock-untyi-char ioblock) nil))) + +(defun %ioblock-untyi (ioblock char) + (if (ioblock-untyi-char ioblock) + (error "Two UNREAD-CHARs without intervening READ-CHAR on ~s" + (ioblock-stream ioblock)) + (setf (ioblock-untyi-char ioblock) char))) + +(declaim (inline ioblock-inpos)) + +(defun ioblock-inpos (ioblock) + (io-buffer-idx (ioblock-inbuf ioblock))) + +(declaim (inline ioblock-outpos)) + +(defun ioblock-outpos (ioblock) + (io-buffer-count (ioblock-outbuf ioblock))) + + + +(declaim (inline %ioblock-force-output)) + +(defun %ioblock-force-output (ioblock finish-p) + (funcall (ioblock-force-output-function ioblock) + (ioblock-stream ioblock) + ioblock + (ioblock-outpos ioblock) + finish-p)) + +;;; ivector should be an ivector. The ioblock should have an +;;; element-shift of 0; start-octet and num-octets should of course +;;; be sane. This is mostly to give the fasdumper a quick way to +;;; write immediate data. +(defun %ioblock-out-ivect (ioblock ivector start-octet num-octets) + (unless (= 0 (the fixnum (ioblock-element-shift ioblock))) + (error "Can't write vector to stream ~s" (ioblock-stream ioblock))) + (let* ((written 0) + (out (ioblock-outbuf ioblock)) + (bufsize (io-buffer-size out)) + (buffer (io-buffer-buffer out))) + (declare (fixnum written bufsize)) + (do* ((pos start-octet (+ pos written)) + (left num-octets (- left written))) + ((= left 0) num-octets) + (declare (fixnum pos left)) + (setf (ioblock-dirty ioblock) t) + (let* ((index (io-buffer-idx out)) + (count (io-buffer-count out)) + (avail (- bufsize index))) + (declare (fixnum index avail count)) + (cond + ((= (setq written avail) 0) + (%ioblock-force-output ioblock nil)) + (t + (if (> written left) + (setq written left)) + (%copy-ivector-to-ivector ivector pos buffer index written) + (setf (ioblock-dirty ioblock) t) + (incf index written) + (if (> index count) + (setf (io-buffer-count out) index)) + (setf (io-buffer-idx out) index) + (if (= index bufsize) + (%ioblock-force-output ioblock nil)))))))) + + +(defun %ioblock-unencoded-write-simple-string (ioblock string start-char num-chars) + (declare (fixnum start-char num-chars) (simple-string string)) + (let* ((written 0) + (col (ioblock-charpos ioblock)) + (out (ioblock-outbuf ioblock)) + (bufsize (io-buffer-size out)) + (buffer (io-buffer-buffer out))) + (declare (fixnum written bufsize col) + (type (simple-array (unsigned-byte 8) (*)) buffer) + (optimize (speed 3) (safety 0))) + (do* ((pos start-char (+ pos written)) + (left num-chars (- left written))) + ((= left 0) (setf (ioblock-charpos ioblock) col) num-chars) + (declare (fixnum pos left)) + (setf (ioblock-dirty ioblock) t) + (let* ((index (io-buffer-idx out)) + (count (io-buffer-count out)) + (avail (- bufsize index))) + (declare (fixnum index avail count)) + (cond + ((= (setq written avail) 0) + (%ioblock-force-output ioblock nil)) + (t + (if (> written left) + (setq written left)) + (do* ((p pos (1+ p)) + (i index (1+ i)) + (j 0 (1+ j))) + ((= j written)) + (declare (fixnum p i j)) + (let* ((ch (schar string p)) + (code (char-code ch))) + (declare (type (mod #x110000) code)) + (if (eql ch #\newline) + (setq col 0) + (incf col)) + (setf (aref buffer i) (if (>= code 256) (char-code #\Sub) code)))) + (setf (ioblock-dirty ioblock) t) + (incf index written) + (if (> index count) + (setf (io-buffer-count out) index)) + (setf (io-buffer-idx out) index) + (if (= index bufsize) + (%ioblock-force-output ioblock nil)))))))) + + + +(defun %ioblock-eofp (ioblock) + (let* ((buf (ioblock-inbuf ioblock))) + (and (eql (io-buffer-idx buf) + (io-buffer-count buf)) + (locally (declare (optimize (speed 3) (safety 0))) + (with-ioblock-input-locked (ioblock) + (funcall (ioblock-eofp-function ioblock) + (ioblock-stream ioblock) + ioblock)))))) + +(defun %ioblock-listen (ioblock) + (let* ((buf (ioblock-inbuf ioblock))) + (or (< (the fixnum (io-buffer-idx buf)) + (the fixnum (io-buffer-count buf))) + (funcall (ioblock-listen-function ioblock) + (ioblock-stream ioblock) + ioblock)))) + +(declaim (inline %ioblock-write-element)) + +(defun %ioblock-write-element (ioblock element) + (declare (optimize (speed 3) (safety 0))) + (let* ((buf (ioblock-outbuf ioblock)) + (idx (io-buffer-idx buf)) + (count (io-buffer-count buf)) + (limit (io-buffer-limit buf))) + (declare (fixnum idx limit count)) + (when (= idx limit) + (%ioblock-force-output ioblock nil) + (setq idx 0 count 0)) + (setf (aref (io-buffer-buffer buf) idx) element) + (incf idx) + (setf (io-buffer-idx buf) idx) + (when (> idx count) + (setf (io-buffer-count buf) idx)) + (setf (ioblock-dirty ioblock) t) + element)) + +(declaim (inline %ioblock-write-u8-element)) +(defun %ioblock-write-u8-element (ioblock element) + (declare (optimize (speed 3) (safety 0))) + (let* ((buf (ioblock-outbuf ioblock)) + (idx (io-buffer-idx buf)) + (count (io-buffer-count buf)) + (limit (io-buffer-limit buf))) + (declare (fixnum idx limit count)) + (when (= idx limit) + (%ioblock-force-output ioblock nil) + (setq idx 0 count 0)) + (setf (aref (the (simple-array (unsigned-byte 8) (*)) (io-buffer-buffer buf)) idx) element) + (incf idx) + (setf (io-buffer-idx buf) idx) + (when (> idx count) + (setf (io-buffer-count buf) idx)) + (setf (ioblock-dirty ioblock) t) + element)) + +(declaim (inline %ioblock-write-s8-element)) +(defun %ioblock-write-s8-element (ioblock element) + (declare (optimize (speed 3) (safety 0))) + (let* ((buf (ioblock-outbuf ioblock)) + (idx (io-buffer-idx buf)) + (count (io-buffer-count buf)) + (limit (io-buffer-limit buf))) + (declare (fixnum idx limit count)) + (when (= idx limit) + (%ioblock-force-output ioblock nil) + (setq idx 0 count 0)) + (setf (aref (the (simple-array (signed-byte 8) (*)) (io-buffer-buffer buf)) idx) element) + (incf idx) + (setf (io-buffer-idx buf) idx) + (when (> idx count) + (setf (io-buffer-count buf) idx)) + (setf (ioblock-dirty ioblock) t) + element)) + +(declaim (inline %ioblock-write-u16-element)) +(defun %ioblock-write-u16-element (ioblock element) + (declare (optimize (speed 3) (safety 0))) + (let* ((buf (ioblock-outbuf ioblock)) + (idx (io-buffer-idx buf)) + (count (io-buffer-count buf)) + (limit (io-buffer-limit buf))) + (declare (fixnum idx limit count)) + (when (= idx limit) + (%ioblock-force-output ioblock nil) + (setq idx 0 count 0)) + (setf (aref (the (simple-array (unsigned-byte 16) (*)) (io-buffer-buffer buf)) idx) element) + (incf idx) + (setf (io-buffer-idx buf) idx) + (when (> idx count) + (setf (io-buffer-count buf) idx)) + (setf (ioblock-dirty ioblock) t) + element)) + +(declaim (inline %ioblock-write-u16-code-unit)) +(defun %ioblock-write-u16-code-unit (ioblock element) + (declare (optimize (speed 3) (safety 0)) + (type (unsigned-byte 16) element)) + (let* ((buf (ioblock-outbuf ioblock)) + (idx (io-buffer-idx buf)) + (count (io-buffer-count buf)) + (limit (io-buffer-limit buf)) + (vector (io-buffer-buffer buf)) + (b0 #+big-endian-target (ldb (byte 8 8) element) + #+little-endian-target (ldb (byte 8 0) element)) + (b1 #+big-endian-target (ldb (byte 8 0) element) + #+little-endian-target (ldb (byte 8 8) element))) + (declare (fixnum idx limit count) + (type (simple-array (unsigned-byte 8) (*)) vector) + (type (unsigned-byte 8) b0 b1)) + + (when (= idx limit) + (%ioblock-force-output ioblock nil) + (setq idx 0 count 0)) + (setf (aref vector idx) b0) + (incf idx) + (when (= idx limit) + (when (> idx count) + (setf (io-buffer-count buf) idx)) + (%ioblock-force-output ioblock nil) + (setq idx 0 count 0)) + (setf (aref vector idx) b1) + (incf idx) + (setf (io-buffer-idx buf) idx) + (when (> idx count) + (setf (io-buffer-count buf) idx)) + (setf (ioblock-dirty ioblock) t) + element)) + +(declaim (inline %ioblock-write-swapped-u16-code-unit)) +(defun %ioblock-write-swapped-u16-code-unit (ioblock element) + (declare (optimize (speed 3) (safety 0))) +(let* ((buf (ioblock-outbuf ioblock)) + (idx (io-buffer-idx buf)) + (count (io-buffer-count buf)) + (limit (io-buffer-limit buf)) + (vector (io-buffer-buffer buf)) + (b0 #+big-endian-target (ldb (byte 8 8) element) + #+little-endian-target (ldb (byte 8 0) element)) + (b1 #+big-endian-target (ldb (byte 8 0) element) + #+little-endian-target (ldb (byte 8 8) element))) + (declare (fixnum idx limit count) + (type (simple-array (unsigned-byte 8) (*)) vector) + (type (unsigned-byte 8) b0 b1)) + + (when (= idx limit) + (%ioblock-force-output ioblock nil) + (setq idx 0 count 0)) + (setf (aref vector idx) b1) + (incf idx) + (when (= idx limit) + (when (> idx count) + (setf (io-buffer-count buf) idx)) + (%ioblock-force-output ioblock nil) + (setq idx 0 count 0)) + (setf (aref vector idx) b0) + (incf idx) + (setf (io-buffer-idx buf) idx) + (when (> idx count) + (setf (io-buffer-count buf) idx)) + (setf (ioblock-dirty ioblock) t) + element)) + +(declaim (inline %ioblock-write-u32-code-unit)) +(defun %ioblock-write-u32-code-unit (ioblock element) + (declare (optimize (speed 3) (safety 0)) + (type (unsigned-byte 16) element)) + (let* ((buf (ioblock-outbuf ioblock)) + (idx (io-buffer-idx buf)) + (count (io-buffer-count buf)) + (limit (io-buffer-limit buf)) + (vector (io-buffer-buffer buf)) + (b0 #+big-endian-target (ldb (byte 8 24) element) + #+little-endian-target (ldb (byte 8 0) element)) + (b1 #+big-endian-target (ldb (byte 8 16) element) + #+little-endian-target (ldb (byte 8 8) element)) + (b2 #+big-endian-target (ldb (byte 8 8) element) + #+little-endian-target (ldb (byte 8 16) element)) + (b3 #+big-endian-target (ldb (byte 8 0) element) + #+little-endian-target (ldb (byte 8 24) element))) + (declare (fixnum idx limit count) + (type (simple-array (unsigned-byte 8) (*)) vector) + (type (unsigned-byte 8) b0 b1 b2 b3)) + (when (= idx limit) + (%ioblock-force-output ioblock nil) + (setq idx 0 count 0)) + (setf (aref vector idx) b0) + (incf idx) + (when (= idx limit) + (when (> idx count) + (setf (io-buffer-count buf) idx)) + (%ioblock-force-output ioblock nil) + (setq idx 0 count 0)) + (setf (aref vector idx) b1) + (incf idx) + (when (= idx limit) + (when (> idx count) + (setf (io-buffer-count buf) idx)) + (%ioblock-force-output ioblock nil) + (setq idx 0 count 0)) + (setf (aref vector idx) b2) + (incf idx) + (when (= idx limit) + (when (> idx count) + (setf (io-buffer-count buf) idx)) + (%ioblock-force-output ioblock nil) + (setq idx 0 count 0)) + (setf (aref vector idx) b3) + (incf idx) + (setf (io-buffer-idx buf) idx) + (when (> idx count) + (setf (io-buffer-count buf) idx)) + (setf (ioblock-dirty ioblock) t) + element)) + +(declaim (inline %ioblock-write-swapped-u32-code-unit)) +(defun %ioblock-write-swapped-u32-code-unit (ioblock element) + (declare (optimize (speed 3) (safety 0)) + (type (unsigned-byte 16) element)) + (let* ((buf (ioblock-outbuf ioblock)) + (idx (io-buffer-idx buf)) + (count (io-buffer-count buf)) + (limit (io-buffer-limit buf)) + (vector (io-buffer-buffer buf)) + (b0 #+little-endian-target (ldb (byte 8 24) element) + #+big-endian-target (ldb (byte 8 0) element)) + (b1 #+little-endian-target (ldb (byte 8 16) element) + #+big-endian-target (ldb (byte 8 8) element)) + (b2 #+little-endian-target (ldb (byte 8 8) element) + #+big-endian-target (ldb (byte 8 16) element)) + (b3 #+little-endian-target (ldb (byte 8 0) element) + #+big-endian-target (ldb (byte 8 24) element))) + (declare (fixnum idx limit count) + (type (simple-array (unsigned-byte 8) (*)) vector) + (type (unsigned-byte 8) b0 b1 b2 b3)) + (when (= idx limit) + (%ioblock-force-output ioblock nil) + (setq idx 0 count 0)) + (setf (aref vector idx) b0) + (incf idx) + (when (= idx limit) + (when (> idx count) + (setf (io-buffer-count buf) idx)) + (%ioblock-force-output ioblock nil) + (setq idx 0 count 0)) + (setf (aref vector idx) b1) + (incf idx) + (when (= idx limit) + (when (> idx count) + (setf (io-buffer-count buf) idx)) + (%ioblock-force-output ioblock nil) + (setq idx 0 count 0)) + (setf (aref vector idx) b2) + (incf idx) + (when (= idx limit) + (when (> idx count) + (setf (io-buffer-count buf) idx)) + (%ioblock-force-output ioblock nil) + (setq idx 0 count 0)) + (setf (aref vector idx) b3) + (incf idx) + (setf (io-buffer-idx buf) idx) + (when (> idx count) + (setf (io-buffer-count buf) idx)) + (setf (ioblock-dirty ioblock) t) + element)) + +(declaim (inline %ioblock-write-s16-element)) +(defun %ioblock-write-s16-element (ioblock element) + (declare (optimize (speed 3) (safety 0))) + (let* ((buf (ioblock-outbuf ioblock)) + (idx (io-buffer-idx buf)) + (count (io-buffer-count buf)) + (limit (io-buffer-limit buf))) + (declare (fixnum idx limit count)) + (when (= idx limit) + (%ioblock-force-output ioblock nil) + (setq idx 0 count 0)) + (setf (aref (the (simple-array (signed-byte 16) (*)) (io-buffer-buffer buf)) idx) element) + (incf idx) + (setf (io-buffer-idx buf) idx) + (when (> idx count) + (setf (io-buffer-count buf) idx)) + (setf (ioblock-dirty ioblock) t) + element)) + +(declaim (inline %ioblock-write-u32-element)) +(defun %ioblock-write-u32-element (ioblock element) + (declare (optimize (speed 3) (safety 0))) + (let* ((buf (ioblock-outbuf ioblock)) + (idx (io-buffer-idx buf)) + (count (io-buffer-count buf)) + (limit (io-buffer-limit buf))) + (declare (fixnum idx limit count)) + (when (= idx limit) + (%ioblock-force-output ioblock nil) + (setq idx 0 count 0)) + (setf (aref (the (simple-array (unsigned-byte 32) (*)) (io-buffer-buffer buf)) idx) element) + (incf idx) + (setf (io-buffer-idx buf) idx) + (when (> idx count) + (setf (io-buffer-count buf) idx)) + (setf (ioblock-dirty ioblock) t) + element)) + +(declaim (inline %ioblock-write-swapped-u32-element)) +(defun %ioblock-write-swapped-u32-element (ioblock element) + (declare (optimize (speed 3) (safety 0))) + (let* ((buf (ioblock-outbuf ioblock)) + (idx (io-buffer-idx buf)) + (count (io-buffer-count buf)) + (limit (io-buffer-limit buf))) + (declare (fixnum idx limit count)) + (when (= idx limit) + (%ioblock-force-output ioblock nil) + (setq idx 0 count 0)) + (setf (aref (the (simple-array (unsigned-byte 32) (*)) (io-buffer-buffer buf)) idx) + (%swap-u32 element)) + (incf idx) + (setf (io-buffer-idx buf) idx) + (when (> idx count) + (setf (io-buffer-count buf) idx)) + (setf (ioblock-dirty ioblock) t) + element)) + +(declaim (inline %ioblock-write-s32-element)) +(defun %ioblock-write-s32-element (ioblock element) + (declare (optimize (speed 3) (safety 0))) + (let* ((buf (ioblock-outbuf ioblock)) + (idx (io-buffer-idx buf)) + (count (io-buffer-count buf)) + (limit (io-buffer-limit buf))) + (declare (fixnum idx limit count)) + (when (= idx limit) + (%ioblock-force-output ioblock nil) + (setq idx 0 count 0)) + (setf (aref (the (simple-array (signed-byte 32) (*)) (io-buffer-buffer buf)) idx) element) + (incf idx) + (setf (io-buffer-idx buf) idx) + (when (> idx count) + (setf (io-buffer-count buf) idx)) + (setf (ioblock-dirty ioblock) t) + element)) + +#+64-bit-target +(progn +(declaim (inline %ioblock-write-u64-element)) +(defun %ioblock-write-u64-element (ioblock element) + (declare (optimize (speed 3) (safety 0))) + (let* ((buf (ioblock-outbuf ioblock)) + (idx (io-buffer-idx buf)) + (count (io-buffer-count buf)) + (limit (io-buffer-limit buf))) + (declare (fixnum idx limit count)) + (when (= idx limit) + (%ioblock-force-output ioblock nil) + (setq idx 0 count 0)) + (setf (aref (the (simple-array (unsigned-byte 64) (*)) (io-buffer-buffer buf)) idx) element) + (incf idx) + (setf (io-buffer-idx buf) idx) + (when (> idx count) + (setf (io-buffer-count buf) idx)) + (setf (ioblock-dirty ioblock) t) + element)) + +(declaim (inline %ioblock-write-s64-element)) +(defun %ioblock-write-s64-element (ioblock element) + (declare (optimize (speed 3) (safety 0))) + (let* ((buf (ioblock-outbuf ioblock)) + (idx (io-buffer-idx buf)) + (count (io-buffer-count buf)) + (limit (io-buffer-limit buf))) + (declare (fixnum idx limit count)) + (when (= idx limit) + (%ioblock-force-output ioblock nil) + (setq idx 0 count 0)) + (setf (aref (the (simple-array (signed-byte 64) (*)) (io-buffer-buffer buf)) idx) element) + (incf idx) + (setf (io-buffer-idx buf) idx) + (when (> idx count) + (setf (io-buffer-count buf) idx)) + (setf (ioblock-dirty ioblock) t) + element)) +) + +(declaim (inline %ioblock-write-char)) +(defun %ioblock-write-char (ioblock char) + (declare (optimize (speed 3) (safety 0))) + (if (eq char #\linefeed) + (setf (ioblock-charpos ioblock) 0) + (incf (ioblock-charpos ioblock))) + (let* ((code (char-code char))) + (declare (type (mod #x110000) code)) + (if (< code 256) + (%ioblock-write-u8-element ioblock code) + (%ioblock-write-u8-element ioblock (char-code #\Sub))))) + +(defun %private-ioblock-write-char (ioblock char) + (declare (optimize (speed 3) (safety 0))) + (check-ioblock-owner ioblock) + (%ioblock-write-char ioblock char)) + +(defun %locked-ioblock-write-char (ioblock char) + (declare (optimize (speed 3) (safety 0))) + (with-ioblock-output-lock-grabbed (ioblock) + (%ioblock-write-char ioblock char))) + +(declaim (inline %ioblock-write-u8-encoded-char)) +(defun %ioblock-write-u8-encoded-char (ioblock char) + (declare (optimize (speed 3) (safety 0))) + (if (eq char #\linefeed) + (setf (ioblock-charpos ioblock) 0) + (incf (ioblock-charpos ioblock))) + (let* ((code (char-code char))) + (declare (type (mod #x110000) code)) + (if (< code (the fixnum (ioblock-encode-literal-char-code-limit ioblock))) + (%ioblock-write-u8-element ioblock code) + (funcall (ioblock-encode-output-function ioblock) + char + #'%ioblock-write-u8-element + ioblock)))) + +(defun %private-ioblock-write-u8-encoded-char (ioblock char) + (declare (optimize (speed 3) (safety 0))) + (check-ioblock-owner ioblock) + (%ioblock-write-u8-encoded-char ioblock char)) + +(defun %locked-ioblock-write-u8-encoded-char (ioblock char) + (declare (optimize (speed 3) (safety 0))) + (with-ioblock-output-lock-grabbed (ioblock) + (%ioblock-write-u8-encoded-char ioblock char))) + + +(defun %ioblock-write-u8-encoded-simple-string (ioblock string start-char num-chars) + (declare (fixnum start-char num-chars) + (simple-base-string string) + (optimize (speed 3) (safety 0))) + (do* ((i 0 (1+ i)) + (col (ioblock-charpos ioblock)) + (limit (ioblock-encode-literal-char-code-limit ioblock)) + (encode-function (ioblock-encode-output-function ioblock)) + (start-char start-char (1+ start-char))) + ((= i num-chars) (setf (ioblock-charpos ioblock) col) num-chars) + (declare (fixnum i start-char limit)) + (let* ((char (schar string start-char)) + (code (char-code char))) + (declare (type (mod #x110000) code)) + (if (eq char #\newline) + (setq col 0) + (incf col)) + (if (< code limit) + (%ioblock-write-u8-element ioblock code) + (funcall encode-function char #'%ioblock-write-u8-element ioblock))))) + + +(declaim (inline %ioblock-write-u16-encoded-char)) +(defun %ioblock-write-u16-encoded-char (ioblock char) + (declare (optimize (speed 3) (safety 0))) + (when (ioblock-pending-byte-order-mark ioblock) + (setf (ioblock-pending-byte-order-mark ioblock) nil) + (%ioblock-write-u16-code-unit ioblock byte-order-mark-char-code)) + (if (eq char #\linefeed) + (setf (ioblock-charpos ioblock) 0) + (incf (ioblock-charpos ioblock))) + (let* ((code (char-code char))) + (declare (type (mod #x110000) code)) + (if (< code (the fixnum (ioblock-encode-literal-char-code-limit ioblock))) + (%ioblock-write-u16-code-unit ioblock code) + (funcall (ioblock-encode-output-function ioblock) + char + #'%ioblock-write-u16-code-unit + ioblock)))) + +(defun %private-ioblock-write-u16-encoded-char (ioblock char) + (declare (optimize (speed 3) (safety 0))) + (check-ioblock-owner ioblock) + (%ioblock-write-u16-encoded-char ioblock char)) + +(defun %locked-ioblock-write-u16-encoded-char (ioblock char) + (declare (optimize (speed 3) (safety 0))) + (with-ioblock-output-lock-grabbed (ioblock) + (%ioblock-write-u16-encoded-char ioblock char))) + + +(defun %ioblock-write-u16-encoded-simple-string (ioblock string start-char num-chars) + (declare (fixnum start-char num-chars) + (simple-base-string string) + (optimize (speed 3) (safety 0))) + (when (ioblock-pending-byte-order-mark ioblock) + (setf (ioblock-pending-byte-order-mark ioblock) nil) + (%ioblock-write-u16-code-unit ioblock byte-order-mark-char-code)) + (do* ((i 0 (1+ i)) + (col (ioblock-charpos ioblock)) + (limit (ioblock-encode-literal-char-code-limit ioblock)) + (encode-function (ioblock-encode-output-function ioblock)) + (start-char start-char (1+ start-char))) + ((= i num-chars) (setf (ioblock-charpos ioblock) col) num-chars) + (declare (fixnum i start-char limit)) + (let* ((char (schar string start-char)) + (code (char-code char))) + (declare (type (mod #x110000) code)) + (if (eq char #\newline) + (setq col 0) + (incf col)) + (if (< code limit) + (%ioblock-write-u16-code-unit ioblock code) + (funcall encode-function char #'%ioblock-write-u16-code-unit ioblock))))) + +(declaim (inline %ioblock-write-swapped-u16-encoded-char)) +(defun %ioblock-write-swapped-u16-encoded-char (ioblock char) + (declare (optimize (speed 3) (safety 0))) + (if (eq char #\linefeed) + (setf (ioblock-charpos ioblock) 0) + (incf (ioblock-charpos ioblock))) + (let* ((code (char-code char))) + (declare (type (mod #x110000) code)) + (if (< code (the fixnum (ioblock-encode-literal-char-code-limit ioblock))) + (%ioblock-write-swapped-u16-code-unit ioblock code) + (funcall (ioblock-encode-output-function ioblock) + char + #'%ioblock-write-swapped-u16-code-unit + ioblock)))) + +(defun %private-ioblock-write-swapped-u16-encoded-char (ioblock char) + (declare (optimize (speed 3) (safety 0))) + (check-ioblock-owner ioblock) + (%ioblock-write-swapped-u16-encoded-char ioblock char)) + +(defun %locked-ioblock-write-swapped-u16-encoded-char (ioblock char) + (declare (optimize (speed 3) (safety 0))) + (with-ioblock-output-lock-grabbed (ioblock) + (%ioblock-write-swapped-u16-encoded-char ioblock char))) + +(defun %ioblock-write-swapped-u16-encoded-simple-string (ioblock string start-char num-chars) + (declare (fixnum start-char num-chars) + (simple-base-string string) + (optimize (speed 3) (safety 0))) + (do* ((i 0 (1+ i)) + (col (ioblock-charpos ioblock)) + (limit (ioblock-encode-literal-char-code-limit ioblock)) + (encode-function (ioblock-encode-output-function ioblock)) + (wcf (ioblock-write-char-when-locked-function ioblock)) + (start-char start-char (1+ start-char))) + ((= i num-chars) (setf (ioblock-charpos ioblock) col) num-chars) + (declare (fixnum i start-char limit)) + (let* ((char (schar string start-char)) + (code (char-code char))) + (declare (type (mod #x110000) code)) + (cond ((eq char #\newline) + (setq col 0) + (funcall wcf ioblock char)) + (t + (incf col) + (if (< code limit) + (%ioblock-write-swapped-u16-code-unit ioblock code) + (funcall encode-function char #'%ioblock-write-swapped-u16-code-unit ioblock))))))) + + +(declaim (inline %ioblock-write-u32-encoded-char)) +(defun %ioblock-write-u32-encoded-char (ioblock char) + (declare (optimize (speed 3) (safety 0))) + (when (ioblock-pending-byte-order-mark ioblock) + (setf (ioblock-pending-byte-order-mark ioblock) nil) + (%ioblock-write-u32-code-unit ioblock byte-order-mark)) + (if (eq char #\linefeed) + (setf (ioblock-charpos ioblock) 0) + (incf (ioblock-charpos ioblock))) + (let* ((code (char-code char))) + (declare (type (mod #x110000) code)) + (if (< code (the fixnum (ioblock-encode-literal-char-code-limit ioblock))) + (%ioblock-write-u32-code-unit ioblock code) + (funcall (ioblock-encode-output-function ioblock) + code + #'%ioblock-write-u32-code-unit + ioblock)))) + +(defun %private-ioblock-write-u32-encoded-char (ioblock char) + (declare (optimize (speed 3) (safety 0))) + (check-ioblock-owner ioblock) + (%ioblock-write-u32-encoded-char ioblock char)) + +(defun %locked-ioblock-write-u32-encoded-char (ioblock char) + (declare (optimize (speed 3) (safety 0))) + (with-ioblock-output-lock-grabbed (ioblock) + (%ioblock-write-u32-encoded-char ioblock char))) + +(defun %ioblock-write-u32-encoded-simple-string (ioblock string start-char num-chars) + (declare (fixnum start-char num-chars) + (simple-base-string string) + (optimize (speed 3) (safety 0))) + (when (ioblock-pending-byte-order-mark ioblock) + (setf (ioblock-pending-byte-order-mark ioblock) nil) + (%ioblock-write-u32-code-unit ioblock byte-order-mark-char-code)) + (do* ((i 0 (1+ i)) + (col (ioblock-charpos ioblock)) + (limit (ioblock-encode-literal-char-code-limit ioblock)) + (encode-function (ioblock-encode-output-function ioblock)) + (start-char start-char (1+ start-char))) + ((= i num-chars) (setf (ioblock-charpos ioblock) col) num-chars) + (declare (fixnum i start-char limit)) + (let* ((char (schar string start-char)) + (code (char-code char))) + (declare (type (mod #x110000) code)) + (if (eq char #\newline) + (setq col 0) + (incf col)) + (if (< code limit) + (%ioblock-write-u32-code-unit ioblock code) + (funcall encode-function char #'%ioblock-write-u32-code-unit ioblock))))) + + +(declaim (inline %ioblock-write-swapped-u32-encoded-char)) +(defun %ioblock-write-swapped-u32-encoded-char (ioblock char) + (declare (optimize (speed 3) (safety 0))) + (if (eq char #\linefeed) + (setf (ioblock-charpos ioblock) 0) + (incf (ioblock-charpos ioblock))) + (let* ((code (char-code char))) + (declare (type (mod #x110000) code)) + (if (< code (the fixnum (ioblock-encode-literal-char-code-limit ioblock))) + (%ioblock-write-swapped-u32-code-unit ioblock code) + (funcall (ioblock-encode-output-function ioblock) + code + #'%ioblock-write-swapped-u32-code-unit + ioblock)))) + +(defun %private-ioblock-write-swapped-u32-encoded-char (ioblock char) + (declare (optimize (speed 3) (safety 0))) + (check-ioblock-owner ioblock) + (%ioblock-write-swapped-u32-encoded-char ioblock char)) + +(defun %locked-ioblock-write-swapped-u32-encoded-char (ioblock char) + (declare (optimize (speed 3) (safety 0))) + (with-ioblock-output-lock-grabbed (ioblock) + (%ioblock-write-swapped-u32-encoded-char ioblock char))) + +(defun %ioblock-write-swapped-u32-encoded-simple-string (ioblock string start-char num-chars) + (declare (fixnum start-char num-chars) + (simple-base-string string) + (optimize (speed 3) (safety 0))) + (do* ((i 0 (1+ i)) + (col (ioblock-charpos ioblock)) + (limit (ioblock-encode-literal-char-code-limit ioblock)) + (encode-function (ioblock-encode-output-function ioblock)) + (start-char start-char (1+ start-char))) + ((= i num-chars) (setf (ioblock-charpos ioblock) col) num-chars) + (declare (fixnum i start-char limit)) + (let* ((char (schar string start-char)) + (code (char-code char))) + (declare (type (mod #x110000) code)) + (if (eq char #\newline) + (setq col 0) + (incf col)) + (if (< code limit) + (%ioblock-write-swapped-u32-code-unit ioblock code) + (funcall encode-function char #'%ioblock-write-swapped-u32-code-unit ioblock))))) + +(declaim (inline %ioblock-write-u8-byte)) +(defun %ioblock-write-u8-byte (ioblock byte) + (declare (optimize (speed 3) (safety 0))) + (%ioblock-write-u8-element ioblock (require-type byte '(unsigned-byte 8)))) + +(defun %private-ioblock-write-u8-byte (ioblock byte) + (declare (optimize (speed 3) (safety 0))) + (check-ioblock-owner ioblock) + (%ioblock-write-u8-byte ioblock byte)) + +(defun %locked-ioblock-write-u8-byte (ioblock byte) + (declare (optimize (speed 3) (safety 0))) + (with-ioblock-output-lock-grabbed (ioblock) + (%ioblock-write-u8-byte ioblock byte))) + +(declaim (inline %ioblock-write-s8-byte)) +(defun %ioblock-write-s8-byte (ioblock byte) + (declare (optimize (speed 3) (safety 0))) + (%ioblock-write-s8-element ioblock (require-type byte '(signed-byte 8)))) + +(defun %private-ioblock-write-s8-byte (ioblock byte) + (declare (optimize (speed 3) (safety 0))) + (check-ioblock-owner ioblock) + (%ioblock-write-s8-byte ioblock byte)) + +(defun %locked-ioblock-write-s8-byte (ioblock byte) + (declare (optimize (speed 3) (safety 0))) + (with-ioblock-output-lock-grabbed (ioblock) + (%ioblock-write-s8-byte ioblock byte))) + +(declaim (inline %ioblock-write-u16-byte)) +(defun %ioblock-write-u16-byte (ioblock byte) + (declare (optimize (speed 3) (safety 0))) + (%ioblock-write-u16-element ioblock (require-type byte '(unsigned-byte 16)))) + +(defun %private-ioblock-write-u16-byte (ioblock byte) + (declare (optimize (speed 3) (safety 0))) + (check-ioblock-owner ioblock) + (%ioblock-write-u16-byte ioblock byte)) + +(defun %locked-ioblock-write-u16-byte (ioblock byte) + (declare (optimize (speed 3) (safety 0))) + (with-ioblock-output-lock-grabbed (ioblock) + (%ioblock-write-u16-byte ioblock byte))) + +(declaim (inline %ioblock-write-s16-byte)) +(defun %ioblock-write-s16-byte (ioblock byte) + (declare (optimize (speed 3) (safety 0))) + (%ioblock-write-s16-element ioblock (require-type byte '(signed-byte 16)))) + +(defun %private-ioblock-write-s16-byte (ioblock byte) + (declare (optimize (speed 3) (safety 0))) + (check-ioblock-owner ioblock) + (%ioblock-write-s16-byte ioblock byte)) + +(defun %locked-ioblock-write-s16-byte (ioblock byte) + (declare (optimize (speed 3) (safety 0))) + (with-ioblock-output-lock-grabbed (ioblock) + (%ioblock-write-s16-byte ioblock byte))) + +(declaim (inline %ioblock-write-u32-byte)) +(defun %ioblock-write-u32-byte (ioblock byte) + (declare (optimize (speed 3) (safety 0))) + (%ioblock-write-u32-element ioblock (require-type byte '(unsigned-byte 32)))) + +(defun %private-ioblock-write-u32-byte (ioblock byte) + (declare (optimize (speed 3) (safety 0))) + (check-ioblock-owner ioblock) + (%ioblock-write-u32-byte ioblock byte)) + +(defun %locked-ioblock-write-u32-byte (ioblock byte) + (declare (optimize (speed 3) (safety 0))) + (with-ioblock-output-lock-grabbed (ioblock) + (%ioblock-write-u32-byte ioblock byte))) + +(declaim (inline %ioblock-write-s32-byte)) +(defun %ioblock-write-s32-byte (ioblock byte) + (declare (optimize (speed 3) (safety 0))) + (%ioblock-write-s32-element ioblock (require-type byte '(signed-byte 32)))) + +(defun %private-ioblock-write-s32-byte (ioblock byte) + (declare (optimize (speed 3) (safety 0))) + (check-ioblock-owner ioblock) + (%ioblock-write-s32-byte ioblock byte)) + +(defun %locked-ioblock-write-s32-byte (ioblock byte) + (declare (optimize (speed 3) (safety 0))) + (with-ioblock-output-lock-grabbed (ioblock) + (%ioblock-write-s32-byte ioblock byte))) + +#+64-bit-target +(progn +(declaim (inline %ioblock-write-u64-byte)) +(defun %ioblock-write-u64-byte (ioblock byte) + (declare (optimize (speed 3) (safety 0))) + (%ioblock-write-u64-element ioblock (require-type byte '(unsigned-byte 64)))) + +(defun %private-ioblock-write-u64-byte (ioblock byte) + (declare (optimize (speed 3) (safety 0))) + (check-ioblock-owner ioblock) + (%ioblock-write-u64-byte ioblock byte)) + +(defun %locked-ioblock-write-u64-byte (ioblock byte) + (declare (optimize (speed 3) (safety 0))) + (with-ioblock-output-lock-grabbed (ioblock) + (%ioblock-write-u64-byte ioblock byte))) + +(declaim (inline %ioblock-write-s64-byte)) +(defun %ioblock-write-s64-byte (ioblock byte) + (declare (optimize (speed 3) (safety 0))) + (%ioblock-write-s64-element ioblock (require-type byte '(signed-byte 64)))) + +(defun %private-ioblock-write-s64-byte (ioblock byte) + (declare (optimize (speed 3) (safety 0))) + (check-ioblock-owner ioblock) + (%ioblock-write-s64-byte ioblock byte)) + +(defun %locked-ioblock-write-s64-byte (ioblock byte) + (declare (optimize (speed 3) (safety 0))) + (with-ioblock-output-lock-grabbed (ioblock) + (%ioblock-write-s64-byte ioblock byte))) +) ;#+64-bit-target + +(defun %ioblock-clear-output (ioblock) + (let* ((buf (ioblock-outbuf ioblock))) + (setf (io-buffer-count buf) 0 + (io-buffer-idx buf) 0))) + +(defun %ioblock-unencoded-read-line (ioblock) + (let* ((inbuf (ioblock-inbuf ioblock))) + (let* ((string "") + (len 0) + (eof nil) + (buf (io-buffer-buffer inbuf)) + (newline (char-code #\newline))) + (let* ((ch (ioblock-untyi-char ioblock))) + (when ch + (setf (ioblock-untyi-char ioblock) nil) + (if (eql ch #\newline) + (return-from %ioblock-unencoded-read-line + (values string nil)) + (progn + (setq string (make-string 1) + len 1) + (setf (schar string 0) ch))))) + (loop + (let* ((more 0) + (idx (io-buffer-idx inbuf)) + (count (io-buffer-count inbuf))) + (declare (fixnum idx count more)) + (if (= idx count) + (if eof + (return (values string t)) + (progn + (setq eof t) + (%ioblock-advance ioblock t))) + (progn + (setq eof nil) + (let* ((pos (position newline buf :start idx :end count))) + (when pos + (locally (declare (fixnum pos)) + (setf (io-buffer-idx inbuf) (the fixnum (1+ pos))) + (setq more (- pos idx)) + (unless (zerop more) + (setq string + (%extend-vector + 0 string (the fixnum (+ len more))))) + (%copy-u8-to-string + buf idx string len more) + (return (values string nil)))) + ;; No #\newline in the buffer. Read everything that's + ;; there into the string, and fill the buffer again. + (setf (io-buffer-idx inbuf) count) + (setq more (- count idx) + string (%extend-vector + 0 string (the fixnum (+ len more)))) + (%copy-u8-to-string + buf idx string len more) + (incf len more))))))))) + +;;; There are lots of ways of doing better here, but in the most general +;;; case we can't tell (a) what a newline looks like in the buffer or (b) +;;; whether there's a 1:1 mapping between code units and characters. +(defun %ioblock-encoded-read-line (ioblock) + (let* ((str (make-array 20 :element-type 'base-char + :adjustable t :fill-pointer 0)) + (rcf (ioblock-read-char-when-locked-function ioblock)) + (eof nil)) + (do* ((ch (funcall rcf ioblock) (funcall rcf ioblock))) + ((or (eq ch #\newline) (setq eof (eq ch :eof))) + (values (ensure-simple-string str) eof)) + (vector-push-extend ch str)))) + +(defun %ioblock-unencoded-character-read-vector (ioblock vector start end) + (do* ((i start) + (in (ioblock-inbuf ioblock)) + (inbuf (io-buffer-buffer in)) + (need (- end start))) + ((= i end) end) + (declare (fixnum i need)) + (let* ((ch (%ioblock-tyi ioblock))) + (if (eq ch :eof) + (return i)) + (setf (schar vector i) ch) + (incf i) + (decf need) + (let* ((idx (io-buffer-idx in)) + (count (io-buffer-count in)) + (avail (- count idx))) + (declare (fixnum idx count avail)) + (unless (zerop avail) + (if (> avail need) + (setq avail need)) + (%copy-u8-to-string inbuf idx vector i avail) + (setf (io-buffer-idx in) (+ idx avail)) + (incf i avail) + (decf need avail)))))) + +;;; Also used when newline translation complicates things. +(defun %ioblock-encoded-character-read-vector (ioblock vector start end) + (declare (fixnum start end)) + (do* ((i start (1+ i)) + (rcf (ioblock-read-char-when-locked-function ioblock))) + ((= i end) end) + (declare (fixnum i)) + (let* ((ch (funcall rcf ioblock))) + (if (eq ch :eof) + (return i)) + (setf (schar vector i) ch)))) + + +(defun %ioblock-binary-read-vector (ioblock vector start end) + (declare (fixnum start end)) + (let* ((in (ioblock-inbuf ioblock)) + (inbuf (io-buffer-buffer in)) + (rbf (ioblock-read-byte-when-locked-function ioblock))) + (setf (ioblock-untyi-char ioblock) nil) + (if (not (= (the fixnum (typecode inbuf)) + (the fixnum (typecode vector)))) + (do* ((i start (1+ i))) + ((= i end) i) + (declare (fixnum i)) + (let* ((b (funcall rbf ioblock))) + (if (eq b :eof) + (return i) + (setf (uvref vector i) b)))) + (do* ((i start) + (need (- end start))) + ((= i end) end) + (declare (fixnum i need)) + (let* ((b (funcall rbf ioblock))) + (if (eq b :eof) + (return i)) + (setf (uvref vector i) b) + (incf i) + (decf need) + (let* ((idx (io-buffer-idx in)) + (count (io-buffer-count in)) + (avail (- count idx))) + (declare (fixnum idx count avail)) + (unless (zerop avail) + (if (> avail need) + (setq avail need)) + (%copy-ivector-to-ivector + inbuf + (ioblock-elements-to-octets ioblock idx) + vector + (ioblock-elements-to-octets ioblock i) + (ioblock-elements-to-octets ioblock avail)) + (setf (io-buffer-idx in) (+ idx avail)) + (incf i avail) + (decf need avail)))))))) + +;;; About the same, only less fussy about ivector's element-type. +;;; (All fussiness is about the stream's element-type ...). +;;; Whatever the element-type is, elements must be 1 octet in size. +(defun %ioblock-character-in-ivect (ioblock vector start nb) + (declare (type (simple-array (unsigned-byte 8) (*)) vector) + (fixnum start nb) + (optimize (speed 3) (safety 0))) + (unless (= 0 (the fixnum (ioblock-element-shift ioblock))) + (error "Can't read vector from stream ~s" (ioblock-stream ioblock))) + (do* ((i start) + (in (ioblock-inbuf ioblock)) + (inbuf (io-buffer-buffer in)) + (need nb) + (end (+ start nb))) + ((= i end) end) + (declare (fixnum i end need)) + (let* ((ch (%ioblock-tyi ioblock))) + (if (eq ch :eof) + (return (- i start))) + (setf (aref vector i) (char-code ch)) + (incf i) + (decf need) + (let* ((idx (io-buffer-idx in)) + (count (io-buffer-count in)) + (avail (- count idx))) + (declare (fixnum idx count avail)) + (unless (zerop avail) + (if (> avail need) + (setq avail need)) + (%copy-u8-to-string inbuf idx vector i avail) + (setf (io-buffer-idx in) (+ idx avail)) + (incf i avail) + (decf need avail)))))) + +(defun %ioblock-binary-in-ivect (ioblock vector start nb) + (declare (type (simple-array (unsigned-byte 8) (*)) vector) + (fixnum start nb) + (optimize (speed 3) (safety 0))) + (unless (= 0 (the fixnum (ioblock-element-shift ioblock))) + (error "Can't read vector from stream ~s" (ioblock-stream ioblock))) + (setf (ioblock-untyi-char ioblock) nil) + (do* ((i start) + (rbf (ioblock-read-byte-when-locked-function ioblock)) + (in (ioblock-inbuf ioblock)) + (inbuf (io-buffer-buffer in)) + (need nb) + (end (+ start nb))) + ((= i end) nb) + (declare (fixnum i end need)) + (let* ((b (funcall rbf ioblock))) + (if (eq b :eof) + (return (- i start))) + (setf (uvref vector i) b) + (incf i) + (decf need) + (let* ((idx (io-buffer-idx in)) + (count (io-buffer-count in)) + (avail (- count idx))) + (declare (fixnum idx count avail)) + (unless (zerop avail) + (if (> avail need) + (setq avail need)) + (%copy-ivector-to-ivector inbuf idx vector i avail) + (setf (io-buffer-idx in) (+ idx avail)) + (incf i avail) + (decf need avail)))))) + +;;; Thread must own ioblock lock(s). +(defun %%ioblock-close (ioblock) + (when (ioblock-device ioblock) + (let* ((stream (ioblock-stream ioblock))) + (funcall (ioblock-close-function ioblock) stream ioblock) + (setf (ioblock-device ioblock) nil) + (setf (stream-ioblock stream) nil) + (let* ((in-iobuf (ioblock-inbuf ioblock)) + (out-iobuf (ioblock-outbuf ioblock)) + (in-buffer (if in-iobuf (io-buffer-buffer in-iobuf))) + (in-bufptr (if in-iobuf (io-buffer-bufptr in-iobuf))) + (out-buffer (if out-iobuf (io-buffer-buffer out-iobuf))) + (out-bufptr (if out-iobuf (io-buffer-bufptr out-iobuf)))) + (if (and in-buffer in-bufptr) + (%dispose-heap-ivector in-buffer)) + (unless (eq in-buffer out-buffer) + (if (and out-buffer out-bufptr) + (%dispose-heap-ivector out-buffer))) + (when in-iobuf + (setf (io-buffer-buffer in-iobuf) nil + (io-buffer-bufptr in-iobuf) nil + (ioblock-inbuf ioblock) nil)) + (when out-iobuf + (setf (io-buffer-buffer out-iobuf) nil + (io-buffer-bufptr out-iobuf) nil + (ioblock-outbuf ioblock) nil)) + t)))) + +(defun %ioblock-close (ioblock) + (let* ((in-lock (ioblock-inbuf-lock ioblock)) + (out-lock (ioblock-outbuf-lock ioblock))) + (if in-lock + (with-lock-grabbed (in-lock) + (if (and out-lock (not (eq out-lock in-lock))) + (with-lock-grabbed (out-lock) + (%%ioblock-close ioblock)) + (%%ioblock-close ioblock))) + (if out-lock + (with-lock-grabbed (out-lock) + (%%ioblock-close ioblock)) + (progn + (check-ioblock-owner ioblock) + (%%ioblock-close ioblock)))))) + + + +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; + +;;; Character-at-a-time line-termination-translation functions. +;;; It's not always possible to just blast through the buffer, blindly +;;; replacing #xd with #xa (for example), and it's not always desirable +;;; to do that (if we support changing encoding on open streams.) +;;; This is done at a fairly high level; some cases could be done at +;;; a lower level, and some cases are hard even at that lower level. +;;; This approach doesn't slow down the simple case (when no line-termination +;;; translation is used), and hopefully isn't -that- bad. + +(declaim (inline %ioblock-read-char-translating-cr-to-newline)) +(defun %ioblock-read-char-translating-cr-to-newline (ioblock) + (let* ((ch (funcall + (ioblock-read-char-without-translation-when-locked-function + ioblock) + ioblock))) + (if (eql ch #\Return) + #\Newline + ch))) + +(defun %private-ioblock-read-char-translating-cr-to-newline (ioblock) + (check-ioblock-owner ioblock) + (%ioblock-read-char-translating-cr-to-newline ioblock)) + +(defun %locked-ioblock-read-char-translating-cr-to-newline (ioblock) + (with-ioblock-input-lock-grabbed (ioblock) + (%ioblock-read-char-translating-cr-to-newline ioblock))) + +(declaim (inline %ioblock-read-char-translating-crlf-to-newline)) +(defun %ioblock-read-char-translating-crlf-to-newline (ioblock) + (let* ((ch (funcall + (ioblock-read-char-without-translation-when-locked-function + ioblock) + ioblock))) + (if (eql ch #\Return) + (let* ((next (funcall + (ioblock-read-char-without-translation-when-locked-function + ioblock) + ioblock))) + (if (eql next #\Linefeed) + next + (progn + (unless (eq next :eof) + (setf (ioblock-untyi-char ioblock) next)) + ch))) + ch))) + +(defun %private-ioblock-read-char-translating-crlf-to-newline (ioblock) + (check-ioblock-owner ioblock) + (%ioblock-read-char-translating-crlf-to-newline ioblock)) + +(defun %locked-ioblock-read-char-translating-crlf-to-newline (ioblock) + (with-ioblock-input-lock-grabbed (ioblock) + (%ioblock-read-char-translating-crlf-to-newline ioblock))) + +(declaim (inline %ioblock-read-char-translating-line-separator-to-newline)) +(defun %ioblock-read-char-translating-line-separator-to-newline (ioblock) + (let* ((ch (funcall + (ioblock-read-char-without-translation-when-locked-function + ioblock) + ioblock))) + (if (eql ch #\Line_Separator) + #\Newline + ch))) + +(defun %private-ioblock-read-char-translating-line-separator-to-newline (ioblock) + (check-ioblock-owner ioblock) + (%ioblock-read-char-translating-line-separator-to-newline ioblock)) + +(defun %locked-ioblock-read-char-translating-line-separator-to-newline (ioblock) + (with-ioblock-input-lock-grabbed (ioblock) + (%ioblock-read-char-translating-line-separator-to-newline ioblock))) + +(declaim (inline %ioblock-write-char-translating-newline-to-cr)) +(defun %ioblock-write-char-translating-newline-to-cr (ioblock char) + (funcall (ioblock-write-char-without-translation-when-locked-function + ioblock) + ioblock + (if (eql char #\Newline) #\Return char))) + +(defun %private-ioblock-write-char-translating-newline-to-cr (ioblock char) + (check-ioblock-owner ioblock) + (%ioblock-write-char-translating-newline-to-cr ioblock char)) + +(defun %locked-ioblock-write-char-translating-newline-to-cr (ioblock char) + (with-ioblock-output-lock-grabbed (ioblock) + (%ioblock-write-char-translating-newline-to-cr ioblock char))) + +(declaim (inline %ioblock-write-char-translating-newline-to-crlf)) +(defun %ioblock-write-char-translating-newline-to-crlf (ioblock char) + (when (eql char #\Newline) + (funcall (ioblock-write-char-without-translation-when-locked-function + ioblock) + ioblock + #\Return)) + (funcall (ioblock-write-char-without-translation-when-locked-function + ioblock) + ioblock + char)) + +(defun %private-ioblock-write-char-translating-newline-to-crlf (ioblock char) + (check-ioblock-owner ioblock) + (%ioblock-write-char-translating-newline-to-crlf ioblock char)) + +(defun %locked-ioblock-write-char-translating-newline-to-crlf (ioblock char) + (with-ioblock-output-lock-grabbed (ioblock) + (%ioblock-write-char-translating-newline-to-crlf ioblock char))) + +(declaim (inline %ioblock-write-char-translating-newline-to-line-separator)) +(defun %ioblock-write-char-translating-newline-to-line-separator (ioblock char) + (funcall (ioblock-write-char-without-translation-when-locked-function + ioblock) + ioblock + (if (eql char #\Newline) #\Line_Separator char))) + +(defun %private-ioblock-write-char-translating-newline-to-line-separator (ioblock char) + (check-ioblock-owner ioblock) + (%ioblock-write-char-translating-newline-to-line-separator ioblock char)) + +(defun %locked-ioblock-write-char-translating-newline-to-line-separator (ioblock char) + (with-ioblock-output-lock-grabbed (ioblock) + (%ioblock-write-char-translating-newline-to-line-separator ioblock char))) + +;;; If we do newline translation, we probably can't be too clever about reading/writing +;;; strings. +(defun %ioblock-write-simple-string-with-newline-translation (ioblock string start-pos num-chars) + (declare (fixnum start-pos num-chars) (simple-string string)) + (let* ((col (ioblock-charpos ioblock)) + (wcf (ioblock-write-char-when-locked-function ioblock))) + (declare (fixnum col)) + (do* ((i start-pos (1+ i)) + (n 0 (1+ n))) + ((= n num-chars) (setf (ioblock-charpos ioblock) col) num-chars) + (let* ((char (schar string i))) + (if (eql char #\Newline) + (setq col 0) + (incf col)) + (funcall wcf ioblock char))))) + + + +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; + +(defun setup-ioblock-input (ioblock character-p element-type sharing encoding line-termination) + (setf (ioblock-sharing ioblock) sharing) + (when character-p + (setf (ioblock-unread-char-function ioblock) (select-stream-untyi-function (ioblock-stream ioblock) :input)) + (setf (ioblock-decode-literal-code-unit-limit ioblock) + (if encoding + (character-encoding-decode-literal-code-unit-limit encoding) + 256)) + (if encoding + (let* ((unit-size (character-encoding-code-unit-size encoding))) + (setf (ioblock-peek-char-function ioblock) '%encoded-ioblock-peek-char) + (setf (ioblock-read-line-function ioblock) + '%ioblock-encoded-read-line) + (setf (ioblock-character-read-vector-function ioblock) + '%ioblock-encoded-character-read-vector) + (setf (ioblock-decode-input-function ioblock) + (character-encoding-stream-decode-function encoding)) + (setf (ioblock-read-char-function ioblock) + (ecase unit-size + (8 + (setf (ioblock-read-char-when-locked-function ioblock) + '%ioblock-read-u8-encoded-char) + (case sharing + (:private '%private-ioblock-read-u8-encoded-char) + (:lock '%locked-ioblock-read-u8-encoded-char) + (t '%ioblock-read-u8-encoded-char))) + (16 + (if (character-encoding-native-endianness encoding) + (progn + (setf (ioblock-read-char-when-locked-function ioblock) + '%ioblock-read-u16-encoded-char) + (case sharing + (:private '%private-ioblock-read-u16-encoded-char) + (:lock '%locked-ioblock-read-u16-encoded-char) + (t '%ioblock-read-u16-encoded-char))) + (progn + (setf (ioblock-read-char-when-locked-function ioblock) + '%ioblock-read-swapped-u16-encoded-char) + (case sharing + (:private '%private-ioblock-read-swapped-u16-encoded-char) + (:lock '%locked-ioblock-read-swapped-u16-encoded-char) + (t '%ioblock-read-swapped-u16-encoded-char))))) + (32 + (if (character-encoding-native-endianness encoding) + (progn + (setf (ioblock-read-char-when-locked-function ioblock) + #'%ioblock-read-u32-encoded-char) + (case sharing + (:private #'%private-ioblock-read-u32-encoded-char) + (:lock #'%locked-ioblock-read-u32-encoded-char) + (t #'%ioblock-read-u32-encoded-char))) + (progn + (setf (ioblock-read-char-when-locked-function ioblock) + #'%ioblock-read-swapped-u32-encoded-char) + (case sharing + (:private '#'%private-ioblock-read-swapped-u16-encoded-char) + (:lock #'%locked-ioblock-read-swapped-u32-encoded-char) + (t #'%ioblock-read-swapped-u32-encoded-char)))))))) + (progn + (setf (ioblock-peek-char-function ioblock) '%ioblock-peek-char) + (setf (ioblock-read-char-function ioblock) + (case sharing + (:private '%private-ioblock-tyi) + (:lock '%locked-ioblock-tyi) + (t '%ioblock-tyi))) + (setf (ioblock-read-char-when-locked-function ioblock) + '%ioblock-tyi) + (setf (ioblock-character-read-vector-function ioblock) + '%ioblock-unencoded-character-read-vector) + (setf (ioblock-read-line-function ioblock) + '%ioblock-unencoded-read-line))) + (when line-termination + (install-ioblock-input-line-termination ioblock line-termination)) + ) + + (unless (or (eq element-type 'character) + (subtypep element-type 'character)) + (let* ((subtag (element-type-subtype element-type))) + (declare (type (unsigned-byte 8) subtag)) + (setf (ioblock-read-byte-function ioblock) + (cond ((= subtag target::subtag-u8-vector) + (if character-p + ;; The bivalent case, at least for now + (progn + (setf (ioblock-read-byte-when-locked-function ioblock) + '%bivalent-ioblock-read-u8-byte) + (case sharing + (:private '%bivalent-private-ioblock-read-u8-byte) + (:lock '%bivalent-locked-ioblock-read-u8-byte) + (t '%bivalent-ioblock-read-u8-byte))) + (progn + (setf (ioblock-read-byte-when-locked-function ioblock) + '%ioblock-read-u8-byte) + (case sharing + (:private '%private-ioblock-read-u8-byte) + (:lock '%locked-ioblock-read-u8-byte) + (t '%ioblock-read-u8-byte))))) + ((= subtag target::subtag-s8-vector) + (setf (ioblock-read-byte-when-locked-function ioblock) + '%ioblock-read-s8-byte) + (case sharing + (:private '%private-ioblock-read-s8-byte) + (:lock '%locked-ioblock-read-s8-byte) + (t '%ioblock-read-s8-byte))) + ((= subtag target::subtag-u16-vector) + (setf (ioblock-read-byte-when-locked-function ioblock) + '%ioblock-read-u16-byte) + (case sharing + (:private '%private-ioblock-read-u16-byte) + (:lock '%locked-ioblock-read-u16-byte) + (t '%ioblock-read-u16-byte))) + ((= subtag target::subtag-s16-vector) + (setf (ioblock-read-byte-when-locked-function ioblock) + '%ioblock-read-s16-byte) + (case sharing + (:private '%private-ioblock-read-s16-byte) + (:lock '%locked-ioblock-read-s16-byte) + (t '%ioblock-read-s16-byte))) + ((= subtag target::subtag-u32-vector) + (setf (ioblock-read-byte-when-locked-function ioblock) + '%ioblock-read-u32-byte) + (case sharing + (:private '%private-ioblock-read-u32-byte) + (:lock '%locked-ioblock-read-u32-byte) + (t '%ioblock-read-u32-byte))) + ((= subtag target::subtag-s32-vector) + (setf (ioblock-read-byte-when-locked-function ioblock) + '%ioblock-read-s32-byte) + (case sharing + (:private '%private-ioblock-read-s32-byte) + (:lock '%locked-ioblock-read-s32-byte) + (t '%ioblock-read-s32-byte))) + #+64-bit-target + ((= subtag target::subtag-u64-vector) + (setf (ioblock-read-byte-when-locked-function ioblock) + '%ioblock-read-u64-byte) + (case sharing + (:private '%private-ioblock-read-u64-byte) + (:lock '%locked-ioblock-read-u64-byte) + (t '%ioblock-read-u64-byte))) + #+64-bit-target + ((= subtag target::subtag-s64-vector) + (setf (ioblock-read-byte-when-locked-function ioblock) + '%ioblock-read-s64-byte) + (case sharing + (:private '%private-ioblock-read-s64-byte) + (:lock '%locked-ioblock-read-s64-byte) + (t '%ioblock-read-s64-byte))) + ;; Not sure what this means, currently. + (t + (setf (ioblock-read-byte-when-locked-function ioblock) + '%general-ioblock-read-byte) + '%general-ioblock-read-byte)))))) + +(defun install-ioblock-input-line-termination (ioblock line-termination) + (when line-termination + (let* ((sharing (ioblock-sharing ioblock))) + (setf (ioblock-read-char-without-translation-when-locked-function ioblock) + (ioblock-read-char-when-locked-function ioblock) + (ioblock-character-read-vector-function ioblock) + '%ioblock-encoded-character-read-vector + (ioblock-read-line-function ioblock) '%ioblock-encoded-read-line) + (ecase line-termination + (:cr (setf (ioblock-read-char-when-locked-function ioblock) + '%ioblock-read-char-translating-cr-to-newline + (ioblock-read-char-function ioblock) + (case sharing + (:private + '%private-ioblock-read-char-translating-cr-to-newline) + (:lock + '%locked-ioblock-read-char-translating-cr-to-newline) + (t '%ioblock-read-char-translating-cr-to-newline)))) + (:crlf (setf (ioblock-read-char-when-locked-function ioblock) + '%ioblock-read-char-translating-crlf-to-newline + (ioblock-read-char-function ioblock) + (case sharing + (:private + '%private-ioblock-read-char-translating-crlf-to-newline) + (:lock + '%locked-ioblock-read-char-translating-crlf-to-newline) + (t '%ioblock-read-char-translating-crlf-to-newline)))) + (:unicode (setf (ioblock-read-char-when-locked-function ioblock) + '%ioblock-read-char-translating-line-separator-to-newline + (ioblock-read-char-function ioblock) + (case sharing + (:private + '%private-ioblock-read-char-translating-line-separator-to-newline) + (:lock + '%locked-ioblock-read-char-translating-line-separator-to-newline) + (t '%ioblock-read-char-translating-line-separator-to-newline))))) + (setf (ioblock-line-termination ioblock) line-termination)))) + +(defun setup-ioblock-output (ioblock character-p element-type sharing encoding line-termination) + (or (ioblock-sharing ioblock) + (setf (ioblock-sharing ioblock) sharing)) + (when character-p + (setf (ioblock-encode-literal-char-code-limit ioblock) + (if encoding + (character-encoding-encode-literal-char-code-limit encoding) + 256)) + (if encoding + (let* ((unit-size (character-encoding-code-unit-size encoding))) + (setf (ioblock-encode-output-function ioblock) + (character-encoding-stream-encode-function encoding)) + (setf (ioblock-write-char-function ioblock) + (ecase unit-size + (8 + (setf (ioblock-write-char-when-locked-function ioblock) + '%ioblock-write-u8-encoded-char) + (case sharing + (:private '%private-ioblock-write-u8-encoded-char) + (:lock '%locked-ioblock-write-u8-encoded-char) + (t '%ioblock-write-u8-encoded-char))) + (16 + (if (character-encoding-native-endianness encoding) + (progn + (setf (ioblock-write-char-when-locked-function ioblock) + '%ioblock-write-u16-encoded-char) + (case sharing + (:private '%private-ioblock-write-u16-encoded-char) + (:lock '%locked-ioblock-write-u16-encoded-char) + (t '%ioblock-write-u16-encoded-char))) + (progn + (setf (ioblock-write-char-when-locked-function ioblock) + '%ioblock-write-swapped-u16-encoded-char) + (case sharing + (:private '%private-ioblock-write-swapped-u16-encoded-char) + (:lock '%locked-ioblock-write-swapped-u16-encoded-char) + (t '%ioblock-write-swapped-u16-encoded-char))))) + (32 + (if (character-encoding-native-endianness encoding) + (progn + (setf (ioblock-write-char-when-locked-function ioblock) + #'%ioblock-write-u32-encoded-char) + (case sharing + (:private #'%private-ioblock-write-u32-encoded-char) + (:lock #'%locked-ioblock-write-u32-encoded-char) + (t #'%ioblock-write-u32-encoded-char))) + (progn + (setf (ioblock-write-char-when-locked-function ioblock) + #'%ioblock-write-swapped-u32-encoded-char) + (case sharing + (:private #'%private-ioblock-write-swapped-u32-encoded-char) + (:lock #'%locked-ioblock-write-swapped-u32-encoded-char) + (t #'%ioblock-write-swapped-u32-encoded-char))))))) + (setf (ioblock-write-simple-string-function ioblock) + (ecase unit-size + (8 '%ioblock-write-u8-encoded-simple-string) + (16 + (if (character-encoding-native-endianness encoding) + '%ioblock-write-u16-encoded-simple-string + '%ioblock-write-swapped-u16-encoded-simple-string)) + (32 + (if (character-encoding-native-endianness encoding) + #'%ioblock-write-u32-encoded-simple-string + #'%ioblock-write-swapped-u32-encoded-simple-string)))) + (when (character-encoding-use-byte-order-mark encoding) + (setf (ioblock-pending-byte-order-mark ioblock) t))) + (progn + (setf (ioblock-write-simple-string-function ioblock) + '%ioblock-unencoded-write-simple-string) + (setf (ioblock-write-char-when-locked-function ioblock) + '%ioblock-write-char) + (setf (ioblock-write-char-function ioblock) + (case sharing + (:private '%private-ioblock-write-char) + (:lock '%locked-ioblock-write-char) + (t '%ioblock-write-char))))) + (when line-termination + (install-ioblock-output-line-termination ioblock line-termination))) + (unless (or (eq element-type 'character) + (subtypep element-type 'character)) + (let* ((subtag (element-type-subtype element-type))) + (declare (type (unsigned-byte 8) subtag)) + (setf (ioblock-write-byte-function ioblock) + (cond ((= subtag target::subtag-u8-vector) + (progn + (setf (ioblock-write-byte-when-locked-function ioblock) + '%ioblock-write-u8-byte) + (case sharing + (:private '%private-ioblock-write-u8-byte) + (:lock '%locked-ioblock-write-u8-byte) + (t '%ioblock-write-u8-byte)))) + ((= subtag target::subtag-s8-vector) + (setf (ioblock-write-byte-when-locked-function ioblock) + '%ioblock-write-s8-byte) + (case sharing + (:private '%private-ioblock-write-s8-byte) + (:lock '%locked-ioblock-write-s8-byte) + (t '%ioblock-write-s8-byte))) + ((= subtag target::subtag-u16-vector) + (setf (ioblock-write-byte-when-locked-function ioblock) + '%ioblock-write-u16-byte) + (case sharing + (:private '%private-ioblock-write-u16-byte) + (:lock '%locked-ioblock-write-u16-byte) + (t '%ioblock-write-u16-byte))) + ((= subtag target::subtag-s16-vector) + (setf (ioblock-write-byte-when-locked-function ioblock) + '%ioblock-write-s16-byte) + (case sharing + (:private '%private-ioblock-write-s16-byte) + (:lock '%locked-ioblock-write-s16-byte) + (t '%ioblock-write-s16-byte))) + ((= subtag target::subtag-u32-vector) + (setf (ioblock-write-byte-when-locked-function ioblock) + '%ioblock-write-u32-byte) + (case sharing + (:private '%private-ioblock-write-u32-byte) + (:lock '%locked-ioblock-write-u32-byte) + (t '%ioblock-write-u32-byte))) + ((= subtag target::subtag-s32-vector) + (setf (ioblock-write-byte-when-locked-function ioblock) + '%ioblock-write-s32-byte) + (case sharing + (:private '%private-ioblock-write-s32-byte) + (:lock '%locked-ioblock-write-s32-byte) + (t '%ioblock-write-s32-byte))) + #+64-bit-target + ((= subtag target::subtag-u64-vector) + (setf (ioblock-write-byte-when-locked-function ioblock) + '%ioblock-write-u64-byte) + (case sharing + (:private '%private-ioblock-write-u64-byte) + (:lock '%locked-ioblock-write-u64-byte) + (t '%ioblock-write-u64-byte))) + #+64-bit-target + ((= subtag target::subtag-s64-vector) + (setf (ioblock-write-byte-when-locked-function ioblock) + '%ioblock-write-u64-byte) + (case sharing + (:private '%private-ioblock-write-s64-byte) + (:lock '%locked-ioblock-write-s64-byte) + (t '%ioblock-write-s64-byte))) + (t + (setf (ioblock-write-byte-when-locked-function ioblock) + '%general-ioblock-write-byte) + '%general-ioblock-write-byte)))))) + +(defun install-ioblock-output-line-termination (ioblock line-termination) + (let* ((sharing (ioblock-sharing ioblock))) + (when line-termination + (setf (ioblock-write-char-without-translation-when-locked-function ioblock) + (ioblock-write-char-when-locked-function ioblock) + (ioblock-write-simple-string-function ioblock) + '%ioblock-write-simple-string-with-newline-translation) + (ecase line-termination + (:cr (setf (ioblock-write-char-when-locked-function ioblock) + '%ioblock-write-char-translating-newline-to-cr + (ioblock-read-char-function ioblock) + (case sharing + (:private + '%private-ioblock-write-char-translating-newline-to-cr) + (:lock + '%locked-ioblock-write-char-translating-newline-to-cr) + (t '%ioblock-write-char-translating-newline-to-cr)))) + (:crlf (setf (ioblock-write-char-when-locked-function ioblock) + '%ioblock-write-char-translating-newline-to-crlf + (ioblock-write-char-function ioblock) + (case sharing + (:private + '%private-ioblock-write-char-translating-newline-to-crlf) + (:lock + '%locked-ioblock-write-char-translating-newline-to-crlf) + (t '%ioblock-write-char-translating-newline-to-crlf)))) + (:unicode (setf (ioblock-write-char-when-locked-function ioblock) + '%ioblock-write-char-translating-newline-to-line-separator + (ioblock-write-char-function ioblock) + (case sharing + (:private + '%private-ioblock-write-char-translating-newline-to-line-separator) + (:lock + '%locked-ioblock-write-char-translating-newline-to-line-separator) + (t '%ioblock-write-char-translating-newline-to-line-separator))))) + (setf (ioblock-line-termination ioblock) line-termination)))) + + +(defun ensure-reasonable-element-type (element-type) + (let* ((upgraded (upgraded-array-element-type element-type))) + (if (eq upgraded 'bit) + '(unsigned-byte 8) + (if (eq upgraded 'fixnum) + #+64-bit-target '(signed-byte 64) #+32-bit-target '(signed-byte 32) + (if (eq upgraded t) + (error "Stream element-type ~s can't be reasonably supported." element-type) + upgraded))))) + +(defun init-stream-ioblock (stream + &key + insize ; integer to allocate inbuf here, nil + ; otherwise + outsize ; integer to allocate outbuf here, nil + ; otherwise + share-buffers-p ; true if input and output + ; share a buffer + element-type + device + advance-function + listen-function + eofp-function + force-output-function + close-function + element-shift + interactive + (sharing :private) + character-p + encoding + line-termination + input-timeout + output-timeout + deadline + &allow-other-keys) + (declare (ignorable element-shift)) + (setq line-termination (cdr (assoc line-termination *canonical-line-termination-conventions*))) + (when encoding + (unless (typep encoding 'character-encoding) + (setq encoding (get-character-encoding encoding))) + (if (eq encoding (get-character-encoding nil)) + (setq encoding nil))) + (when sharing + (unless (or (eq sharing :private) + (eq sharing :lock)) + (if (eq sharing :external) + (setq sharing nil) + (report-bad-arg sharing '(member nil :private :lock :external))))) + (let* ((ioblock (or (let* ((ioblock (stream-ioblock stream nil))) + (when ioblock + (setf (ioblock-stream ioblock) stream) + ioblock)) + (stream-create-ioblock stream)))) + (when (eq sharing :private) + (setf (ioblock-owner ioblock) 0)) + (setf (ioblock-encoding ioblock) encoding) + (when insize + (unless (ioblock-inbuf ioblock) + (multiple-value-bind (buffer ptr in-size-in-octets) + (make-heap-ivector insize + (if character-p + '(unsigned-byte 8) + (setq element-type + (ensure-reasonable-element-type element-type)))) + (setf (ioblock-inbuf ioblock) + (make-io-buffer :buffer buffer + :bufptr ptr + :size in-size-in-octets + :limit insize)) + (when (eq sharing :lock) + (setf (ioblock-inbuf-lock ioblock) (make-lock))) + (setf (ioblock-line-termination ioblock) line-termination) + (setup-ioblock-input ioblock character-p element-type sharing encoding line-termination) + (setf (ioblock-element-shift ioblock) (max 0 (ceiling (log (/ in-size-in-octets insize) 2)))) + ))) + (if share-buffers-p + (if insize + (progn (setf (ioblock-outbuf ioblock) + (ioblock-inbuf ioblock)) + (setf (ioblock-outbuf-lock ioblock) + (ioblock-inbuf-lock ioblock))) + (error "Can't share buffers unless insize is non-zero and non-null")) + (when outsize + (unless (ioblock-outbuf ioblock) + (multiple-value-bind (buffer ptr out-size-in-octets) + (make-heap-ivector outsize + (if character-p + '(unsigned-byte 8) + (setq element-type (ensure-reasonable-element-type element-type)))) + (setf (ioblock-outbuf ioblock) + (make-io-buffer :buffer buffer + :bufptr ptr + :count 0 + :limit outsize + :size out-size-in-octets)) + (when (eq sharing :lock) + (setf (ioblock-outbuf-lock ioblock) (make-lock))) + (setf (ioblock-element-shift ioblock) (max 0 (ceiling (log (/ out-size-in-octets outsize) 2)))) + )))) + (when (or share-buffers-p outsize) + (setup-ioblock-output ioblock character-p element-type sharing encoding line-termination)) + (when element-type + (setf (ioblock-element-type ioblock) (if character-p 'character element-type))) +; (when element-shift +; (setf (ioblock-element-shift ioblock) element-shift)) + (when device + (setf (ioblock-device ioblock) device)) + (when advance-function + (setf (ioblock-advance-function ioblock) advance-function)) + (when listen-function + (setf (ioblock-listen-function ioblock) listen-function)) + (when eofp-function + (setf (ioblock-eofp-function ioblock) eofp-function)) + (when force-output-function + (setf (ioblock-force-output-function ioblock) force-output-function)) + (when close-function + (setf (ioblock-close-function ioblock) close-function)) + (when interactive + (setf (ioblock-interactive ioblock) interactive)) + (setf (stream-ioblock stream) ioblock) + (when encoding + (setf (ioblock-native-byte-order ioblock) + (character-encoding-native-endianness encoding))) + (let* ((bom-info (and insize encoding (character-encoding-use-byte-order-mark encoding)))) + (when bom-info + (ioblock-check-input-bom ioblock bom-info sharing))) + (setf (ioblock-input-timeout ioblock) input-timeout) + (setf (ioblock-output-timeout ioblock) output-timeout) + (setf (ioblock-deadline ioblock) deadline) + ioblock)) + +;;; If there's a byte-order-mark (or a reversed byte-order-mark) at +;;; the beginning of the input stream, deal with it. If there's any +;;; input present, make sure that we don't write a BOM on output. If +;;; this is a little-endian machine, input data was present, and there +;;; was no BOM in that data, make things big-endian. If there's a +;;; leading BOM or swapped BOM, eat it (consume it so that it doesn't +;;; ordinarily appear as input.) +;;; +(defun ioblock-check-input-bom (ioblock swapped-encoding-name sharing) + (let* ((n (%ioblock-advance ioblock nil))) ; try to read, don't block + (when n + (setf (ioblock-pending-byte-order-mark ioblock) nil) + (let* ((inbuf (ioblock-inbuf ioblock)) + (unit-size (character-encoding-code-unit-size (ioblock-encoding ioblock))) + (min (ash unit-size -3)) + (buf (io-buffer-buffer inbuf)) + (swapped-encoding + (and + (>= n min) + (case (case unit-size + (16 (%native-u8-ref-u16 buf 0)) + (32 (%native-u8-ref-u32 buf 0))) + (#.byte-order-mark-char-code + (setf (io-buffer-idx inbuf) min) + nil) + (#.swapped-byte-order-mark-char-code + (setf (io-buffer-idx inbuf) min) + t) + (t #+little-endian-target t)) + (lookup-character-encoding swapped-encoding-name)))) + (when swapped-encoding + (let* ((output-p (not (null (ioblock-outbuf ioblock))))) + (setf (ioblock-native-byte-order ioblock) + (character-encoding-native-endianness swapped-encoding)) + (ecase unit-size + (16 + (setf (ioblock-read-char-when-locked-function ioblock) + '%ioblock-read-swapped-u16-encoded-char) + (case sharing + (:private '%private-ioblock-read-swapped-u16-encoded-char) + (:lock '%locked-ioblock-read-swapped-u16-encoded-char) + (t '%ioblock-read-swapped-u16-encoded-char))) + (32 + (setf (ioblock-read-char-when-locked-function ioblock) + '%ioblock-read-swapped-u32-encoded-char) + (case sharing + (:private '%private-ioblock-read-swapped-u32-encoded-char) + (:lock '%locked-ioblock-read-swapped-u32-encoded-char) + (t '%ioblock-read-swapped-u16-encoded-char)))) + (when output-p + (ecase unit-size + (16 + (setf (ioblock-write-char-when-locked-function ioblock) + '%ioblock-write-swapped-u16-encoded-char) + (case sharing + (:private '%private-ioblock-write-swapped-u16-encoded-char) + (:lock '%locked-ioblock-write-swapped-u16-encoded-char) + (t '%ioblock-write-swapped-u16-encoded-char)) + (setf (ioblock-write-simple-string-function ioblock) + '%ioblock-write-swapped-u16-encoded-simple-string)) + (32 + (setf (ioblock-write-char-when-locked-function ioblock) + '%ioblock-write-swapped-u32-encoded-char) + (case sharing + (:private '%private-ioblock-write-swapped-u32-encoded-char) + (:lock '%locked-ioblock-write-swapped-u32-encoded-char) + (t '%ioblock-write-swapped-u32-encoded-char)) + (setf (ioblock-write-simple-string-function ioblock) + '%ioblock-write-swapped-u32-encoded-simple-string)))))))))) + + + +;;; We can't define a MAKE-INSTANCE method on STRUCTURE-CLASS subclasses +;;; in MCL; of course, calling the structure-class's constructor does +;;; much the same thing (but note that MCL only keeps track of the +;;; default, automatically generated constructor.) +;;; (As fascinating as that may be, that has nothing to do with any +;;; nearby code, though it may have once been relevant.) +(defun make-ioblock-stream (class + &rest initargs + &key + &allow-other-keys) + (declare (dynamic-extent initargs)) + (let* ((s + (if (subtypep class 'basic-stream) + (apply #'make-basic-stream-instance class :allow-other-keys t initargs) + (apply #'make-instance class :allow-other-keys t initargs)))) + (apply #'init-stream-ioblock s initargs) + s)) + + + + + +(defmethod select-stream-class ((s symbol) in-p out-p char-p) + (select-stream-class (class-prototype (find-class s)) in-p out-p char-p)) + +(defmethod select-stream-class ((s structure-class) in-p out-p char-p) + (select-stream-class (class-prototype s) in-p out-p char-p)) + +(defmethod select-stream-class ((s standard-class) in-p out-p char-p) + (select-stream-class (class-prototype s) in-p out-p char-p)) + + +(defparameter *canonical-line-termination-conventions* + '((:unix . nil) + (:macos . :cr) + (:cr . :cr) + (:crlf . :crlf) + (:cp/m . :crlf) + (:msdos . :crlf) + (:dos . :crlf) + (:windows . :crlf) + (:inferred . nil) + (:unicode . :unicode))) + + +(defun optimal-buffer-size (fd element-type) + #+windows-target (declare (ignore fd)) + (let* (#-windows-target (nominal (or (nth-value 6 (%fstat fd)) *elements-per-buffer*)) + (octets #+windows-target #$BUFSIZ + #-windows-target + (case (%unix-fd-kind fd) + (:pipe (#_fpathconf fd #$_PC_PIPE_BUF)) + (:socket + #+linux-target nominal + #-linux-target + (int-getsockopt fd #$SOL_SOCKET + #+solaris-target #$SO_SNDBUF + #-solaris-target #$SO_SNDLOWAT)) + ((:character-special :tty) (#_fpathconf fd #$_PC_MAX_INPUT)) + (t nominal)))) + (case (subtag-bytes (element-type-subtype element-type) 1) + (1 octets) + (2 (ash octets -1)) + (4 (ash octets -2)) + (8 (ash octets -3))))) + + + + + +(defun milliseconds-until-deadline (deadline ioblock) + (let* ((now (get-internal-real-time))) + (if (> now deadline) + (error 'communication-deadline-expired :stream (ioblock-stream ioblock)) + (values (round (- deadline now) (/ internal-time-units-per-second 1000)))))) + + +;;; Note that we can get "bivalent" streams by specifiying :character-p t +;;; with a reasonable element-type (e.g. (UNSIGNED-BYTE 8)) +(defun make-fd-stream (fd &key + (direction :input) + (interactive t) + (element-type 'character) + (class 'fd-stream) + (sharing :private) + (character-p (or (eq element-type 'character) + (subtypep element-type 'character))) + (basic nil) + encoding + line-termination + auto-close + input-timeout + output-timeout + deadline) + (let* ((elements-per-buffer (optimal-buffer-size fd element-type))) + (when line-termination + (setq line-termination + (cdr (assoc line-termination *canonical-line-termination-conventions*)))) + (when basic + (setq class (map-to-basic-stream-class-name class)) + (setq basic (subtypep (find-class class) 'basic-stream))) + (let* ((in-p (member direction '(:io :input))) + (out-p (member direction '(:io :output))) + (class-name (select-stream-class class in-p out-p character-p)) + (class (find-class class-name)) + (stream + (make-ioblock-stream class + :insize (if in-p elements-per-buffer) + :outsize (if out-p elements-per-buffer) + :device fd + :interactive interactive + :element-type element-type + :advance-function (if in-p + (select-stream-advance-function class direction)) + :listen-function (if in-p 'fd-stream-listen) + :eofp-function (if in-p 'fd-stream-eofp) + :force-output-function (if out-p + (select-stream-force-output-function class direction)) + :close-function 'fd-stream-close + :sharing sharing + :character-p character-p + :encoding encoding + :line-termination line-termination + :input-timeout input-timeout + :output-timeout output-timeout + :deadline deadline))) + (if auto-close + (terminate-when-unreachable stream + (lambda (stream) + (close-for-termination stream t)))) + stream))) + + +;;; Fundamental streams. + +(defclass fundamental-stream (stream) + ()) + +(defclass fundamental-input-stream (fundamental-stream input-stream) + ((shared-resource :initform nil :accessor input-stream-shared-resource))) + +(defclass fundamental-output-stream (fundamental-stream output-stream) + ()) + +(defmethod input-stream-p ((x t)) + (report-bad-arg x 'stream)) + +(defmethod input-stream-p ((s input-stream)) + t) + +(defmethod output-stream-p ((x t)) + (report-bad-arg x 'stream)) + +(defmethod output-stream-p ((s input-stream)) + (typep s 'output-stream)) + +(defmethod output-stream-p ((s output-stream)) + t) + +(defmethod input-stream-p ((s output-stream)) + (typep s 'input-stream)) + +(defclass binary-stream (stream) + ()) + +(defclass character-stream (stream) + ()) + +(defmethod stream-external-format ((s character-stream)) + (make-external-format :character-encoding #+big-endian-target :utf-32be #+little-endian-target :utf-32le :line-termination :unix)) + + +(defmethod (setf stream-external-format) (new (s character-stream)) + (check-type new external-format) + (stream-external-format s)) + + +(defclass fundamental-character-stream (fundamental-stream character-stream) + ()) + +(defmethod stream-element-type ((s fundamental-character-stream)) + 'character) + +(defclass fundamental-binary-stream (fundamental-stream binary-stream) + ()) + +(defclass character-input-stream (input-stream character-stream) + ()) + +(defclass fundamental-character-input-stream (fundamental-input-stream + fundamental-character-stream + character-input-stream) + ()) + +(defmethod stream-read-char-no-hang ((s fundamental-character-input-stream)) + (stream-read-char s)) + +(defmethod stream-peek-char ((s fundamental-character-input-stream)) + (let* ((ch (stream-read-char s))) + (unless (eq ch :eof) + (stream-unread-char s ch)) + ch)) + +(defmethod stream-listen ((s fundamental-character-input-stream)) + (let* ((ch (stream-read-char-no-hang s))) + (when (and ch (not (eq ch :eof))) + (stream-unread-char s ch)) + ch)) + +(defmethod stream-clear-input ((s fundamental-character-input-stream)) + ) + +(defmethod stream-read-line ((s character-input-stream)) + (generic-read-line s)) + +(defclass character-output-stream (output-stream character-stream) + ()) + +(defclass fundamental-character-output-stream (fundamental-output-stream + fundamental-character-stream + character-output-stream) + ()) + +(defclass binary-input-stream (input-stream binary-stream) + ()) + +(defclass fundamental-binary-input-stream (fundamental-input-stream + fundamental-binary-stream + binary-input-stream) + ()) + +(defclass binary-output-stream (output-stream binary-stream) + ()) + +(defclass fundamental-binary-output-stream (fundamental-output-stream + fundamental-binary-stream + binary-output-stream) + ()) + + + +(defmethod stream-read-byte ((s t)) + (report-bad-arg s '(and input-stream binary-stream))) + +(defmethod stream-write-byte ((s t) b) + (declare (ignore b)) + (report-bad-arg s '(and output-stream binary-stream))) + +(defmethod stream-length ((s stream) &optional new) + (declare (ignore new))) + +(defmethod stream-start-line-p ((s character-output-stream)) + (eql 0 (stream-line-column s))) + +(defmethod stream-terpri ((s character-output-stream)) + (stream-write-char s #\Newline)) + +(defmethod stream-fresh-line ((s character-output-stream)) + (unless (stream-start-line-p s) + (stream-terpri s) + t)) + +;;; The bad news is that this doesn't even bother to do the obvious +;;; (calling STREAM-WRITE-STRING with a longish string of spaces.) +;;; The good news is that this method is pretty useless to (format "~T" ...) +;;; anyhow. +(defmethod stream-advance-to-column ((s fundamental-character-output-stream) + col) + (generic-advance-to-column s col)) + +(defmethod stream-write-string ((stream fundamental-character-output-stream) string &optional (start 0) end) + (generic-stream-write-string stream string start end)) + + +;;; The read-/write-vector methods could be specialized for stream classes +;;; that expose the underlying buffering mechanism. +;;; They can assume that the 'vector' argument is a simple one-dimensional +;;; array and that the 'start' and 'end' arguments are sane. + +(defmethod stream-write-vector ((stream character-output-stream) + vector start end) + (declare (fixnum start end)) + (do* ((i start (1+ i))) + ((= i end)) + (declare (fixnum i)) + (write-char (uvref vector i) stream))) + +(defmethod stream-write-vector ((stream binary-output-stream) + vector start end) + (declare (fixnum start end)) + (do* ((i start (1+ i))) + ((= i end)) + (declare (fixnum i)) + (write-byte (uvref vector i) stream))) + +(defmethod stream-read-vector ((stream character-input-stream) + vector start end) + (generic-character-read-vector stream vector start end)) + + +(defmethod stream-read-vector ((stream binary-input-stream) + vector start end) + (declare (fixnum start end)) + (do* ((i start (1+ i))) + ((= i end) end) + (declare (fixnum i)) + (let* ((b (read-byte stream nil :eof))) + (if (eq b :eof) + (return i) + (setf (uvref vector i) b))))) + + + + + +;;; File streams, in the abstract. + +(defclass file-stream (stream) + ()) + +(defmethod stream-domain ((s file-stream)) + :file) + + + + +;;; "Basic" (non-extensible) streams. + + +(declaim (inline basic-stream-p)) + +(defun basic-stream-p (x) + (= (the fixnum (typecode x)) target::subtag-basic-stream)) + +(setf (type-predicate 'basic-stream) 'basic-stream-p) + +(make-built-in-class 'basic-stream 'stream) +(make-built-in-class 'basic-file-stream 'basic-stream 'file-stream) +(make-built-in-class 'basic-character-stream 'basic-stream 'character-stream) +(make-built-in-class 'basic-binary-stream 'basic-stream 'binary-stream) + +(make-built-in-class 'basic-input-stream 'basic-stream 'input-stream) +(make-built-in-class 'basic-output-stream 'basic-stream 'output-stream) +(make-built-in-class 'basic-io-stream 'basic-input-stream 'basic-output-stream) +(make-built-in-class 'basic-character-input-stream 'basic-input-stream 'basic-character-stream 'character-input-stream) +(make-built-in-class 'basic-character-output-stream 'basic-output-stream 'basic-character-stream 'character-output-stream) +(make-built-in-class 'basic-character-io-stream 'basic-character-input-stream 'basic-character-output-stream) +(make-built-in-class 'basic-binary-input-stream 'basic-input-stream 'basic-binary-stream 'binary-input-stream) +(make-built-in-class 'basic-binary-output-stream 'basic-output-stream 'basic-binary-stream 'binary-output-stream) +(make-built-in-class 'basic-binary-io-stream 'basic-binary-input-stream 'basic-binary-output-stream) + + +(defun %ioblock-external-format (ioblock) + (let* ((encoding (or (ioblock-encoding ioblock) + (get-character-encoding nil))) + (line-termination (or (ioblock-line-termination ioblock) + :unix))) + (make-external-format :character-encoding (character-encoding-name encoding) + :line-termination line-termination))) + +(defmethod input-stream-shared-resource ((s basic-input-stream)) + (getf (basic-stream.info s) :shared-resource)) + +(defmethod (setf input-stream-shared-resource) (new (s basic-input-stream)) + (setf (getf (basic-stream.info s) :shared-resource) new)) + +(defmethod print-object ((s basic-stream) out) + (print-unreadable-object (s out :type t :identity t) + (let* ((ioblock (basic-stream.state s)) + (fd (and ioblock (ioblock-device ioblock))) + (encoding (and ioblock (encoding-name (ioblock-encoding ioblock))))) + (if fd + (format out "~a (~a/~d)" encoding (%unix-fd-kind fd) fd) + (format out "~s" :closed))))) + +(defmethod select-stream-class ((s (eql 'basic-stream)) in-p out-p char-p) + (if char-p + (if in-p + (if out-p + 'basic-character-io-stream + 'basic-character-input-stream) + 'basic-character-output-stream) + (if in-p + (if out-p + 'basic-binary-io-stream + 'basic-binary-input-stream) + 'basic-binary-output-stream))) + + +(defmethod map-to-basic-stream-class-name (name) + name) + +(defmethod map-to-basic-stream-class-name ((name (eql 'fd-stream))) + 'basic-stream) + +(defun allocate-basic-stream (class) + (if (subtypep class 'basic-file-stream) + (gvector :basic-stream (%class-own-wrapper class) 0 nil nil nil nil nil) + (gvector :basic-stream (%class-own-wrapper class) 0 nil nil))) + + +(defmethod initialize-basic-stream ((s basic-stream) &key &allow-other-keys) + ) + +(defmethod initialize-basic-stream :after ((s basic-input-stream) &key &allow-other-keys) + (setf (basic-stream.flags s) + (logior (ash 1 basic-stream-flag.open-input) (basic-stream.flags s)))) + +(defmethod initialize-basic-stream :after ((s basic-output-stream) &key &allow-other-keys) + (setf (basic-stream.flags s) + (logior (ash 1 basic-stream-flag.open-output) (basic-stream.flags s)))) + +(defmethod initialize-basic-stream :after ((s basic-binary-stream) &key &allow-other-keys) + (setf (basic-stream.flags s) + (logior (ash 1 basic-stream-flag.open-binary) (basic-stream.flags s)))) + +(defmethod initialize-basic-stream :after ((s basic-character-stream) &key &allow-other-keys) + (setf (basic-stream.flags s) + (logior (ash 1 basic-stream-flag.open-character) (basic-stream.flags s)))) + +(defun make-basic-stream-instance (class &rest initargs) + (let* ((s (allocate-basic-stream class))) + (apply #'initialize-basic-stream s initargs) + s)) + + + +(defmethod (setf stream-ioblock) (ioblock (s basic-stream)) + (setf (basic-stream.state s) ioblock)) + +(defmethod stream-create-ioblock ((stream basic-stream) &rest args &key) + (declare (dynamic-extent args)) + (apply #'make-ioblock :stream stream args)) + + +(defmethod stream-write-list ((stream fundamental-character-output-stream) + list count) + (declare (fixnum count)) + (dotimes (i count) + (stream-write-char stream (pop list)))) + +(defmethod stream-write-list ((stream basic-character-output-stream) + list count) + (declare (fixnum count)) + (dotimes (i count) + (stream-write-char stream (pop list)))) + +(defmethod stream-read-list ((stream character-input-stream) + list count) + (generic-character-read-list stream list count)) + + +(defmethod stream-write-list ((stream fundamental-binary-output-stream) + list count) + (declare (fixnum count)) + (dotimes (i count) + (let* ((element (pop list))) + (if (typep element 'character) + (write-char element stream) + (write-byte element stream))))) + +(defmethod stream-write-list ((stream basic-binary-output-stream) + list count) + (declare (fixnum count)) + (dotimes (i count) + (let* ((element (pop list))) + (if (typep element 'character) + (write-char element stream) + (write-byte element stream))))) + +(defmethod stream-read-list ((stream binary-input-stream) + list count) + (declare (fixnum count)) + (do* ((tail list (cdr tail)) + (i 0 (1+ i))) + ((= i count) count) + (declare (fixnum i)) + (let* ((b (read-byte stream nil :eof))) + (if (eq b :eof) + (return i) + (rplaca tail b))))) + + + +(defun stream-is-closed (s) + (error "~s is closed" s)) + +(defmethod stream-read-char ((s basic-character-input-stream)) + (let* ((ioblock (basic-stream-ioblock s))) + (funcall (ioblock-read-char-function ioblock) ioblock))) + + +(defmethod stream-read-char-no-hang ((stream basic-character-input-stream)) + (let* ((ioblock (basic-stream-ioblock stream))) + (with-ioblock-input-locked (ioblock) + (values + (%ioblock-tyi-no-hang ioblock))))) + +(defmethod stream-peek-char ((stream basic-character-input-stream)) + (let* ((ioblock (basic-stream-ioblock stream))) + (with-ioblock-input-locked (ioblock) + (values + (funcall (ioblock-peek-char-function ioblock) ioblock))))) + +(defmethod stream-clear-input ((stream basic-character-input-stream)) + (let* ((ioblock (basic-stream-ioblock stream))) + (with-ioblock-input-locked (ioblock) + (values + (%ioblock-clear-input ioblock))))) + +(defmethod stream-unread-char ((s basic-character-input-stream) char) + (let* ((ioblock (basic-stream-ioblock s))) + (with-ioblock-input-locked (ioblock) + (values + (funcall (ioblock-unread-char-function ioblock) ioblock char))))) + +(defmethod stream-read-ivector ((s basic-binary-input-stream) + iv start nb) + (let* ((ioblock (basic-stream-ioblock s))) + (with-ioblock-input-locked (ioblock) + (values + (%ioblock-binary-in-ivect ioblock iv start nb))))) + +(defmethod stream-read-vector ((stream basic-character-input-stream) + vector start end) + (declare (fixnum start end)) + (if (not (typep vector 'simple-base-string)) + (generic-character-read-vector stream vector start end) + (let* ((ioblock (basic-stream-ioblock stream))) + (with-ioblock-input-locked (ioblock) + (values + (funcall (ioblock-character-read-vector-function ioblock) + ioblock vector start end)))))) + +(defmethod stream-read-line ((stream basic-character-input-stream)) + (let* ((ioblock (basic-stream-ioblock stream))) + (with-ioblock-input-locked (ioblock) + (funcall (ioblock-read-line-function ioblock) ioblock)))) + + +;;; Synonym streams. + +(defclass synonym-stream (fundamental-stream) + ((symbol :initarg :symbol :reader synonym-stream-symbol))) + +(defmethod print-object ((s synonym-stream) out) + (print-unreadable-object (s out :type t :identity t) + (format out "to ~s" (synonym-stream-symbol s)))) + +(macrolet ((synonym-method (name &rest args) + (let* ((stream (make-symbol "STREAM"))) + `(defmethod ,name ((,stream synonym-stream) ,@args) + (,name (symbol-value (synonym-stream-symbol ,stream)) ,@args))))) + (synonym-method stream-read-char) + (synonym-method stream-read-byte) + (synonym-method stream-unread-char c) + (synonym-method stream-read-char-no-hang) + (synonym-method stream-peek-char) + (synonym-method stream-listen) + (synonym-method stream-eofp) + (synonym-method stream-clear-input) + (synonym-method stream-read-line) + (synonym-method stream-read-list l c) + (synonym-method stream-read-vector v start end) + (synonym-method stream-write-char c) + ;(synonym-method stream-write-string str &optional (start 0) end) + (synonym-method stream-write-byte b) + (synonym-method stream-clear-output) + (synonym-method stream-line-column) + (synonym-method stream-set-column new) + (synonym-method stream-advance-to-column new) + (synonym-method stream-start-line-p) + (synonym-method stream-fresh-line) + (synonym-method stream-terpri) + (synonym-method stream-force-output) + (synonym-method stream-finish-output) + (synonym-method stream-write-list l c) + (synonym-method stream-write-vector v start end) + (synonym-method stream-element-type) + (synonym-method input-stream-p) + (synonym-method output-stream-p) + (synonym-method interactive-stream-p) + (synonym-method stream-direction) + (synonym-method stream-device direction) + (synonym-method stream-surrounding-characters) + (synonym-method stream-input-timeout) + (synonym-method stream-output-timeout) + (synonym-method stream-deadline) + (synonym-method stream-eof-transient-p)) + +(defmethod (setf input-stream-timeout) (new (s synonym-stream)) + (setf (input-stream-timeout (symbol-value (synonym-stream-symbol s))) new)) + +(defmethod (setf output-stream-timeout) (new (s synonym-stream)) + (setf (output-stream-timeout (symbol-value (synonym-stream-symbol s))) new)) + + +(defmethod stream-write-string ((s synonym-stream) string &optional (start 0) end) + (stream-write-string (symbol-value (synonym-stream-symbol s)) string start end)) + +(defmethod stream-length ((s synonym-stream) &optional new) + (stream-length (symbol-value (synonym-stream-symbol s)) new)) + +(defmethod stream-position ((s synonym-stream) &optional new) + (stream-position (symbol-value (synonym-stream-symbol s)) new)) + +(defun make-synonym-stream (symbol) + (make-instance 'synonym-stream :symbol (require-type symbol 'symbol))) + +;;; +(defclass composite-stream-mixin () + ((open-p :initform t))) + +(defmethod close :after ((stream composite-stream-mixin) &key abort) + (declare (ignore abort)) + (with-slots (open-p) stream + (setq open-p nil))) + +(defmethod open-stream-p ((stream composite-stream-mixin)) + (slot-value stream 'open-p)) + + + +;;; Two-way streams. +(defclass two-way-stream (composite-stream-mixin fundamental-input-stream fundamental-output-stream) + ((input-stream :initarg :input-stream :accessor two-way-stream-input-stream) + (output-stream :initarg :output-stream :accessor two-way-stream-output-stream))) + +(defmethod stream-eof-transient-p ((stream two-way-stream)) + (stream-eof-transient-p (two-way-stream-input-stream stream))) + +(defmethod print-object ((s two-way-stream) out) + (print-unreadable-object (s out :type t :identity t) + (format out "input ~s, output ~s" + (two-way-stream-input-stream s) + (two-way-stream-output-stream s)))) + +(macrolet ((two-way-input-method (name &rest args) + (let* ((stream (make-symbol "STREAM"))) + `(defmethod ,name ((,stream two-way-stream) ,@args) + (,name (two-way-stream-input-stream ,stream) ,@args)))) + (two-way-output-method (name &rest args) + (let* ((stream (make-symbol "STREAM"))) + `(defmethod ,name ((,stream two-way-stream) ,@args) + (,name (two-way-stream-output-stream ,stream) ,@args))))) + (two-way-input-method stream-read-char) + (two-way-input-method stream-read-byte) + (two-way-input-method stream-unread-char c) + (two-way-input-method stream-read-char-no-hang) + (two-way-input-method stream-peek-char) + (two-way-input-method stream-listen) + (two-way-input-method stream-eofp) + (two-way-input-method stream-clear-input) + (two-way-input-method stream-read-line) + (two-way-input-method stream-read-list l c) + (two-way-input-method stream-read-vector v start end) + (two-way-input-method stream-surrounding-characters) + (two-way-input-method stream-input-timeout) + (two-way-input-method interactive-stream-p) + (two-way-output-method stream-write-char c) + (two-way-output-method stream-write-byte b) + (two-way-output-method stream-clear-output) + (two-way-output-method stream-line-column) + (two-way-output-method stream-set-column new) + (two-way-output-method stream-advance-to-column new) + (two-way-output-method stream-start-line-p) + (two-way-output-method stream-fresh-line) + (two-way-output-method stream-terpri) + (two-way-output-method stream-force-output) + (two-way-output-method stream-finish-output) + (two-way-output-method stream-write-list l c) + (two-way-output-method stream-write-vector v start end) + (two-way-output-method stream-output-timeout) + (two-way-output-method stream-deadline)) + +(defmethod (setf stream-input-timeout) (new (s two-way-stream)) + (setf (stream-input-timeout (two-way-stream-input-stream s)) new)) + +(defmethod (setf stream-output-timeout) (new (s two-way-stream)) + (setf (stream-output-timeout (two-way-stream-output-stream s)) new)) + +(defmethod (setf stream-deadline) (new (s two-way-stream)) + (setf (stream-deadline (two-way-stream-output-stream s)) new)) + +(defmethod stream-device ((s two-way-stream) direction) + (case direction + (:input (stream-device (two-way-stream-input-stream s) direction)) + (:output (stream-device (two-way-stream-output-stream s) direction)))) + +(defmethod stream-write-string ((s two-way-stream) string &optional (start 0) end) + (stream-write-string (two-way-stream-output-stream s) string start end)) + +(defmethod stream-element-type ((s two-way-stream)) + (let* ((in-type (stream-element-type (two-way-stream-input-stream s))) + (out-type (stream-element-type (two-way-stream-output-stream s)))) + (if (equal in-type out-type) + in-type + `(and ,in-type ,out-type)))) + +(defun make-two-way-stream (in out) + "Return a bidirectional stream which gets its input from INPUT-STREAM and + sends its output to OUTPUT-STREAM." + (unless (input-stream-p in) + (require-type in 'input-stream)) + (unless (output-stream-p out) + (require-type out 'output-stream)) + (make-instance 'two-way-stream :input-stream in :output-stream out)) + +;;; This is intended for use with things like *TERMINAL-IO*, where the +;;; OS echoes interactive input. Whenever we read a character from +;;; the underlying input-stream of such a stream, we need to update +;;; our notion of the underlying output-stream's STREAM-LINE-COLUMN. + +(defclass echoing-two-way-stream (two-way-stream) + ()) + +(defmethod stream-read-char ((s echoing-two-way-stream)) + (let* ((out (two-way-stream-output-stream s)) + (in (two-way-stream-input-stream s))) + (force-output out) + (let* ((ch (stream-read-char in))) + (unless (eq ch :eof) + (if (eq ch #\newline) + (stream-set-column out 0) + (let* ((cur (stream-line-column out))) + (when cur + (stream-set-column out (1+ (the fixnum cur))))))) + ch))) + +(defmethod stream-read-line ((s echoing-two-way-stream)) + (let* ((out (two-way-stream-output-stream s))) + (multiple-value-bind (string eof) + (call-next-method) + (unless eof + (stream-set-column out 0)) + (values string eof)))) + +(defun make-echoing-two-way-stream (in out) + (make-instance 'echoing-two-way-stream :input-stream in :output-stream out)) + +;;;echo streams + +(defclass echo-stream (two-way-stream) + ((did-untyi :initform nil))) + +(defmethod echo-stream-input-stream ((s echo-stream)) + (two-way-stream-input-stream s)) + +(defmethod echo-stream-output-stream ((s echo-stream)) + (two-way-stream-output-stream s)) + +(defmethod stream-read-char ((s echo-stream)) + (let* ((char (stream-read-char (echo-stream-input-stream s)))) + (unless (eq char :eof) + (if (slot-value s 'did-untyi) + (setf (slot-value s 'did-untyi) nil) + (stream-write-char (echo-stream-output-stream s) char))) + char)) + +(defmethod stream-unread-char ((s echo-stream) c) + (call-next-method s c) + (setf (slot-value s 'did-untyi) c)) + +(defmethod stream-read-char-no-hang ((s echo-stream)) + (let* ((char (stream-read-char-no-hang (echo-stream-input-stream s)))) + (unless (eq char :eof) + (if (slot-value s 'did-untyi) + (setf (slot-value s 'did-untyi) nil) + (stream-write-char (echo-stream-output-stream s) char))) + char)) + +(defmethod stream-clear-input ((s echo-stream)) + (call-next-method) + (setf (slot-value s 'did-untyi) nil)) + +(defmethod stream-read-byte ((s echo-stream)) + (let* ((byte (stream-read-byte (echo-stream-input-stream s)))) + (unless (eq byte :eof) + (stream-write-byte (echo-stream-output-stream s) byte)) + byte)) + +(defmethod stream-read-line ((s echo-stream)) + (generic-read-line s)) + +(defmethod stream-read-vector ((s echo-stream) vector start end) + (if (subtypep (stream-element-type s) 'character) + (generic-character-read-vector s vector start end) + (generic-binary-read-vector s vector start end))) + +(defun make-echo-stream (input-stream output-stream) + "Return a bidirectional stream which gets its input from INPUT-STREAM and + sends its output to OUTPUT-STREAM. In addition, all input is echoed to + the output stream." + (make-instance 'echo-stream + :input-stream input-stream + :output-stream output-stream)) + +;;;concatenated-streams + +(defclass concatenated-stream (composite-stream-mixin fundamental-input-stream) + ((streams :initarg :streams :accessor concatenated-stream-streams))) + + +(defun concatenated-stream-current-input-stream (s) + (car (concatenated-stream-streams s))) + +(defun concatenated-stream-next-input-stream (s) + (setf (concatenated-stream-streams s) + (cdr (concatenated-stream-streams s))) + (concatenated-stream-current-input-stream s)) + +(defmethod stream-element-type ((s concatenated-stream)) + (let* ((c (concatenated-stream-current-input-stream s))) + (if c + (stream-element-type c) + nil))) + + + +(defmethod stream-read-char ((s concatenated-stream)) + (do* ((c (concatenated-stream-current-input-stream s) + (concatenated-stream-next-input-stream s))) + ((null c) :eof) + (let* ((ch (stream-read-char c))) + (unless (eq ch :eof) + (return ch))))) + +(defmethod stream-read-char-no-hang ((s concatenated-stream)) + (do* ((c (concatenated-stream-current-input-stream s) + (concatenated-stream-next-input-stream s))) + ((null c) :eof) + (let* ((ch (stream-read-char-no-hang c))) + (unless (eq ch :eof) + (return ch))))) + +(defmethod stream-read-byte ((s concatenated-stream)) + (do* ((c (concatenated-stream-current-input-stream s) + (concatenated-stream-next-input-stream s))) + ((null c) :eof) + (let* ((b (stream-read-byte c))) + (unless (eq b :eof) + (return b))))) + +(defmethod stream-peek-char ((s concatenated-stream)) + (do* ((c (concatenated-stream-current-input-stream s) + (concatenated-stream-next-input-stream s))) + ((null c) :eof) + (let* ((ch (stream-peek-char c))) + (unless (eq ch :eof) + (return ch))))) + +(defmethod stream-read-line ((s concatenated-stream)) + (generic-read-line s)) + +(defmethod stream-read-list ((s concatenated-stream) list count) + (generic-character-read-list s list count)) + +(defmethod stream-read-vector ((s concatenated-stream) vector start end) + (if (subtypep (stream-element-type s) 'character) + (generic-character-read-vector s vector start end) + (generic-binary-read-vector s vector start end))) + +(defmethod stream-unread-char ((s concatenated-stream) char) + (let* ((c (concatenated-stream-current-input-stream s))) + (if c + (stream-unread-char c char)))) + +(defmethod stream-listen ((s concatenated-stream)) + (do* ((c (concatenated-stream-current-input-stream s) + (concatenated-stream-next-input-stream s))) + ((null c)) + (when (stream-listen c) + (return t)))) + +(defmethod stream-eofp ((s concatenated-stream)) + (do* ((c (concatenated-stream-current-input-stream s) + (concatenated-stream-next-input-stream s))) + ((null c) t) + (when (stream-listen c) + (return nil)))) + +(defmethod stream-clear-input ((s concatenated-stream)) + (let* ((c (concatenated-stream-current-input-stream s))) + (when c (stream-clear-input c)))) + + +(defun make-concatenated-stream (&rest streams) + "Return a stream which takes its input from each of the streams in turn, + going on to the next at EOF." + (dolist (s streams (make-instance 'concatenated-stream :streams streams)) + (unless (input-stream-p s) + (error "~S is not an input stream" s)))) + +;;;broadcast-streams + + + +(defclass broadcast-stream (fundamental-output-stream) + ((streams :initarg :streams :reader broadcast-stream-streams))) + +(macrolet ((broadcast-method + (op (stream &rest others ) + &optional + (args (cons stream others))) + (let* ((sub (gensym)) + (result (gensym))) + `(defmethod ,op ((,stream broadcast-stream) ,@others) + (let* ((,result nil)) + (dolist (,sub (broadcast-stream-streams ,stream) ,result) + (setq ,result (,op ,@(cons sub (cdr args)))))))))) + (broadcast-method stream-write-char (s c)) + (broadcast-method stream-write-string + (s str &optional (start 0) end) + (s str start end)) + (broadcast-method stream-write-byte (s b)) + (broadcast-method stream-clear-output (s)) + (broadcast-method stream-line-column (s)) + (broadcast-method stream-set-column (s new)) + (broadcast-method stream-advance-to-column (s new)) + (broadcast-method stream-start-line-p (s)) + (broadcast-method stream-terpri (s)) + (broadcast-method stream-force-output (s)) + (broadcast-method stream-finish-output (s)) + (broadcast-method stream-write-list (s l c)) + (broadcast-method stream-write-vector (s v start end))) + +(defun last-broadcast-stream (s) + (car (last (broadcast-stream-streams s)))) + +(defmethod stream-fresh-line ((s broadcast-stream)) + (let* ((did-output-newline nil)) + (dolist (sub (broadcast-stream-streams s) did-output-newline) + (setq did-output-newline (stream-fresh-line sub))))) + +(defmethod stream-element-type ((s broadcast-stream)) + (let* ((last (last-broadcast-stream s))) + (if last + (stream-element-type last) + t))) + +(defmethod stream-length ((s broadcast-stream) &optional new) + (unless new + (let* ((last (last-broadcast-stream s))) + (if last + (stream-length last) + 0)))) + +(defmethod stream-position ((s broadcast-stream) &optional new) + (unless new + (let* ((last (last-broadcast-stream s))) + (if last + (stream-position last) + 0)))) + +(defun make-broadcast-stream (&rest streams) + (dolist (s streams (make-instance 'broadcast-stream :streams streams)) + (unless (output-stream-p s) + (report-bad-arg s '(satisfies output-stream-p))))) + + + + +;;; String streams. +(make-built-in-class 'string-stream 'basic-character-stream) + +(defmethod print-object ((s string-stream) out) + (print-unreadable-object (s out :type t :identity t) + (unless (open-stream-p s) (format out " ~s" :closed)))) + + + + +(defstruct (string-stream-ioblock (:include ioblock)) + string) + +(defstruct (string-output-stream-ioblock (:include string-stream-ioblock)) + (index 0) + freelist) + +(defstatic *string-output-stream-class* (make-built-in-class 'string-output-stream 'string-stream 'basic-character-output-stream)) +(defstatic *string-output-stream-class-wrapper* (%class-own-wrapper *string-output-stream-class*)) + +(defstatic *fill-pointer-string-output-stream-class* (make-built-in-class 'fill-pointer-string-output-stream 'string-output-stream)) + +(def-standard-initial-binding %string-output-stream-ioblocks% (%cons-pool nil)) + +(defmethod stream-force-output ((s string-output-stream)) + nil) + +(defmethod stream-finish-output ((s string-output-stream)) + nil) + +(defmethod stream-clear-output ((s string-output-stream)) + nil) + +;;; Should only be used for a stream whose class is exactly +;;; *string-output-stream-class* +(defun %close-string-output-stream (stream ioblock) + (let* ((pool %string-output-stream-ioblocks%)) + (when (and pool + (eq (basic-stream.wrapper stream) + *string-output-stream-class-wrapper*) + (eq (string-output-stream-ioblock-freelist ioblock) pool)) + (without-interrupts + (setf (ioblock-stream ioblock) (pool.data pool) + (pool.data pool) ioblock))))) + +;;; If this is the sort of string stream whose ioblock we recycle and +;;; there's a thread-local binding of the variable we use for a freelist, +;;; return the value of that binding. +(defun %string-stream-ioblock-freelist (stream) + (and stream + (eq (basic-stream.wrapper stream) + *string-output-stream-class-wrapper*) + (let* ((loc (%tcr-binding-location (%current-tcr) '%string-output-stream-ioblocks%))) + (and loc (%fixnum-ref loc))))) + + +(defun create-string-output-stream-ioblock (&rest keys &key stream &allow-other-keys) + (declare (dynamic-extent keys)) + (let* ((recycled (and stream + (eq (basic-stream.wrapper stream) + *string-output-stream-class-wrapper*) + (without-interrupts + (let* ((data (pool.data %string-output-stream-ioblocks%))) + (when data + (setf (pool.data %string-output-stream-ioblocks%) + (ioblock-stream data) + (ioblock-stream data) stream + (ioblock-device data) -1 + (ioblock-charpos data) 0 + (string-output-stream-ioblock-index data) 0)) + data))))) + (or recycled (apply #'make-string-output-stream-ioblock keys)))) + + + +(defun %%make-string-output-stream (class string write-char-function write-string-function) + (let* ((stream (allocate-basic-stream class))) + (initialize-basic-stream stream :element-type 'character) + (let* ((ioblock (create-string-output-stream-ioblock + :stream stream + :string string + :element-type 'character + :write-char-function write-char-function + :write-char-when-locked-function write-char-function + :write-simple-string-function write-string-function + :force-output-function #'false + :freelist (%string-stream-ioblock-freelist stream) + :close-function #'%close-string-output-stream))) + (setf (basic-stream.state stream) ioblock) + stream))) + +(declaim (inline %string-push-extend)) +(defun %string-push-extend (char string) + (let* ((fill (%svref string target::vectorH.logsize-cell)) + (size (%svref string target::vectorH.physsize-cell))) + (declare (fixnum fill size)) + (if (< fill size) + (multiple-value-bind (data offset) (array-data-and-offset string) + (declare (simple-string data) (fixnum offset)) + (setf (schar data (the fixnum (+ offset fill))) char + (%svref string target::vectorH.logsize-cell) (the fixnum (1+ fill)))) + (vector-push-extend char string)))) + + +(defun fill-pointer-string-output-stream-ioblock-write-char (ioblock char) + ;; can do better (maybe much better) than VECTOR-PUSH-EXTEND here. + (if (eql char #\Newline) + (setf (ioblock-charpos ioblock) 0) + (incf (ioblock-charpos ioblock))) + (%string-push-extend char (string-stream-ioblock-string ioblock))) + +(defun fill-pointer-string-output-stream-ioblock-write-simple-string (ioblock string start-char num-chars) + (let* ((end (+ start-char num-chars)) + (nlpos (position #\Newline string :start start-char :end end :from-end t))) + (if nlpos + (setf (ioblock-charpos ioblock) (- end nlpos)) + (incf (ioblock-charpos ioblock) num-chars)) + (let* ((out (string-stream-ioblock-string ioblock))) + (do* ((n 0 (1+ n)) + (i start-char (1+ i))) + ((= n num-chars) num-chars) + (%string-push-extend (schar string i) out))))) + +(defmethod stream-position ((s fill-pointer-string-output-stream) &optional newpos) + (let* ((string (string-stream-string s))) + (if newpos + (setf (fill-pointer string) newpos) + (fill-pointer string)))) + +;;; If the stream's string is adjustable, it doesn't really have a meaningful +;;; "maximum size". +(defmethod stream-length ((s string-output-stream) &optional newlen) + (unless newlen + (array-total-size (string-stream-string s)))) + +;;; This creates a FILL-POINTER-STRING-OUTPUT-STREAM. +(defun %make-string-output-stream (string) + (unless (and (typep string 'string) + (array-has-fill-pointer-p string)) + (error "~S must be a string with a fill pointer." string)) + (%%make-string-output-stream *fill-pointer-string-output-stream-class* string 'fill-pointer-string-output-stream-ioblock-write-char 'fill-pointer-string-output-stream-ioblock-write-simple-string)) + +(defun string-output-stream-ioblock-write-char (ioblock char) + (let* ((string (string-output-stream-ioblock-string ioblock)) + (index (string-output-stream-ioblock-index ioblock)) + (len (length string))) + (declare (simple-string string) + (fixnum index len)) + (if (eql char #\Newline) + (setf (ioblock-charpos ioblock) 0) + (incf (ioblock-charpos ioblock))) + (if (= index len) + (let* ((newlen (if (zerop len) 20 (+ len len))) ;non-zero ! + (new (make-string newlen))) + (%copy-ivector-to-ivector string 0 new 0 (the fixnum (ash len 2))) + (setq string new) + (setf (string-output-stream-ioblock-string ioblock) new))) + (setf (string-output-stream-ioblock-index ioblock) (the fixnum (1+ index)) + (schar string index) char))) + +(defun string-output-stream-ioblock-write-simple-string (ioblock string start-char num-chars) + (declare (simple-string string) + (fixnum start-char num-chars) + (optimize (speed 3) (safety 0))) + (let* ((out (string-output-stream-ioblock-string ioblock)) + (index (string-output-stream-ioblock-index ioblock)) + (len (length out)) + (need (+ index num-chars))) + (declare (simple-string out) + (fixnum index len need)) + (if (< len need) + (let* ((newlen (+ need need)) + (new (make-string newlen))) + (declare (fixnum newlen) (simple-string new)) + (dotimes (i len) + (setf (schar new i) (schar out i))) + (setq out new) + (setf (string-output-stream-ioblock-string ioblock) new))) + (do* ((src start-char (1+ src)) + (dest index (1+ dest)) + (nlpos nil) + (end (+ start-char num-chars))) + ((= src end) + (setf (string-output-stream-ioblock-index ioblock) need) + (if nlpos + (setf (ioblock-charpos ioblock) (the fixnum (- end (the fixnum nlpos)))) + (incf (ioblock-charpos ioblock) num-chars)) + num-chars) + (declare (fixnum src dest end)) + (let* ((char (schar string src))) + (if (eql char #\Newline) + (setq nlpos (the fixnum (1+ src)))) + (setf (schar out dest) char))))) + + +(defmethod stream-position ((stream string-output-stream) &optional newpos) + (let* ((ioblock (basic-stream-ioblock stream))) + (if (null newpos) + (string-output-stream-ioblock-index ioblock) + (if (and (typep newpos 'fixnum) + (>= (the fixnum newpos) 0) + (<= (the fixnum newpos) (length (string-output-stream-ioblock-string ioblock)))) + (setf (string-output-stream-ioblock-index ioblock) newpos))))) + +(defun make-simple-string-output-stream () + ;; There's a good chance that we'll get a recycled ioblock + ;; that already has a string; if not, we defer actually + ;; creating a usable string until write-char + (%%make-string-output-stream *string-output-stream-class* + "" + 'string-output-stream-ioblock-write-char + 'string-output-stream-ioblock-write-simple-string)) + +(defun make-string-output-stream (&key (element-type 'character element-type-p)) + "Return an output stream which will accumulate all output given it for + the benefit of the function GET-OUTPUT-STREAM-STRING." + (when (and element-type-p + (not (member element-type '(base-character character + standard-char)))) + (unless (subtypep element-type 'character) + (error "~S argument ~S is not a subtype of ~S." + :element-type element-type 'character))) + (make-simple-string-output-stream)) + + +;;;"Bounded" string output streams. +(defstatic *truncating-string-output-stream-class* (make-built-in-class 'truncating-string-stream 'string-output-stream)) + +(defun truncating-string-output-stream-ioblock-write-char (ioblock char) + (let* ((stream (ioblock-stream ioblock)) + (string (string-output-stream-ioblock-string ioblock)) + (index (string-output-stream-ioblock-index ioblock))) + (declare (fixnum index) (simple-string string)) + (if (< index (the fixnum (length string))) + (progn + (setf (schar string index) char + (string-output-stream-ioblock-index ioblock) (the fixnum (1+ index))) + (if (eql char #\Newline) + (setf (ioblock-charpos ioblock) 0) + (incf (ioblock-charpos ioblock)))) + (setf (getf (basic-stream.info stream) :truncated) t)))) + +(defun truncating-string-output-stream-ioblock-write-simple-string (ioblock string start-char num-chars) + (let* ((stream (ioblock-stream ioblock))) + (do* ((n 0 (1+ n)) + (i start-char (1+ i))) + ((= n num-chars) num-chars) + (truncating-string-output-stream-ioblock-write-char ioblock (schar string i)) + (if (getf (basic-stream.info stream) :truncated) + (return n))))) + +(defun truncating-string-output-stream-truncated-p (stream) + (getf (basic-stream.info stream) :truncated)) + +(defun make-truncating-string-stream (len) + (%%make-string-output-stream *truncating-string-output-stream-class* + (make-string len) + 'truncating-string-output-stream-ioblock-write-char + 'truncating-string-output-stream-ioblock-write-simple-string)) + + +;;;One way to indent on newlines: + +(defstatic *indenting-string-output-stream-class* (make-built-in-class 'indenting-string-output-stream 'string-output-stream)) +(defstatic *indenting-string-output-stream-class-wrapper* (%class-own-wrapper *indenting-string-output-stream-class*)) + + +(defun indenting-string-stream-ioblock-write-char (ioblock c) + (string-output-stream-ioblock-write-char ioblock c) + (if (eql c #\newline) + (let* ((stream (ioblock-stream ioblock)) + (info (basic-stream.info stream)) + (indent (getf info 'indent)) + (prefixlen 0) + (prefixchar (getf info 'prefixchar))) + (when prefixchar + (if (typep prefixchar 'character) + (progn + (setq prefixlen 1) + (string-output-stream-ioblock-write-char ioblock prefixchar)) + (dotimes (i (setq prefixlen (length prefixchar))) + (string-output-stream-ioblock-write-char ioblock (schar prefixchar i))))) + (when indent + (dotimes (i (the fixnum (- indent prefixlen))) + (string-output-stream-ioblock-write-char ioblock #\Space))))) + c) + +(defun indenting-string-stream-ioblock-write-simple-string (ioblock string start-char num-chars) + (do* ((n 0 (1+ n)) + (i start-char (1+ i))) + ((= n num-chars) num-chars) + (indenting-string-stream-ioblock-write-char ioblock (schar string i)))) + +(defun make-indenting-string-output-stream (prefixchar indent) + (let* ((stream (%%make-string-output-stream + *indenting-string-output-stream-class* + (make-string 10) + 'indenting-string-stream-ioblock-write-char + 'indenting-string-stream-ioblock-write-simple-string))) + (setf (getf (basic-stream.info stream) 'indent) indent + (getf (basic-stream.info stream) 'prefixchar) prefixchar) + stream)) + +(defun (setf indenting-string-output-stream-indent) (new stream) + (if (and (typep stream 'basic-stream) + (eq (basic-stream.wrapper stream) *indenting-string-output-stream-class-wrapper*)) + (setf (getf (basic-stream.info stream) 'indent) new) + (report-bad-arg stream 'indenting-string-output-stream))) + + +(defun get-output-stream-string (s) + (let* ((class (if (typep s 'basic-stream) (%wrapper-class (basic-stream.wrapper s))))) + (or (eq class *string-output-stream-class*) + (eq class *truncating-string-output-stream-class*) + (eq class *indenting-string-output-stream-class*) + (eq class *fill-pointer-string-output-stream-class*) + (report-bad-arg s 'string-output-stream)) + (let* ((ioblock (basic-stream-ioblock s)) + (string (string-stream-ioblock-string ioblock))) + (if (eq class *fill-pointer-string-output-stream-class*) + (prog1 (ensure-simple-string string) + (setf (fill-pointer string) 0)) + (let* ((index (string-output-stream-ioblock-index ioblock)) + (result (make-string index))) + (declare (fixnum index)) + (%copy-ivector-to-ivector string 0 result 0 (the fixnum (ash index 2))) + (setf (string-output-stream-ioblock-index ioblock) 0) + result))))) + +;;; String input streams. +(defstatic *string-input-stream-class* (make-built-in-class 'string-input-stream 'string-stream 'basic-character-input-stream)) +(defstatic *string-input-stream-class-wrapper* (%class-own-wrapper *string-input-stream-class*)) +(defstruct (string-input-stream-ioblock (:include string-stream-ioblock)) + (start 0) + index + end + (offset 0)) + + + +(defun string-input-stream-index (s) + (if (and (typep s 'basic-stream) + (eq *string-input-stream-class-wrapper* (basic-stream.wrapper s))) + (let* ((ioblock (basic-stream-ioblock s))) + (- (string-input-stream-ioblock-index ioblock) + (string-input-stream-ioblock-offset ioblock))) + (report-bad-arg s 'string-input-stream))) + + +(defmethod stream-surrounding-characters ((s string-input-stream)) + (let* ((ioblock (basic-stream.state s))) + (when ioblock + (let* ((start (string-input-stream-ioblock-start ioblock)) + (idx (string-input-stream-ioblock-index ioblock)) + (end (string-input-stream-ioblock-end ioblock)) + (string (string-stream-ioblock-string ioblock))) + (subseq string (max (- idx 10) start) (min (+ idx 10) end)))))) + + +(defmethod stream-position ((s string-input-stream) &optional newpos) + (let* ((ioblock (basic-stream-ioblock s)) + (start (string-input-stream-ioblock-start ioblock)) + (idx (string-input-stream-ioblock-index ioblock)) + (end (string-input-stream-ioblock-end ioblock))) + (declare (fixnum end idx start)) + (if newpos + (let* ((limit (- end start))) + (declare (fixnum limit)) + (if (and (typep newpos 'fixnum) + (>= (the fixnum newpos) 0) + (<= (the fixnum newpos) limit)) + (progn + (setf (string-input-stream-ioblock-index ioblock) + (the fixnum (+ start (the fixnum newpos)))) + newpos) + (report-bad-arg newpos `(integer 0 ,limit)))) + (the fixnum (- idx start))))) + + + +(defun string-input-stream-ioblock-read-char (ioblock) + (let* ((string (string-stream-ioblock-string ioblock)) + (idx (string-input-stream-ioblock-index ioblock)) + (end (string-input-stream-ioblock-end ioblock))) + (declare (fixnum idx end) + (simple-string string)) + (if (< idx end) + (progn (setf (string-input-stream-ioblock-index ioblock) + (the fixnum (1+ idx))) + (schar string idx)) + :eof))) + +(defun string-input-stream-ioblock-read-line (ioblock) + (let* ((string (string-stream-ioblock-string ioblock)) + (idx (string-input-stream-ioblock-index ioblock)) + (end (string-input-stream-ioblock-end ioblock))) + (declare (fixnum idx end) + (simple-string string)) + (if (>= idx end) + (values "" t) + (let* ((pos (position #\Newline string :start idx :end end))) + (if pos + (locally (declare (type index pos)) + (let* ((new (make-string (the fixnum (- pos idx))))) + (declare (simple-base-string new)) + (setf (string-input-stream-ioblock-index ioblock) + (the fixnum (1+ pos))) + (do* ((src idx (1+ src)) + (dest 0 (1+ dest))) + ((= src pos) (values new nil)) + (declare (fixnum src dest)) + (setf (schar new dest) (schar string src))))) + (let* ((new (make-string (the fixnum (- end idx))))) + (declare (simple-base-string new)) + (setf (string-input-stream-ioblock-index ioblock) end) + (do* ((src idx (1+ src)) + (dest 0 (1+ dest))) + ((= src end) (values new t)) + (declare (fixnum src dest)) + (setf (schar new dest) (schar string src))))))))) + + +(defun string-input-stream-ioblock-peek-char (ioblock) + (let* ((string (string-stream-ioblock-string ioblock)) + (idx (string-input-stream-ioblock-index ioblock)) + (end (string-input-stream-ioblock-end ioblock))) + (declare (fixnum idx end) + (simple-string string)) + (if (< idx end) + (schar string idx) + :eof))) + +(defun string-input-stream-ioblock-unread-char (ioblock char) + (let* ((string (string-stream-ioblock-string ioblock)) + (idx (string-input-stream-ioblock-index ioblock)) + (start (string-input-stream-ioblock-start ioblock))) + (declare (fixnum idx start) + (simple-string string)) + (unless (> idx start) + (error "Nothing has been read from ~s yet." (ioblock-stream ioblock))) + (decf idx) + (unless (eq char (schar string idx)) + (error "~a was not the last character read from ~s" char (ioblock-stream ioblock))) + (setf (string-input-stream-ioblock-index ioblock) idx) + char)) + + +(defmethod stream-eofp ((s string-input-stream)) + (let* ((ioblock (basic-stream-ioblock s)) + (idx (string-input-stream-ioblock-index ioblock)) + (end (string-input-stream-ioblock-end ioblock))) + (declare (fixnum idx end)) + (>= idx end))) + +(defmethod stream-listen ((s string-input-stream)) + (let* ((ioblock (basic-stream-ioblock s)) + (idx (string-input-stream-ioblock-index ioblock)) + (end (string-input-stream-ioblock-end ioblock))) + (declare (fixnum idx end)) + (< idx end))) + +(defmethod stream-clear-input ((s string-input-stream)) + (basic-stream-ioblock s) + nil) + +(defun string-input-stream-character-read-vector (ioblock vector start end) + (let* ((string (string-stream-ioblock-string ioblock)) + (idx (string-input-stream-ioblock-index ioblock)) + (limit (string-input-stream-ioblock-end ioblock))) + (declare (fixnum idx limit)) + (do* ((i start (1+ i))) + ((= i end) (setf (string-input-stream-ioblock-index ioblock) idx) end) + (declare (fixnum i)) + (if (< idx limit) + (setf (uvref vector i) (schar string idx) + idx (1+ idx)) + (progn + (setf (string-input-stream-ioblock-index ioblock) idx) + (return i)))))) + + + +(defun make-string-input-stream (string &optional (start 0) + (end nil)) + "Return an input stream which will supply the characters of STRING between + START and END in order." + (setq end (check-sequence-bounds string start end)) + (multiple-value-bind (data offset) (array-data-and-offset string) + (unless (typep data 'simple-base-string) + (report-bad-arg string 'string)) + (incf start offset) + (incf end offset) + (let* ((stream (make-basic-stream-instance + *string-input-stream-class* + :element-type 'character)) + (ioblock (make-string-input-stream-ioblock + :stream stream + :offset offset + :string data + :start start + :index start + :end end + :read-char-function 'string-input-stream-ioblock-read-char + :read-char-when-locked-function 'string-input-stream-ioblock-read-char + :peek-char-function 'string-input-stream-ioblock-peek-char + :character-read-vector-function 'string-input-stream-character-read-vector + :close-function #'false + :unread-char-function 'string-input-stream-ioblock-unread-char + :read-line-function 'string-input-stream-ioblock-read-line + ))) + (setf (basic-stream.state stream) ioblock) + stream))) + +(defun string-stream-string (s) + (let* ((class (if (typep s 'basic-stream) (%wrapper-class (basic-stream.wrapper s))))) + (or (eq class *string-output-stream-class*) + (eq class *truncating-string-output-stream-class*) + (eq class *indenting-string-output-stream-class*) + (report-bad-arg s 'string-output-stream))) + (string-stream-ioblock-string (basic-stream-ioblock s))) + + + + +;;; A mixin to be used with FUNDAMENTAL-STREAMs that want to use ioblocks +;;; to buffer I/O. + +(defclass buffered-stream-mixin () + ((ioblock :reader %stream-ioblock :writer (setf stream-ioblock) :initform nil))) + +(defmethod open-stream-p ((s buffered-stream-mixin)) + (with-slots (ioblock) s + (not (null ioblock)))) + +(declaim (inline stream-ioblock)) + +(defun stream-ioblock (stream error-if-nil) + (or (if (typep stream 'basic-stream) + (basic-stream.state stream) + (%stream-ioblock stream)) + (when error-if-nil + (stream-is-closed stream)))) + +(defmethod stream-device ((s buffered-stream-mixin) direction) + (declare (ignore direction)) + (let* ((ioblock (stream-ioblock s nil))) + (and ioblock (ioblock-device ioblock)))) + +(defmethod stream-device ((s basic-stream) direction) + (declare (ignore direction)) + (let* ((ioblock (basic-stream.state s))) + (and ioblock (ioblock-device ioblock)))) + +(defmethod stream-element-type ((s buffered-stream-mixin)) + (ioblock-element-type (stream-ioblock s t))) + +(defmethod stream-element-type ((s basic-stream)) + (ioblock-element-type (basic-stream-ioblock s))) + + +(defmethod stream-create-ioblock ((stream buffered-stream-mixin) &rest args &key) + (declare (dynamic-extent args)) + (apply #'make-ioblock :stream stream args)) + +(defmethod stream-owner ((stream stream)) + ) + +(defmethod stream-owner ((stream buffered-stream-mixin)) + (let* ((ioblock (stream-ioblock stream nil))) + (and ioblock (let* ((owner (ioblock-owner ioblock))) + (unless (eql owner 0) owner))))) + +(defmethod stream-owner ((stream basic-stream)) + (let* ((ioblock (basic-stream.state stream))) + (and ioblock (let* ((owner (ioblock-owner ioblock))) + (unless (eql owner 0) owner))))) + + +(defclass buffered-input-stream-mixin + (buffered-stream-mixin fundamental-input-stream) + ()) + +(defclass buffered-output-stream-mixin + (buffered-stream-mixin fundamental-output-stream) + ()) + +(defclass buffered-io-stream-mixin + (buffered-input-stream-mixin buffered-output-stream-mixin) + ()) + +(defclass buffered-character-input-stream-mixin + (buffered-input-stream-mixin fundamental-character-input-stream) + ()) + +(defclass buffered-character-output-stream-mixin + (buffered-output-stream-mixin fundamental-character-output-stream) + ()) + +(defclass buffered-character-io-stream-mixin + (buffered-character-input-stream-mixin buffered-character-output-stream-mixin) + ()) + +(defclass buffered-binary-input-stream-mixin + (buffered-input-stream-mixin fundamental-binary-input-stream) + ()) + +(defclass buffered-binary-output-stream-mixin + (buffered-output-stream-mixin fundamental-binary-output-stream) + ()) + +(defclass buffered-binary-io-stream-mixin + (buffered-binary-input-stream-mixin + buffered-binary-output-stream-mixin) + ()) + +(defmethod close :after ((stream buffered-stream-mixin) &key abort) + (declare (ignore abort)) + (let* ((ioblock (stream-ioblock stream nil))) + (when ioblock + (%ioblock-close ioblock)))) + +(defmethod close :before ((stream buffered-output-stream-mixin) &key abort) + (unless abort + (when (open-stream-p stream) + (stream-force-output stream)))) + +(defmethod close-for-termination ((stream buffered-output-stream-mixin) abort) + ;; This method should only be invoked via the termination mechanism, + ;; so it can safely assume that there's no contention for the stream. + (let* ((ioblock (stream-ioblock stream nil))) + (when ioblock (setf (ioblock-owner ioblock) nil))) + (close stream :abort abort)) + + +(defmethod interactive-stream-p ((stream buffered-stream-mixin)) + (let* ((ioblock (stream-ioblock stream nil))) + (and ioblock (ioblock-interactive ioblock)))) + +(defmethod interactive-stream-p ((stream basic-stream)) + (let* ((ioblock (basic-stream.state stream))) + (and ioblock (ioblock-interactive ioblock)))) + + +(defmethod close :after ((stream basic-stream) &key abort) + (declare (ignore abort)) + (let* ((ioblock (basic-stream.state stream))) + (when ioblock + (%ioblock-close ioblock)))) + +(defmethod close-for-termination ((stream basic-stream) abort) + (let* ((ioblock (basic-stream.state stream))) + (when ioblock (setf (ioblock-owner ioblock) nil))) + (close stream :abort abort)) + + + +(defmethod open-stream-p ((stream basic-stream)) + (not (null (basic-stream.state stream)))) + +(defmethod close :before ((stream basic-output-stream) &key abort) + (unless abort + (when (open-stream-p stream) + (stream-force-output stream)))) + +(defmethod stream-surrounding-characters ((stream buffered-character-input-stream-mixin)) + (let* ((ioblock (stream-ioblock stream nil))) + (and ioblock (%ioblock-surrounding-characters ioblock)))) + +(defmethod stream-surrounding-characters ((stream basic-character-input-stream)) + (let* ((ioblock (basic-stream.state stream))) + (and ioblock (%ioblock-surrounding-characters ioblock)))) + + +#| +(defgeneric ioblock-advance (stream ioblock readp) + (:documentation + "Called when the current input buffer is empty (or non-existent). + readp true means the caller expects to return a byte now. + Return value is meaningless unless readp is true, in which case + it means that there is input ready")) + +(defgeneric ioblock-listen (stream ioblock) + (:documentation + "Called in response to stream-listen when the current + input buffer is empty. + Returns a boolean")) + +(defgeneric ioblock-eofp (stream ioblock) + (:documentation + "Called in response to stream-eofp when the input buffer is empty. + Returns a boolean.")) + +(defgeneric ioblock-force-output (stream ioblock count finish-p) + (:documentation + "Called in response to stream-force-output. + Write count bytes from ioblock-outbuf. + Finish the I/O if finish-p is true.")) + +(defgeneric ioblock-close (stream ioblock) + (:documentation + "May free some resources associated with the ioblock.")) +|# + +(defmethod ioblock-close ((stream buffered-stream-mixin) ioblock) + (declare (ignore ioblock))) + +(defmethod ioblock-force-output ((stream buffered-output-stream-mixin) + ioblock + count + finish-p) + (declare (ignore ioblock count finish-p))) + + + + +(defmethod stream-read-char ((stream buffered-character-input-stream-mixin)) + (let* ((ioblock (stream-ioblock stream t))) + (funcall (ioblock-read-char-function ioblock) ioblock))) + +(defmethod stream-read-char-no-hang ((stream buffered-character-input-stream-mixin)) + (with-stream-ioblock-input (ioblock stream :speedy t) + (%ioblock-tyi-no-hang ioblock))) + +(defmethod stream-peek-char ((stream buffered-character-input-stream-mixin)) + (with-stream-ioblock-input (ioblock stream :speedy t) + (values + (%ioblock-peek-char ioblock)))) + +(defmethod stream-clear-input ((stream buffered-input-stream-mixin)) + (with-stream-ioblock-input (ioblock stream :speedy t) + (values + (%ioblock-clear-input ioblock)))) + +(defmethod stream-unread-char ((stream buffered-character-input-stream-mixin) char) + (with-stream-ioblock-input (ioblock stream :speedy t) + (funcall (ioblock-unread-char-function ioblock) ioblock char)) + char) + +(defmethod stream-read-byte ((stream buffered-binary-input-stream-mixin)) + (let* ((ioblock (stream-ioblock stream t))) + (funcall (ioblock-read-byte-function ioblock) ioblock))) + +(defmethod stream-read-byte ((stream basic-binary-input-stream)) + (let* ((ioblock (basic-stream-ioblock stream))) + (funcall (ioblock-read-byte-function ioblock) ioblock))) + +(defmethod stream-eofp ((stream buffered-input-stream-mixin)) + (with-stream-ioblock-input (ioblock stream :speedy t) + (values + (%ioblock-eofp ioblock)))) + +(defmethod stream-eofp ((stream basic-input-stream)) + (let* ((ioblock (basic-stream-ioblock stream))) + (with-ioblock-input-locked (ioblock) + (%ioblock-eofp ioblock)))) + +(defmethod stream-listen ((stream buffered-input-stream-mixin)) + (with-stream-ioblock-input (ioblock stream :speedy t) + (values + (%ioblock-listen ioblock)))) + +(defmethod stream-listen ((stream basic-input-stream)) + (let* ((ioblock (basic-stream-ioblock stream))) + (with-ioblock-input-locked (ioblock) + (values + (%ioblock-listen ioblock))))) + + +(defmethod stream-write-byte ((stream buffered-binary-output-stream-mixin) + byte) + (let* ((ioblock (stream-ioblock stream t))) + (funcall (ioblock-write-byte-function ioblock) ioblock byte))) + +(defmethod stream-write-byte ((stream basic-binary-output-stream) byte) + (let* ((ioblock (basic-stream-ioblock stream))) + (funcall (ioblock-write-byte-function ioblock) ioblock byte))) + +(defmethod stream-write-char ((stream buffered-character-output-stream-mixin) char) + (let* ((ioblock (stream-ioblock stream t))) + (funcall (ioblock-write-char-function ioblock) ioblock char))) + +(defmethod stream-write-char ((stream basic-character-output-stream) char) + (let* ((ioblock (basic-stream-ioblock stream))) + (funcall (ioblock-write-char-function ioblock) ioblock char))) + + +(defmethod stream-clear-output ((stream buffered-output-stream-mixin)) + (with-stream-ioblock-output (ioblock stream :speedy t) + (%ioblock-clear-output ioblock)) + nil) + +(defmethod stream-clear-output ((stream basic-output-stream)) + (let* ((ioblock (basic-stream-ioblock stream))) + (with-ioblock-output-locked (ioblock) + (%ioblock-clear-output ioblock)) + nil)) + +(defmethod stream-line-column ((stream buffered-character-output-stream-mixin)) + (let* ((ioblock (stream-ioblock stream nil))) + (and ioblock (ioblock-charpos ioblock)))) + +(defmethod stream-line-column ((stream basic-character-output-stream)) + (let* ((ioblock (basic-stream.state stream))) + (and ioblock (ioblock-charpos ioblock)))) + + + +(defmethod stream-set-column ((stream buffered-character-output-stream-mixin) + new) + (let* ((ioblock (stream-ioblock stream nil))) + (and ioblock (setf (ioblock-charpos ioblock) new)))) + +(defmethod stream-set-column ((stream basic-character-output-stream) + new) + (let* ((ioblock (basic-stream.state stream))) + (and ioblock (setf (ioblock-charpos ioblock) new)))) + +(defmethod stream-force-output ((stream buffered-output-stream-mixin)) + (with-stream-ioblock-output (ioblock stream :speedy t) + (%ioblock-force-output ioblock nil) + nil)) + +(defmethod stream-force-output ((stream basic-output-stream)) + (let* ((ioblock (basic-stream-ioblock stream))) + (with-ioblock-output-locked (ioblock) + (%ioblock-force-output ioblock nil) + nil))) + +(defmethod maybe-stream-force-output ((stream buffered-output-stream-mixin)) + (with-stream-ioblock-output-maybe (ioblock stream :speedy t) + (%ioblock-force-output ioblock nil) + nil)) + +(defmethod maybe-stream-force-output ((stream basic-output-stream)) + (let* ((ioblock (basic-stream-ioblock stream))) + (with-ioblock-output-locked-maybe (ioblock) + (%ioblock-force-output ioblock nil) + nil))) + +(defmethod stream-finish-output ((stream buffered-output-stream-mixin)) + (with-stream-ioblock-output (ioblock stream :speedy t) + (%ioblock-force-output ioblock t) + nil)) + +(defmethod stream-finish-output ((stream basic-output-stream)) + (let* ((ioblock (basic-stream-ioblock stream))) + (with-ioblock-output-locked (ioblock) + (%ioblock-force-output ioblock t) + nil))) + + + +(defmethod stream-write-string ((stream buffered-character-output-stream-mixin) + string &optional (start 0 start-p) end) + + (with-stream-ioblock-output (ioblock stream :speedy t) + (if (and (typep string 'simple-string) + (not start-p)) + (funcall (ioblock-write-simple-string-function ioblock) + ioblock string 0 (length string)) + (progn + (setq end (check-sequence-bounds string start end)) + (locally (declare (fixnum start end)) + (multiple-value-bind (arr offset) + (if (typep string 'simple-string) + (values string 0) + (array-data-and-offset (require-type string 'string))) + (unless (eql 0 offset) + (incf start offset) + (incf end offset)) + (funcall (ioblock-write-simple-string-function ioblock) + ioblock arr start (the fixnum (- end start)))))))) + string) + +(defmethod stream-write-string ((stream basic-character-output-stream) + string &optional (start 0 start-p) end) + + (let* ((ioblock (basic-stream-ioblock stream))) + (with-ioblock-output-locked (ioblock) + (if (and (typep string 'simple-string) + (not start-p)) + (values + (funcall (ioblock-write-simple-string-function ioblock) + ioblock string 0 (length string))) + (progn + (setq end (check-sequence-bounds string start end)) + (locally (declare (fixnum start end)) + (multiple-value-bind (arr offset) + (if (typep string 'simple-string) + (values string 0) + (array-data-and-offset (require-type string 'string))) + (unless (eql 0 offset) + (incf start offset) + (incf end offset)) + (values + (funcall (ioblock-write-simple-string-function ioblock) + ioblock arr start (the fixnum (- end start)))))))))) + string) + + +(defmethod stream-write-ivector ((s buffered-output-stream-mixin) + iv start length) + (with-stream-ioblock-output (ioblock s :speedy t) + (values + (%ioblock-out-ivect ioblock iv start length)))) + +(defmethod stream-write-ivector ((s basic-output-stream) + iv start length) + (let* ((ioblock (basic-stream-ioblock s))) + (with-ioblock-output-locked (ioblock) + (values + (%ioblock-out-ivect ioblock iv start length))))) + + +#+bad-idea +(defmethod stream-read-ivector ((s buffered-character-input-stream-mixin) + iv start nb) + (with-stream-ioblock-input (ioblock s :speedy t) + (values + (%ioblock-character-in-ivect ioblock iv start nb)))) + +(defmethod stream-read-ivector ((s buffered-binary-input-stream-mixin) + iv start nb) + (with-stream-ioblock-input (ioblock s :speedy t) + (values + (%ioblock-binary-in-ivect ioblock iv start nb)))) + + +(defmethod stream-write-vector ((stream buffered-character-output-stream-mixin) + vector start end) + (declare (fixnum start end)) + (if (not (typep vector 'simple-base-string)) + (call-next-method) + (with-stream-ioblock-output (ioblock stream :speedy t) + (let* ((total (- end start))) + (declare (fixnum total)) + (values + (funcall (ioblock-write-simple-string-function ioblock) + ioblock vector start total)))))) + +(defmethod stream-write-vector ((stream basic-character-output-stream) + vector start end) + (declare (fixnum start end)) + (if (not (typep vector 'simple-base-string)) + (call-next-method) + (let* ((ioblock (basic-stream-ioblock stream)) + (total (- end start))) + (declare (fixnum total)) + (with-ioblock-output-locked (ioblock) + (values + (funcall (ioblock-write-simple-string-function ioblock) + ioblock vector start total)))))) + +;;; bivalence: we don't actually have a "bivalent stream" class; +;;; all actual (potentially) bivalent streams (sockets) include binary streams +;;; before character streams in their CPLs. That effectively means that +;;; binary-stream methods for reading and writing sequences have to +;;; handle character I/O in some cases. That may slow some things down +;;; (at least in theory), but the case where the stream's element-type +;;; matches the sequence's element-type isn't affected. +(defun %ioblock-binary-stream-write-vector (ioblock vector start end) + (declare (fixnum start end)) + (let* ((out (ioblock-outbuf ioblock)) + (buf (io-buffer-buffer out)) + (written 0) + (limit (io-buffer-limit out)) + (total (- end start)) + (buftype (typecode buf))) + (declare (fixnum buftype written total limit)) + (if (not (= (the fixnum (typecode vector)) buftype)) + (if (typep vector 'string) + (funcall (ioblock-write-simple-string-function ioblock) + ioblock + vector + start + (- end start)) + (do* ((i start (1+ i)) + (wbf (ioblock-write-byte-when-locked-function ioblock)) + (wcf (ioblock-write-char-when-locked-function ioblock))) + ((= i end)) + (let ((byte (uvref vector i))) + (if (characterp byte) + (funcall wcf ioblock byte) + (funcall wbf ioblock byte))))) + (do* ((pos start (+ pos written)) + (left total (- left written))) + ((= left 0)) + (declare (fixnum pos left)) + (setf (ioblock-dirty ioblock) t) + (let* ((index (io-buffer-idx out)) + (count (io-buffer-count out)) + (avail (- limit index))) + (declare (fixnum index avail count)) + (cond + ((= (setq written avail) 0) + (%ioblock-force-output ioblock nil)) + (t + (if (> written left) + (setq written left)) + (%copy-ivector-to-ivector + vector + (ioblock-elements-to-octets ioblock pos) + buf + (ioblock-elements-to-octets ioblock index) + (ioblock-elements-to-octets ioblock written)) + (setf (ioblock-dirty ioblock) t) + (incf index written) + (if (> index count) + (setf (io-buffer-count out) index)) + (setf (io-buffer-idx out) index) + (if (= index limit) + (%ioblock-force-output ioblock nil))))))))) + +(defmethod stream-write-vector ((stream buffered-binary-output-stream-mixin) + vector start end) + (with-stream-ioblock-output (ioblock stream :speedy t) + (%ioblock-binary-stream-write-vector ioblock vector start end))) + + +(defmethod stream-write-vector ((stream basic-binary-output-stream) + vector start end) + (declare (fixnum start end)) + (let* ((ioblock (basic-stream-ioblock stream))) + (with-ioblock-output-locked (ioblock) + (%ioblock-binary-stream-write-vector ioblock vector start end)))) + + + +(defmethod stream-read-vector ((stream basic-binary-input-stream) + vector start end) + (declare (fixnum start end)) + (if (typep vector 'simple-base-string) + (call-next-method) + (let* ((ioblock (basic-stream-ioblock stream))) + (with-ioblock-input-locked (ioblock) + (values + (%ioblock-binary-read-vector ioblock vector start end)))))) + +(defmethod stream-read-vector ((stream buffered-character-input-stream-mixin) + vector start end) + (declare (fixnum start end)) + (if (not (typep vector 'simple-base-string)) + (call-next-method) + (with-stream-ioblock-input (ioblock stream :speedy t) + (values + (funcall (ioblock-character-read-vector-function ioblock) + ioblock vector start end))))) + + + +(defmethod stream-read-vector ((stream buffered-binary-input-stream-mixin) + vector start end) + (declare (fixnum start end)) + (if (typep vector 'simple-base-string) + (call-next-method) + (with-stream-ioblock-input (ioblock stream :speedy t) + (values + (%ioblock-binary-read-vector ioblock vector start end))))) + + + +(defloadvar *fd-set-size* + (ff-call (%kernel-import target::kernel-import-fd-setsize-bytes) + :unsigned-fullword)) + +(defun unread-data-available-p (fd) + #+(or freebsd-target windows-target) + (fd-input-available-p fd 0) + #-(or freebsd-target windows-target) + (rlet ((arg (* :char) (%null-ptr))) + (when (zerop (int-errno-call (#_ioctl fd #$FIONREAD :address arg))) + (let* ((avail (pref arg :long))) + (and (> avail 0) avail))))) + +;;; Read and discard any available unread input. +(defun %fd-drain-input (fd) + (%stack-block ((buf 1024)) + (do* ((avail (unread-data-available-p fd) (unread-data-available-p fd))) + ((or (null avail) (eql avail 0))) + (do* ((max (min avail 1024) (min avail 1024))) + ((zerop avail)) + (let* ((count (fd-read fd buf max))) + (if (< count 0) + (return) + (decf avail count))))))) + +(defun fd-zero (fdset) + (ff-call (%kernel-import target::kernel-import-do-fd-zero) + :address fdset + :void)) + +(defun fd-set (fd fdset) + (ff-call (%kernel-import target::kernel-import-do-fd-set) + :unsigned-fullword fd + :address fdset + :void)) + +(defun fd-clr (fd fdset) + (ff-call (%kernel-import target::kernel-import-do-fd-clr) + :unsigned-fullword fd + :address fdset + :void)) + +(defun fd-is-set (fd fdset) + (not (= 0 (the fixnum (ff-call (%kernel-import target::kernel-import-do-fd-is-set) + :unsigned-fullword fd + :address fdset + :unsigned-fullword))))) + +(defun process-input-would-block (fd) + #+windows-target (declare (ignore fd)) + #+windows-target t + #-windows-target + (if (logtest #$O_NONBLOCK (the fixnum (fd-get-flags fd))) + (process-input-wait fd) + (- #$ETIMEDOUT))) + +(defun process-input-wait (fd &optional timeout) + "Wait until input is available on a given file-descriptor." + (rlet ((now :timeval)) + (let* ((wait-end + (when timeout + (gettimeofday now) + (+ (timeval->milliseconds now) timeout)))) + (loop + (multiple-value-bind (win error) + (fd-input-available-p fd (or timeout -1)) + (when win + (return (values t nil nil))) + (when (eql error 0) ;timed out + (return (values nil t nil))) + ;; If it returned and a timeout was specified, check + ;; to see if it's been exceeded. If so, return NIL; + ;; otherwise, adjust the remaining timeout. + ;; If there was no timeout, continue to wait forever. + (unless (eql error (- #$EINTR)) + (return (values nil nil error))) + (when timeout + (gettimeofday now) + (setq timeout (- wait-end (timeval->milliseconds now))) + (if (<= timeout 0) + (return (values nil t nil))))))))) + + +(defun process-output-would-block (fd) + #+windows-target (declare (ignore fd)) + #+windows-target t + #-windows-target + (if (logtest #$O_NONBLOCK (the fixnum (fd-get-flags fd))) + (process-output-wait fd) + (- #$ETIMEDOUT))) + +(defun process-output-wait (fd &optional timeout) + "Wait until output is possible on a given file descriptor." + (rlet ((now :timeval)) + (let* ((wait-end + (when timeout + (gettimeofday now) + (+ (timeval->milliseconds now) timeout)))) + (loop + (multiple-value-bind (win error) + (fd-ready-for-output-p fd (or timeout -1)) + (when win + (return (values t nil nil))) + (when (eql error 0) + (return (values nil t nil))) + (unless (eql error (- #$EINTR)) + (return (values nil nil error))) + ;; If it returned and a timeout was specified, check + ;; to see if it's been exceeded. If so, return NIL; + ;; otherwise, adjust the remaining timeout. + ;; If there was no timeout, continue to wait forever. + (when timeout + (gettimeofday now) + (setq timeout (- wait-end (timeval->milliseconds now))) + (if (<= timeout 0) + (return (values nil t nil))))))))) + + + +(defun ticks-to-timeval (ticks tv) + (when ticks + (let* ((total-us (* ticks (/ 1000000 *ticks-per-second*)))) + (multiple-value-bind (seconds us) (floor total-us 1000000) + (setf (pref tv :timeval.tv_sec) seconds + (pref tv :timeval.tv_usec) us))))) + +(defun fd-input-available-p (fd &optional milliseconds) + #+windows-target + (case (%unix-fd-kind fd) + (:socket + (rlet ((infds #>fd_set) + (tv :timeval :tv_sec 0 :tv_usec 0)) + (fd-zero infds) + (fd-set fd infds) + (when milliseconds + (multiple-value-bind (seconds millis) + (floor milliseconds 1000) + (setf (pref tv :timeval.tv_sec) seconds + (pref tv :timeval.tv_usec) (* 1000 millis)))) + (let* ((result (#_select 1 infds (%null-ptr) (%null-ptr) (if milliseconds tv (%null-ptr))))) + (cond ((> result 0) (values t 0)) + ((= result 0) (values nil 0)) + (t (values nil (- (#_GetLastError)))))))) + (:pipe (if (data-available-on-pipe-p fd) + (values t 0) + (if (and milliseconds (> milliseconds 0)) + (values (process-wait-with-timeout "input-wait" milliseconds #'data-available-on-pipe-p fd) 0) + (values nil 0)))) + (:file (let* ((curpos (fd-tell fd)) + (eofpos (%stack-block ((peofpos 8)) + (#_GetFileSizeEx (%int-to-ptr fd) peofpos) + (%%get-unsigned-longlong peofpos 0)))) + (values (< curpos eofpos) 0))) + ;;(:character-special (windows-tty-input-available-p fd milliseconds)) + + (t (values nil 0))) + #-windows-target + (rlet ((pollfds (:array (:struct :pollfd) 1))) + (setf (pref (paref pollfds (:* (:struct :pollfd)) 0) :pollfd.fd) fd + (pref (paref pollfds (:* (:struct :pollfd)) 0) :pollfd.events) #$POLLIN) + (let* ((res (int-errno-call (#_poll pollfds 1 (or milliseconds -1))))) + (declare (fixnum res)) + (values (> res 0) res)))) + + +(defun fd-ready-for-output-p (fd &optional milliseconds) + #+windows-target + (case (%unix-fd-kind fd) + (:socket + (rlet ((tv :timeval :tv_sec 0 :tv_usec 0) + (outfds :fd_set)) + (fd-zero outfds) + (fd-set fd outfds) + (when milliseconds + (multiple-value-bind (seconds millis) + (floor milliseconds 1000) + (setf (pref tv #>timeval.tv_sec) seconds + (pref tv #>timeval.tv_usec) (* millis 1000)))) + (let* ((res (#_select 1 (%null-ptr) outfds (%null-ptr) (if milliseconds tv (%null-ptr))))) + (cond ((> res 0) (values t 0)) + ((= res 0) (values nil 0)) + (t (values 0 (- (#_GetLastError)))))))) + (t (values t 0))) + #-windows-target + (rlet ((pollfds (:array (:struct :pollfd) 1))) + (setf (pref (paref pollfds (:* (:struct :pollfd)) 0) :pollfd.fd) fd + (pref (paref pollfds (:* (:struct :pollfd)) 0) :pollfd.events) #$POLLOUT) + (let* ((res (int-errno-call (#_poll pollfds 1 (or milliseconds -1))))) + (declare (fixnum res)) + (values (> res 0) res)))) + + + +;;; FD-streams, built on top of the ioblock mechanism. +(defclass fd-stream (buffered-stream-mixin fundamental-stream) ()) + + +(defmethod select-stream-advance-function ((s symbol) direction) + (select-stream-advance-function (find-class s) direction)) + +(defmethod select-stream-advance-function ((c class) direction) + (select-stream-advance-function (class-prototype c) direction)) + +(defmethod select-stream-advance-function ((s fd-stream) (direction t)) + 'fd-stream-advance) + +(defmethod select-stream-advance-function ((s basic-stream) (direction t)) + 'fd-stream-advance) + + +(defmethod select-stream-force-output-function ((s symbol) direction) + (select-stream-force-output-function (find-class s) direction)) + +(defmethod select-stream-force-output-function ((c class) direction) + (select-stream-force-output-function (class-prototype c) direction)) + +(defmethod select-stream-force-output-function ((f fd-stream) (direction t)) + 'fd-stream-force-output) + +(defmethod select-stream-force-output-function ((f basic-stream) (direction t)) + 'fd-stream-force-output) + +(defmethod print-object ((s fd-stream) out) + (print-unreadable-object (s out :type t :identity t) + (let* ((ioblock (stream-ioblock s nil)) + (fd (and ioblock (ioblock-device ioblock))) + (encoding (and ioblock (encoding-name (ioblock-encoding ioblock))))) + (if fd + (format out "~s (~a/~d)" encoding (%unix-fd-kind fd) fd) + (format out "~s" :closed))))) + +(defclass fd-input-stream (fd-stream buffered-input-stream-mixin) + ()) + +(defclass fd-output-stream (fd-stream buffered-output-stream-mixin) + ()) + +(defclass fd-io-stream (fd-stream buffered-io-stream-mixin) + ()) + +(defclass fd-character-input-stream (fd-input-stream + buffered-character-input-stream-mixin) + ()) + +(defclass fd-character-output-stream (fd-output-stream + buffered-character-output-stream-mixin) + ()) + +(defclass fd-character-io-stream (fd-io-stream + buffered-character-io-stream-mixin) + ()) + +(defclass fd-binary-input-stream (fd-input-stream + buffered-binary-input-stream-mixin) + ()) + +(defclass fd-binary-output-stream (fd-output-stream + buffered-binary-output-stream-mixin) + ()) + +(defclass fd-binary-io-stream (fd-io-stream buffered-binary-io-stream-mixin) + ()) + +(defun fd-stream-advance (s ioblock read-p) + (let* ((fd (ioblock-device ioblock)) + (buf (ioblock-inbuf ioblock)) + (bufptr (io-buffer-bufptr buf)) + (size (io-buffer-size buf)) + (avail nil)) + (setf (io-buffer-idx buf) 0 + (io-buffer-count buf) 0 + (ioblock-eof ioblock) nil) + (when (or read-p (setq avail (stream-listen s))) + (unless avail + (let* ((deadline (ioblock-deadline ioblock)) + (timeout + (if deadline + (milliseconds-until-deadline deadline ioblock) + (ioblock-input-timeout ioblock)))) + (when timeout + (multiple-value-bind (win timedout error) + (process-input-wait fd timeout) + (unless win + (if timedout + (error (if deadline + 'communication-deadline-expired + 'input-timeout) + :stream s) + (stream-io-error s (- error) "read"))))))) + (let* ((n (with-eagain fd :input + (fd-read fd bufptr size)))) + (declare (fixnum n)) + (if (< n 0) + (stream-io-error s (- n) "read") + (if (> n 0) + (setf (io-buffer-count buf) + (ioblock-octets-to-elements ioblock n)) + (progn (setf (ioblock-eof ioblock) t) + nil))))))) + +(defun fd-stream-eofp (s ioblock) + (declare (ignore s)) + (ioblock-eof ioblock)) + +(defun fd-stream-listen (s ioblock) + (declare (ignore s)) + (unread-data-available-p (ioblock-device ioblock))) + +(defun fd-stream-close (s ioblock) + (cancel-terminate-when-unreachable s) + (when (ioblock-dirty ioblock) + (stream-force-output s)) + (let* ((fd (ioblock-device ioblock))) + (when fd + (setf (ioblock-device ioblock) nil) + (if (>= fd 0) (fd-close fd))))) + +(defun fd-stream-force-output (s ioblock count finish-p) + (when (or (ioblock-dirty ioblock) finish-p) + (setf (ioblock-dirty ioblock) nil) + (let* ((fd (ioblock-device ioblock)) + (io-buffer (ioblock-outbuf ioblock)) + (buf (%null-ptr)) + (octets-to-write (ioblock-elements-to-octets ioblock count)) + (octets octets-to-write)) + (declare (fixnum octets)) + (declare (dynamic-extent buf)) + (%setf-macptr buf (io-buffer-bufptr io-buffer)) + (setf (io-buffer-idx io-buffer) 0 + (io-buffer-count io-buffer) 0) + (do* () + ((= octets 0) + (when finish-p + (case (%unix-fd-kind fd) + (:file (fd-fsync fd)))) + octets-to-write) + (let* ((deadline (ioblock-deadline ioblock)) + (timeout + (if deadline + (milliseconds-until-deadline deadline ioblock) + (ioblock-output-timeout ioblock)))) + (when timeout + (multiple-value-bind (win timedout error) + (process-output-wait fd timeout) + (unless win + (if timedout + (error (if deadline + 'communication-deadline-expired + 'output-timeout) + :stream s) + (stream-io-error s (- error) "write")))))) + (let* ((written (with-eagain fd :output + (fd-write fd buf octets)))) + (declare (fixnum written)) + (if (< written 0) + (stream-io-error s (- written) "write")) + (decf octets written) + (unless (zerop octets) + (%incf-ptr buf written))))))) + +(defmethod stream-read-line ((s buffered-input-stream-mixin)) + (with-stream-ioblock-input (ioblock s :speedy t) + (funcall (ioblock-read-line-function ioblock) ioblock))) + +(defmethod stream-clear-input ((s fd-input-stream)) + (call-next-method) + (with-stream-ioblock-input (ioblock s :speedy t) + (let* ((fd (ioblock-device ioblock))) + (when fd (%fd-drain-input fd))))) + +(defmethod select-stream-class ((class (eql 'fd-stream)) in-p out-p char-p) + (if char-p + (if in-p + (if out-p + 'fd-character-io-stream + 'fd-character-input-stream) + 'fd-character-output-stream) + (if in-p + (if out-p + 'fd-binary-io-stream + 'fd-binary-input-stream) + 'fd-binary-output-stream))) + +(defstruct (input-selection (:include dll-node)) + (package nil :type (or null string package)) + (source-file nil :type (or null string pathname)) + (string-stream nil :type (or null string-input-stream))) + +(defstruct (input-selection-queue (:include locked-dll-header))) + +(defclass selection-input-stream (fd-character-input-stream) + ((package :initform nil :reader selection-input-stream-package) + (pathname :initform nil :reader selection-input-stream-pathname) + (peer-fd :reader selection-input-stream-peer-fd))) + +(defmethod select-stream-class ((class (eql 'selection-input-stream)) + in-p out-p char-p) + (if (and in-p char-p (not out-p)) + 'selection-input-stream + (error "Can't create that type of stream."))) + +(defun make-selection-input-stream (fd &key peer-fd encoding) + (let* ((s (make-fd-stream fd + :class 'selection-input-stream + :sharing :lock + :encoding encoding))) + (setf (slot-value s 'peer-fd) peer-fd) + s)) + + +;;; Very simple protocol: +;;; ^ppackage-name#\newline +;;; ^vpathname#\newline +;;; ^q quotes next character +;;; else raw data +(defmethod stream-read-char ((s selection-input-stream)) + (with-slots (package pathname) s + (let* ((quoted nil)) + (loop + (let* ((ch (call-next-method))) + (if quoted + (return ch) + (case ch + (#\^p (setq package nil) + (let* ((p (read-line s nil nil))) + (unless (zerop (length p)) + (setq package p)))) + (#\^v (setq pathname nil) + (let* ((p (read-line s nil nil))) + (unless (zerop (length p)) + (setq pathname p)))) + (#\^q (setq quoted t)) + (t (return ch))))))))) + +(defmethod stream-peek-char ((s selection-input-stream)) + (let* ((ch (stream-read-char s))) + (unless (eq ch :eof) + (stream-unread-char s ch)) + ch)) + +(defmethod stream-read-line ((s selection-input-stream)) + (generic-read-line s)) + +(defmethod stream-read-list ((stream selection-input-stream) + list count) + (generic-character-read-list stream list count)) + +(defmethod stream-read-vector ((stream selection-input-stream) + vector start end) + (generic-character-read-vector stream vector start end)) + + +;;;File streams. + +(let* ((open-file-streams ()) + (open-file-streams-lock (make-lock))) + (defun open-file-streams () + (with-lock-grabbed (open-file-streams-lock) + (copy-list open-file-streams))) + (defun note-open-file-stream (f) + (with-lock-grabbed (open-file-streams-lock) + (push f open-file-streams)) + t) + (defun remove-open-file-stream (f) + (with-lock-grabbed (open-file-streams-lock) + (setq open-file-streams (nremove f open-file-streams))) + t) + (defun clear-open-file-streams () + (with-lock-grabbed (open-file-streams-lock) + (setq open-file-streams nil)))) + + +(defun open (filename &key (direction :input) + (element-type 'base-char) + (if-exists (if (eq (pathname-version filename) :newest) + :new-version + :error)) + (if-does-not-exist (cond ((eq direction :probe) + nil) + ((or (eq direction :input) + (eq if-exists :overwrite) + (eq if-exists :append)) + :error) + (t :create))) + (external-format :default) + (class 'file-stream) + (sharing :private) + (basic t)) + "Return a stream which reads from or writes to FILENAME. + Defined keywords: + :DIRECTION - one of :INPUT, :OUTPUT, :IO, or :PROBE + :ELEMENT-TYPE - the type of object to read or write, default BASE-CHAR + :IF-EXISTS - one of :ERROR, :NEW-VERSION, :RENAME, :RENAME-AND-DELETE, + :OVERWRITE, :APPEND, :SUPERSEDE or NIL + :IF-DOES-NOT-EXIST - one of :ERROR, :CREATE or NIL + See the manual for details." + (loop + (restart-case + (return + (make-file-stream filename + direction + element-type + if-exists + if-does-not-exist + class + external-format + sharing + basic)) + (retry-open () + :report (lambda (stream) (format stream "Retry opening ~s" filename)) + nil)))) + + + + + +(defun gen-file-name (path) + (let* ((date (file-write-date path)) + (tem-path (merge-pathnames (make-pathname :name (%integer-to-string date) :type "tem" :defaults nil) path))) + (loop + (when (%create-file tem-path :if-exists nil) (return tem-path)) + (setf (%pathname-name tem-path) (%integer-to-string (setq date (1+ date))))))) + +(defun probe-file-x (path) + (%probe-file-x (native-translated-namestring path))) + +(defun file-length (stream) + (typecase stream + ;; Don't use an OR type here + (file-stream (stream-length stream)) + (synonym-stream (file-length + (symbol-value (synonym-stream-symbol stream)))) + (broadcast-stream (let* ((last (last-broadcast-stream stream))) + (if last + (file-length last) + 0))) + (otherwise (report-bad-arg stream 'file-stream)))) + +(defun file-position (stream &optional position) + (when position + (if (eq position :start) + (setq position 0) + (if (eq position :end) + (setq position (file-length stream)) + (unless (typep position 'unsigned-byte) + (report-bad-arg position '(or + null + (eql :start) + (eql :end) + unsigned-byte)))))) + (stream-position stream position)) + + +(defun %request-terminal-input () + (let* ((shared-resource + (if (typep *terminal-io* 'two-way-stream) + (input-stream-shared-resource + (two-way-stream-input-stream *terminal-io*))))) + (if shared-resource (%acquire-shared-resource shared-resource t)))) + + + + +(defun %%yield-terminal-to (&optional process) + (let* ((stream (if (typep *terminal-io* 'synonym-stream) + (symbol-value (synonym-stream-symbol *terminal-io*)) + *terminal-io*)) + (shared-resource + (if (typep stream 'two-way-stream) + (input-stream-shared-resource + (two-way-stream-input-stream stream))))) + (when shared-resource (%yield-shared-resource shared-resource process)))) + +(defun %restore-terminal-input (&optional took-it) + (let* ((shared-resource + (if took-it + (if (typep *terminal-io* 'two-way-stream) + (input-stream-shared-resource + (two-way-stream-input-stream *terminal-io*)))))) + (when shared-resource + (%release-shared-resource shared-resource)))) + +;;; Initialize the global streams +;;; These are defparameters because they replace the ones that were in l1-init +;;; while bootstrapping. + +(defparameter *terminal-io* nil "terminal I/O stream") +(defparameter *debug-io* nil "interactive debugging stream") +(defparameter *query-io* nil "query I/O stream") +(defparameter *error-output* nil "error output stream") +(defparameter *standard-input* nil "default input stream") +(defparameter *standard-output* nil "default output stream") +(defparameter *trace-output* nil "trace output stream") + +(proclaim '(stream + *query-io* *debug-io* *error-output* *standard-input* + *standard-output* *trace-output*)) + +;;; Interaction with the REPL. READ-TOPLEVEL-FORM should return 3 +;;; values: a form, a (possibly null) pathname, and a boolean that +;;; indicates whether or not the result(s) of evaluating the form +;;; should be printed. (The last value has to do with how selections +;;; that contain multiple forms are handled; see *VERBOSE-EVAL-SELECTION* +;;; and the SELECTION-INPUT-STREAM method below.) + +(defmethod read-toplevel-form ((stream synonym-stream) &rest keys) + (apply #'read-toplevel-form (symbol-value (synonym-stream-symbol stream)) keys)) + +(defmethod read-toplevel-form ((stream two-way-stream) &rest keys) + (if (typep stream 'echo-stream) + (call-next-method) + (apply #'read-toplevel-form (two-way-stream-input-stream stream) keys))) + +(defmethod read-toplevel-form :after ((stream echoing-two-way-stream) &key &allow-other-keys) + (stream-set-column (two-way-stream-output-stream stream) 0)) + +(defmethod read-toplevel-form ((stream input-stream) &key eof-value file-name start-offset map) + (loop + (let* ((*in-read-loop* nil) + (first-char (peek-char t stream nil eof-value)) + (form + (let ((*read-suppress* nil)) + (cond ((eq first-char #\:) + (read-command-or-keyword stream eof-value)) + ((eq first-char eof-value) eof-value) + (t (multiple-value-bind (form note) + (read-recording-source stream :eofval eof-value + :file-name file-name + :start-offset start-offset + :map map + :save-source-text t) + (setq *loading-toplevel-location* note) + form)))))) + (if (eq form eof-value) + (return (values form nil t)) + (progn + (let ((ch)) ;Trim whitespace + (while (and (listen stream) + (setq ch (read-char stream nil nil)) + (whitespacep cH)) + (setq ch nil)) + (when ch (unread-char ch stream))) + (when *listener-indent* + (write-char #\space stream) + (write-char #\space stream)) + (return (values (process-single-selection form) nil t))))))) + +(defparameter *verbose-eval-selection* nil + "When true, the results of evaluating all forms in an input selection +are printed. When false, only the results of evaluating the last form +are printed.") + +(defmethod read-toplevel-form ((stream selection-input-stream) + &key eof-value &allow-other-keys) + (if (eq (stream-peek-char stream) :eof) + (values eof-value nil t) + (let* ((*package* *package*) + (pkg-name (selection-input-stream-package stream))) + (when pkg-name (setq *package* (pkg-arg pkg-name))) + (let* ((form (call-next-method)) + (last-form-in-selection (not (listen stream)))) + (values form + (selection-input-stream-pathname stream) + (or last-form-in-selection *verbose-eval-selection*)))))) + + +(defun (setf %ioblock-external-format) (ef ioblock) + (let* ((encoding (get-character-encoding (external-format-character-encoding ef))) + (line-termination (external-format-line-termination ef))) + (when (eq encoding (get-character-encoding nil)) + (setq encoding nil)) + (setq line-termination (cdr (assoc line-termination + *canonical-line-termination-conventions*))) + (setf (ioblock-encoding ioblock) encoding) + (when (ioblock-inbuf ioblock) + (setup-ioblock-input ioblock t (ioblock-element-type ioblock) (ioblock-sharing ioblock) encoding line-termination)) + (when (ioblock-outbuf ioblock) + (setup-ioblock-output ioblock t (ioblock-element-type ioblock) (ioblock-sharing ioblock) encoding line-termination)) + ef)) + +(defmethod stream-external-format ((s basic-character-stream)) + (%ioblock-external-format (basic-stream-ioblock s))) + +(defmethod (setf stream-external-format) (new (s basic-character-stream)) + (setf (%ioblock-external-format (basic-stream-ioblock s)) + (normalize-external-format (stream-domain s) new))) + +(defmethod stream-external-format ((s buffered-stream-mixin)) + (%ioblock-external-format (stream-ioblock s t))) + +(defmethod (setf stream-external-format) (new (s buffered-stream-mixin)) + (setf (%ioblock-external-format (stream-ioblock s t)) + (normalize-external-format (stream-domain s) new))) + +(defmethod stream-input-timeout ((s basic-input-stream)) + (let* ((ioblock (basic-stream-ioblock s))) + (with-ioblock-input-locked (ioblock) + (let* ((timeout (ioblock-input-timeout ioblock))) + (when timeout + (values (floor timeout 1000.0))))))) + +(defmethod (setf stream-input-timeout) (new (s basic-input-stream)) + (setq new (check-io-timeout new)) + (let* ((ioblock (basic-stream-ioblock s))) + (with-ioblock-input-locked (ioblock) + (setf (ioblock-input-timeout ioblock) + (if new (round (* new 1000)))) + new))) + +(defmethod stream-output-timeout ((s basic-output-stream)) + (let* ((ioblock (basic-stream-ioblock s))) + (with-ioblock-output-locked (ioblock) + (let* ((timeout (ioblock-output-timeout ioblock))) + (when timeout + (values (floor timeout 1000.0))))))) + +(defmethod (setf stream-output-timeout) (new (s basic-output-stream)) + (setq new (check-io-timeout new)) + (let* ((ioblock (basic-stream-ioblock s))) + (with-ioblock-output-locked (ioblock) + (setf (ioblock-output-timeout ioblock) + (if new (round (* new 1000)))) + new))) + +(defmethod stream-deadline ((s basic-output-stream)) + (let* ((ioblock (basic-stream-ioblock s))) + (with-ioblock-output-locked (ioblock) + (ioblock-deadline ioblock)))) + +(defmethod (setf stream-deadline) (new (s basic-output-stream)) + (let* ((ioblock (basic-stream-ioblock s))) + (with-ioblock-output-locked (ioblock) + (setf (ioblock-deadline ioblock) new) + new))) + + + +(defmethod stream-input-timeout ((s buffered-input-stream-mixin)) + (let* ((ioblock (stream-ioblock s t))) + (with-ioblock-input-locked (ioblock) + (let* ((timeout (ioblock-input-timeout ioblock))) + (when timeout + (values (floor timeout 1000.0))))))) + +(defmethod (setf stream-input-timeout) (new (s buffered-input-stream-mixin)) + (setq new (check-io-timeout new)) + (let* ((ioblock (stream-ioblock s t))) + (with-ioblock-input-locked (ioblock) + (setf (ioblock-input-timeout ioblock) + (if new (round (* new 1000)))) + new))) + +(defmethod stream-output-timeout ((s buffered-output-stream-mixin)) + (let* ((ioblock (stream-ioblock s t))) + (with-ioblock-output-locked (ioblock) + (let* ((timeout (ioblock-output-timeout ioblock))) + (when timeout + (values (floor timeout 1000.0))))))) + +(defmethod (setf stream-output-timeout) (new (s buffered-output-stream-mixin)) + (setq new (check-io-timeout new)) + (let* ((ioblock (stream-ioblock s t))) + (with-ioblock-output-locked (ioblock) + (setf (ioblock-output-timeout ioblock) + (if new (round (* new 1000)))) + new))) + +(defmethod stream-deadline ((s buffered-output-stream-mixin)) + (let* ((ioblock (stream-ioblock s t))) + (with-ioblock-output-locked (ioblock) + (ioblock-deadline ioblock)))) + +(defmethod (setf stream-deadline) (new (s buffered-output-stream-mixin)) + (let* ((ioblock (stream-ioblock s t))) + (with-ioblock-output-locked (ioblock) + (setf (ioblock-deadline ioblock) new) + new))) + + +(defmethod select-stream-untyi-function ((s symbol) direction) + (select-stream-untyi-function (find-class s) direction)) + +(defmethod select-stream-untyi-function ((c class) direction) + (select-stream-untyi-function (class-prototype c) direction)) + +(defmethod select-stream-untyi-function ((s fd-stream) (direction t)) + '%ioblock-untyi) + +(defmethod select-stream-untyi-function ((s basic-stream) (direction t)) + '%ioblock-untyi) + +; end of L1-streams.lisp Index: /branches/new-random/level-1/l1-symhash.lisp =================================================================== --- /branches/new-random/level-1/l1-symhash.lisp (revision 13309) +++ /branches/new-random/level-1/l1-symhash.lisp (revision 13309) @@ -0,0 +1,865 @@ +;;;-*-Mode: LISP; Package: CCL -*- +;;; +;;; Copyright (C) 2009 Clozure Associates +;;; Copyright (C) 1994-2001 Digitool, Inc +;;; This file is part of Clozure CL. +;;; +;;; Clozure CL is licensed under the terms of the Lisp Lesser GNU Public +;;; License , known as the LLGPL and distributed with Clozure CL as the +;;; file "LICENSE". The LLGPL consists of a preamble and the LGPL, +;;; which is distributed with Clozure CL as the file "LGPL". Where these +;;; conflict, the preamble takes precedence. +;;; +;;; Clozure CL is referenced in the preamble as the "LIBRARY." +;;; +;;; The LLGPL is also available online at +;;; http://opensource.franz.com/preamble.html + +(in-package "CCL") + +(declaim (special %all-packages%)) +(declaim (list %all-package%)) +(declaim (type package *package*)) + + + +(defun dereference-base-string-or-symbol (s) + (if (symbolp s) + (dereference-base-string (symbol-name s)) + (dereference-base-string s))) + +(defun dereference-base-string-or-symbol-or-char (s) + (if (typep s 'character) + (values (make-string 1 :element-type 'base-char :initial-element s) 0 1) + (dereference-base-string-or-symbol s))) + + +(defun %string= (string1 string2 start1 end1) + (declare (optimize (speed 3) (safety 0)) + (fixnum start1 end1)) + (when (eq (length string2) (%i- end1 start1)) + (do* ((i start1 (1+ i)) + (j 0 (1+ j))) + ((>= i end1)) + (declare (fixnum i j)) + (when (not (eq (%scharcode string1 i)(%scharcode string2 j))) + (return-from %string= nil))) + t)) + + + + +(defun export (sym-or-syms &optional (package *package*)) + "Exports SYMBOLS from PACKAGE, checking that no name conflicts result." + (setq package (pkg-arg package)) + (if (atom sym-or-syms) + (let* ((temp (cons sym-or-syms nil))) + (declare (dynamic-extent temp)) + (export temp package)) + (progn + (dolist (sym sym-or-syms) + (unless (symbolp sym) (return (setq sym-or-syms (mapcar #'(lambda (s) (require-type s 'symbol)) sym-or-syms))))) + ;; First, see if any packages used by the package being + ;; "exported from" already contain a distinct non-shadowing + ;; symbol that conflicts with one of those that we're trying to + ;; export. + (let* ((conflicts (check-export-conflicts sym-or-syms package))) + (if conflicts + (progn + (resolve-export-conflicts conflicts package) + (export sym-or-syms package)) + (let* ((missing nil) (need-import nil)) + (dolist (s sym-or-syms) + (multiple-value-bind (foundsym foundp) (%findsym (symbol-name s) package) + (if (not (and foundp (eq s foundsym))) + (push s missing) + (if (eq foundp :inherited) + (push s need-import))))) + (when missing + (cerror "Import missing symbols before exporting them from ~S." + 'export-requires-import + :package package + :to-be-imported missing) + (import missing package)) + (if need-import (import need-import package)) + ; Can't lose now: symbols are all directly present in package. + ; Ensure that they're all external; do so with interrupts disabled + (without-interrupts + (let* ((etab (pkg.etab package)) + (ivec (car (pkg.itab package)))) + (dolist (s sym-or-syms t) + (multiple-value-bind (foundsym foundp internal-offset) + (%findsym (symbol-name s) package) + (when (eq foundp :internal) + (setf (%svref ivec internal-offset) (package-deleted-marker)) + (let* ((pname (symbol-name foundsym))) + (%htab-add-symbol foundsym etab (nth-value 2 (%get-htab-symbol pname (length pname) etab))))))))))))))) + +(defun check-export-conflicts (symbols package) + (let* ((conflicts nil)) + (with-package-lock (package) + (dolist (user (pkg.used-by package) conflicts) + (with-package-lock (user) + (dolist (s symbols) + (multiple-value-bind (foundsym foundp) (%findsym (symbol-name s) user) + (if (and foundp (neq foundsym s) (not (memq foundsym (pkg.shadowed user)))) + (push (list (eq foundp :inherited) s user foundsym) conflicts))))))))) + + + +(defun keywordp (x) + "Return true if Object is a symbol in the \"KEYWORD\" package." + (and (symbolp x) (eq (symbol-package x) *keyword-package*))) + +;;;No type/range checking. For DO-SYMBOLS and friends. +(defun %htab-symbol (array index) + (let* ((sym (%svref array index))) + (if (symbolp sym) + (values (%symptr->symbol sym) t) + (values nil nil)))) + +(defun find-all-symbols (name) + "Return a list of all symbols in the system having the specified name." + (let* ((syms ()) + (pname (ensure-simple-string (string name))) + (len (length pname))) + (with-package-list-read-lock + (dolist (p %all-packages% syms) + (with-package-lock (p) + (multiple-value-bind (sym foundp) (%find-package-symbol pname p len) + (if foundp (pushnew sym syms :test #'eq)))))))) + + +(defun list-all-packages () + "Return a list of all existing packages." + (with-package-list-read-lock (copy-list %all-packages%))) + +(defun rename-package (package new-name &optional new-nicknames) + "Changes the name and nicknames for a package." + (setq package (pkg-arg package) + new-name (ensure-simple-string (string new-name))) + (with-package-lock (package) + (let* ((names (pkg.names package))) + (declare (type cons names)) + (dolist (n names) + (let* ((ref (register-package-ref n))) + (setf (package-ref.pkg ref) nil))) + (rplaca names (new-package-name new-name package)) + (let* ((ref (register-package-ref (car names)))) + (setf (package-ref.pkg ref) package)) + (rplacd names nil)) + (%add-nicknames new-nicknames package))) + +;;; Someday, this should become LISP:IN-PACKAGE. +(defun old-in-package (name &key + nicknames + (use nil use-p) + (internal-size 60) + (external-size 10)) + (let ((pkg (find-package (setq name (string name))))) + (if pkg + (progn + (use-package use pkg) + (%add-nicknames nicknames pkg)) + (setq pkg + (make-package name + :nicknames nicknames + :use (if use-p use *make-package-use-defaults*) + :internal-size internal-size + :external-size external-size))) + (setq *package* pkg))) + + +(defvar *make-package-use-defaults* '("COMMON-LISP" "CCL")) + +;;; On principle, this should get exported here. Unfortunately, we +;;; can't execute calls to export quite yet. + + +(defun make-package (name &key + nicknames + (use *make-package-use-defaults*) + (internal-size 60) + (external-size 10)) + "Make a new package having the specified NAME, NICKNAMES, and + USE list. :INTERNAL-SYMBOLS and :EXTERNAL-SYMBOLS are + estimates for the number of internal and external symbols which + will ultimately be present in the package. The default value of + USE is implementation-dependent, and in this implementation + it is NIL." + (setq internal-size (require-type internal-size 'fixnum) + external-size (require-type external-size 'fixnum)) + (let* ((pkg-name (new-package-name name)) + (pkg (gvector :package + (%new-package-hashtable internal-size) + (%new-package-hashtable external-size) + nil + nil + (list pkg-name) + nil + (make-read-write-lock) + nil))) + (let* ((ref (register-package-ref pkg-name))) + (setf (package-ref.pkg ref) pkg)) + (use-package use pkg) + (%add-nicknames nicknames pkg) + (with-package-list-write-lock + (push pkg %all-packages%)) + pkg)) + +(defun new-package-name (name &optional package) + (do* ((prompt "Enter package name to use instead of ~S .")) + ((let* ((found (find-package (setq name (ensure-simple-string (string name)))))) + (or (not found) + (eq package found))) + name) + (restart-case (%error "Package name ~S is already in use." (list name) (%get-frame-ptr)) + (new-name (new-name) + :report (lambda (s) (format s prompt name)) + :interactive + (lambda () + (list (block nil (catch-cancel (return (get-string-from-user + (format nil prompt name)))) + nil))) + (if new-name (setq name new-name)))))) + +(defun new-package-nickname (name package) + (setq name (string name)) + (let* ((other (find-package name)) + (prompt "Enter package name to use instead of ~S .")) + (if other + (unless (eq other package) + (let* ((conflict-with-proper-name (string= (package-name other) name)) + (condition (make-condition 'package-name-conflict-error + :package package + :format-arguments (list name other) + :format-control (%str-cat "~S is already " + (if conflict-with-proper-name + "the " + "a nick") + "name of ~S.")))) + (restart-case (%error condition nil (%get-frame-ptr)) + (continue () + :report (lambda (s) (format s "Don't make ~S a nickname for ~S" name package))) + (new-name (new-name) + :report (lambda (s) (format s prompt name)) + :interactive + (lambda () + (list (block nil (catch-cancel (return (get-string-from-user + (format nil prompt name)))) + nil))) + (if new-name (new-package-nickname new-name package))) + (remove-conflicting-nickname () + :report (lambda (s) + (format s "Remove conflicting-nickname ~S from ~S." name other)) + :test (lambda (&rest ignore) (declare (ignore ignore)) (not conflict-with-proper-name)) + (rplacd (pkg.names other) + (delete name (cdr (pkg.names other)) :test #'string=)) + name)))) + name))) + +(defun %add-nicknames (nicknames package) + (let ((names (pkg.names package))) + (dolist (name nicknames package) + (let* ((ok-name (new-package-nickname name package))) + (when ok-name + (let* ((ref (register-package-ref ok-name))) + (setf (package-ref.pkg ref) package) + (push ok-name (cdr names)))))))) + +(defun find-symbol (string &optional package) + "Return the symbol named STRING in PACKAGE. If such a symbol is found + then the second value is :INTERNAL, :EXTERNAL or :INHERITED to indicate + how the symbol is accessible. If no symbol is found then both values + are NIL." + (multiple-value-bind (sym flag) + (%findsym (ensure-simple-string string) (pkg-arg (or package *package*))) + (values sym flag))) + +(defun %pkg-ref-find-symbol (string ref) + (multiple-value-bind (sym flag) + (%findsym (ensure-simple-string string) + (or (package-ref.pkg ref) + (%kernel-restart $xnopkg (package-ref.name ref)))) + (values sym flag))) + +;;; Somewhat saner interface to %find-symbol +(defun %findsym (string package) + (%find-symbol string (length string) package)) + +(eval-when (:compile-toplevel) + (declaim (inline %intern))) + +(defun %intern (str package) + (setq str (ensure-simple-string str)) + (with-package-lock (package) + (multiple-value-bind (symbol where internal-offset external-offset) + (%find-symbol str (length str) package) + (if where + (values symbol where) + (values (%add-symbol str package internal-offset external-offset) nil))))) + + +(defun intern (str &optional (package *package*)) + "Return a symbol in PACKAGE having the specified NAME, creating it + if necessary." + (%intern str (pkg-arg package))) + +(defun %pkg-ref-intern (str ref) + (%intern str (or (package-ref.pkg ref) + (%kernel-restart $xnopkg (package-ref.name ref))))) + +(defun unintern (symbol &optional (package *package*)) + "Makes SYMBOL no longer present in PACKAGE. If SYMBOL was present + then T is returned, otherwise NIL. If PACKAGE is SYMBOL's home + package, then it is made uninterned." + (setq package (pkg-arg package)) + (setq symbol (require-type symbol 'symbol)) + (multiple-value-bind (foundsym table index) (%find-package-symbol (symbol-name symbol) package) + (when (and table (eq symbol foundsym)) + (when (memq symbol (pkg.shadowed package)) + ;; A conflict is possible if more than one distinct + ;; similarly-named external symbols exist in the packages used + ;; by this one. Grovel around looking for such conflicts; if + ;; any are found, signal an error (via %kernel-restart) which + ;; offers to either shadowing-import one of the conflicting + ;; symbols into the current package or abandon the attempt to + ;; unintern in the first place. + (let* ((first nil) + (first-p nil) + (name (symbol-name symbol)) + (len (length name)) + (others nil)) + (declare (dynamic-extent first)) + (with-package-lock (package) + (dolist (pkg (pkg.used package)) + (with-package-lock (pkg) + (multiple-value-bind (found conflicting-sym) (%get-htab-symbol name len (pkg.etab pkg)) + (when found + (if first-p + (unless (or (eq conflicting-sym first) + (memq conflicting-sym others)) + (push conflicting-sym others)) + (setq first-p t first conflicting-sym))))))) + (when others + ;;If this returns, it will have somehow fixed things. + (return-from unintern (%kernel-restart $xunintc symbol package (cons first others))))) + ;; No conflicts found, but symbol was on shadowing-symbols list. Remove it atomically. + (do* ((head (cons nil (pkg.shadowed package))) + (prev head next) + (next (cdr prev) (cdr next))) + ((null next)) ; Should never happen + (declare (dynamic-extent head) + (list head prev next) + (optimize (speed 3) (safety 0))) + (when (eq (car next) symbol) + (setf (cdr prev) (cdr next) + (pkg.shadowed package) (cdr head)) + (return)))) + ;; Now remove the symbol from package; if package was its home + ;; package, set its package to NIL. If we get here, the "table" + ;; and "index" values returned above are still valid. + (%svset (car table) index (package-deleted-marker)) + (when (eq (symbol-package symbol) package) + (%set-symbol-package symbol nil)) + t))) + +(defun import-1 (package sym) + (multiple-value-bind (conflicting-sym type internal-offset external-offset) (%findsym (symbol-name sym) package) + (if (and type (neq conflicting-sym sym)) + (let* ((external-p (eq type :inherited)) + (condition (make-condition 'import-conflict-error + :package package + :imported-sym sym + :conflicting-sym conflicting-sym + :conflict-external external-p))) + (restart-case (error condition) + (continue () + :report (lambda (s) (format s "Ignore attempt to import ~S to ~S." sym package))) + (resolve-conflict () + :report (lambda (s) + (let* ((package-name (package-name package))) + (if external-p + (format s "~A ~s in package ~s ." 'shadowing-import sym package-name) + (format s "~A ~s from package ~s ." 'unintern conflicting-sym package-name)))) + (if external-p + (shadowing-import-1 package sym) + (progn + (unintern conflicting-sym package) + (import-1 package sym)))))) + (unless (or (eq type :external) (eq type :internal)) + (%insert-symbol sym package internal-offset external-offset))))) + + +(defun import (sym-or-syms &optional package) + "Make SYMBOLS accessible as internal symbols in PACKAGE. If a symbol + is already accessible then it has no effect. If a name conflict + would result from the importation, then a correctable error is signalled." + (setq package (pkg-arg (or package *package*))) + (if (listp sym-or-syms) + (dolist (sym sym-or-syms) + (import-1 package sym)) + (import-1 package sym-or-syms)) + t) + +(defun shadow-1 (package sym) + (let* ((pname (ensure-simple-string (string sym))) + (len (length pname))) + (without-interrupts + (multiple-value-bind (symbol where internal-idx external-idx) (%find-symbol pname len package) + (if (or (eq where :internal) (eq where :external)) + (pushnew symbol (pkg.shadowed package)) + (push (%add-symbol pname package internal-idx external-idx) (pkg.shadowed package))))) + nil)) + +(defun shadow (sym-or-symbols-or-string-or-strings &optional package) + "Make an internal symbol in PACKAGE with the same name as each of + the specified SYMBOLS. If a symbol with the given name is already + present in PACKAGE, then the existing symbol is placed in the + shadowing symbols list if it is not already present." + (setq package (pkg-arg (or package *package*))) + (if (listp sym-or-symbols-or-string-or-strings) + (dolist (s sym-or-symbols-or-string-or-strings) + (shadow-1 package s)) + (shadow-1 package sym-or-symbols-or-string-or-strings)) + t) + +(defun unexport (sym-or-symbols &optional package) + "Makes SYMBOLS no longer exported from PACKAGE." + (setq package (pkg-arg (or package *package*))) + (if (listp sym-or-symbols) + (dolist (sym sym-or-symbols) + (unexport-1 package sym)) + (unexport-1 package sym-or-symbols)) + t) + +(defun unexport-1 (package sym) + (when (eq package *keyword-package*) + (error "Can't unexport ~S from ~S ." sym package)) + (multiple-value-bind (foundsym foundp internal-offset external-offset) + (%findsym (symbol-name sym) package) + (unless foundp + (error 'symbol-name-not-accessible + :symbol-name (symbol-name sym) + :package package)) + (when (eq foundp :external) + (let* ((evec (car (pkg.etab package))) + (itab (pkg.itab package)) + (ivec (car itab)) + (icount&limit (cdr itab))) + (declare (type cons itab icount&limit)) + (setf (svref evec external-offset) (package-deleted-marker)) + (setf (svref ivec internal-offset) (%symbol->symptr foundsym)) + (if (eql (setf (car icount&limit) + (the fixnum (1+ (the fixnum (car icount&limit))))) + (the fixnum (cdr icount&limit))) + (%resize-htab itab))))) + nil) + +;;; Both args must be packages. +(defun %use-package-conflict-check (using-package package-to-use) + (let ((already-used (pkg.used using-package))) + (unless (or (eq using-package package-to-use) + (memq package-to-use already-used)) + ;; There are two types of conflict that can potentially occur: + ;; 1) An external symbol in the package being used conflicts + ;; with a symbol present in the using package + ;; 2) An external symbol in the package being used conflicts + ;; with an external symbol in some other package that's + ;; already used. + (let* ((ext-ext-conflicts nil) + (used-using-conflicts nil) + (shadowed-in-using (pkg.shadowed using-package)) + (to-use-etab (pkg.etab package-to-use))) + (without-interrupts + (dolist (already already-used) + (let ((user (if (memq package-to-use (pkg.used-by already)) + package-to-use + (if (memq package-to-use (pkg.used already)) + already)))) + (if user + (let* ((used (if (eq user package-to-use) already package-to-use)) + (user-etab (pkg.etab user)) + (used-etab (pkg.etab used))) + (dolist (shadow (pkg.shadowed user)) + (let ((sname (symbol-name shadow))) + (unless (member sname shadowed-in-using :test #'string=) + (let ((len (length sname))) + (when (%get-htab-symbol sname len user-etab) ; external in user + (multiple-value-bind (external-in-used used-sym) (%get-htab-symbol sname len used-etab) + (when (and external-in-used (neq used-sym shadow)) + (push (list shadow used-sym) ext-ext-conflicts))))))))) + ;; Remember what we're doing here ? + ;; Neither of the two packages use the other. Iterate + ;; over the external symbols in the package that has + ;; the fewest external symbols and note conflicts with + ;; external symbols in the other package. + (let* ((smaller (if (%i< (%cadr to-use-etab) (%cadr (pkg.etab already))) + package-to-use + already)) + (larger (if (eq smaller package-to-use) already package-to-use)) + (larger-etab (pkg.etab larger)) + (smaller-v (%car (pkg.etab smaller)))) + (dotimes (i (uvsize smaller-v)) + (declare (fixnum i)) + (let ((symptr (%svref smaller-v i))) + (when (symbolp symptr) + (let* ((sym (%symptr->symbol symptr)) + (symname (symbol-name sym))) + (unless (member symname shadowed-in-using :test #'string=) + (multiple-value-bind (found-in-larger sym-in-larger) + (%get-htab-symbol symname (length symname) larger-etab) + (when (and found-in-larger (neq sym-in-larger sym)) + (push (list sym sym-in-larger) ext-ext-conflicts)))))))))))) + ;; Now see if any non-shadowed, directly present symbols in + ;; the using package conflicts with an external symbol in the + ;; package being used. There are two ways of doing this; one + ;; of them -may- be much faster than the other. + (let* ((to-use-etab-size (%cadr to-use-etab)) + (present-symbols-size (%i+ (%cadr (pkg.itab using-package)) (%cadr (pkg.etab using-package))))) + (unless (eql 0 present-symbols-size) + (if (%i< present-symbols-size to-use-etab-size) + ;; Faster to look up each present symbol in to-use-etab. + (let ((htabvs (list (%car (pkg.etab using-package)) (%car (pkg.itab using-package))))) + (declare (dynamic-extent htabvs)) + (dolist (v htabvs) + (dotimes (i (the fixnum (uvsize v))) + (declare (fixnum i)) + (let ((symptr (%svref v i))) + (when (symbolp symptr) + (let* ((sym (%symptr->symbol symptr))) + (unless (memq sym shadowed-in-using) + (let* ((name (symbol-name symptr))) + (multiple-value-bind (found-p to-use-sym) (%get-htab-symbol name (length name) to-use-etab) + (when (and found-p (neq to-use-sym sym)) + (push (list sym to-use-sym) used-using-conflicts))))))))))) + ;; See if any external symbol present in the package + ;; being used conflicts with any symbol present in the + ;; using package. + (let ((v (%car to-use-etab))) + (dotimes (i (uvsize v)) + (declare (fixnum i)) + (let ((symptr (%svref v i))) + (when (symbolp symptr) + (let* ((sym (%symptr->symbol symptr))) + (multiple-value-bind (using-sym found-p) (%find-package-symbol (symbol-name sym) using-package) + (when (and found-p + (neq sym using-sym) + (not (memq using-sym shadowed-in-using))) + (push (list using-sym sym) used-using-conflicts)))))))))))) + (values ext-ext-conflicts used-using-conflicts))))) + +(defun use-package-1 (using-package package-to-use) + (if (eq (setq package-to-use (pkg-arg package-to-use)) + *keyword-package*) + (error "~S can't use ~S." using-package package-to-use)) + (do* ((used-external-conflicts nil) + (used-using-conflicts nil)) + ((and (null (multiple-value-setq (used-external-conflicts used-using-conflicts) + (%use-package-conflict-check using-package package-to-use))) + (null used-using-conflicts))) + (if used-external-conflicts + (%kernel-restart $xusecX package-to-use using-package used-external-conflicts) + (if used-using-conflicts + (%kernel-restart $xusec package-to-use using-package used-using-conflicts)))) + (unless (memq using-package (pkg.used-by package-to-use)) ; Not already used in break loop/restart, etc. + (push using-package (pkg.used-by package-to-use)) + (push package-to-use (pkg.used using-package)))) + +(defun use-package (packages-to-use &optional package) + "Add all the PACKAGES-TO-USE to the use list for PACKAGE so that + the external symbols of the used packages are accessible as internal + symbols in PACKAGE." + (setq package (pkg-arg (or package *package*))) + (if (listp packages-to-use) + (dolist (to-use packages-to-use) + (use-package-1 package to-use)) + (use-package-1 package packages-to-use)) + t) + +(defun shadowing-import-1 (package sym) + (let* ((pname (symbol-name sym)) + (len (length pname)) + (need-add t)) + (without-interrupts + (multiple-value-bind (othersym htab offset) (%find-package-symbol pname package) + (if htab + (if (eq othersym sym) + (setq need-add nil) + (progn ; Delete conflicting symbol + (if (eq (symbol-package othersym) package) + (%set-symbol-package othersym nil)) + (setf (%svref (car htab) offset) (package-deleted-marker)) + (setf (pkg.shadowed package) (delete othersym (pkg.shadowed package) :test #'eq))))) + (if need-add ; No symbols with same pname; intern & shadow + (multiple-value-bind (xsym foundp internal-offset external-offset) + (%find-symbol pname len package) + (declare (ignore xsym foundp)) + (%insert-symbol sym package internal-offset external-offset))) + (pushnew sym (pkg.shadowed package)) + nil)))) + +(defun shadowing-import (sym-or-syms &optional (package *package*)) + "Import SYMBOLS into package, disregarding any name conflict. If + a symbol of the same name is present, then it is uninterned." + (setq package (pkg-arg package)) + (if (listp sym-or-syms) + (dolist (sym sym-or-syms) + (shadowing-import-1 package sym)) + (shadowing-import-1 package sym-or-syms)) + t) + +(defun unuse-package (packages-to-unuse &optional package) + "Remove PACKAGES-TO-UNUSE from the USE list for PACKAGE." + (let ((p (pkg-arg (or package *package*)))) + (flet ((unuse-one-package (unuse) + (setq unuse (pkg-arg unuse)) + (setf (pkg.used p) (nremove unuse (pkg.used p)) + (pkg.used-by unuse) (nremove p (pkg.used-by unuse))))) + (declare (dynamic-extent #'unuse-one-package)) + (if (listp packages-to-unuse) + (dolist (u packages-to-unuse) (unuse-one-package u)) + (unuse-one-package packages-to-unuse)) + t))) + +(defun delete-package (package) + "Delete the package designated by PACKAGE-DESIGNATOR from the package + system data structures." + (unless (packagep package) + (setq package (or (find-package package) + (progn + (cerror "Do nothing" 'no-such-package :package package) + (return-from delete-package nil))))) + (with-package-list-read-lock + (unless (memq package %all-packages%) + (return-from delete-package nil))) + (when (pkg.used-by package) + (cerror "unuse ~S" 'package-is-used-by :package package + :using-packages (pkg.used-by package))) + (while (pkg.used-by package) + (unuse-package package (car (pkg.used-by package)))) + (while (pkg.used package) + (unuse-package (car (pkg.used package)) package)) + (setf (pkg.shadowed package) nil) + (with-package-list-write-lock + (setq %all-packages% (nremove package %all-packages%))) + (dolist (n (pkg.names package)) + (let* ((ref (register-package-ref n))) + (setf (package-ref.pkg ref) nil))) + (setf (pkg.names package) nil) + (let* ((ivec (car (pkg.itab package))) + (evec (car (pkg.etab package))) + (deleted (package-deleted-marker))) + (dotimes (i (the fixnum (length ivec))) + (let* ((sym (%svref ivec i))) + (setf (%svref ivec i) deleted) ; in case it's in STATIC space + (when (symbolp sym) + (if (eq (symbol-package sym) package) + (%set-symbol-package sym nil))))) + (dotimes (i (the fixnum (length evec))) + (let* ((sym (%svref evec i))) + (setf (%svref evec i) deleted) ; in case it's in STATIC space + (when (symbolp sym) + (if (eq (symbol-package sym) package) + (%set-symbol-package sym nil)))))) + (let ((itab (pkg.itab package)) (etab (pkg.etab package)) (v '#(nil nil nil))) + (%rplaca itab v) (%rplaca etab v) + (%rplaca (%cdr itab) 0) (%rplaca (%cdr etab) 0) + (%rplacd (%cdr itab) #x4000) (%rplacd (%cdr etab) #x4000)) + t) + +(defun %find-package-symbol (string package &optional (len (length string))) + (let* ((etab (pkg.etab package)) + (itab (pkg.itab package))) + (multiple-value-bind (foundp sym offset) (%get-htab-symbol string len itab) + (if foundp + (values sym itab offset) + (progn + (multiple-value-setq (foundp sym offset) + (%get-htab-symbol string len etab)) + (if foundp + (values sym etab offset) + (values nil nil nil))))))) + +;;;For the inspector, number of symbols in pkg. +(defun %pkgtab-count (pkgtab) + (let* ((n 0)) + (declare (fixnum n)) + (dovector (x (pkgtab-table pkgtab) n) + (when (symbolp x) + (incf n))))) + + +(defun %resize-package (pkg) + (%resize-htab (pkg.itab pkg)) + (%resize-htab (pkg.etab pkg)) + pkg) + +;These allow deleted packages, so can't use pkg-arg which doesn't. +;Of course, the wonderful world of optional arguments comes in handy. +(defun pkg-arg-allow-deleted (pkg) + (pkg-arg pkg t)) + + +(defun package-name (pkg) (%car (pkg.names (pkg-arg-allow-deleted pkg)))) +;;>> Shouldn't these copy-list their result so that the user +;;>> can't cause a crash through evil rplacding? +;Of course that would make rplacding less evil, and then how would they ever learn? +(defun package-nicknames (pkg) (%cdr (pkg.names (pkg-arg-allow-deleted pkg)))) +(defun package-use-list (pkg) (pkg.used (pkg-arg-allow-deleted pkg))) +(defun package-used-by-list (pkg) (pkg.used-by (pkg-arg-allow-deleted pkg))) +(defun package-shadowing-symbols (pkg) (pkg.shadowed (pkg-arg-allow-deleted pkg))) + +;;; This assumes that all symbol-names and package-names are strings. +(defun %define-package (name size + external-size ; extension (may be nil.) + nicknames + shadow + shadowing-import-from-specs + use + import-from-specs + intern + export + &optional doc) + (if (eq use :default) (setq use *make-package-use-defaults*)) + (let* ((pkg (find-package name))) + (if pkg + ;; Restarts could offer several ways of fixing this. + (unless (string= (package-name pkg) name) + (cerror "Redefine ~*~S" + "~S is already a nickname for ~S" name pkg)) + (setq pkg (make-package name + :use nil + :internal-size (or size 60) + :external-size (or external-size + (max (length export) 1))))) + (unuse-package (package-use-list pkg) pkg) + (rename-package pkg name nicknames) + (flet ((operation-on-all-specs (function speclist) + (let ((to-do nil)) + (dolist (spec speclist) + (let ((from (pop spec))) + (dolist (str spec) + (multiple-value-bind (sym win) (find-symbol str from) + (if win + (push sym to-do) + ; This should (maybe) be a PACKAGE-ERROR. + (cerror "Ignore attempt to ~s ~s from package ~s" + "Cannot ~s ~s from package ~s" function str from)))))) + (when to-do (funcall function to-do pkg))))) + + (dolist (sym shadow) (shadow sym pkg)) + (operation-on-all-specs 'shadowing-import shadowing-import-from-specs) + (use-package use pkg) + (operation-on-all-specs 'import import-from-specs) + (dolist (str intern) (intern str pkg)) + (when export + (let* ((syms nil)) + (dolist (str export) + (multiple-value-bind (sym found) (find-symbol str pkg) + (unless found (setq sym (intern str pkg))) + (push sym syms))) + (export syms pkg))) + (when (and doc *save-doc-strings*) + (set-documentation pkg t doc)) + pkg))) + +(defun %setup-pkg-iter-state (pkg-list types) + (collect ((steps)) + (flet ((cons-pkg-iter-step (package type table &optional shadowed) + (steps (vector package type table shadowed nil nil)))) + (let* ((pkgs (if (listp pkg-list) + (mapcar #'pkg-arg pkg-list) + (list (pkg-arg pkg-list))))) + (dolist (pkg pkgs) + (dolist (type types) + (case type + (:internal (cons-pkg-iter-step pkg type (pkg.itab pkg))) + (:external (cons-pkg-iter-step pkg type (pkg.etab pkg))) + (:inherited + (let* ((shadowed (pkg.shadowed pkg)) + (used (pkg.used pkg))) + (dolist (u used) + (cons-pkg-iter-step pkg type (pkg.etab u) shadowed))))))))) + (vector nil (steps)))) + +(defun %pkg-iter-next (state) + (flet ((get-step () + (let* ((step (pkg-iter.step state))) + (loop + (if (and step (> (pkg-iter-step.index step) 0)) + (return step)) + (when (setq step (pop (pkg-iter.remaining-steps state))) + (setf (pkg-iter.step state) step) + (setf (pkg-iter-step.index step) + (length (setf (pkg-iter-step.vector step) + (pkgtab-table (pkg-iter-step.table step)))))) + (unless step + (return)))))) + (loop + (let* ((step (get-step))) + (when (null step) (return)) + (multiple-value-bind (symbol found) + (%htab-symbol (pkg-iter-step.vector step) + (decf (pkg-iter-step.index step))) + (when (and found + (not (member symbol (pkg-iter-step.shadowed step) + :test #'string=))) + (return (values t + symbol + (pkg-iter-step.type step) + (pkg-iter-step.pkg step))))))))) + + +;;; For do-symbols and with-package-iterator +;;; string must be a simple string +;;; package must be a package +;;; Wouldn't it be nice if this distinguished "not found" from "found NIL" ? +(defun %name-present-in-package-p (string package) + (values (%find-package-symbol string package))) + +;;; This is supposed to be (somewhat) like the lisp machine's MAKE-PACKAGE. +;;; Accept and ignore some keyword arguments, accept and process some others. + +(defun lispm-make-package (name &key + (use *make-package-use-defaults*) + nicknames + ;prefix-name + ;invisible + (shadow nil shadow-p) + (export nil export-p) + (shadowing-import nil shadowing-import-p) + (import nil import-p) + (import-from nil import-from-p) + ;relative-names + ;relative-names-for-me + ;size + ;hash-inherited-symbols + ;external-only + ;include + ;new-symbol-function + ;colon-mode + ;prefix-intern-function + &allow-other-keys) + ; (declare (ignore prefix-name invisible relative-names relative-names-for-me + ; size hash-inherited-symbols external-only include + ; new-symbol-function colon-mode prefix-intern-function)) + (let ((pkg (make-package name :use NIL :nicknames nicknames))) + (when shadow-p (shadow shadow pkg)) + (when shadowing-import-p (shadowing-import shadowing-import pkg)) + (use-package use pkg) + (when import-from-p + (let ((from-pkg (pop import-from))) + (dolist (name import-from) + (multiple-value-bind (sym win) (find-symbol (string name) from-pkg) + (when win (import-1 pkg sym)))))) + (when import-p (import import pkg)) + (when export-p + (let* ((syms nil)) + (dolist (name export) + (multiple-value-bind (sym win) (find-symbol (string name) pkg) + (unless win (setq sym (intern (string name) pkg))) + (push sym syms))) + (export syms pkg))) + pkg)) + Index: /branches/new-random/level-1/l1-sysio.lisp =================================================================== --- /branches/new-random/level-1/l1-sysio.lisp (revision 13309) +++ /branches/new-random/level-1/l1-sysio.lisp (revision 13309) @@ -0,0 +1,928 @@ +;;;-*-Mode: LISP; Package: CCL -*- +;;; +;;; Copyright (C) 2009 Clozure Associates +;;; Copyright (C) 1994-2001 Digitool, Inc +;;; This file is part of Clozure CL. +;;; +;;; Clozure CL is licensed under the terms of the Lisp Lesser GNU Public +;;; License , known as the LLGPL and distributed with Clozure CL as the +;;; file "LICENSE". The LLGPL consists of a preamble and the LGPL, +;;; which is distributed with Clozure CL as the file "LGPL". Where these +;;; conflict, the preamble takes precedence. +;;; +;;; Clozure CL is referenced in the preamble as the "LIBRARY." +;;; +;;; The LLGPL is also available online at +;;; http://opensource.franz.com/preamble.html + +(in-package "CCL") + +(defstruct (file-ioblock (:include ioblock)) + (octet-pos 0 ) ; current io position in octets + (fileeof 0 ) ; file length in elements + ) + + + + +;;; The file-ioblock-octet-pos field is the (octet) position +;;; at which the next I/O operation will begin (e.g., where the +;;; input came from and/or where the output's going.) There are +;;; cases (e.g., after a STREAM-CLEAR-INPUT) when this can't be +;;; determined (based on its previous value and the logical size +;;; of the buffer) so we'll have to ask the OS. + +(defun file-octet-filepos (file-ioblock) + (fd-tell (file-ioblock-device file-ioblock))) + +(defun synch-file-octet-filepos (file-ioblock) + (setf (file-ioblock-octet-pos file-ioblock) + (file-octet-filepos file-ioblock))) + +(defun infer-line-termination (file-ioblock) + (let* ((encoding (or (file-ioblock-encoding file-ioblock) + (get-character-encoding nil))) + (inbuf (file-ioblock-inbuf file-ioblock)) + (buffer (io-buffer-buffer inbuf)) + (n (io-buffer-count inbuf))) + (when (zerop n) + (setq n (or (fd-stream-advance (file-ioblock-stream file-ioblock) + file-ioblock + t) + 0))) + (multiple-value-bind (nchars last) + (funcall (character-encoding-length-of-vector-encoding-function encoding) + buffer + 0 + n) + (declare (fixnum nchars last)) + (let* ((string (make-string nchars))) + (declare (dynamic-extent string)) + (decode-character-encoded-vector encoding buffer 0 last string) + (let* ((line-termination + (do* ((i 0 (1+ i)) + (last-was-cr nil)) + ((= i nchars) (if last-was-cr :cr)) + (declare (fixnum i)) + (let* ((char (schar string i))) + (if last-was-cr + (if (eq char #\Linefeed) + (return :crlf) + (return :cr)) + (case char + (#\Newline (return nil)) + (#\Line_Separator (return :unicode)) + (#\Return (setq last-was-cr t)))))))) + (when line-termination + (install-ioblock-input-line-termination file-ioblock line-termination) + (when (file-ioblock-outbuf file-ioblock) + (install-ioblock-output-line-termination file-ioblock line-termination)))))) + (when (eq (ioblock-owner file-ioblock) *current-process*) + (setf (ioblock-owner file-ioblock) 0)))) + + + +(defvar *default-external-format* :unix) + +(defvar *default-file-character-encoding* nil) + +(defmethod default-character-encoding ((domain (eql :file))) + *default-file-character-encoding*) + +(defvar *default-line-termination* :unix + "The value of this variable is used when :EXTERNAL-FORMAT is +unspecified or specified as :DEFAULT. It can meaningfully be given any +of the values :UNIX, :MACOS, :MSDOS, :UNICODE or :INFERRED, each of which is +interpreted as described in the documentation. + +Because there's some risk that unsolicited newline translation could have +undesirable consequences, the initial value of this variable in Clozure CL +is :UNIX.") + +(defstruct (external-format (:constructor %make-external-format) + (:copier nil)) + (character-encoding :default :read-only t) + (line-termination :default :read-only t)) + +(defmethod print-object ((ef external-format) stream) + (print-unreadable-object (ef stream :type t :identity t) + (format stream "~s/~s" (external-format-character-encoding ef) (external-format-line-termination ef)))) + + + +(defvar *external-formats* (make-hash-table :test #'equal)) + +(defun make-external-format (&key (domain t) + (character-encoding :default) + (line-termination :default)) + (if (eq line-termination :default) + (setq line-termination *default-line-termination*)) + (unless (assq line-termination *canonical-line-termination-conventions*) + (error "~S is not a known line-termination format." line-termination)) + + (if (eq character-encoding :default) + (setq character-encoding + (default-character-encoding domain))) + (unless (lookup-character-encoding character-encoding) + (error "~S is not the name of a known characer encoding." + character-encoding)) + (let* ((pair (cons character-encoding line-termination))) + (declare (dynamic-extent pair)) + (or (gethash pair *external-formats*) + (setf (gethash (cons character-encoding line-termination) *external-formats*) + (%make-external-format :character-encoding character-encoding + :line-termination line-termination))))) + + + +(defun normalize-external-format (domain external-format) + (cond ((listp external-format) + (unless (plistp external-format) + (error "External-format ~s is not a property list." external-format)) + (normalize-external-format domain (apply #'make-external-format :domain domain external-format))) + ((typep external-format 'external-format) + external-format) + ((eq external-format :default) + (normalize-external-format domain *default-external-format*)) + ((lookup-character-encoding external-format) + (normalize-external-format domain `(:character-encoding ,external-format))) + ((assq external-format *canonical-line-termination-conventions*) + (normalize-external-format domain `(:line-termination ,external-format))) + (t + (error "Invalid external-format: ~s" external-format)))) + + + + + + + +;;; Establish a new position for the specified file-stream. +(defun file-ioblock-seek (file-ioblock newoctetpos) + (let* ((result (fd-lseek + (file-ioblock-device file-ioblock) newoctetpos #$SEEK_SET))) + (if (< result 0) + (error 'simple-stream-error + :stream (file-ioblock-stream file-ioblock) + :format-control (format nil "Can't set file position to ~d: ~a" + newoctetpos (%strerror result))) + newoctetpos))) + +;;; For input streams, getting/setting the position is fairly simple. +;;; Getting the position is a simple matter of adding the buffer +;;; origin to the current position within the buffer. +;;; Setting the position involves either adjusting the buffer index +;;; (if the new position is within the current buffer) or seeking +;;; to a new position. + +(defun %ioblock-input-file-position (file-ioblock newpos) + (let* ((octet-base (file-ioblock-octet-pos file-ioblock)) + (element-base (ioblock-octets-to-elements file-ioblock octet-base)) + (inbuf (file-ioblock-inbuf file-ioblock)) + (curpos (+ element-base (io-buffer-idx inbuf)))) + (if (null newpos) + curpos + (progn + (if (and (>= newpos element-base) + (< newpos (+ element-base (io-buffer-count inbuf)))) + (setf (io-buffer-idx inbuf) (- newpos element-base)) + (file-ioblock-seek-and-reset file-ioblock + (ioblock-elements-to-octets + file-ioblock + newpos))) + newpos)))) + +;;; For (pure) output streams, it's a little more complicated. If we +;;; have to seek to a new origin, we may need to flush the buffer +;;; first. + +(defun %ioblock-output-file-position (file-ioblock newpos) + (let* ((octet-base (file-ioblock-octet-pos file-ioblock)) + (element-base (ioblock-octets-to-elements file-ioblock octet-base)) + (outbuf (file-ioblock-outbuf file-ioblock)) + (curpos (+ element-base (io-buffer-idx outbuf))) + (maxpos (+ element-base (io-buffer-count outbuf)))) + (if (null newpos) + curpos + (progn + (unless (= newpos 0) + (setf (ioblock-pending-byte-order-mark file-ioblock) nil)) + (if (and (>= newpos element-base) + (<= newpos maxpos)) + ;; Backing up is easy. Skipping forward (without flushing + ;; and seeking) would be hard, 'cause we can't tell what + ;; we're skipping over. + (let* ((newidx (- newpos element-base))) + (setf (io-buffer-idx outbuf) newidx)) + (progn + (when (file-ioblock-dirty file-ioblock) + (fd-stream-force-output (file-ioblock-stream file-ioblock) + file-ioblock + (io-buffer-count outbuf) + nil) + ;; May have just extended the file; may need to update + ;; fileeof. + (when (> maxpos (file-ioblock-fileeof file-ioblock)) + (setf (file-ioblock-fileeof file-ioblock) maxpos))) + (file-ioblock-seek-and-reset file-ioblock + (ioblock-elements-to-octets + file-ioblock + newpos)))) + newpos)))) + +;;; For I/O file streams, there's an additional complication: if we +;;; back up within the (shared) buffer and the old position was beyond +;;; the buffer's input count, we have to set the input count to the +;;; old position. (Consider the case of writing a single element at +;;; the end-of-file, backing up one element, then reading the element +;;; we wrote.) We -can- skip forward over stuff that's been read; +;;; if the buffer's dirty, we'll eventually write it back out. + +(defun %ioblock-io-file-position (file-ioblock newpos) + (let* ((octet-base (file-ioblock-octet-pos file-ioblock)) + (element-base (ioblock-octets-to-elements file-ioblock octet-base)) + (outbuf (file-ioblock-outbuf file-ioblock)) ; outbuf = inbuf + (curidx (io-buffer-idx outbuf)) + (curpos (+ element-base curidx))) + (if (null newpos) + curpos + (let* ((incount (io-buffer-count outbuf))) + (unless (= newpos 0) + (setf (ioblock-pending-byte-order-mark file-ioblock) nil)) + (cond + ((and (>= newpos element-base) + (<= newpos curpos)) + ;; If we've read less than we've written, make what's + ;; been written available for subsequent input. + (when (> curidx incount) + (setf (io-buffer-count outbuf) curidx)) + (setf (io-buffer-idx outbuf) (- newpos element-base))) + ((and (>= newpos element-base) + (< newpos (+ element-base incount))) + (setf (io-buffer-idx outbuf) (- newpos element-base))) + (t + (let* ((maxpos (+ element-base (io-buffer-count outbuf)))) + (when (> maxpos (file-ioblock-fileeof file-ioblock)) + (setf (file-ioblock-fileeof file-ioblock) maxpos))) + (when (file-ioblock-dirty file-ioblock) + (file-ioblock-seek file-ioblock octet-base) + (fd-stream-force-output (file-ioblock-stream file-ioblock) + file-ioblock + (io-buffer-count outbuf) + nil)) + (file-ioblock-seek-and-reset file-ioblock + (ioblock-elements-to-octets + file-ioblock newpos)))) + newpos)))) + +;;; Again, it's simplest to define this in terms of the stream's direction. +;;; Note that we can't change the size of file descriptors open for input +;;; only. + +(defun %ioblock-input-file-length (file-ioblock newlen) + (unless newlen + (file-ioblock-fileeof file-ioblock))) + +(defun %ioblock-output-file-length (file-ioblock newlen) + (let* ((octet-base (file-ioblock-octet-pos file-ioblock)) + (element-base (ioblock-octets-to-elements file-ioblock octet-base)) + (outbuf (file-ioblock-outbuf file-ioblock)) + (curidx (io-buffer-idx outbuf)) + (maxpos (+ element-base (io-buffer-count outbuf))) + (curlen (file-ioblock-fileeof file-ioblock))) + (if (> maxpos curlen) + (setf (file-ioblock-fileeof file-ioblock) (setq curlen maxpos))) + (if (null newlen) + curlen + (let* ((fd (file-ioblock-device file-ioblock)) + (new-octet-eof (ioblock-elements-to-octets file-ioblock newlen)) + (cur-octet-pos (fd-tell fd))) + (cond ((> newlen curlen) + ;; Extend the file; maintain the current position. + ;; ftruncate isn't guaranteed to extend a file past + ;; its current EOF. Seeking to the new EOF, then + ;; writing, is guaranteed to do so. Seek to the + ;; new EOF, write a random byte, truncate to the + ;; specified length, then seek back to where we + ;; were and pretend that nothing happened. + (file-ioblock-seek file-ioblock new-octet-eof) + (%stack-block ((buf 1)) + (fd-write fd buf 1)) + (fd-ftruncate fd new-octet-eof) + (file-ioblock-seek file-ioblock cur-octet-pos)) + ((> newlen maxpos) + ;; Make the file shorter. Doesn't affect + ;; our position or anything that we have buffered. + (fd-ftruncate fd new-octet-eof)) + ((< newlen element-base) + ;; Discard any buffered output. Truncate the + ;; file, then seek to the new EOF. + (fd-ftruncate fd new-octet-eof) + (file-ioblock-seek-and-reset file-ioblock new-octet-eof)) + (t + (fd-ftruncate fd new-octet-eof) + (let* ((newidx (- newlen element-base))) + (when (> maxpos newlen) + (setf (io-buffer-count outbuf) newidx)) + (when (> curidx newidx) + (setf (io-buffer-idx outbuf) newidx))))) + (setf (file-ioblock-fileeof file-ioblock) newlen))))) + + + +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; +(defclass fundamental-file-stream (fd-stream file-stream) + ((filename :initform nil :initarg :filename :accessor file-stream-filename) + (actual-filename :initform nil :initarg :actual-filename) + (external-format :initform :default :initarg :external-format + :accessor file-stream-external-format))) + + + +(defmethod stream-filename ((s fundamental-file-stream)) + (file-stream-filename s)) + +(defmethod stream-actual-filename ((s file-stream)) + (slot-value s 'actual-filename)) + +(defmethod (setf stream-filename) (new (s fundamental-file-stream)) + (setf (file-stream-filename s) new)) + +(defmethod (setf stream-actual-filename) (new (s fundamental-file-stream)) + (setf (slot-value s 'actual-filename) new)) + +(defun print-file-stream (s out) + (print-unreadable-object (s out :type t :identity t) + (let* ((file-ioblock (stream-ioblock s nil))) + (format out "(~s/" (stream-filename s)) + (if file-ioblock + (format out "~d ~a)" (file-ioblock-device file-ioblock) (encoding-name (ioblock-encoding file-ioblock))) + (format out ":closed"))))) + +(defmethod print-object ((s fundamental-file-stream) out) + (print-file-stream s out)) + +(make-built-in-class 'basic-file-stream 'file-stream 'basic-stream) + +(defmethod stream-filename ((s basic-file-stream)) + (basic-file-stream.filename s)) + +(defmethod stream-actual-filename ((s basic-file-stream)) + (basic-file-stream.actual-filename s)) + +(defmethod (setf stream-filename) (new (s basic-file-stream)) + (setf (basic-file-stream.filename s) new)) + +(defmethod (setf stream-actual-filename) (new (s basic-file-stream)) + (setf (basic-file-stream.actual-filename s) new)) + +(defmethod print-object ((s basic-file-stream) out) + (print-file-stream s out)) + + +(defmethod initialize-basic-stream ((s basic-file-stream) &key element-type external-format &allow-other-keys) + (setf (getf (basic-stream.info s) :element-type) element-type) + (setf (basic-file-stream.external-format s) external-format)) + +(defmethod stream-create-ioblock ((stream fundamental-file-stream) &rest args &key) + (declare (dynamic-extent args)) + (apply #'make-file-ioblock :stream stream args)) + +(defmethod stream-create-ioblock ((stream basic-file-stream) &rest args &key) + (declare (dynamic-extent args)) + (apply #'make-file-ioblock :stream stream args)) + +(defclass fundamental-file-input-stream (fundamental-file-stream fd-input-stream) + ()) + +(make-built-in-class 'basic-file-input-stream 'basic-file-stream 'basic-input-stream) + + +(defclass fundamental-file-output-stream (fundamental-file-stream fd-output-stream) + ()) + +(make-built-in-class 'basic-file-output-stream 'basic-file-stream 'basic-output-stream) + +(defclass fundamental-file-io-stream (fundamental-file-stream fd-io-stream) + ()) + +(make-built-in-class 'basic-file-io-stream 'basic-file-stream 'basic-io-stream) + + +(defclass fundamental-file-character-input-stream (fundamental-file-input-stream + fd-character-input-stream) + ()) + +(make-built-in-class 'basic-file-character-input-stream 'basic-file-input-stream 'basic-character-input-stream) + + +(defclass fundamental-file-character-output-stream (fundamental-file-output-stream + fd-character-output-stream) + ()) + +(make-built-in-class 'basic-file-character-output-stream 'basic-file-output-stream 'basic-character-output-stream) + +(defclass fundamental-file-character-io-stream (fundamental-file-io-stream + fd-character-io-stream) + ()) + +(make-built-in-class 'basic-file-character-io-stream 'basic-file-io-stream 'basic-character-io-stream) + +(defclass fundamental-file-binary-input-stream (fundamental-file-input-stream + fd-binary-input-stream) + ()) + +(make-built-in-class 'basic-file-binary-input-stream 'basic-file-input-stream 'basic-binary-input-stream) + +(defclass fundamental-file-binary-output-stream (fundamental-file-output-stream + fd-binary-output-stream) + ()) + +(make-built-in-class 'basic-file-binary-output-stream 'basic-file-output-stream 'basic-binary-output-stream) + +(defclass fundamental-file-binary-io-stream (fundamental-file-io-stream fd-binary-io-stream) + ()) + +(make-built-in-class 'basic-file-binary-io-stream 'basic-file-io-stream 'basic-binary-io-stream) + + + + +;;; This stuff is a lot simpler if we restrict the hair to the +;;; case of file streams opened in :io mode (which have to worry +;;; about flushing the shared buffer before filling it, and things +;;; like that.) + +(defmethod stream-clear-input ((f fundamental-file-input-stream)) + (with-stream-ioblock-input (file-ioblock f :speedy t) + (call-next-method) + (synch-file-octet-filepos file-ioblock) + nil)) + + +(defmethod stream-clear-input ((f basic-file-input-stream)) + (let* ((file-ioblock (basic-stream-ioblock f))) + (with-ioblock-input-locked (file-ioblock) + (call-next-method) + (synch-file-octet-filepos file-ioblock) + nil))) + + +(defmethod stream-clear-input ((f fundamental-file-io-stream)) + (with-stream-ioblock-input (file-ioblock f :speedy t) + (stream-force-output f) + (call-next-method) + (synch-file-octet-filepos file-ioblock) + nil)) + +(defmethod stream-clear-input ((f basic-file-io-stream)) + (let* ((file-ioblock (basic-stream-ioblock f))) + (with-ioblock-input-locked (file-ioblock) + (call-next-method) + (synch-file-octet-filepos file-ioblock) + nil))) + +(defmethod stream-clear-output ((f fundamental-file-output-stream)) + (with-stream-ioblock-output (file-ioblock f :speedy t) + (call-next-method) + (synch-file-octet-filepos file-ioblock) + nil)) + +(defmethod stream-clear-output ((f basic-file-output-stream)) + (let* ((file-ioblock (basic-stream-ioblock f))) + (with-ioblock-input-locked (file-ioblock) + (call-next-method) + (synch-file-octet-filepos file-ioblock) + nil))) + + + +;;; If we've been reading, the file position where we're going +;;; to read this time is (+ where-it-was-last-time what-we-read-last-time.) +(defun input-file-ioblock-advance (stream file-ioblock read-p) + (let* ((newpos (+ (file-ioblock-octet-pos file-ioblock) + (io-buffer-count (file-ioblock-inbuf file-ioblock))))) + (setf (file-ioblock-octet-pos file-ioblock) newpos) + (fd-stream-advance stream file-ioblock read-p))) + +;;; If the buffer's dirty, we have to back up and rewrite it before +;;; reading in a new buffer. +(defun io-file-ioblock-advance (stream file-ioblock read-p) + (let* ((curpos (file-ioblock-octet-pos file-ioblock)) + (count (io-buffer-count (file-ioblock-inbuf file-ioblock))) + (newpos (+ curpos + (ioblock-elements-to-octets file-ioblock count)))) + (when (ioblock-dirty file-ioblock) + (file-ioblock-seek file-ioblock curpos) + (fd-stream-force-output stream file-ioblock count nil)) + (unless (eql newpos (file-octet-filepos file-ioblock)) + (error "Expected newpos to be ~d, fd is at ~d" + newpos (file-octet-filepos file-ioblock))) + (setf (file-ioblock-octet-pos file-ioblock) newpos) + (fd-stream-advance stream file-ioblock read-p))) + + +(defun output-file-force-output (stream file-ioblock count finish-p) + (let* ((pos (%ioblock-output-file-position file-ioblock nil)) + (n (fd-stream-force-output stream file-ioblock count finish-p))) + (incf (file-ioblock-octet-pos file-ioblock) (or n 0)) + (%ioblock-output-file-position file-ioblock pos) + n)) + +;;; Can't be sure where the underlying fd is positioned, so seek first. +(defun io-file-force-output (stream file-ioblock count finish-p) + (let* ((pos (%ioblock-io-file-position file-ioblock nil))) + (file-ioblock-seek file-ioblock (file-ioblock-octet-pos file-ioblock)) + (let* ((n (fd-stream-force-output stream file-ioblock count finish-p))) + (incf (file-ioblock-octet-pos file-ioblock) (or n 0)) + (%ioblock-io-file-position file-ioblock pos) + n))) + + +;;; Invalidate both buffers and seek to the new position. The output +;;; buffer's been flushed already if it needed to be. + +(defun file-ioblock-seek-and-reset (file-ioblock newoctetpos) + (let* ((inbuf (file-ioblock-inbuf file-ioblock)) + (outbuf (file-ioblock-outbuf file-ioblock))) + (setf (file-ioblock-dirty file-ioblock) nil) + (when inbuf + (setf (io-buffer-count inbuf) 0 + (io-buffer-idx inbuf) 0)) + (when outbuf + (setf (io-buffer-count outbuf) 0 + (io-buffer-idx outbuf) 0)) + (setf (file-ioblock-octet-pos file-ioblock) newoctetpos) + (file-ioblock-seek file-ioblock newoctetpos))) + +(defmethod stream-position ((stream fundamental-file-input-stream) &optional newpos) + (with-stream-ioblock-input (file-ioblock stream :speedy t) + (%ioblock-input-file-position file-ioblock newpos))) + + +(defmethod stream-position ((stream basic-file-input-stream) &optional newpos) + (let* ((file-ioblock (basic-stream-ioblock stream))) + (with-ioblock-input-locked (file-ioblock) + (%ioblock-input-file-position file-ioblock newpos)))) + +(defmethod stream-position ((stream fundamental-file-output-stream) &optional newpos) + (with-stream-ioblock-output (file-ioblock stream :speedy t) + (%ioblock-output-file-position file-ioblock newpos))) + +(defmethod stream-position ((stream basic-file-output-stream) &optional newpos) + (let* ((file-ioblock (basic-stream-ioblock stream))) + (with-ioblock-output-locked (file-ioblock) + (%ioblock-output-file-position file-ioblock newpos)))) + + +(defmethod stream-position ((stream fundamental-file-io-stream) &optional newpos) + (with-stream-ioblock-input (file-ioblock stream :speedy t) + (%ioblock-io-file-position file-ioblock newpos))) + +(defmethod stream-position ((stream basic-file-io-stream) &optional newpos) + (let* ((file-ioblock (basic-stream-ioblock stream))) + (with-ioblock-input-locked (file-ioblock) + (%ioblock-io-file-position file-ioblock newpos)))) + + +(defmethod stream-length ((stream fundamental-file-input-stream) &optional newlen) + (with-stream-ioblock-input (file-ioblock stream :speedy t) + (let* ((res (%ioblock-input-file-length file-ioblock newlen))) + (and res (>= res 0) res)))) + + +(defmethod stream-length ((stream basic-file-input-stream) &optional newlen) + (let* ((file-ioblock (basic-stream-ioblock stream))) + (with-ioblock-input-locked (file-ioblock) + (let* ((res (%ioblock-input-file-length file-ioblock newlen))) + (and res (>= res 0) res))))) + + +(defmethod stream-length ((s fundamental-file-output-stream) &optional newlen) + (with-stream-ioblock-output (file-ioblock s :speedy t) + (let* ((res (%ioblock-output-file-length file-ioblock newlen))) + (and res (>= res 0) res)))) + + +(defmethod stream-length ((stream basic-file-output-stream) &optional newlen) + (let* ((file-ioblock (basic-stream-ioblock stream))) + (with-ioblock-output-locked (file-ioblock) + (let* ((res (%ioblock-output-file-length file-ioblock newlen))) + (and res (>= res 0) res))))) + +(defmethod stream-length ((s fundamental-file-io-stream) &optional newlen) + (with-stream-ioblock-input (file-ioblock s :speedy t) + (let* ((res (%ioblock-output-file-length file-ioblock newlen))) + (and res (>= res 0) res)))) + +(defmethod stream-length ((stream basic-file-io-stream) &optional newlen) + (let* ((file-ioblock (basic-stream-ioblock stream))) + (with-ioblock-input-locked (file-ioblock) + (let* ((res (%ioblock-output-file-length file-ioblock newlen))) + (and res (>= res 0) res))))) + +(defun close-file-stream (s abort) + (when (open-stream-p s) + (let* ((ioblock (stream-ioblock s t)) + (filename (stream-filename s)) + (actual-filename (stream-actual-filename s))) + (when actual-filename ; t => created when opened + (if abort + (progn + (setf (ioblock-dirty ioblock) nil) + (fd-stream-close s ioblock) + (if (eq actual-filename t) + (delete-file filename) + (unix-rename (namestring actual-filename) (probe-file-x filename)))) + (unless (eq actual-filename t) + (delete-file actual-filename)))) + (remove-open-file-stream s)))) + + +(defmethod close ((s fundamental-file-stream) &key abort) + (close-file-stream s abort) + (call-next-method)) + +(defmethod close ((s basic-file-stream) &key abort) + (close-file-stream s abort) + (call-next-method)) + +(defmethod select-stream-class ((class fundamental-file-stream) in-p out-p char-p) + (if char-p + (if (and in-p out-p) + 'fundamental-file-character-io-stream + (if in-p + 'fundamental-file-character-input-stream + (if out-p + 'fundamental-file-character-output-stream + 'fundamental-file-stream))) + (if (and in-p out-p) + 'fundamental-file-binary-io-stream + (if in-p + 'fundamental-file-binary-input-stream + (if out-p + 'fundamental-file-binary-output-stream + 'fundamental-file-stream))))) + +(defmethod select-stream-class ((class file-stream) in-p out-p char-p) + (if char-p + (if (and in-p out-p) + 'fundamental-file-character-io-stream + (if in-p + 'fundamental-file-character-input-stream + (if out-p + 'fundamental-file-character-output-stream + 'fundamental-file-stream))) + (if (and in-p out-p) + 'fundamental-file-binary-io-stream + (if in-p + 'fundamental-file-binary-input-stream + (if out-p + 'fundamental-file-binary-output-stream + 'fundamental-file-stream))))) + +(defmethod map-to-basic-stream-class-name ((name (eql 'fundamental-file-stream))) + 'basic-file-stream) + +(defmethod map-to-basic-stream-class-name ((name (eql 'file-stream))) + 'basic-file-stream) + +(defmethod select-stream-class ((class (eql 'basic-file-stream)) in-p out-p char-p) + (if char-p + (if (and in-p out-p) + 'basic-file-character-io-stream + (if in-p + 'basic-file-character-input-stream + (if out-p + 'basic-file-character-output-stream + 'basic-file-stream))) + (if (and in-p out-p) + 'basic-file-binary-io-stream + (if in-p + 'basic-file-binary-input-stream + (if out-p + 'basic-file-binary-output-stream + 'basic-file-stream))))) + + +(defmethod select-stream-advance-function ((s file-stream) direction) + (ecase direction + (:io 'io-file-ioblock-advance) + (:input 'input-file-ioblock-advance))) + +(defmethod select-stream-force-output-function ((s file-stream) direction) + (ecase direction + (:io 'io-file-force-output) + (:output 'output-file-force-output))) + +(defmethod select-stream-untyi-function ((s file-stream) (direction t)) + '%file-ioblock-untyi) + +;;; Conceptually, decrement the stream's position by the number of octets +;;; needed to encode CHAR. +;;; Since we don't use IOBLOCK-UNTYI-CHAR, it's hard to detect the error +;;; of calling UNREAD-CHAR twice in a row. +(defun %file-ioblock-untyi (ioblock char) + (let* ((inbuf (ioblock-inbuf ioblock)) + (idx (io-buffer-idx inbuf)) + (encoding (ioblock-encoding ioblock)) + (noctets (if encoding + (funcall (character-encoding-character-size-in-octets-function encoding) char) + 1))) + (declare (fixnum idx noctets)) + (if (>= idx noctets) + (setf (io-buffer-idx inbuf) (the fixnum (- idx noctets))) + (let* ((stream (ioblock-stream ioblock)) + (pos (stream-position stream)) + (newpos (- pos noctets))) + (if (< newpos 0) + (error "Invalid attempt to unread ~s on ~s." char (ioblock-stream ioblock)) + (stream-position stream newpos)))) + char)) + + + +(defun make-file-stream (filename + direction + element-type + if-exists + if-does-not-exist + class + external-format + sharing + basic) + (let* ((temp-name nil) + (created nil) + (dir (pathname-directory filename)) + (filename (if (eq (car dir) :relative) + (full-pathname filename) + filename)) + (pathname (pathname filename))) + (block open + (if (or (memq element-type '(:default character base-char)) + (subtypep element-type 'character)) + (if (eq element-type :default)(setq element-type 'character)) + (progn + (setq element-type (type-expand element-type)) + (cond ((equal element-type '#.(type-expand 'signed-byte)) + (setq element-type '(signed-byte 8))) + ((equal element-type '#.(type-expand 'unsigned-byte)) + (setq element-type '(unsigned-byte 8)))))) + (case direction + (:probe (setq if-exists :ignored)) + (:input (setq if-exists :ignored)) + ((:io :output) nil) + (t (report-bad-arg direction '(member :input :output :io :probe)))) + (check-pathname-not-wild filename) ;; probe-file-x misses wild versions.... + (multiple-value-bind (native-truename kind)(probe-file-x filename) + (if native-truename + (if (eq kind :directory) + (if (eq direction :probe) + (return-from open nil) + (signal-file-error (- #$EISDIR) filename)) + (if (setq filename (if-exists if-exists filename "Open ...")) + (progn + (multiple-value-setq (native-truename kind) (probe-file-x filename)) + (cond + ((not native-truename) + (setq native-truename (%create-file filename) + created t)) + ((memq direction '(:output :io)) + (when (eq if-exists :supersede) + (let ((truename (native-to-pathname native-truename))) + (setq temp-name (gen-file-name truename)) + (unix-rename native-truename (native-untranslated-namestring temp-name)) + (%create-file native-truename)))))) + (return-from open nil))) + (if (setq filename (if-does-not-exist if-does-not-exist filename)) + (progn + (unless (setq native-truename (%create-file filename :if-exists if-exists)) + (return-from open nil)) + (setq created t)) + (return-from open nil))) + (let* ((fd (fd-open native-truename (case direction + ((:probe :input) #$O_RDONLY) + (:output #$O_WRONLY) + (:io #$O_RDWR))))) + (when (< fd 0) (signal-file-error fd filename)) + (let* ((fd-kind (%unix-fd-kind fd))) + (if (not (eq fd-kind :file)) + (make-fd-stream fd :direction direction + :element-type element-type + :sharing sharing + :basic basic) + (progn + (when basic + (setq class (map-to-basic-stream-class-name class)) + (setq basic (subtypep (find-class class) 'basic-stream))) + (let* ((in-p (member direction '(:io :input))) + (out-p (member direction '(:io :output))) + (io-p (eq direction :io)) + (char-p (or (eq element-type 'character) + (subtypep element-type 'character))) + (elements-per-buffer (optimal-buffer-size fd element-type)) + (real-external-format + (if char-p + (normalize-external-format :file external-format) + )) + (line-termination (if char-p (external-format-line-termination real-external-format))) + (encoding (if char-p (external-format-character-encoding real-external-format))) + (class-name (select-stream-class class in-p out-p char-p)) + (class (find-class class-name)) + (fstream (make-ioblock-stream + class + :insize (if in-p elements-per-buffer) + :outsize (if (and out-p (not io-p)) + elements-per-buffer) + :share-buffers-p io-p + :interactive nil + :direction direction + :element-type element-type + :direction direction + :listen-function 'fd-stream-listen + :close-function 'fd-stream-close + :advance-function + (if in-p (select-stream-advance-function class direction)) + :force-output-function + (if out-p (select-stream-force-output-function + class direction)) + :device fd + :encoding encoding + :external-format (or real-external-format :binary) + :sharing sharing + :line-termination line-termination + :character-p (or (eq element-type 'character) + (subtypep element-type 'character)))) + (ioblock (stream-ioblock fstream t))) + (setf (stream-filename fstream) (namestring pathname) + (stream-actual-filename fstream) (or temp-name created)) + (setf (file-ioblock-fileeof ioblock) + (ioblock-octets-to-elements ioblock (fd-size fd))) + (when (and in-p (eq line-termination :inferred)) + (infer-line-termination ioblock)) + (cond ((eq if-exists :append) + (file-position fstream :end)) + ((and (memq direction '(:io :output)) + (neq if-exists :overwrite)) + (stream-length fstream 0))) + (if (eq direction :probe) + (close fstream) + (note-open-file-stream fstream)) + fstream))))))))) + + + + + + +(defmethod stream-external-format ((s broadcast-stream)) + (let* ((last (last-broadcast-stream s))) + (if last + (stream-external-format s) + :default))) + +;;; Under the circumstances, this is a very slow way of saying +;;; "we don't support EXTENDED-CHARs". +(defun file-string-length (stream object) + "Return the delta in STREAM's FILE-POSITION that would be caused by writing + OBJECT to STREAM. Non-trivial only in implementations that support + international character sets." + (if (typep stream 'broadcast-stream) + (let* ((last (last-broadcast-stream stream))) + (if last + (file-string-length last object) + 1)) + (progn + (unless (and (typep stream 'file-stream) + (let* ((eltype (stream-element-type stream))) + (or (eq 'character eltype) + (eq 'base-char eltype) + (subtypep eltype 'character)))) + (error "~S is not a file stream capable of character output" stream)) + (if (typep object 'character) + (setq object (make-string 1 :initial-element object)) + (progn + (require-type object 'string))) + (let* ((start 0) + (end (length object))) + (multiple-value-bind (data offset) (array-data-and-offset object) + (unless (eq data object) + (setq object data) + (incf start offset) + (incf end offset))) + (let* ((external-format (stream-external-format stream)) + (encoding (get-character-encoding (external-format-character-encoding external-format))) + (line-termination (external-format-line-termination external-format))) + (- + (+ (funcall (character-encoding-octets-in-string-function encoding) + object + start + end) + (if (eq line-termination :crlf) + (* (count #\Newline object :start start :end end) + (file-string-length stream #\Return)) + 0)) + (if (eql (file-position stream) 0) + 0 + (length (character-encoding-bom-encoding encoding))))))))) + Index: /branches/new-random/level-1/l1-typesys.lisp =================================================================== --- /branches/new-random/level-1/l1-typesys.lisp (revision 13309) +++ /branches/new-random/level-1/l1-typesys.lisp (revision 13309) @@ -0,0 +1,4393 @@ +;;;-*- Mode: Lisp; Package: CCL -*- +;;; +;;; Copyright (C) 2009 Clozure Associates +;;; Copyright (C) 1994-2001 Digitool, Inc +;;; This file is part of Clozure CL. +;;; +;;; Clozure CL is licensed under the terms of the Lisp Lesser GNU Public +;;; License , known as the LLGPL and distributed with Clozure CL as the +;;; file "LICENSE". The LLGPL consists of a preamble and the LGPL, +;;; which is distributed with Clozure CL as the file "LGPL". Where these +;;; conflict, the preamble takes precedence. +;;; +;;; Clozure CL is referenced in the preamble as the "LIBRARY." +;;; +;;; The LLGPL is also available online at +;;; http://opensource.franz.com/preamble.html + +;; This is a hacked-up version of the CMU CL type system. + +(in-package "CCL") + + + +;;; This condition is signalled whenever we make a UNKNOWN-TYPE so that +;;; compiler warnings can be emitted as appropriate. +;;; +(define-condition parse-unknown-type (condition) + ((specifier :reader parse-unknown-type-specifier :initarg :specifier)) + (:report (lambda (c s) (print-unreadable-object (c s :type t) + (format s "unknown type ~A" (parse-unknown-type-specifier c)))))) + +(defun parse-lambda-list (list) + (let* ((required) + (optional) + (keys) + (aux)) + (let ((restp nil) + (rest nil) + (keyp nil) + (allowp nil) + (state :required)) + (dolist (arg list) + (if (and (symbolp arg) + (let ((name (symbol-name arg))) + (and (/= (length name) 0) + (char= (char name 0) #\&)))) + (case arg + (&optional + (unless (eq state :required) + (error "Misplaced &optional in lambda-list: ~S." list)) + (setq state '&optional)) + (&rest + (unless (member state '(:required &optional)) + (error "Misplaced &rest in lambda-list: ~S." list)) + (setq state '&rest)) + (&key + (unless (member state '(:required &optional :post-rest + )) + (error "Misplaced &key in lambda-list: ~S." list)) + (setq keyp t) + (setq state '&key)) + (&allow-other-keys + (unless (eq state '&key) + (error "Misplaced &allow-other-keys in lambda-list: ~S." list)) + (setq allowp t state '&allow-other-keys)) + (&aux + (when (member state '(&rest)) + (error "Misplaced &aux in lambda-list: ~S." list)) + (setq state '&aux)) + (t + (error "Unknown &keyword in lambda-list: ~S." arg))) + (case state + (:required (push arg required)) + (&optional (push arg optional)) + (&rest + (setq restp t rest arg state :post-rest)) + (&key (push arg keys)) + (&aux (push arg aux)) + (t + (error "Found garbage in lambda-list when expecting a keyword: ~S." arg))))) + + (values (nreverse required) (nreverse optional) restp rest keyp (nreverse keys) allowp (nreverse aux))))) + +(defvar %deftype-expanders% (make-hash-table :test #'eq)) +(defvar *type-translators* (make-hash-table :test #'eq)) +(defvar *builtin-type-info* (make-hash-table :test #'equal)) +(defvar %builtin-type-cells% (make-hash-table :test 'equal)) + +(defvar *use-implementation-types* t) + +(defun info-type-builtin (name) + (gethash name *builtin-type-info*)) + +(defun (setf info-type-builtin) (val name) + (setf (gethash name *builtin-type-info*) val)) + +(defun info-type-translator (name) + (gethash name *type-translators*)) + + + + +;;; Allow bootstrapping: mostly, allow us to bootstrap the type system +;;; by having DEFTYPE expanders defined on built-in classes (the user +;;; shouldn't be allowed to do so, at least not easily. + +;(defvar *type-system-initialized* nil) + +(defun %deftype (name fn doc) + (clear-type-cache) + (cond ((null fn) + (remhash name %deftype-expanders%)) + ((and *type-system-initialized* + (or (built-in-type-p name) + (let ((c (find-class name nil))) + (and c (eq (class-name c) name))))) + (error "Cannot redefine type ~S because ~:[it is the name of a class~;it is a built-in type~]" name (built-in-type-p name))) + ((memq name *nx-known-declarations*) + (check-declaration-redefinition name 'deftype)) + (t (setf (gethash name %deftype-expanders%) fn) + (record-source-file name 'type))) + (set-documentation name 'type doc) ; nil clears it. + name) + +(defun %define-type-translator (name fn doc) + (declare (ignore doc)) + (setf (gethash name *type-translators*) fn) + name) + +;;;(defun %deftype-expander (name) +;;; (or (gethash name %deftype-expanders%) +;;; (and *compiling-file* (%cdr (assq name *compile-time-deftype-expanders*))))) +(defun %deftype-expander (name) + (gethash name %deftype-expanders%)) + +(defun process-deftype-arglist (arglist &aux (in-optional? nil)) + "Returns a NEW list similar to arglist except + inserts * as the default default for &optional args." + (mapcar #'(lambda (item) + (cond ((eq item '&optional) (setq in-optional? t) item) + ((memq item lambda-list-keywords) (setq in-optional? nil) item) + ((and in-optional? (symbolp item)) (list item ''*)) + (t item))) + arglist)) + + +(defun expand-type-macro (definer name arglist body env) + (setq name (require-type name 'symbol)) + (multiple-value-bind (lambda doc) + (parse-macro-internal name arglist body env '*) + `(progn + (eval-when (:compile-toplevel) + (note-type-info ',name 'macro ,env)) + (eval-when (:compile-toplevel :load-toplevel :execute) + (,definer ',name + (nfunction ,name ,lambda) + ,doc))))) + +(defmacro deftype (name arglist &body body &environment env) + "Define a new type, with syntax like DEFMACRO." + (expand-type-macro '%deftype name arglist body env)) + +(defmacro def-type-translator (name arglist &body body &environment env) + (expand-type-macro '%define-type-translator name arglist body env)) + + +(defun type-expand (form &optional env &aux def) + (while (setq def (cond ((symbolp form) + (gethash form %deftype-expanders%)) + ((and (consp form) (symbolp (%car form))) + (gethash (%car form) %deftype-expanders%)) + (t nil))) + (setq form (funcall def (if (consp form) form (list form)) env))) + form) + +(defmethod print-object ((tc type-class) stream) + (print-unreadable-object (tc stream :type t :identity t) + (format stream "~s" (type-class-name tc)))) + +(defmethod print-object ((c ctype) stream) + (print-unreadable-object (c stream :type t) + (format stream "~S" (type-specifier c)))) + +(defmethod make-load-form ((c ctype) &optional env) + (declare (ignore env)) + `(specifier-type ',(type-specifier c))) + +(defmethod make-load-form ((cell type-cell) &optional env) + (declare (ignore env)) + `(register-type-cell `,(type-cell-type-specifier cell))) + +(defmethod print-object ((cell type-cell) stream) + (print-unreadable-object (cell stream :type t :identity t) + (format stream "for ~s" (type-cell-type-specifier cell)))) + +(defun make-key-info (&key name type) + (%istruct 'key-info name type)) + +(defun type-class-or-lose (name) + (or (cdr (assq name *type-classes*)) + (error "~S is not a defined type class." name))) + +(eval-when (:compile-toplevel :execute) + +(defconstant type-class-function-slots + '((:simple-subtypep . #.type-class-simple-subtypep) + (:complex-subtypep-arg1 . #.type-class-complex-subtypep-arg1) + (:complex-subtypep-arg2 . #.type-class-complex-subtypep-arg2) + (:simple-union . #.type-class-simple-union) + (:complex-union . #.type-class-complex-union) + (:simple-intersection . #.type-class-simple-intersection) + (:complex-intersection . #.type-class-complex-intersection) + (:simple-= . #.type-class-simple-=) + (:complex-= . #.type-class-complex-=) + (:unparse . #.type-class-unparse))) + +) + +(defun class-typep (form class) + (memq class (%inited-class-cpl (class-of form)))) + +;;; CLASS-FUNCTION-SLOT-OR-LOSE -- Interface +;;; +(defun class-function-slot-or-lose (name) + (or (cdr (assoc name type-class-function-slots)) + (error "~S is not a defined type class method." name))) + + +(eval-when (:compile-toplevel :execute) + +;;; INVOKE-TYPE-METHOD -- Interface +;;; +;;; Invoke a type method on TYPE1 and TYPE2. If the two types have the same +;;; class, invoke the simple method. Otherwise, invoke any complex method. If +;;; there isn't a distinct complex-arg1 method, then swap the arguments when +;;; calling type1's method. If no applicable method, return DEFAULT. +;;; + +(defmacro invoke-type-method (simple complex-arg2 type1 type2 &key + (default '(values nil t)) + complex-arg1) + (let ((simple (class-function-slot-or-lose simple)) + (cslot1 (class-function-slot-or-lose (or complex-arg1 complex-arg2))) + (cslot2 (class-function-slot-or-lose complex-arg2))) + (once-only ((n-type1 type1) + (n-type2 type2)) + (once-only ((class1 `(ctype-class-info ,n-type1)) + (class2 `(ctype-class-info ,n-type2))) + `(if (eq ,class1 ,class2) + (funcall (%svref ,class1 ,simple) ,n-type1 ,n-type2) + ,(once-only ((complex1 `(%svref ,class1 ,cslot1)) + (complex2 `(%svref ,class2 ,cslot2))) + `(cond (,complex2 (funcall ,complex2 ,n-type1 ,n-type2)) + (,complex1 + ,(if complex-arg1 + `(funcall ,complex1 ,n-type1 ,n-type2) + `(funcall ,complex1 ,n-type2 ,n-type1))) + (t ,default)))))))) + + + +;;;; Utilities: + +;;; ANY-TYPE-OP, EVERY-TYPE-OP -- Interface +;;; +;;; Like ANY and EVERY, except that we handle two-arg uncertain predicates. +;;; If the result is uncertain, then we return Default from the block PUNT. +;;; If LIST-FIRST is true, then the list element is the first arg, otherwise +;;; the second. +;;; +(defmacro any-type-op (op thing list &key (default '(values nil nil)) + list-first) + (let ((n-this (gensym)) + (n-thing (gensym)) + (n-val (gensym)) + (n-win (gensym)) + (n-uncertain (gensym))) + `(let ((,n-thing ,thing) + (,n-uncertain nil)) + (dolist (,n-this ,list + (if ,n-uncertain + (return-from PUNT ,default) + nil)) + (multiple-value-bind (,n-val ,n-win) + ,(if list-first + `(,op ,n-this ,n-thing) + `(,op ,n-thing ,n-this)) + (unless ,n-win (setq ,n-uncertain t)) + (when ,n-val (return t))))))) +;;; +(defmacro every-type-op (op thing list &key (default '(values nil nil)) + list-first) + (let ((n-this (gensym)) + (n-thing (gensym)) + (n-val (gensym)) + (n-win (gensym))) + `(let ((,n-thing ,thing)) + (dolist (,n-this ,list t) + (multiple-value-bind (,n-val ,n-win) + ,(if list-first + `(,op ,n-this ,n-thing) + `(,op ,n-thing ,n-this)) + (unless ,n-win (return-from PUNT ,default)) + (unless ,n-val (return nil))))))) + +) + + +;;; VANILLA-INTERSECTION -- Interface +;;; +;;; Compute the intersection for types that intersect only when one is a +;;; hierarchical subtype of the other. +;;; +(defun vanilla-intersection (type1 type2) + (multiple-value-bind (stp1 win1) + (csubtypep type1 type2) + (multiple-value-bind (stp2 win2) + (csubtypep type2 type1) + (cond (stp1 (values type1 t)) + (stp2 (values type2 t)) + ((and win1 win2) (values *empty-type* t)) + (t + (values type1 nil)))))) + + +;;; VANILLA-UNION -- Interface +;;; +(defun vanilla-union (type1 type2) + (cond ((csubtypep type1 type2) type2) + ((csubtypep type2 type1) type1) + (t nil))) + +(defun hierarchical-intersection2 (type1 type2) + (multiple-value-bind (subtypep1 win1) (csubtypep type1 type2) + (multiple-value-bind (subtypep2 win2) (csubtypep type2 type1) + (cond (subtypep1 type1) + (subtypep2 type2) + ((and win1 win2) *empty-type*) + (t nil))))) + +(defun hierarchical-union2 (type1 type2) + (cond ((csubtypep type1 type2) type2) + ((csubtypep type2 type1) type1) + (t nil))) + +;;; DELEGATE-COMPLEX-{SUBTYPEP-ARG2,INTERSECTION} -- Interface +;;; +;;; These functions are used as method for types which need a complex +;;; subtypep method to handle some superclasses, but cover a subtree of the +;;; type graph (i.e. there is no simple way for any other type class to be a +;;; subtype.) There are always still complex ways, namely UNION and MEMBER +;;; types, so we must give TYPE1's method a chance to run, instead of +;;; immediately returning NIL, T. +;;; +(defun delegate-complex-subtypep-arg2 (type1 type2) + (let ((subtypep-arg1 + (type-class-complex-subtypep-arg1 + (ctype-class-info type1)))) + (if subtypep-arg1 + (funcall subtypep-arg1 type1 type2) + (values nil t)))) +;;; +(defun delegate-complex-intersection (type1 type2) + (let ((method (type-class-complex-intersection (ctype-class-info type1)))) + (if (and method (not (eq method #'delegate-complex-intersection))) + (funcall method type2 type1) + (hierarchical-intersection2 type1 type2)))) + +;;; HAS-SUPERCLASSES-COMPLEX-SUBTYPEP-ARG1 -- Internal +;;; +;;; Used by DEFINE-SUPERCLASSES to define the SUBTYPE-ARG1 method. Info is +;;; a list of conses (SUPERCLASS-CLASS . {GUARD-TYPE-SPECIFIER | NIL}). Will +;;; never be called with a hairy type as type2, since the hairy type type2 +;;; method gets first crack. +;;; +#| +(defun has-superclasses-complex-subtypep-arg1 (type1 type2 info) + (values + (and (typep type2 'class) + (dolist (x info nil) + (when (or (not (cdr x)) + (csubtypep type1 (specifier-type (cdr x)))) + (return + (or (eq type2 (car x)) + (let ((inherits (layout-inherits (class-layout (car x))))) + (dotimes (i (length inherits) nil) + (when (eq type2 (layout-class (svref inherits i))) + (return t))))))))) + t)) +|# + +(eval-when (:compile-toplevel :execute) +;;; DEFINE-SUPERCLASSES -- Interface +;;; +;;; Takes a list of specs of the form (superclass &optional guard). +;;; Consider one spec (with no guard): any instance of type-class is also a +;;; subtype of SUPERCLASS and of any of its superclasses. If there are +;;; multiple specs, then some will have guards. We choose the first spec whose +;;; guard is a supertype of TYPE1 and use its superclass. In effect, a +;;; sequence of guards G0, G1, G2 is actually G0, (and G1 (not G0)), +;;; (and G2 (not (or G0 G1))). +;;; +#| +(defmacro define-superclasses (type-class &rest specs) + (let ((info + (mapcar #'(lambda (spec) + (destructuring-bind (super &optional guard) + spec + (cons (find-class super) guard))) + specs))) + `(progn + (setf (type-class-complex-subtypep-arg1 + (type-class-or-lose ',type-class)) + #'(lambda (type1 type2) + (has-superclasses-complex-subtypep-arg1 type1 type2 ',info))) + + (setf (type-class-complex-subtypep-arg2 + (type-class-or-lose ',type-class)) + #'delegate-complex-subtypep-arg2) + + (setf (type-class-complex-intersection + (type-class-or-lose ',type-class)) + #'delegate-complex-intersection)))) +|# + +); eval-when (compile eval) + + +(defun reparse-unknown-ctype (type) + (if (unknown-ctype-p type) + (specifier-type (type-specifier type)) + type)) + +(defun swapped-args-fun (f) + #'(lambda (x y) + (funcall f y x))) + +(defun equal-but-no-car-recursion (x y) + (cond ((eql x y) t) + ((consp x) + (and (consp y) + (eql (car x) (car y)) + (equal-but-no-car-recursion (cdr x) (cdr y)))) + (t nil))) + +(defun any/type (op thing list) + (declare (type function op)) + (let ((certain? t)) + (dolist (i list (values nil certain?)) + (multiple-value-bind (sub-value sub-certain?) (funcall op thing i) + (if sub-certain? + (when sub-value (return (values t t))) + (setf certain? nil)))))) + +(defun every/type (op thing list) + (declare (type function op)) + (let ((certain? t)) + (dolist (i list (if certain? (values t t) (values nil nil))) + (multiple-value-bind (sub-value sub-certain?) (funcall op thing i) + (if sub-certain? + (unless sub-value (return (values nil t))) + (setf certain? nil)))))) + +(defun invoke-complex-=-other-method (type1 type2) + (let* ((type-class (ctype-class-info type1)) + (method-fun (type-class-complex-= type-class))) + (if method-fun + (funcall (the function method-fun) type2 type1) + (values nil t)))) + +(defun invoke-complex-subtypep-arg1-method (type1 type2 &optional subtypep win) + (let* ((type-class (ctype-class-info type1)) + (method-fun (type-class-complex-subtypep-arg1 type-class))) + (if method-fun + (funcall (the function method-fun) type1 type2) + (values subtypep win)))) + +(defun type-might-contain-other-types-p (type) + (or (hairy-ctype-p type) + (negation-ctype-p type) + (union-ctype-p type) + (intersection-ctype-p type))) + + +(eval-when (:compile-toplevel :execute) + +(defmacro define-type-method ((class method &rest more-methods) + lambda-list &body body) + `(progn + (let* ((fn (nfunction (,class ,method ,@more-methods) + (lambda ,lambda-list ,@body)))) + ,@(mapcar #'(lambda (method) + `(setf (%svref + (type-class-or-lose ',class) + ,(class-function-slot-or-lose method)) + fn)) + (cons method more-methods))) + nil)) + +) + + +(defun ctype-p (x) + (and (eql (typecode x) target::subtag-istruct) + (memq (istruct-type-name x) + '#.(cons 'ctype + (cons 'unknown-ctype + (append (mapcar #'class-name + (class-direct-subclasses (find-class 'args-ctype))) + (mapcar #'class-name + (class-direct-subclasses (find-class 'ctype))))))))) + + +(setf (type-predicate 'ctype) 'ctype-p) + + +;;;; Function and Values types. +;;; +;;; Pretty much all of the general type operations are illegal on VALUES +;;; types, since we can't discriminate using them, do SUBTYPEP, etc. FUNCTION +;;; types are acceptable to the normal type operations, but are generally +;;; considered to be equivalent to FUNCTION. These really aren't true types in +;;; any type theoretic sense, but we still parse them into CTYPE structures for +;;; two reasons: +;;; -- Parsing and unparsing work the same way, and indeed we can't tell +;;; whether a type is a function or values type without parsing it. +;;; -- Many of the places that can be annotated with real types can also be +;;; annotated function or values types. + +;; Methods on the VALUES type class. + +(defun make-values-ctype (&key + required + optional + rest + keyp + keywords + allowp) + (%istruct 'values-ctype + (type-class-or-lose 'values) + nil + required + optional + rest + keyp + keywords + allowp + )) + +(defun values-ctype-p (x) (istruct-typep x 'values-ctype)) +(setf (type-predicate 'values-ctype) 'values-ctype-p) + + +(define-type-method (values :simple-subtypep :complex-subtypep-arg1) + (type1 type2) + (declare (ignore type2)) + (error "Subtypep is illegal on this type:~% ~S" (type-specifier type1))) + +(define-type-method (values :complex-subtypep-arg2) + (type1 type2) + (declare (ignore type1)) + (error "Subtypep is illegal on this type:~% ~S" (type-specifier type2))) + + +(define-type-method (values :unparse) (type) + (cons 'values (unparse-args-types type))) + + +;;; TYPE=-LIST -- Internal +;;; +;;; Return true if List1 and List2 have the same elements in the same +;;; positions according to TYPE=. We return NIL, NIL if there is an uncertain +;;; comparison. +;;; +(defun type=-list (list1 list2) + (declare (list list1 list2)) + (do ((types1 list1 (cdr types1)) + (types2 list2 (cdr types2))) + ((or (null types1) (null types2)) + (if (or types1 types2) + (values nil t) + (values t t))) + (multiple-value-bind (val win) + (type= (first types1) (first types2)) + (unless win + (return (values nil nil))) + (unless val + (return (values nil t)))))) + +(define-type-method (values :simple-=) (type1 type2) + (let ((rest1 (args-ctype-rest type1)) + (rest2 (args-ctype-rest type2))) + (cond ((or (args-ctype-keyp type1) (args-ctype-keyp type2) + (args-ctype-allowp type1) (args-ctype-allowp type2)) + (values nil nil)) + ((and rest1 rest2 (type/= rest1 rest2)) + (type= rest1 rest2)) + ((or rest1 rest2) + (values nil t)) + (t + (multiple-value-bind (req-val req-win) + (type=-list (values-ctype-required type1) + (values-ctype-required type2)) + (multiple-value-bind (opt-val opt-win) + (type=-list (values-ctype-optional type1) + (values-ctype-optional type2)) + (values (and req-val opt-val) (and req-win opt-win)))))))) + + +;; Methods on the FUNCTION type class. + + +(defun make-function-ctype (&key + required + optional + rest + keyp + keywords + allowp + wild-args + returns) + (%istruct 'function-ctype + (type-class-or-lose 'function) + nil + required + optional + rest + keyp + keywords + allowp + wild-args + returns + )) + +(defun function-ctype-p (x) (istruct-typep x 'function-ctype)) +(setf (type-predicate 'function-ctype) 'function-ctype-p) + +;;; A flag that we can bind to cause complex function types to be unparsed as +;;; FUNCTION. Useful when we want a type that we can pass to TYPEP. +;;; +(defvar *unparse-function-type-simplify* nil) + +(define-type-method (function :unparse) (type) + (if *unparse-function-type-simplify* + 'function + (list 'function + (if (function-ctype-wild-args type) + '* + (unparse-args-types type)) + (type-specifier + (function-ctype-returns type))))) + +;;; Since all function types are equivalent to FUNCTION, they are all subtypes +;;; of each other. +;;; + +(define-type-method (function :simple-subtypep) (type1 type2) + (flet ((fun-type-simple-p (type) + (not (or (function-ctype-rest type) + (function-ctype-keyp type)))) + (every-csubtypep (types1 types2) + (loop + for a1 in types1 + for a2 in types2 + do (multiple-value-bind (res sure-p) + (csubtypep a1 a2) + (unless res (return (values res sure-p)))) + finally (return (values t t))))) + (macrolet ((3and (x y) + `(multiple-value-bind (val1 win1) ,x + (if (and (not val1) win1) + (values nil t) + (multiple-value-bind (val2 win2) ,y + (if (and val1 val2) + (values t t) + (values nil (and win2 (not val2))))))))) + (3and (values-subtypep (function-ctype-returns type1) + (function-ctype-returns type2)) + (cond ((function-ctype-wild-args type2) (values t t)) + ((function-ctype-wild-args type1) + (cond ((function-ctype-keyp type2) (values nil nil)) + ((not (function-ctype-rest type2)) (values nil t)) + ((not (null (function-ctype-required type2))) (values nil t)) + (t (3and (type= *universal-type* (function-ctype-rest type2)) + (every/type #'type= *universal-type* + (function-ctype-optional type2)))))) + ((not (and (fun-type-simple-p type1) + (fun-type-simple-p type2))) + (values nil nil)) + (t (multiple-value-bind (min1 max1) (function-type-nargs type1) + (multiple-value-bind (min2 max2) (function-type-nargs type2) + (cond ((or (> max1 max2) (< min1 min2)) + (values nil t)) + ((and (= min1 min2) (= max1 max2)) + (3and (every-csubtypep (function-ctype-required type1) + (function-ctype-required type2)) + (every-csubtypep (function-ctype-optional type1) + (function-ctype-optional type2)))) + (t (every-csubtypep + (concatenate 'list + (function-ctype-required type1) + (function-ctype-optional type1)) + (concatenate 'list + (function-ctype-required type2) + (function-ctype-optional type2))))))))))))) + + + +;(define-superclasses function (function)) + + +;;; The union or intersection of two FUNCTION types is FUNCTION. +;;; (unless the types are type=) +;;; +(define-type-method (function :simple-union) (type1 type2) + (if (type= type1 type2) + type1 + (specifier-type 'function))) + +;;; +(define-type-method (function :simple-intersection) (type1 type2) + (if (type= type1 type2) + type1 + (specifier-type 'function))) + + +(define-type-method (function :complex-intersection) (type1 type2) + (declare (type function-ctype type2)) + (let ((function (specifier-type 'function))) + (if (eq type1 function) + type2 + (type-intersection2 type1 function)))) + + + +;;; ### Not very real, but good enough for redefining transforms according to +;;; type: +;;; +(define-type-method (function :simple-=) (type1 type2) + (values (equalp type1 type2) t)) + +;;; The CONSTANT-TYPE structure represents a use of the CONSTANT-ARGUMENT "type +;;; specifier", which is only meaningful in function argument type specifiers +;;; used within the compiler. +;;; + +(defun clone-type-class-methods (src-tc dest-tc) + (do* ((n (uvsize src-tc)) + (i 2 (1+ i))) + ((= i n) dest-tc) + (declare (fixnum i n)) + (setf (%svref dest-tc i) + (%svref src-tc i)))) + +(clone-type-class-methods (type-class-or-lose 'values) (type-class-or-lose 'constant)) + +(defun make-constant-ctype (&key type) + (%istruct 'constant-ctype + (type-class-or-lose 'constant) + nil + type)) + +(defun constant-ctype-p (x) (istruct-typep x 'constant-ctype)) +(setf (type-predicate 'constant-ctype) 'constant-ctype-p) + +(define-type-method (constant :unparse) (type) + `(constant-argument ,(type-specifier (constant-ctype-type type)))) + +(define-type-method (constant :simple-=) (type1 type2) + (type= (constant-ctype-type type1) (constant-ctype-type type2))) + +(def-type-translator constant-argument (type &environment env) + (make-constant-ctype :type (specifier-type type env))) + + +;;; Parse-Args-Types -- Internal +;;; +;;; Given a lambda-list like values type specification and a Args-Type +;;; structure, fill in the slots in the structure accordingly. This is used +;;; for both FUNCTION and VALUES types. +;;; + +(defun parse-args-types (lambda-list result &optional env) + (multiple-value-bind (required optional restp rest keyp keys allowp aux) + (parse-lambda-list lambda-list) + (when aux + (error "&Aux in a FUNCTION or VALUES type: ~S." lambda-list)) + (flet ((parse (spec) (specifier-type spec env))) + (setf (args-ctype-required result) (mapcar #'parse required)) + (setf (args-ctype-optional result) (mapcar #'parse optional)) + (setf (args-ctype-rest result) (if restp (parse rest) nil)) + (setf (args-ctype-keyp result) keyp) + (let* ((key-info ())) + (dolist (key keys) + (when (or (atom key) (/= (length key) 2)) + (signal-program-error "Keyword type description is not a two-list: ~S." key)) + (let ((kwd (first key))) + (when (member kwd key-info :test #'eq :key #'(lambda (x) (key-info-name x))) + (signal-program-error "Repeated keyword ~S in lambda list: ~S." kwd lambda-list)) + (push (make-key-info :name kwd + :type (parse (second key))) key-info))) + (setf (args-ctype-keywords result) (nreverse key-info))) + (setf (args-ctype-allowp result) allowp)))) + +;;; Unparse-Args-Types -- Internal +;;; +;;; Return the lambda-list like type specification corresponding +;;; to a Args-Type. +;;; +(defun unparse-args-types (type) + (let* ((result ())) + + (dolist (arg (args-ctype-required type)) + (push (type-specifier arg) result)) + + (when (args-ctype-optional type) + (push '&optional result) + (dolist (arg (args-ctype-optional type)) + (push (type-specifier arg) result))) + + (when (args-ctype-rest type) + (push '&rest result) + (push (type-specifier (args-ctype-rest type)) result)) + + (when (args-ctype-keyp type) + (push '&key result) + (dolist (key (args-ctype-keywords type)) + (push (list (key-info-name key) + (type-specifier (key-info-type key))) result))) + + (when (args-ctype-allowp type) + (push '&allow-other-keys result)) + + (nreverse result))) + +(def-type-translator function (&optional (args '*) (result '*) &environment env) + (let ((res (make-function-ctype + :returns (values-specifier-type result env)))) + (if (eq args '*) + (setf (function-ctype-wild-args res) t) + (parse-args-types args res env)) + res)) + +(def-type-translator values (&rest values &environment env) + (let ((res (make-values-ctype))) + (parse-args-types values res env) + (when (or (values-ctype-keyp res) (values-ctype-allowp res)) + (signal-program-error "&KEY or &ALLOW-OTHER-KEYS in values type: ~s" + res)) + res)) + +;;; Single-Value-Type -- Interface +;;; +;;; Return the type of the first value indicated by Type. This is used by +;;; people who don't want to have to deal with values types. +;;; +(defun single-value-type (type) + (declare (type ctype type)) + (cond ((values-ctype-p type) + (or (car (args-ctype-required type)) + (if (args-ctype-optional type) + (type-union (car (args-ctype-optional type)) + (specifier-type 'null))) + (args-ctype-rest type) + (specifier-type 'null))) + ((eq type *wild-type*) + *universal-type*) + (t + type))) + + +;;; FUNCTION-TYPE-NARGS -- Interface +;;; +;;; Return the minmum number of arguments that a function can be called +;;; with, and the maximum number or NIL. If not a function type, return +;;; NIL, NIL. +;;; +(defun function-type-nargs (type) + (declare (type ctype type)) + (if (function-ctype-p type) + (let ((fixed (length (args-ctype-required type)))) + (if (or (args-ctype-rest type) + (args-ctype-keyp type) + (args-ctype-allowp type)) + (values fixed nil) + (values fixed (+ fixed (length (args-ctype-optional type)))))) + (values nil nil))) + + +;;; Values-Types -- Interface +;;; +;;; Determine if Type corresponds to a definite number of values. The first +;;; value is a list of the types for each value, and the second value is the +;;; number of values. If the number of values is not fixed, then return NIL +;;; and :Unknown. +;;; +(defun values-types (type) + (declare (type ctype type)) + (cond ((eq type *wild-type*) + (values nil :unknown)) + ((not (values-ctype-p type)) + (values (list type) 1)) + ((or (args-ctype-optional type) + (args-ctype-rest type) + (args-ctype-keyp type) + (args-ctype-allowp type)) + (values nil :unknown)) + (t + (let ((req (args-ctype-required type))) + (values (mapcar #'single-value-type req) (length req)))))) + + +;;; Values-Type-Types -- Internal +;;; +;;; Return two values: +;;; 1] A list of all the positional (fixed and optional) types. +;;; 2] The rest type (if any). If keywords allowed, *universal-type*. If no +;;; keywords or rest, *empty-type*. +;;; +(defun values-type-types (type &optional (default-type *empty-type*)) + (declare (type values-ctype type)) + (values (append (args-ctype-required type) + (args-ctype-optional type)) + (cond ((args-ctype-keyp type) *universal-type*) + ((args-ctype-rest type)) + (t default-type)))) + + +;;; Fixed-Values-Op -- Internal +;;; +;;; Return a list of Operation applied to the types in Types1 and Types2, +;;; padding with Rest2 as needed. Types1 must not be shorter than Types2. The +;;; second value is T if Operation always returned a true second value. +;;; +(defun fixed-values-op (types1 types2 rest2 operation) + (declare (list types1 types2) (type ctype rest2) (type function operation)) + (let ((exact t)) + (values (mapcar #'(lambda (t1 t2) + (multiple-value-bind (res win) + (funcall operation t1 t2) + (unless win (setq exact nil)) + res)) + types1 + (append types2 + (make-list (- (length types1) (length types2)) + :initial-element rest2))) + exact))) + +;;; Coerce-To-Values -- Internal +;;; +;;; If Type isn't a values type, then make it into one: +;;; ==> (values type &rest t) +;;; +(defun coerce-to-values (type) + (declare (type ctype type)) + (if (values-ctype-p type) + type + (make-values-ctype :required (list type)))) + + +;;; Args-Type-Op -- Internal +;;; +;;; Do the specified Operation on Type1 and Type2, which may be any type, +;;; including Values types. With values types such as: +;;; (values a0 a1) +;;; (values b0 b1) +;;; +;;; We compute the more useful result: +;;; (values ( a0 b0) ( a1 b1)) +;;; +;;; Rather than the precise result: +;;; ( (values a0 a1) (values b0 b1)) +;;; +;;; This has the virtue of always keeping the values type specifier outermost, +;;; and retains all of the information that is really useful for static type +;;; analysis. We want to know what is always true of each value independently. +;;; It is worthless to know that IF the first value is B0 then the second will +;;; be B1. +;;; +;;; If the values count signatures differ, then we produce result with the +;;; required value count chosen by Nreq when applied to the number of required +;;; values in type1 and type2. Any &key values become &rest T (anyone who uses +;;; keyword values deserves to lose.) +;;; +;;; The second value is true if the result is definitely empty or if Operation +;;; returned true as its second value each time we called it. Since we +;;; approximate the intersection of values types, the second value being true +;;; doesn't mean the result is exact. +;;; +(defun args-type-op (type1 type2 operation nreq default-type) + (declare (type ctype type1 type2 default-type) + (type function operation nreq)) + (if (eq type1 type2) + (values type1 t) + (if (or (values-ctype-p type1) (values-ctype-p type2)) + (let ((type1 (coerce-to-values type1)) + (type2 (coerce-to-values type2))) + (multiple-value-bind (types1 rest1) + (values-type-types type1 default-type) + (multiple-value-bind (types2 rest2) + (values-type-types type2 default-type) + (multiple-value-bind (rest rest-exact) + (funcall operation rest1 rest2) + (multiple-value-bind + (res res-exact) + (if (< (length types1) (length types2)) + (fixed-values-op types2 types1 rest1 operation) + (fixed-values-op types1 types2 rest2 operation)) + (let* ((req (funcall nreq + (length (args-ctype-required type1)) + (length (args-ctype-required type2)))) + (required (subseq res 0 req)) + (opt (subseq res req)) + (opt-last (position rest opt :test-not #'type= + :from-end t))) + (if (find *empty-type* required :test #'type=) + (values *empty-type* t) + (values (make-values-ctype + :required required + :optional (if opt-last + (subseq opt 0 (1+ opt-last)) + ()) + :rest (if (eq rest *empty-type*) nil rest)) + (and rest-exact res-exact))))))))) + (funcall operation type1 type2)))) + +;;; Values-Type-Union, Values-Type-Intersection -- Interface +;;; +;;; Do a union or intersection operation on types that might be values +;;; types. The result is optimized for utility rather than exactness, but it +;;; is guaranteed that it will be no smaller (more restrictive) than the +;;; precise result. +;;; + +(defun values-type-union (type1 type2) + (declare (type ctype type1 type2)) + (cond ((or (eq type1 *wild-type*) (eq type2 *wild-type*)) *wild-type*) + ((eq type1 *empty-type*) type2) + ((eq type2 *empty-type*) type1) + (t + (values (args-type-op type1 type2 #'type-union #'min *empty-type*))))) + +(defun values-type-intersection (type1 type2) + (declare (type ctype type1 type2)) + (cond ((eq type1 *wild-type*) (values type2 t)) + ((eq type2 *wild-type*) (values type1 t)) + (t + (args-type-op type1 type2 #'type-intersection #'max + (specifier-type 'null))))) + + +;;; Values-Types-Intersect -- Interface +;;; +;;; Like Types-Intersect, except that it sort of works on values types. +;;; Note that due to the semantics of Values-Type-Intersection, this might +;;; return {T, T} when there isn't really any intersection (?). +;;; +(defun values-types-intersect (type1 type2) + (cond ((or (eq type1 *empty-type*) (eq type2 *empty-type*)) + (values t t)) + ((or (values-ctype-p type1) (values-ctype-p type2)) + (multiple-value-bind (res win) + (values-type-intersection type1 type2) + (values (not (eq res *empty-type*)) + win))) + (t + (types-intersect type1 type2)))) + +;;; Values-Subtypep -- Interface +;;; +;;; A subtypep-like operation that can be used on any types, including +;;; values types. +;;; + +(defun values-subtypep (type1 type2) + (declare (type ctype type1 type2)) + (cond ((eq type2 *wild-type*) (values t t)) + ((eq type1 *wild-type*) + (values (eq type2 *universal-type*) t)) + ((not (values-types-intersect type1 type2)) + (values nil t)) + (t + (if (or (values-ctype-p type1) (values-ctype-p type2)) + (let ((type1 (coerce-to-values type1)) + (type2 (coerce-to-values type2))) + (multiple-value-bind (types1 rest1) + (values-type-types type1) + (multiple-value-bind (types2 rest2) + (values-type-types type2) + (cond ((< (length (values-ctype-required type1)) + (length (values-ctype-required type2))) + (values nil t)) + ((< (length types1) (length types2)) + (values nil nil)) + ((or (values-ctype-keyp type1) + (values-ctype-keyp type2)) + (values nil nil)) + (t + (do ((t1 types1 (rest t1)) + (t2 types2 (rest t2))) + ((null t2) + (csubtypep rest1 rest2)) + (multiple-value-bind + (res win-p) + (csubtypep (first t1) (first t2)) + (unless win-p + (return (values nil nil))) + (unless res + (return (values nil t)))))))))) + (csubtypep type1 type2))))) + + + +;;;; Type method interfaces: + +;;; Csubtypep -- Interface +;;; +;;; Like subtypep, only works on Type structures. +;;; +(defun csubtypep (type1 type2) + (declare (type ctype type1 type2)) + (unless (typep type1 'ctype) + (report-bad-arg type1 'ctype)) + (unless (typep type2 'ctype) + (report-bad-arg type2 'ctype)) + (cond ((or (eq type1 type2) + (eq type1 *empty-type*) + (eq type2 *wild-type*)) + (values t t)) + (t + (invoke-type-method :simple-subtypep :complex-subtypep-arg2 + type1 type2 + :complex-arg1 :complex-subtypep-arg1)))) + +;;; Type1 is a type-epecifier; type2 is a TYPE-CELL which may cache +;;; a mapping between a type-specifier and a CTYPE. +(defun cell-csubtypep-2 (type-specifier type-cell) + (let* ((type1 (specifier-type type-specifier)) + (type2 (or (type-cell-ctype type-cell) + (let* ((ctype (specifier-type + (type-cell-type-specifier type-cell)))) + (when (cacheable-ctype-p ctype) + (setf (type-cell-ctype type-cell) ctype)) + ctype)))) + (cond ((or (eq type1 type2) + (eq type1 *empty-type*) + (eq type2 *wild-type*)) + (values t t)) + (t + (invoke-type-method :simple-subtypep :complex-subtypep-arg2 + type1 type2 + :complex-arg1 :complex-subtypep-arg1))))) + + + +;;; Type= -- Interface +;;; +;;; If two types are definitely equivalent, return true. The second value +;;; indicates whether the first value is definitely correct. This should only +;;; fail in the presence of Hairy types. +;;; + +(defun type= (type1 type2) + (declare (type ctype type1 type2)) + (if (eq type1 type2) + (values t t) + (invoke-type-method :simple-= :complex-= type1 type2))) + +;;; TYPE/= -- Interface +;;; +;;; Not exactly the negation of TYPE=, since when the relationship is +;;; uncertain, we still return NIL, NIL. This is useful in cases where the +;;; conservative assumption is =. +;;; +(defun type/= (type1 type2) + (declare (type ctype type1 type2)) + (multiple-value-bind (res win) + (type= type1 type2) + (if win + (values (not res) t) + (values nil nil)))) + +;;; Type-Union -- Interface +;;; +;;; Find a type which includes both types. Any inexactness is represented +;;; by the fuzzy element types; we return a single value that is precise to the +;;; best of our knowledge. This result is simplified into the canonical form, +;;; thus is not a UNION type unless there is no other way to represent the +;;; result. +;;; + +(defun type-union (&rest input-types) + (%type-union input-types)) + +(defun %type-union (input-types) + (let* ((simplified (simplify-unions input-types))) + (cond ((null simplified) *empty-type*) + ((null (cdr simplified)) (car simplified)) + (t (make-union-ctype simplified))))) + +(defun simplify-unions (types) + (when types + (multiple-value-bind (first rest) + (if (union-ctype-p (car types)) + (values (car (union-ctype-types (car types))) + (append (cdr (union-ctype-types (car types))) + (cdr types))) + (values (car types) (cdr types))) + (let ((rest (simplify-unions rest)) u) + (dolist (r rest (cons first rest)) + (when (setq u (type-union2 first r)) + (return (simplify-unions (nsubstitute u r rest))))))))) + +(defun type-union2 (type1 type2) + (declare (type ctype type1 type2)) + (setq type1 (reparse-unknown-ctype type1)) + (setq type2 (reparse-unknown-ctype type2)) + (cond ((eq type1 type2) type1) + ((csubtypep type1 type2) type2) + ((csubtypep type2 type1) type1) + (t + (flet ((1way (x y) + (invoke-type-method :simple-union :complex-union + x y + :default nil))) + (or (1way type1 type2) + (1way type2 type1)))))) + +;;; Return as restrictive and simple a type as we can discover that is +;;; no more restrictive than the intersection of TYPE1 and TYPE2. At +;;; worst, we arbitrarily return one of the arguments as the first +;;; value (trying not to return a hairy type). +(defun type-approx-intersection2 (type1 type2) + (declare (type ctype type1 type2)) + (cond ((type-intersection2 type1 type2)) + ((hairy-ctype-p type1) type2) + (t type1))) + + +;;; Type-Intersection -- Interface +;;; +;;; Return as restrictive a type as we can discover that is no more +;;; restrictive than the intersection of Type1 and Type2. The second value is +;;; true if the result is exact. At worst, we randomly return one of the +;;; arguments as the first value (trying not to return a hairy type). +;;; + +(defun type-intersection (&rest input-types) + (%type-intersection input-types)) + +(defun %type-intersection (input-types) + (let ((simplified (simplify-intersections input-types))) + ;;(declare (type (vector ctype) simplified)) + ;; We want to have a canonical representation of types (or failing + ;; that, punt to HAIRY-TYPE). Canonical representation would have + ;; intersections inside unions but not vice versa, since you can + ;; always achieve that by the distributive rule. But we don't want + ;; to just apply the distributive rule, since it would be too easy + ;; to end up with unreasonably huge type expressions. So instead + ;; we try to generate a simple type by distributing the union; if + ;; the type can't be made simple, we punt to HAIRY-TYPE. + (if (and (cdr simplified) (some #'union-ctype-p simplified)) + (let* ((first-union (find-if #'union-ctype-p simplified)) + (other-types (remove first-union simplified)) + (distributed (maybe-distribute-one-union first-union other-types))) + (if distributed + (apply #'type-union distributed) + (make-hairy-ctype + :specifier `(and ,@(mapcar #'type-specifier simplified))))) + (cond + ((null simplified) *universal-type*) + ((null (cdr simplified)) (car simplified)) + (t (make-intersection-ctype + (some #'(lambda (c) (ctype-enumerable c)) simplified) + simplified)))))) + +(defun simplify-intersections (types) + (when types + (let ((first (if (typep (car types) 'ctype) + (%car types) + (specifier-type (%car types))))) + (multiple-value-bind (first rest) + (if (intersection-ctype-p first) + (values (car (intersection-ctype-types first)) + (append (cdr (intersection-ctype-types first)) + (cdr types))) + (values first (cdr types))) + (let ((rest (simplify-intersections rest)) u) + (dolist (r rest (cons first rest)) + (when (setq u (type-intersection2 first r)) + (return (simplify-intersections (nsubstitute u r rest)))))))))) + +(defun type-intersection2 (type1 type2) + (declare (type ctype type1 type2)) + (setq type1 (reparse-unknown-ctype type1)) + (setq type2 (reparse-unknown-ctype type2)) + (cond ((eq type1 type2) + type1) + ((or (intersection-ctype-p type1) + (intersection-ctype-p type2)) + ;; Intersections of INTERSECTION-TYPE should have the + ;; INTERSECTION-CTYPE-TYPES values broken out and intersected + ;; separately. The full TYPE-INTERSECTION function knows how + ;; to do that, so let it handle it. + (type-intersection type1 type2)) + ;; + ;; (AND (FUNCTION (T) T) GENERIC-FUNCTION) for instance, but + ;; not (AND (FUNCTION (T) T) (FUNCTION (T) T)). + ((let ((function (specifier-type 'function))) + (or (and (function-ctype-p type1) + (not (function-ctype-p type2)) + (neq function type2) + (csubtypep type2 function) + (not (csubtypep function type2))) + (and (function-ctype-p type2) + (not (function-ctype-p type1)) + (neq function type1) + (csubtypep type1 function) + (not (csubtypep function type1))))) + nil) + (t + (flet ((1way (x y) + (invoke-type-method :simple-intersection + :complex-intersection + x y + :default :no-type-method-found))) + (let ((xy (1way type1 type2))) + (or (and (not (eql xy :no-type-method-found)) xy) + (let ((yx (1way type2 type1))) + (or (and (not (eql yx :no-type-method-found)) yx) + (cond ((and (eql xy :no-type-method-found) + (eql yx :no-type-method-found)) + *empty-type*) + (t + nil)))))))))) + + + +(defun maybe-distribute-one-union (union-type types) + (let* ((intersection (apply #'type-intersection types)) + (union (mapcar (lambda (x) (type-intersection x intersection)) + (union-ctype-types union-type)))) + (if (notany (lambda (x) + (or (hairy-ctype-p x) + (intersection-ctype-p x))) + union) + union + nil))) + +;;; Types-Intersect -- Interface +;;; +;;; The first value is true unless the types don't intersect. The second +;;; value is true if the first value is definitely correct. NIL is considered +;;; to intersect with any type. If T is a subtype of either type, then we also +;;; return T, T. This way we consider hairy types to intersect with T. +;;; +(defun types-intersect (type1 type2) + (declare (type ctype type1 type2)) + (if (or (eq type1 *empty-type*) (eq type2 *empty-type*)) + (values t t) + (let ((intersection2 (type-intersection2 type1 type2))) + (cond ((not intersection2) + (if (or (csubtypep *universal-type* type1) + (csubtypep *universal-type* type2)) + (values t t) + (values t nil))) + ((eq intersection2 *empty-type*) (values nil t)) + (t (values t t)))))) + +;;; Type-Specifier -- Interface +;;; +;;; Return a Common Lisp type specifier corresponding to this type. +;;; +(defun type-specifier (type) + (unless (ctype-p type) + (setq type (require-type type 'ctype))) + (locally + (declare (type ctype type)) + (funcall (type-class-unparse (ctype-class-info type)) type))) + + +(defconstant compound-only-type-specifiers + ;; See CLHS Figure 4-4. + '(and mod satisfies eql not values member or)) + + +;;; VALUES-SPECIFIER-TYPE -- Interface +;;; +;;; Return the type structure corresponding to a type specifier. We pick +;;; off Structure types as a special case. +;;; + +(defun values-specifier-type-internal (orig env) + (or (info-type-builtin orig) ; this table could contain bytes etal and ands ors nots of built-in types - no classes + + ;; Now that we have our hands on the environment, we could pass it into type-expand, + ;; but we'd have no way of knowing whether the expansion depended on the env, so + ;; we wouldn't know if the result is safe to cache. So for now don't let type + ;; expanders see the env, which just means they won't see compile-time types. + (let ((spec (type-expand orig #+not-yet env))) + (cond + ((and (not (eq spec orig)) + (info-type-builtin spec))) + ((or (eq (info-type-kind spec) :instance) + (and (symbolp spec) + (typep (find-class spec nil env) 'compile-time-class))) + (let* ((class-ctype (%class.ctype (find-class spec t env)))) + (or (class-ctype-translation class-ctype) + class-ctype))) + ((typep spec 'class) + (let* ((class-ctype (%class.ctype spec))) + (or (class-ctype-translation class-ctype) + class-ctype))) + ((let ((cell (find-builtin-cell spec nil))) + (and cell (cdr cell)))) + (t + (when (member spec compound-only-type-specifiers) + (error 'invalid-type-specifier :typespec spec)) + (let* ((lspec (if (atom spec) (list spec) spec)) + (fun (info-type-translator (car lspec)))) + (cond (fun (funcall fun lspec env)) + ((or (and (consp spec) + (symbolp (car spec)) + (not (or (find-class (car spec) nil env) + (info-type-builtin (car spec))))) + (symbolp spec)) + (when *type-system-initialized* + (signal 'parse-unknown-type :specifier spec)) + ;; + ;; Inhibit caching... + nil) + (t + (error 'invalid-type-specifier :typespec spec))))))))) + +(eval-when (:compile-toplevel :execute) + (defconstant type-cache-size (ash 1 12)) + (defconstant type-cache-mask (1- type-cache-size))) + +(defun compile-time-ctype-p (ctype) + (and (typep ctype 'class-ctype) + (typep (class-ctype-class ctype) 'compile-time-class))) + + +;;; We can get in trouble if we try to cache certain kinds of ctypes, +;;; notably MEMBER types which refer to objects which might +;;; be stack-allocated or might be EQUAL without being EQL. +(defun cacheable-ctype-p (ctype) + (case (istruct-cell-name (%svref ctype 0)) + (member-ctype + (dolist (m (member-ctype-members ctype) t) + (when (or (typep m 'cons) + (typep m 'array)) + (return nil)))) + (union-ctype + (every #'cacheable-ctype-p (union-ctype-types ctype))) + (intersection-ctype + (every #'cacheable-ctype-p (intersection-ctype-types ctype))) + (array-ctype + (cacheable-ctype-p (array-ctype-element-type ctype))) + ((values-ctype function-ctype) + (and (every #'cacheable-ctype-p (values-ctype-required ctype)) + (every #'cacheable-ctype-p (values-ctype-optional ctype)) + (let* ((rest (values-ctype-rest ctype))) + (or (null rest) (cacheable-ctype-p rest))) + (every #'(lambda (info) + (cacheable-ctype-p (key-info-type info))) + (values-ctype-keywords ctype)) + (or (not (eq (istruct-cell-name (%svref ctype 0)) 'function-ctype)) + (let* ((result (function-ctype-returns ctype))) + (or (null result) + (cacheable-ctype-p result)))))) + (negation-ctype + (cacheable-ctype-p (negation-ctype-type ctype))) + (cons-ctype + (and (cacheable-ctype-p (cons-ctype-car-ctype ctype)) + (cacheable-ctype-p (cons-ctype-cdr-ctype ctype)))) + (unknown-ctype nil) + (class-ctype + (not (typep (class-ctype-class ctype) 'compile-time-class))) + ;; Anything else ? Simple things (numbers, classes) can't lose. + (t t))) + + + + +(defun hash-type-specifier (spec) + (logand (sxhash spec) type-cache-mask)) + + +(let* ((type-cache-specs (make-array type-cache-size)) + (type-cache-ctypes (make-array type-cache-size)) + (probes 0) + (hits 0) + (ncleared 0) + (locked nil) + (lock (make-lock))) + + (defun clear-type-cache () + (with-lock-grabbed (lock) + (%init-misc 0 type-cache-specs) + (%init-misc 0 type-cache-ctypes) + (incf ncleared)) + nil) + + (defun values-specifier-type (spec &optional env) + (if (typep spec 'class) + (let* ((class-ctype (%class.ctype spec))) + (or (class-ctype-translation class-ctype) class-ctype)) + (handler-case + (with-lock-grabbed (lock) + (if locked + (or (values-specifier-type-internal spec env) + (make-unknown-ctype :specifier spec)) + (unwind-protect + (progn + (setq locked t) + (if (or (symbolp spec) + (and (consp spec) + (symbolp (car spec)) + ;; hashing scheme uses equal, so only use when equivalent to eql + (not (and (eq (car spec) 'member) + (some (lambda (x) + (typep x '(or cons string bit-vector pathname))) + (cdr spec)))))) + (let* ((idx (hash-type-specifier spec))) + (incf probes) + (if (equal (svref type-cache-specs idx) spec) + (progn + (incf hits) + (svref type-cache-ctypes idx)) + (let* ((ctype (values-specifier-type-internal spec env))) + (if ctype + (progn + (when (cacheable-ctype-p ctype) + (setf (svref type-cache-specs idx) (copy-tree spec) ; in case it was stack-consed + (svref type-cache-ctypes idx) ctype)) + ctype) + (make-unknown-ctype :specifier spec))))) + (values-specifier-type-internal spec env))) + (setq locked nil)))) + (error (condition) (error condition))))) + + (defun type-cache-hit-rate () + (values hits probes)) + + (defun type-cache-locked-p () + locked) + + (defun lock-type-cache () + (setq locked t))) + + + + +;;; SPECIFIER-TYPE -- Interface +;;; +;;; Like VALUES-SPECIFIER-TYPE, except that we guarantee to never return a +;;; VALUES type. +;;; +(defun specifier-type (x &optional env) + (let ((res (values-specifier-type x env))) + (when (values-ctype-p res) + (signal-program-error "VALUES type illegal in this context:~% ~S" x)) + res)) + +(defun single-value-specifier-type (x &optional env) + (let ((res (specifier-type x env))) + (if (eq res *wild-type*) + *universal-type* + res))) + +(defun standardized-type-specifier (spec &optional env) + (handler-case + (type-specifier (specifier-type spec env)) + (program-error () spec) + (parse-unknown-type () spec))) + +(defun modified-numeric-type (base + &key + (class (numeric-ctype-class base)) + (format (numeric-ctype-format base)) + (complexp (numeric-ctype-complexp base)) + (low (numeric-ctype-low base)) + (high (numeric-ctype-high base)) + (enumerable (ctype-enumerable base))) + (make-numeric-ctype :class class + :format format + :complexp complexp + :low low + :high high + :enumerable enumerable)) + +;;; Precompute-Types -- Interface +;;; +;;; Take a list of type specifiers, compute the translation and define it as +;;; a builtin type. +;;; + +(defun precompute-types (specs) + (dolist (spec specs) + (let ((res (specifier-type spec))) + (when (numeric-ctype-p res) + (let ((pred (make-numeric-ctype-predicate res))) + (when pred (setf (numeric-ctype-predicate res) pred)))) + (unless (unknown-ctype-p res) + (setf (info-type-builtin spec) res) + (setf (info-type-kind spec) :primitive))))) + +;;;; Builtin types. + +;;; The NAMED-TYPE is used to represent *, T and NIL. These types must be +;;; super or sub types of all types, not just classes and * & NIL aren't +;;; classes anyway, so it wouldn't make much sense to make them built-in +;;; classes. +;;; + +(defun define-named-ctype (name) + (let* ((ctype (%istruct 'named-ctype + (type-class-or-lose 'named) + nil + name))) + (setf (info-type-kind name) :builtin + (info-type-builtin name) ctype))) + + +(defvar *wild-type* (define-named-ctype '*)) +(defvar *empty-type* (define-named-ctype nil)) +(defvar *universal-type* (define-named-ctype t)) + +(defun named-ctype-p (x) + (istruct-typep x 'named-ctype)) + +(setf (type-predicate 'named-ctype) 'named-ctype-p) + +(define-type-method (named :simple-=) (type1 type2) + (values (eq type1 type2) t)) + +(define-type-method (named :complex-=) (type1 type2) + (cond + ((and (eq type2 *empty-type*) + (intersection-ctype-p type1) + ;; not allowed to be unsure on these... FIXME: keep the list + ;; of CL types that are intersection types once and only + ;; once. + (not (or (type= type1 (specifier-type 'ratio)) + (type= type1 (specifier-type 'keyword))))) + ;; things like (AND (EQL 0) (SATISFIES ODDP)) or (AND FUNCTION + ;; STREAM) can get here. In general, we can't really tell + ;; whether these are equal to NIL or not, so + (values nil nil)) + ((type-might-contain-other-types-p type1) + (invoke-complex-=-other-method type1 type2)) + (t (values nil t)))) + + +(define-type-method (named :simple-subtypep) (type1 type2) + (values (or (eq type1 *empty-type*) (eq type2 *wild-type*)) t)) + +(define-type-method (named :complex-subtypep-arg1) (type1 type2) + (cond ((eq type1 *empty-type*) + t) + (;; When TYPE2 might be the universal type in disguise + (type-might-contain-other-types-p type2) + ;; Now that the UNION and HAIRY COMPLEX-SUBTYPEP-ARG2 methods + ;; can delegate to us (more or less as CALL-NEXT-METHOD) when + ;; they're uncertain, we can't just barf on COMPOUND-TYPE and + ;; HAIRY-TYPEs as we used to. Instead we deal with the + ;; problem (where at least part of the problem is cases like + ;; (SUBTYPEP T '(SATISFIES FOO)) + ;; or + ;; (SUBTYPEP T '(AND (SATISFIES FOO) (SATISFIES BAR))) + ;; where the second type is a hairy type like SATISFIES, or + ;; is a compound type which might contain a hairy type) by + ;; returning uncertainty. + (values nil nil)) + (t + ;; By elimination, TYPE1 is the universal type. + (assert (or (eq type1 *wild-type*) (eq type1 *universal-type*))) + ;; This case would have been picked off by the SIMPLE-SUBTYPEP + ;; method, and so shouldn't appear here. + (assert (not (eq type2 *universal-type*))) + ;; Since TYPE2 is not EQ *UNIVERSAL-TYPE* and is not the + ;; universal type in disguise, TYPE2 is not a superset of TYPE1. + (values nil t)))) + + +(define-type-method (named :complex-subtypep-arg2) (type1 type2) + (assert (not (eq type2 *wild-type*))) ; * isn't really a type. + (cond ((eq type2 *universal-type*) + (values t t)) + ((type-might-contain-other-types-p type1) + ;; those types can be *EMPTY-TYPE* or *UNIVERSAL-TYPE* in + ;; disguise. So we'd better delegate. + (invoke-complex-subtypep-arg1-method type1 type2)) + (t + ;; FIXME: This seems to rely on there only being 2 or 3 + ;; NAMED-TYPE values, and the exclusion of various + ;; possibilities above. It would be good to explain it and/or + ;; rewrite it so that it's clearer. + (values (not (eq type2 *empty-type*)) t)))) + + +(define-type-method (named :complex-intersection) (type1 type2) + (hierarchical-intersection2 type1 type2)) + +(define-type-method (named :unparse) (x) + (named-ctype-name x)) + + + +;;;; Hairy and unknown types: + +;;; The Hairy-Type represents anything too wierd to be described +;;; reasonably or to be useful, such as SATISFIES. We just remember +;;; the original type spec. +;;; + +(defun make-hairy-ctype (&key specifier (enumerable t)) + (%istruct 'hairy-ctype + (type-class-or-lose 'hairy) + enumerable + specifier)) + +(defun hairy-ctype-p (x) + (or (istruct-typep x 'hairy-ctype) + (istruct-typep x 'unknown-ctype))) + +(setf (type-predicate 'hairy-ctype) 'hairy-ctype-p) + +(define-type-method (hairy :unparse) (x) (hairy-ctype-specifier x)) + +(define-type-method (hairy :simple-subtypep) (type1 type2) + (let ((hairy-spec1 (hairy-ctype-specifier type1)) + (hairy-spec2 (hairy-ctype-specifier type2))) + (cond ((equal-but-no-car-recursion hairy-spec1 hairy-spec2) + (values t t)) + (t + (values nil nil))))) + +(define-type-method (hairy :complex-subtypep-arg2) (type1 type2) + (invoke-complex-subtypep-arg1-method type1 type2)) + +(define-type-method (hairy :complex-subtypep-arg1) (type1 type2) + (declare (ignore type1 type2)) + (values nil nil)) + +(define-type-method (hairy :complex-=) (type1 type2) + (if (and (unknown-ctype-p type2) + (let* ((specifier2 (unknown-ctype-specifier type2)) + (name2 (if (consp specifier2) + (car specifier2) + specifier2))) + (info-type-kind name2))) + (let ((type2 (specifier-type (unknown-ctype-specifier type2)))) + (if (unknown-ctype-p type2) + (values nil nil) + (type= type1 type2))) + (values nil nil))) + +(define-type-method (hairy :simple-intersection :complex-intersection) + (type1 type2) + (if (type= type1 type2) + type1 + nil)) + + +(define-type-method (hairy :simple-union) + (type1 type2) + (if (type= type1 type2) + type1 + nil)) + +(define-type-method (hairy :simple-=) (type1 type2) + (if (equal-but-no-car-recursion (hairy-ctype-specifier type1) + (hairy-ctype-specifier type2)) + (values t t) + (values nil nil))) + + + +(def-type-translator satisfies (&whole x fun) + (unless (symbolp fun) + (report-bad-arg fun 'symbol)) + (make-hairy-ctype :specifier x)) + + + +;;; Negation Ctypes +(defun make-negation-ctype (&key type (enumerable t)) + (%istruct 'negation-ctype + (type-class-or-lose 'negation) + enumerable + type)) + +(defun negation-ctype-p (x) + (istruct-typep x 'negation-ctype)) + +(setf (type-predicate 'negation-ctype) 'negation-ctype-p) + +(define-type-method (negation :unparse) (x) + `(not ,(type-specifier (negation-ctype-type x)))) + +(define-type-method (negation :simple-subtypep) (type1 type2) + (csubtypep (negation-ctype-type type2) (negation-ctype-type type1))) + +(define-type-method (negation :complex-subtypep-arg2) (type1 type2) + (let* ((complement-type2 (negation-ctype-type type2)) + (intersection2 (type-intersection type1 complement-type2))) + (if intersection2 + ;; FIXME: if uncertain, maybe try arg1? + (type= intersection2 *empty-type*) + (invoke-complex-subtypep-arg1-method type1 type2)))) + +(define-type-method (negation :complex-subtypep-arg1) (type1 type2) + (block nil + ;; (Several logical truths in this block are true as long as + ;; b/=T. As of sbcl-0.7.1.28, it seems impossible to construct a + ;; case with b=T where we actually reach this type method, but + ;; we'll test for and exclude this case anyway, since future + ;; maintenance might make it possible for it to end up in this + ;; code.) + (multiple-value-bind (equal certain) + (type= type2 *universal-type*) + (unless certain + (return (values nil nil))) + (when equal + (return (values t t)))) + (let ((complement-type1 (negation-ctype-type type1))) + ;; Do the special cases first, in order to give us a chance if + ;; subtype/supertype relationships are hairy. + (multiple-value-bind (equal certain) + (type= complement-type1 type2) + ;; If a = b, ~a is not a subtype of b (unless b=T, which was + ;; excluded above). + (unless certain + (return (values nil nil))) + (when equal + (return (values nil t)))) + ;; KLUDGE: ANSI requires that the SUBTYPEP result between any + ;; two built-in atomic type specifiers never be uncertain. This + ;; is hard to do cleanly for the built-in types whose + ;; definitions include (NOT FOO), i.e. CONS and RATIO. However, + ;; we can do it with this hack, which uses our global knowledge + ;; that our implementation of the type system uses disjoint + ;; implementation types to represent disjoint sets (except when + ;; types are contained in other types). (This is a KLUDGE + ;; because it's fragile. Various changes in internal + ;; representation in the type system could make it start + ;; confidently returning incorrect results.) -- WHN 2002-03-08 + (unless (or (type-might-contain-other-types-p complement-type1) + (type-might-contain-other-types-p type2)) + ;; Because of the way our types which don't contain other + ;; types are disjoint subsets of the space of possible values, + ;; (SUBTYPEP '(NOT AA) 'B)=NIL when AA and B are simple (and B + ;; is not T, as checked above). + (return (values nil t))) + ;; The old (TYPE= TYPE1 TYPE2) branch would never be taken, as + ;; TYPE1 and TYPE2 will only be equal if they're both NOT types, + ;; and then the :SIMPLE-SUBTYPEP method would be used instead. + ;; But a CSUBTYPEP relationship might still hold: + (multiple-value-bind (equal certain) + (csubtypep complement-type1 type2) + ;; If a is a subtype of b, ~a is not a subtype of b (unless + ;; b=T, which was excluded above). + (unless certain + (return (values nil nil))) + (when equal + (return (values nil t)))) + (multiple-value-bind (equal certain) + (csubtypep type2 complement-type1) + ;; If b is a subtype of a, ~a is not a subtype of b. (FIXME: + ;; That's not true if a=T. Do we know at this point that a is + ;; not T?) + (unless certain + (return (values nil nil))) + (when equal + (return (values nil t)))) + ;; old CSR comment ca. 0.7.2, now obsoleted by the SIMPLE-CTYPE? + ;; KLUDGE case above: Other cases here would rely on being able + ;; to catch all possible cases, which the fragility of this type + ;; system doesn't inspire me; for instance, if a is type= to ~b, + ;; then we want T, T; if this is not the case and the types are + ;; disjoint (have an intersection of *empty-type*) then we want + ;; NIL, T; else if the union of a and b is the *universal-type* + ;; then we want T, T. So currently we still claim to be unsure + ;; about e.g. (subtypep '(not fixnum) 'single-float). + ;; + ;; OTOH we might still get here: + (values nil nil)))) + +(define-type-method (negation :complex-=) (type1 type2) + ;; (NOT FOO) isn't equivalent to anything that's not a negation + ;; type, except possibly a type that might contain it in disguise. + (declare (ignore type2)) + (if (type-might-contain-other-types-p type1) + (values nil nil) + (values nil t))) + +(define-type-method (negation :simple-intersection) (type1 type2) + (let ((not1 (negation-ctype-type type1)) + (not2 (negation-ctype-type type2))) + (cond + ((csubtypep not1 not2) type2) + ((csubtypep not2 not1) type1) + ;; Why no analagous clause to the disjoint in the SIMPLE-UNION2 + ;; method, below? The clause would read + ;; + ;; ((EQ (TYPE-UNION NOT1 NOT2) *UNIVERSAL-TYPE*) *EMPTY-TYPE*) + ;; + ;; but with proper canonicalization of negation types, there's + ;; no way of constructing two negation types with union of their + ;; negations being the universal type. + (t + nil)))) + +(define-type-method (negation :complex-intersection) (type1 type2) + (cond + ((csubtypep type1 (negation-ctype-type type2)) *empty-type*) + ((eq (type-intersection type1 (negation-ctype-type type2)) *empty-type*) + type1) + (t nil))) + +(define-type-method (negation :simple-union) (type1 type2) + (let ((not1 (negation-ctype-type type1)) + (not2 (negation-ctype-type type2))) + (cond + ((csubtypep not1 not2) type1) + ((csubtypep not2 not1) type2) + ((eq (type-intersection not1 not2) *empty-type*) + *universal-type*) + (t nil)))) + +(define-type-method (negation :complex-union) (type1 type2) + (cond + ((csubtypep (negation-ctype-type type2) type1) *universal-type*) + ((eq (type-intersection type1 (negation-ctype-type type2)) *empty-type*) + type2) + (t nil))) + +(define-type-method (negation :simple-=) (type1 type2) + (type= (negation-ctype-type type1) (negation-ctype-type type2))) + +(def-type-translator not (typespec &environment env) + (let* ((not-type (specifier-type typespec env)) + (spec (type-specifier not-type))) + (cond + ;; canonicalize (NOT (NOT FOO)) + ((and (listp spec) (eq (car spec) 'not)) + (specifier-type (cadr spec) env)) + ;; canonicalize (NOT NIL) and (NOT T) + ((eq not-type *empty-type*) *universal-type*) + ((eq not-type *universal-type*) *empty-type*) + ((and (numeric-ctype-p not-type) + (null (numeric-ctype-low not-type)) + (null (numeric-ctype-high not-type))) + (make-negation-ctype :type not-type)) + ((numeric-ctype-p not-type) + (type-union + (make-negation-ctype + :type (modified-numeric-type not-type :low nil :high nil)) + (cond + ((null (numeric-ctype-low not-type)) + (modified-numeric-type + not-type + :low (let ((h (numeric-ctype-high not-type))) + (if (consp h) (car h) (list h))) + :high nil)) + ((null (numeric-ctype-high not-type)) + (modified-numeric-type + not-type + :low nil + :high (let ((l (numeric-ctype-low not-type))) + (if (consp l) (car l) (list l))))) + (t (type-union + (modified-numeric-type + not-type + :low nil + :high (let ((l (numeric-ctype-low not-type))) + (if (consp l) (car l) (list l)))) + (modified-numeric-type + not-type + :low (let ((h (numeric-ctype-high not-type))) + (if (consp h) (car h) (list h))) + :high nil)))))) + ((intersection-ctype-p not-type) + (apply #'type-union + (mapcar #'(lambda (x) + (specifier-type `(not ,(type-specifier x)) env)) + (intersection-ctype-types not-type)))) + ((union-ctype-p not-type) + (apply #'type-intersection + (mapcar #'(lambda (x) + (specifier-type `(not ,(type-specifier x)) env)) + (union-ctype-types not-type)))) + ((member-ctype-p not-type) + (let ((members (member-ctype-members not-type))) + (if (some #'floatp members) + (let (floats) + (dolist (pair '((0.0f0 . -0.0f0) (0.0d0 . -0.0d0))) + (when (member (car pair) members) + (assert (not (member (cdr pair) members))) + (push (cdr pair) floats) + (setf members (remove (car pair) members))) + (when (member (cdr pair) members) + (assert (not (member (car pair) members))) + (push (car pair) floats) + (setf members (remove (cdr pair) members)))) + (apply #'type-intersection + (if (null members) + *universal-type* + (make-negation-ctype + :type (make-member-ctype :members members))) + (mapcar + (lambda (x) + (let ((type (ctype-of x))) + (type-union + (make-negation-ctype + :type (modified-numeric-type type + :low nil :high nil)) + (modified-numeric-type type + :low nil :high (list x)) + (make-member-ctype :members (list x)) + (modified-numeric-type type + :low (list x) :high nil)))) + floats))) + (make-negation-ctype :type not-type)))) + ((and (cons-ctype-p not-type) + (eq (cons-ctype-car-ctype not-type) *universal-type*) + (eq (cons-ctype-cdr-ctype not-type) *universal-type*)) + (make-negation-ctype :type not-type)) + ((cons-ctype-p not-type) + (type-union + (make-negation-ctype :type (specifier-type 'cons env)) + (cond + ((and (not (eq (cons-ctype-car-ctype not-type) *universal-type*)) + (not (eq (cons-ctype-cdr-ctype not-type) *universal-type*))) + (type-union + (make-cons-ctype + (specifier-type `(not ,(type-specifier + (cons-ctype-car-ctype not-type))) env) + *universal-type*) + (make-cons-ctype + *universal-type* + (specifier-type `(not ,(type-specifier + (cons-ctype-cdr-ctype not-type))) env)))) + ((not (eq (cons-ctype-car-ctype not-type) *universal-type*)) + (make-cons-ctype + (specifier-type `(not ,(type-specifier + (cons-ctype-car-ctype not-type))) env) + *universal-type*)) + ((not (eq (cons-ctype-cdr-ctype not-type) *universal-type*)) + (make-cons-ctype + *universal-type* + (specifier-type `(not ,(type-specifier + (cons-ctype-cdr-ctype not-type))) env))) + (t (error "Weird CONS type ~S" not-type))))) + (t (make-negation-ctype :type not-type))))) + + +;;;; Numeric types. + +;;; A list of all the float formats, in order of decreasing precision. +;;; +(eval-when (:compile-toplevel :load-toplevel :execute) + (defconstant float-formats + '(long-float double-float single-float short-float))) + +;;; The type of a float format. +;;; +(deftype float-format () `(member ,@float-formats)) + +(defun type-bound-number (x) + (if (consp x) + (destructuring-bind (result) x result) + x)) + +(defun make-numeric-ctype (&key class + format + (complexp :real) + low + high + enumerable + predicate) + ;; if interval is empty + (if (and low + high + (if (or (consp low) (consp high)) ; if either bound is exclusive + (>= (type-bound-number low) (type-bound-number high)) + (> low high))) + *empty-type* + (multiple-value-bind (canonical-low canonical-high) + (case class + (integer + ;; INTEGER types always have their LOW and HIGH bounds + ;; represented as inclusive, not exclusive values. + (values (if (consp low) + (1+ (type-bound-number low)) + low) + (if (consp high) + (1- (type-bound-number high)) + high))) + (t + ;; no canonicalization necessary + (values low high))) + (when (and (eq class 'rational) + (integerp canonical-low) + (integerp canonical-high) + (= canonical-low canonical-high)) + (setf class 'integer)) + (%istruct 'numeric-ctype + (type-class-or-lose 'number) + enumerable + class + format + complexp + canonical-low + canonical-high + predicate)))) + + +(defun make-numeric-ctype-predicate (ctype) + (let ((class (numeric-ctype-class ctype)) + (lo (numeric-ctype-low ctype)) + (hi (numeric-ctype-high ctype))) + (if (eq class 'integer) + (if (and hi + lo + (<= hi target::target-most-positive-fixnum) + (>= lo target::target-most-negative-fixnum)) + #'(lambda (n) + (and (fixnump n) + (locally (declare (fixnum n hi lo)) + (and (%i>= n lo) + (%i<= n hi))))))))) + +(defun numeric-ctype-p (x) + (istruct-typep x 'numeric-ctype)) + +(setf (type-predicate 'numeric-ctype) 'numeric-ctype-p) + +(define-type-method (number :simple-=) (type1 type2) + (values + (and (eq (numeric-ctype-class type1) (numeric-ctype-class type2)) + (eq (numeric-ctype-format type1) (numeric-ctype-format type2)) + (eq (numeric-ctype-complexp type1) (numeric-ctype-complexp type2)) + (equalp (numeric-ctype-low type1) (numeric-ctype-low type2)) + (equalp (numeric-ctype-high type1) (numeric-ctype-high type2))) + t)) + +(define-type-method (number :unparse) (type) + (let* ((complexp (numeric-ctype-complexp type)) + (low (numeric-ctype-low type)) + (high (numeric-ctype-high type)) + (base (case (numeric-ctype-class type) + (integer 'integer) + (rational 'rational) + (float (or (numeric-ctype-format type) 'float)) + (t 'real)))) + (let ((base+bounds + (cond ((and (eq base 'integer) high low) + (let ((high-count (logcount high)) + (high-length (integer-length high))) + (cond ((= low 0) + (cond ((= high 0) '(integer 0 0)) + ((= high 1) 'bit) + ((and (= high-count high-length) + (plusp high-length)) + `(unsigned-byte ,high-length)) + (t + `(mod ,(1+ high))))) + ((and (= low target::target-most-negative-fixnum) + (= high target::target-most-positive-fixnum)) + 'fixnum) + ((and (= low (lognot high)) + (= high-count high-length) + (> high-count 0)) + `(signed-byte ,(1+ high-length))) + (t + `(integer ,low ,high))))) + (high `(,base ,(or low '*) ,high)) + (low + (if (and (eq base 'integer) (= low 0)) + 'unsigned-byte + `(,base ,low))) + (t base)))) + (ecase complexp + (:real + base+bounds) + (:complex + (if (eq base+bounds 'real) + 'complex + `(complex ,base+bounds))) + ((nil) + (assert (eq base+bounds 'real)) + 'number))))) + +;;; Numeric-Bound-Test -- Internal +;;; +;;; Return true if X is "less than or equal" to Y, taking open bounds into +;;; consideration. Closed is the predicate used to test the bound on a closed +;;; interval (e.g. <=), and Open is the predicate used on open bounds (e.g. <). +;;; Y is considered to be the outside bound, in the sense that if it is +;;; infinite (NIL), then the test suceeds, whereas if X is infinite, then the +;;; test fails (unless Y is also infinite). +;;; +;;; This is for comparing bounds of the same kind, e.g. upper and upper. +;;; Use Numeric-Bound-Test* for different kinds of bounds. +;;; +(defmacro numeric-bound-test (x y closed open) + `(cond ((not ,y) t) + ((not ,x) nil) + ((consp ,x) + (if (consp ,y) + (,closed (car ,x) (car ,y)) + (,closed (car ,x) ,y))) + (t + (if (consp ,y) + (,open ,x (car ,y)) + (,closed ,x ,y))))) + +;;; Numeric-Bound-Test* -- Internal +;;; +;;; Used to compare upper and lower bounds. This is different from the +;;; same-bound case: +;;; -- Since X = NIL is -infinity, whereas y = NIL is +infinity, we return true +;;; if *either* arg is NIL. +;;; -- an open inner bound is "greater" and also squeezes the interval, causing +;;; us to use the Open test for those cases as well. +;;; +(defmacro numeric-bound-test* (x y closed open) + `(cond ((not ,y) t) + ((not ,x) t) + ((consp ,x) + (if (consp ,y) + (,open (car ,x) (car ,y)) + (,open (car ,x) ,y))) + (t + (if (consp ,y) + (,open ,x (car ,y)) + (,closed ,x ,y))))) + +;;; Numeric-Bound-Max -- Internal +;;; +;;; Return whichever of the numeric bounds X and Y is "maximal" according to +;;; the predicates Closed (e.g. >=) and Open (e.g. >). This is only meaningful +;;; for maximizing like bounds, i.e. upper and upper. If Max-P is true, then +;;; we return NIL if X or Y is NIL, otherwise we return the other arg. +;;; +(defmacro numeric-bound-max (x y closed open max-p) + (once-only ((n-x x) + (n-y y)) + `(cond + ((not ,n-x) ,(if max-p nil n-y)) + ((not ,n-y) ,(if max-p nil n-x)) + ((consp ,n-x) + (if (consp ,n-y) + (if (,closed (car ,n-x) (car ,n-y)) ,n-x ,n-y) + (if (,open (car ,n-x) ,n-y) ,n-x ,n-y))) + (t + (if (consp ,n-y) + (if (,open (car ,n-y) ,n-x) ,n-y ,n-x) + (if (,closed ,n-y ,n-x) ,n-y ,n-x)))))) + + +(define-type-method (number :simple-subtypep) (type1 type2) + (let ((class1 (numeric-ctype-class type1)) + (class2 (numeric-ctype-class type2)) + (complexp2 (numeric-ctype-complexp type2)) + (format2 (numeric-ctype-format type2)) + (low1 (numeric-ctype-low type1)) + (high1 (numeric-ctype-high type1)) + (low2 (numeric-ctype-low type2)) + (high2 (numeric-ctype-high type2))) + ;; + ;; If one is complex and the other isn't, they are disjoint. + (cond ((not (or (eq (numeric-ctype-complexp type1) complexp2) + (null complexp2))) + (values nil t)) + ;; + ;; If the classes are specified and different, the types are + ;; disjoint unless type2 is rational and type1 is integer. + ((not (or (eq class1 class2) (null class2) + (and (eq class1 'integer) (eq class2 'rational)))) + (values nil t)) + ;; + ;; If the float formats are specified and different, the types + ;; are disjoint. + ((not (or (eq (numeric-ctype-format type1) format2) + (null format2))) + (values nil t)) + ;; + ;; Check the bounds. + ((and (numeric-bound-test low1 low2 >= >) + (numeric-bound-test high1 high2 <= <)) + (values t t)) + (t + (values nil t))))) + +;(define-superclasses number (generic-number)) + +;;; NUMERIC-TYPES-ADJACENT -- Internal +;;; +;;; If the high bound of Low is adjacent to the low bound of High, then +;;; return T, otherwise NIL. +;;; +(defun numeric-types-adjacent (low high) + (let ((low-bound (numeric-ctype-high low)) + (high-bound (numeric-ctype-low high))) + (cond ((not (and low-bound high-bound)) nil) + ((consp low-bound) + (eql (car low-bound) high-bound)) + ((consp high-bound) + (eql (car high-bound) low-bound)) + ((and (eq (numeric-ctype-class low) 'integer) + (eq (numeric-ctype-class high) 'integer)) + (eql (1+ low-bound) high-bound)) + (t + nil)))) + +;;; +;;; Return a numeric type that is a supertype for both type1 and type2. +;;; +(define-type-method (number :simple-union) (type1 type2) + (declare (type numeric-ctype type1 type2)) + (cond ((csubtypep type1 type2) type2) + ((csubtypep type2 type1) type1) + (t + (let ((class1 (numeric-ctype-class type1)) + (format1 (numeric-ctype-format type1)) + (complexp1 (numeric-ctype-complexp type1)) + (class2 (numeric-ctype-class type2)) + (format2 (numeric-ctype-format type2)) + (complexp2 (numeric-ctype-complexp type2))) + (cond + ((and (eq class1 class2) + (eq format1 format2) + (eq complexp1 complexp2) + (or (numeric-types-intersect type1 type2) + (numeric-types-adjacent type1 type2) + (numeric-types-adjacent type2 type1))) + (make-numeric-ctype + :class class1 + :format format1 + :complexp complexp1 + :low (numeric-bound-max (numeric-ctype-low type1) + (numeric-ctype-low type2) + <= < t) + :high (numeric-bound-max (numeric-ctype-high type1) + (numeric-ctype-high type2) + >= > t))) + ;; FIXME: These two clauses are almost identical, and the + ;; consequents are in fact identical in every respect. + ((and (eq class1 'rational) + (eq class2 'integer) + (eq format1 format2) + (eq complexp1 complexp2) + (integerp (numeric-ctype-low type2)) + (integerp (numeric-ctype-high type2)) + (= (numeric-ctype-low type2) (numeric-ctype-high type2)) + (or (numeric-types-adjacent type1 type2) + (numeric-types-adjacent type2 type1))) + (make-numeric-ctype + :class 'rational + :format format1 + :complexp complexp1 + :low (numeric-bound-max (numeric-ctype-low type1) + (numeric-ctype-low type2) + <= < t) + :high (numeric-bound-max (numeric-ctype-high type1) + (numeric-ctype-high type2) + >= > t))) + ((and (eq class1 'integer) + (eq class2 'rational) + (eq format1 format2) + (eq complexp1 complexp2) + (integerp (numeric-ctype-low type1)) + (integerp (numeric-ctype-high type1)) + (= (numeric-ctype-low type1) (numeric-ctype-high type1)) + (or (numeric-types-adjacent type1 type2) + (numeric-types-adjacent type2 type1))) + (make-numeric-ctype + :class 'rational + :format format1 + :complexp complexp1 + :low (numeric-bound-max (numeric-ctype-low type1) + (numeric-ctype-low type2) + <= < t) + :high (numeric-bound-max (numeric-ctype-high type1) + (numeric-ctype-high type2) + >= > t))) + (t nil)))))) + +(setf (info-type-kind 'number) :primitive + (info-type-builtin 'number) (make-numeric-ctype :complexp nil)) + +(def-type-translator complex (&optional spec &environment env) + (if (eq spec '*) + (make-numeric-ctype :complexp :complex) + (labels ((not-numeric () + (error "Component type for Complex is not numeric: ~S." spec)) + (not-real () + (error "Component type for Complex is not a subtype of real: ~S." spec)) + (complex1 (component-type) + (unless (numeric-ctype-p component-type) + (not-numeric)) + (when (eq (numeric-ctype-complexp component-type) :complex) + (not-real)) + (let ((res (copy-uvector component-type))) + (setf (numeric-ctype-complexp res) :complex) + (setf (numeric-ctype-predicate res) nil) ; << + res)) + (do-complex (ctype) + (cond + ((eq ctype *empty-type*) *empty-type*) + ((eq ctype *universal-type*) (not-real)) + ((numeric-ctype-p ctype) (complex1 ctype)) + ((union-ctype-p ctype) + (apply #'type-union + (mapcar #'do-complex (union-ctype-types ctype)))) + ((member-ctype-p ctype) + (apply #'type-union + (mapcar (lambda (x) (do-complex (ctype-of x))) + (member-ctype-members ctype)))) + ((and (intersection-ctype-p ctype) + ;; just enough to handle simple types like RATIO. + (let ((numbers (remove-if-not + #'numeric-ctype-p + (intersection-ctype-types ctype)))) + (and (car numbers) + (null (cdr numbers)) + (eq (numeric-ctype-complexp (car numbers)) :real) + (complex1 (car numbers)))))) + (t ; punt on harder stuff for now + (not-real))))) + (let ((ctype (specifier-type spec env))) + (do-complex ctype))))) + +;;; Check-Bound -- Internal +;;; +;;; Check that X is a well-formed numeric bound of the specified Type. +;;; If X is *, return NIL, otherwise return the bound. +;;; +(defmacro check-bound (x type) + `(cond ((eq ,x '*) nil) + ((or (typep ,x ',type) + (and (consp ,x) (typep (car ,x) ',type) (null (cdr ,x)))) + ,x) + (t + (error "Bound is not *, a ~A or a list of a ~A: ~S" ',type ',type ,x)))) + +(def-type-translator integer (&optional low high) + (let* ((l (check-bound low integer)) + (lb (if (consp l) (1+ (car l)) l)) + (h (check-bound high integer)) + (hb (if (consp h) (1- (car h)) h))) + (if (and hb lb (< hb lb)) + *empty-type* + (make-numeric-ctype :class 'integer :complexp :real + :enumerable (not (null (and l h))) + :low lb + :high hb)))) + +(deftype mod (n) + (unless (and (integerp n) (> n 0)) + (error "Bad N specified for MOD type specifier: ~S." n)) + `(integer 0 ,(1- n))) + + +(defmacro def-bounded-type (type class format) + `(def-type-translator ,type (&optional low high) + (let ((lb (check-bound low ,type)) + (hb (check-bound high ,type))) + (unless (numeric-bound-test* lb hb <= <) + (error "Lower bound ~S is not less than upper bound ~S." low high)) + (make-numeric-ctype :class ',class :format ',format :low lb :high hb)))) + +(def-bounded-type rational rational nil) + +(defun coerce-bound (bound type inner-coerce-bound-fun) + (declare (type function inner-coerce-bound-fun)) + (cond ((eql bound '*) + bound) + ((consp bound) + (destructuring-bind (inner-bound) bound + (list (funcall inner-coerce-bound-fun inner-bound type)))) + (t + (funcall inner-coerce-bound-fun bound type)))) + +(defun inner-coerce-real-bound (bound type) + (ecase type + (rational (rationalize bound)) + (float (if (floatp bound) + bound + ;; Coerce to the widest float format available, to + ;; avoid unnecessary loss of precision: + (coerce bound 'long-float))))) + +(defun coerced-real-bound (bound type) + (coerce-bound bound type #'inner-coerce-real-bound)) + +(defun coerced-float-bound (bound type) + (coerce-bound bound type #'coerce)) + +#| +(def-type-translator real (&optional (low '*) (high '*)) + (specifier-type `(or (float ,(coerced-real-bound low 'float) + ,(coerced-real-bound high 'float)) + (rational ,(coerced-real-bound low 'rational) + ,(coerced-real-bound high 'rational))))) + +(def-type-translator float (&optional (low '*) (high '*)) + (specifier-type + `(or (single-float ,(coerced-float-bound low 'single-float) + ,(coerced-float-bound high 'single-float)) + (double-float ,(coerced-float-bound low 'double-float) + ,(coerced-float-bound high 'double-float))))) +|# + +(def-bounded-type float float nil) +(def-bounded-type real nil nil) + +(defmacro define-float-format (f) + `(def-bounded-type ,f float ,f)) + +(define-float-format short-float) +(define-float-format single-float) +(define-float-format double-float) +(define-float-format long-float) + +(defun numeric-types-intersect (type1 type2) + (declare (type numeric-ctype type1 type2)) + (let* ((class1 (numeric-ctype-class type1)) + (class2 (numeric-ctype-class type2)) + (complexp1 (numeric-ctype-complexp type1)) + (complexp2 (numeric-ctype-complexp type2)) + (format1 (numeric-ctype-format type1)) + (format2 (numeric-ctype-format type2)) + (low1 (numeric-ctype-low type1)) + (high1 (numeric-ctype-high type1)) + (low2 (numeric-ctype-low type2)) + (high2 (numeric-ctype-high type2))) + ;; + ;; If one is complex and the other isn't, then they are disjoint. + (cond ((not (or (eq complexp1 complexp2) + (null complexp1) (null complexp2))) + nil) + ;; + ;; If either type is a float, then the other must either be specified + ;; to be a float or unspecified. Otherwise, they are disjoint. + ((and (eq class1 'float) (not (member class2 '(float nil)))) nil) + ((and (eq class2 'float) (not (member class1 '(float nil)))) nil) + ;; + ;; If the float formats are specified and different, the types + ;; are disjoint. + ((not (or (eq format1 format2) (null format1) (null format2))) + nil) + (t + ;; + ;; Check the bounds. This is a bit odd because we must always have + ;; the outer bound of the interval as the second arg. + (if (numeric-bound-test high1 high2 <= <) + (or (and (numeric-bound-test low1 low2 >= >) + (numeric-bound-test* low1 high2 <= <)) + (and (numeric-bound-test low2 low1 >= >) + (numeric-bound-test* low2 high1 <= <))) + (or (and (numeric-bound-test* low2 high1 <= <) + (numeric-bound-test low2 low1 >= >)) + (and (numeric-bound-test high2 high1 <= <) + (numeric-bound-test* high2 low1 >= >)))))))) + +;;; Round-Numeric-Bound -- Internal +;;; +;;; Take the numeric bound X and convert it into something that can be used +;;; as a bound in a numeric type with the specified Class and Format. If up-p +;;; is true, then we round up as needed, otherwise we round down. Up-p true +;;; implies that X is a lower bound, i.e. (N) > N. +;;; +;;; This is used by Numeric-Type-Intersection to mash the bound into the +;;; appropriate type number. X may only be a float when Class is Float. +;;; +;;; ### Note: it is possible for the coercion to a float to overflow or +;;; underflow. This happens when the bound doesn't fit in the specified +;;; format. In this case, we should really return the appropriate +;;; {Most | Least}-{Positive | Negative}-XXX-Float float of desired format. +;;; But these conditions aren't currently signalled in any useful way. +;;; +;;; Also, when converting an open rational bound into a float we should +;;; probably convert it to a closed bound of the closest float in the specified +;;; format. In general, open float bounds are fucked. +;;; +(defun round-numeric-bound (x class format up-p) + (if x + (let ((cx (if (consp x) (car x) x))) + (ecase class + ((nil rational) x) + (integer + (if (and (consp x) (integerp cx)) + (if up-p (1+ cx) (1- cx)) + (if up-p (ceiling cx) (floor cx)))) + (float + (let ((res (if format (coerce cx format) (float cx)))) + (if (consp x) (list res) res))))) + nil)) + +;;; Number :Simple-Intersection type method -- Internal +;;; +;;; Handle the case of Type-Intersection on two numeric types. We use +;;; Types-Intersect to throw out the case of types with no intersection. If an +;;; attribute in Type1 is unspecified, then we use Type2's attribute, which +;;; must be at least as restrictive. If the types intersect, then the only +;;; attributes that can be specified and different are the class and the +;;; bounds. +;;; +;;; When the class differs, we use the more restrictive class. The only +;;; interesting case is rational/integer, since rational includes integer. +;;; +;;; We make the result lower (upper) bound the maximum (minimum) of the +;;; argument lower (upper) bounds. We convert the bounds into the +;;; appropriate numeric type before maximizing. This avoids possible confusion +;;; due to mixed-type comparisons (but I think the result is the same). +;;; +(define-type-method (number :simple-intersection) (type1 type2) + (declare (type numeric-ctype type1 type2)) + (if (numeric-types-intersect type1 type2) + (let* ((class1 (numeric-ctype-class type1)) + (class2 (numeric-ctype-class type2)) + (class (ecase class1 + ((nil) class2) + ((integer float) class1) + (rational (if (eq class2 'integer) 'integer 'rational)))) + (format (or (numeric-ctype-format type1) + (numeric-ctype-format type2)))) + (make-numeric-ctype + :class class + :format format + :complexp (or (numeric-ctype-complexp type1) + (numeric-ctype-complexp type2)) + :low (numeric-bound-max + (round-numeric-bound (numeric-ctype-low type1) + class format t) + (round-numeric-bound (numeric-ctype-low type2) + class format t) + > >= nil) + :high (numeric-bound-max + (round-numeric-bound (numeric-ctype-high type1) + class format nil) + (round-numeric-bound (numeric-ctype-high type2) + class format nil) + < <= nil))) + *empty-type*)) + +;;; Float-Format-Max -- Interface +;;; +;;; Given two float formats, return the one with more precision. If either +;;; one is null, return NIL. +;;; +(defun float-format-max (f1 f2) + (when (and f1 f2) + (dolist (f float-formats (error "Bad float format: ~S." f1)) + (when (or (eq f f1) (eq f f2)) + (return f))))) + + +;;; Numeric-Contagion -- Interface +;;; +;;; Return the result of an operation on Type1 and Type2 according to the +;;; rules of numeric contagion. This is always NUMBER, some float format +;;; (possibly complex) or RATIONAL. Due to rational canonicalization, there +;;; isn't much we can do here with integers or rational complex numbers. +;;; +;;; If either argument is not a Numeric-Type, then return NUMBER. This is +;;; useful mainly for allowing types that are technically numbers, but not a +;;; Numeric-Type. +;;; +(defun numeric-contagion (type1 type2) + (if (and (numeric-ctype-p type1) (numeric-ctype-p type2)) + (let ((class1 (numeric-ctype-class type1)) + (class2 (numeric-ctype-class type2)) + (format1 (numeric-ctype-format type1)) + (format2 (numeric-ctype-format type2)) + (complexp1 (numeric-ctype-complexp type1)) + (complexp2 (numeric-ctype-complexp type2))) + (cond ((or (null complexp1) + (null complexp2)) + (specifier-type 'number)) + ((eq class1 'float) + (make-numeric-ctype + :class 'float + :format (ecase class2 + (float (float-format-max format1 format2)) + ((integer rational) format1) + ((nil) + ;; A double-float with any real number is a + ;; double-float. + (if (eq format1 'double-float) + 'double-float + nil))) + :complexp (if (or (eq complexp1 :complex) + (eq complexp2 :complex)) + :complex + :real))) + ((eq class2 'float) (numeric-contagion type2 type1)) + ((and (eq complexp1 :real) (eq complexp2 :real)) + (make-numeric-ctype + :class (and class1 class2 'rational) + :complexp :real)) + (t + (specifier-type 'number)))) + (specifier-type 'number))) + + + + + +;;;; Array types: + +;;; The Array-Type is used to represent all array types, including things such +;;; as SIMPLE-STRING. +;;; + +(defun make-array-ctype (&key + (dimensions '*) + (complexp '*) + element-type + (specialized-element-type *wild-type*)) + (%istruct 'array-ctype + (type-class-or-lose 'array) + nil + dimensions + complexp + element-type + specialized-element-type + (unless (eq specialized-element-type *wild-type*) + (ctype-subtype specialized-element-type)))) + +(defun array-ctype-p (x) (istruct-typep x 'array-ctype)) +(setf (type-predicate 'array-ctype) 'array-ctype-p) + +;;; Specialized-Element-Type-Maybe -- Internal +;;; +;;; What this does depends on the setting of the +;;; *use-implementation-types* switch. If true, return the specialized element +;;; type, otherwise return the original element type. +;;; +(defun specialized-element-type-maybe (type) + (declare (type array-ctype type)) + (if *use-implementation-types* + (array-ctype-specialized-element-type type) + (array-ctype-element-type type))) + +(define-type-method (array :simple-=) (type1 type2) + (if (or (unknown-ctype-p (array-ctype-element-type type1)) + (unknown-ctype-p (array-ctype-element-type type2))) + (multiple-value-bind (equalp certainp) + (type= (array-ctype-element-type type1) + (array-ctype-element-type type2)) + (assert (not (and (not equalp) certainp))) + (values equalp certainp)) + (values (and (equal (array-ctype-dimensions type1) + (array-ctype-dimensions type2)) + (eq (array-ctype-complexp type1) + (array-ctype-complexp type2)) + (type= (specialized-element-type-maybe type1) + (specialized-element-type-maybe type2))) + t))) + +(define-type-method (array :unparse) (type) + (let ((dims (array-ctype-dimensions type)) + (eltype (type-specifier (array-ctype-element-type type))) + (complexp (array-ctype-complexp type))) + (cond ((eq dims '*) + (if (eq eltype '*) + (if complexp 'array 'simple-array) + (if complexp `(array ,eltype) `(simple-array ,eltype)))) + ((= (length dims) 1) + (if complexp + (if (eq (car dims) '*) + (case eltype + (bit 'bit-vector) + ((character base-char) 'base-string) + (* 'vector) + (t `(vector ,eltype))) + (case eltype + (bit `(bit-vector ,(car dims))) + ((character base-char) `(base-string ,(car dims))) + (t `(vector ,eltype ,(car dims))))) + (if (eq (car dims) '*) + (case eltype + (bit 'simple-bit-vector) + ((base-char character) 'simple-base-string) + ((t) 'simple-vector) + (t `(simple-array ,eltype (*)))) + (case eltype + (bit `(simple-bit-vector ,(car dims))) + ((base-char character) `(simple-base-string ,(car dims))) + ((t) `(simple-vector ,(car dims))) + (t `(simple-array ,eltype ,dims)))))) + (t + (if complexp + `(array ,eltype ,dims) + `(simple-array ,eltype ,dims)))))) + +(define-type-method (array :simple-subtypep) (type1 type2) + (let ((dims1 (array-ctype-dimensions type1)) + (dims2 (array-ctype-dimensions type2)) + (complexp2 (array-ctype-complexp type2))) + (cond (;; not subtypep unless dimensions are compatible + (not (or (eq dims2 '*) + (and (not (eq dims1 '*)) + (= (length (the list dims1)) + (length (the list dims2))) + (every (lambda (x y) + (or (eq y '*) (eql x y))) + (the list dims1) + (the list dims2))))) + (values nil t)) + ;; not subtypep unless complexness is compatible + ((not (or (eq complexp2 :maybe) + (eq (array-ctype-complexp type1) complexp2))) + (values nil t)) + ;; Since we didn't fail any of the tests above, we win + ;; if the TYPE2 element type is wild. + ((eq (array-ctype-element-type type2) *wild-type*) + (values t t)) + (;; Since we didn't match any of the special cases above, we + ;; can't give a good answer unless both the element types + ;; have been defined. + (or (unknown-ctype-p (array-ctype-element-type type1)) + (unknown-ctype-p (array-ctype-element-type type2))) + (values nil nil)) + (;; Otherwise, the subtype relationship holds iff the + ;; types are equal, and they're equal iff the specialized + ;; element types are identical. + t + (values (type= (specialized-element-type-maybe type1) + (specialized-element-type-maybe type2)) + t))))) + +; (define-superclasses array (string string) (vector vector) (array)) + + +(defun array-types-intersect (type1 type2) + (declare (type array-ctype type1 type2)) + (let ((dims1 (array-ctype-dimensions type1)) + (dims2 (array-ctype-dimensions type2)) + (complexp1 (array-ctype-complexp type1)) + (complexp2 (array-ctype-complexp type2))) + ;; See whether dimensions are compatible. + (cond ((not (or (eq dims1 '*) (eq dims2 '*) + (and (= (length dims1) (length dims2)) + (every (lambda (x y) + (or (eq x '*) (eq y '*) (= x y))) + dims1 dims2)))) + (values nil t)) + ;; See whether complexpness is compatible. + ((not (or (eq complexp1 :maybe) + (eq complexp2 :maybe) + (eq complexp1 complexp2))) + (values nil t)) + ((or (eq (array-ctype-specialized-element-type type1) *wild-type*) + (eq (array-ctype-specialized-element-type type2) *wild-type*) + (type= (specialized-element-type-maybe type1) + (specialized-element-type-maybe type2))) + (values t t)) + (t + (values nil t))))) + +(define-type-method (array :simple-intersection) (type1 type2) + (declare (type array-ctype type1 type2)) + (if (array-types-intersect type1 type2) + (let ((dims1 (array-ctype-dimensions type1)) + (dims2 (array-ctype-dimensions type2)) + (complexp1 (array-ctype-complexp type1)) + (complexp2 (array-ctype-complexp type2)) + (eltype1 (array-ctype-element-type type1)) + (eltype2 (array-ctype-element-type type2))) + (specialize-array-type + (make-array-ctype + :dimensions (cond ((eq dims1 '*) dims2) + ((eq dims2 '*) dims1) + (t + (mapcar #'(lambda (x y) (if (eq x '*) y x)) + dims1 dims2))) + :complexp (if (eq complexp1 :maybe) complexp2 complexp1) + :element-type (cond + ((eq eltype1 *wild-type*) eltype2) + ((eq eltype2 *wild-type*) eltype1) + (t (type-intersection eltype1 eltype2)))))) + *empty-type*)) + +;;; Check-Array-Dimensions -- Internal +;;; +;;; Check a supplied dimension list to determine if it is legal. +;;; +(defun check-array-dimensions (dims) + (typecase dims + ((member *) dims) + (integer + (when (minusp dims) + (signal-program-error "Arrays can't have a negative number of dimensions: ~D." dims)) + (when (>= dims array-rank-limit) + (signal-program-error "Array type has too many dimensions: ~S." dims)) + (make-list dims :initial-element '*)) + (list + (when (>= (length dims) array-rank-limit) + (signal-program-error "Array type has too many dimensions: ~S." dims)) + (dolist (dim dims) + (unless (eq dim '*) + (unless (and (integerp dim) + (>= dim 0) (< dim array-dimension-limit)) + (signal-program-error "Bad dimension in array type: ~S." dim)))) + dims) + (t + (signal-program-error "Array dimensions is not a list, integer or *:~% ~S" + dims)))) + +(def-type-translator array (&optional element-type dimensions &environment env) + (specialize-array-type + (make-array-ctype :dimensions (check-array-dimensions dimensions) + :complexp :maybe + :element-type (specifier-type element-type env)))) + +(def-type-translator simple-array (&optional element-type dimensions &environment env) + (specialize-array-type + (make-array-ctype :dimensions (check-array-dimensions dimensions) + :element-type (specifier-type element-type env) + :complexp nil))) + +;;; Order matters here. +(defparameter specialized-array-element-types + '(nil bit (unsigned-byte 8) (signed-byte 8) (unsigned-byte 16) + (signed-byte 16) (unsigned-byte 32) #+32-bit-target fixnum (signed-byte 32) + #+64-bit-target (unsigned-byte 64) + #+64-bit-target fixnum + #+64-bit-target (signed-byte 64) + character short-float double-float)) + +(defun specialize-array-type (type) + (let* ((eltype (array-ctype-element-type type)) + (specialized-type (if (eq eltype *wild-type*) + *wild-type* + (dolist (stype-name specialized-array-element-types + *universal-type*) + (let ((stype (specifier-type stype-name))) + (when (csubtypep eltype stype) + (return stype))))))) + + (setf (array-ctype-specialized-element-type type) specialized-type + (array-ctype-typecode type) (unless (eq specialized-type *wild-type*) + (ctype-subtype specialized-type))) + type)) + + + +;;;; Member types. + +;;; The Member-Type represents uses of the MEMBER type specifier. We bother +;;; with this at this level because MEMBER types are fairly important and union +;;; and intersection are well defined. + +(defun %make-member-ctype (members) + (%istruct 'member-ctype + (type-class-or-lose 'member) + t + members)) + +(defun make-member-ctype (&key members) + (let* ((singlep (subsetp '(-0.0f0 0.0f0) members)) + (doublep (subsetp '(-0.0d0 0.0d0) members)) + (union-types + (if singlep + (if doublep + (list *ctype-of-single-float-0* *ctype-of-double-float-0*) + (list *ctype-of-single-float-0*)) + (if doublep + (list *ctype-of-double-float-0*))))) + (if union-types + (progn + (if singlep + (setq members (set-difference '(-0.0f0 0.0f0) members))) + (if doublep + (setq members (set-difference '(-0.d00 0.0d0) members))) + (make-union-ctype (if (null members) + union-types + (cons (%make-member-ctype members) union-types)))) + (%make-member-ctype members)))) + + +(defun member-ctype-p (x) (istruct-typep x 'member-ctype)) +(setf (type-predicate 'member-ctype) 'member-ctype-p) + +(define-type-method (member :unparse) (type) + (if (type= type (specifier-type 'standard-char)) + 'standard-char + (let ((members (member-ctype-members type))) + (if (equal members '(nil)) + 'null + `(member ,@members))))) + +(define-type-method (member :simple-subtypep) (type1 type2) + (values (subsetp (member-ctype-members type1) (member-ctype-members type2)) + t)) + + +(define-type-method (member :complex-subtypep-arg1) (type1 type2) + (every/type (swapped-args-fun #'ctypep) + type2 + (member-ctype-members type1))) + +;;; We punt if the odd type is enumerable and intersects with the member type. +;;; If not enumerable, then it is definitely not a subtype of the member type. +;;; +(define-type-method (member :complex-subtypep-arg2) (type1 type2) + (cond ((not (ctype-enumerable type1)) (values nil t)) + ((types-intersect type1 type2) + (invoke-complex-subtypep-arg1-method type1 type2)) + (t + (values nil t)))) + +(define-type-method (member :simple-intersection) (type1 type2) + (let ((mem1 (member-ctype-members type1)) + (mem2 (member-ctype-members type2))) + (values (cond ((subsetp mem1 mem2) type1) + ((subsetp mem2 mem1) type2) + (t + (let ((res (intersection mem1 mem2))) + (if res + (make-member-ctype :members res) + *empty-type*)))) + t))) + +(define-type-method (member :complex-intersection) (type1 type2) + (block PUNT + (collect ((members)) + (let ((mem2 (member-ctype-members type2))) + (dolist (member mem2) + (multiple-value-bind (val win) (ctypep member type1) + (unless win + (return-from punt nil)) + (when val (members member)))) + (cond ((subsetp mem2 (members)) type2) + ((null (members)) *empty-type*) + (t + (make-member-ctype :members (members)))))))) + +;;; We don't need a :COMPLEX-UNION, since the only interesting case is a union +;;; type, and the member/union interaction is handled by the union type +;;; method. +(define-type-method (member :simple-union) (type1 type2) + (let ((mem1 (member-ctype-members type1)) + (mem2 (member-ctype-members type2))) + (cond ((subsetp mem1 mem2) type2) + ((subsetp mem2 mem1) type1) + (t + (make-member-ctype :members (union mem1 mem2)))))) + + +(define-type-method (member :simple-=) (type1 type2) + (let ((mem1 (member-ctype-members type1)) + (mem2 (member-ctype-members type2))) + (values (and (subsetp mem1 mem2) (subsetp mem2 mem1)) + t))) + +(define-type-method (member :complex-=) (type1 type2) + (if (ctype-enumerable type1) + (multiple-value-bind (val win) + (csubtypep type2 type1) + (if (or val (not win)) + (values nil nil) + (values nil t))) + (values nil t))) + +(def-type-translator member (&rest members) + (if members + (collect ((non-numbers) (numbers)) + (dolist (m (remove-duplicates members)) + (if (and (numberp m) + (not (and (floatp m) (zerop m)))) + (numbers (ctype-of m)) + (non-numbers m))) + (apply #'type-union + (if (non-numbers) + (make-member-ctype :members (non-numbers)) + *empty-type*) + (numbers))) + *empty-type*)) + + + + +;;;; Union types: + +;;; The Union-Type represents uses of the OR type specifier which can't be +;;; canonicalized to something simpler. Canonical form: +;;; +;;; 1] There is never more than one Member-Type component. +;;; 2] There are never any Union-Type components. +;;; + +(defun make-union-ctype (types) + (declare (list types)) + (%istruct 'union-ctype + (type-class-or-lose 'union) + (every #'(lambda (x) (ctype-enumerable x)) types) + types)) + +(defun union-ctype-p (x) (istruct-typep x 'union-ctype)) +(setf (type-predicate 'union-ctype) 'union-ctype-p) + + +;;; If List, then return that, otherwise the OR of the component types. +;;; +(define-type-method (union :unparse) (type) + (declare (type ctype type)) + (cond + ((type= type (specifier-type 'list)) 'list) + ((type= type (specifier-type 'float)) 'float) + ((type= type (specifier-type 'real)) 'real) + ((type= type (specifier-type 'sequence)) 'sequence) + ((type= type (specifier-type 'bignum)) 'bignum) + (t `(or ,@(mapcar #'type-specifier (union-ctype-types type)))))) + + + +(define-type-method (union :simple-=) (type1 type2) + (multiple-value-bind (subtype certain?) + (csubtypep type1 type2) + (if subtype + (csubtypep type2 type1) + (if certain? + (values nil t) + (multiple-value-bind (subtype certain?) + (csubtypep type2 type1) + (declare (ignore subtype)) + (values nil certain?)))))) + + +(define-type-method (union :complex-=) (type1 type2) + (declare (ignore type1)) + (if (some #'type-might-contain-other-types-p + (union-ctype-types type2)) + (values nil nil) + (values nil t))) + + +(defun union-simple-subtypep (type1 type2) + (every/type (swapped-args-fun #'union-complex-subtypep-arg2) + type2 + (union-ctype-types type1))) + +(define-type-method (union :simple-subtypep) (type1 type2) + (union-simple-subtypep type1 type2)) + +(defun union-complex-subtypep-arg1 (type1 type2) + (every/type (swapped-args-fun #'csubtypep) + type2 + (union-ctype-types type1))) + +(define-type-method (union :complex-subtypep-arg1) (type1 type2) + (union-complex-subtypep-arg1 type1 type2)) + +(defun union-complex-subtypep-arg2 (type1 type2) + (multiple-value-bind (sub-value sub-certain?) + (progn + (assert (union-ctype-p type2)) + (assert (not (union-ctype-p type1))) + (type= type1 + (apply #'type-union + (mapcar (lambda (x) (type-intersection type1 x)) + (union-ctype-types type2))))) + (if sub-certain? + (values sub-value sub-certain?) + (invoke-complex-subtypep-arg1-method type1 type2)))) + +(define-type-method (union :complex-subtypep-arg2) (type1 type2) + (union-complex-subtypep-arg2 type1 type2)) + +(define-type-method (union :simple-intersection :complex-intersection) + (type1 type2) + (assert (union-ctype-p type2)) + (cond ((and (union-ctype-p type1) + (union-simple-subtypep type1 type2)) type1) + ((and (union-ctype-p type1) + (union-simple-subtypep type2 type1)) type2) + ((and (not (union-ctype-p type1)) + (union-complex-subtypep-arg2 type1 type2)) + type1) + ((and (not (union-ctype-p type1)) + (union-complex-subtypep-arg1 type2 type1)) + type2) + (t + (let ((accumulator *empty-type*)) + (dolist (t2 (union-ctype-types type2) accumulator) + (setf accumulator + (type-union accumulator + (type-intersection type1 t2)))))))) + + + +(def-type-translator or (&rest type-specifiers &environment env) + (apply #'type-union + (mapcar #'(lambda (spec) (specifier-type spec env)) type-specifiers))) + + + +;;; Intersection types +(defun make-intersection-ctype (enumerable types) + (%istruct 'intersection-ctype + (type-class-or-lose 'intersection) + enumerable + types)) + +(defun intersection-ctype-p (x) + (istruct-typep x 'intersection-ctype)) +(setf (type-predicate 'intersection-ctype) 'intersection-ctype-p) + +(define-type-method (intersection :unparse) (type) + (declare (type ctype type)) + (or (find type '(ratio keyword) :key #'specifier-type :test #'type=) + `(and ,@(mapcar #'type-specifier (intersection-ctype-types type))))) + +;;; shared machinery for type equality: true if every type in the set +;;; TYPES1 matches a type in the set TYPES2 and vice versa +(defun type=-set (types1 types2) + (flet (;; true if every type in the set X matches a type in the set Y + (type<=-set (x y) + (declare (type list x y)) + (every (lambda (xelement) + (position xelement y :test #'type=)) + x))) + (values (and (type<=-set types1 types2) + (type<=-set types2 types1)) + t))) + +(define-type-method (intersection :simple-=) (type1 type2) + (type=-set (intersection-ctype-types type1) + (intersection-ctype-types type2))) + +(defun %intersection-complex-subtypep-arg1 (type1 type2) + (type= type1 (type-intersection type1 type2))) + +(defun %intersection-simple-subtypep (type1 type2) + (every/type #'%intersection-complex-subtypep-arg1 + type1 + (intersection-ctype-types type2))) + +(define-type-method (intersection :simple-subtypep) (type1 type2) + (%intersection-simple-subtypep type1 type2)) + +(define-type-method (intersection :complex-subtypep-arg1) (type1 type2) + (%intersection-complex-subtypep-arg1 type1 type2)) + +(defun %intersection-complex-subtypep-arg2 (type1 type2) + (every/type #'csubtypep type1 (intersection-ctype-types type2))) + +(define-type-method (intersection :complex-subtypep-arg2) (type1 type2) + (%intersection-complex-subtypep-arg2 type1 type2)) + +(define-type-method (intersection :simple-union :complex-union) + (type1 type2) + (assert (intersection-ctype-p type2)) + (cond ((and (intersection-ctype-p type1) + (%intersection-simple-subtypep type1 type2)) type2) + ((and (intersection-ctype-p type1) + (%intersection-simple-subtypep type2 type1)) type1) + ((and (not (intersection-ctype-p type1)) + (%intersection-complex-subtypep-arg2 type1 type2)) + type2) + ((and (not (intersection-ctype-p type1)) + (%intersection-complex-subtypep-arg1 type2 type1)) + type1) + ((and (csubtypep type2 (specifier-type 'ratio)) + (numeric-ctype-p type1) + (csubtypep type1 (specifier-type 'integer)) + (csubtypep type2 + (make-numeric-ctype + :class 'rational + :complexp nil + :low (if (null (numeric-ctype-low type1)) + nil + (list (1- (numeric-ctype-low type1)))) + :high (if (null (numeric-ctype-high type1)) + nil + (list (1+ (numeric-ctype-high type1))))))) + (type-union type1 + (apply #'type-intersection + (remove (specifier-type '(not integer)) + (intersection-ctype-types type2) + :test #'type=)))) + (t + (let ((accumulator *universal-type*)) + (do ((t2s (intersection-ctype-types type2) (cdr t2s))) + ((null t2s) accumulator) + (let ((union (type-union type1 (car t2s)))) + (when (union-ctype-p union) + (if (and (eq accumulator *universal-type*) + (null (cdr t2s))) + (return union) + (return nil))) + (setf accumulator + (type-intersection accumulator union)))))))) + +(def-type-translator and (&rest type-specifiers &environment env) + (apply #'type-intersection + (mapcar #'(lambda (spec) (specifier-type spec env)) + type-specifiers))) + +;;; cons-ctype +(defun wild-ctype-to-universal-ctype (c) + (if (type= c *wild-type*) + *universal-type* + c)) + +(defun make-cons-ctype (car-ctype-value cdr-ctype-value) + (if (or (eq car-ctype-value *empty-type*) + (eq cdr-ctype-value *empty-type*)) + *empty-type* + (%istruct 'cons-ctype + (type-class-or-lose 'cons) + nil + (wild-ctype-to-universal-ctype car-ctype-value) + (wild-ctype-to-universal-ctype cdr-ctype-value)))) + +(defun cons-ctype-p (x) + (istruct-typep x 'cons-ctype)) + +(setf (type-predicate 'cons-ctype) 'cons-ctype-p) + +(def-type-translator cons (&optional (car-type-spec '*) (cdr-type-spec '*) &environment env) + (make-cons-ctype (specifier-type car-type-spec env) + (specifier-type cdr-type-spec env))) + +(define-type-method (cons :unparse) (type) + (let* ((car-spec (type-specifier (cons-ctype-car-ctype type))) + (cdr-spec (type-specifier (cons-ctype-cdr-ctype type)))) + (if (and (member car-spec '(t *)) + (member cdr-spec '(t *))) + 'cons + `(cons ,car-spec ,cdr-spec)))) + +(define-type-method (cons :simple-=) (type1 type2) + (declare (cons-ctype type1 type2)) + (and (type= (cons-ctype-car-ctype type1) (cons-ctype-car-ctype type2)) + (type= (cons-ctype-cdr-ctype type1) (cons-ctype-cdr-ctype type2)))) + +(define-type-method (cons :simple-subtypep) (type1 type2) + (declare (cons-ctype type1 type2)) + (multiple-value-bind (val-car win-car) + (csubtypep (cons-ctype-car-ctype type1) (cons-ctype-car-ctype type2)) + (multiple-value-bind (val-cdr win-cdr) + (csubtypep (cons-ctype-cdr-ctype type1) (cons-ctype-cdr-ctype type2)) + (if (and val-car val-cdr) + (values t (and win-car win-cdr)) + (values nil (or win-car win-cdr)))))) + +(define-type-method (cons :simple-union) (type1 type2) + (declare (type cons-ctype type1 type2)) + (let ((car-type1 (cons-ctype-car-ctype type1)) + (car-type2 (cons-ctype-car-ctype type2)) + (cdr-type1 (cons-ctype-cdr-ctype type1)) + (cdr-type2 (cons-ctype-cdr-ctype type2)) + (car-not1) + (car-not2)) + (macrolet ((frob-car (car1 car2 cdr1 cdr2 + &optional (not1 nil not1p)) + `(type-union + (make-cons-ctype ,car1 (type-union ,cdr1 ,cdr2)) + (make-cons-ctype + (type-intersection + ,car2 + ,(if not1p + not1 + `(specifier-type + `(not ,(type-specifier ,car1))))) + ,cdr2)))) + (cond ((type= car-type1 car-type2) + (make-cons-ctype car-type1 + (type-union cdr-type1 cdr-type2))) + ((type= cdr-type1 cdr-type2) + (make-cons-ctype (type-union car-type1 car-type2) + cdr-type1)) + ((csubtypep car-type1 car-type2) + (frob-car car-type1 car-type2 cdr-type1 cdr-type2)) + ((csubtypep car-type2 car-type1) + (frob-car car-type2 car-type1 cdr-type2 cdr-type1)) + ;; more general case of the above, but harder to compute + ((progn + (setf car-not1 (specifier-type + `(not ,(type-specifier car-type1)))) + (not (csubtypep car-type2 car-not1))) + (frob-car car-type1 car-type2 cdr-type1 cdr-type2 car-not1)) + ((progn + (setf car-not2 (specifier-type + `(not ,(type-specifier car-type2)))) + (not (csubtypep car-type1 car-not2))) + (frob-car car-type2 car-type1 cdr-type2 cdr-type1 car-not2)))))) + +(define-type-method (cons :simple-intersection) (type1 type2) + (declare (type cons-ctype type1 type2)) + (let ((car-int2 (type-intersection2 (cons-ctype-car-ctype type1) + (cons-ctype-car-ctype type2))) + (cdr-int2 (type-intersection2 (cons-ctype-cdr-ctype type1) + (cons-ctype-cdr-ctype type2)))) + (cond ((and car-int2 cdr-int2) + (make-cons-ctype car-int2 cdr-int2)) + (car-int2 + (make-cons-ctype car-int2 + (type-intersection (cons-ctype-cdr-ctype type1) + (cons-ctype-cdr-ctype type2)))) + (cdr-int2 + (make-cons-ctype (type-intersection (cons-ctype-car-ctype type1) + (cons-ctype-car-ctype type2)) + cdr-int2))))) + + + +;;; An UNKNOWN-TYPE is a type not known to the type system (not yet defined). +;;; We make this distinction since we don't want to complain about types that +;;; are hairy but defined. +;;; + +(defun make-unknown-ctype (&key specifier (enumerable t)) + (%istruct 'unknown-ctype + (type-class-or-lose 'hairy) + enumerable + specifier)) + +(defun unknown-ctype-p (x) + (istruct-typep x 'unknown-ctype)) + +(setf (type-predicate 'unknown-ctype) 'unknown-ctype-p) + + + + + +;;;; foreign-type types + + +(defun %make-foreign-ctype (foreign-type) + (%istruct 'foreign-ctype + (type-class-or-lose 'foreign) + nil + foreign-type)) + +(defun foreign-ctype-p (x) (istruct-typep x 'foreign-ctype)) +(setf (type-predicate 'foreign-ctype) 'foreign-ctype-p) + +(define-type-method (foreign :unparse) (type) + `(foreign ,(unparse-foreign-type (foreign-ctype-foreign-type type)))) + +(define-type-method (foreign :simple-subtypep) (type1 type2) + (values (foreign-subtype-p (foreign-ctype-foreign-type type1) + (foreign-ctype-foreign-type type2)) + t)) + +;(define-superclasses foreign (foreign-value)) + +(define-type-method (foreign :simple-=) (type1 type2) + (let ((foreign-type-1 (foreign-ctype-foreign-type type1)) + (foreign-type-2 (foreign-ctype-foreign-type type2))) + (values (or (eq foreign-type-1 foreign-type-2) + (foreign-type-= foreign-type-1 foreign-type-2)) + t))) + +(def-type-translator foreign (&optional (foreign-type nil)) + (typecase foreign-type + (null + (make-foreign-ctype)) + (foreign-type + (make-foreign-ctype foreign-type)) + (t + (make-foreign-ctype (parse-foreign-type foreign-type))))) + +(defun make-foreign-ctype (&optional foreign-type) + (if foreign-type + (let ((lisp-rep-type (compute-lisp-rep-type foreign-type))) + (if lisp-rep-type + (specifier-type lisp-rep-type) + (%make-foreign-ctype foreign-type))) + *universal-type*)) + + +;;; CLASS-CTYPES are supposed to help integrate CLOS and the CMU type system. +;;; They mostly just contain a backpointer to the CLOS class; the CPL is then +;;; used to resolve type relationships. + +(defun class-ctype-p (x) (istruct-typep x 'class-ctype)) +(setf (type-predicate 'class-ctype) 'class-ctype-p) + +(defun args-ctype-p (x) (and (eql (typecode x) target::subtag-istruct) + (member (istruct-type-name x) + '(args-ctype values-ctype function-ctype)))) + +(setf (type-predicate 'args-ctype) 'args-ctype-p + (type-predicate 'function-ctype) 'function-ctype-p + (type-predicate 'values-ctype) 'values-ctype-p) + + +;;; Simple methods for TYPE= and SUBTYPEP should never be called when the two +;;; classes are equal, since there are EQ checks in those operations. +;;; +(define-type-method (class :simple-=) (type1 type2) + (assert (not (eq type1 type2))) + (values nil t)) + +(define-type-method (class :simple-subtypep) (type1 type2) + (assert (not (eq type1 type2))) + (let* ((class1 (if (class-ctype-p type1) (class-ctype-class type1))) + (class2 (if (class-ctype-p type2) (class-ctype-class type2)))) + (if (and class1 class2) + (let* ((ordinal2 (%class-ordinal class2)) + (wrapper1 (%class.own-wrapper class1)) + (bits1 (if wrapper1 (%wrapper-cpl-bits wrapper1)))) + (if bits1 + (locally (declare (simple-bit-vector bits1) + (optimize (speed 3) (safety 0))) + (values (if (< ordinal2 (length bits1)) + (not (eql 0 (sbit bits1 ordinal2)))) + t)) + (if (%standard-instance-p class1) + (if (memq class2 (%class.local-supers class1)) + (values t t) + (if (eq (%class-of-instance class1) + *forward-referenced-class-class*) + (values nil nil) + ;; %INITED-CLASS-CPL will return NIL if class1 can't + ;; be finalized; in that case, we don't know the answer. + (let ((supers (%inited-class-cpl class1))) + (if (memq class2 supers) + (values t t) + (values nil (not (null supers))))))) + (values nil t)))) + (values nil t)))) + +(defun find-class-intersection (c1 c2) + (labels ((walk-subclasses (class f) + (dolist (sub (class-direct-subclasses class)) + (walk-subclasses sub f)) + (funcall f class))) + (let* ((intersection nil)) + (walk-subclasses c1 #'(lambda (c) + (when (subclassp c c2) + (pushnew (%class.ctype c) intersection)))) + (when intersection + (%type-union intersection))))) + +(define-type-method (class :simple-intersection) (type1 type2) + (assert (not (eq type1 type2))) + (let* ((class1 (if (class-ctype-p type1) (class-ctype-class type1))) + (class2 (if (class-ctype-p type2) (class-ctype-class type2)))) + (if (and class1 + (not (typep class1 'compile-time-class)) + class2 + (not (typep class2 'compile-time-class))) + (cond ((subclassp class1 class2) + type1) + ((subclassp class2 class1) + type2) + ;;; In the STANDARD-CLASS case where neither's + ;;; a subclass of the other, there may be + ;;; one or mor classes that're a subclass of both. We + ;;; -could- try to find all such classes, but + ;;; punt instead. + (t (or (find-class-intersection class1 class2) + *empty-type*))) + nil))) + +(define-type-method (class :complex-subtypep-arg2) (type1 class2) + (if (and (intersection-ctype-p type1) + (> (count-if #'class-ctype-p (intersection-ctype-types type1)) 1)) + (values nil nil) + (if (function-ctype-p type1) + (csubtypep (specifier-type 'function) class2) + (invoke-complex-subtypep-arg1-method type1 class2 nil t)))) + +(define-type-method (class :complex-subtypep-arg1) (type1 type2) + (if (and (function-ctype-p type2) + (eq type1 (specifier-type 'function)) + (function-ctype-wild-args type2) + (eq *wild-type* (function-ctype-returns type2))) + (values t t) + (values nil t))) + +(define-type-method (class :unparse) (type) + (class-name (class-ctype-class type))) + + + +;;; TYPE-DIFFERENCE -- Interface +;;; +;;; Return the type that describes all objects that are in X but not in Y. +;;; If we can't determine this type, then return NIL. +;;; +;;; For now, we only are clever dealing with union and member types. If +;;; either type is not a union type, then we pretend that it is a union of just +;;; one type. What we do is remove from X all the types that are a subtype any +;;; type in Y. If any type in X intersects with a type in Y but is not a +;;; subtype, then we give up. +;;; +;;; We must also special-case any member type that appears in the union. We +;;; remove from X's members all objects that are TYPEP to Y. If Y has any +;;; members, we must be careful that none of those members are CTYPEP to any +;;; of Y's non-member types. We give up in this case, since to compute that +;;; difference we would have to break the type from X into some collection of +;;; types that represents the type without that particular element. This seems +;;; too hairy to be worthwhile, given its low utility. +;;; +(defun type-difference (x y) + (let ((x-types (if (union-ctype-p x) (union-ctype-types x) (list x))) + (y-types (if (union-ctype-p y) (union-ctype-types y) (list y)))) + (collect ((res)) + (dolist (x-type x-types) + (if (member-ctype-p x-type) + (collect ((members)) + (dolist (mem (member-ctype-members x-type)) + (multiple-value-bind (val win) (ctypep mem y) + (unless win (return-from type-difference nil)) + (unless val + (members mem)))) + (when (members) + (res (make-member-ctype :members (members))))) + (dolist (y-type y-types (res x-type)) + (multiple-value-bind (val win) (csubtypep x-type y-type) + (unless win (return-from type-difference nil)) + (when val (return)) + (when (types-intersect x-type y-type) + (return-from type-difference nil)))))) + (let ((y-mem (find-if #'member-ctype-p y-types))) + (when y-mem + (let ((members (member-ctype-members y-mem))) + (dolist (x-type x-types) + (unless (member-ctype-p x-type) + (dolist (member members) + (multiple-value-bind (val win) (ctypep member x-type) + (when (or (not win) val) + (return-from type-difference nil))))))))) + (apply #'type-union (res))))) + +;;; CTypep -- Interface +;;; +;;; If Type is a type that we can do a compile-time test on, then return the +;;; whether the object is of that type as the first value and second value +;;; true. Otherwise return NIL, NIL. +;;; +;;; We give up on unknown types, pick off FUNCTION and UNION types. For +;;; structure types, we require that the type be defined in both the current +;;; and compiler environments, and that the INCLUDES be the same. +;;; +(defun ctypep (obj type) + (declare (type ctype type)) + (etypecase type + ((or numeric-ctype named-ctype member-ctype array-ctype cons-ctype) + (values (%typep obj type) t)) + (class-ctype + (values (not (null (class-typep obj (class-ctype-class type)))) t) +) + (union-ctype + (any/type #'ctypep obj (union-ctype-types type))) + (intersection-ctype + (every/type #'ctypep obj (intersection-ctype-types type))) + (function-ctype + (values (functionp obj) t)) + (unknown-ctype + (values nil nil)) + (foreign-ctype + (values (foreign-typep obj (foreign-ctype-foreign-type type)) t)) + (negation-ctype + (multiple-value-bind (res win) + (ctypep obj (negation-ctype-type type)) + (if win + (values (not res) t) + (values nil nil)))) + (hairy-ctype + ;; Now the tricky stuff. + (let* ((hairy-spec (hairy-ctype-specifier type)) + (symbol (if (consp hairy-spec) (car hairy-spec) hairy-spec))) + (ecase symbol + (and ; how would this get there ? + (if (atom hairy-spec) + (values t t) + (dolist (spec (cdr hairy-spec) (values t t)) + (multiple-value-bind (res win) + (ctypep obj (specifier-type spec)) + (unless win (return (values nil nil))) + (unless res (return (values nil t))))))) + (not ; how would this get there ? + (multiple-value-bind + (res win) + (ctypep obj (specifier-type (cadr hairy-spec))) + (if win + (values (not res) t) + (values nil nil)))) + (satisfies + (let ((fun (second hairy-spec))) + (cond ((and (symbolp fun) (fboundp fun)) + ;; Binding *BREAK-ON-SIGNALS* here is a modularity + ;; violation intended to improve the signal-to-noise + ;; ratio on a mailing list. + (values (not (null (let* ((*break-on-signals* nil)) + (ignore-errors (funcall fun obj))))) t)) + (t + (values nil nil)))))))))) + +;;; %TYPEP -- internal. +;;; +;;; The actual typep engine. The compiler only generates calls to this +;;; function when it can't figure out anything more intelligent to do. +;;; +; lose 1 function call -MAYBE +(defun %typep (object specifier) + (%%typep object + (if (typep specifier 'ctype) + specifier + (specifier-type specifier)))) + +(eval-when (:compile-toplevel) + (declaim (inline numeric-%%typep + array-%%typep + member-%%typep + cons-%%typep))) + +(defun numeric-%%typep (object type) + (let ((pred (numeric-ctype-predicate type))) + (if pred + (funcall pred object) + (and (numberp object) + (let ((num (if (complexp object) (realpart object) object))) + (ecase (numeric-ctype-class type) + (integer (integerp num)) + (rational (rationalp num)) + (float + (ecase (numeric-ctype-format type) + (single-float (typep num 'single-float)) + (double-float (typep num 'double-float)) + ((nil) (floatp num)))) + ((nil) t))) + (flet ((bound-test (val) + (let ((low (numeric-ctype-low type)) + (high (numeric-ctype-high type))) + (and (cond ((null low) t) + ((listp low) (> val (car low))) + (t (>= val low))) + (cond ((null high) t) + ((listp high) (< val (car high))) + (t (<= val high))))))) + (ecase (numeric-ctype-complexp type) + ((nil) t) + (:complex + (and (complexp object) + (bound-test (realpart object)) + (bound-test (imagpart object)))) + (:real + (and (not (complexp object)) + (bound-test object))))))))) + +(defun array-%%typep (object type) + (let* ((typecode (typecode object))) + (declare (type (unsigned-byte 8) typecode)) + (and (>= typecode target::subtag-arrayH) + (ecase (array-ctype-complexp type) + ((t) (not (simple-array-p object))) + ((nil) (simple-array-p object)) + ((* :maybe) t)) + (let* ((ctype-dimensions (array-ctype-dimensions type))) + (or (eq ctype-dimensions '*) + (if (eql typecode target::subtag-arrayH) + (let* ((rank (%svref object target::arrayH.rank-cell))) + (declare (fixnum rank)) + (and (eql rank (length ctype-dimensions)) + (do* ((i 0 (1+ i)) + (dim target::arrayH.dim0-cell (1+ dim)) + (want (array-ctype-dimensions type) (cdr want)) + (got (%svref object dim) (%svref object dim))) + ((eql i rank) t) + (unless (or (eq (car want) '*) + (eql (%car want) (the fixnum got))) + (return nil))))) + (and (null (cdr ctype-dimensions)) + (or (eq (%car ctype-dimensions) '*) + (eql (%car ctype-dimensions) + (if (eql typecode target::subtag-vectorH) + (%svref object target::vectorH.physsize-cell) + (uvsize object)))))))) + (or (eq (array-ctype-element-type type) *wild-type*) + (eql (array-ctype-typecode type) + (if (> typecode target::subtag-vectorH) + typecode + (ldb target::arrayH.flags-cell-subtag-byte (the fixnum (%svref object target::arrayH.flags-cell))))) + (type= (array-ctype-specialized-element-type type) + (specifier-type (array-element-type object))))))) + + +(defun member-%%typep (object type) + (not (null (member object (member-ctype-members type))))) + +(defun cons-%%typep (object type) + (and (consp object) + (%%typep (car object) (cons-ctype-car-ctype type)) + (%%typep (cdr object) (cons-ctype-cdr-ctype type)))) + + +(defun %%typep (object type) + ;(if (not (typep type 'ctype))(setq type (specifier-type type))) + (locally (declare (type ctype type)) + (etypecase type + (named-ctype + (ecase (named-ctype-name type) + ((* t) t) + ((nil) nil))) + (numeric-ctype + (numeric-%%typep object type)) + (array-ctype + (array-%%typep object type)) + (member-ctype + (member-%%typep object type)) + (class-ctype + (not (null (class-typep object (class-ctype-class type))))) + (union-ctype + (dolist (type (union-ctype-types type)) + (when (%%typep object type) + (return t)))) + (intersection-ctype + (dolist (type (intersection-ctype-types type) t) + (unless (%%typep object type) (return nil)))) + (cons-ctype + (cons-%%typep object type)) + (unknown-ctype + ;; Parse it again to make sure it's really undefined. + (let ((reparse (specifier-type (unknown-ctype-specifier type)))) + (if (typep reparse 'unknown-ctype) + (error "Unknown type specifier: ~S" + (unknown-ctype-specifier reparse)) + (%%typep object reparse)))) + (negation-ctype + (not (%%typep object (negation-ctype-type type)))) + (hairy-ctype + ;; Now the tricky stuff. + (let* ((hairy-spec (hairy-ctype-specifier type)) + (symbol (if (consp hairy-spec) (car hairy-spec) hairy-spec))) + (ecase symbol + (and + (or (atom hairy-spec) + (dolist (spec (cdr hairy-spec) t) + (unless (%%typep object (specifier-type spec)) + (return nil))))) + (not + (unless (and (listp hairy-spec) (= (length hairy-spec) 2)) + (error "Invalid type specifier: ~S" hairy-spec)) + (not (%%typep object (specifier-type (cadr hairy-spec))))) + (satisfies + (unless (and (listp hairy-spec) (= (length hairy-spec) 2)) + (error "Invalid type specifier: ~S" hairy-spec)) + (let ((fn (cadr hairy-spec))) + (if (funcall (typecase fn + (function fn) + (symbol (symbol-function fn)) + (t + (coerce fn 'function))) + object) + t + nil)))))) + #| + (foreign-ctype + (foreign-typep object (foreign-ctype-foreign-type type))) +|# + (function-ctype + (error "Function types are not a legal argument to TYPEP:~% ~S" + (type-specifier type)))))) + + +;;; Ctype-Of -- Interface +;;; +;;; Like Type-Of, only returns a Type structure instead of a type +;;; specifier. We try to return the type most useful for type checking, rather +;;; than trying to come up with the one that the user might find most +;;; informative. +;;; + +(defun float-format-name (x) + (declare (float x)) + (etypecase x + (single-float "SINGLE-FLOAT") + (double-float "DOUBLE-FLOAT"))) + +(defun ctype-of-number (x) + (let ((num (if (complexp x) (realpart x) x))) + (multiple-value-bind (complexp low high) + (if (complexp x) + (let ((imag (imagpart x))) + (values :complex (min num imag) (max num imag))) + (values :real num num)) + (make-numeric-ctype :class (etypecase num + (integer (if (complexp x) + (if (integerp (imagpart x)) + 'integer + 'rational) + 'integer)) + (rational 'rational) + (float 'float)) + :format (and (floatp num) + (if (typep num 'double-float) + 'double-float + 'single-float)) + :complexp complexp + :low low + :high high)))) + +(defun ctype-of (x) + (typecase x + (function (specifier-type 'function)) ; GFs .. + (symbol + (make-member-ctype :members (list x))) + (number (ctype-of-number x)) + (array + (let ((etype (specifier-type (array-element-type x)))) + (make-array-ctype :dimensions (array-dimensions x) + :complexp (not (typep x 'simple-array)) + :element-type etype + :specialized-element-type etype))) + (t + (%class.ctype (class-of x))))) + +(defvar *ctype-of-double-float-0* (ctype-of 0.0d0)) +(defvar *ctype-of-single-float-0* (ctype-of 0.0f0)) + + + + +; These DEFTYPES should only happen while initializing. + +(progn +(let-globally ((*type-system-initialized* nil)) + + +(deftype bit () '(integer 0 1)) + +(deftype eql (val) `(member ,val)) + +(deftype signed-byte (&optional s) + (cond ((eq s '*) 'integer) + ((and (integerp s) (> s 0)) + (let ((bound (ash 1 (1- s)))) + `(integer ,(- bound) ,(1- bound)))) + (t + (signal-program-error "Bad size specified for SIGNED-BYTE type specifier: ~S." s)))) + +(deftype unsigned-byte (&optional s) + (cond ((eq s '*) '(integer 0)) + ((and (integerp s) (> s 0)) + `(integer 0 ,(1- (ash 1 s)))) + (t + (error "Bad size specified for UNSIGNED-BYTE type specifier: ~S." s)))) + +(deftype vector (&optional element-type size) + `(array ,element-type (,size))) + +(deftype simple-vector (&optional size) + `(simple-array t (,size))) + +(deftype base-string (&optional size) + `(array base-char (,size))) +(deftype simple-base-string (&optional size) + `(simple-array base-char (,size))) + + + +(deftype string (&optional size) + `(array character (,size))) + +(deftype simple-string (&optional size) + `(simple-array character (,size))) + +(deftype bit-vector (&optional size) + `(array bit (,size))) + +(deftype simple-bit-vector (&optional size) + `(simple-array bit (,size))) + +; TYPE-OF sometimes returns random symbols that aren't really type specifiers. + +(deftype simple-unsigned-word-vector (&optional size) + `(simple-array (unsigned-byte 16) (,size))) + +(deftype simple-unsigned-byte-vector (&optional size) + `(simple-array (unsigned-byte 8) (,size))) + +(deftype simple-unsigned-long-vector (&optional size) + `(simple-array (unsigned-byte 32) (,size))) + +(deftype simple-signed-word-vector (&optional size) + `(simple-array (signed-byte 16) (,size))) + +(deftype simple-signed-byte-vector (&optional size) + `(simple-array (signed-byte 8) (,size))) + +(deftype simple-signed-long-vector (&optional size) + `(simple-array (signed-byte 32) (,size))) + + + +(deftype simple-short-float-vector (&optional size) + `(simple-array short-float (,size))) + +(deftype unsigned-word-vector (&optional size) + `(vector (unsigned-byte 16) ,size)) + +(deftype single-float-vector (&optional size) + `(vector short-float ,size)) + +(deftype unsigned-byte-vector (&optional size) + `(vector (unsigned-byte 8) ,size)) + +(deftype unsigned-long-vector (&optional size) + `(vector (unsigned-byte 32) ,size)) + +(deftype long-float-vector (&optional size) + `(vector double-float ,size)) + +(deftype long-vector (&optional size) + `(vector (signed-byte 32) ,size)) + +(deftype double-float-vector (&optional size) + `(vector double-float ,size)) + +(deftype byte-vector (&optional size) + `(vector (signed-byte 8) ,size)) + +(deftype general-vector (&optional size) + `(vector t ,size)) + +(deftype word-vector (&optional size) + `(vector (signed-byte 16) ,size)) + +(deftype short-float-vector (&optional size) + `(vector single-float ,size)) + +(deftype simple-1d-array (&optional size) + `(simple-array * (,size))) + +(deftype simple-long-vector (&optional size) + `(simple-array (signed-byte 32) (,size))) + +(deftype simple-word-vector (&optional size) + `(simple-array (signed-byte 16) (,size))) + +(deftype simple-short-float-vector (&optional size) + `(simple-array single-float (,size))) + +(deftype simple-byte-vector (&optional size) + `(simple-array (signed-byte 8) (,size))) + +(deftype simple-double-float-vector (&optional size) + `(simple-array double-float (,size))) + +(deftype simple-single-float-vector (&optional size) + `(simple-array single-float (,size))) + +(deftype simple-long-float-vector (&optional size) + `(simple-array double-float (,size))) + +(deftype simple-fixnum-vector (&optional size) + `(simple-array fixnum (,size))) + +(deftype fixnum-vector (&optional size) + `(array fixnum (,size))) + +#+64-bit-target +(deftype simple-doubleword-vector (&optional size) + `(simple-array (signed-byte 64) (,size))) + +#+64-bit-target +(deftype simple-unsigned-doubleword-vector (&optional size) + `(simple-array (unsigned-byte 64) (,size))) + + +(deftype short-float (&optional low high) + `(single-float ,low ,high)) + +(deftype long-float (&optional low high) + `(double-float ,low ,high)) + +#|| +;;; As empty a type as you're likely to find ... +(deftype extended-char () + "Type of CHARACTERs that aren't BASE-CHARs." + nil) +||# + +(deftype natural () + `(unsigned-byte ,target::nbits-in-word)) + +(deftype signed-natural () + `(signed-byte ,target::nbits-in-word)) +) + + +(let* ((builtin-translations + `((array . array) + (simple-array . simple-array) + (cons . cons) + (vector . vector) + (null . (member nil)) + (list . (or cons null)) + (sequence . (or list vector)) + (simple-vector . simple-vector) + (bit-vector . bit-vector) + (simple-bit-vector . simple-bit-vector) + (simple-string . simple-string) + (simple-base-string . simple-base-string) + (string . string) + (base-string . base-string) + (real . real) + (complex . complex) + (float . float) + (double-float . double-float) + (long-float . double-float) + (single-float . single-float) + (short-float . single-float) + + (rational . rational) + (integer . integer) + (ratio . (and rational (not integer))) + (fixnum . (integer ,target::target-most-negative-fixnum + ,target::target-most-positive-fixnum)) + (bignum . (or (integer * (,target::target-most-negative-fixnum)) + (integer (,target::target-most-positive-fixnum) *))) + + ))) + (dolist (spec builtin-translations) + (setf (info-type-kind (car spec)) :primitive + (info-type-builtin (car spec)) (specifier-type (cdr spec))))) + + + + + + +(precompute-types '((mod 2) (mod 4) (mod 16) (mod #x100) (mod #x10000) + #-cross-compiling + (mod #x100000000) + (unsigned-byte 1) + (unsigned-byte 8) (unsigned-byte 16) (unsigned-byte 32) + (unsigned-byte 64) + (signed-byte 8) (signed-byte 16) (signed-byte 32) + (signed-byte 64) + (or function symbol) + )) + + +(precompute-types *cl-types*) + +;;; Treat CHARACTER and BASE-CHAR as equivalent. +(setf (info-type-builtin 'character) (info-type-builtin 'base-char)) +;;; And EXTENDED-CHAR as empty. +(setf (info-type-builtin 'extended-char) *empty-type*) + +(defparameter *null-type* (specifier-type 'null)) + + +(flet ((set-builtin-class-type-translation (thing) + (let* ((class-name (if (atom thing) thing (car thing))) + (spec (if (atom thing) thing (cadr thing))) + (spectype (specifier-type spec))) + (setf (class-ctype-translation + (%class.ctype (find-class class-name))) spectype)))) + (mapc #'set-builtin-class-type-translation + '( + ;; Root Of All Evil + t + ;; Numbers: + number real ratio complex rational fixnum + ;; Integers: + signed-byte unsigned-byte bit bignum integer + ;; Floats + float double-float single-float + ;; Arrays + array + ;; Simple Arrays + simple-array + ;; Vectors + vector string base-string bit-vector + unsigned-byte-vector unsigned-word-vector unsigned-long-vector + byte-vector word-vector long-vector + single-float-vector double-float-vector + general-vector + fixnum-vector + #+64-bit-target + doubleword-vector + #+64-bit-target + unsigned-doubleword-vector + ;; Simple 1-Dimensional Arrays + simple-1d-array simple-string simple-base-string simple-bit-vector + simple-unsigned-byte-vector + simple-unsigned-long-vector + simple-unsigned-word-vector + simple-byte-vector + simple-word-vector + simple-long-vector + simple-single-float-vector + simple-double-float-vector + simple-vector + simple-fixnum-vector + #+64-bit-target + simple-doubleword-vector + #+64-bit-target + simple-unsigned-doubleword-vector + ;; Sequence types + sequence list cons null + + ) + + )) +) +;(setq *type-system-initialized* t) + + + + +; These deftypes help the CMUCL compiler; the type system doesn't depend on them. + +;;; Since Clozure CL's DEFTYPE tries to globally define the type +;;; at compile-time as well as load- and execute time, hide +;;; the definition of these "built-in" types. (It'd be cleaner +;;; to make DEFTYPE do something saner at compile-time.) +(let* () ; make the following be non-toplevel +(deftype boolean () '(member t nil)) + +(deftype atom () '(not cons)) +;;; +;;; A type specifier. +(deftype type-specifier () '(or list symbol class)) +;;; +;;; An index into an array. Also used for sequence index. +(deftype index () `(integer 0 (,array-dimension-limit))) +;;; +;;; Array rank, total size... +(deftype array-rank () `(integer 0 (,array-rank-limit))) +(deftype array-total-size () `(integer 0 (,array-total-size-limit))) +;;; +;;; Some thing legal in an evaluated context. +(deftype form () t) +;;; +;;; Maclisp compatibility... +(deftype stringlike () '(or string symbol)) +(deftype stringable () '(or string symbol character)) +;;; +;;; Save a little typing... +(deftype truth () '(member t)) +;;; +;;; A thing legal in places where we want the name of a file. +(deftype filename () '(or string pathname)) +;;; +;;; A legal arg to pathname functions. +(deftype pathnamelike () '(or string pathname stream)) +;;; +;;; A thing returned by the irrational functions. We assume that they never +;;; compute a rational result. +(deftype irrational () '(or float (complex float))) +;;; +;;; Character components: +(deftype char-code () `(integer 0 (,char-code-limit))) +;;; +;;; A consed sequence result. If a vector, is a simple array. +(deftype consed-sequence () '(or list (simple-array * (*)))) +;;; +;;; The :end arg to a sequence... +(deftype sequence-end () '(or null index)) +;;; +;;; A valid argument to a stream function... +(deftype streamlike () '(or stream (member nil t))) +;;; +;;; A thing that can be passed to funcall & friends. +(deftype callable () '(or function symbol)) + +;;; Until we decide if and how to wedge this into the type system, make it +;;; equivalent to t. +;;; +(deftype void () t) +;;; +;;; An index into an integer. +(deftype bit-index () `(integer 0 ,target::target-most-positive-fixnum)) +;;; +;;; Offset argument to Ash (a signed bit index). +(deftype ash-index () 'fixnum) + +;;; Not sure how to do this without SATISFIES. +(deftype setf-function-name () `(satisfies setf-function-name-p)) + +;;; Better than nothing, arguably. +(deftype function-name () `(or symbol setf-function-name)) + +(deftype valid-char-code () `(satisfies valid-char-code-p)) + +) ; end of LET* sleaze + +(defun array-or-union-ctype-element-type (ctype) + (if (typep ctype 'array-ctype) + (type-specifier (array-ctype-element-type ctype)) + (if (typep ctype 'union-ctype) + `(or ,@(mapcar #'array-or-union-ctype-element-type + (union-ctype-types ctype)))))) + + +(defvar *simple-predicate-function-prototype* + #'(lambda (thing) + (%%typep thing #.(specifier-type t)))) + +(defun make-simple-type-predicate (function datum) + #+ppc-target + (gvector :function + (uvref *simple-predicate-function-prototype* 0) + datum + function + nil + (dpb 1 $lfbits-numreq 0)) + #+x86-target + (%clone-x86-function + *simple-predicate-function-prototype* + datum + function + nil + (dpb 1 $lfbits-numreq 0))) + +(defun check-ctypep (thing ctype) + (multiple-value-bind (win sure) (ctypep thing ctype) + (or win (not sure)))) + + +(defun generate-predicate-for-ctype (ctype) + (typecase ctype + (numeric-ctype + (or (numeric-ctype-predicate ctype) + (make-simple-type-predicate 'numeric-%%typep ctype))) + (array-ctype + (make-simple-type-predicate 'array-%%typep ctype)) + (member-ctype + (make-simple-type-predicate 'member-%%typep ctype)) + (named-ctype + (case (named-ctype-name ctype) + ((* t) #'true) + (t #'false))) + (cons-ctype + (make-simple-type-predicate 'cons-%%typep ctype)) + (function-ctype + #'functionp) + (class-ctype + (make-simple-type-predicate 'class-cell-typep (find-class-cell (class-name (class-ctype-class ctype)) t))) + (t + (make-simple-type-predicate 'check-ctypep ctype)))) + + + + + +;;; Ensure that standard EFFECTIVE-SLOT-DEFINITIONs have a meaningful +;;; type predicate, if we can. +(defmethod shared-initialize :after ((spec effective-slot-definition) + slot-names + &key + &allow-other-keys) + (declare (ignore slot-names)) + (let* ((type (slot-definition-type spec))) + (setf (slot-value spec 'type-predicate) + (or (and (typep type 'symbol) + (not (eq type 't)) + (type-predicate type)) + (handler-case + (let* ((ctype (specifier-type type))) + (unless (eq ctype *universal-type*) + (generate-predicate-for-ctype ctype))) + (program-error () + (warn "Invalid type specifier ~s in slot definition for ~s in class ~s." type (slot-definition-name spec) (slot-definition-class spec)) + (lambda (v) + (cerror "Allow the assignment or initialization." + "Can't determine whether or not the value ~s should be used to initialize or assign to the slot ~&named ~s in an instance of ~s, because the slot is declared ~&to be of the invalid type ~s." + v (slot-definition-name spec) (slot-definition-class spec) (slot-definition-type spec)) + ;; Suppress further checking, at least for things that use this effective slotd. + ;; (It's hard to avoid this, and more trouble than it's worth to do better.) + (setf (slot-value spec 'type-predicate) nil) + t)) + (parse-unknown-type (c) + (declare (ignore c)) + #'(lambda (value) + ;; If the type's now known, install a new predicate. + (let* ((nowctype (specifier-type type))) + (unless (typep nowctype 'unknown-ctype) + (setf (slot-value spec 'type-predicate) + (generate-predicate-for-ctype nowctype))) + (multiple-value-bind (win sure) + (ctypep value nowctype) + (or (not sure) win)))))))))) + Index: /branches/new-random/level-1/l1-unicode.lisp =================================================================== --- /branches/new-random/level-1/l1-unicode.lisp (revision 13309) +++ /branches/new-random/level-1/l1-unicode.lisp (revision 13309) @@ -0,0 +1,6402 @@ +;;;-*-Mode: LISP; Package: CCL -*- +;;; +;;; Copyright (C) 2006-2009 Clozure Associates and contributors. +;;; This file is part of Clozure CL. +;;; +;;; Clozure CL is licensed under the terms of the Lisp Lesser GNU Public +;;; License , known as the LLGPL and distributed with Clozure CL as the +;;; file "LICENSE". The LLGPL consists of a preamble and the LGPL, +;;; which is distributed with Clozure CL as the file "LGPL". Where these +;;; conflict, the preamble takes precedence. +;;; +;;; Clozure CL is referenced in the preamble as the "LIBRARY." +;;; +;;; The LLGPL is also available online at +;;; http://opensource.franz.com/preamble.html + + +;;; Unicode translation stuff, mostly in support of I/O. + +(in-package "CCL") + + +(defvar *character-encodings* (make-hash-table :test #'eq)) + +(defun lookup-character-encoding (name) + (gethash name *character-encodings*)) + +(defun get-character-encoding (name) + (or (lookup-character-encoding name) + (error "Unknown character encoding: ~s." name))) + +(defun (setf get-character-encoding) (new name) + (setf (gethash name *character-encodings*) new)) + +(defun ensure-character-encoding (thing) + (if (typep thing 'character-encoding) + thing + (or (lookup-character-encoding thing) + (error "~s is not a character-encoding or the name of a character-encoding." + thing)))) + + +(defun character-encoded-in-single-octet (c) + (declare (ignore c)) + 1) + +(defstruct character-encoding + (name ()) ;canonical name + (code-unit-size 8) ;in bits: 8, 16, 32 + (native-endianness t) ;if nil, need to swap 16,32-bit units + (max-units-per-char 1) ;usually 1-4 + + ;; Writes CHAR (or a replacement character if CHAR can't be encoded) + ;; to STREAM and returns the number of code-units written. + stream-encode-function ;(CHAR WRITE-FUNCTION STREAM) + + ;; Returns a charcter (possibly #\Replacement_Character) or :EOF. + stream-decode-function ;(1ST-UNIT NEXT-UNIT STREAM) + + ;; Sets 1 or more units in a vector argument and returns a value 1 + ;; greater than the index of the last octet written to the vector + vector-encode-function ;(STRING VECTOR INDEX START END) + + ;; Returns a value 1 greater than the last octet index consumed from + ;; the vector argument. + vector-decode-function ;(VECTOR INDEX NOCTETS STRING) + + ;; Sets one or more units in memory at the address denoted by + ;; the pointer and index arguments and returns (+ idx number of + ;; units written to memory), else returns NIL if any character + ;; can't be encoded. + memory-encode-function ;(STRING POINTER INDEX START END) + + + ;; Returns (as multiple values) the string encoded in memory + ;; at the address denoted by the address and index args and the + ;; sum of the index arg and the number of octets consumed. + memory-decode-function ;(POINTER NOCTETS INDEX STRING) + + ;; Returns the number of octets needed to encode STRING between START and END + octets-in-string-function ;(STRING START END) + + ;; Returns the number of (full) characters encoded in VECTOR, and + ;; the index the index of the first octet not used to encode + ;; them. (The second value may be less than END. + length-of-vector-encoding-function ;(VECTOR START END) + + ;; Returns the number of (full) characters encoded in memory at (+ POINTER START) + ;; and the number of octets used to encode them. (The second value may be less + ;; than NOCTETS.) + length-of-memory-encoding-function ;(POINTER NOCTETS START) + + ;; Code units less than this value map to themselves on input. + (decode-literal-code-unit-limit 0) + + ;; Does a byte-order-mark determine the endianness of input ? + ;; Should we prepend a BOM to output ? + ;; If non-nil, the value should be the name of the an encoding + ;; that implements this encoding with swapped byte order. + (use-byte-order-mark nil) + ;; What alternate line-termination conventions can be encoded ? (This basically + ;; means "can #\Line_Separator be encoded?", since :CR and :CRLF can always + ;; be encoded.) + (alternate-line-termination-conventions '(:cr :crlf)) + ;; By what other MIME names is this encoding known ? + (aliases nil) + (documentation nil) + ;; What does a native byte-order-mark look like (as a sequence of octets) + ;; in this encoding ? (NIL if a BOM can't be encoded.) + (bom-encoding nil) + ;; How is #\NUL encoded, as a sequence of octets ? (Typically, as a minimal- + ;; length sequenve of 0s, but there are exceptions.) + (nul-encoding #(0)) + ;; Char-codes less than this value map to themselves on output. + (encode-literal-char-code-limit 0) + (character-size-in-octets-function 'character-encoded-in-single-octet) + ) + +(defconstant byte-order-mark #\u+feff) +(defconstant byte-order-mark-char-code (char-code byte-order-mark)) +(defconstant swapped-byte-order-mark-char-code #xfffe) + + +(defmethod default-character-encoding ((domain t)) + (character-encoding-name (get-character-encoding nil))) + +(defun decode-character-encoded-vector (encoding vector start-index noctets string) + (setq encoding (ensure-character-encoding encoding)) + (unless (= (the (unsigned-byte 8) (typecode vector)) + target::subtag-u8-vector) + (report-bad-arg vector '(simple-array (unsigned-byte 8) (*)))) + (unless (= (the (unsigned-byte 8) (typecode string)) + target::subtag-simple-base-string) + (report-bad-arg vector 'simple-string)) + (let* ((len (length vector))) + (declare (type index len)) + (unless (and (typep start-index 'fixnum) + (>= (the fixnum start-index) 0) + (< (the fixnum start-index) len)) + (error "~s is an invalid start index for ~s" start-index vector)) + (unless (and (typep noctets 'fixnum) + (>= (the fixnum noctets) 0) + (<= (+ (the fixnum start-index) (the fixnum noctets)) len)) + (error "~S is an invalid octet count for ~s at ~s" noctets vector start-index)) + (funcall (character-encoding-vector-decode-function encoding) + vector + start-index + noctets + string))) + + +(defmethod print-object ((ce character-encoding) stream) + (print-unreadable-object (ce stream :type t :identity t) + (format stream "~a" (character-encoding-name ce)))) + +;;; N.B. (ccl:nfunction (lambda (...) ...)) is just like +;;; (cl:function (lambda (...) ...)), except that the resulting +;;; function will have "name" (this is often helpful when debugging.) + +(defmacro define-character-encoding (name doc &rest args &key &allow-other-keys) + (setq name (intern (string name) "KEYWORD")) + (let* ((encoding (gensym)) + (alias (gensym))) + `(let* ((,encoding (make-character-encoding :name ,name :documentation ,doc ,@args))) + (setf (get-character-encoding ,name) ,encoding) + (dolist (,alias (character-encoding-aliases ,encoding)) + (setf (get-character-encoding ,alias) ,encoding)) + ',name))) + +(defun encoding-name (encoding) + (character-encoding-name (or encoding (get-character-encoding nil)))) + +;;; ISO-8859-1 is trivial, though of course it can't really encode characters +;;; whose CHAR-CODE is >= 256 + +(defun 8-bit-fixed-width-octets-in-string (string start end) + (declare (ignore string)) + (if (>= end start) + (- end start) + 0)) + +(defun 8-bit-fixed-width-length-of-vector-encoding (vector start end) + (declare (ignore vector)) + (if (>= end start) + (values (- end start) end) + (values 0 start))) + +(defun 8-bit-fixed-width-length-of-memory-encoding (pointer noctets start) + (declare (ignore pointer start)) + (values noctets noctets)) + +(define-character-encoding :iso-8859-1 + "An 8-bit, fixed-width character encoding in which all character +codes map to their Unicode equivalents. Intended to support most +characters used in most Western European languages." + + ;; The NIL alias is used internally to mean that ISO-8859-1 is + ;; the "null" 8-bit encoding + :aliases '(nil :iso_8859-1 :latin1 :l1 :ibm819 :cp819 :csISOLatin1) + :stream-encode-function + (nfunction + iso-8859-1-stream-encode + (lambda (char write-function stream) + (let* ((code (char-code char))) + (declare (type (mod #x110000) code)) + (if (>= code 256) + (setq code (char-code #\Sub))) + (funcall write-function stream code) + 1))) + :stream-decode-function + (nfunction + iso-8859-1-stream-decode + (lambda (1st-unit next-unit-function stream) + (declare (ignore next-unit-function stream) + (type (unsigned-byte 8) 1st-unit)) + (code-char 1st-unit))) + :vector-encode-function + (nfunction + iso-8859-1-vector-encode + (lambda (string vector idx start end) + (declare (type (simple-array (unsigned-byte 8) (*)) vector) + (fixnum idx)) + (do* ((i start (1+ i))) + ((>= i end) idx) + (let* ((char (schar string i)) + (code (char-code char))) + (declare (type (mod #x110000) code)) + (if (>= code 256) + (setq code (char-code #\Sub))) + (progn + (setf (aref vector idx) code) + (incf idx)))))) + :vector-decode-function + (nfunction + iso-8859-1-vector-decode + (lambda (vector idx noctets string) + (declare (type (simple-array (unsigned-byte 8) (*)) vector)) + (do* ((i 0 (1+ i)) + (index idx (1+ index))) + ((>= i noctets) index) + (setf (schar string i) (code-char (the (unsigned-byte 8) + (aref vector index))))))) + :memory-encode-function + (nfunction + iso-8859-1-memory-encode + (lambda (string pointer idx start end) + (do* ((i start (1+ i))) + ((>= i end) idx) + (let* ((code (char-code (schar string i)))) + (declare (type (mod #x110000) code)) + (if (>= code 256) + (setq code (char-code #\Sub))) + (setf (%get-unsigned-byte pointer idx) code) + (incf idx))))) + :memory-decode-function + (nfunction + iso-8859-1-memory-decode + (lambda (pointer noctets idx string) + (do* ((i 0 (1+ i)) + (index idx (1+ index))) + ((>= i noctets) index) + (setf (schar string i) (code-char (the (unsigned-byte 8) + (%get-unsigned-byte pointer index))))))) + :octets-in-string-function + #'8-bit-fixed-width-octets-in-string + :length-of-vector-encoding-function + #'8-bit-fixed-width-length-of-vector-encoding + :length-of-memory-encoding-function + #'8-bit-fixed-width-length-of-memory-encoding + :decode-literal-code-unit-limit 256 + :encode-literal-char-code-limit 256 + ) + +(define-character-encoding :us-ascii + "A 7-bit, fixed-width character encoding in which all character +codes map to their Unicode equivalents." + + :aliases '(:csASCII :cp637 :IBM637 :us :ISO646-US :ascii :ISO-ir-6) + :stream-encode-function + (nfunction + ascii-stream-encode + (lambda (char write-function stream) + (let* ((code (char-code char))) + (declare (type (mod #x110000) code)) + (when (>= code 128) + (setq code (char-code #\Sub))) + (funcall write-function stream code) + 1))) + :stream-decode-function + (nfunction + ascii-stream-decode + (lambda (1st-unit next-unit-function stream) + (declare (ignore next-unit-function stream) + (type (unsigned-byte 8) 1st-unit)) + (if (< 1st-unit 128) + (code-char 1st-unit) + #\Replacement_Character))) + :vector-encode-function + (nfunction + ascii-vector-encode + (lambda (string vector idx start end) + (declare (type (simple-array (unsigned-byte 8) (*)) vector) + (fixnum idx)) + (do* ((i start (1+ i))) + ((>= i end) idx) + (let* ((char (schar string i)) + (code (char-code char))) + (declare (type (mod #x110000) code)) + (if (>= code 128) + (setq code (char-code #\Sub))) + (setf (aref vector idx) code) + (incf idx))))) + :vector-decode-function + (nfunction + ascii-vector-decode + (lambda (vector idx noctets string) + (declare (type (simple-array (unsigned-byte 8) (*)) vector)) + (do* ((i 0 (1+ i)) + (index idx (1+ index))) + ((>= i noctets) index) + (let* ((code (aref vector index))) + (declare (type (unsigned-byte 8) code)) + (when (>= code 128) + (setq code (char-code #\Sub))) + (setf (schar string i) (code-char code)))))) + :memory-encode-function + (nfunction + ascii-memory-encode + (lambda (string pointer idx start end) + (do* ((i start (1+ i))) + ((>= i end) idx) + (let* ((code (char-code (schar string i)))) + (declare (type (mod #x110000) code)) + (if (>= code 128) + (setq code (char-code #\Sub))) + (setf (%get-unsigned-byte pointer idx) code) + (incf idx))))) + :memory-decode-function + (nfunction + ascii-memory-decode + (lambda (pointer noctets idx string) + (do* ((i 0 (1+ i)) + (index idx (1+ index))) + ((>= i noctets) index) + (let* ((code (%get-unsigned-byte pointer index))) + (declare (type (unsigned-byte 8) code)) + (if (>= code 128) + (setf (schar string i) #\sub) + (setf (schar string i) (code-char code))))))) + :octets-in-string-function + #'8-bit-fixed-width-octets-in-string + :length-of-vector-encoding-function + #'8-bit-fixed-width-length-of-vector-encoding + :length-of-memory-encoding-function + #'8-bit-fixed-width-length-of-memory-encoding + :decode-literal-code-unit-limit 128 + :encode-literal-char-code-limit 128 + ) + + + +;;; Other 1-byte, fixed-width encodings. Typically, codes in the range +;;; #x00-#x9f maps straight through, while codes #xa0-#xff select arbitrary +;;; Unicode characters that are commonly used in some locale. (Sometimes +;;; the break is at #x80 instead of #xa0). + +(defstatic *iso-8859-2-to-unicode* + #( + ;; #xa0 + #\u+00a0 #\u+0104 #\u+02d8 #\u+0141 #\u+00a4 #\u+013d #\u+015a #\u+00a7 + #\u+00a8 #\u+0160 #\u+015e #\u+0164 #\u+0179 #\u+00ad #\u+017d #\u+017b + ;; #xb0 + #\u+00b0 #\u+0105 #\u+02db #\u+0142 #\u+00b4 #\u+013e #\u+015b #\u+02c7 + #\u+00b8 #\u+0161 #\u+015f #\u+0165 #\u+017a #\u+02dd #\u+017e #\u+017c + ;; #xc0 + #\u+0154 #\u+00c1 #\u+00c2 #\u+0102 #\u+00c4 #\u+0139 #\u+0106 #\u+00c7 + #\u+010c #\u+00c9 #\u+0118 #\u+00cb #\u+011a #\u+00cd #\u+00ce #\u+010e + ;; #xd0 + #\u+0110 #\u+0143 #\u+0147 #\u+00d3 #\u+00d4 #\u+0150 #\u+00d6 #\u+00d7 + #\u+0158 #\u+016e #\u+00da #\u+0170 #\u+00dc #\u+00dd #\u+0162 #\u+00df + ;; #xe0 + #\u+0155 #\u+00e1 #\u+00e2 #\u+0103 #\u+00e4 #\u+013a #\u+0107 #\u+00e7 + #\u+010d #\u+00e9 #\u+0119 #\u+00eb #\u+011b #\u+00ed #\u+00ee #\u+010f + ;; #xf0 + #\u+0111 #\u+0144 #\u+0148 #\u+00f3 #\u+00f4 #\u+0151 #\u+00f6 #\u+00f7 + #\u+0159 #\u+016f #\u+00fa #\u+0171 #\u+00fc #\u+00fd #\u+0163 #\u+02d9 +)) + +(defstatic *unicode-00a0-0180-to-iso-8859-2* + #( + #xa0 nil nil nil #xa4 nil nil #xa7 ; #xa0-#xa7 + #xa8 nil nil nil nil #xad nil nil ; #xa8-#xaf + #xb0 nil nil nil #xb4 nil nil nil ; #xb0-#xb7 + #xb8 nil nil nil nil nil nil nil ; #xb8-#xbf + nil #xc1 #xc2 nil #xc4 nil nil #xc7 ; #xc0-#xc7 + nil #xc9 nil #xcb nil #xcd #xce nil ; #xc8-#xcf + nil nil nil #xd3 #xd4 nil #xd6 #xd7 ; #xd0-#xd7 + nil nil #xda nil #xdc #xdd nil #xdf ; #xd8-#xdf + nil #xe1 #xe2 nil #xe4 nil nil #xe7 ; #xe0-#xe7 + nil #xe9 nil #xeb nil #xed #xee nil ; #xe8-#xef + nil nil nil #xf3 #xf4 nil #xf6 #xf7 ; #xf0-#xf7 + nil nil #xfa nil #xfc #xfd nil nil ; #xf8-#xff + ;; #x0100 + nil nil #xc3 #xe3 #xa1 #xb1 #xc6 #xe6 ; #x100-#x107 + nil nil nil nil #xc8 #xe8 #xcf #xef ; #x108-#x10f + #xd0 #xf0 nil nil nil nil nil nil ; #x110-#x117 + #xca #xea #xcc #xec nil nil nil nil ; #x118-#x11f + nil nil nil nil nil nil nil nil ; #x120-#x127 + nil nil nil nil nil nil nil nil ; #x128-#x12f + nil nil nil nil nil nil nil nil ; #x130-#x137 + nil #xc5 #xe5 nil nil #xa5 #xb5 nil ; #x138-#x13f + nil #xa3 #xb3 #xd1 #xf1 nil nil #xd2 ; #x140-#x147 + #xf2 nil nil nil nil nil nil nil ; #x148-#x14f + #xd5 #xf5 nil nil #xc0 #xe0 nil nil ; #x150-#x157 + #xd8 #xf8 #xa6 #xb6 nil nil #xaa #xba ; #x158-#x15f + #xa9 #xb9 #xde #xfe #xab #xbb nil nil ; #x160-#x167 + nil nil nil nil nil nil #xd9 #xf9 ; #x168-#x16f + #xdb #xfb nil nil nil nil nil nil ; #x170-#x177 + nil #xac #xbc #xaf #xbf #xae #xbe nil ; #x178-#x17f + )) + +(defstatic *unicode-00c0-00e0-to-iso-8859-2* + #( + nil nil nil nil nil nil nil #xb7 ; #xc0-#xc7 + nil nil nil nil nil nil nil nil ; #xc8-#xcf + nil nil nil nil nil nil nil nil ; #xd0-#xd7 + #xa2 #xff nil #xb2 nil #xbd nil nil ; #xd8-#xdf + )) + +(define-character-encoding :iso-8859-2 + "An 8-bit, fixed-width character encoding in which codes #x00-#x9f +map to their Unicode equivalents and other codes map to other Unicode +character values. Intended to provide most characters found in most +languages used in Central/Eastern Europe." + :aliases '(:iso_8859-2 :latin-2 :l2 :csISOLatin2) + :stream-encode-function + (nfunction + iso-8859-2-stream-encode + (lambda (char write-function stream) + (let* ((code (char-code char)) + (c2 (cond ((< code #xa0) code) + ((< code #x180) + (svref *unicode-00a0-0180-to-iso-8859-2* + (the fixnum (- code #xa0)))) + ((and (>= code #x2c0) (< code #x2e0)) + (svref *unicode-00c0-00e0-to-iso-8859-2* + (the fixnum (- code #x2c0))))))) + + (declare (type (mod #x110000) code)) + (funcall write-function stream (or c2 (char-code #\Sub))) + 1))) + :stream-decode-function + (nfunction + iso-8859-2-stream-decode + (lambda (1st-unit next-unit-function stream) + (declare (ignore next-unit-function stream) + (type (unsigned-byte 8) 1st-unit)) + (if (< 1st-unit #xa0) + (code-char 1st-unit) + (svref *iso-8859-2-to-unicode* (the fixnum (- 1st-unit #xa0)))))) + :vector-encode-function + (nfunction + iso-8859-2-vector-encode + (lambda (string vector idx start end) + (declare (type (simple-array (unsigned-byte 8) (*)) vector) + (fixnum idx)) + (do* ((i start (1+ i))) + ((>= i end) idx) + (let* ((code (char-code (schar string i))) + (c2 (cond ((< code #xa0) code) + ((< code #x180) + (svref *unicode-00a0-0180-to-iso-8859-2* + (the fixnum (- code #xa0)))) + ((and (>= code #x2c0) (< code #x2e0)) + (svref *unicode-00c0-00e0-to-iso-8859-2* + (the fixnum (- code #x2c0))))))) + (declare (type (mod #x110000) code)) + (setf (aref vector idx) (or c2 (char-code #\Sub))) + (incf idx))))) + :vector-decode-function + (nfunction + iso-8859-2-vector-decode + (lambda (vector idx noctets string) + (declare (type (simple-array (unsigned-byte 8) (*)) vector)) + (do* ((i 0 (1+ i)) + (index idx (1+ index))) + ((>= i noctets) index) + (let* ((1st-unit (aref vector index))) + (declare (type (unsigned-byte 8) 1st-unit)) + (setf (schar string i) + (if (< 1st-unit #xa0) + (code-char 1st-unit) + (svref *iso-8859-2-to-unicode* (the fixnum (- 1st-unit #xa0))))))))) + :memory-encode-function + (nfunction + iso-8859-2-memory-encode + (lambda (string pointer idx start end) + (do* ((i start (1+ i))) + ((>= i end) idx) + (let* ((code (char-code (schar string i))) + (c2 (cond ((< code #xa0) code) + ((< code #x180) + (svref *unicode-00a0-0180-to-iso-8859-2* + (the fixnum (- code #xa0)))) + ((and (>= code #x2c0) (< code #x2e0)) + (svref *unicode-00c0-00e0-to-iso-8859-2* + (the fixnum (- code #x2c0))))))) + (declare (type (mod #x110000) code)) + (setf (%get-unsigned-byte pointer idx) (or c2 (char-code #\Sub))) + (1+ idx))))) + :memory-decode-function + (nfunction + iso-8859-2-memory-decode + (lambda (pointer noctets idx string) + (do* ((i 0 (1+ i)) + (index idx (1+ index))) + ((>= i noctets) index) + (let* ((1st-unit (%get-unsigned-byte pointer index))) + (declare (type (unsigned-byte 8) 1st-unit)) + (setf (schar string i) + (if (< 1st-unit #xa0) + (code-char 1st-unit) + (svref *iso-8859-2-to-unicode* (the fixnum (- 1st-unit #xa0))))))))) + :octets-in-string-function + #'8-bit-fixed-width-octets-in-string + :length-of-vector-encoding-function + #'8-bit-fixed-width-length-of-vector-encoding + :length-of-memory-encoding-function + #'8-bit-fixed-width-length-of-memory-encoding + :decode-literal-code-unit-limit #xa0 + :encode-literal-char-code-limit #xa0 + ) + +(defstatic *iso-8859-3-to-unicode* + #( + ;; #xa0 + #\u+00a0 #\u+0126 #\u+02d8 #\u+00a3 #\u+00a4 #\u+fffd #\u+0124 #\u+00a7 + #\u+00a8 #\u+0130 #\u+015e #\u+011e #\u+0134 #\u+00ad #\u+fffd #\u+017b + ;; #xb0 + #\u+00b0 #\u+0127 #\u+00b2 #\u+00b3 #\u+00b4 #\u+00b5 #\u+0125 #\u+00b7 + #\u+00b8 #\u+0131 #\u+015f #\u+011f #\u+0135 #\u+00bd #\u+fffd #\u+017c + ;; #xc0 + #\u+00c0 #\u+00c1 #\u+00c2 #\u+fffd #\u+00c4 #\u+010a #\u+0108 #\u+00c7 + #\u+00c8 #\u+00c9 #\u+00ca #\u+00cb #\u+00cc #\u+00cd #\u+00ce #\u+00cf + ;; #xd0 + #\u+fffd #\u+00d1 #\u+00d2 #\u+00d3 #\u+00d4 #\u+0120 #\u+00d6 #\u+00d7 + #\u+011c #\u+00d9 #\u+00da #\u+00db #\u+00dc #\u+016c #\u+015c #\u+00df + ;; #xe0 + #\u+00e0 #\u+00e1 #\u+00e2 #\u+fffd #\u+00e4 #\u+010b #\u+0109 #\u+00e7 + #\u+00e8 #\u+00e9 #\u+00ea #\u+00eb #\u+00ec #\u+00ed #\u+00ee #\u+00ef + ;; #xf0 + #\u+fffd #\u+00f1 #\u+00f2 #\u+00f3 #\u+00f4 #\u+0121 #\u+00f6 #\u+00f7 + #\u+011d #\u+00f9 #\u+00fa #\u+00fb #\u+00fc #\u+016d #\u+015d #\u+02d9 + )) + +(defstatic *unicode-a0-100-to-iso-8859-3* + #( + #xa0 nil nil #xa3 #xa4 nil nil #xa7 ; #xa0-#xa7 + #xa8 nil nil nil nil #xad nil nil ; #xa8-#xaf + #xb0 nil #xb2 #xb3 #xb4 #xb5 nil #xb7 ; #xb0-#xb7 + #xb8 nil nil nil nil #xbd nil nil ; #xb8-#xbf + #xc0 #xc1 #xc2 nil #xc4 nil nil #xc7 ; #xc0-#xc7 + #xc8 #xc9 #xca #xcb #xcc #xcd #xce #xcf ; #xc8-#xcf + nil #xd1 #xd2 #xd3 #xd4 nil #xd6 #xd7 ; #xd0-#xd7 + nil #xd9 #xda #xdb #xdc nil nil #xdf ; #xd8-#xdf + #xe0 #xe1 #xe2 nil #xe4 nil nil #xe7 ; #xe0-#xe7 + #xe8 #xe9 #xea #xeb #xec #xed #xee #xef ; #xe8-#xef + nil #xf1 #xf2 #xf3 #xf4 nil #xf6 #xf7 ; #xf0-#xf7 + nil #xf9 #xfa #xfb #xfc nil nil nil ; #xf8-#xff + )) + +(defstatic *unicode-108-180-to-iso-8859-3* + #( + #xc6 #xe6 #xc5 #xe5 #x00 #x00 #x00 #x00 ; #x108-#x10f + nil nil nil nil nil nil nil nil ; #x110-#x117 + nil nil nil nil #xd8 #xf8 #xab #xbb ; #x118-#x11f + #xd5 #xf5 nil nil #xa6 #xb6 #xa1 #xb1 ; #x120-#x127 + nil nil nil nil nil nil nil nil ; #x128-#x12f + #xa9 #xb9 nil nil #xac #xbc nil nil ; #x130-#x137 + nil nil nil nil nil nil nil nil ; #x138-#x13f + nil nil nil nil nil nil nil nil ; #x140-#x147 + nil nil nil nil nil nil nil nil ; #x148-#x14f + nil nil nil nil nil nil nil nil ; #x150-#x157 + nil nil nil nil #xde #xfe #xaa #xba ; #x158-#x15f + nil nil nil nil nil nil nil nil ; #x160-#x167 + nil nil nil nil #xdd #xfd nil nil ; #x168-#x16f + nil nil nil nil nil nil nil nil ; #x170-#x177 + nil nil nil #xaf #xbf nil nil nil ; #x178-#x17f + )) + +(defstatic *unicode-2d8-2e0-to-iso-8859-3* + #( + #xa2 #xff nil nil nil nil nil nil ; #x2d8-#x2df + )) + + + +(define-character-encoding :iso-8859-3 + "An 8-bit, fixed-width character encoding in which codes #x00-#x9f +map to their Unicode equivalents and other codes map to other Unicode +character values. Intended to provide most characters found in most +languages used in Southern Europe." + + :aliases '(:iso_8859-3 :latin3 :l3 :csisolatin3) + :stream-encode-function + (nfunction + iso-8859-3-stream-encode + (lambda (char write-function stream) + (let* ((code (char-code char)) + (c2 (cond ((< code #xa0) code) + ((< code #x100) + (svref *unicode-a0-100-to-iso-8859-3* + (the fixnum (- code #xa0)))) + ((and (>= code #x108) (< code #x180)) + (svref *unicode-108-180-to-iso-8859-3* + (the fixnum (- code #x108)))) + ((and (>= code #x2d8) (< code #x2e0)) + (svref *unicode-2d8-2e0-to-iso-8859-3* + (the fixnum (- code #x2d8))))))) + (declare (type (mod #x110000) code)) + (funcall write-function stream (or c2 (char-code #\Sub))) + 1))) + :stream-decode-function + (nfunction + iso-8859-3-stream-decode + (lambda (1st-unit next-unit-function stream) + (declare (ignore next-unit-function stream) + (type (unsigned-byte 8) 1st-unit)) + (if (< 1st-unit #xa0) + (code-char 1st-unit) + (svref *iso-8859-3-to-unicode* (the fixnum (- 1st-unit #xa0)))))) + :vector-encode-function + (nfunction + iso-8859-3-vector-encode + (lambda (string vector idx start end) + (declare (type (simple-array (unsigned-byte 8) (*)) vector) + (fixnum idx)) + (do* ((i start (1+ i))) + ((>= i end) idx) + (let* ((char (schar string i)) + (code (char-code char)) + (c2 (cond ((< code #xa0) code) + ((< code #x100) + (svref *unicode-a0-100-to-iso-8859-3* + (the fixnum (- code #xa0)))) + ((and (>= code #x108) (< code #x180)) + (svref *unicode-108-180-to-iso-8859-3* + (the fixnum (- code #x108)))) + ((and (>= code #x2d8) (< code #x2e0)) + (svref *unicode-2d8-2e0-to-iso-8859-3* + + (the fixnum (- code #x2d8))))))) + (declare (type (mod #x110000) code)) + (setf (aref vector idx) (or c2 (char-code #\Sub))) + (incf idx))))) + :vector-decode-function + (nfunction + iso-8859-3-vector-decode + (lambda (vector idx noctets string) + (declare (type (simple-array (unsigned-byte 8) (*)) vector)) + (do* ((i 0 (1+ i)) + (index idx (1+ index))) + ((>= i noctets) index) + (let* ((1st-unit (aref vector index))) + (declare (type (unsigned-byte 8) 1st-unit)) + (setf (schar string i) + (if (< 1st-unit #xa0) + (code-char 1st-unit) + (svref *iso-8859-3-to-unicode* (the fixnum (- 1st-unit #xa0))))))))) + :memory-encode-function + (nfunction + iso-8859-3-memory-encode + (lambda (string pointer idx start end) + (do* ((i start (1+ i))) + ((>= i end) idx) + (let* ((code (char-code (schar string i))) + (c2 (cond ((< code #xa0) code) + ((< code #x100) + (svref *unicode-a0-100-to-iso-8859-3* + (the fixnum (- code #xa0)))) + ((and (>= code #x108) (< code #x180)) + (svref *unicode-108-180-to-iso-8859-3* + (the fixnum (- code #x108)))) + ((and (>= code #x2d8) (< code #x2e0)) + (svref *unicode-2d8-2e0-to-iso-8859-3* + (the fixnum (- code #x2d8))))))) + (declare (type (mod #x110000) code)) + (setf (%get-unsigned-byte pointer idx) (or c2 (char-code #\Sub))) + (incf idx))))) + :memory-decode-function + (nfunction + iso-8859-3-memory-decode + (lambda (pointer noctets idx string) + (do* ((i 0 (1+ i)) + (index idx (1+ index))) + ((>= i noctets) index) + (let* ((1st-unit (%get-unsigned-byte pointer index))) + (declare (type (unsigned-byte 8) 1st-unit)) + (setf (schar string i) + (if (< 1st-unit #xa0) + (code-char 1st-unit) + (svref *iso-8859-3-to-unicode* (the fixnum (- 1st-unit #xa0))))))))) + :octets-in-string-function + #'8-bit-fixed-width-octets-in-string + :length-of-vector-encoding-function + #'8-bit-fixed-width-length-of-vector-encoding + :length-of-memory-encoding-function + #'8-bit-fixed-width-length-of-memory-encoding + :decode-literal-code-unit-limit #xa0 + :encode-literal-char-code-limit #xa0 + ) + + +(defstatic *iso-8859-4-to-unicode* + #( + ;; #xa0 + #\u+00a0 #\u+0104 #\u+0138 #\u+0156 #\u+00a4 #\u+0128 #\u+013b #\u+00a7 + #\u+00a8 #\u+0160 #\u+0112 #\u+0122 #\u+0166 #\u+00ad #\u+017d #\u+00af + ;; #xb0 + #\u+00b0 #\u+0105 #\u+02db #\u+0157 #\u+00b4 #\u+0129 #\u+013c #\u+02c7 + #\u+00b8 #\u+0161 #\u+0113 #\u+0123 #\u+0167 #\u+014a #\u+017e #\u+014b + ;; #xc0 + #\u+0100 #\u+00c1 #\u+00c2 #\u+00c3 #\u+00c4 #\u+00c5 #\u+00c6 #\u+012e + #\u+010c #\u+00c9 #\u+0118 #\u+00cb #\u+0116 #\u+00cd #\u+00ce #\u+012a + ;; #xd0 + #\u+0110 #\u+0145 #\u+014c #\u+0136 #\u+00d4 #\u+00d5 #\u+00d6 #\u+00d7 + #\u+00d8 #\u+0172 #\u+00da #\u+00db #\u+00dc #\u+0168 #\u+016a #\u+00df + ;; #xe0 + #\u+0101 #\u+00e1 #\u+00e2 #\u+00e3 #\u+00e4 #\u+00e5 #\u+00e6 #\u+012f + #\u+010d #\u+00e9 #\u+0119 #\u+00eb #\u+0117 #\u+00ed #\u+00ee #\u+012b + ;; #xf0 + #\u+0111 #\u+0146 #\u+014d #\u+0137 #\u+00f4 #\u+00f5 #\u+00f6 #\u+00f7 + #\u+00f8 #\u+0173 #\u+00fa #\u+00fb #\u+00fc #\u+0169 #\u+016b #\u+02d9 + )) + + +(defstatic *unicode-a0-180-to-iso-8859-4* + #( + #xa0 nil nil nil #xa4 nil nil #xa7 ; #xa0-#xa7 + #xa8 nil nil nil nil #xad nil #xaf ; #xa8-#xaf + #xb0 nil nil nil #xb4 nil nil nil ; #xb0-#xb7 + #xb8 nil nil nil nil nil nil nil ; #xb8-#xbf + nil #xc1 #xc2 #xc3 #xc4 #xc5 #xc6 nil ; #xc0-#xc7 + nil #xc9 nil #xcb nil #xcd #xce nil ; #xc8-#xcf + nil nil nil nil #xd4 #xd5 #xd6 #xd7 ; #xd0-#xd7 + #xd8 nil #xda #xdb #xdc nil nil #xdf ; #xd8-#xdf + nil #xe1 #xe2 #xe3 #xe4 #xe5 #xe6 nil ; #xe0-#xe7 + nil #xe9 nil #xeb nil #xed #xee nil ; #xe8-#xef + nil nil nil nil #xf4 #xf5 #xf6 #xf7 ; #xf0-#xf7 + #xf8 nil #xfa #xfb #xfc nil nil nil ; #xf8-#xff + #xc0 #xe0 nil nil #xa1 #xb1 nil nil ; #x100-#x107 + nil nil nil nil #xc8 #xe8 nil nil ; #x108-#x10f + #xd0 #xf0 #xaa #xba nil nil #xcc #xec ; #x110-#x117 + #xca #xea nil nil nil nil nil nil ; #x118-#x11f + nil nil #xab #xbb nil nil nil nil ; #x120-#x127 + #xa5 #xb5 #xcf #xef nil nil #xc7 #xe7 ; #x128-#x12f + nil nil nil nil nil nil #xd3 #xf3 ; #x130-#x137 + #xa2 nil nil #xa6 #xb6 nil nil nil ; #x138-#x13f + nil nil nil nil nil #xd1 #xf1 nil ; #x140-#x147 + nil nil #xbd #xbf #xd2 #xf2 nil nil ; #x148-#x14f + nil nil nil nil nil nil #xa3 #xb3 ; #x150-#x157 + nil nil nil nil nil nil nil nil ; #x158-#x15f + #xa9 #xb9 nil nil nil nil #xac #xbc ; #x160-#x167 + #xdd #xfd #xde #xfe nil nil nil nil ; #x168-#x16f + nil nil #xd9 #xf9 nil nil nil nil ; #x170-#x177 + nil nil nil nil nil #xae #xbe nil ; #x178-#x17f + )) + +(defstatic *unicode-2c0-2e0-to-iso-8859-4* + #( + nil nil nil nil nil nil nil #xb7 ; #x2c0-#x2c7 + nil nil nil nil nil nil nil nil ; #x2c8-#x2cf + nil nil nil nil nil nil nil nil ; #x2d0-#x2d7 + nil #xff nil #xb2 nil nil nil nil ; #x2d8-#x2df + )) + + + +(define-character-encoding :iso-8859-4 + "An 8-bit, fixed-width character encoding in which codes #x00-#x9f +map to their Unicode equivalents and other codes map to other Unicode +character values. Intended to provide most characters found in most +languages used in Northern Europe." + + :aliases '(:iso_8859-4 :latin4 :l4 :csisolatin4) + :stream-encode-function + (nfunction + iso-8859-4-stream-encode + (lambda (char write-function stream) + (let* ((code (char-code char)) + (c2 (cond ((< code #xa0) code) + ((< code #x180) + (svref *unicode-a0-180-to-iso-8859-4* + (the fixnum (- code #xa0)))) + ((and (>= code #x2d8) (< code #x2e0)) + (svref *unicode-2c0-2e0-to-iso-8859-4* + (the fixnum (- code #x2c0))))))) + + (declare (type (mod #x110000) code)) + (funcall write-function stream (or c2 (char-code #\Sub))) + 1))) + :stream-decode-function + (nfunction + iso-8859-4-stream-decode + (lambda (1st-unit next-unit-function stream) + (declare (ignore next-unit-function stream) + (type (unsigned-byte 8) 1st-unit)) + (if (< 1st-unit #xa0) + (code-char 1st-unit) + (svref *iso-8859-4-to-unicode* (the fixnum (- 1st-unit #xa0)))))) + :vector-encode-function + (nfunction + iso-8859-4-vector-encode + (lambda (string vector idx start end) + (declare (type (simple-array (unsigned-byte 8) (*)) vector) + (fixnum idx)) + (do* ((i start (1+ i))) + ((>= i end) idx) + (let* ((char (schar string i)) + (code (char-code char)) + (c2 (cond ((< code #xa0) code) + ((< code #x180) + (svref *unicode-a0-180-to-iso-8859-4* + (the fixnum (- code #xa0)))) + ((and (>= code #x2d8) (< code #x2e0)) + (svref *unicode-2c0-2e0-to-iso-8859-4* + (the fixnum (- code #x2c0))))))) + (declare (type (mod #x110000) code)) + (setf (aref vector idx) (or c2 (char-code #\Sub))) + (incf idx))))) + :vector-decode-function + (nfunction + iso-8859-4-vector-decode + (lambda (vector idx noctets string) + (declare (type (simple-array (unsigned-byte 8) (*)) vector)) + (do* ((i 0 (1+ i)) + (index idx (1+ index))) + ((>= i noctets) index) + (let* ((1st-unit (aref vector index))) + (declare (type (unsigned-byte 8) 1st-unit)) + (setf (schar string i) + (if (< 1st-unit #xa0) + (code-char 1st-unit) + (svref *iso-8859-4-to-unicode* (the fixnum (- 1st-unit #xa0))))))))) + :memory-encode-function + (nfunction + iso-8859-4-memory-encode + (lambda (string pointer idx start end) + (do* ((i start (1+ i))) + ((>= i end) idx) + (let* ((code (char-code (schar string i))) + (c2 (cond ((< code #xa0) code) + ((< code #x180) + (svref *unicode-a0-180-to-iso-8859-4* + (the fixnum (- code #xa0)))) + ((and (>= code #x2d8) (< code #x2e0)) + (svref *unicode-2c0-2e0-to-iso-8859-4* + (the fixnum (- code #x2c0))))))) + (declare (type (mod #x110000) code)) + (setf (%get-unsigned-byte pointer idx) (or c2 (char-code #\Sub))) + (incf idx))))) + :memory-decode-function + (nfunction + iso-8859-4-memory-decode + (lambda (pointer noctets idx string) + (do* ((i 0 (1+ i)) + (index idx (1+ index))) + ((>= i noctets) index) + (let* ((1st-unit (%get-unsigned-byte pointer index))) + (declare (type (unsigned-byte 8) 1st-unit)) + (setf (schar string i) + (if (< 1st-unit #xa0) + (code-char 1st-unit) + (svref *iso-8859-4-to-unicode* (the fixnum (- 1st-unit #xa0))))))))) + :octets-in-string-function + #'8-bit-fixed-width-octets-in-string + :length-of-vector-encoding-function + #'8-bit-fixed-width-length-of-vector-encoding + :length-of-memory-encoding-function + #'8-bit-fixed-width-length-of-memory-encoding + :decode-literal-code-unit-limit #xa0 + :encode-literal-char-code-limit #xa0 + ) + +(defstatic *iso-8859-5-to-unicode* + #( + ;; #xa0 + #\u+00a0 #\u+0401 #\u+0402 #\u+0403 #\u+0404 #\u+0405 #\u+0406 #\u+0407 + #\u+0408 #\u+0409 #\u+040a #\u+040b #\u+040c #\u+00ad #\u+040e #\u+040f + ;; #xb0 + #\u+0410 #\u+0411 #\u+0412 #\u+0413 #\u+0414 #\u+0415 #\u+0416 #\u+0417 + #\u+0418 #\u+0419 #\u+041a #\u+041b #\u+041c #\u+041d #\u+041e #\u+041f + ;; #xc0 + #\u+0420 #\u+0421 #\u+0422 #\u+0423 #\u+0424 #\u+0425 #\u+0426 #\u+0427 + #\u+0428 #\u+0429 #\u+042a #\u+042b #\u+042c #\u+042d #\u+042e #\u+042f + ;; #xd0 + #\u+0430 #\u+0431 #\u+0432 #\u+0433 #\u+0434 #\u+0435 #\u+0436 #\u+0437 + #\u+0438 #\u+0439 #\u+043a #\u+043b #\u+043c #\u+043d #\u+043e #\u+043f + ;; #xe0 + #\u+0440 #\u+0441 #\u+0442 #\u+0443 #\u+0444 #\u+0445 #\u+0446 #\u+0447 + #\u+0448 #\u+0449 #\u+044a #\u+044b #\u+044c #\u+044d #\u+044e #\u+044f + ;; #xf0 + #\u+2116 #\u+0451 #\u+0452 #\u+0453 #\u+0454 #\u+0455 #\u+0456 #\u+0457 + #\u+0458 #\u+0459 #\u+045a #\u+045b #\u+045c #\u+00a7 #\u+045e #\u+045f + )) + + +(defstatic *unicode-a0-b0-to-iso-8859-5* + #( + #xa0 nil nil nil nil nil nil #xfd ; #xa0-#xa7 + nil nil nil nil nil #xad nil nil ; #xa8-#xaf + )) + +(defstatic *unicode-400-460-to-iso-8859-5* + #( + nil #xa1 #xa2 #xa3 #xa4 #xa5 #xa6 #xa7 ; #x400-#x407 + #xa8 #xa9 #xaa #xab #xac nil #xae #xaf ; #x408-#x40f + #xb0 #xb1 #xb2 #xb3 #xb4 #xb5 #xb6 #xb7 ; #x410-#x417 + #xb8 #xb9 #xba #xbb #xbc #xbd #xbe #xbf ; #x418-#x41f + #xc0 #xc1 #xc2 #xc3 #xc4 #xc5 #xc6 #xc7 ; #x420-#x427 + #xc8 #xc9 #xca #xcb #xcc #xcd #xce #xcf ; #x428-#x42f + #xd0 #xd1 #xd2 #xd3 #xd4 #xd5 #xd6 #xd7 ; #x430-#x437 + #xd8 #xd9 #xda #xdb #xdc #xdd #xde #xdf ; #x438-#x43f + #xe0 #xe1 #xe2 #xe3 #xe4 #xe5 #xe6 #xe7 ; #x440-#x447 + #xe8 #xe9 #xea #xeb #xec #xed #xee #xef ; #x448-#x44f + nil #xf1 #xf2 #xf3 #xf4 #xf5 #xf6 #xf7 ; #x450-#x457 + #xf8 #xf9 #xfa #xfb #xfc nil #xfe #xff ; #x458-#x45f + )) + + +(define-character-encoding :iso-8859-5 + "An 8-bit, fixed-width character encoding in which codes #x00-#x9f +map to their Unicode equivalents and other codes map to other Unicode +character values. Intended to provide most characters found in the +Cyrillic alphabet." + + :aliases '(:iso_8859-5 :cyrillic :csISOLatinCyrillic :iso-ir-144) + :stream-encode-function + (nfunction + iso-8859-5-stream-encode + (lambda (char write-function stream) + (let* ((code (char-code char)) + (c2 (cond ((< code #xa0) code) + ((< code #xb0) + (svref *unicode-a0-b0-to-iso-8859-5* + (the fixnum (- code #xa0)))) + ((and (>= code #x400) (< code #x460)) + (svref *unicode-400-460-to-iso-8859-5* + (the fixnum (- code #x400))))))) + + (declare (type (mod #x110000) code)) + (funcall write-function stream (or c2 (char-code #\Sub))) + 1))) + :stream-decode-function + (nfunction + iso-8859-5-stream-decode + (lambda (1st-unit next-unit-function stream) + (declare (ignore next-unit-function stream) + (type (unsigned-byte 8) 1st-unit)) + (if (< 1st-unit #xa0) + (code-char 1st-unit) + (svref *iso-8859-5-to-unicode* (the fixnum (- 1st-unit #xa0)))))) + :vector-encode-function + (nfunction + iso-8859-5-vector-encode + (lambda (string vector idx start end) + (declare (type (simple-array (unsigned-byte 8) (*)) vector) + (fixnum idx)) + (do* ((i start (1+ i))) + ((>= i end) idx) + (let* ((char (schar string i)) + (code (char-code char)) + (c2 (cond ((< code #xa0) code) + ((< code #xb0) + (svref *unicode-a0-b0-to-iso-8859-5* + (the fixnum (- code #xa0)))) + ((and (>= code #x400) (< code #x460)) + (svref *unicode-400-460-to-iso-8859-5* + (the fixnum (- code #x400))))))) + (declare (type (mod #x110000) code)) + (setf (aref vector idx) (or c2 (char-code #\Sub))) + (incf idx))))) + :vector-decode-function + (nfunction + iso-8859-5-vector-decode + (lambda (vector idx noctets string) + (declare (type (simple-array (unsigned-byte 8) (*)) vector)) + (do* ((i 0 (1+ i)) + (index idx (1+ index))) + ((>= i noctets) index) + (let* ((1st-unit (aref vector index))) + (declare (type (unsigned-byte 8) 1st-unit)) + (setf (schar string i) + (if (< 1st-unit #xa0) + (code-char 1st-unit) + (svref *iso-8859-5-to-unicode* (the fixnum (- 1st-unit #xa0))))))))) + :memory-encode-function + (nfunction + iso-8859-5-memory-encode + (lambda (string pointer idx start end) + (do* ((i start (1+ i))) + ((>= i end) idx) + (let* ((code (char-code (schar string i))) + (c2 (cond ((< code #xa0) code) + ((< code #xb0) + (svref *unicode-a0-b0-to-iso-8859-5* + (the fixnum (- code #xa0)))) + ((and (>= code #x400) (< code #x460)) + (svref *unicode-400-460-to-iso-8859-5* + (the fixnum (- code #x400))))))) + (declare (type (mod #x110000) code)) + (setf (%get-unsigned-byte pointer idx) (or c2 (char-code #\Sub))) + (incf idx))))) + :memory-decode-function + (nfunction + iso-8859-5-memory-decode + (lambda (pointer noctets idx string) + (do* ((i 0 (1+ i)) + (index idx (1+ index))) + ((>= i noctets) index) + (let* ((1st-unit (%get-unsigned-byte pointer index))) + (declare (type (unsigned-byte 8) 1st-unit)) + (setf (schar string i) + (if (< 1st-unit #xa0) + (code-char 1st-unit) + (svref *iso-8859-5-to-unicode* (the fixnum (- 1st-unit #xa0))))))))) + :octets-in-string-function + #'8-bit-fixed-width-octets-in-string + :length-of-vector-encoding-function + #'8-bit-fixed-width-length-of-vector-encoding + :length-of-memory-encoding-function + #'8-bit-fixed-width-length-of-memory-encoding + :decode-literal-code-unit-limit #xa0 + :encode-literal-char-code-limit #xa0 + ) + +(defstatic *iso-8859-6-to-unicode* + #( + ;; #xa0 + #\u+00a0 #\u+fffd #\u+fffd #\u+fffd #\u+00a4 #\u+fffd #\u+fffd #\u+fffd + #\u+fffd #\u+fffd #\u+fffd #\u+fffd #\u+060c #\u+00ad #\u+fffd #\u+fffd + ;; #xb0 + #\u+fffd #\u+fffd #\u+fffd #\u+fffd #\u+fffd #\u+fffd #\u+fffd #\u+fffd + #\u+fffd #\u+fffd #\u+fffd #\u+061b #\u+fffd #\u+fffd #\u+fffd #\u+061f + ;; #xc0 + #\u+fffd #\u+0621 #\u+0622 #\u+0623 #\u+0624 #\u+0625 #\u+0626 #\u+0627 + #\u+0628 #\u+0629 #\u+062a #\u+062b #\u+062c #\u+062d #\u+062e #\u+062f + ;; #xd0 + #\u+0630 #\u+0631 #\u+0632 #\u+0633 #\u+0634 #\u+0635 #\u+0636 #\u+0637 + #\u+0638 #\u+0639 #\u+063a #\u+fffd #\u+fffd #\u+fffd #\u+fffd #\u+fffd + ;; #xe0 + #\u+0640 #\u+0641 #\u+0642 #\u+0643 #\u+0644 #\u+0645 #\u+0646 #\u+0647 + #\u+0648 #\u+0649 #\u+064a #\u+064b #\u+064c #\u+064d #\u+064e #\u+064f + ;; #xf0 + #\u+0650 #\u+0651 #\u+0652 #\u+fffd #\u+fffd #\u+fffd #\u+fffd #\u+fffd + #\u+fffd #\u+fffd #\u+fffd #\u+fffd #\u+fffd #\u+fffd #\u+fffd #\u+fffd + )) + +(defstatic *unicode-a0-b0-to-iso-8859-6* + #( + 0xa0 nil nil nil 0xa4 nil nil nil ; #xa0-#xa7 + nil nil nil nil nil #xad nil nil ; #xa8-#xaf + )) + + +(defstatic *unicode-608-658-to-iso-8859-6* + #( + nil nil nil nil #xac nil nil nil ; #x608-#x60f + nil nil nil nil nil nil nil nil ; #x610-#x617 + nil nil nil #xbb nil nil nil #xbf ; #x618-#x61f + nil #xc1 #xc2 #xc3 #xc4 #xc5 #xc6 #xc7 ; #x620-#x627 + #xc8 #xc9 #xca #xcb #xcc #xcd #xce #xcf ; #x628-#x62f + #xd0 #xd1 #xd2 #xd3 #xd4 #xd5 #xd6 #xd7 ; #x630-#x637 + #xd8 #xd9 #xda nil nil nil nil nil ; #x638-#x63f + #xe0 #xe1 #xe2 #xe3 #xe4 #xe5 #xe6 #xe7 ; #x640-#x647 + #xe8 #xe9 #xea #xeb #xec #xed #xee #xef ; #x648-#x64f + #xf0 #xf1 #xf2 nil nil nil nil nil ; #x650-#x657 + )) + +(define-character-encoding :iso-8859-6 + "An 8-bit, fixed-width character encoding in which codes #x00-#x9f +map to their Unicode equivalents and other codes map to other Unicode +character values. Intended to provide most characters found in the +Arabic alphabet." + + :aliases '(:iso_8859-6 :arabic :csISOLatinArabic :iso-ir-127) + :stream-encode-function + (nfunction + iso-8859-6-stream-encode + (lambda (char write-function stream) + (let* ((code (char-code char)) + (c2 (cond ((< code #xa0) code) + ((< code #xb0) + (svref *unicode-a0-b0-to-iso-8859-6* + (the fixnum (- code #xa0)))) + ((and (>= code #x608) (< code #x658)) + (svref *unicode-608-658-to-iso-8859-6* + (the fixnum (- code #x608))))))) + + (declare (type (mod #x110000) code)) + (funcall write-function stream (or c2 (char-code #\Sub))) + 1))) + :stream-decode-function + (nfunction + iso-8859-6-stream-decode + (lambda (1st-unit next-unit-function stream) + (declare (ignore next-unit-function stream) + (type (unsigned-byte 8) 1st-unit)) + (if (< 1st-unit #xa0) + (code-char 1st-unit) + (svref *iso-8859-6-to-unicode* (the fixnum (- 1st-unit #xa0)))))) + :vector-encode-function + (nfunction + iso-8859-6-vector-encode + (lambda (string vector idx start end) + (declare (type (simple-array (unsigned-byte 8) (*)) vector) + (fixnum idx)) + (do* ((i start (1+ i))) + ((>= i end) idx) + (let* ((char (schar string i)) + (code (char-code char)) + (c2 (cond ((< code #xa0) code) + ((< code #xb0) + (svref *unicode-a0-b0-to-iso-8859-6* + (the fixnum (- code #xa0)))) + ((and (>= code #x608) (< code #x658)) + (svref *unicode-608-658-to-iso-8859-6* + (the fixnum (- code #x608))))))) + (declare (type (mod #x110000) code)) + (setf (aref vector idx) (or c2 (char-code #\Sub))) + (incf idx))))) + :vector-decode-function + (nfunction + iso-8859-6-vector-decode + (lambda (vector idx noctets string) + (declare (type (simple-array (unsigned-byte 8) (*)) vector)) + (do* ((i 0 (1+ i)) + (index idx (1+ index))) + ((>= i noctets) index) + (let* ((1st-unit (aref vector index))) + (declare (type (unsigned-byte 8) 1st-unit)) + (setf (schar string i) + (if (< 1st-unit #xa0) + (code-char 1st-unit) + (svref *iso-8859-6-to-unicode* (the fixnum (- 1st-unit #xa0))))))))) + :memory-encode-function + (nfunction + iso-8859-6-memory-encode + (lambda (string pointer idx start end) + (do* ((i start (1+ i))) + ((>= i end) idx) + (let* ((code (char-code (schar string i))) + (c2 (cond ((< code #xa0) code) + ((< code #xb0) + (svref *unicode-a0-b0-to-iso-8859-6* + (the fixnum (- code #xa0)))) + ((and (>= code #x608) (< code #x658)) + (svref *unicode-608-658-to-iso-8859-6* + (the fixnum (- code #x608))))))) + (declare (type (mod #x110000) code)) + (setf (%get-unsigned-byte pointer idx) (or c2 (char-code #\Sub))) + (incf idx))))) + :memory-decode-function + (nfunction + iso-8859-6-memory-decode + (lambda (pointer noctets idx string) + (do* ((i 0 (1+ i)) + (index idx (1+ index))) + ((>= i noctets) index) + (let* ((1st-unit (%get-unsigned-byte pointer index))) + (declare (type (unsigned-byte 8) 1st-unit)) + (setf (schar string i) + (if (< 1st-unit #xa0) + (code-char 1st-unit) + (svref *iso-8859-6-to-unicode* (the fixnum (- 1st-unit #xa0))))))))) + :octets-in-string-function + #'8-bit-fixed-width-octets-in-string + :length-of-vector-encoding-function + #'8-bit-fixed-width-length-of-vector-encoding + :length-of-memory-encoding-function + #'8-bit-fixed-width-length-of-memory-encoding + :decode-literal-code-unit-limit #xa0 + :encode-literal-char-code-limit #xa0 + ) + +(defstatic *iso-8859-7-to-unicode* + #( + ;; #xa0 + #\u+00a0 #\u+2018 #\u+2019 #\u+00a3 #\u+20ac #\u+20af #\u+00a6 #\u+00a7 + #\u+00a8 #\u+00a9 #\u+037a #\u+00ab #\u+00ac #\u+00ad #\u+fffd #\u+2015 + ;; #xb0 + #\u+00b0 #\u+00b1 #\u+00b2 #\u+00b3 #\u+0384 #\u+0385 #\u+0386 #\u+00b7 + #\u+0388 #\u+0389 #\u+038a #\u+00bb #\u+038c #\u+00bd #\u+038e #\u+038f + ;; #xc0 + #\u+0390 #\u+0391 #\u+0392 #\u+0393 #\u+0394 #\u+0395 #\u+0396 #\u+0397 + #\u+0398 #\u+0399 #\u+039a #\u+039b #\u+039c #\u+039d #\u+039e #\u+039f + ;; #xd0 + #\u+03a0 #\u+03a1 #\u+fffd #\u+03a3 #\u+03a4 #\u+03a5 #\u+03a6 #\u+03a7 + #\u+03a8 #\u+03a9 #\u+03aa #\u+03ab #\u+03ac #\u+03ad #\u+03ae #\u+03af + ;; #xe0 + #\u+03b0 #\u+03b1 #\u+03b2 #\u+03b3 #\u+03b4 #\u+03b5 #\u+03b6 #\u+03b7 + #\u+03b8 #\u+03b9 #\u+03ba #\u+03bb #\u+03bc #\u+03bd #\u+03be #\u+03bf + ;; #xf0 + #\u+03c0 #\u+03c1 #\u+03c2 #\u+03c3 #\u+03c4 #\u+03c5 #\u+03c6 #\u+03c7 + #\u+03c8 #\u+03c9 #\u+03ca #\u+03cb #\u+03cc #\u+03cd #\u+03ce #\u+fffd + )) + +(defstatic *unicode-a0-c0-to-iso-8859-7* + #( + #xa0 nil nil #xa3 nil nil #xa6 #xa7 ; #xa0-#xa7 + #xa8 #xa9 nil #xab #xac #xad nil nil ; #xa8-#xaf + #xb0 #xb1 #xb2 #xb3 nil nil nil #xb7 ; #xb0-#xb7 + nil nil nil #xbb nil #xbd nil nil ; #xb8-#xbf + )) + +(defstatic *unicode-378-3d0-to-iso-8859-7* + #( + nil nil #xaa nil nil nil nil nil ; #x378-#x37f + nil nil nil nil #xb4 #xb5 #xb6 nil ; #x380-#x387 + #xb8 #xb9 #xba nil #xbc nil #xbe #xbf ; #x388-#x38f + #xc0 #xc1 #xc2 #xc3 #xc4 #xc5 #xc6 #xc7 ; #x390-#x397 + #xc8 #xc9 #xca #xcb #xcc #xcd #xce #xcf ; #x398-#x39f + #xd0 #xd1 nil #xd3 #xd4 #xd5 #xd6 #xd7 ; #x3a0-#x3a7 + #xd8 #xd9 #xda #xdb #xdc #xdd #xde #xdf ; #x3a8-#x3af + #xe0 #xe1 #xe2 #xe3 #xe4 #xe5 #xe6 #xe7 ; #x3b0-#x3b7 + #xe8 #xe9 #xea #xeb #xec #xed #xee #xef ; #x3b8-#x3bf + #xf0 #xf1 #xf2 #xf3 #xf4 #xf5 #xf6 #xf7 ; #x3c0-#x3c7 + #xf8 #xf9 #xfa #xfb #xfc #xfd #xfe nil ; #x3c8-#x3cf + )) + +(defstatic *unicode-2010-2020-to-iso-8859-7* + #( + nil nil nil nil nil #xaf nil nil ; #x2010-#x2017 + #xa1 #xa2 nil nil nil nil nil nil ; #x2018-#x201f + )) + +(defstatic *unicode-20ac-20b0-to-iso-8859-7* + #( + #xa4 nil nil #xa5 + )) + +(define-character-encoding :iso-8859-7 + "An 8-bit, fixed-width character encoding in which codes #x00-#x9f +map to their Unicode equivalents and other codes map to other Unicode +character values. Intended to provide most characters found in the +Greek alphabet." + + :aliases '(:iso_8859-7 :greek :greek8 :csISOLatinGreek :iso-ir-126 :ELOT_928 :ecma-118) + :stream-encode-function + (nfunction + iso-8859-7-stream-encode + (lambda (char write-function stream) + (let* ((code (char-code char)) + (c2 (cond ((< code #xa0) code) + ((< code #xc0) + (svref *unicode-a0-c0-to-iso-8859-7* + (the fixnum (- code #xa0)))) + ((and (>= code #x378) (< code #x3d0)) + (svref *unicode-378-3d0-to-iso-8859-7* + (the fixnum (- code #x378)))) + ((and (>= code #x2010) (< code #x2020)) + (svref *unicode-2010-2020-to-iso-8859-7* + (the fixnum (- code #x2010)))) + ((and (>= code #x20ac) (< code #x20b0)) + (svref *unicode-20ac-20b0-to-iso-8859-7* + (the fixnum (- code #x20ac))))))) + + (declare (type (mod #x110000) code)) + (funcall write-function stream (or c2 (char-code #\Sub))) + 1))) + :stream-decode-function + (nfunction + iso-8859-7-stream-decode + (lambda (1st-unit next-unit-function stream) + (declare (ignore next-unit-function stream) + (type (unsigned-byte 8) 1st-unit)) + (if (< 1st-unit #xa0) + (code-char 1st-unit) + (svref *iso-8859-7-to-unicode* (the fixnum (- 1st-unit #xa0)))))) + :vector-encode-function + (nfunction + iso-8859-7-vector-encode + (lambda (string vector idx start end) + (declare (type (simple-array (unsigned-byte 8) (*)) vector) + (fixnum idx)) + (do* ((i start (1+ i))) + ((>= i end) idx) + (let* ((char (schar string i)) + (code (char-code char)) + (c2 (cond ((< code #xa0) code) + ((< code #xc0) + (svref *unicode-a0-c0-to-iso-8859-7* + (the fixnum (- code #xa0)))) + ((and (>= code #x378) (< code #x3d0)) + (svref *unicode-378-3d0-to-iso-8859-7* + (the fixnum (- code #x378)))) + ((and (>= code #x2010) (< code #x2020)) + (svref *unicode-2010-2020-to-iso-8859-7* + (the fixnum (- code #x2010)))) + ((and (>= code #x20ac) (< code #x20b0)) + (svref *unicode-20ac-20b0-to-iso-8859-7* + (the fixnum (- code #x20ac))))))) + (declare (type (mod #x110000) code)) + (setf (aref vector idx) (or c2 (char-code #\Sub))) + (incf idx))))) + :vector-decode-function + (nfunction + iso-8859-7-vector-decode + (lambda (vector idx noctets string) + (declare (type (simple-array (unsigned-byte 8) (*)) vector)) + (do* ((i 0 (1+ i)) + (index idx (1+ index))) + ((>= i noctets) index) + (let* ((1st-unit (aref vector index))) + (declare (type (unsigned-byte 8) 1st-unit)) + (setf (schar string i) + (if (< 1st-unit #xa0) + (code-char 1st-unit) + (svref *iso-8859-7-to-unicode* (the fixnum (- 1st-unit #xa0))))))))) + :memory-encode-function + (nfunction + iso-8859-7-memory-encode + (lambda (string pointer idx start end) + (do* ((i start (1+ i))) + ((>= i end) idx) + (let* ((code (char-code (schar string i))) + (c2 (cond ((< code #xa0) code) + ((< code #xc0) + (svref *unicode-a0-c0-to-iso-8859-7* + (the fixnum (- code #xa0)))) + ((and (>= code #x378) (< code #x3d0)) + (svref *unicode-378-3d0-to-iso-8859-7* + (the fixnum (- code #x378)))) + ((and (>= code #x2010) (< code #x2020)) + (svref *unicode-2010-2020-to-iso-8859-7* + (the fixnum (- code #x2010)))) + ((and (>= code #x20ac) (< code #x20b0)) + (svref *unicode-20ac-20b0-to-iso-8859-7* + (the fixnum (- code #x20ac))))))) + (declare (type (mod #x110000) code)) + (setf (%get-unsigned-byte pointer idx) (or c2 (char-code #\Sub))) + (incf idx))))) + :memory-decode-function + (nfunction + iso-8859-7-memory-decode + (lambda (pointer noctets idx string) + (do* ((i 0 (1+ i)) + (index idx (1+ index))) + ((>= i noctets) index) + (let* ((1st-unit (%get-unsigned-byte pointer index))) + (declare (type (unsigned-byte 8) 1st-unit)) + (setf (schar string i) + (if (< 1st-unit #xa0) + (code-char 1st-unit) + (svref *iso-8859-7-to-unicode* (the fixnum (- 1st-unit #xa0))))))))) + :octets-in-string-function + #'8-bit-fixed-width-octets-in-string + :length-of-vector-encoding-function + #'8-bit-fixed-width-length-of-vector-encoding + :length-of-memory-encoding-function + #'8-bit-fixed-width-length-of-memory-encoding + :decode-literal-code-unit-limit #xa0 + :encode-literal-char-code-limit #xa0 + ) + +(defstatic *iso-8859-8-to-unicode* + #( + ;; #xa0 + #\u+00a0 #\u+fffd #\u+00a2 #\u+00a3 #\u+00a4 #\u+00a5 #\u+00a6 #\u+00a7 + #\u+00a8 #\u+00a9 #\u+00d7 #\u+00ab #\u+00ac #\u+00ad #\u+00ae #\u+00af + ;; #xb0 + #\u+00b0 #\u+00b1 #\u+00b2 #\u+00b3 #\u+00b4 #\u+00b5 #\u+00b6 #\u+00b7 + #\u+00b8 #\u+00b9 #\u+00f7 #\u+00bb #\u+00bc #\u+00bd #\u+00be #\u+fffd + ;; #xc0 + #\u+fffd #\u+fffd #\u+fffd #\u+fffd #\u+fffd #\u+fffd #\u+fffd #\u+fffd + #\u+fffd #\u+fffd #\u+fffd #\u+fffd #\u+fffd #\u+fffd #\u+fffd #\u+fffd + ;; #xd0 + #\u+fffd #\u+fffd #\u+fffd #\u+fffd #\u+fffd #\u+fffd #\u+fffd #\u+fffd + #\u+fffd #\u+fffd #\u+fffd #\u+fffd #\u+fffd #\u+fffd #\u+fffd #\u+2017 + ;; #xe0 + #\u+05d0 #\u+05d1 #\u+05d2 #\u+05d3 #\u+05d4 #\u+05d5 #\u+05d6 #\u+05d7 + #\u+05d8 #\u+05d9 #\u+05da #\u+05db #\u+05dc #\u+05dd #\u+05de #\u+05df + ;; #xf0 + #\u+05e0 #\u+05e1 #\u+05e2 #\u+05e3 #\u+05e4 #\u+05e5 #\u+05e6 #\u+05e7 + #\u+05e8 #\u+05e9 #\u+05ea #\u+fffd #\u+fffd #\u+200e #\u+200f #\u+fffd + )) + +(defstatic *unicode-a0-f8-to-iso-8859-8* + #( + #xa0 nil #xa2 #xa3 #xa4 #xa5 #xa6 #xa7 ; #xa0-#xa7 + #xa8 #xa9 nil #xab #xac #xad #xae #xaf ; #xa8-#xaf + #xb0 #xb1 #xb2 #xb3 #xb4 #xb5 #xb6 #xb7 ; #xb0-#xb7 + #xb8 #xb9 nil #xbb #xbc #xbd #xbe nil ; #xb8-#xbf + nil nil nil nil nil nil nil nil ; #xc0-#xc7 + nil nil nil nil nil nil nil nil ; #xc8-#xcf + nil nil nil nil nil nil nil #xaa ; #xd0-#xd7 + nil nil nil nil nil nil nil nil ; #xd8-#xdf + nil nil nil nil nil nil nil nil ; #xe0-#xe7 + nil nil nil nil nil nil nil nil ; #xe8-#xef + nil nil nil nil nil nil nil #xba ; #xf0-#xf7 + )) + +(defstatic *unicode-5d0-5f0-to-iso-8859-8* + #( + #xe0 #xe1 #xe2 #xe3 #xe4 #xe5 #xe6 #xe7 ; #x5d0-#x5d7 + #xe8 #xe9 #xea #xeb #xec #xed #xee #xef ; #x5d8-#x5df + #xf0 #xf1 #xf2 #xf3 #xf4 #xf5 #xf6 #xf7 ; #x5e0-#x5e7 + #xf8 #xf9 #xfa nil nil nil nil nil ; #x5e8-#x5ef + )) + +(defstatic *unicode-2008-2018-to-iso-8859-8* + #( + nil nil nil nil nil nil #xfd #xfe ; #x2008-#x200f + nil nil nil nil nil nil nil #xdf ; #x2010-#x2017 + )) + +(define-character-encoding :iso-8859-8 + "An 8-bit, fixed-width character encoding in which codes #x00-#x9f +map to their Unicode equivalents and other codes map to other Unicode +character values. Intended to provide most characters found in the +Hebrew alphabet." + + :aliases '(:iso_8859-8 :hebrew :csISOLatinHebrew :iso-ir-138) + :stream-encode-function + (nfunction + iso-8859-8-stream-encode + (lambda (char write-function stream) + (let* ((code (char-code char)) + (c2 (cond ((< code #xa0) code) + ((< code #xf8) + (svref *unicode-a0-f8-to-iso-8859-8* + (the fixnum (- code #xa0)))) + ((and (>= code #x5d0) (< code #x5f0)) + (svref *unicode-5d0-5f0-to-iso-8859-8* + (the fixnum (- code #x5d0)))) + ((and (>= code #x2008) (< code #x2018)) + (svref *unicode-2008-2018-to-iso-8859-8* + (the fixnum (- code #x2008))))))) + + (declare (type (mod #x110000) code)) + (funcall write-function stream (or c2 (char-code #\Sub))) + 1))) + :stream-decode-function + (nfunction + iso-8859-8-stream-decode + (lambda (1st-unit next-unit-function stream) + (declare (ignore next-unit-function stream) + (type (unsigned-byte 8) 1st-unit)) + (if (< 1st-unit #xa0) + (code-char 1st-unit) + (svref *iso-8859-8-to-unicode* (the fixnum (- 1st-unit #xa0)))))) + :vector-encode-function + (nfunction + iso-8859-8-vector-encode + (lambda (string vector idx start end) + (declare (type (simple-array (unsigned-byte 8) (*)) vector) + (fixnum idx)) + (do* ((i start (1+ i))) + ((>= i end) idx) + (let* ((char (schar string i)) + (code (char-code char)) + (c2 (cond ((< code #xa0) code) + ((< code #xf8) + (svref *unicode-a0-f8-to-iso-8859-8* + (the fixnum (- code #xa0)))) + ((and (>= code #x5d0) (< code #x5f0)) + (svref *unicode-5d0-5f0-to-iso-8859-8* + (the fixnum (- code #x5d0)))) + ((and (>= code #x2008) (< code #x2018)) + (svref *unicode-2008-2018-to-iso-8859-8* + (the fixnum (- code #x2008))))))) + (declare (type (mod #x110000) code)) + (setf (aref vector idx) (or c2 (char-code #\Sub))) + (incf idx))))) + :vector-decode-function + (nfunction + iso-8859-8-vector-decode + (lambda (vector idx noctets string) + (declare (type (simple-array (unsigned-byte 8) (*)) vector)) + (do* ((i 0 (1+ i)) + (index idx (1+ index))) + ((>= i noctets) index) + (let* ((1st-unit (aref vector index))) + (declare (type (unsigned-byte 8) 1st-unit)) + (setf (schar string i) + (if (< 1st-unit #xa0) + (code-char 1st-unit) + (svref *iso-8859-8-to-unicode* (the fixnum (- 1st-unit #xa0))))))))) + :memory-encode-function + (nfunction + iso-8859-8-memory-encode + (lambda (string pointer idx start end) + (do* ((i start (1+ i))) + ((>= i end) idx) + (let* ((code (char-code (schar string i))) + (c2 (cond ((< code #xa0) code) + ((< code #xf8) + (svref *unicode-a0-f8-to-iso-8859-8* + (the fixnum (- code #xa0)))) + ((and (>= code #x5d0) (< code #x5f0)) + (svref *unicode-5d0-5f0-to-iso-8859-8* + (the fixnum (- code #x5d0)))) + ((and (>= code #x2008) (< code #x2018)) + (svref *unicode-2008-2018-to-iso-8859-8* + (the fixnum (- code #x2008))))))) + (declare (type (mod #x110000) code)) + (setf (%get-unsigned-byte pointer idx) (or c2 (char-code #\Sub))) + (incf idx))))) + :memory-decode-function + (nfunction + iso-8859-8-memory-decode + (lambda (pointer noctets idx string) + (do* ((i 0 (1+ i)) + (index idx (1+ index))) + ((>= i noctets) index) + (let* ((1st-unit (%get-unsigned-byte pointer index))) + (declare (type (unsigned-byte 8) 1st-unit)) + (setf (schar string i) + (if (< 1st-unit #xa0) + (code-char 1st-unit) + (svref *iso-8859-8-to-unicode* (the fixnum (- 1st-unit #xa0))))))))) + :octets-in-string-function + #'8-bit-fixed-width-octets-in-string + :length-of-vector-encoding-function + #'8-bit-fixed-width-length-of-vector-encoding + :length-of-memory-encoding-function + #'8-bit-fixed-width-length-of-memory-encoding + :decode-literal-code-unit-limit #xa0 + :encode-literal-char-code-limit #xa0 + ) + +(defstatic *iso-8859-9-to-unicode* + #( + ;; #xd0 + #\u+011e #\u+00d1 #\u+00d2 #\u+00d3 #\u+00d4 #\u+00d5 #\u+00d6 #\u+00d7 + #\u+00d8 #\u+00d9 #\u+00da #\u+00db #\u+00dc #\u+0130 #\u+015e #\u+00df + ;; #xe0 + #\u+00e0 #\u+00e1 #\u+00e2 #\u+00e3 #\u+00e4 #\u+00e5 #\u+00e6 #\u+00e7 + #\u+00e8 #\u+00e9 #\u+00ea #\u+00eb #\u+00ec #\u+00ed #\u+00ee #\u+00ef + ;; #xf0 + #\u+011f #\u+00f1 #\u+00f2 #\u+00f3 #\u+00f4 #\u+00f5 #\u+00f6 #\u+00f7 + #\u+00f8 #\u+00f9 #\u+00fa #\u+00fb #\u+00fc #\u+0131 #\u+015f #\u+00ff + )) + +(defstatic *unicode-d0-100-to-iso-8859-9* + #( + nil #xd1 #xd2 #xd3 #xd4 #xd5 #xd6 #xd7 ; #xd0-#xd7 + #xd8 #xd9 #xda #xdb #xdc nil nil #xdf ; #xd8-#xdf + #xe0 #xe1 #xe2 #xe3 #xe4 #xe5 #xe6 #xe7 ; #xe0-#xe7 + #xe8 #xe9 #xea #xeb #xec #xed #xee #xef ; #xe8-#xef + nil #xf1 #xf2 #xf3 #xf4 #xf5 #xf6 #xf7 ; #xf0-#xf7 + #xf8 #xf9 #xfa #xfb #xfc nil nil #xff ; #xf8-#xff + )) + +(defstatic *unicode-118-160-to-iso-8859-9* + #( + nil nil nil nil nil nil #xd0 #xf0 ; #x118-#x11f + nil nil nil nil nil nil nil nil ; #x120-#x127 + nil nil nil nil nil nil nil nil ; #x128-#x12f + #xdd #xfd nil nil nil nil nil nil ; #x130-#x137 + nil nil nil nil nil nil nil nil ; #x138-#x13f + nil nil nil nil nil nil nil nil ; #x140-#x147 + nil nil nil nil nil nil nil nil ; #x148-#x14f + nil nil nil nil nil nil nil nil ; #x150-#x157 + nil nil nil nil nil nil #xde #xfe ; #x158-#x15f + )) + + +(define-character-encoding :iso-8859-9 + "An 8-bit, fixed-width character encoding in which codes #x00-#xcf +map to their Unicode equivalents and other codes map to other Unicode +character values. Intended to provide most characters found in the +Turkish alphabet." + + :aliases '(:iso_8859-9 :latin5 :csISOLatin5 :iso-ir-148) + :stream-encode-function + (nfunction + iso-8859-9-stream-encode + (lambda (char write-function stream) + (let* ((code (char-code char)) + (c2 (cond ((< code #xd0) code) + ((< code #x100) + (svref *unicode-d0-100-to-iso-8859-9* + (the fixnum (- code #xd0)))) + ((and (>= code #x118) (< code #x160)) + (svref *unicode-118-160-to-iso-8859-9* + (the fixnum (- code #x118))))))) + + (declare (type (mod #x110000) code)) + (funcall write-function stream (or c2 (char-code #\Sub))) + 1))) + :stream-decode-function + (nfunction + iso-8859-9-stream-decode + (lambda (1st-unit next-unit-function stream) + (declare (ignore next-unit-function stream) + (type (unsigned-byte 8) 1st-unit)) + (if (< 1st-unit #xa0) + (code-char 1st-unit) + (svref *iso-8859-9-to-unicode* (the fixnum (- 1st-unit #xa0)))))) + :vector-encode-function + (nfunction + iso-8859-9-vector-encode + (lambda (string vector idx start end) + (declare (type (simple-array (unsigned-byte 8) (*)) vector) + (fixnum idx)) + (do* ((i start (1+ i))) + ((>= i end) idx) + (let* ((char (schar string i)) + (code (char-code char)) + (c2 (cond ((< code #xd0) code) + ((< code #x100) + (svref *unicode-d0-100-to-iso-8859-9* + (the fixnum (- code #xd0)))) + ((and (>= code #x118) (< code #x160)) + (svref *unicode-118-160-to-iso-8859-9* + (the fixnum (- code #x118))))))) + (declare (type (mod #x110000) code)) + (setf (aref vector idx) (or c2 (char-code #\Sub))) + (incf idx))))) + :vector-decode-function + (nfunction + iso-8859-9-vector-decode + (lambda (vector idx noctets string) + (declare (type (simple-array (unsigned-byte 8) (*)) vector)) + (do* ((i 0 (1+ i)) + (index idx (1+ index))) + ((>= i noctets) index) + (let* ((1st-unit (aref vector index))) + (declare (type (unsigned-byte 8) 1st-unit)) + (setf (schar string i) + (if (< 1st-unit #xa0) + (code-char 1st-unit) + (svref *iso-8859-9-to-unicode* (the fixnum (- 1st-unit #xa0))))))))) + :memory-encode-function + (nfunction + iso-8859-9-memory-encode + (lambda (string pointer idx start end) + (do* ((i start (1+ i))) + ((>= i end) idx) + (let* ((code (char-code (schar string i))) + (c2 (cond ((< code #xd0) code) + ((< code #x100) + (svref *unicode-d0-100-to-iso-8859-9* + (the fixnum (- code #xd0)))) + ((and (>= code #x118) (< code #x160)) + (svref *unicode-118-160-to-iso-8859-9* + (the fixnum (- code #x118))))))) + (declare (type (mod #x110000) code)) + (setf (%get-unsigned-byte pointer idx) (or c2 (char-code #\Sub))) + (incf idx))))) + :memory-decode-function + (nfunction + iso-8859-9-memory-decode + (lambda (pointer noctets idx string) + (do* ((i 0 (1+ i)) + (index idx (1+ index))) + ((>= i noctets) index) + (let* ((1st-unit (%get-unsigned-byte pointer index))) + (declare (type (unsigned-byte 8) 1st-unit)) + (setf (schar string i) + (if (< 1st-unit #xa0) + (code-char 1st-unit) + (svref *iso-8859-9-to-unicode* (the fixnum (- 1st-unit #xa0))))))))) + :octets-in-string-function + #'8-bit-fixed-width-octets-in-string + :length-of-vector-encoding-function + #'8-bit-fixed-width-length-of-vector-encoding + :length-of-memory-encoding-function + #'8-bit-fixed-width-length-of-memory-encoding + :decode-literal-code-unit-limit #xd0 + :encode-literal-char-code-limit #xa0 + ) + +(defstatic *iso-8859-10-to-unicode* + #( + ;; #xa0 + #\u+00a0 #\u+0104 #\u+0112 #\u+0122 #\u+012a #\u+0128 #\u+0136 #\u+00a7 + #\u+013b #\u+0110 #\u+0160 #\u+0166 #\u+017d #\u+00ad #\u+016a #\u+014a + ;; #xb0 + #\u+00b0 #\u+0105 #\u+0113 #\u+0123 #\u+012b #\u+0129 #\u+0137 #\u+00b7 + #\u+013c #\u+0111 #\u+0161 #\u+0167 #\u+017e #\u+2015 #\u+016b #\u+014b + ;; #xc0 + #\u+0100 #\u+00c1 #\u+00c2 #\u+00c3 #\u+00c4 #\u+00c5 #\u+00c6 #\u+012e + #\u+010c #\u+00c9 #\u+0118 #\u+00cb #\u+0116 #\u+00cd #\u+00ce #\u+00cf + ;; #xd0 + #\u+00d0 #\u+0145 #\u+014c #\u+00d3 #\u+00d4 #\u+00d5 #\u+00d6 #\u+0168 + #\u+00d8 #\u+0172 #\u+00da #\u+00db #\u+00dc #\u+00dd #\u+00de #\u+00df + ;; #xe0 + #\u+0101 #\u+00e1 #\u+00e2 #\u+00e3 #\u+00e4 #\u+00e5 #\u+00e6 #\u+012f + #\u+010d #\u+00e9 #\u+0119 #\u+00eb #\u+0117 #\u+00ed #\u+00ee #\u+00ef + ;; #xf0 + #\u+00f0 #\u+0146 #\u+014d #\u+00f3 #\u+00f4 #\u+00f5 #\u+00f6 #\u+0169 + #\u+00f8 #\u+0173 #\u+00fa #\u+00fb #\u+00fc #\u+00fd #\u+00fe #\u+0138 + )) + +(defstatic *unicode-a0-180-to-iso-8859-10* + #( + #xa0 nil nil nil nil nil nil #xa7 ; #xa0-#xa7 + nil nil nil nil nil #xad nil nil ; #xa8-#xaf + #xb0 nil nil nil nil nil nil #xb7 ; #xb0-#xb7 + nil nil nil nil nil nil nil nil ; #xb8-#xbf + nil #xc1 #xc2 #xc3 #xc4 #xc5 #xc6 nil ; #xc0-#xc7 + nil #xc9 nil #xcb nil #xcd #xce #xcf ; #xc8-#xcf + #xd0 nil nil #xd3 #xd4 #xd5 #xd6 nil ; #xd0-#xd7 + #xd8 nil #xda #xdb #xdc #xdd #xde #xdf ; #xd8-#xdf + nil #xe1 #xe2 #xe3 #xe4 #xe5 #xe6 nil ; #xe0-#xe7 + nil #xe9 nil #xeb nil #xed #xee #xef ; #xe8-#xef + #xf0 nil nil #xf3 #xf4 #xf5 #xf6 nil ; #xf0-#xf7 + #xf8 nil #xfa #xfb #xfc #xfd #xfe nil ; #xf8-#xff + #xc0 #xe0 nil nil #xa1 #xb1 nil nil ; #x100-#x107 + nil nil nil nil #xc8 #xe8 nil nil ; #x108-#x10f + #xa9 #xb9 #xa2 #xb2 nil nil #xcc #xec ; #x110-#x117 + #xca #xea nil nil nil nil nil nil ; #x118-#x11f + nil nil #xa3 #xb3 nil nil nil nil ; #x120-#x127 + #xa5 #xb5 #xa4 #xb4 nil nil #xc7 #xe7 ; #x128-#x12f + nil nil nil nil nil nil #xa6 #xb6 ; #x130-#x137 + #xff nil nil #xa8 #xb8 nil nil nil ; #x138-#x13f + nil nil nil nil nil #xd1 #xf1 nil ; #x140-#x147 + nil nil #xaf #xbf #xd2 #xf2 nil nil ; #x148-#x14f + nil nil nil nil nil nil nil nil ; #x150-#x157 + nil nil nil nil nil nil nil nil ; #x158-#x15f + #xaa #xba nil nil nil nil #xab #xbb ; #x160-#x167 + #xd7 #xf7 #xae #xbe nil nil nil nil ; #x168-#x16f + nil nil #xd9 #xf9 nil nil nil nil ; #x170-#x177 + nil nil nil nil nil #xac #xbc nil ; #x178-#x17f + )) + +(define-character-encoding :iso-8859-10 + "An 8-bit, fixed-width character encoding in which codes #x00-#x9f +map to their Unicode equivalents and other codes map to other Unicode +character values. Intended to provide most characters found in Nordic +alphabets." + + :aliases '(:iso_8859-10 :latin6 :csISOLatin6 :iso-ir-157) + :stream-encode-function + (nfunction + iso-8859-10-stream-encode + (lambda (char write-function stream) + (let* ((code (char-code char)) + (c2 (cond ((< code #xa0) code) + ((< code #x180) + (svref *unicode-a0-180-to-iso-8859-10* + (the fixnum (- code #xa0))))))) + (declare (type (mod #x110000) code)) + (funcall write-function stream (or c2 (char-code #\Sub))) + 1))) + :stream-decode-function + (nfunction + iso-8859-10-stream-decode + (lambda (1st-unit next-unit-function stream) + (declare (ignore next-unit-function stream) + (type (unsigned-byte 8) 1st-unit)) + (if (< 1st-unit #xa0) + (code-char 1st-unit) + (svref *iso-8859-10-to-unicode* (the fixnum (- 1st-unit #xa0)))))) + :vector-encode-function + (nfunction + iso-8859-10-vector-encode + (lambda (string vector idx start end) + (declare (type (simple-array (unsigned-byte 8) (*)) vector) + (fixnum idx)) + (do* ((i start (1+ i))) + ((>= i end) idx) + (let* ((char (schar string i)) + (code (char-code char)) + (c2 (cond ((< code #xa0) code) + ((< code #x180) + (svref *unicode-a0-180-to-iso-8859-10* + (the fixnum (- code #xa0))))))) + (declare (type (mod #x110000) code)) + (setf (aref vector idx) (or c2 (char-code #\Sub))) + (incf idx))))) + :vector-decode-function + (nfunction + iso-8859-10-vector-decode + (lambda (vector idx noctets string) + (declare (type (simple-array (unsigned-byte 8) (*)) vector)) + (do* ((i 0 (1+ i)) + (index idx (1+ index))) + ((>= i noctets) index) + (let* ((1st-unit (aref vector index))) + (declare (type (unsigned-byte 8) 1st-unit)) + (setf (schar string i) + (if (< 1st-unit #xa0) + (code-char 1st-unit) + (svref *iso-8859-10-to-unicode* (the fixnum (- 1st-unit #xa0))))))))) + :memory-encode-function + (nfunction + iso-8859-10-memory-encode + (lambda (string pointer idx start end) + (do* ((i start (1+ i))) + ((>= i end) idx) + (let* ((code (char-code (schar string i))) + (c2 (cond ((< code #xa0) code) + ((< code #x180) + (svref *unicode-a0-180-to-iso-8859-10* + (the fixnum (- code #xa0))))))) + (declare (type (mod #x110000) code)) + (setf (%get-unsigned-byte pointer idx) (or c2 (char-code #\Sub))) + (incf idx))))) + :memory-decode-function + (nfunction + iso-8859-10-memory-decode + (lambda (pointer noctets idx string) + (do* ((i 0 (1+ i)) + (index idx (1+ index))) + ((>= i noctets) index) + (let* ((1st-unit (%get-unsigned-byte pointer index))) + (declare (type (unsigned-byte 8) 1st-unit)) + (setf (schar string i) + (if (< 1st-unit #xa0) + (code-char 1st-unit) + (svref *iso-8859-10-to-unicode* (the fixnum (- 1st-unit #xa0))))))))) + :octets-in-string-function + #'8-bit-fixed-width-octets-in-string + :length-of-vector-encoding-function + #'8-bit-fixed-width-length-of-vector-encoding + :length-of-memory-encoding-function + #'8-bit-fixed-width-length-of-memory-encoding + :decode-literal-code-unit-limit #xa0 + :encode-literal-char-code-limit #xa0 + ) + +(define-character-encoding :iso-8859-11 + "An 8-bit, fixed-width character encoding in which codes #x00-#x9f +map to their Unicode equivalents and other codes map to other Unicode +character values. Intended to provide most characters found the Thai +alphabet." + :aliases '() + :stream-encode-function + (nfunction + iso-8859-11-stream-encode + (lambda (char write-function stream) + (let* ((code (char-code char)) + (c2 (cond ((< code #xa1) code) + ((and (<= code #xfb) + (not (and (>= code #xdb) (<= code #xde)))) + (+ code #x0d60))))) + (declare (type (mod #x110000) code)) + (funcall write-function stream (or c2 (char-code #\Sub))) + 1))) + :stream-decode-function + (nfunction + iso-8859-11-stream-decode + (lambda (1st-unit next-unit-function stream) + (declare (ignore next-unit-function stream) + (type (unsigned-byte 8) 1st-unit)) + (if (< 1st-unit #xa1) + (code-char 1st-unit) + (if (and (>= 1st-unit #xe01) + (<= 1st-unit #xe5b) + (not (and (>= 1st-unit #xe3b) + (<= 1st-unit #xe3e)))) + (code-char (- 1st-unit #xd60)) + #\Replacement_Character)))) + :vector-encode-function + (nfunction + iso-8859-11-vector-encode + (lambda (string vector idx start end) + (declare (type (simple-array (unsigned-byte 8) (*)) vector) + (fixnum idx)) + (do* ((i start (1+ i))) + ((>= i end) idx) + (let* ((char (schar string i)) + (code (char-code char)) + (c2 (cond ((< code #xa1) code) + ((and (<= code #xfb) + (not (and (>= code #xdb) (<= code #xde)))) + (+ code #x0d60))))) + (declare (type (mod #x110000) code)) + (setf (aref vector idx) (or c2 (char-code #\Sub))) + (incf idx))))) + :vector-decode-function + (nfunction + iso-8859-11-vector-decode + (lambda (vector idx noctets string) + (declare (type (simple-array (unsigned-byte 8) (*)) vector)) + (do* ((i 0 (1+ i)) + (index idx (1+ index))) + ((>= i noctets) index) + (let* ((1st-unit (aref vector index))) + (declare (type (unsigned-byte 8) 1st-unit)) + (setf (schar string i) + (if (< 1st-unit #xa1) + (code-char 1st-unit) + (if (and (>= 1st-unit #xe01) + (<= 1st-unit #xe5b) + (not (and (>= 1st-unit #xe3b) + (<= 1st-unit #xe3e)))) + (code-char (- 1st-unit #xd60)) + #\Replacement_Character))))))) + :memory-encode-function + (nfunction + iso-8859-11-memory-encode + (lambda (string pointer idx start end) + (do* ((i start (1+ i))) + ((>= i end) idx) + (let* ((code (char-code (schar string i))) + (c2 (cond ((< code #xa1) code) + ((and (<= code #xfb) + (not (and (>= code #xdb) (<= code #xde)))) + (+ code #x0d60))))) + (declare (type (mod #x110000) code)) + (setf (%get-unsigned-byte pointer idx) (or c2 (char-code #\Sub))) + (incf idx))))) + :memory-decode-function + (nfunction + iso-8859-11-memory-decode + (lambda (pointer noctets idx string) + (do* ((i 0 (1+ i)) + (index idx (1+ index))) + ((>= i noctets) index) + (let* ((1st-unit (%get-unsigned-byte pointer index))) + (declare (type (unsigned-byte 8) 1st-unit)) + (setf (schar string i) + (if (< 1st-unit #xa1) + (code-char 1st-unit) + (if (and (>= 1st-unit #xe01) + (<= 1st-unit #xe5b) + (not (and (>= 1st-unit #xe3b) + (<= 1st-unit #xe3e)))) + (code-char (- 1st-unit #xd60)) + #\Replacement_Character))))))) + :octets-in-string-function + #'8-bit-fixed-width-octets-in-string + :length-of-vector-encoding-function + #'8-bit-fixed-width-length-of-vector-encoding + :length-of-memory-encoding-function + #'8-bit-fixed-width-length-of-memory-encoding + :decode-literal-code-unit-limit #xa0 + :encode-literal-char-code-limit #xa0 + ) + +;;; There is no iso-8859-12 encoding. + +(defstatic *iso-8859-13-to-unicode* + #( + ;; #xa0 + #\u+00a0 #\u+201d #\u+00a2 #\u+00a3 #\u+00a4 #\u+201e #\u+00a6 #\u+00a7 + #\u+00d8 #\u+00a9 #\u+0156 #\u+00ab #\u+00ac #\u+00ad #\u+00ae #\u+00c6 + ;; #xb0 + #\u+00b0 #\u+00b1 #\u+00b2 #\u+00b3 #\u+201c #\u+00b5 #\u+00b6 #\u+00b7 + #\u+00f8 #\u+00b9 #\u+0157 #\u+00bb #\u+00bc #\u+00bd #\u+00be #\u+00e6 + ;; #xc0 + #\u+0104 #\u+012e #\u+0100 #\u+0106 #\u+00c4 #\u+00c5 #\u+0118 #\u+0112 + #\u+010c #\u+00c9 #\u+0179 #\u+0116 #\u+0122 #\u+0136 #\u+012a #\u+013b + ;; #xd0 + #\u+0160 #\u+0143 #\u+0145 #\u+00d3 #\u+014c #\u+00d5 #\u+00d6 #\u+00d7 + #\u+0172 #\u+0141 #\u+015a #\u+016a #\u+00dc #\u+017b #\u+017d #\u+00df + ;; #xe0 + #\u+0105 #\u+012f #\u+0101 #\u+0107 #\u+00e4 #\u+00e5 #\u+0119 #\u+0113 + #\u+010d #\u+00e9 #\u+017a #\u+0117 #\u+0123 #\u+0137 #\u+012b #\u+013c + ;; #xf0 + #\u+0161 #\u+0144 #\u+0146 #\u+00f3 #\u+014d #\u+00f5 #\u+00f6 #\u+00f7 + #\u+0173 #\u+0142 #\u+015b #\u+016b #\u+00fc #\u+017c #\u+017e #\u+2019 + )) + +(defstatic *unicode-a0-180-to-iso-8859-13* + #( + #xa0 nil #xa2 #xa3 #xa4 nil #xa6 #xa7 ; #xa0-#xa7 + nil #xa9 nil #xab #xac #xad #xae nil ; #xa8-#xaf + #xb0 #xb1 #xb2 #xb3 nil #xb5 #xb6 #xb7 ; #xb0-#xb7 + nil #xb9 nil #xbb #xbc #xbd #xbe nil ; #xb8-#xbf + nil nil nil nil #xc4 #xc5 #xaf nil ; #xc0-#xc7 + nil #xc9 nil nil nil nil nil nil ; #xc8-#xcf + nil nil nil #xd3 nil #xd5 #xd6 #xd7 ; #xd0-#xd7 + #xa8 nil nil nil #xdc nil nil #xdf ; #xd8-#xdf + nil nil nil nil #xe4 #xe5 #xbf nil ; #xe0-#xe7 + nil #xe9 nil nil nil nil nil nil ; #xe8-#xef + nil nil nil #xf3 nil #xf5 #xf6 #xf7 ; #xf0-#xf7 + #xb8 nil nil nil #xfc nil nil nil ; #xf8-#xff + #xc2 #xe2 nil nil #xc0 #xe0 #xc3 #xe3 ; #x100-#x107 + nil nil nil nil #xc8 #xe8 nil nil ; #x108-#x10f + nil nil #xc7 #xe7 nil nil #xcb #xeb ; #x110-#x117 + #xc6 #xe6 nil nil nil nil nil nil ; #x118-#x11f + nil nil #xcc #xec nil nil nil nil ; #x120-#x127 + nil nil #xce #xee nil nil #xc1 #xe1 ; #x128-#x12f + nil nil nil nil nil nil #xcd #xed ; #x130-#x137 + nil nil nil #xcf #xef nil nil nil ; #x138-#x13f + nil #xd9 #xf9 #xd1 #xf1 #xd2 #xf2 nil ; #x140-#x147 + nil nil nil nil #xd4 #xf4 nil nil ; #x148-#x14f + nil nil nil nil nil nil #xaa #xba ; #x150-#x157 + nil nil #xda #xfa nil nil nil nil ; #x158-#x15f + #xd0 #xf0 nil nil nil nil nil nil ; #x160-#x167 + nil nil #xdb #xfb nil nil nil nil ; #x168-#x16f + nil nil #xd8 #xf8 nil nil nil nil ; #x170-#x177 + nil #xca #xea #xdd #xfd #xde #xfe nil ; #x178-#x17f + )) + +(defstatic *unicode-2018-2020-to-iso-8859-13* + #( + nil #xff nil nil #xb4 #xa1 #xa5 nil ; #x2018-#x201f */ + )) + + +(define-character-encoding :iso-8859-13 + "An 8-bit, fixed-width character encoding in which codes #x00-#x9f +map to their Unicode equivalents and other codes map to other Unicode +character values. Intended to provide most characters found in Baltic +alphabets." + + :aliases '() + :stream-encode-function + (nfunction + iso-8859-13-stream-encode + (lambda (char write-function stream) + (let* ((code (char-code char)) + (c2 (cond ((< code #xa0) code) + ((< code #x180) + (svref *unicode-a0-180-to-iso-8859-13* + (the fixnum (- code #xa0)))) + ((and (>= code #x2018) + (< code #x2020)) + (svref *unicode-2018-2020-to-iso-8859-13* + (the fixnum (- code #x2018))))))) + (declare (type (mod #x110000) code)) + (funcall write-function stream (or c2 (char-code #\Sub))) + 1))) + :stream-decode-function + (nfunction + iso-8859-13-stream-decode + (lambda (1st-unit next-unit-function stream) + (declare (ignore next-unit-function stream) + (type (unsigned-byte 8) 1st-unit)) + (if (< 1st-unit #xa0) + (code-char 1st-unit) + (svref *iso-8859-13-to-unicode* (the fixnum (- 1st-unit #xa0)))))) + :vector-encode-function + (nfunction + iso-8859-13-vector-encode + (lambda (string vector idx start end) + (declare (type (simple-array (unsigned-byte 8) (*)) vector) + (fixnum idx)) + (do* ((i start (1+ i))) + ((>= i end) idx) + (let* ((char (schar string i)) + (code (char-code char)) + (c2 (cond ((< code #xa0) code) + ((< code #x180) + (svref *unicode-a0-180-to-iso-8859-13* + (the fixnum (- code #xa0)))) + ((and (>= code #x2018) + (< code #x2020)) + (svref *unicode-2018-2020-to-iso-8859-13* + (the fixnum (- code #x2018))))))) + (declare (type (mod #x110000) code)) + (setf (aref vector idx) (or c2 (char-code #\Sub))) + (incf idx))))) + :vector-decode-function + (nfunction + iso-8859-13-vector-decode + (lambda (vector idx noctets string) + (declare (type (simple-array (unsigned-byte 8) (*)) vector)) + (do* ((i 0 (1+ i)) + (index idx (1+ index))) + ((>= i noctets) index) + (let* ((1st-unit (aref vector index))) + (declare (type (unsigned-byte 8) 1st-unit)) + (setf (schar string i) + (if (< 1st-unit #xa0) + (code-char 1st-unit) + (svref *iso-8859-13-to-unicode* (the fixnum (- 1st-unit #xa0))))))))) + :memory-encode-function + (nfunction + iso-8859-13-memory-encode + (lambda (string pointer idx start end) + (do* ((i start (1+ i))) + ((>= i end) idx) + (let* ((code (char-code (schar string i))) + (c2 (cond ((< code #xa0) code) + ((< code #x180) + (svref *unicode-a0-180-to-iso-8859-13* + (the fixnum (- code #xa0)))) + ((and (>= code #x2018) + (< code #x2020)) + (svref *unicode-2018-2020-to-iso-8859-13* + (the fixnum (- code #x2018))))))) + (declare (type (mod #x110000) code)) + (setf (%get-unsigned-byte pointer idx) (or c2 (char-code #\Sub))) + (incf idx))))) + :memory-decode-function + (nfunction + iso-8859-13-memory-decode + (lambda (pointer noctets idx string) + (do* ((i 0 (1+ i)) + (index idx (1+ index))) + ((>= i noctets) index) + (let* ((1st-unit (%get-unsigned-byte pointer index))) + (declare (type (unsigned-byte 8) 1st-unit)) + (setf (schar string i) + (if (< 1st-unit #xa0) + (code-char 1st-unit) + (svref *iso-8859-13-to-unicode* (the fixnum (- 1st-unit #xa0))))))))) + :octets-in-string-function + #'8-bit-fixed-width-octets-in-string + :length-of-vector-encoding-function + #'8-bit-fixed-width-length-of-vector-encoding + :length-of-memory-encoding-function + #'8-bit-fixed-width-length-of-memory-encoding + :decode-literal-code-unit-limit #xa0 + :encode-literal-char-code-limit #xa0 + ) + +(defstatic *iso-8859-14-to-unicode* + #( + ;; #xa0 + #\u+00a0 #\u+1e02 #\u+1e03 #\u+00a3 #\u+010a #\u+010b #\u+1e0a #\u+00a7 + #\u+1e80 #\u+00a9 #\u+1e82 #\u+1e0b #\u+1ef2 #\u+00ad #\u+00ae #\u+0178 + ;; #xb0 + #\u+1e1e #\u+1e1f #\u+0120 #\u+0121 #\u+1e40 #\u+1e41 #\u+00b6 #\u+1e56 + #\u+1e81 #\u+1e57 #\u+1e83 #\u+1e60 #\u+1ef3 #\u+1e84 #\u+1e85 #\u+1e61 + ;; #xc0 + #\u+00c0 #\u+00c1 #\u+00c2 #\u+00c3 #\u+00c4 #\u+00c5 #\u+00c6 #\u+00c7 + #\u+00c8 #\u+00c9 #\u+00ca #\u+00cb #\u+00cc #\u+00cd #\u+00ce #\u+00cf + ;; #xd0 + #\u+0174 #\u+00d1 #\u+00d2 #\u+00d3 #\u+00d4 #\u+00d5 #\u+00d6 #\u+1e6a + #\u+00d8 #\u+00d9 #\u+00da #\u+00db #\u+00dc #\u+00dd #\u+0176 #\u+00df + ;; #xe0 + #\u+00e0 #\u+00e1 #\u+00e2 #\u+00e3 #\u+00e4 #\u+00e5 #\u+00e6 #\u+00e7 + #\u+00e8 #\u+00e9 #\u+00ea #\u+00eb #\u+00ec #\u+00ed #\u+00ee #\u+00ef + ;; #xf0 + #\u+0175 #\u+00f1 #\u+00f2 #\u+00f3 #\u+00f4 #\u+00f5 #\u+00f6 #\u+1e6b + #\u+00f8 #\u+00f9 #\u+00fa #\u+00fb #\u+00fc #\u+00fd #\u+0177 #\u+00ff + )) + +(defstatic *unicode-a0-100-to-iso-8859-14* + #( + #xa0 nil nil #xa3 nil nil nil #xa7 ; #xa0-#xa7 + nil #xa9 nil nil nil #xad #xae nil ; #xa8-#xaf + nil nil nil nil nil nil #xb6 nil ; #xb0-#xb7 + nil nil nil nil nil nil nil nil ; #xb8-#xbf + #xc0 #xc1 #xc2 #xc3 #xc4 #xc5 #xc6 #xc7 ; #xc0-#xc7 + #xc8 #xc9 #xca #xcb #xcc #xcd #xce #xcf ; #xc8-#xcf + nil #xd1 #xd2 #xd3 #xd4 #xd5 #xd6 nil ; #xd0-#xd7 + #xd8 #xd9 #xda #xdb #xdc #xdd nil #xdf ; #xd8-#xdf + #xe0 #xe1 #xe2 #xe3 #xe4 #xe5 #xe6 #xe7 ; #xe0-#xe7 + #xe8 #xe9 #xea #xeb #xec #xed #xee #xef ; #xe8-#xef + nil #xf1 #xf2 #xf3 #xf4 #xf5 #xf6 nil ; #xf0-#xf7 + #xf8 #xf9 #xfa #xfb #xfc #xfd nil #xff ; #xf8-#xff + )) + +(defstatic *unicode-108-128-to-iso-8859-14* + #( + nil nil #xa4 #xa5 nil nil nil nil ; #x108-#x10f + nil nil nil nil nil nil nil nil ; #x110-#x117 + nil nil nil nil nil nil nil nil ; #x118-#x11f + #xb2 #xb3 nil nil nil nil nil nil ; #x120-#x127 + )) + +(defstatic *unicode-170-180-to-iso-8859-14* + #( + nil nil nil nil #xd0 #xf0 #xde #xfe ; #x170-#x177 + #xaf nil nil nil nil nil nil nil ; #x178-#x17f + )) + +(defstatic *unicode-1e00-1e88-to-iso-8859-14* + #( + nil nil #xa1 #xa2 nil nil nil nil ; #x1e00-#x1e07 + nil nil #xa6 #xab nil nil nil nil ; #x1e08-#x1e0f + nil nil nil nil nil nil nil nil ; #x1e10-#x1e17 + nil nil nil nil nil nil #xb0 #xb1 ; #x1e18-#x1e1f + nil nil nil nil nil nil nil nil ; #x1e20-#x1e27 + nil nil nil nil nil nil nil nil ; #x1e28-#x1e2f + nil nil nil nil nil nil nil nil ; #x1e30-#x1e37 + nil nil nil nil nil nil nil nil ; #x1e38-#x1e3f + #xb4 #xb5 nil nil nil nil nil nil ; #x1e40-#x1e47 + nil nil nil nil nil nil nil nil ; #x1e48-#x1e4f + nil nil nil nil nil nil #xb7 #xb9 ; #x1e50-#x1e57 + nil nil nil nil nil nil nil nil ; #x1e58-#x1e5f + #xbb #xbf nil nil nil nil nil nil ; #x1e60-#x1e67 + nil nil #xd7 #xf7 nil nil nil nil ; #x1e68-#x1e6f + nil nil nil nil nil nil nil nil ; #x1e70-#x1e77 + nil nil nil nil nil nil nil nil ; #x1e78-#x1e7f + #xa8 #xb8 #xaa #xba #xbd #xbe nil nil ; #x1e80-#x1e87 + )) + +(defstatic *unicode-1ef0-1ef8-to-iso-8859-14* + #( + nil nil #xac #xbc nil nil nil nil ; #x1ef0-#x1ef7 + )) + +(define-character-encoding :iso-8859-14 + "An 8-bit, fixed-width character encoding in which codes #x00-#x9f +map to their Unicode equivalents and other codes map to other Unicode +character values. Intended to provide most characters found in Celtic +languages." + :aliases '(:iso_8859-14 :iso-ir-199 :latin8 :l8 :iso-celtic) + :stream-encode-function + (nfunction + iso-8859-14-stream-encode + (lambda (char write-function stream) + (let* ((code (char-code char)) + (c2 (cond ((< code #xa0) code) + ((< code #x100) + (svref *unicode-a0-100-to-iso-8859-14* + (the fixnum (- code #xa0)))) + ((and (>= code #x108) (< code #x128)) + (svref *unicode-108-128-to-iso-8859-14* + (the fixnum (- code #x108)))) + ((and (>= code #x170) (< code #x180)) + (svref *unicode-170-180-to-iso-8859-14* + (the fixnum (- code #x170)))) + ((and (>= code #x1e00) (< code #x1e88)) + (svref *unicode-1e00-1e88-to-iso-8859-14* + (the fixnum (- code #x1e00)))) + ((and (>= code #x1ef0) (< code #x1ef8)) + (svref *unicode-1ef0-1ef8-to-iso-8859-14* + (the fixnum (- code #x1ef0))))))) + (declare (type (mod #x110000) code)) + (funcall write-function stream (or c2 (char-code #\Sub))) + 1))) + :stream-decode-function + (nfunction + iso-8859-14-stream-decode + (lambda (1st-unit next-unit-function stream) + (declare (ignore next-unit-function stream) + (type (unsigned-byte 8) 1st-unit)) + (if (< 1st-unit #xa0) + (code-char 1st-unit) + (svref *iso-8859-14-to-unicode* (the fixnum (- 1st-unit #xa0)))))) + :vector-encode-function + (nfunction + iso-8859-14-vector-encode + (lambda (string vector idx start end) + (declare (type (simple-array (unsigned-byte 8) (*)) vector) + (fixnum idx)) + (do* ((i start (1+ i))) + ((>= i end) idx) + (let* ((char (schar string i)) + (code (char-code char)) + (c2 (cond ((< code #xa0) code) + ((< code #x100) + (svref *unicode-a0-100-to-iso-8859-14* + (the fixnum (- code #xa0)))) + ((and (>= code #x108) (< code #x128)) + (svref *unicode-108-128-to-iso-8859-14* + (the fixnum (- code #x108)))) + ((and (>= code #x170) (< code #x180)) + (svref *unicode-170-180-to-iso-8859-14* + (the fixnum (- code #x170)))) + ((and (>= code #x1e00) (< code #x1e88)) + (svref *unicode-1e00-1e88-to-iso-8859-14* + (the fixnum (- code #x1e00)))) + ((and (>= code #x1ef0) (< code #x1ef8)) + (svref *unicode-1ef0-1ef8-to-iso-8859-14* + (the fixnum (- code #x1ef0))))))) + (declare (type (mod #x110000) code)) + (setf (aref vector idx) (or c2 (char-code #\Sub))) + (incf idx))))) + :vector-decode-function + (nfunction + iso-8859-14-vector-decode + (lambda (vector idx noctets string) + (declare (type (simple-array (unsigned-byte 8) (*)) vector)) + (do* ((i 0 (1+ i)) + (index idx (1+ index))) + ((>= i noctets) index) + (let* ((1st-unit (aref vector index))) + (declare (type (unsigned-byte 8) 1st-unit)) + (setf (schar string i) + (if (< 1st-unit #xa0) + (code-char 1st-unit) + (svref *iso-8859-14-to-unicode* (the fixnum (- 1st-unit #xa0))))))))) + :memory-encode-function + (nfunction + iso-8859-14-memory-encode + (lambda (string pointer idx start end) + (do* ((i start (1+ i))) + ((>= i end) idx) + (let* ((code (char-code (schar string i))) + (c2 (cond ((< code #xa0) code) + ((< code #x100) + (svref *unicode-a0-100-to-iso-8859-14* + (the fixnum (- code #xa0)))) + ((and (>= code #x108) (< code #x128)) + (svref *unicode-108-128-to-iso-8859-14* + (the fixnum (- code #x108)))) + ((and (>= code #x170) (< code #x180)) + (svref *unicode-170-180-to-iso-8859-14* + (the fixnum (- code #x170)))) + ((and (>= code #x1e00) (< code #x1e88)) + (svref *unicode-1e00-1e88-to-iso-8859-14* + (the fixnum (- code #x1e00)))) + ((and (>= code #x1ef0) (< code #x1ef8)) + (svref *unicode-1ef0-1ef8-to-iso-8859-14* + (the fixnum (- code #x1ef0))))))) + (declare (type (mod #x110000) code)) + (setf (%get-unsigned-byte pointer idx) (or c2 (char-code #\Sub))) + (incf idx))))) + :memory-decode-function + (nfunction + iso-8859-14-memory-decode + (lambda (pointer noctets idx string) + (do* ((i 0 (1+ i)) + (index idx (1+ index))) + ((>= i noctets) index) + (let* ((1st-unit (%get-unsigned-byte pointer index))) + (declare (type (unsigned-byte 8) 1st-unit)) + (setf (schar string i) + (if (< 1st-unit #xa0) + (code-char 1st-unit) + (svref *iso-8859-14-to-unicode* (the fixnum (- 1st-unit #xa0))))))))) + :octets-in-string-function + #'8-bit-fixed-width-octets-in-string + :length-of-vector-encoding-function + #'8-bit-fixed-width-length-of-vector-encoding + :length-of-memory-encoding-function + #'8-bit-fixed-width-length-of-memory-encoding + :decode-literal-code-unit-limit #xa0 + :encode-literal-char-code-limit #xa0 + ) + +(defstatic *iso-8859-15-to-unicode* + #( + ;; #xa0 + #\u+00a0 #\u+00a1 #\u+00a2 #\u+00a3 #\u+20ac #\u+00a5 #\u+0160 #\u+00a7 + #\u+0161 #\u+00a9 #\u+00aa #\u+00ab #\u+00ac #\u+00ad #\u+00ae #\u+00af + ;; #xb0 + #\u+00b0 #\u+00b1 #\u+00b2 #\u+00b3 #\u+017d #\u+00b5 #\u+00b6 #\u+00b7 + #\u+017e #\u+00b9 #\u+00ba #\u+00bb #\u+0152 #\u+0153 #\u+0178 #\u+00bf + ;; #xc0 + #\u+00c0 #\u+00c1 #\u+00c2 #\u+00c3 #\u+00c4 #\u+00c5 #\u+00c6 #\u+00c7 + ;; #xc8 + #\u+00c8 #\u+00c9 #\u+00ca #\u+00cb #\u+00cc #\u+00cd #\u+00ce #\u+00cf + ;; #xd0 + #\u+00d0 #\u+00d1 #\u+00d2 #\u+00d3 #\u+00d4 #\u+00d5 #\u+00d6 #\u+00d7 + ;; #xd8 + #\u+00d8 #\u+00d9 #\u+00da #\u+00db #\u+00dc #\u+00dd #\u+00de #\u+00df + ;; #xe0 + #\u+00e0 #\u+00e1 #\u+00e2 #\u+00e3 #\u+00e4 #\u+00e5 #\u+00e6 #\u+00e7 + ;; #xe8 + #\u+00e8 #\u+00e9 #\u+00ea #\u+00eb #\u+00ec #\u+00ed #\u+00ee #\u+00ef + ;; #xf0 + #\u+00f0 #\u+00f1 #\u+00f2 #\u+00f3 #\u+00f4 #\u+00f5 #\u+00f6 #\u+00f7 + ;; #xf8 + #\u+00f8 #\u+00f9 #\u+00fa #\u+00fb #\u+00fc #\u+00fd #\u+00fe #\u+00ff + )) + +(defstatic *unicode-a0-100-to-iso-8859-15* + #( + #xa0 #xa1 #xa2 #xa3 nil #xa5 nil #xa7 ; #xa0-#xa7 + nil #xa9 #xaa #xab #xac #xad #xae #xaf ; #xa8-#xaf + #xb0 #xb1 #xb2 #xb3 nil #xb5 #xb6 #xb7 ; #xb0-#xb7 + nil #xb9 #xba #xbb nil nil nil #xbf ; #xb8-0xbf + #xc0 #xc1 #xc2 #xc3 #xc4 #xc5 #xc6 #xc7 ; #xc0-#xc7 + #xc8 #xc9 #xca #xcb #xcc #xcd #xce #xcf ; #xc8-#xcf + #xd0 #xd1 #xd2 #xd3 #xd4 #xd5 #xd6 #xd7 ; #xd0-#xd7 + #xd8 #xd9 #xda #xdb #xdc #xdd #xde #xdf ; #xd8-#xdf + #xe0 #xe1 #xe2 #xe3 #xe4 #xe5 #xe6 #xe7 ; #xe0-#xe7 + #xe8 #xe9 #xea #xeb #xec #xed #xee #xef ; #xe8-#xef + #xf0 #xf1 #xf2 #xf3 #xf4 #xf5 #xf6 #xf7 ; #xf0-#xf7 + #xf8 #xf9 #xfa #xfb #xfc #xfd #xfe #xff ; #xf8-#xff + )) + +(defstatic *unicode-150-180-to-iso-8859-15* + #( + nil nil #xbc #xbd nil nil nil nil ; #x150-#x157 + nil nil nil nil nil nil nil nil ; #x158-#x15f + #xa6 #xa8 nil nil nil nil nil nil ; #x160-#x167 + nil nil nil nil nil nil nil nil ; #x168-#x16f + nil nil nil nil nil nil nil nil ; #x170-#x177 + #xbe nil nil nil nil #xb4 #xb8 nil ; #x178-#x17f + )) + +(define-character-encoding :iso-8859-15 + "An 8-bit, fixed-width character encoding in which codes #x00-#x9f +map to their Unicode equivalents and other codes map to other Unicode +character values. Intended to provide most characters found in Western +European languages (including the Euro sign and some other characters +missing from ISO-8859-1." + :aliases '(:iso_8859-15 :latin9) + :stream-encode-function + (nfunction + iso-8859-15-stream-encode + (lambda (char write-function stream) + (let* ((code (char-code char)) + (c2 (cond ((< code #xa0) code) + ((< code #x100) + (svref *unicode-a0-100-to-iso-8859-15* + (the fixnum (- code #xa0)))) + ((and (>= code #x150) (< code #x180)) + (svref *unicode-150-180-to-iso-8859-15* + (the fixnum (- code #x150)))) + ((= code #x20ac) #xa4)))) + (declare (type (mod #x110000) code)) + (funcall write-function stream (or c2 (char-code #\Sub))) + 1))) + :stream-decode-function + (nfunction + iso-8859-15-stream-decode + (lambda (1st-unit next-unit-function stream) + (declare (ignore next-unit-function stream) + (type (unsigned-byte 8) 1st-unit)) + (if (< 1st-unit #xa0) + (code-char 1st-unit) + (svref *iso-8859-15-to-unicode* (the fixnum (- 1st-unit #xa0)))))) + :vector-encode-function + (nfunction + iso-8859-15-vector-encode + (lambda (string vector idx start end) + (declare (type (simple-array (unsigned-byte 8) (*)) vector) + (fixnum idx)) + (do* ((i start (1+ i))) + ((>= i end) idx) + (let* ((char (schar string i)) + (code (char-code char)) + (c2 (cond ((< code #xa0) code) + ((< code #x100) + (svref *unicode-a0-100-to-iso-8859-15* + (the fixnum (- code #xa0)))) + ((and (>= code #x150) (< code #x180)) + (svref *unicode-150-180-to-iso-8859-15* + (the fixnum (- code #x150)))) + ((= code #x20ac) #xa4)))) + (declare (type (mod #x110000) code)) + (setf (aref vector idx) (or c2 (char-code #\Sub))) + (incf idx))))) + :vector-decode-function + (nfunction + iso-8859-15-vector-decode + (lambda (vector idx noctets string) + (declare (type (simple-array (unsigned-byte 8) (*)) vector)) + (do* ((i 0 (1+ i)) + (index idx (1+ index))) + ((>= i noctets) index) + (let* ((1st-unit (aref vector index))) + (declare (type (unsigned-byte 8) 1st-unit)) + (setf (schar string i) + (if (< 1st-unit #xa0) + (code-char 1st-unit) + (svref *iso-8859-15-to-unicode* (the fixnum (- 1st-unit #xa0))))))))) + :memory-encode-function + (nfunction + iso-8859-15-memory-encode + (lambda (string pointer idx start end) + (do* ((i start (1+ i))) + ((>= i end) idx) + (let* ((code (char-code (schar string i))) + (c2 (cond ((< code #xa0) code) + ((< code #x100) + (svref *unicode-a0-100-to-iso-8859-15* + (the fixnum (- code #xa0)))) + ((and (>= code #x150) (< code #x180)) + (svref *unicode-150-180-to-iso-8859-15* + (the fixnum (- code #x150)))) + ((= code #x20ac) #xa4)))) + (declare (type (mod #x110000) code)) + (setf (%get-unsigned-byte pointer idx) (or c2 (char-code #\Sub))) + (incf idx))))) + :memory-decode-function + (nfunction + iso-8859-15-memory-decode + (lambda (pointer noctets idx string) + (do* ((i 0 (1+ i)) + (index idx (1+ index))) + ((>= i noctets) index) + (let* ((1st-unit (%get-unsigned-byte pointer index))) + (declare (type (unsigned-byte 8) 1st-unit)) + (setf (schar string i) + (if (< 1st-unit #xa0) + (code-char 1st-unit) + (svref *iso-8859-15-to-unicode* (the fixnum (- 1st-unit #xa0))))))))) + :octets-in-string-function + #'8-bit-fixed-width-octets-in-string + :length-of-vector-encoding-function + #'8-bit-fixed-width-length-of-vector-encoding + :length-of-memory-encoding-function + #'8-bit-fixed-width-length-of-memory-encoding + :decode-literal-code-unit-limit #xa0 + :encode-literal-char-code-limit #xa0 + ) + +(defstatic *iso-8859-16-to-unicode* + #( + ;; #xa0 + #\u+00a0 #\u+0104 #\u+0105 #\u+0141 #\u+20ac #\u+201e #\u+0160 #\u+00a7 + #\u+0161 #\u+00a9 #\u+0218 #\u+00ab #\u+0179 #\u+00ad #\u+017a #\u+017b + ;; #xb0 + #\u+00b0 #\u+00b1 #\u+010c #\u+0142 #\u+017d #\u+201d #\u+00b6 #\u+00b7 + #\u+017e #\u+010d #\u+0219 #\u+00bb #\u+0152 #\u+0153 #\u+0178 #\u+017c + ;; #xc0 + #\u+00c0 #\u+00c1 #\u+00c2 #\u+0102 #\u+00c4 #\u+0106 #\u+00c6 #\u+00c7 + #\u+00c8 #\u+00c9 #\u+00ca #\u+00cb #\u+00cc #\u+00cd #\u+00ce #\u+00cf + ;; #xd0 + #\u+0110 #\u+0143 #\u+00d2 #\u+00d3 #\u+00d4 #\u+0150 #\u+00d6 #\u+015a + #\u+0170 #\u+00d9 #\u+00da #\u+00db #\u+00dc #\u+0118 #\u+021a #\u+00df + ;; #xe0 + #\u+00e0 #\u+00e1 #\u+00e2 #\u+0103 #\u+00e4 #\u+0107 #\u+00e6 #\u+00e7 + #\u+00e8 #\u+00e9 #\u+00ea #\u+00eb #\u+00ec #\u+00ed #\u+00ee #\u+00ef + ;; #xf0 + #\u+0111 #\u+0144 #\u+00f2 #\u+00f3 #\u+00f4 #\u+0151 #\u+00f6 #\u+015b + #\u+0171 #\u+00f9 #\u+00fa #\u+00fb #\u+00fc #\u+0119 #\u+021b #\u+00ff + )) + +(defstatic *unicode-a0-180-to-iso-8859-16* + #( + #xa0 nil nil nil nil nil nil #xa7 ; #xa0-#xa7 + nil #xa9 nil #xab nil #xad nil nil ; #xa8-#xaf + #xb0 #xb1 nil nil nil nil #xb6 #xb7 ; #xb0-#xb7 + nil nil nil #xbb nil nil nil nil ; #xb8-#xbf + #xc0 #xc1 #xc2 nil #xc4 nil #xc6 #xc7 ; #xc0-#xc7 + #xc8 #xc9 #xca #xcb #xcc #xcd #xce #xcf ; #xc8-#xcf + nil nil #xd2 #xd3 #xd4 nil #xd6 nil ; #xd0-#xd7 + nil #xd9 #xda #xdb #xdc nil nil #xdf ; #xd8-#xdf + #xe0 #xe1 #xe2 nil #xe4 nil #xe6 #xe7 ; #xe0-#xe7 + #xe8 #xe9 #xea #xeb #xec #xed #xee #xef ; #xe8-#xef + nil nil #xf2 #xf3 #xf4 nil #xf6 nil ; #xf0-#xf7 + nil #xf9 #xfa #xfb #xfc nil nil #xff ; #xf8-#xff + nil nil #xc3 #xe3 #xa1 #xa2 #xc5 #xe5 ; #x100-#x107 + nil nil nil nil #xb2 #xb9 nil nil ; #x108-#x10f + #xd0 #xf0 nil nil nil nil nil nil ; #x110-#x117 + #xdd #xfd nil nil nil nil nil nil ; #x118-#x11f + nil nil nil nil nil nil nil nil ; #x120-#x127 + nil nil nil nil nil nil nil nil ; #x128-#x12f + nil nil nil nil nil nil nil nil ; #x130-#x137 + nil nil nil nil nil nil nil nil ; #x138-#x13f + nil #xa3 #xb3 #xd1 #xf1 nil nil nil ; #x140-#x147 + nil nil nil nil nil nil nil nil ; #x148-#x14f + #xd5 #xf5 #xbc #xbd nil nil nil nil ; #x150-#x157 + nil nil #xd7 #xf7 nil nil nil nil ; #x158-#x15f + #xa6 #xa8 nil nil nil nil nil nil ; #x160-#x167 + nil nil nil nil nil nil nil nil ; #x168-#x16f + #xd8 #xf8 nil nil nil nil nil nil ; #x170-#x177 + #xbe #xac #xae #xaf #xbf #xb4 #xb8 nil ; #x178-#x17f + )) + +(defstatic *unicode-218-220-to-iso-8859-16* + #( + #xaa #xba #xde #xfe nil nil nil nil ; #x218-#x21f + )) + +(defstatic *unicode-2018-2020-to-iso-8859-16* + #( + nil nil nil nil nil #xb5 #xa5 nil ; #x2018-#x201f + )) + + +(define-character-encoding :iso-8859-16 + "An 8-bit, fixed-width character encoding in which codes #x00-#x9f +map to their Unicode equivalents and other codes map to other Unicode +character values. Intended to provide most characters found in Southeast +European languages." + :aliases '(:iso_8859-16 :latin10 :l1 :iso-ir-226) + :stream-encode-function + (nfunction + iso-8859-16-stream-encode + (lambda (char write-function stream) + (let* ((code (char-code char)) + (c2 (cond ((< code #xa0) code) + ((< code #x180) + (svref *unicode-a0-180-to-iso-8859-16* + (the fixnum (- code #xa0)))) + ((and (>= code #x218) (< code #x220)) + (svref *unicode-218-220-to-iso-8859-16* + (the fixnum (- code #x218)))) + ((and (>= code #x2018) (< code #x2020)) + (svref *unicode-2018-2020-to-iso-8859-16* + (the fixnum (- code #x2018)))) + ((= code #x20ac) #xa4)))) + (declare (type (mod #x110000) code)) + (funcall write-function stream (or c2 (char-code #\Sub))) + 1))) + :stream-decode-function + (nfunction + iso-8859-16-stream-decode + (lambda (1st-unit next-unit-function stream) + (declare (ignore next-unit-function stream) + (type (unsigned-byte 8) 1st-unit)) + (if (< 1st-unit #xa0) + (code-char 1st-unit) + (svref *iso-8859-16-to-unicode* (the fixnum (- 1st-unit #xa0)))))) + :vector-encode-function + (nfunction + iso-8859-16-vector-encode + (lambda (string vector idx start end) + (declare (type (simple-array (unsigned-byte 8) (*)) vector) + (fixnum idx)) + (do* ((i start (1+ i))) + ((>= i end) idx) + (let* ((char (schar string i)) + (code (char-code char)) + (c2 (cond ((< code #xa0) code) + ((< code #x180) + (svref *unicode-a0-180-to-iso-8859-16* + (the fixnum (- code #xa0)))) + ((and (>= code #x218) (< code #x220)) + (svref *unicode-218-220-to-iso-8859-16* + (the fixnum (- code #x218)))) + ((and (>= code #x2018) (< code #x2020)) + (svref *unicode-2018-2020-to-iso-8859-16* + (the fixnum (- code #x2018)))) + ((= code #x20ac) #xa4)))) + (declare (type (mod #x110000) code)) + (setf (aref vector idx) (or c2 (char-code #\Sub))) + (incf idx))))) + :vector-decode-function + (nfunction + iso-8859-16-vector-decode + (lambda (vector idx noctets string) + (declare (type (simple-array (unsigned-byte 8) (*)) vector)) + (do* ((i 0 (1+ i)) + (index idx (1+ index))) + ((>= i noctets) index) + (let* ((1st-unit (aref vector index))) + (declare (type (unsigned-byte 8) 1st-unit)) + (setf (schar string i) + (if (< 1st-unit #xa0) + (code-char 1st-unit) + (svref *iso-8859-16-to-unicode* (the fixnum (- 1st-unit #xa0))))))))) + :memory-encode-function + (nfunction + iso-8859-16-memory-encode + (lambda (string pointer idx start end) + (do* ((i start (1+ i))) + ((>= i end) idx) + (let* ((code (char-code (schar string i))) + (c2 (cond ((< code #xa0) code) + ((< code #x180) + (svref *unicode-a0-180-to-iso-8859-16* + (the fixnum (- code #xa0)))) + ((and (>= code #x218) (< code #x220)) + (svref *unicode-218-220-to-iso-8859-16* + (the fixnum (- code #x218)))) + ((and (>= code #x2018) (< code #x2020)) + (svref *unicode-2018-2020-to-iso-8859-16* + (the fixnum (- code #x2018)))) + ((= code #x20ac) #xa4)))) + (declare (type (mod #x110000) code)) + (setf (%get-unsigned-byte pointer idx) (or c2 (char-code #\Sub))) + (incf idx))))) + :memory-decode-function + (nfunction + iso-8859-16-memory-decode + (lambda (pointer noctets idx string) + (do* ((i 0 (1+ i)) + (index idx (1+ index))) + ((>= i noctets) index) + (let* ((1st-unit (%get-unsigned-byte pointer index))) + (declare (type (unsigned-byte 8) 1st-unit)) + (setf (schar string i) + (if (< 1st-unit #xa0) + (code-char 1st-unit) + (svref *iso-8859-16-to-unicode* (the fixnum (- 1st-unit #xa0))))))))) + :octets-in-string-function + #'8-bit-fixed-width-octets-in-string + :length-of-vector-encoding-function + #'8-bit-fixed-width-length-of-vector-encoding + :length-of-memory-encoding-function + #'8-bit-fixed-width-length-of-memory-encoding + :decode-literal-code-unit-limit #xa0 + :encode-literal-char-code-limit #xa0 + ) + +(defstatic *macintosh-to-unicode* + #( + ;; #x80 + #\u+00c4 #\u+00c5 #\u+00c7 #\u+00c9 #\u+00d1 #\u+00d6 #\u+00dc #\u+00e1 + #\u+00e0 #\u+00e2 #\u+00e4 #\u+00e3 #\u+00e5 #\u+00e7 #\u+00e9 #\u+00e8 + ;; #x90 + #\u+00ea #\u+00eb #\u+00ed #\u+00ec #\u+00ee #\u+00ef #\u+00f1 #\u+00f3 + #\u+00f2 #\u+00f4 #\u+00f6 #\u+00f5 #\u+00fa #\u+00f9 #\u+00fb #\u+00fc + ;; #xa0 + #\u+2020 #\u+00b0 #\u+00a2 #\u+00a3 #\u+00a7 #\u+2022 #\u+00b6 #\u+00df + #\u+00ae #\u+00a9 #\u+2122 #\u+00b4 #\u+00a8 #\u+2260 #\u+00c6 #\u+00d8 + ;; #xb0 + #\u+221e #\u+00b1 #\u+2264 #\u+2265 #\u+00a5 #\u+00b5 #\u+2202 #\u+2211 + #\u+220f #\u+03c0 #\u+222b #\u+00aa #\u+00ba #\u+2126 #\u+00e6 #\u+00f8 + ;; #xc0 + #\u+00bf #\u+00a1 #\u+00ac #\u+221a #\u+0192 #\u+2248 #\u+2206 #\u+00ab + #\u+00bb #\u+2026 #\u+00a0 #\u+00c0 #\u+00c3 #\u+00d5 #\u+0152 #\u+0153 + ;; #xd0 + #\u+2013 #\u+2014 #\u+201c #\u+201d #\u+2018 #\u+2019 #\u+00f7 #\u+25ca + #\u+00ff #\u+0178 #\u+2044 #\u+00a4 #\u+2039 #\u+203a #\u+fb01 #\u+fb02 + ;; #xe0 + #\u+2021 #\u+00b7 #\u+201a #\u+201e #\u+2030 #\u+00c2 #\u+00ca #\u+00c1 + #\u+00cb #\u+00c8 #\u+00cd #\u+00ce #\u+00cf #\u+00cc #\u+00d3 #\u+00d4 + ;; #xf0 + #\u+f8ff #\u+00d2 #\u+00da #\u+00db #\u+00d9 #\u+0131 #\u+02c6 #\u+02dc + #\u+00af #\u+02d8 #\u+02d9 #\u+02da #\u+00b8 #\u+02dd #\u+02db #\u+02c7 + )) + + +(defstatic *unicode-a0-100-to-macintosh* + #( + #xca #xc1 #xa2 #xa3 #xdb #xb4 nil #xa4 ; #xa0-#xa7 + #xac #xa9 #xbb #xc7 #xc2 nil #xa8 #xf8 ; #xa8-#xaf + #xa1 #xb1 nil nil #xab #xb5 #xa6 #xe1 ; #xb0-#xb7 + #xfc nil #xbc #xc8 nil nil nil #xc0 ; #xb8-#xbf + #xcb #xe7 #xe5 #xcc #x80 #x81 #xae #x82 ; #xc0-#xc7 + #xe9 #x83 #xe6 #xe8 #xed #xea #xeb #xec ; #xc8-#xcf + nil #x84 #xf1 #xee #xef #xcd #x85 nil ; #xd0-#xd7 + #xaf #xf4 #xf2 #xf3 #x86 nil nil #xa7 ; #xd8-#xdf + #x88 #x87 #x89 #x8b #x8a #x8c #xbe #x8d ; #xe0-#xe7 + #x8f #x8e #x90 #x91 #x93 #x92 #x94 #x95 ; #xe8-#xef + nil #x96 #x98 #x97 #x99 #x9b #x9a #xd6 ; #xf0-#xf7 + #xbf #x9d #x9c #x9e #x9f nil nil #xd8 ; #xf8-#xff + )) + +(defstatic *unicode-130-198-to-macintosh* + #( + nil #xf5 nil nil nil nil nil nil ; #x130-#x137 + nil nil nil nil nil nil nil nil ; #x138-#x13f + nil nil nil nil nil nil nil nil ; #x140-#x147 + nil nil nil nil nil nil nil nil ; #x148-#x14f + nil nil #xce #xcf nil nil nil nil ; #x150-#x157 + nil nil nil nil nil nil nil nil ; #x158-#x15f + nil nil nil nil nil nil nil nil ; #x160-#x167 + nil nil nil nil nil nil nil nil ; #x168-#x16f + nil nil nil nil nil nil nil nil ; #x170-#x177 + #xd9 nil nil nil nil nil nil nil ; #x178-#x17f + nil nil nil nil nil nil nil nil ; #x180-#x187 + nil nil nil nil nil nil nil nil ; #x188-#x18f + nil nil #xc4 nil nil nil nil nil ; #x190-#x197 + )) + +(defstatic *unicode-2c0-2e0-to-macintosh* + #( + nil nil nil nil nil nil #xf6 #xff ; #x2c0-#x2c7 + nil nil nil nil nil nil nil nil ; #x2c8-#x2cf + nil nil nil nil nil nil nil nil ; #x2d0-#x2d7 + #xf9 #xfa #xfb #xfe #xf7 #xfd nil nil ; #x2d8-#x2df + )) + +(defstatic *unicode-2010-2048-to-macintosh* + #( + nil nil nil #xd0 #xd1 nil nil nil ; #x2010-#x2017 + #xd4 #xd5 #xe2 nil #xd2 #xd3 #xe3 nil ; #x2018-#x201f + #xa0 #xe0 #xa5 nil nil nil #xc9 nil ; #x2020-#x2027 + nil nil nil nil nil nil nil nil ; #x2028-#x202f + #xe4 nil nil nil nil nil nil nil ; #x2030-#x2037 + nil #xdc #xdd nil nil nil nil nil ; #x2038-#x203f + nil nil nil nil #xda nil nil nil ; #x2040-#x2047 + )) + +(defstatic *unicode-2120-2128-to-macintosh* + #( + nil nil #xaa nil nil nil #xbd nil ; #x2120-#x2127 + )) + +(defstatic *unicode-2200-2268-to-macintosh* + #( + nil nil #xb6 nil nil nil #xc6 nil ; #x2200-#x2207 + nil nil nil nil nil nil nil #xb8 ; #x2208-#x220f + nil #xb7 nil nil nil nil nil nil ; #x2210-#x2217 + nil nil #xc3 nil nil nil #xb0 nil ; #x2218-#x221f + nil nil nil nil nil nil nil nil ; #x2220-#x2227 + nil nil nil #xba nil nil nil nil ; #x2228-#x222f + nil nil nil nil nil nil nil nil ; #x2230-#x2237 + nil nil nil nil nil nil nil nil ; #x2238-#x223f + nil nil nil nil nil nil nil nil ; #x2240-#x2247 + #xc5 nil nil nil nil nil nil nil ; #x2248-#x224f + nil nil nil nil nil nil nil nil ; #x2250-#x2257 + nil nil nil nil nil nil nil nil ; #x2258-#x225f + #xad nil nil nil #xb2 #xb3 nil nil ; #x2260-#x2267 + )) + +(defstatic *unicode-fb00-fb08-to-macintosh* + #( + nil #xde #xdf nil nil nil nil nil ; #xfb00-#xfb07 + )) + +(define-character-encoding :macintosh + "An 8-bit, fixed-width character encoding in which codes #x00-#x7f +map to their Unicode equivalents and other codes map to other Unicode +character values. Traditionally used on Classic MacOS to encode characters +used in western languages." + :aliases '(:macos-roman :macosroman :mac-roman :macroman) + + :stream-encode-function + (nfunction + macintosh-stream-encode + (lambda (char write-function stream) + (let* ((code (char-code char)) + (c2 (cond ((< code #x80) code) + ((and (>= code #xa0) (< code #x100) + (svref *unicode-a0-100-to-macintosh* + (the fixnum (- code #xa0))))) + ((and (>= code #x130) (< code #x198)) + (svref *unicode-130-198-to-macintosh* + (the fixnum (- code #x130)))) + ((and (>= code #x2c0) (< code #x2e0)) + (svref *unicode-2c0-2e0-to-macintosh* + (the fixnum (- code #x2c0)))) + ((= code #x3c0) #xb9) + ((and (>= code #x2010) (< code #x2048)) + (svref *unicode-2010-2048-to-macintosh* + (the fixnum (- code #x2010)))) + ((and (>= code #x2120) (< code #x2128)) + (svref *unicode-2120-2128-to-macintosh* + (the fixnum (- code #x2120)))) + ((and (>= code #x2200) (< code #x2268)) + (svref *unicode-2200-2268-to-macintosh* + (the fixnum (- code #x2200)))) + ((= code #x25ca) #xd7) + ((and (>= code #xfb00) (< code #xfb08)) + (svref *unicode-fb00-fb08-to-macintosh* + (the fixnum (- code #xfb00)))) + ((= code #xf8ff) #xf0)))) + (declare (type (mod #x110000) code)) + (funcall write-function stream (or c2 (char-code #\Sub))) + 1))) + :stream-decode-function + (nfunction + macintosh-stream-decode + (lambda (1st-unit next-unit-function stream) + (declare (ignore next-unit-function stream) + (type (unsigned-byte 8) 1st-unit)) + (if (< 1st-unit #x80) + (code-char 1st-unit) + (svref *macintosh-to-unicode* (the fixnum (- 1st-unit #x80)))))) + :vector-encode-function + (nfunction + macintosh-vector-encode + (lambda (string vector idx start end) + (declare (type (simple-array (unsigned-byte 8) (*)) vector) + (fixnum idx)) + (do* ((i start (1+ i))) + ((>= i end) idx) + (let* ((char (schar string i)) + (code (char-code char)) + (c2 (cond ((< code #x80) code) + ((and (>= code #xa0) (< code #x100) + (svref *unicode-a0-100-to-macintosh* + (the fixnum (- code #xa0))))) + ((and (>= code #x130) (< code #x198)) + (svref *unicode-130-198-to-macintosh* + (the fixnum (- code #x130)))) + ((and (>= code #x2c0) (< code #x2e0)) + (svref *unicode-2c0-2e0-to-macintosh* + (the fixnum (- code #x2c0)))) + ((= code #x3c0) #xb9) + ((and (>= code #x2010) (< code #x2048)) + (svref *unicode-2010-2048-to-macintosh* + (the fixnum (- code #x2010)))) + ((and (>= code #x2120) (< code #x2128)) + (svref *unicode-2120-2128-to-macintosh* + (the fixnum (- code #x2120)))) + ((and (>= code #x2200) (< code #x2268)) + (svref *unicode-2200-2268-to-macintosh* + (the fixnum (- code #x2200)))) + ((= code #x25ca) #xd7) + ((and (>= code #xfb00) (< code #xfb08)) + (svref *unicode-fb00-fb08-to-macintosh* + (the fixnum (- code #xfb00)))) + ((= code #xf8ff) #xf0)))) + (declare (type (mod #x110000) code)) + (setf (aref vector idx) (or c2 (char-code #\Sub))) + (incf idx))))) + :vector-decode-function + (nfunction + macintosh-vector-decode + (lambda (vector idx noctets string) + (declare (type (simple-array (unsigned-byte 8) (*)) vector)) + (do* ((i 0 (1+ i)) + (index idx (1+ index))) + ((>= i noctets) index) + (let* ((1st-unit (aref vector index))) + (declare (type (unsigned-byte 8) 1st-unit)) + (setf (schar string i) + (if (< 1st-unit #x80) + (code-char 1st-unit) + (svref *macintosh-to-unicode* (the fixnum (- 1st-unit #x80))))))))) + :memory-encode-function + (nfunction + macintosh-memory-encode + (lambda (string pointer idx start end) + (do* ((i start (1+ i))) + ((>= i end) idx) + (let* ((code (char-code (schar string i))) + (c2 (cond ((< code #x80) code) + ((and (>= code #xa0) (< code #x100) + (svref *unicode-a0-100-to-macintosh* + (the fixnum (- code #xa0))))) + ((and (>= code #x130) (< code #x198)) + (svref *unicode-130-198-to-macintosh* + (the fixnum (- code #x130)))) + ((and (>= code #x2c0) (< code #x2e0)) + (svref *unicode-2c0-2e0-to-macintosh* + (the fixnum (- code #x2c0)))) + ((= code #x3c0) #xb9) + ((and (>= code #x2010) (< code #x2048)) + (svref *unicode-2010-2048-to-macintosh* + (the fixnum (- code #x2010)))) + ((and (>= code #x2120) (< code #x2128)) + (svref *unicode-2120-2128-to-macintosh* + (the fixnum (- code #x2120)))) + ((and (>= code #x2200) (< code #x2268)) + (svref *unicode-2200-2268-to-macintosh* + (the fixnum (- code #x2200)))) + ((= code #x25ca) #xd7) + ((and (>= code #xfb00) (< code #xfb08)) + (svref *unicode-fb00-fb08-to-macintosh* + (the fixnum (- code #xfb00)))) + ((= code #xf8ff) #xf0)))) + (declare (type (mod #x110000) code)) + (setf (%get-unsigned-byte pointer idx) (or c2 (char-code #\Sub))) + (incf idx))))) + :memory-decode-function + (nfunction + macintosh-memory-decode + (lambda (pointer noctets idx string) + (do* ((i 0 (1+ i)) + (index idx (1+ index))) + ((>= i noctets) index) + (let* ((1st-unit (%get-unsigned-byte pointer index))) + (declare (type (unsigned-byte 8) 1st-unit)) + (setf (schar string i) + (if (< 1st-unit #x80) + (code-char 1st-unit) + (svref *macintosh-to-unicode* (the fixnum (- 1st-unit #xa0))))))))) + :octets-in-string-function + #'8-bit-fixed-width-octets-in-string + :length-of-vector-encoding-function + #'8-bit-fixed-width-length-of-vector-encoding + :length-of-memory-encoding-function + #'8-bit-fixed-width-length-of-memory-encoding + :decode-literal-code-unit-limit #x80 + :encode-literal-char-code-limit #x80 + ) + + +;;; UTF-8. Decoding checks for malformed sequences; it might be faster (and +;;; would certainly be simpler) if it didn't. +(define-character-encoding :utf-8 + "An 8-bit, variable-length character encoding in which characters +with CHAR-CODEs in the range #x00-#x7f can be encoded in a single +octet; characters with larger code values can be encoded in 2 to 4 +bytes." + :max-units-per-char 4 + :stream-encode-function + (nfunction + utf-8-stream-encode + (lambda (char write-function stream) + (let* ((code (char-code char))) + (declare (type (mod #x110000) code)) + (cond ((< code #x80) + (funcall write-function stream code) + 1) + ((< code #x800) + (let* ((y (ldb (byte 5 6) code)) + (z (ldb (byte 6 0) code))) + (declare (fixnum y z)) + (funcall write-function stream (logior #xc0 y)) + (funcall write-function stream (logior #x80 z)) + 2)) + ((< code #x10000) + (let* ((x (ldb (byte 4 12) code)) + (y (ldb (byte 6 6) code)) + (z (ldb (byte 6 0) code))) + (declare (fixnum x y z)) + (funcall write-function stream (logior #xe0 x)) + (funcall write-function stream (logior #x80 y)) + (funcall write-function stream (logior #x80 z)) + 3)) + (t + (let* ((w (ldb (byte 3 18) code)) + (x (ldb (byte 6 12) code)) + (y (ldb (byte 6 6) code)) + (z (ldb (byte 6 0) code))) + (declare (fixnum w x y z)) + (funcall write-function stream (logior #xf0 w)) + (funcall write-function stream (logior #x80 x)) + (funcall write-function stream (logior #x80 y)) + (funcall write-function stream (logior #x80 z)) + 4)))))) + :stream-decode-function + (nfunction + utf-8-stream-decode + (lambda (1st-unit next-unit-function stream) + (declare (type (unsigned-byte 8) 1st-unit)) + (if (< 1st-unit #x80) + (code-char 1st-unit) + (if (>= 1st-unit #xc2) + (let* ((s1 (funcall next-unit-function stream))) + (if (eq s1 :eof) + s1 + (locally + (declare (type (unsigned-byte 8) s1)) + (if (< 1st-unit #xe0) + (if (< (the fixnum (logxor s1 #x80)) #x40) + (code-char + (logior + (the fixnum (ash (the fixnum (logand #x1f 1st-unit)) 6)) + (the fixnum (logxor s1 #x80)))) + #\Replacement_Character) + (let* ((s2 (funcall next-unit-function stream))) + (if (eq s2 :eof) + s2 + (locally + (declare (type (unsigned-byte 8) s2)) + (if (< 1st-unit #xf0) + (if (and (< (the fixnum (logxor s1 #x80)) #x40) + (< (the fixnum (logxor s2 #x80)) #x40) + (or (>= 1st-unit #xe1) + (>= s1 #xa0))) + (or (code-char (the fixnum + (logior (the fixnum + (ash (the fixnum (logand 1st-unit #xf)) + 12)) + (the fixnum + (logior + (the fixnum + (ash (the fixnum (logand s1 #x3f)) + 6)) + (the fixnum (logand s2 #x3f))))))) + #\Replacement_Character) + #\Replacement_Character) + (if (< 1st-unit #xf8) + (let* ((s3 (funcall next-unit-function stream))) + (if (eq s3 :eof) + s3 + (locally + (declare (type (unsigned-byte 8) s3)) + (if (and (< (the fixnum (logxor s1 #x80)) #x40) + (< (the fixnum (logxor s2 #x80)) #x40) + (< (the fixnum (logxor s3 #x80)) #x40) + (or (>= 1st-unit #xf1) + (>= s1 #x90))) + (code-char + (logior + (the fixnum + (logior + (the fixnum + (ash (the fixnum (logand 1st-unit 7)) 18)) + (the fixnum + (ash (the fixnum (logxor s1 #x80)) 12)))) + (the fixnum + (logior + (the fixnum + (ash (the fixnum (logxor s2 #x80)) 6)) + (the fixnum (logxor s3 #x80)))))) + #\Replacement_Character)))) + #\Replacement_Character))))))))) + #\Replacement_Character)))) + :vector-encode-function + (nfunction + utf-8-vector-encode + (lambda (string vector idx start end) + (declare (type (simple-array (unsigned-byte 8) (*)) vector) + (fixnum idx)) + (do* ((i start (1+ i))) + ((>= i end) idx) + (let* ((char (schar string i)) + (code (char-code char))) + (declare (type (mod #x110000) code)) + (cond ((< code #x80) + (setf (aref vector idx) code) + (incf idx)) + ((< code #x800) + (setf (aref vector idx) + (logior #xc0 (the fixnum (ash code -6)))) + (setf (aref vector (the fixnum (1+ idx))) + (logior #x80 (the fixnum (logand code #x3f)))) + (incf idx 2)) + ((< code #x10000) + (setf (aref vector idx) + (logior #xe0 (the fixnum (ash code -12)))) + (setf (aref vector (the fixnum (1+ idx))) + (logior #x80 (the fixnum (logand #x3f (the fixnum (ash code -6)))))) + (setf (aref vector (the fixnum (+ idx 2))) + (logior #x80 (the fixnum (logand code #x3f)))) + (incf idx 3)) + (t + (setf (aref vector idx) + (logior #xf0 + (the fixnum (logand #x7 (the fixnum (ash code -18)))))) + (setf (aref vector (the fixnum (1+ idx))) + (logior #x80 (the fixnum (logand #x3f (the fixnum (ash code -12)))))) + (setf (aref vector (the fixnum (+ idx 2))) + (logior #x80 (the fixnum (logand #x3f (the fixnum (ash code -6)))))) + (setf (aref vector (the fixnum (+ idx 3))) + (logior #x80 (logand #x3f code))) + (incf idx 4))))))) + :vector-decode-function + (nfunction + utf-8-vector-decode + (lambda (vector idx noctets string) + (declare (type (simple-array (unsigned-byte 8) (*)) vector) + (type index idx)) + (do* ((i 0 (1+ i)) + (end (+ idx noctets)) + (index idx (1+ index))) + ((= index end) index) + (let* ((1st-unit (aref vector index))) + (declare (type (unsigned-byte 8) 1st-unit)) + (let* ((char + (if (< 1st-unit #x80) + (code-char 1st-unit) + (if (>= 1st-unit #xc2) + (let* ((2nd-unit (aref vector (incf index)))) + (declare (type (unsigned-byte 8) 2nd-unit)) + (if (< 1st-unit #xe0) + (if (< (the fixnum (logxor 2nd-unit #x80)) #x40) + (code-char + (logior + (the fixnum (ash (the fixnum (logand #x1f 1st-unit)) 6)) + (the fixnum (logxor 2nd-unit #x80))))) + (let* ((3rd-unit (aref vector (incf index)))) + (declare (type (unsigned-byte 8) 3rd-unit)) + (if (< 1st-unit #xf0) + (if (and (< (the fixnum (logxor 2nd-unit #x80)) #x40) + (< (the fixnum (logxor 3rd-unit #x80)) #x40) + (or (>= 1st-unit #xe1) + (>= 2nd-unit #xa0))) + (code-char (the fixnum + (logior (the fixnum + (ash (the fixnum (logand 1st-unit #xf)) + 12)) + (the fixnum + (logior + (the fixnum + (ash (the fixnum (logand 2nd-unit #x3f)) + 6)) + (the fixnum (logand 3rd-unit #x3f)))))))) + (let* ((4th-unit (aref vector (incf index)))) + (declare (type (unsigned-byte 8) 4th-unit)) + (if (and (< (the fixnum (logxor 2nd-unit #x80)) #x40) + (< (the fixnum (logxor 3rd-unit #x80)) #x40) + (< (the fixnum (logxor 4th-unit #x80)) #x40) + (or (>= 1st-unit #xf1) + (>= 2nd-unit #x90))) + (code-char + (logior + (the fixnum + (logior + (the fixnum + (ash (the fixnum (logand 1st-unit 7)) 18)) + (the fixnum + (ash (the fixnum (logxor 2nd-unit #x80)) 12)))) + (the fixnum + (logior + (the fixnum + (ash (the fixnum (logxor 3rd-unit #x80)) 6)) + (the fixnum (logxor 4th-unit #x80)))))))))))))))) + (setf (schar string i) (or char #\Replacement_Character))))))) + :memory-encode-function + #'utf-8-memory-encode + :memory-decode-function + #'utf-8-memory-decode + :octets-in-string-function + #'utf-8-octets-in-string + :length-of-vector-encoding-function + (nfunction + utf-8-length-of-vector-encoding + (lambda (vector start end) + (declare (type (simple-array (unsigned-byte 8) (*)) vector)) + (do* ((i start) + (nchars 0)) + ((>= i end) + (values nchars i)) + (declare (fixnum i)) + (let* ((code (aref vector i)) + (nexti (+ i (cond ((< code #xc2) 1) + ((< code #xe0) 2) + ((< code #xf0) 3) + ((< code #xf8) 4) + (t 1))))) + (declare (type (unsigned-byte 8) code)) + (if (> nexti end) + (return (values nchars i)) + (setq nchars (1+ nchars) i nexti)))))) + :length-of-memory-encoding-function + #'utf-8-length-of-memory-encoding + :decode-literal-code-unit-limit #x80 + :encode-literal-char-code-limit #x80 + :bom-encoding #(#xef #xbb #xbf) + :character-size-in-octets-function (lambda (c) + (let* ((code (char-code c))) + (declare (type (mod #x110000) code)) + (if (< code #x80) + 1 + (if (< code #x800) + 2 + (if (< code #x10000) + 3 + 4))))) + + ) + + +;;; For a code-unit-size greater than 8: the stream-encode function's write-function +;;; accepts a code-unit in native byte order and swaps it if necessary and the +;;; stream-decode function receives a first-unit in native byte order and its +;;; next-unit-function returns a unit in native byte order. The memory/vector +;;; functions have to do their own byte swapping. + + +(defmacro utf-16-combine-surrogate-pairs (a b) + `(code-char + (the (unsigned-byte 21) + (+ #x10000 + (the (unsigned-byte 20) + (logior + (the (unsigned-byte 20) (ash (the (unsigned-byte 10) + (- ,a #xd800)) + 10)) + (the (unsigned-byte 10) (- ,b #xdc00)))))))) + +(defun utf-16-stream-encode (char write-function stream) + (let* ((code (char-code char)) + (highbits (- code #x10000))) + (declare (type (mod #x110000) code) + (fixnum highbits)) + (if (< highbits 0) + (progn + (funcall write-function stream code) + 1) + (progn + (funcall write-function stream (logior #xd800 (the fixnum (ash highbits -10)))) + (funcall write-function stream (logior #xdc00 (the fixnum (logand highbits #x3ff)))) + 2)))) + +(defun utf-16-stream-decode (1st-unit next-unit-function stream) + (declare (type (unsigned-byte 16) 1st-unit)) + (if (or (< 1st-unit #xd800) + (>= 1st-unit #xe000)) + (code-char 1st-unit) + (if (< 1st-unit #xdc00) + (let* ((2nd-unit (funcall next-unit-function stream))) + (if (eq 2nd-unit :eof) + 2nd-unit + (locally (declare (type (unsigned-byte 16) 2nd-unit)) + (if (and (>= 2nd-unit #xdc00) + (< 2nd-unit #xe000)) + (utf-16-combine-surrogate-pairs 1st-unit 2nd-unit) + #\Replacement_Character)))) + #\Replacement_Character))) + + + +(declaim (inline %big-endian-u8-ref-u16 %little-endian-u8-ref-u16)) +(defun %big-endian-u8-ref-u16 (u8-vector idx) + (declare (type (simple-array (unsigned-byte 8) (*)) u8-vector) + (fixnum idx)) + (logior (the (unsigned-byte 16) (ash (the (unsigned-byte 8) (aref u8-vector idx)) 8)) + (the (unsigned-byte 8) (aref u8-vector (the fixnum (1+ idx)))))) + +(defun %little-endian-u8-ref-u16 (u8-vector idx) + (declare (type (simple-array (unsigned-byte 8) (*)) u8-vector) + (fixnum idx)) + (logior (the (unsigned-byte 16) (ash (the (unsigned-byte 8) + (aref u8-vector (the fixnum (1+ idx)))) 8)) + (the (unsigned-byte 8) (aref u8-vector idx)))) + +#+big-endian-target +(progn +(defmacro %native-u8-ref-u16 (vector idx) + `(%big-endian-u8-ref-u16 ,vector ,idx)) + +(defmacro %reversed-u8-ref-u16 (vector idx) + `(%little-endian-u8-ref-u16 ,vector ,idx)) +) + +#+little-endian-target +(progn +(defmacro %native-u8-ref-u16 (vector idx) + `(%little-endian-u8-ref-u16 ,vector ,idx)) + +(defmacro %reversed-u8-ref-u16 (vector idx) + `(%big-endian-u8-ref-u16 ,vector ,idx)) +) + + +(declaim (inline (setf %big-endian-u8-ref-u16) (setf %little-endian-u8-ref-u16))) +(defun (setf %big-endian-u8-ref-u16) (val u8-vector idx) + (declare (type (unsigned-byte 16) val) + (type (simple-array (unsigned-byte 8) (*)) u8-vector) + (fixnum idx)) + (setf (aref u8-vector idx) (ldb (byte 8 8) val) + (aref u8-vector (the fixnum (1+ idx))) (ldb (byte 8 0) val)) + val) + +(defun (setf %little-endian-u8-ref-u16) (val u8-vector idx) + (declare (type (unsigned-byte 16) val) + (type (simple-array (unsigned-byte 8) (*)) u8-vector) + (fixnum idx)) + (setf (aref u8-vector idx) (ldb (byte 8 0) val) + (aref u8-vector (the fixnum (1+ idx))) (ldb (byte 8 8) val)) + val) + +(defun utf-16-character-size-in-octets (c) + (let* ((code (char-code c))) + (declare (type (mod #x110000) code)) + (if (< code #x10000) + 2 + 4))) + +;;; utf-16, native byte order. +(define-character-encoding #+big-endian-target :utf-16be #-big-endian-target :utf-16le + #+big-endian-target + "A 16-bit, variable-length encoding in which characters with +CHAR-CODEs less than #x10000 can be encoded in a single 16-bit +big-endian word and characters with larger codes can be encoded in a +pair of 16-bit big-endian words. The endianness of the encoded data +is implicit in the encoding; byte-order-mark characters are not +interpreted on input or prepended to output." + #+little-endian-target + "A 16-bit, variable-length encoding in which characters with +CHAR-CODEs less than #x10000 can be encoded in a single 16-bit +little-endian word and characters with larger codes can be encoded in +a pair of 16-bit little-endian words. The endianness of the encoded +data is implicit in the encoding; byte-order-mark characters are not +interpreted on input or prepended to output." + :max-units-per-char 2 + :code-unit-size 16 + :native-endianness t + :stream-encode-function + #'utf-16-stream-encode + :stream-decode-function + #'utf-16-stream-decode + :vector-encode-function + (nfunction + native-utf-16-vector-encode + (lambda (string vector idx start end) + (declare (type (simple-array (unsigned-byte 8) (*)) vector) + (fixnum idx start end)) + (do* ((i start (1+ i))) + ((>= i end) idx) + (declare (fixnum i)) + (let* ((char (schar string i)) + (code (char-code char)) + (highbits (- code #x10000))) + (declare (type (mod #x110000) code) + (fixnum highbits)) + (cond ((< highbits 0) + (setf (%native-u8-ref-u16 vector idx) code) + (incf idx 2)) + (t + (let* ((firstword (logior #xd800 (the fixnum (ash highbits -10)))) + (secondword (logior #xdc00 (the fixnum (logand highbits #x3ff))))) + (declare (type (unsigned-byte 16) firstword secondword)) + (setf (%native-u8-ref-u16 vector idx) firstword + (%native-u8-ref-u16 vector (the fixnum (+ idx 2))) secondword) + (incf idx 4)))))))) + :vector-decode-function + (nfunction + native-utf-16-vector-decode + (lambda (vector idx noctets string) + (declare (type (simple-array (unsigned-byte 8) (*)) vector) + (type index idx)) + (do* ((i 0 (1+ i)) + (end (+ idx noctets)) + (index idx)) + ((= index end) index) + (declare (fixnum i end index)) + (let* ((1st-unit (%native-u8-ref-u16 vector index))) + (declare (type (unsigned-byte 16) 1st-unit)) + (incf index 2) + (let* ((char + (if (or (< 1st-unit #xd800) + (>= 1st-unit #xe000)) + (code-char 1st-unit) + (if (< 1st-unit #xdc00) + (let* ((2nd-unit (%native-u8-ref-u16 vector index))) + (declare (type (unsigned-byte 16) 2nd-unit)) + (incf index 2) + (if (and (>= 2nd-unit #xdc00) + (< 2nd-unit #xe000)) + (utf-16-combine-surrogate-pairs 1st-unit 2nd-unit))))))) + (setf (schar string i) (or char #\Replacement_Character))))))) + :memory-encode-function + (nfunction + native-utf-16-memory-encode + (lambda (string pointer idx start end) + (declare (fixnum idx)) + (do* ((i start (1+ i))) + ((>= i end) idx) + (let* ((code (char-code (schar string i))) + (highbits (- code #x10000))) + (declare (type (mod #x110000) code) + (fixnum highbits)) + (cond ((< highbits 0) + (setf (%get-unsigned-word pointer idx) code) + (incf idx 2)) + (t + (setf (%get-unsigned-word pointer idx) (logior #xd800 (the fixnum (ash highbits -10)))) + (incf idx 2) + (setf (%get-unsigned-word pointer idx) (logior #xdc00 (the fixnum (logand highbits #x3ff)))) + (incf idx 2))))))) + :memory-decode-function + (nfunction + native-utf-16-memory-decode + (lambda (pointer noctets idx string) + (declare (fixnum noctets idx)) + (do* ((i 0 (1+ i)) + (end (+ idx noctets)) + (index idx)) + ((>= index end) index) + (declare (fixnum i index end)) + (let* ((1st-unit (%get-unsigned-word pointer index))) + (declare (type (unsigned-byte 16) 1st-unit)) + (incf index 2) + (let* ((char + (if (or (< 1st-unit #xd800) + (>= 1st-unit #xe000)) + (code-char 1st-unit) + (if (< 1st-unit #xdc00) + (let* ((2nd-unit (%get-unsigned-word pointer index))) + (declare (type (unsigned-byte 16) 2nd-unit)) + (incf index) + (if (and (>= 2nd-unit #xdc00) + (< 2nd-unit #xe000)) + (utf-16-combine-surrogate-pairs 1st-unit 2nd-unit))))))) + (setf (schar string i) (or char #\Replacement_Character))))))) + :octets-in-string-function + #'utf-16-octets-in-string + :length-of-vector-encoding-function + (nfunction + native-utf-16-length-of-vector-encoding + (lambda (vector start end) + (declare (type (simple-array (unsigned-byte 8) (*)) vector)) + (declare (fixnum start end)) + (do* ((i start) + (j (+ 2 i) (+ 2 i)) + (nchars 0)) + ((> j end) (values nchars i)) + (declare (fixnum i j nchars)) + (let* ((code (%native-u8-ref-u16 vector i)) + (nexti (+ i (if (or (< code #xd800) + (>= code #xdc00)) + 2 + 4)))) + (declare (type (unsigned-byte 16) code) + (fixnum nexti)) + (if (> nexti end) + (return (values nchars i)) + (setq i nexti nchars (1+ nchars))))))) + :length-of-memory-encoding-function + (nfunction + native-utf-16-length-of-memory-encoding + (lambda (pointer noctets start) + (do* ((i start) + (j (+ i 2) (+ i 2)) + (end (+ start noctets)) + (nchars 0)) + ((> j end) (values nchars i)) + (let* ((code (%get-unsigned-word pointer i)) + (nexti (+ i (if (or (< code #xd800) + (>= code #xdc00)) + 2 + 4)))) + (declare (type (unsigned-byte 16) code) + (fixnum nexti)) + (if (> nexti end) + (return (values nchars i)) + (setq i nexti nchars (1+ nchars))))))) + :decode-literal-code-unit-limit #xd800 + :encode-literal-char-code-limit #x10000 + :nul-encoding #(0 0) + :character-size-in-octets-function 'utf-16-character-size-in-octets + ) + +;;; utf-16, reversed byte order +(define-character-encoding #+big-endian-target :utf-16le #-big-endian-target :utf-16be + #+little-endian-target + "A 16-bit, variable-length encoding in which characters with +CHAR-CODEs less than #x10000 can be encoded in a single 16-bit +big-endian word and characters with larger codes can be encoded in a +pair of 16-bit big-endian words. The endianness of the encoded data +is implicit in the encoding; byte-order-mark characters are not +interpreted on input or prepended to output." + #+big-endian-target + "A 16-bit, variable-length encoding in which characters with +CHAR-CODEs less than #x10000 can be encoded in a single 16-bit +little-endian word and characters with larger codes can be encoded in +a pair of 16-bit little-endian words. The endianness of the encoded +data is implicit in the encoding; byte-order-mark characters are not +interpreted on input or prepended to output." + :max-units-per-char 2 + :code-unit-size 16 + :native-endianness nil + :stream-encode-function + #'utf-16-stream-encode + :stream-decode-function + #'utf-16-stream-decode + :vector-encode-function + (nfunction + reversed-utf-16-vector-encode + (lambda (string vector idx start end) + (declare (type (simple-array (unsigned-byte 8) (*)) vector) + (fixnum idx start end)) + (do* ((i start (1+ i))) + ((>= i end) idx) + (declare (fixnum i)) + (let* ((char (schar string i)) + (code (char-code char)) + (highbits (- code #x10000))) + (declare (type (mod #x110000) code) + (fixnum highbits)) + (cond ((< highbits 0) + (setf (%reversed-u8-ref-u16 vector idx) code) + (incf idx 2)) + (t + (let* ((firstword (logior #xd800 (the fixnum (ash highbits -10)))) + (secondword (logior #xdc00 (the fixnum (logand highbits #x3ff))))) + (declare (type (unsigned-byte 16) firstword secondword)) + (setf (%reversed-u8-ref-u16 vector idx) firstword + (%reversed-u8-ref-u16 vector (the fixnum (+ idx 2))) secondword) + (incf idx 4)))))))) + :vector-decode-function + (nfunction + reversed-utf-16-vector-decode + (lambda (vector idx noctets string) + (declare (type (simple-array (unsigned-byte 8) (*)) vector) + (type index idx)) + (do* ((i 0 (1+ i)) + (end (+ idx noctets)) + (index idx)) + ((= index end) index) + (declare (fixnum i end index)) + (let* ((1st-unit (%reversed-u8-ref-u16 vector index))) + (declare (type (unsigned-byte 16) 1st-unit)) + (incf index 2) + (let* ((char + (if (or (< 1st-unit #xd800) + (>= 1st-unit #xe000)) + (code-char 1st-unit) + (if (< 1st-unit #xdc00) + (let* ((2nd-unit (%reversed-u8-ref-u16 vector index))) + (declare (type (unsigned-byte 16) 2nd-unit)) + (incf index 2) + (if (and (>= 2nd-unit #xdc00) + (< 2nd-unit #xe000)) + (utf-16-combine-surrogate-pairs 1st-unit 2nd-unit))))))) + (setf (schar string i) (or char #\Replacement_Character))))))) + :memory-encode-function + (nfunction + reversed-utf-16-memory-encode + (lambda (string pointer idx start end) + (declare (fixnum idx)) + (do* ((i start (1+ i))) + ((>= i end) idx) + (let* ((code (char-code (schar string i))) + (highbits (- code #x10000))) + (declare (type (mod #x110000) code) + (fixnum highbits)) + (cond ((< highbits 0) + (setf (%get-unsigned-word pointer idx) (%swap-u16 code)) + (incf idx 2)) + (t + (setf (%get-unsigned-word pointer idx) (%swap-u16 (logior #xd800 (the fixnum (ash highbits -10))))) + (incf idx 2) + (setf (%get-unsigned-word pointer idx) (%swap-u16 (logior #xdc00 (the fixnum (logand highbits #x3ff))))) + (incf idx 2))))))) + :memory-decode-function + (nfunction + reversed-utf-16-memory-decode + (lambda (pointer noctets idx string) + (declare (fixnum noctets idx)) + (do* ((i 0 (1+ i)) + (end (+ idx noctets)) + (index idx)) + ((>= index end) index) + (declare (fixnum i index end)) + (let* ((1st-unit (%swap-u16 (%get-unsigned-word pointer index)))) + (declare (type (unsigned-byte 16) 1st-unit)) + (incf index 2) + (let* ((char + (if (or (< 1st-unit #xd800) + (>= 1st-unit #xe000)) + (code-char 1st-unit) + (if (< 1st-unit #xdc00) + (let* ((2nd-unit (%swap-u16 (%get-unsigned-word pointer index)))) + (declare (type (unsigned-byte 16) 2nd-unit)) + (incf index) + (if (and (>= 2nd-unit #xdc00) + (< 2nd-unit #xe000)) + (utf-16-combine-surrogate-pairs 1st-unit 2nd-unit))))))) + (setf (schar string i) (or char #\Replacement_Character))))))) + :octets-in-string-function + #'utf-16-octets-in-string + :length-of-vector-encoding-function + (nfunction + reversed-utf-16-length-of-vector-encoding + (lambda (vector start end) + (declare (type (simple-array (unsigned-byte 8) (*)) vector)) + (declare (fixnum start end)) + (do* ((i start) + (j (+ 2 i) (+ 2 i)) + (nchars 0)) + ((> j end) (values nchars i)) + (declare (fixnum i j nchars)) + (let* ((code (%reversed-u8-ref-u16 vector i)) + (nexti (+ i (if (or (< code #xd800) + (>= code #xdc00)) + 2 + 4)))) + (declare (type (unsigned-byte 16) code) + (fixnum nexti)) + (if (> nexti end) + (return (values nchars i)) + (setq i nexti nchars (1+ nchars))))))) + :length-of-memory-encoding-function + (nfunction + reversed-utf-16-length-of-memory-encoding + (lambda (pointer noctets start) + (do* ((i start) + (j (+ i 2) (+ i 2)) + (end (+ start noctets)) + (nchars 0)) + ((> j end) (values nchars i)) + (let* ((code (%swap-u16 (%get-unsigned-word pointer i))) + (nexti (+ i (if (or (< code #xd800) + (>= code #xdc00)) + 2 + 4)))) + (declare (type (unsigned-byte 16) code) + (fixnum nexti)) + (if (> nexti end) + (return (values nchars i)) + (setq i nexti nchars (1+ nchars))))))) + :decode-literal-code-unit-limit #xd800 + :encode-literal-char-code-limit #x10000 + :nul-encoding #(0 0) + :character-size-in-octets-function 'utf-16-character-size-in-octets + ) + +;;; UTF-16. Memory and vector functions determine endianness of +;;; input by the presence of a byte-order mark (or swapped BOM) +;;; at the beginning of input, and assume big-endian order +;;; if this mark is missing; on output, a BOM is prepended and +;;; things are written in native byte order. +;;; The endianness of stream-io operations is determined by +;;; stream content; new output streams are written in native +;;; endianness with a BOM character prepended. Input streams +;;; are read in native byte order if the initial character is +;;; a BOM, in reversed byte order if the initial character is +;;; a swapped BOM, and in big-endian order (per RFC 2781) if +;;; there is no BOM. + +(define-character-encoding :utf-16 + "A 16-bit, variable-length encoding in which characters with +CHAR-CODEs less than #x10000 can be encoded in a single 16-bit +word and characters with larger codes can be encoded in a +pair of 16-bit words. The endianness of the encoded data is +indicated by the endianness of a byte-order-mark character (#\u+feff) +prepended to the data; in the absence of such a character on input, +the data is assumed to be in big-endian order. Output is written +in native byte-order with a leading byte-order mark." + :max-units-per-char 2 + :code-unit-size 16 + :native-endianness t ;not necessarily true. + :stream-encode-function + #'utf-16-stream-encode + :stream-decode-function + #'utf-16-stream-decode + :vector-encode-function + (nfunction + utf-16-vector-encode + (lambda (string vector idx start end) + (declare (type (simple-array (unsigned-byte 8) (*)) vector) + (fixnum idx)) + (setf (%native-u8-ref-u16 vector idx) byte-order-mark-char-code) + (incf idx 2) + (do* ((i start (1+ i))) + ((>= i end) idx) + (declare (fixnum i)) + (let* ((char (schar string i)) + (code (char-code char)) + (highbits (- code #x10000))) + (declare (type (mod #x110000) code) + (fixnum highbits)) + (cond ((< highbits 0) + (setf (%native-u8-ref-u16 vector idx) code) + (incf idx 2)) + (t + (let* ((firstword (logior #xd800 (the fixnum (ash highbits -10)))) + (secondword (logior #xdc00 (the fixnum (logand highbits #x3ff))))) + (declare (type (unsigned-byte 16) firstword secondword)) + (setf (%native-u8-ref-u16 vector idx) firstword + (%native-u8-ref-u16 vector (the fixnum (+ idx 2))) secondword) + (incf idx 4)))))))) + :vector-decode-function + (nfunction + utf-16-vector-decode + (lambda (vector idx noctets string) + (declare (type (simple-array (unsigned-byte 16) (*)) vector) + (type index idx)) + (let* ((origin idx) + (swap (if (>= noctets 2) + (case (%native-u8-ref-u16 vector idx) + (#.byte-order-mark-char-code + (incf idx 2) nil) + (#.swapped-byte-order-mark-char-code + (incf idx 2) t) + (t #+little-endian-target t))))) + (do* ((i 0 (1+ i)) + (end (+ origin noctets)) + (index idx)) + ((= index end) index) + (declare (fixnum i end index)) + (let* ((1st-unit (if swap + (%reversed-u8-ref-u16 vector index) + (%native-u8-ref-u16 vector index)))) + (declare (type (unsigned-byte 16) 1st-unit)) + (incf index 2) + (let* ((char + (if (or (< 1st-unit #xd800) + (>= 1st-unit #xe000)) + (code-char 1st-unit) + (if (< 1st-unit #xdc00) + (let* ((2nd-unit (if swap + (%reversed-u8-ref-u16 vector index) + (%native-u8-ref-u16 vector index)))) + (declare (type (unsigned-byte 16) 2nd-unit)) + (incf index 2) + (if (and (>= 2nd-unit #xdc00) + (< 2nd-unit #xe000)) + (utf-16-combine-surrogate-pairs 1st-unit 2nd-unit))))))) + (setf (schar string i) (or char #\Replacement_Character)))))))) + :memory-encode-function + (nfunction + utf-16-memory-encode + (lambda (string pointer idx start end) + (declare (fixnum idx)) + ;; Output a BOM. + (setf (%get-unsigned-word pointer idx) byte-order-mark-char-code) + (incf idx 2) + (do* ((i start (1+ i))) + ((>= i end) idx) + (let* ((code (char-code (schar string i))) + (highbits (- code #x10000))) + (declare (type (mod #x110000) code) + (fixnum highbits)) + (cond ((< highbits 0) + (setf (%get-unsigned-word pointer idx) code) + (incf idx 2)) + (t + (setf (%get-unsigned-word pointer idx) (logior #xd800 (the fixnum (ash highbits -10)))) + (setf (%get-unsigned-word pointer (the fixnum (+ idx 2))) + (logior #xdc00 (the fixnum (logand highbits #x3ff)))) + (incf idx 4))))))) + :memory-decode-function + (nfunction + utf-16-memory-decode + (lambda (pointer noctets idx string) + (declare (fixnum noctets idx)) + (let* ((swap (when (> noctets 1) + (case (%get-unsigned-word pointer idx) + (#.byte-order-mark-char-code + (incf idx 2) + (decf noctets 2) + nil) + (#.swapped-byte-order-mark-char-code + (incf idx 2) + (decf noctets 2) + t) + (t #+little-endian-target t))))) + (do* ((i 0 (1+ i)) + (end (+ idx noctets)) + (index idx )) + ((>= index end) index) + (declare (fixnum i index end)) + (let* ((1st-unit (%get-unsigned-word pointer index))) + (declare (type (unsigned-byte 16) 1st-unit)) + (incf index 2) + (if swap (setq 1st-unit (%swap-u16 1st-unit))) + (let* ((char + (if (or (< 1st-unit #xd800) + (>= 1st-unit #xe000)) + (code-char 1st-unit) + (if (< 1st-unit #xdc00) + (let* ((2nd-unit (%get-unsigned-byte pointer index))) + (declare (type (unsigned-byte 16) 2nd-unit)) + (if swap (setq 2nd-unit (%swap-u16 2nd-unit))) + (incf index 2) + (if (and (>= 2nd-unit #xdc00) + (< 2nd-unit #xe000)) + (utf-16-combine-surrogate-pairs 1st-unit 2nd-unit))))))) + (setf (schar string i) (or char #\Replacement_Character)))))))) + :octets-in-string-function + (nfunction + utf-16-bom-octets-in-string + (lambda (string start end) + (+ 2 (utf-16-octets-in-string string start end)))) + :length-of-vector-encoding-function + (nfunction + utf-16-length-of-vector-encoding + (lambda (vector start end) + (declare (type (simple-array (unsigned-byte 16) (*)) vector)) + (let* ((swap (when (>= end (+ start 2)) + (case (%native-u8-ref-u16 vector start) + (#.byte-order-mark-char-code + (incf start 2) + nil) + (#.swapped-byte-order-mark-char-code + (incf start 2) + t) + (t #+little-endian-target t))))) + (do* ((i start) + (j (+ 2 i) (+ 2 j)) + (nchars 0)) + ((> j end) + (values nchars i)) + (let* ((code (if swap + (%reversed-u8-ref-u16 vector i) + (%native-u8-ref-u16 vector i))) + (nexti (+ i (if (or (< code #xd800) + (>= code #xdc00)) + 2 + 4)))) + (declare (type (unsigned-byte 16) code) + (fixnum nexti)) + (if (> nexti end) + (return (values nchars i)) + (setq i nexti nchars (1+ nchars)))))))) + :length-of-memory-encoding-function + (nfunction + utf-16-length-of-memory-encoding + (lambda (pointer noctets start) + (declare (fixnum noctets start)) + (when (oddp noctets) + (setq noctets (1- noctets))) + (let* ((origin start) + (swap (when (>= noctets 2) + (case (%get-unsigned-word pointer (+ start start)) + (#.byte-order-mark-char-code + (incf start 2) + nil) + (#.swapped-byte-order-mark-char-code + (incf start 2) + t) + (t #+little-endian-target t))))) + (declare (fixnum origin)) + (do* ((i start) + (j (+ i 2) (+ i 2)) + (end (+ origin noctets)) + (nchars 0 (1+ nchars))) + ((> j end) (values nchars (- i origin))) + (declare (fixnum i j end nchars)) + (let* ((code (%get-unsigned-word pointer i))) + (declare (type (unsigned-byte 16) code)) + (if swap (setq code (%swap-u16 code))) + (let* ((nexti (+ i (if (or (< code #xd800) + (>= code #xdc00)) + 2 + 4)))) + (declare (fixnum nexti)) + (if (> nexti end) + (return (values nchars (- i origin))) + (setq i nexti)))))))) + :decode-literal-code-unit-limit #xd800 + :encode-literal-char-code-limit #x10000 + :use-byte-order-mark + #+big-endian-target :utf-16le + #+little-endian-target :utf-16be + :bom-encoding #+big-endian-target #(#xfe #xff) #+little-endian-target #(#xff #xfe) + :nul-encoding #(0 0) + :character-size-in-octets-function 'utf-16-character-size-in-octets + ) + + +(defun two-octets-per-character (c) + (declare (ignore c)) + 2) + +(defun ucs-2-stream-encode (char write-function stream) + (let* ((code (char-code char))) + (declare (type (mod #x110000) code)) + (if (>= code #x10000) + (setq code (char-code #\Replacement_Character))) + (funcall write-function stream code) + 1)) + +(defun ucs-2-stream-decode (1st-unit next-unit-function stream) + (declare (type (unsigned-byte 16) 1st-unit) + (ignore next-unit-function stream)) + ;; CODE-CHAR returns NIL on either half of a surrogate pair. + (or (code-char 1st-unit) + #\Replacement_Character)) + + +(defun ucs-2-octets-in-string (string start end) + (declare (ignore string)) + (if (>= end start) + (* 2 (- end start)) + 0)) + +(defun ucs-2-length-of-vector-encoding (vector start end) + (declare (ignore vector)) + (let* ((noctets (max (- end start) 0))) + (values (ash noctets -1) (+ start (logandc2 noctets 1))))) + +(defun ucs-2-length-of-memory-encoding (pointer noctets start) + (declare (ignore pointer start)) + (values (ash noctets -1) (logandc2 noctets 1))) + + + +;;; UCS-2, native byte order +(define-character-encoding #+big-endian-target :ucs-2be #-big-endian-target :ucs-2le + #+big-endian-target + "A 16-bit, fixed-length encoding in which characters with +CHAR-CODEs less than #x10000 can be encoded in a single 16-bit +big-endian word. The encoded data is implicitly big-endian; +byte-order-mark characters are not interpreted on input or prepended +to output." + #+little-endian-target + "A 16-bit, fixed-length encoding in which characters with +CHAR-CODEs less than #x10000 can be encoded in a single 16-bit +little-endian word. The encoded data is implicitly little-endian; +byte-order-mark characters are not interpreted on input or prepended +to output." + :max-units-per-char 1 + :code-unit-size 16 + :native-endianness t + :stream-encode-function + #'ucs-2-stream-encode + :stream-decode-function + #'ucs-2-stream-decode + :vector-encode-function + (nfunction + native-ucs-2-vector-encode + (lambda (string vector idx start end) + (declare (type (simple-array (unsigned-byte 8) (*)) vector) + (fixnum idx)) + (do* ((i start (1+ i))) + ((>= i end) idx) + (let* ((char (schar string i)) + (code (char-code char))) + (declare (type (mod #x110000) code)) + (when (>= code #x10000) + (setq code (char-code #\Replacement_Character))) + (setf (%native-u8-ref-u16 vector idx) code) + (incf idx 2))))) + :vector-decode-function + (nfunction + native-ucs-2-vector-decode + (lambda (vector idx noctets string) + (declare (type (simple-array (unsigned-byte 8) (*)) vector) + (type index idx)) + (do* ((i 0 (1+ i)) + (end (+ idx noctets)) + (index idx (+ 2 index))) + ((>= index end) index) + (declare (fixnum i end index)) + (setf (schar string i) + (or (code-char (%native-u8-ref-u16 vector index)) + #\Replacement_Character))))) + :memory-encode-function + (nfunction + native-ucs-2-memory-encode + (lambda (string pointer idx start end) + (declare (fixnum idx)) + (do* ((i start (1+ i))) + ((>= i end) idx) + (let* ((code (char-code (schar string i)))) + (declare (type (mod #x110000) code)) + (setf (%get-unsigned-word pointer idx) + (if (>= code #x10000) + (char-code #\Replacement_Character) + code)) + (incf idx 2))))) + :memory-decode-function + (nfunction + native-ucs-2-memory-decode + (lambda (pointer noctets idx string) + (declare (fixnum noctets idx)) + (do* ((i 0 (1+ i)) + (index idx (+ index 2))) + ((>= i noctets) index) + (declare (fixnum i index)) + (let* ((1st-unit (%get-unsigned-word pointer index))) + (declare (type (unsigned-byte 16) 1st-unit)) + (setf (schar string i) (or (char-code 1st-unit) #\Replacement_Character)))))) + :octets-in-string-function + #'ucs-2-octets-in-string + :length-of-vector-encoding-function + #'ucs-2-length-of-vector-encoding + :length-of-memory-encoding-function + #'ucs-2-length-of-memory-encoding + :decode-literal-code-unit-limit #x10000 + :encode-literal-char-code-limit #x10000 + :nul-encoding #(0 0) + :character-size-in-octets-function 'two-octets-per-character + ) + +;;; UCS-2, reversed byte order +(define-character-encoding #+big-endian-target :ucs-2le #-big-endian-target :ucs-2be + #+little-endian-target + "A 16-bit, fixed-length encoding in which characters with +CHAR-CODEs less than #x10000 can be encoded in a single 16-bit +big-endian word. The encoded data is implicitly big-endian; +byte-order-mark characters are not interpreted on input or prepended +to output." + #+big-endian-target + "A 16-bit, fixed-length encoding in which characters with +CHAR-CODEs less than #x10000 can be encoded in a single 16-bit + +little-endian word. The encoded data is implicitly little-endian; +byte-order-mark characters are not interpreted on input or prepended +to output." + :max-units-per-char 1 + :code-unit-size 16 + :native-endianness nil + :stream-encode-function + #'ucs-2-stream-encode + :stream-decode-function + #'ucs-2-stream-decode + :vector-encode-function + (nfunction + reversed-ucs-2-vector-encode + (lambda (string vector idx start end) + (declare (type (simple-array (unsigned-byte 8) (*)) vector) + (fixnum idx)) + (do* ((i start (1+ i))) + ((>= i end) idx) + (let* ((char (schar string i)) + (code (char-code char))) + (declare (type (mod #x110000) code)) + (when (>= code #x10000) + (setq code (char-code #\Replacement_Character))) + (setf (%reversed-u8-ref-u16 vector idx) code) + (incf idx 2))))) + :vector-decode-function + (nfunction + reversed-ucs-2-vector-decode + (lambda (vector idx noctets string) + (declare (type (simple-array (unsigned-byte 8) (*)) vector) + (type index idx)) + (do* ((i 0 (1+ i)) + (end (+ idx noctets)) + (index idx (+ 2 index))) + ((>= index end) index) + (declare (fixnum i end index)) + (setf (schar string i) + (or (code-char (%reversed-u8-ref-u16 vector index)) + #\Replacement_Character))))) + :memory-encode-function + (nfunction + reversed-ucs-2-memory-encode + (lambda (string pointer idx start end) + (declare (fixnum idx)) + (do* ((i start (1+ i))) + ((>= i end) idx) + (let* ((code (char-code (schar string i)))) + (declare (type (mod #x110000) code)) + (setf (%get-unsigned-word pointer idx) + (if (>= code #x10000) + (%swap-u16 (char-code #\Replacement_Character)) + (%swap-u16 code))) + (incf idx 2))))) + :memory-decode-function + (nfunction + reversed-ucs-2-memory-decode + (lambda (pointer noctets idx string) + (declare (fixnum noctets idx)) + (do* ((i 0 (1+ i)) + (index idx (+ index 2))) + ((>= i noctets) index) + (declare (fixnum i index)) + (let* ((1st-unit (%swap-u16 (%get-unsigned-word pointer index)))) + (declare (type (unsigned-byte 16) 1st-unit)) + (setf (schar string i) (or (code-char 1st-unit) #\Replacement_Character)))))) + :octets-in-string-function + #'ucs-2-octets-in-string + :length-of-vector-encoding-function + #'ucs-2-length-of-vector-encoding + :length-of-memory-encoding-function + #'ucs-2-length-of-memory-encoding + :decode-literal-code-unit-limit #x10000 + :encode-literal-char-code-limit #x10000 + :nul-encoding #(0 0) + :character-size-in-octets-function 'two-octets-per-character + ) + +(define-character-encoding :ucs-2 + "A 16-bit, fixed-length encoding in which characters with +CHAR-CODEs less than #x10000 can be encoded in a single 16-bit word. +The endianness of the encoded data is indicated by the endianness of a +byte-order-mark character (#\u+feff) prepended to the data; in the +absence of such a character on input, the data is assumed to be in +big-endian order." + :max-units-per-char 1 + :code-unit-size 16 + :native-endianness t ;not necessarily true. + :stream-encode-function + #'ucs-2-stream-encode + :stream-decode-function + #'ucs-2-stream-decode + :vector-encode-function + (nfunction + ucs-2-vector-encode + (lambda (string vector idx start end) + (declare (type (simple-array (unsigned-byte 8) (*)) vector) + (fixnum idx)) + (setf (%native-u8-ref-u16 vector idx) byte-order-mark-char-code) + (incf idx 2) + (do* ((i start (1+ i))) + ((>= i end) idx) + (let* ((char (schar string i)) + (code (char-code char))) + (declare (type (mod #x110000) code)) + (when (>= code #x10000) + (setq code (char-code #\Replacement_Character))) + (setf (%native-u8-ref-u16 vector idx) code) + (incf idx 2))))) + :vector-decode-function + (nfunction + ucs-2-vector-decode + (lambda (vector idx noctets string) + (declare (type (simple-array (unsigned-byte 8) (*)) vector) + (type index idx) + (fixnum noctets)) + (let* ((swap (if (> noctets 1) + (case (%native-u8-ref-u16 vector idx) + (#.byte-order-mark-char-code + (incf idx 2) (decf noctets 2) nil) + (#.swapped-byte-order-mark-char-code + (incf idx 2) (decf noctets 2) t) + (t #+little-endian-target t))))) + + (do* ((i 0 (1+ i)) + (end (+ idx noctets)) + (index idx (1+ index))) + ((>= index end) index) + (declare (fixnum i end index)) + (let* ((1st-unit (if swap + (%reversed-u8-ref-u16 vector index) + (%native-u8-ref-u16 vector index)))) + (declare (type (unsigned-byte 16) 1st-unit)) + (setf (schar string i) (or (code-char 1st-unit) #\Replacement_Character))))))) + :memory-encode-function + (nfunction + ucs-2-memory-encode + (lambda (string pointer idx start end) + (declare (fixnum idx)) + (setf (%get-unsigned-word pointer idx) byte-order-mark-char-code) + (incf idx 2) + (do* ((i start (1+ i))) + ((>= i end) idx) + (let* ((code (char-code (schar string i)))) + (declare (type (mod #x110000) code)) + (setf (%get-unsigned-word pointer idx) + (if (>= code #x10000) + (char-code #\Replacement_Character) + code)) + (incf idx 2))))) + :memory-decode-function + (nfunction + ucs-2-memory-decode + (lambda (pointer noctets idx string) + (declare (fixnum noctets idx)) + (let* ((swap (when (> noctets 1) + (case (%get-unsigned-word pointer idx) + (#.byte-order-mark-char-code + (incf idx 2) + (decf noctets 2) + nil) + (#.swapped-byte-order-mark-char-code + (incf idx 2) + (decf noctets 2) + t) + (t #+little-endian-target t))))) + (do* ((i 0 (1+ i)) + (index idx (+ index 2))) + ((>= i noctets) index) + (declare (fixnum i index)) + (let* ((1st-unit (%get-unsigned-word pointer index))) + (declare (type (unsigned-byte 16) 1st-unit)) + (if swap (setq 1st-unit (%swap-u16 1st-unit))) + (setf (schar string i) (or (code-char 1st-unit) #\Replacement_Character))))))) + :octets-in-string-function + (nfunction + ucs-2-bom-octets-in-string + (lambda (string start end) + (+ 2 (ucs-2-octets-in-string string start end)))) + :length-of-vector-encoding-function + (nfunction + ucs-2-length-of-vector-encoding + (lambda (vector start end) + (declare (fixnum start end)) + (when (>= end (+ start 2)) + (let* ((maybe-bom (%native-u8-ref-u16 vector start))) + (declare (type (unsigned-byte 16) maybe-bom)) + (when (or (= maybe-bom byte-order-mark-char-code) + (= maybe-bom swapped-byte-order-mark-char-code)) + (incf start 2)))) + (do* ((i start j) + (j (+ i 2) (+ j 2)) + (nchars 0 (1+ nchars))) + ((> j end) (values nchars i))))) + :length-of-memory-encoding-function + (nfunction + ucs-2-length-of-memory-encoding + (lambda (pointer noctets start) + (let* ((skip + (when (> noctets 1) + (case (%get-unsigned-word pointer start) + (#.byte-order-mark-char-code + 2) + (#.swapped-byte-order-mark-char-code + 2))))) + (values (ash (- noctets skip) -1) (logandc2 noctets 1))))) + :decode-literal-code-unit-limit #x10000 + :encode-literal-char-code-limit #x10000 + :use-byte-order-mark + #+big-endian-target :ucs-2le + #+little-endian-target :ucs-2be + :nul-encoding #(0 0) + :character-size-in-octets-function 'two-octets-per-character + ) + + +(defun four-octets-per-character (c) + (declare (ignore c)) + 4) + +(defun ucs-4-stream-encode (char write-function stream) + (let* ((code (char-code char))) + (declare (type (mod #x110000) code)) + (funcall write-function stream code) + 1)) + +(defun ucs-4-stream-decode (1st-unit next-unit-function stream) + (declare (type (unsigned-byte 16) 1st-unit) + (ignore next-unit-function stream)) + (code-char 1st-unit)) + + +(defun ucs-4-octets-in-string (string start end) + (declare (ignore string)) + (if (>= end start) + (* 4 (- end start)) + 0)) + + +(declaim (inline %big-endian-u8-ref-u32 %little-endian-u8-ref-u32)) +(defun %big-endian-u8-ref-u32 (u8-vector idx) + (declare (type (simple-array (unsigned-byte 8) (*)) u8-vector) + (fixnum idx)) + (logior (the (unsigned-byte 32) (ash (the (unsigned-byte 8) (aref u8-vector idx)) 24)) + (the (unsigned-byte 24) + (logior + (ash (the (unsigned-byte 8) (aref u8-vector (the fixnum (1+ idx)))) 16) + (the (unsigned-byte 16) + (logior + (ash (the (unsigned-byte 8) (aref u8-vector (the fixnum (+ idx 2)))) 8) + (the (unsigned-byte 8) (aref u8-vector (the fixnum (+ idx 3)))))))))) + +(defun %little-endian-u8-ref-u32 (u8-vector idx) + (declare (type (simple-array (unsigned-byte 8) (*)) u8-vector) + (fixnum idx)) + (logior (the (unsigned-byte 32) (ash (the (unsigned-byte 8) (aref u8-vector (the fixnum (+ idx 3)))) 24)) + (the (unsigned-byte 24) + (logior + (ash (the (unsigned-byte 8) (aref u8-vector (the fixnum (+ idx 2)))) 16) + (the (unsigned-byte 16) + (logior + (ash (the (unsigned-byte 8) (aref u8-vector (the fixnum (1+ idx)))) 8) + (the (unsigned-byte 8) (aref u8-vector (the fixnum idx))))))))) + +#+big-endian-target +(progn +(defmacro %native-u8-ref-u32 (vector idx) + `(%big-endian-u8-ref-u32 ,vector ,idx)) + +(defmacro %reversed-u8-ref-u32 (vector idx) + `(%little-endian-u8-ref-u32 ,vector ,idx)) +) + +#+little-endian-target +(progn +(defmacro %native-u8-ref-u32 (vector idx) + `(%little-endian-u8-ref-u32 ,vector ,idx)) + +(defmacro %reversed-u8-ref-u32 (vector idx) + `(%big-endian-u8-ref-u32 ,vector ,idx)) +) + + +(declaim (inline (setf %big-endian-u8-ref-32) (setf %little-endian-u8-ref-u32))) +(defun (setf %big-endian-u8-ref-u32) (val u8-vector idx) + (declare (type (unsigned-byte 32) val) + (type (simple-array (unsigned-byte 8) (*)) u8-vector) + (fixnum idx)) + (setf (aref u8-vector idx) (ldb (byte 8 24) val) + (aref u8-vector (the fixnum (1+ idx))) (ldb (byte 8 16) val) + (aref u8-vector (the fixnum (+ idx 2))) (ldb (byte 8 8) val) + (aref u8-vector (the fixnum (+ idx 3))) (ldb (byte 8 0) val)) + val) + +(defun (setf %little-endian-u8-ref-u32) (val u8-vector idx) + (declare (type (unsigned-byte 32) val) + (type (simple-array (unsigned-byte 8) (*)) u8-vector) + (fixnum idx)) + (setf (aref u8-vector idx) (ldb (byte 8 0) val) + (aref u8-vector (the fixnum (1+ idx))) (ldb (byte 8 8) val) + (aref u8-vector (the fixnum (+ idx 2))) (ldb (byte 8 16) val) + (aref u8-vector (the fixnum (+ idx 3))) (ldb (byte 8 24) val)) + val) + + +;;; UTF-32/UCS-4, native byte order +(define-character-encoding #+big-endian-target :utf-32be #-big-endian-target :utf-32le + #+big-endian-target + "A 32-bit, fixed-length encoding in which all Unicode characters +encoded in a single 32-bit word. The encoded data is implicitly big-endian; +byte-order-mark characters are not interpreted on input or prepended +to output." + #+little-endian-target + "A 32-bit, fixed-length encoding in which all Unicode characters can +encoded in a single 32-bit word. The encoded data is implicitly +little-endian; byte-order-mark characters are not interpreted on input +or prepended to output." + :aliases #+big-endian-target '(:ucs-4be) #+little-endian-target '(:ucs-4le) + :max-units-per-char 1 + :code-unit-size 32 + :native-endianness t + :stream-encode-function + #'ucs-4-stream-encode + :Stream-decode-function + #'ucs-4-stream-decode + :vector-encode-function + (nfunction + native-ucs-4-vector-encode + (lambda (string vector idx start end) + (declare (type (simple-array (unsigned-byte 8) (*)) vector) + (fixnum idx)) + (do* ((i start (1+ i))) + ((>= i end) idx) + (let* ((char (schar string i)) + (code (char-code char))) + (declare (type (mod #x110000) code)) + (setf (%native-u8-ref-u32 vector idx) code) + (incf idx 4))))) + :vector-decode-function + (nfunction + native-ucs-4-vector-decode + (lambda (vector idx noctets string) + (declare (type (simple-array (unsigned-byte 8) (*)) vector) + (type index idx)) + (do* ((i 0 (1+ i)) + (end (+ idx noctets)) + (index idx (+ 4 index))) + ((>= index end) index) + (declare (fixnum i end index)) + (let* ((code (%native-u8-ref-u32 vector index))) + (declare (type (unsigned-byte 32) code)) + (setf (schar string i) + (or (if (< code char-code-limit) + (code-char code)) + #\Replacement_Character)))))) + :memory-encode-function + (nfunction + native-ucs-4-memory-encode + (lambda (string pointer idx start end) + (declare (fixnum idx)) + (do* ((i start (1+ i))) + ((>= i end) idx) + (let* ((code (char-code (schar string i)))) + (declare (type (mod #x110000) code)) + (setf (%get-unsigned-long pointer idx) code) + (incf idx 4))))) + :memory-decode-function + (nfunction + native-ucs-4-memory-decode + (lambda (pointer noctets idx string) + (declare (fixnum noctets idx)) + (do* ((i 0 (1+ i)) + (index idx (+ index 4))) + ((>= i noctets) index) + (declare (fixnum i index)) + (let* ((1st-unit (%get-unsigned-long pointer index))) + (declare (type (unsigned-byte 32) 1st-unit)) + (setf (schar string i) (or (if (< 1st-unit char-code-limit) + (code-char 1st-unit)) + #\Replacement_Character)))))) + :octets-in-string-function + #'ucs-4-octets-in-string + :length-of-vector-encoding-function + (nfunction + native-ucs-4-length-of-vector-encoding + (lambda (vector start end) + (declare (ignore vector)) + (do* ((i start j) + (j (+ i 4) (+ j 4)) + (nchars 0 (1+ nchars))) + ((> j end) (values nchars i))))) + :length-of-memory-encoding-function + (nfunction + native-ucs-4-length-of-memory-encoding + (lambda (pointer noctets start) + (declare (ignore pointer)) + (values (ash noctets -2) (+ start (logandc2 noctets 3))))) + :decode-literal-code-unit-limit #x110000 + :encode-literal-char-code-limit #x110000 + :nul-encoding #(0 0 0 0) + :character-size-in-octets-function 'four-octets-per-character + ) + +;;; UTF-32/UCS-4, reversed byte order +(define-character-encoding #+big-endian-target :utf-32le #-big-endian-target :utf-32be + #+little-endian-target + "A 32-bit, fixed-length encoding in which all Unicode characters +encoded in a single 32-bit word. The encoded data is implicitly big-endian; +byte-order-mark characters are not interpreted on input or prepended +to output." + #+big-endian-target + "A 32-bit, fixed-length encoding in which all Unicode characters can +encoded in a single 32-bit word. The encoded data is implicitly +little-endian; byte-order-mark characters are not interpreted on input +or prepended to output." + :aliases #+big-endian-target '(:ucs-4le) #+little-endian-target '(:ucs-4be) + :max-units-per-char 1 + :code-unit-size 32 + :native-endianness nil + :stream-encode-function + #'ucs-4-stream-encode + :Stream-decode-function + #'ucs-4-stream-decode + :vector-encode-function + (nfunction + native-ucs-4-vector-encode + (lambda (string vector idx start end) + (declare (type (simple-array (unsigned-byte 8) (*)) vector) + (fixnum idx)) + (do* ((i start (1+ i))) + ((>= i end) idx) + (let* ((char (schar string i)) + (code (char-code char))) + (declare (type (mod #x110000) code)) + (setf (%reversed-u8-ref-u32 vector idx) code) + (incf idx 4))))) + :vector-decode-function + (nfunction + native-ucs-4-vector-decode + (lambda (vector idx noctets string) + (declare (type (simple-array (unsigned-byte 8) (*)) vector) + (type index idx)) + (do* ((i 0 (1+ i)) + (end (+ idx noctets)) + (index idx (+ 4 index))) + ((>= index end) index) + (declare (fixnum i end index)) + (let* ((code (%reversed-u8-ref-u32 vector index))) + (declare (type (unsigned-byte 32) code)) + (setf (schar string i) + (or (if (< code char-code-limit) + (code-char code)) + #\Replacement_Character)))))) + :memory-encode-function + (nfunction + native-ucs-4-memory-encode + (lambda (string pointer idx start end) + (declare (fixnum idx)) + (do* ((i start (1+ i))) + ((>= i end) idx) + (let* ((code (char-code (schar string i)))) + (declare (type (mod #x110000) code)) + (setf (%get-unsigned-long pointer idx) (%swap-u32 code)) + (incf idx 4))))) + :memory-decode-function + (nfunction + reversed-ucs-4-memory-decode + (lambda (pointer noctets idx string) + (declare (fixnum noctets idx)) + (do* ((i 0 (1+ i)) + (index idx (+ index 4))) + ((>= i noctets) index) + (declare (fixnum i index)) + (let* ((1st-unit (%swap-u32 (%get-unsigned-long pointer index)))) + (declare (type (unsigned-byte 32) 1st-unit)) + (setf (schar string i) (or (if (< 1st-unit char-code-limit) + (code-char 1st-unit)) + #\Replacement_Character)))))) + + :octets-in-string-function + #'ucs-4-octets-in-string + :length-of-vector-encoding-function + (nfunction + reversed-ucs-4-length-of-vector-encoding + (lambda (vector start end) + (declare (ignore vector)) + (do* ((i start j) + (j (+ i 4) (+ j 4)) + (nchars 0 (1+ nchars))) + ((> j end) (values nchars i))))) + :length-of-memory-encoding-function + (nfunction + reversed-ucs-4-length-of-memory-encoding + (lambda (pointer noctets start) + (declare (ignore pointer)) + (values (ash noctets -2) (+ start (logandc2 noctets 3))))) + :decode-literal-code-unit-limit #x110000 + :encode-literal-char-code-limit #x110000 + :nul-encoding #(0 0 0 0) + :character-size-in-octets-function 'four-octets-per-character + ) + +(define-character-encoding :utf-32 + "A 32-bit, fixed-length encoding in which all Unicode characters +can be encoded in a single 32-bit word. The endianness of the encoded +data is indicated by the endianness of a byte-order-mark +character (#\u+feff) prepended to the data; in the absence of such a +character on input, input data is assumed to be in big-endian order. +Output is written in native byte order with a leading byte-order +mark." + + :aliases '(:ucs-4) + :max-units-per-char 1 + :code-unit-size 32 + :native-endianness t ;not necessarily true. + :stream-encode-function + #+ucs-4-stream-encode + :stream-decode-function + #'ucs-4-stream-decode + :vector-encode-function + (nfunction + utf-32-vector-encode + (lambda (string vector idx start end) + (declare (type (simple-array (unsigned-byte 8) (*)) vector) + (fixnum idx)) + (setf (%native-u8-ref-u32 vector idx) byte-order-mark-char-code) + (incf idx 4) + (do* ((i start (1+ i))) + ((>= i end) idx) + (let* ((char (schar string i)) + (code (char-code char))) + (declare (type (mod #x110000) code)) + (setf (%native-u8-ref-u32 vector idx) code) + (incf idx 4))))) + :vector-decode-function + (nfunction + utf-32-vector-decode + (lambda (vector idx noctets string) + (declare (type (simple-array (unsigned-byte 8) (*)) vector) + (type index idx) + (fixnum noctets)) + (let* ((swap (if (> noctets 3) + (case (%native-u8-ref-u32 vector idx) + (#.byte-order-mark-char-code + (incf idx 4) (decf noctets 4) nil) + (#.swapped-byte-order-mark-char-code + (incf idx 4) (decf noctets 4) t) + (t #+little-endian-target t))))) + + (do* ((i 0 (1+ i)) + (end (+ idx noctets)) + (index idx (1+ index))) + ((>= index end) index) + (declare (fixnum i end index)) + (let* ((1st-unit (if swap + (%reversed-u8-ref-u32 vector index) + (%native-u8-ref-u32 vector index)))) + (declare (type (unsigned-byte 32) 1st-unit)) + (setf (schar string i) (or (if (< 1st-unit char-code-limit) + (code-char 1st-unit)) + #\Replacement_Character))))))) + :memory-encode-function + (nfunction + utf-32-memory-encode + (lambda (string pointer idx start end) + (declare (fixnum idx)) + (setf (%get-unsigned-long pointer idx) byte-order-mark-char-code) + (incf idx 4) + (do* ((i start (1+ i))) + ((>= i end) idx) + (let* ((code (char-code (schar string i)))) + (declare (type (mod #x110000) code)) + (setf (%get-unsigned-long pointer idx) code) + (incf idx 4))))) + :memory-decode-function + (nfunction + utf-32-memory-decode + (lambda (pointer noctets idx string) + (declare (fixnum noctets idx)) + (let* ((swap (when (> noctets 3) + (case (%get-unsigned-long pointer idx) + (#.byte-order-mark-char-code + (incf idx 4) + (decf noctets 4) + nil) + (#.swapped-byte-order-mark-char-code + (incf idx 4) + (decf noctets 4) + t) + (t #+little-endian-target t))))) + (do* ((i 0 (1+ i)) + (index idx (+ index 2))) + ((>= i noctets) index) + (declare (fixnum i index)) + (let* ((1st-unit (%get-unsigned-long pointer index))) + (declare (type (unsigned-byte 32) 1st-unit)) + (if swap (setq 1st-unit (%swap-u32 1st-unit))) + (setf (schar string i) (or (if (< 1st-unit char-code-limit) + (code-char 1st-unit)) + #\Replacement_Character))))))) + :octets-in-string-function + (nfunction + utf-32-bom-octets-in-string + (lambda (string start end) + (+ 4 (ucs-4-octets-in-string string start end)))) + :length-of-vector-encoding-function + (nfunction + utf-32-length-of-vector-encoding + (lambda (vector start end) + (when (>= end (+ start 4)) + (let* ((maybe-bom (%native-u8-ref-u32 vector start))) + (declare (type (unsigned-byte 32) maybe-bom)) + (when (or (= maybe-bom byte-order-mark-char-code) + (= maybe-bom swapped-byte-order-mark-char-code)) + (incf start 4)))) + (do* ((i start j) + (j (+ i 4) (+ J 4)) + (nchars 0 (1+ nchars))) + ((> j end) (values nchars i))))) + :length-of-memory-encoding-function + (nfunction + utf-32-length-of-memory-encoding + (lambda (pointer noctets start) + (when (> noctets 3) + (case (%get-unsigned-long pointer ) + (#.byte-order-mark-char-code + (incf start 4) + (decf noctets 4)) + (#.swapped-byte-order-mark-char-code + (incf start 4) + (decf noctets 4)))) + (values (ash noctets -2) (+ start (logandc2 noctets 3))))) + :decode-literal-code-unit-limit #x110000 + :encode-literal-char-code-limit #x110000 + :use-byte-order-mark + #+big-endian-target :utf-32le + #+little-endian-target :utf-32be + :bom-encoding #+big-endian-target #(#x00 #x00 #xfe #xff) #+little-endian-target #(#xff #xfe #x00 #x00) + :nul-encoding #(0 0 0 0) + :character-size-in-octets-function 'four-octets-per-character + ) + +(defun describe-character-encoding (name) + (let* ((enc (lookup-character-encoding name))) + (when enc + (let* ((name (character-encoding-name enc)) + (doc (character-encoding-documentation enc)) + (aliases (character-encoding-aliases enc))) + (format t "~&~s" name) + (when (null (car aliases)) + (pop aliases)) + (when aliases + (format t " [Aliases:~{ ~s~}]" aliases)) + (format t "~&~a~%~%" doc) + (values))))) + +(defun describe-character-encodings () + (let* ((names nil)) + (maphash #'(lambda (name enc) + (when (eq name (character-encoding-name enc)) + (push name names))) + *character-encodings*) + (dolist (name (sort names #'string<) (values)) + (describe-character-encoding name)))) + +(defmethod make-load-form ((c character-encoding) &optional environment) + (declare (ignore environment)) + `(get-character-encoding ,(character-encoding-name c))) + +(defvar *native-newline-string* (make-string 1 :initial-element #\Newline)) +(defvar *unicode-newline-string* (make-string 1 :initial-element #\Line_Separator)) +(defvar *cr-newline-string* (make-string 1 :initial-element #\Return)) +(defvar *crlf-newline-string* (make-array 2 :element-type 'character :initial-contents '(#\Return #\Linefeed))) +(defvar *nul-string* (make-string 1 :initial-element #\Nul)) + +(defun string-size-in-octets (string &key + (start 0) + end + external-format + use-byte-order-mark) + (setq end (check-sequence-bounds string start end)) + (let* ((ef (normalize-external-format t external-format))) + (%string-size-in-octets string + start + end + (get-character-encoding + (external-format-character-encoding ef)) + (cdr (assoc (external-format-line-termination ef) + *canonical-line-termination-conventions*)) + use-byte-order-mark))) + + +(defun %string-size-in-octets (string start end encoding line-termination use-byte-order-mark) + (declare (fixnum start end)) + (multiple-value-bind (simple-string offset) + (array-data-and-offset string) + (declare (fixnum offset) (simple-string simple-string)) + (incf start offset) + (incf end offset) + (let* ((n (if use-byte-order-mark + (length (character-encoding-bom-encoding encoding)) + 0)) + (f (character-encoding-octets-in-string-function encoding)) + (nlpos (if line-termination + (position #\Newline simple-string :start start :end end)))) + (if (not nlpos) + (+ n (funcall f simple-string start end)) + (let* ((nlstring (case line-termination + (:cr *cr-newline-string*) + (:crlf *crlf-newline-string*) + (:unicode *unicode-newline-string*))) + (nlstring-length (if (eq line-termination :crlf) 2 1))) + (do* () + ((null nlpos) (+ n (funcall f simple-string start end))) + (unless (eql nlpos start) + (incf n (funcall f simple-string start nlpos))) + (incf n (funcall f nlstring 0 nlstring-length)) + (setq start (1+ nlpos) + nlpos (position #\Newline simple-string :start start :end end)))))))) + +(defun encode-string-to-octets (string &key + (start 0) + end + external-format + use-byte-order-mark + (vector nil vector-p) + (vector-offset 0)) + (setq end (check-sequence-bounds string start end)) + (let* ((ef (normalize-external-format t external-format)) + (encoding (get-character-encoding + (external-format-character-encoding ef))) + (line-termination (cdr (assoc (external-format-line-termination ef) + *canonical-line-termination-conventions*))) + (n (%string-size-in-octets string start end encoding line-termination use-byte-order-mark))) + (declare (fixnum start end n)) + (unless (and (typep vector-offset 'fixnum) + (or (not vector-p) + (< vector-offset (length vector)))) + (error "Invalid vector offset ~s" vector-offset)) + (if (not vector-p) + (setq vector (make-array (+ n vector-offset) + :element-type '(unsigned-byte 8))) + (progn + (unless (= (typecode vector) target::subtag-u8-vector) + (report-bad-arg vector '(simple-array (unsigned-byte 8) (*)))) + (unless (>= (length vector) (+ vector-offset n)) + (error "Can't encode ~s into supplied vector ~s; ~&~d octets are needed, but only ~d are available" string vector n (- (length vector) vector-offset))))) + (when use-byte-order-mark + (let* ((bom (character-encoding-bom-encoding encoding))) + (dotimes (i (length bom)) + (setf (aref vector vector-offset) + (aref bom i)) + (incf vector-offset)))) + (multiple-value-bind (simple-string offset) (array-data-and-offset string) + (incf start offset) + (incf end offset) + (let* ((f (character-encoding-vector-encode-function encoding)) + (nlpos (if line-termination + (position #\Newline simple-string :start start :end end)))) + (if (null nlpos) + (setq vector-offset + (funcall f simple-string vector vector-offset start end)) + (let* ((nlstring (case line-termination + (:cr *cr-newline-string*) + (:crlf *crlf-newline-string*) + (:unicode *unicode-newline-string*))) + (nlstring-length (if (eq line-termination :crlf) 2 1))) + (do* () + ((null nlpos) + (setq vector-offset + (funcall f simple-string vector vector-offset start end))) + (unless (eql nlpos start) + (setq vector-offset (funcall f simple-string vector vector-offset start nlpos))) + (setq vector-offset (funcall f nlstring vector vector-offset 0 nlstring-length)) + (setq start (1+ nlpos) + nlpos (position #\Newline simple-string :start start :end end))))) + (values vector vector-offset))))) + + + +(defun count-characters-in-octet-vector (vector &key + (start 0) + end + external-format) + (setq end (check-sequence-bounds vector start end)) + (%count-characters-in-octet-vector + vector + start + end + (get-character-encoding (external-format-character-encoding (normalize-external-format t external-format))))) + +(defun %count-characters-in-octet-vector (vector start end encoding) + (unless (= (typecode vector) target::subtag-u8-vector) + (report-bad-arg vector '(simple-array (unsigned-byte 8) (*)))) + (funcall (character-encoding-length-of-vector-encoding-function encoding) + vector + start + end)) + + +(defun decode-string-from-octets (vector &key + (start 0) + end + external-format + (string nil string-p)) + (setq end (check-sequence-bounds vector start end)) + (unless (= (typecode vector) target::subtag-u8-vector) + (multiple-value-bind (array offset) + (array-data-and-offset vector) + (unless (= (typecode array) target::subtag-u8-vector) + (report-bad-arg vector '(array (unsgigned-byte 8) (*)))) + (setq vector array + start (+ start offset) + end (+ end offset)))) + (let* ((encoding (get-character-encoding + (external-format-character-encoding + (normalize-external-format t external-format))))) + (multiple-value-bind (nchars last-octet) + (%count-characters-in-octet-vector vector start end encoding) + (if (not string-p) + (setq string (make-string nchars)) + (progn + (unless (= (typecode string) target::subtag-simple-base-string) + (report-bad-arg string 'simple-string)) + (unless (>= (length string) nchars) + (error "String ~s is too small; ~d characters are needed." + string nchars)))) + (funcall (character-encoding-vector-decode-function encoding) + vector + start + (- last-octet start) + string) + (values string last-octet)))) + + +(defun string-encoded-length-in-bytes (encoding string start end) + (if (typep string 'simple-base-string) + (funcall (character-encoding-octets-in-string-function encoding) + string + (or start 0) + (or end (length string))) + (let* ((s (string string))) + (multiple-value-bind (data offset) (array-data-and-offset s) + (funcall (character-encoding-octets-in-string-function encoding) + data + (+ offset (or start 0)) + (+ offset (or end (length s)))))))) + +;;; Same as above, but add the length of a trailing 0 code-unit. +(defun cstring-encoded-length-in-bytes (encoding string start end) + (+ (ash (character-encoding-code-unit-size encoding) -3) ; NUL terminator + (string-encoded-length-in-bytes encoding string start end))) + + + +(defun encode-string-to-memory (encoding pointer offset string start end) + (if (typep string 'simple-base-string) + (funcall (character-encoding-memory-encode-function encoding) + string pointer offset (or start 0) (or end (length string))) + (let* ((s (string string))) + (multiple-value-bind (data data-offset) + (array-data-and-offset s) + (funcall (character-encoding-memory-encode-function encoding) + data pointer offset (+ data-offset (or start 0)) (+ data-offset (or end (length s)))))))) + +(defun get-encoded-string (encoding-name pointer noctets) + (let* ((encoding (ensure-character-encoding encoding-name))) + (multiple-value-bind (nchars nused) + (funcall (character-encoding-length-of-memory-encoding-function encoding) + pointer + noctets + 0) + (let* ((string (make-string nchars))) + (funcall (character-encoding-memory-decode-function encoding) + pointer + nused + 0 + string) + string)))) + + +(defun get-encoded-cstring (encoding-name pointer) + (let* ((encoding (ensure-character-encoding encoding-name))) + (get-encoded-string + encoding + pointer + (ecase (character-encoding-code-unit-size encoding) + (8 (%cstrlen pointer)) + (16 (do* ((i 0 (+ i 2))) + ((= 0 (%get-unsigned-word pointer i)) + (return i)) + (declare (fixnum i)))) + (32 (do* ((i 0 (+ i 4))) + ((= 0 (%get-unsigned-long pointer i)) + (return i)) + (declare (fixnum i)))))))) + + + + + + + +;;; This is an array of 256 integers, that (sparsely) encodes 64K bits. +;;; (There might be as many as 256 significant bits in some of entries +;;; in this table.) +(defstatic *bmp-combining-bitmap* + #( + #x00 + #x00 + #x00 + #xFFFF0000FFFFFFFFFFFFFFFFFFFF + #x37800000000000000000000000000000000 + #x16BBFFFFFBFFFE000000000000000000000000000000000000 + #x3D9FFFC00000000000000000000000010000003FF8000000000000000000 + #x1FFC00000000000000000000007FFFFFF000000020000 + + #x00 + #xC0080399FD00000000000000E0000000C001E3FFFD00000000000000E + #x3BBFD00000000000000E0003000000003987D000000000000004 + #x803DC7C0000000000000040000000000C0398FD00000000000000E + #x603DDFC00000000000000C0000000000603DDFC00000000000000E + #xC0000FF5F8400000000000000000C0000000000803DCFC00000000000000C + #x3F001BF20000000000000000000000007F8007F2000000000000 + #x401FFFFFFFFEFF00DFFFFE000000000000C2A0000003000000 + + #x3C0000003C7F00000000000 + #x7FFFFFF0000000000003FFFFE000000000000000000000000 + #x00 + #x00 + #x00 + #x00 + #x00 + #xFFFFFFFF0000000000000000C0000000C0000001C0000001C0000 + + #x2000000000000000000000000000000000000003800 + #x00 + #x00 + #x00 + #x00 + #x00 + #x00 + #x00 + + #x7FFFFFF0000000000000000000000000000000000000000000000000000 + #x00 + #x00 + #x00 + #x00 + #x00 + #x00 + #x00 + + #x00 + #x00 + #x00 + #x00 + #x00 + #x00 + #x00 + #x00 + + #x600000000000000000000000000FC0000000000 + #x00 + #x00 + #x00 + #x00 + #x00 + #x00 + #x00 + + #x00 + #x00 + #x00 + #x00 + #x00 + #x00 + #x00 + #x00 + + #x00 + #x00 + #x00 + #x00 + #x00 + #x00 + #x00 + #x00 + + #x00 + #x00 + #x00 + #x00 + #x00 + #x00 + #x00 + #x00 + + #x00 + #x00 + #x00 + #x00 + #x00 + #x00 + #x00 + #x00 + + #x00 + #x00 + #x00 + #x00 + #x00 + #x00 + #x00 + #x00 + + #x00 + #x00 + #x00 + #x00 + #x00 + #x00 + #x00 + #x00 + + #x00 + #x00 + #x00 + #x00 + #x00 + #x00 + #x00 + #x00 + + #x00 + #x00 + #x00 + #x00 + #x00 + #x00 + #x00 + #x00 + + #x00 + #x00 + #x00 + #x00 + #x00 + #x00 + #x00 + #x00 + + #x00 + #x00 + #x00 + #x00 + #x00 + #x00 + #x00 + #x00 + + #x00 + #x00 + #x00 + #x00 + #x00 + #x00 + #x00 + #x00 + + #x00 + #x00 + #x00 + #x00 + #x00 + #x00 + #x00 + #x00 + + #x00 + #x00 + #x00 + #x00 + #x00 + #x00 + #x00 + #x00 + + #x00 + #x00 + #x00 + #x00 + #x00 + #x00 + #x00 + #x00 + + #x00 + #x00 + #x00 + #x00 + #x00 + #x00 + #x00 + #x00 + + #x00 + #x00 + #x00 + #x00 + #x00 + #x00 + #x00 + #x00 + + #x00 + #x00 + #x00 + #x00 + #x00 + #x00 + #x00 + #x00 + + #x00 + #x00 + #x00 + #x00 + #x00 + #x00 + #x00 + #x00 + + #x00 + #x00 + #x00 + #x00 + #x00 + #x00 + #x00 + #x00 + + #x00 + #x00 + #x00 + #x00 + #x00 + #x00 + #x00 + #x00 + + #x00 + #x00 + #x00 + #x00 + #x00 + #x00 + #x00 + #x00 + + #x00 + #x00 + #x00 + #x00 + #x00 + #x00 + #x00 + #x00 + + #x00 + #x00 + #x00 + #x00 + #x00 + #x00 + #x00 + #x00 + + #x00 + #x00 + #x00 + #x00 + #x00 + #x00 + #x00 + #x00 + + #x00 + #x00 + #x00 + #x40000000 + #x00 + #x00 + #xF0000FFFF + #x00)) + +(defun is-combinable (char) + (let* ((code (char-code char))) + (declare (type (mod #x110000) code)) + (when (< code #x1000) + (logbitp (ldb (byte 8 0) code) + (svref *bmp-combining-bitmap* (ldb (byte 8 8) code)))))) + +(defstatic *bmp-combining-chars* + #(#\Combining_Grave_Accent + #\Combining_Acute_Accent + #\Combining_Circumflex_Accent + #\Combining_Tilde + #\Combining_Macron + #\Combining_Breve + #\Combining_Dot_Above + #\Combining_Diaeresis + #\Combining_Hook_Above + #\Combining_Ring_Above + #\Combining_Double_Acute_Accent + #\Combining_Caron + #\Combining_Double_Grave_Accent + #\Combining_Inverted_Breve + #\Combining_Comma_Above + #\Combining_Reversed_Comma_Above + #\Combining_Horn + #\Combining_Dot_Below + #\Combining_Diaeresis_Below + #\Combining_Ring_Below + #\Combining_Comma_Below + #\Combining_Cedilla + #\Combining_Ogonek + #\Combining_Circumflex_Accent_Below + #\Combining_Breve_Below + #\Combining_Tilde_Below + #\Combining_Macron_Below + #\Combining_Long_Solidus_Overlay + #\Combining_Greek_Perispomeni + #\Combining_Greek_Ypogegrammeni + #\Arabic_Maddah_Above + #\Arabic_Hamza_Above + #\Arabic_Hamza_Below + #\U+093C + #\U+09BE + #\U+09D7 + #\U+0B3E + #\U+0B56 + #\U+0B57 + #\U+0BBE + #\U+0BD7 + #\U+0C56 + #\U+0CC2 + #\U+0CD5 + #\U+0CD6 + #\U+0D3E + #\U+0D57 + #\U+0DCA + #\U+0DCF + #\U+0DDF + #\U+102E + #\U+3099 + #\U+309A)) + +(defstatic *bmp-combining-base-chars* + #( + ;; #\Combining_Grave_Accent + + #(#\A #\E #\I #\N #\O #\U #\W #\Y #\a #\e #\i #\n #\o #\u #\w #\y + #\Diaeresis #\Latin_Capital_Letter_A_With_Circumflex + #\Latin_Capital_Letter_E_With_Circumflex + #\Latin_Capital_Letter_O_With_Circumflex + #\Latin_Capital_Letter_U_With_Diaeresis + #\Latin_Small_Letter_A_With_Circumflex + #\Latin_Small_Letter_E_With_Circumflex + #\Latin_Small_Letter_O_With_Circumflex + #\Latin_Small_Letter_U_With_Diaeresis + #\Latin_Capital_Letter_A_With_Breve #\Latin_Small_Letter_A_With_Breve + #\Latin_Capital_Letter_E_With_Macron + #\Latin_Small_Letter_E_With_Macron + #\Latin_Capital_Letter_O_With_Macron + #\Latin_Small_Letter_O_With_Macron #\Latin_Capital_Letter_O_With_Horn + #\Latin_Small_Letter_O_With_Horn #\Latin_Capital_Letter_U_With_Horn + #\Latin_Small_Letter_U_With_Horn #\Greek_Capital_Letter_Alpha + #\Greek_Capital_Letter_Epsilon #\Greek_Capital_Letter_Eta + #\Greek_Capital_Letter_Iota #\Greek_Capital_Letter_Omicron + #\Greek_Capital_Letter_Upsilon #\Greek_Capital_Letter_Omega + #\Greek_Small_Letter_Alpha #\Greek_Small_Letter_Epsilon + #\Greek_Small_Letter_Eta #\Greek_Small_Letter_Iota + #\Greek_Small_Letter_Omicron #\Greek_Small_Letter_Upsilon + #\Greek_Small_Letter_Omega #\Greek_Small_Letter_Iota_With_Dialytika + #\Greek_Small_Letter_Upsilon_With_Dialytika + #\Cyrillic_Capital_Letter_Ie #\Cyrillic_Capital_Letter_I + #\Cyrillic_Small_Letter_Ie #\Cyrillic_Small_Letter_I #\U+1F00 #\U+1F01 + #\U+1F08 #\U+1F09 #\U+1F10 #\U+1F11 #\U+1F18 #\U+1F19 #\U+1F20 + #\U+1F21 #\U+1F28 #\U+1F29 #\U+1F30 #\U+1F31 #\U+1F38 #\U+1F39 + #\U+1F40 #\U+1F41 #\U+1F48 #\U+1F49 #\U+1F50 #\U+1F51 #\U+1F59 + #\U+1F60 #\U+1F61 #\U+1F68 #\U+1F69 #\U+1FBF #\U+1FFE) + + + ;; #\Combining_Acute_Accent + + #(#\A #\C #\E #\G #\I #\K #\L #\M #\N #\O #\P #\R #\S #\U #\W #\Y #\Z + #\a #\c #\e #\g #\i #\k #\l #\m #\n #\o #\p #\r #\s #\u #\w #\y #\z + #\Diaeresis #\Latin_Capital_Letter_A_With_Circumflex + #\Latin_Capital_Letter_A_With_Ring_Above #\Latin_Capital_Letter_Ae + #\Latin_Capital_Letter_C_With_Cedilla + #\Latin_Capital_Letter_E_With_Circumflex + #\Latin_Capital_Letter_I_With_Diaeresis + #\Latin_Capital_Letter_O_With_Circumflex + #\Latin_Capital_Letter_O_With_Tilde + #\Latin_Capital_Letter_O_With_Stroke + #\Latin_Capital_Letter_U_With_Diaeresis + #\Latin_Small_Letter_A_With_Circumflex + #\Latin_Small_Letter_A_With_Ring_Above #\Latin_Small_Letter_Ae + #\Latin_Small_Letter_C_With_Cedilla + #\Latin_Small_Letter_E_With_Circumflex + #\Latin_Small_Letter_I_With_Diaeresis + #\Latin_Small_Letter_O_With_Circumflex + #\Latin_Small_Letter_O_With_Tilde #\Latin_Small_Letter_O_With_Stroke + #\Latin_Small_Letter_U_With_Diaeresis + #\Latin_Capital_Letter_A_With_Breve #\Latin_Small_Letter_A_With_Breve + #\Latin_Capital_Letter_E_With_Macron + #\Latin_Small_Letter_E_With_Macron + #\Latin_Capital_Letter_O_With_Macron + #\Latin_Small_Letter_O_With_Macron #\Latin_Capital_Letter_U_With_Tilde + #\Latin_Small_Letter_U_With_Tilde #\Latin_Capital_Letter_O_With_Horn + #\Latin_Small_Letter_O_With_Horn #\Latin_Capital_Letter_U_With_Horn + #\Latin_Small_Letter_U_With_Horn #\Greek_Capital_Letter_Alpha + #\Greek_Capital_Letter_Epsilon #\Greek_Capital_Letter_Eta + #\Greek_Capital_Letter_Iota #\Greek_Capital_Letter_Omicron + #\Greek_Capital_Letter_Upsilon #\Greek_Capital_Letter_Omega + #\Greek_Small_Letter_Alpha #\Greek_Small_Letter_Epsilon + #\Greek_Small_Letter_Eta #\Greek_Small_Letter_Iota + #\Greek_Small_Letter_Omicron #\Greek_Small_Letter_Upsilon + #\Greek_Small_Letter_Omega #\Greek_Small_Letter_Iota_With_Dialytika + #\Greek_Small_Letter_Upsilon_With_Dialytika + #\Greek_Upsilon_With_Hook_Symbol #\Cyrillic_Capital_Letter_Ghe + #\Cyrillic_Capital_Letter_Ka #\Cyrillic_Small_Letter_Ghe + #\Cyrillic_Small_Letter_Ka #\U+1F00 #\U+1F01 #\U+1F08 #\U+1F09 + #\U+1F10 #\U+1F11 #\U+1F18 #\U+1F19 #\U+1F20 #\U+1F21 #\U+1F28 + #\U+1F29 #\U+1F30 #\U+1F31 #\U+1F38 #\U+1F39 #\U+1F40 #\U+1F41 + #\U+1F48 #\U+1F49 #\U+1F50 #\U+1F51 #\U+1F59 #\U+1F60 #\U+1F61 + #\U+1F68 #\U+1F69 #\U+1FBF #\U+1FFE) + + + ;; #\Combining_Circumflex_Accent + + #(#\A #\C #\E #\G #\H #\I #\J #\O #\S #\U #\W #\Y #\Z #\a #\c #\e #\g + #\h #\i #\j #\o #\s #\u #\w #\y #\z #\U+1EA0 #\U+1EA1 #\U+1EB8 + #\U+1EB9 #\U+1ECC #\U+1ECD) + + + ;; #\Combining_Tilde + + #(#\A #\E #\I #\N #\O #\U #\V #\Y #\a #\e #\i #\n #\o #\u #\v #\y + #\Latin_Capital_Letter_A_With_Circumflex + #\Latin_Capital_Letter_E_With_Circumflex + #\Latin_Capital_Letter_O_With_Circumflex + #\Latin_Small_Letter_A_With_Circumflex + #\Latin_Small_Letter_E_With_Circumflex + #\Latin_Small_Letter_O_With_Circumflex + #\Latin_Capital_Letter_A_With_Breve #\Latin_Small_Letter_A_With_Breve + #\Latin_Capital_Letter_O_With_Horn #\Latin_Small_Letter_O_With_Horn + #\Latin_Capital_Letter_U_With_Horn #\Latin_Small_Letter_U_With_Horn) + + + ;; #\Combining_Macron + + #(#\A #\E #\G #\I #\O #\U #\Y #\a #\e #\g #\i #\o #\u #\y + #\Latin_Capital_Letter_A_With_Diaeresis #\Latin_Capital_Letter_Ae + #\Latin_Capital_Letter_O_With_Tilde + #\Latin_Capital_Letter_O_With_Diaeresis + #\Latin_Capital_Letter_U_With_Diaeresis + #\Latin_Small_Letter_A_With_Diaeresis #\Latin_Small_Letter_Ae + #\Latin_Small_Letter_O_With_Tilde + #\Latin_Small_Letter_O_With_Diaeresis + #\Latin_Small_Letter_U_With_Diaeresis + #\Latin_Capital_Letter_O_With_Ogonek + #\Latin_Small_Letter_O_With_Ogonek + #\Latin_Capital_Letter_A_With_Dot_Above + #\Latin_Small_Letter_A_With_Dot_Above + #\Latin_Capital_Letter_O_With_Dot_Above + #\Latin_Small_Letter_O_With_Dot_Above #\Greek_Capital_Letter_Alpha + #\Greek_Capital_Letter_Iota #\Greek_Capital_Letter_Upsilon + #\Greek_Small_Letter_Alpha #\Greek_Small_Letter_Iota + #\Greek_Small_Letter_Upsilon #\Cyrillic_Capital_Letter_I + #\Cyrillic_Capital_Letter_U #\Cyrillic_Small_Letter_I + #\Cyrillic_Small_Letter_U #\U+1E36 #\U+1E37 #\U+1E5A #\U+1E5B) + + + ;; #\Combining_Breve + + #(#\A #\E #\G #\I #\O #\U #\a #\e #\g #\i #\o #\u + #\Latin_Capital_Letter_E_With_Cedilla + #\Latin_Small_Letter_E_With_Cedilla #\Greek_Capital_Letter_Alpha + #\Greek_Capital_Letter_Iota #\Greek_Capital_Letter_Upsilon + #\Greek_Small_Letter_Alpha #\Greek_Small_Letter_Iota + #\Greek_Small_Letter_Upsilon #\Cyrillic_Capital_Letter_A + #\Cyrillic_Capital_Letter_Ie #\Cyrillic_Capital_Letter_Zhe + #\Cyrillic_Capital_Letter_I #\Cyrillic_Capital_Letter_U + #\Cyrillic_Small_Letter_A #\Cyrillic_Small_Letter_Ie + #\Cyrillic_Small_Letter_Zhe #\Cyrillic_Small_Letter_I + #\Cyrillic_Small_Letter_U #\U+1EA0 #\U+1EA1) + + + ;; #\Combining_Dot_Above + + #(#\A #\B #\C #\D #\E #\F #\G #\H #\I #\M #\N #\O #\P #\R #\S #\T #\W + #\X #\Y #\Z #\a #\b #\c #\d #\e #\f #\g #\h #\m #\n #\o #\p #\r #\s + #\t #\w #\x #\y #\z #\Latin_Capital_Letter_S_With_Acute + #\Latin_Small_Letter_S_With_Acute #\Latin_Capital_Letter_S_With_Caron + #\Latin_Small_Letter_S_With_Caron #\Latin_Small_Letter_Long_S #\U+1E62 + #\U+1E63) + + + ;; #\Combining_Diaeresis + + #(#\A #\E #\H #\I #\O #\U #\W #\X #\Y #\a #\e #\h #\i #\o #\t #\u #\w + #\x #\y #\Latin_Capital_Letter_O_With_Tilde + #\Latin_Small_Letter_O_With_Tilde #\Latin_Capital_Letter_U_With_Macron + #\Latin_Small_Letter_U_With_Macron #\Greek_Capital_Letter_Iota + #\Greek_Capital_Letter_Upsilon #\Greek_Small_Letter_Iota + #\Greek_Small_Letter_Upsilon #\Greek_Upsilon_With_Hook_Symbol + #\Cyrillic_Capital_Letter_Byelorussian-Ukrainian_I + #\Cyrillic_Capital_Letter_A #\Cyrillic_Capital_Letter_Ie + #\Cyrillic_Capital_Letter_Zhe #\Cyrillic_Capital_Letter_Ze + #\Cyrillic_Capital_Letter_I #\Cyrillic_Capital_Letter_O + #\Cyrillic_Capital_Letter_U #\Cyrillic_Capital_Letter_Che + #\Cyrillic_Capital_Letter_Yeru #\Cyrillic_Capital_Letter_E + #\Cyrillic_Small_Letter_A #\Cyrillic_Small_Letter_Ie + #\Cyrillic_Small_Letter_Zhe #\Cyrillic_Small_Letter_Ze + #\Cyrillic_Small_Letter_I #\Cyrillic_Small_Letter_O + #\Cyrillic_Small_Letter_U #\Cyrillic_Small_Letter_Che + #\Cyrillic_Small_Letter_Yeru #\Cyrillic_Small_Letter_E + #\Cyrillic_Small_Letter_Byelorussian-Ukrainian_I + #\Cyrillic_Capital_Letter_Schwa #\Cyrillic_Small_Letter_Schwa + #\Cyrillic_Capital_Letter_Barred_O #\Cyrillic_Small_Letter_Barred_O) + + + ;; #\Combining_Hook_Above + + #(#\A #\E #\I #\O #\U #\Y #\a #\e #\i #\o #\u #\y + #\Latin_Capital_Letter_A_With_Circumflex + #\Latin_Capital_Letter_E_With_Circumflex + #\Latin_Capital_Letter_O_With_Circumflex + #\Latin_Small_Letter_A_With_Circumflex + #\Latin_Small_Letter_E_With_Circumflex + #\Latin_Small_Letter_O_With_Circumflex + #\Latin_Capital_Letter_A_With_Breve #\Latin_Small_Letter_A_With_Breve + #\Latin_Capital_Letter_O_With_Horn #\Latin_Small_Letter_O_With_Horn + #\Latin_Capital_Letter_U_With_Horn #\Latin_Small_Letter_U_With_Horn) + + + ;; #\Combining_Ring_Above + + #(#\A #\U #\a #\u #\w #\y) + + + ;; #\Combining_Double_Acute_Accent + + #(#\O #\U #\o #\u #\Cyrillic_Capital_Letter_U + #\Cyrillic_Small_Letter_U) + + + ;; #\Combining_Caron + + #(#\A #\C #\D #\E #\G #\H #\I #\K #\L #\N #\O #\R #\S #\T #\U #\Z #\a + #\c #\d #\e #\g #\h #\i #\j #\k #\l #\n #\o #\r #\s #\t #\u #\z + #\Latin_Capital_Letter_U_With_Diaeresis + #\Latin_Small_Letter_U_With_Diaeresis #\Latin_Capital_Letter_Ezh + #\Latin_Small_Letter_Ezh) + + + ;; #\Combining_Double_Grave_Accent + + #(#\A #\E #\I #\O #\R #\U #\a #\e #\i #\o #\r #\u + #\Cyrillic_Capital_Letter_Izhitsa #\Cyrillic_Small_Letter_Izhitsa) + + + ;; #\Combining_Inverted_Breve + + #(#\A #\E #\I #\O #\R #\U #\a #\e #\i #\o #\r #\u) + + + ;; #\Combining_Comma_Above + + #(#\Greek_Capital_Letter_Alpha #\Greek_Capital_Letter_Epsilon + #\Greek_Capital_Letter_Eta #\Greek_Capital_Letter_Iota + #\Greek_Capital_Letter_Omicron #\Greek_Capital_Letter_Omega + #\Greek_Small_Letter_Alpha #\Greek_Small_Letter_Epsilon + #\Greek_Small_Letter_Eta #\Greek_Small_Letter_Iota + #\Greek_Small_Letter_Omicron #\Greek_Small_Letter_Rho + #\Greek_Small_Letter_Upsilon #\Greek_Small_Letter_Omega) + + + ;; #\Combining_Reversed_Comma_Above + + #(#\Greek_Capital_Letter_Alpha #\Greek_Capital_Letter_Epsilon + #\Greek_Capital_Letter_Eta #\Greek_Capital_Letter_Iota + #\Greek_Capital_Letter_Omicron #\Greek_Capital_Letter_Rho + #\Greek_Capital_Letter_Upsilon #\Greek_Capital_Letter_Omega + #\Greek_Small_Letter_Alpha #\Greek_Small_Letter_Epsilon + #\Greek_Small_Letter_Eta #\Greek_Small_Letter_Iota + #\Greek_Small_Letter_Omicron #\Greek_Small_Letter_Rho + #\Greek_Small_Letter_Upsilon #\Greek_Small_Letter_Omega) + + + ;; #\Combining_Horn + + #(#\O #\U #\o #\u) + + + ;; #\Combining_Dot_Below + + #(#\A #\B #\D #\E #\H #\I #\K #\L #\M #\N #\O #\R #\S #\T #\U #\V #\W + #\Y #\Z #\a #\b #\d #\e #\h #\i #\k #\l #\m #\n #\o #\r #\s #\t #\u + #\v #\w #\y #\z #\Latin_Capital_Letter_O_With_Horn + #\Latin_Small_Letter_O_With_Horn #\Latin_Capital_Letter_U_With_Horn + #\Latin_Small_Letter_U_With_Horn) + + + ;; #\Combining_Diaeresis_Below + + #(#\U #\u) + + + ;; #\Combining_Ring_Below + + #(#\A #\a) + + + ;; #\Combining_Comma_Below + + #(#\S #\T #\s #\t) + + + ;; #\Combining_Cedilla + + #(#\C #\D #\E #\G #\H #\K #\L #\N #\R #\S #\T #\c #\d #\e #\g #\h #\k + #\l #\n #\r #\s #\t) + + + ;; #\Combining_Ogonek + + #(#\A #\E #\I #\O #\U #\a #\e #\i #\o #\u) + + + ;; #\Combining_Circumflex_Accent_Below + + #(#\D #\E #\L #\N #\T #\U #\d #\e #\l #\n #\t #\u) + + + ;; #\Combining_Breve_Below + + #(#\H #\h) + + + ;; #\Combining_Tilde_Below + + #(#\E #\I #\U #\e #\i #\u) + + + ;; #\Combining_Macron_Below + + #(#\B #\D #\K #\L #\N #\R #\T #\Z #\b #\d #\h #\k #\l #\n #\r #\t #\z) + + + ;; #\Combining_Long_Solidus_Overlay + + #(#\< #\= #\> #\U+2190 #\U+2192 #\U+2194 #\U+21D0 #\U+21D2 #\U+21D4 + #\U+2203 #\U+2208 #\U+220B #\U+2223 #\U+2225 #\U+223C #\U+2243 + #\U+2245 #\U+2248 #\U+224D #\U+2261 #\U+2264 #\U+2265 #\U+2272 + #\U+2273 #\U+2276 #\U+2277 #\U+227A #\U+227B #\U+227C #\U+227D + #\U+2282 #\U+2283 #\U+2286 #\U+2287 #\U+2291 #\U+2292 #\U+22A2 + #\U+22A8 #\U+22A9 #\U+22AB #\U+22B2 #\U+22B3 #\U+22B4 #\U+22B5) + + + ;; #\Combining_Greek_Perispomeni + + #(#\Diaeresis #\Greek_Small_Letter_Alpha #\Greek_Small_Letter_Eta + #\Greek_Small_Letter_Iota #\Greek_Small_Letter_Upsilon + #\Greek_Small_Letter_Omega #\Greek_Small_Letter_Iota_With_Dialytika + #\Greek_Small_Letter_Upsilon_With_Dialytika #\U+1F00 #\U+1F01 #\U+1F08 + #\U+1F09 #\U+1F20 #\U+1F21 #\U+1F28 #\U+1F29 #\U+1F30 #\U+1F31 + #\U+1F38 #\U+1F39 #\U+1F50 #\U+1F51 #\U+1F59 #\U+1F60 #\U+1F61 + #\U+1F68 #\U+1F69 #\U+1FBF #\U+1FFE) + + + ;; #\Combining_Greek_Ypogegrammeni + + #(#\Greek_Capital_Letter_Alpha #\Greek_Capital_Letter_Eta + #\Greek_Capital_Letter_Omega #\Greek_Small_Letter_Alpha_With_Tonos + #\Greek_Small_Letter_Eta_With_Tonos #\Greek_Small_Letter_Alpha + #\Greek_Small_Letter_Eta #\Greek_Small_Letter_Omega + #\Greek_Small_Letter_Omega_With_Tonos #\U+1F00 #\U+1F01 #\U+1F02 + #\U+1F03 #\U+1F04 #\U+1F05 #\U+1F06 #\U+1F07 #\U+1F08 #\U+1F09 + #\U+1F0A #\U+1F0B #\U+1F0C #\U+1F0D #\U+1F0E #\U+1F0F #\U+1F20 + #\U+1F21 #\U+1F22 #\U+1F23 #\U+1F24 #\U+1F25 #\U+1F26 #\U+1F27 + #\U+1F28 #\U+1F29 #\U+1F2A #\U+1F2B #\U+1F2C #\U+1F2D #\U+1F2E + #\U+1F2F #\U+1F60 #\U+1F61 #\U+1F62 #\U+1F63 #\U+1F64 #\U+1F65 + #\U+1F66 #\U+1F67 #\U+1F68 #\U+1F69 #\U+1F6A #\U+1F6B #\U+1F6C + #\U+1F6D #\U+1F6E #\U+1F6F #\U+1F70 #\U+1F74 #\U+1F7C #\U+1FB6 + #\U+1FC6 #\U+1FF6) + + + ;; #\Arabic_Maddah_Above + + #(#\Arabic_Letter_Alef) + + + ;; #\Arabic_Hamza_Above + + #(#\Arabic_Letter_Alef #\Arabic_Letter_Waw #\Arabic_Letter_Yeh + #\Arabic_Letter_Heh_Goal #\Arabic_Letter_Yeh_Barree + #\Arabic_Letter_Ae) + + + ;; #\Arabic_Hamza_Below + + #(#\Arabic_Letter_Alef) + + + ;; #\U+093C + + #(#\U+0928 #\U+0930 #\U+0933) + + + ;; #\U+09BE + + #(#\U+09C7) + + + ;; #\U+09D7 + + #(#\U+09C7) + + + ;; #\U+0B3E + + #(#\U+0B47) + + + ;; #\U+0B56 + + #(#\U+0B47) + + + ;; #\U+0B57 + + #(#\U+0B47) + + + ;; #\U+0BBE + + #(#\U+0BC6 #\U+0BC7) + + + ;; #\U+0BD7 + + #(#\U+0B92 #\U+0BC6) + + + ;; #\U+0C56 + + #(#\U+0C46) + + + ;; #\U+0CC2 + + #(#\U+0CC6) + + + ;; #\U+0CD5 + + #(#\U+0CBF #\U+0CC6 #\U+0CCA) + + + ;; #\U+0CD6 + + #(#\U+0CC6) + + + ;; #\U+0D3E + + #(#\U+0D46 #\U+0D47) + + + ;; #\U+0D57 + + #(#\U+0D46) + + + ;; #\U+0DCA + + #(#\U+0DD9 #\U+0DDC) + + + ;; #\U+0DCF + + #(#\U+0DD9) + + + ;; #\U+0DDF + + #(#\U+0DD9) + + + ;; #\U+102E + + #(#\U+1025) + + + ;; #\U+3099 + + #(#\U+3046 #\U+304B #\U+304D #\U+304F #\U+3051 #\U+3053 #\U+3055 + #\U+3057 #\U+3059 #\U+305B #\U+305D #\U+305F #\U+3061 #\U+3064 + #\U+3066 #\U+3068 #\U+306F #\U+3072 #\U+3075 #\U+3078 #\U+307B + #\U+309D #\U+30A6 #\U+30AB #\U+30AD #\U+30AF #\U+30B1 #\U+30B3 + #\U+30B5 #\U+30B7 #\U+30B9 #\U+30BB #\U+30BD #\U+30BF #\U+30C1 + #\U+30C4 #\U+30C6 #\U+30C8 #\U+30CF #\U+30D2 #\U+30D5 #\U+30D8 + #\U+30DB #\U+30EF #\U+30F0 #\U+30F1 #\U+30F2 #\U+30FD) + + + ;; #\U+309A + + #(#\U+306F #\U+3072 #\U+3075 #\U+3078 #\U+307B #\U+30CF #\U+30D2 + #\U+30D5 #\U+30D8 #\U+30DB) + )) + +(defstatic *bmp-precombined-chars* + #( + + ;; #\Combining_Grave_Accent + + #(#\Latin_Capital_Letter_A_With_Grave + #\Latin_Capital_Letter_E_With_Grave + #\Latin_Capital_Letter_I_With_Grave + #\Latin_Capital_Letter_N_With_Grave + #\Latin_Capital_Letter_O_With_Grave + #\Latin_Capital_Letter_U_With_Grave #\U+1E80 #\U+1EF2 + #\Latin_Small_Letter_A_With_Grave #\Latin_Small_Letter_E_With_Grave + #\Latin_Small_Letter_I_With_Grave #\Latin_Small_Letter_N_With_Grave + #\Latin_Small_Letter_O_With_Grave #\Latin_Small_Letter_U_With_Grave + #\U+1E81 #\U+1EF3 #\U+1FED #\U+1EA6 #\U+1EC0 #\U+1ED2 + #\Latin_Capital_Letter_U_With_Diaeresis_And_Grave #\U+1EA7 #\U+1EC1 + #\U+1ED3 #\Latin_Small_Letter_U_With_Diaeresis_And_Grave #\U+1EB0 + #\U+1EB1 #\U+1E14 #\U+1E15 #\U+1E50 #\U+1E51 #\U+1EDC #\U+1EDD + #\U+1EEA #\U+1EEB #\U+1FBA #\U+1FC8 #\U+1FCA #\U+1FDA #\U+1FF8 + #\U+1FEA #\U+1FFA #\U+1F70 #\U+1F72 #\U+1F74 #\U+1F76 #\U+1F78 + #\U+1F7A #\U+1F7C #\U+1FD2 #\U+1FE2 + #\Cyrillic_Capital_Letter_Ie_With_Grave + #\Cyrillic_Capital_Letter_I_With_Grave + #\Cyrillic_Small_Letter_Ie_With_Grave + #\Cyrillic_Small_Letter_I_With_Grave #\U+1F02 #\U+1F03 #\U+1F0A + #\U+1F0B #\U+1F12 #\U+1F13 #\U+1F1A #\U+1F1B #\U+1F22 #\U+1F23 + #\U+1F2A #\U+1F2B #\U+1F32 #\U+1F33 #\U+1F3A #\U+1F3B #\U+1F42 + #\U+1F43 #\U+1F4A #\U+1F4B #\U+1F52 #\U+1F53 #\U+1F5B #\U+1F62 + #\U+1F63 #\U+1F6A #\U+1F6B #\U+1FCD #\U+1FDD) + + + ;; #\Combining_Acute_Accent + + #(#\Latin_Capital_Letter_A_With_Acute + #\Latin_Capital_Letter_C_With_Acute + #\Latin_Capital_Letter_E_With_Acute + #\Latin_Capital_Letter_G_With_Acute + #\Latin_Capital_Letter_I_With_Acute #\U+1E30 + #\Latin_Capital_Letter_L_With_Acute #\U+1E3E + #\Latin_Capital_Letter_N_With_Acute + #\Latin_Capital_Letter_O_With_Acute #\U+1E54 + #\Latin_Capital_Letter_R_With_Acute + #\Latin_Capital_Letter_S_With_Acute + #\Latin_Capital_Letter_U_With_Acute #\U+1E82 + #\Latin_Capital_Letter_Y_With_Acute + #\Latin_Capital_Letter_Z_With_Acute #\Latin_Small_Letter_A_With_Acute + #\Latin_Small_Letter_C_With_Acute #\Latin_Small_Letter_E_With_Acute + #\Latin_Small_Letter_G_With_Acute #\Latin_Small_Letter_I_With_Acute + #\U+1E31 #\Latin_Small_Letter_L_With_Acute #\U+1E3F + #\Latin_Small_Letter_N_With_Acute #\Latin_Small_Letter_O_With_Acute + #\U+1E55 #\Latin_Small_Letter_R_With_Acute + #\Latin_Small_Letter_S_With_Acute #\Latin_Small_Letter_U_With_Acute + #\U+1E83 #\Latin_Small_Letter_Y_With_Acute + #\Latin_Small_Letter_Z_With_Acute #\Greek_Dialytika_Tonos #\U+1EA4 + #\Latin_Capital_Letter_A_With_Ring_Above_And_Acute + #\Latin_Capital_Letter_Ae_With_Acute #\U+1E08 #\U+1EBE #\U+1E2E + #\U+1ED0 #\U+1E4C #\Latin_Capital_Letter_O_With_Stroke_And_Acute + #\Latin_Capital_Letter_U_With_Diaeresis_And_Acute #\U+1EA5 + #\Latin_Small_Letter_A_With_Ring_Above_And_Acute + #\Latin_Small_Letter_Ae_With_Acute #\U+1E09 #\U+1EBF #\U+1E2F #\U+1ED1 + #\U+1E4D #\Latin_Small_Letter_O_With_Stroke_And_Acute + #\Latin_Small_Letter_U_With_Diaeresis_And_Acute #\U+1EAE #\U+1EAF + #\U+1E16 #\U+1E17 #\U+1E52 #\U+1E53 #\U+1E78 #\U+1E79 #\U+1EDA + #\U+1EDB #\U+1EE8 #\U+1EE9 #\Greek_Capital_Letter_Alpha_With_Tonos + #\Greek_Capital_Letter_Epsilon_With_Tonos + #\Greek_Capital_Letter_Eta_With_Tonos + #\Greek_Capital_Letter_Iota_With_Tonos + #\Greek_Capital_Letter_Omicron_With_Tonos + #\Greek_Capital_Letter_Upsilon_With_Tonos + #\Greek_Capital_Letter_Omega_With_Tonos + #\Greek_Small_Letter_Alpha_With_Tonos + #\Greek_Small_Letter_Epsilon_With_Tonos + #\Greek_Small_Letter_Eta_With_Tonos + #\Greek_Small_Letter_Iota_With_Tonos + #\Greek_Small_Letter_Omicron_With_Tonos + #\Greek_Small_Letter_Upsilon_With_Tonos + #\Greek_Small_Letter_Omega_With_Tonos + #\Greek_Small_Letter_Iota_With_Dialytika_And_Tonos + #\Greek_Small_Letter_Upsilon_With_Dialytika_And_Tonos + #\Greek_Upsilon_With_Acute_And_Hook_Symbol + #\Cyrillic_Capital_Letter_Gje #\Cyrillic_Capital_Letter_Kje + #\Cyrillic_Small_Letter_Gje #\Cyrillic_Small_Letter_Kje #\U+1F04 + #\U+1F05 #\U+1F0C #\U+1F0D #\U+1F14 #\U+1F15 #\U+1F1C #\U+1F1D + #\U+1F24 #\U+1F25 #\U+1F2C #\U+1F2D #\U+1F34 #\U+1F35 #\U+1F3C + #\U+1F3D #\U+1F44 #\U+1F45 #\U+1F4C #\U+1F4D #\U+1F54 #\U+1F55 + #\U+1F5D #\U+1F64 #\U+1F65 #\U+1F6C #\U+1F6D #\U+1FCE #\U+1FDE) + + + ;; #\Combining_Circumflex_Accent + + #(#\Latin_Capital_Letter_A_With_Circumflex + #\Latin_Capital_Letter_C_With_Circumflex + #\Latin_Capital_Letter_E_With_Circumflex + #\Latin_Capital_Letter_G_With_Circumflex + #\Latin_Capital_Letter_H_With_Circumflex + #\Latin_Capital_Letter_I_With_Circumflex + #\Latin_Capital_Letter_J_With_Circumflex + #\Latin_Capital_Letter_O_With_Circumflex + #\Latin_Capital_Letter_S_With_Circumflex + #\Latin_Capital_Letter_U_With_Circumflex + #\Latin_Capital_Letter_W_With_Circumflex + #\Latin_Capital_Letter_Y_With_Circumflex #\U+1E90 + #\Latin_Small_Letter_A_With_Circumflex + #\Latin_Small_Letter_C_With_Circumflex + #\Latin_Small_Letter_E_With_Circumflex + #\Latin_Small_Letter_G_With_Circumflex + #\Latin_Small_Letter_H_With_Circumflex + #\Latin_Small_Letter_I_With_Circumflex + #\Latin_Small_Letter_J_With_Circumflex + #\Latin_Small_Letter_O_With_Circumflex + #\Latin_Small_Letter_S_With_Circumflex + #\Latin_Small_Letter_U_With_Circumflex + #\Latin_Small_Letter_W_With_Circumflex + #\Latin_Small_Letter_Y_With_Circumflex #\U+1E91 #\U+1EAC #\U+1EAD + #\U+1EC6 #\U+1EC7 #\U+1ED8 #\U+1ED9) + + + ;; #\Combining_Tilde + + #(#\Latin_Capital_Letter_A_With_Tilde #\U+1EBC + #\Latin_Capital_Letter_I_With_Tilde + #\Latin_Capital_Letter_N_With_Tilde + #\Latin_Capital_Letter_O_With_Tilde + #\Latin_Capital_Letter_U_With_Tilde #\U+1E7C #\U+1EF8 + #\Latin_Small_Letter_A_With_Tilde #\U+1EBD + #\Latin_Small_Letter_I_With_Tilde #\Latin_Small_Letter_N_With_Tilde + #\Latin_Small_Letter_O_With_Tilde #\Latin_Small_Letter_U_With_Tilde + #\U+1E7D #\U+1EF9 #\U+1EAA #\U+1EC4 #\U+1ED6 #\U+1EAB #\U+1EC5 + #\U+1ED7 #\U+1EB4 #\U+1EB5 #\U+1EE0 #\U+1EE1 #\U+1EEE #\U+1EEF) + + + ;; #\Combining_Macron + + #(#\Latin_Capital_Letter_A_With_Macron + #\Latin_Capital_Letter_E_With_Macron #\U+1E20 + #\Latin_Capital_Letter_I_With_Macron + #\Latin_Capital_Letter_O_With_Macron + #\Latin_Capital_Letter_U_With_Macron + #\Latin_Capital_Letter_Y_With_Macron + #\Latin_Small_Letter_A_With_Macron #\Latin_Small_Letter_E_With_Macron + #\U+1E21 #\Latin_Small_Letter_I_With_Macron + #\Latin_Small_Letter_O_With_Macron #\Latin_Small_Letter_U_With_Macron + #\Latin_Small_Letter_Y_With_Macron + #\Latin_Capital_Letter_A_With_Diaeresis_And_Macron + #\Latin_Capital_Letter_Ae_With_Macron + #\Latin_Capital_Letter_O_With_Tilde_And_Macron + #\Latin_Capital_Letter_O_With_Diaeresis_And_Macron + #\Latin_Capital_Letter_U_With_Diaeresis_And_Macron + #\Latin_Small_Letter_A_With_Diaeresis_And_Macron + #\Latin_Small_Letter_Ae_With_Macron + #\Latin_Small_Letter_O_With_Tilde_And_Macron + #\Latin_Small_Letter_O_With_Diaeresis_And_Macron + #\Latin_Small_Letter_U_With_Diaeresis_And_Macron + #\Latin_Capital_Letter_O_With_Ogonek_And_Macron + #\Latin_Small_Letter_O_With_Ogonek_And_Macron + #\Latin_Capital_Letter_A_With_Dot_Above_And_Macron + #\Latin_Small_Letter_A_With_Dot_Above_And_Macron + #\Latin_Capital_Letter_O_With_Dot_Above_And_Macron + #\Latin_Small_Letter_O_With_Dot_Above_And_Macron #\U+1FB9 #\U+1FD9 + #\U+1FE9 #\U+1FB1 #\U+1FD1 #\U+1FE1 + #\Cyrillic_Capital_Letter_I_With_Macron + #\Cyrillic_Capital_Letter_U_With_Macron + #\Cyrillic_Small_Letter_I_With_Macron + #\Cyrillic_Small_Letter_U_With_Macron #\U+1E38 #\U+1E39 #\U+1E5C + #\U+1E5D) + + + ;; #\Combining_Breve + + #(#\Latin_Capital_Letter_A_With_Breve + #\Latin_Capital_Letter_E_With_Breve + #\Latin_Capital_Letter_G_With_Breve + #\Latin_Capital_Letter_I_With_Breve + #\Latin_Capital_Letter_O_With_Breve + #\Latin_Capital_Letter_U_With_Breve #\Latin_Small_Letter_A_With_Breve + #\Latin_Small_Letter_E_With_Breve #\Latin_Small_Letter_G_With_Breve + #\Latin_Small_Letter_I_With_Breve #\Latin_Small_Letter_O_With_Breve + #\Latin_Small_Letter_U_With_Breve #\U+1E1C #\U+1E1D #\U+1FB8 #\U+1FD8 + #\U+1FE8 #\U+1FB0 #\U+1FD0 #\U+1FE0 + #\Cyrillic_Capital_Letter_A_With_Breve + #\Cyrillic_Capital_Letter_Ie_With_Breve + #\Cyrillic_Capital_Letter_Zhe_With_Breve + #\Cyrillic_Capital_Letter_Short_I #\Cyrillic_Capital_Letter_Short_U + #\Cyrillic_Small_Letter_A_With_Breve + #\Cyrillic_Small_Letter_Ie_With_Breve + #\Cyrillic_Small_Letter_Zhe_With_Breve #\Cyrillic_Small_Letter_Short_I + #\Cyrillic_Small_Letter_Short_U #\U+1EB6 #\U+1EB7) + + + ;; #\Combining_Dot_Above + + #(#\Latin_Capital_Letter_A_With_Dot_Above #\U+1E02 + #\Latin_Capital_Letter_C_With_Dot_Above #\U+1E0A + #\Latin_Capital_Letter_E_With_Dot_Above #\U+1E1E + #\Latin_Capital_Letter_G_With_Dot_Above #\U+1E22 + #\Latin_Capital_Letter_I_With_Dot_Above #\U+1E40 #\U+1E44 + #\Latin_Capital_Letter_O_With_Dot_Above #\U+1E56 #\U+1E58 #\U+1E60 + #\U+1E6A #\U+1E86 #\U+1E8A #\U+1E8E + #\Latin_Capital_Letter_Z_With_Dot_Above + #\Latin_Small_Letter_A_With_Dot_Above #\U+1E03 + #\Latin_Small_Letter_C_With_Dot_Above #\U+1E0B + #\Latin_Small_Letter_E_With_Dot_Above #\U+1E1F + #\Latin_Small_Letter_G_With_Dot_Above #\U+1E23 #\U+1E41 #\U+1E45 + #\Latin_Small_Letter_O_With_Dot_Above #\U+1E57 #\U+1E59 #\U+1E61 + #\U+1E6B #\U+1E87 #\U+1E8B #\U+1E8F + #\Latin_Small_Letter_Z_With_Dot_Above #\U+1E64 #\U+1E65 #\U+1E66 + #\U+1E67 #\U+1E9B #\U+1E68 #\U+1E69) + + + ;; #\Combining_Diaeresis + + #(#\Latin_Capital_Letter_A_With_Diaeresis + #\Latin_Capital_Letter_E_With_Diaeresis #\U+1E26 + #\Latin_Capital_Letter_I_With_Diaeresis + #\Latin_Capital_Letter_O_With_Diaeresis + #\Latin_Capital_Letter_U_With_Diaeresis #\U+1E84 #\U+1E8C + #\Latin_Capital_Letter_Y_With_Diaeresis + #\Latin_Small_Letter_A_With_Diaeresis + #\Latin_Small_Letter_E_With_Diaeresis #\U+1E27 + #\Latin_Small_Letter_I_With_Diaeresis + #\Latin_Small_Letter_O_With_Diaeresis #\U+1E97 + #\Latin_Small_Letter_U_With_Diaeresis #\U+1E85 #\U+1E8D + #\Latin_Small_Letter_Y_With_Diaeresis #\U+1E4E #\U+1E4F #\U+1E7A + #\U+1E7B #\Greek_Capital_Letter_Iota_With_Dialytika + #\Greek_Capital_Letter_Upsilon_With_Dialytika + #\Greek_Small_Letter_Iota_With_Dialytika + #\Greek_Small_Letter_Upsilon_With_Dialytika + #\Greek_Upsilon_With_Diaeresis_And_Hook_Symbol + #\Cyrillic_Capital_Letter_Yi + #\Cyrillic_Capital_Letter_A_With_Diaeresis + #\Cyrillic_Capital_Letter_Io + #\Cyrillic_Capital_Letter_Zhe_With_Diaeresis + #\Cyrillic_Capital_Letter_Ze_With_Diaeresis + #\Cyrillic_Capital_Letter_I_With_Diaeresis + #\Cyrillic_Capital_Letter_O_With_Diaeresis + #\Cyrillic_Capital_Letter_U_With_Diaeresis + #\Cyrillic_Capital_Letter_Che_With_Diaeresis + #\Cyrillic_Capital_Letter_Yeru_With_Diaeresis + #\Cyrillic_Capital_Letter_E_With_Diaeresis + #\Cyrillic_Small_Letter_A_With_Diaeresis #\Cyrillic_Small_Letter_Io + #\Cyrillic_Small_Letter_Zhe_With_Diaeresis + #\Cyrillic_Small_Letter_Ze_With_Diaeresis + #\Cyrillic_Small_Letter_I_With_Diaeresis + #\Cyrillic_Small_Letter_O_With_Diaeresis + #\Cyrillic_Small_Letter_U_With_Diaeresis + #\Cyrillic_Small_Letter_Che_With_Diaeresis + #\Cyrillic_Small_Letter_Yeru_With_Diaeresis + #\Cyrillic_Small_Letter_E_With_Diaeresis #\Cyrillic_Small_Letter_Yi + #\Cyrillic_Capital_Letter_Schwa_With_Diaeresis + #\Cyrillic_Small_Letter_Schwa_With_Diaeresis + #\Cyrillic_Capital_Letter_Barred_O_With_Diaeresis + #\Cyrillic_Small_Letter_Barred_O_With_Diaeresis) + + + ;; #\Combining_Hook_Above + + #(#\U+1EA2 #\U+1EBA #\U+1EC8 #\U+1ECE #\U+1EE6 #\U+1EF6 #\U+1EA3 + #\U+1EBB #\U+1EC9 #\U+1ECF #\U+1EE7 #\U+1EF7 #\U+1EA8 #\U+1EC2 + #\U+1ED4 #\U+1EA9 #\U+1EC3 #\U+1ED5 #\U+1EB2 #\U+1EB3 #\U+1EDE + #\U+1EDF #\U+1EEC #\U+1EED) + + + ;; #\Combining_Ring_Above + + #(#\Latin_Capital_Letter_A_With_Ring_Above + #\Latin_Capital_Letter_U_With_Ring_Above + #\Latin_Small_Letter_A_With_Ring_Above + #\Latin_Small_Letter_U_With_Ring_Above #\U+1E98 #\U+1E99) + + + ;; #\Combining_Double_Acute_Accent + + #(#\Latin_Capital_Letter_O_With_Double_Acute + #\Latin_Capital_Letter_U_With_Double_Acute + #\Latin_Small_Letter_O_With_Double_Acute + #\Latin_Small_Letter_U_With_Double_Acute + #\Cyrillic_Capital_Letter_U_With_Double_Acute + #\Cyrillic_Small_Letter_U_With_Double_Acute) + + + ;; #\Combining_Caron + + #(#\Latin_Capital_Letter_A_With_Caron + #\Latin_Capital_Letter_C_With_Caron + #\Latin_Capital_Letter_D_With_Caron + #\Latin_Capital_Letter_E_With_Caron + #\Latin_Capital_Letter_G_With_Caron + #\Latin_Capital_Letter_H_With_Caron + #\Latin_Capital_Letter_I_With_Caron + #\Latin_Capital_Letter_K_With_Caron + #\Latin_Capital_Letter_L_With_Caron + #\Latin_Capital_Letter_N_With_Caron + #\Latin_Capital_Letter_O_With_Caron + #\Latin_Capital_Letter_R_With_Caron + #\Latin_Capital_Letter_S_With_Caron + #\Latin_Capital_Letter_T_With_Caron + #\Latin_Capital_Letter_U_With_Caron + #\Latin_Capital_Letter_Z_With_Caron #\Latin_Small_Letter_A_With_Caron + #\Latin_Small_Letter_C_With_Caron #\Latin_Small_Letter_D_With_Caron + #\Latin_Small_Letter_E_With_Caron #\Latin_Small_Letter_G_With_Caron + #\Latin_Small_Letter_H_With_Caron #\Latin_Small_Letter_I_With_Caron + #\Latin_Small_Letter_J_With_Caron #\Latin_Small_Letter_K_With_Caron + #\Latin_Small_Letter_L_With_Caron #\Latin_Small_Letter_N_With_Caron + #\Latin_Small_Letter_O_With_Caron #\Latin_Small_Letter_R_With_Caron + #\Latin_Small_Letter_S_With_Caron #\Latin_Small_Letter_T_With_Caron + #\Latin_Small_Letter_U_With_Caron #\Latin_Small_Letter_Z_With_Caron + #\Latin_Capital_Letter_U_With_Diaeresis_And_Caron + #\Latin_Small_Letter_U_With_Diaeresis_And_Caron + #\Latin_Capital_Letter_Ezh_With_Caron + #\Latin_Small_Letter_Ezh_With_Caron) + + + ;; #\Combining_Double_Grave_Accent + + #(#\Latin_Capital_Letter_A_With_Double_Grave + #\Latin_Capital_Letter_E_With_Double_Grave + #\Latin_Capital_Letter_I_With_Double_Grave + #\Latin_Capital_Letter_O_With_Double_Grave + #\Latin_Capital_Letter_R_With_Double_Grave + #\Latin_Capital_Letter_U_With_Double_Grave + #\Latin_Small_Letter_A_With_Double_Grave + #\Latin_Small_Letter_E_With_Double_Grave + #\Latin_Small_Letter_I_With_Double_Grave + #\Latin_Small_Letter_O_With_Double_Grave + #\Latin_Small_Letter_R_With_Double_Grave + #\Latin_Small_Letter_U_With_Double_Grave + #\Cyrillic_Capital_Letter_Izhitsa_With_Double_Grave_Accent + #\Cyrillic_Small_Letter_Izhitsa_With_Double_Grave_Accent) + + + ;; #\Combining_Inverted_Breve + + #(#\Latin_Capital_Letter_A_With_Inverted_Breve + #\Latin_Capital_Letter_E_With_Inverted_Breve + #\Latin_Capital_Letter_I_With_Inverted_Breve + #\Latin_Capital_Letter_O_With_Inverted_Breve + #\Latin_Capital_Letter_R_With_Inverted_Breve + #\Latin_Capital_Letter_U_With_Inverted_Breve + #\Latin_Small_Letter_A_With_Inverted_Breve + #\Latin_Small_Letter_E_With_Inverted_Breve + #\Latin_Small_Letter_I_With_Inverted_Breve + #\Latin_Small_Letter_O_With_Inverted_Breve + #\Latin_Small_Letter_R_With_Inverted_Breve + #\Latin_Small_Letter_U_With_Inverted_Breve) + + + ;; #\Combining_Comma_Above + + #(#\U+1F08 #\U+1F18 #\U+1F28 #\U+1F38 #\U+1F48 #\U+1F68 #\U+1F00 + #\U+1F10 #\U+1F20 #\U+1F30 #\U+1F40 #\U+1FE4 #\U+1F50 #\U+1F60) + + + ;; #\Combining_Reversed_Comma_Above + + #(#\U+1F09 #\U+1F19 #\U+1F29 #\U+1F39 #\U+1F49 #\U+1FEC #\U+1F59 + #\U+1F69 #\U+1F01 #\U+1F11 #\U+1F21 #\U+1F31 #\U+1F41 #\U+1FE5 + #\U+1F51 #\U+1F61) + + + ;; #\Combining_Horn + + #(#\Latin_Capital_Letter_O_With_Horn + #\Latin_Capital_Letter_U_With_Horn #\Latin_Small_Letter_O_With_Horn + #\Latin_Small_Letter_U_With_Horn) + + + ;; #\Combining_Dot_Below + + #(#\U+1EA0 #\U+1E04 #\U+1E0C #\U+1EB8 #\U+1E24 #\U+1ECA #\U+1E32 + #\U+1E36 #\U+1E42 #\U+1E46 #\U+1ECC #\U+1E5A #\U+1E62 #\U+1E6C + #\U+1EE4 #\U+1E7E #\U+1E88 #\U+1EF4 #\U+1E92 #\U+1EA1 #\U+1E05 + #\U+1E0D #\U+1EB9 #\U+1E25 #\U+1ECB #\U+1E33 #\U+1E37 #\U+1E43 + #\U+1E47 #\U+1ECD #\U+1E5B #\U+1E63 #\U+1E6D #\U+1EE5 #\U+1E7F + #\U+1E89 #\U+1EF5 #\U+1E93 #\U+1EE2 #\U+1EE3 #\U+1EF0 #\U+1EF1) + + + ;; #\Combining_Diaeresis_Below + + #(#\U+1E72 #\U+1E73) + + + ;; #\Combining_Ring_Below + + #(#\U+1E00 #\U+1E01) + + + ;; #\Combining_Comma_Below + + #(#\Latin_Capital_Letter_S_With_Comma_Below + #\Latin_Capital_Letter_T_With_Comma_Below + #\Latin_Small_Letter_S_With_Comma_Below + #\Latin_Small_Letter_T_With_Comma_Below) + + + ;; #\Combining_Cedilla + + #(#\Latin_Capital_Letter_C_With_Cedilla #\U+1E10 + #\Latin_Capital_Letter_E_With_Cedilla + #\Latin_Capital_Letter_G_With_Cedilla #\U+1E28 + #\Latin_Capital_Letter_K_With_Cedilla + #\Latin_Capital_Letter_L_With_Cedilla + #\Latin_Capital_Letter_N_With_Cedilla + #\Latin_Capital_Letter_R_With_Cedilla + #\Latin_Capital_Letter_S_With_Cedilla + #\Latin_Capital_Letter_T_With_Cedilla + #\Latin_Small_Letter_C_With_Cedilla #\U+1E11 + #\Latin_Small_Letter_E_With_Cedilla + #\Latin_Small_Letter_G_With_Cedilla #\U+1E29 + #\Latin_Small_Letter_K_With_Cedilla + #\Latin_Small_Letter_L_With_Cedilla + #\Latin_Small_Letter_N_With_Cedilla + #\Latin_Small_Letter_R_With_Cedilla + #\Latin_Small_Letter_S_With_Cedilla + #\Latin_Small_Letter_T_With_Cedilla) + + + ;; #\Combining_Ogonek + + #(#\Latin_Capital_Letter_A_With_Ogonek + #\Latin_Capital_Letter_E_With_Ogonek + #\Latin_Capital_Letter_I_With_Ogonek + #\Latin_Capital_Letter_O_With_Ogonek + #\Latin_Capital_Letter_U_With_Ogonek + #\Latin_Small_Letter_A_With_Ogonek #\Latin_Small_Letter_E_With_Ogonek + #\Latin_Small_Letter_I_With_Ogonek #\Latin_Small_Letter_O_With_Ogonek + #\Latin_Small_Letter_U_With_Ogonek) + + + ;; #\Combining_Circumflex_Accent_Below + + #(#\U+1E12 #\U+1E18 #\U+1E3C #\U+1E4A #\U+1E70 #\U+1E76 #\U+1E13 + #\U+1E19 #\U+1E3D #\U+1E4B #\U+1E71 #\U+1E77) + + + ;; #\Combining_Breve_Below + + #(#\U+1E2A #\U+1E2B) + + + ;; #\Combining_Tilde_Below + + #(#\U+1E1A #\U+1E2C #\U+1E74 #\U+1E1B #\U+1E2D #\U+1E75) + + + ;; #\Combining_Macron_Below + + #(#\U+1E06 #\U+1E0E #\U+1E34 #\U+1E3A #\U+1E48 #\U+1E5E #\U+1E6E + #\U+1E94 #\U+1E07 #\U+1E0F #\U+1E96 #\U+1E35 #\U+1E3B #\U+1E49 + #\U+1E5F #\U+1E6F #\U+1E95) + + + ;; #\Combining_Long_Solidus_Overlay + + #(#\U+226E #\U+2260 #\U+226F #\U+219A #\U+219B #\U+21AE #\U+21CD + #\U+21CF #\U+21CE #\U+2204 #\U+2209 #\U+220C #\U+2224 #\U+2226 + #\U+2241 #\U+2244 #\U+2247 #\U+2249 #\U+226D #\U+2262 #\U+2270 + #\U+2271 #\U+2274 #\U+2275 #\U+2278 #\U+2279 #\U+2280 #\U+2281 + #\U+22E0 #\U+22E1 #\U+2284 #\U+2285 #\U+2288 #\U+2289 #\U+22E2 + #\U+22E3 #\U+22AC #\U+22AD #\U+22AE #\U+22AF #\U+22EA #\U+22EB + #\U+22EC #\U+22ED) + + + ;; #\Combining_Greek_Perispomeni + + #(#\U+1FC1 #\U+1FB6 #\U+1FC6 #\U+1FD6 #\U+1FE6 #\U+1FF6 #\U+1FD7 + #\U+1FE7 #\U+1F06 #\U+1F07 #\U+1F0E #\U+1F0F #\U+1F26 #\U+1F27 + #\U+1F2E #\U+1F2F #\U+1F36 #\U+1F37 #\U+1F3E #\U+1F3F #\U+1F56 + #\U+1F57 #\U+1F5F #\U+1F66 #\U+1F67 #\U+1F6E #\U+1F6F #\U+1FCF + #\U+1FDF) + + + ;; #\Combining_Greek_Ypogegrammeni + + #(#\U+1FBC #\U+1FCC #\U+1FFC #\U+1FB4 #\U+1FC4 #\U+1FB3 #\U+1FC3 + #\U+1FF3 #\U+1FF4 #\U+1F80 #\U+1F81 #\U+1F82 #\U+1F83 #\U+1F84 + #\U+1F85 #\U+1F86 #\U+1F87 #\U+1F88 #\U+1F89 #\U+1F8A #\U+1F8B + #\U+1F8C #\U+1F8D #\U+1F8E #\U+1F8F #\U+1F90 #\U+1F91 #\U+1F92 + #\U+1F93 #\U+1F94 #\U+1F95 #\U+1F96 #\U+1F97 #\U+1F98 #\U+1F99 + #\U+1F9A #\U+1F9B #\U+1F9C #\U+1F9D #\U+1F9E #\U+1F9F #\U+1FA0 + #\U+1FA1 #\U+1FA2 #\U+1FA3 #\U+1FA4 #\U+1FA5 #\U+1FA6 #\U+1FA7 + #\U+1FA8 #\U+1FA9 #\U+1FAA #\U+1FAB #\U+1FAC #\U+1FAD #\U+1FAE + #\U+1FAF #\U+1FB2 #\U+1FC2 #\U+1FF2 #\U+1FB7 #\U+1FC7 #\U+1FF7) + + + ;; #\Arabic_Maddah_Above + + #(#\Arabic_Letter_Alef_With_Madda_Above) + + + ;; #\Arabic_Hamza_Above + + #(#\Arabic_Letter_Alef_With_Hamza_Above + #\Arabic_Letter_Waw_With_Hamza_Above + #\Arabic_Letter_Yeh_With_Hamza_Above + #\Arabic_Letter_Heh_Goal_With_Hamza_Above + #\Arabic_Letter_Yeh_Barree_With_Hamza_Above + #\Arabic_Letter_Heh_With_Yeh_Above) + + + ;; #\Arabic_Hamza_Below + + #(#\Arabic_Letter_Alef_With_Hamza_Below) + + + ;; #\U+093C + + #(#\U+0929 #\U+0931 #\U+0934) + + + ;; #\U+09BE + + #(#\U+09CB) + + + ;; #\U+09D7 + + #(#\U+09CC) + + + ;; #\U+0B3E + + #(#\U+0B4B) + + + ;; #\U+0B56 + + #(#\U+0B48) + + + ;; #\U+0B57 + + #(#\U+0B4C) + + + ;; #\U+0BBE + + #(#\U+0BCA #\U+0BCB) + + + ;; #\U+0BD7 + + #(#\U+0B94 #\U+0BCC) + + + ;; #\U+0C56 + + #(#\U+0C48) + + + ;; #\U+0CC2 + + #(#\U+0CCA) + + + ;; #\U+0CD5 + + #(#\U+0CC0 #\U+0CC7 #\U+0CCB) + + + ;; #\U+0CD6 + + #(#\U+0CC8) + + + ;; #\U+0D3E + + #(#\U+0D4A #\U+0D4B) + + + ;; #\U+0D57 + + #(#\U+0D4C) + + + ;; #\U+0DCA + + #(#\U+0DDA #\U+0DDD) + + + ;; #\U+0DCF + + #(#\U+0DDC) + + + ;; #\U+0DDF + + #(#\U+0DDE) + + + ;; #\U+102E + + #(#\U+1026) + + + ;; #\U+3099 + + #(#\U+3094 #\U+304C #\U+304E #\U+3050 #\U+3052 #\U+3054 #\U+3056 + #\U+3058 #\U+305A #\U+305C #\U+305E #\U+3060 #\U+3062 #\U+3065 + #\U+3067 #\U+3069 #\U+3070 #\U+3073 #\U+3076 #\U+3079 #\U+307C + #\U+309E #\U+30F4 #\U+30AC #\U+30AE #\U+30B0 #\U+30B2 #\U+30B4 + #\U+30B6 #\U+30B8 #\U+30BA #\U+30BC #\U+30BE #\U+30C0 #\U+30C2 + #\U+30C5 #\U+30C7 #\U+30C9 #\U+30D0 #\U+30D3 #\U+30D6 #\U+30D9 + #\U+30DC #\U+30F7 #\U+30F8 #\U+30F9 #\U+30FA #\U+30FE) + + + ;; #\U+309A + + #(#\U+3071 #\U+3074 #\U+3077 #\U+307A #\U+307D #\U+30D1 #\U+30D4 + #\U+30D7 #\U+30DA #\U+30DD) + )) + +(defun search-char-vector (vector char) + ;; vector is a SIMPLE-VECTOR of chars sorted by char-code. + ;; return the index of char in vector or NIL if not found + (let* ((left 0) + (right (1- (length vector)))) + (declare (fixnum left right)) + (if (and (char>= char (svref vector left)) + (char<= char (svref vector right))) + (do* () + ((> left right)) + (let* ((mid (ash (the fixnum (+ left right)) -1)) + (midch (svref vector mid))) + (declare (fixnum mid)) + (if (eql char midch) + (return mid) + (if (char< char midch) + (setq right (1- mid)) + (setq left (1+ mid))))))))) + + +(defconstant HANGUL-SBASE #xAC00) +(defconstant HANGUL-LBASE #x1100) +(defconstant HANGUL-VBASE #x1161) +(defconstant HANGUL-TBASE #x11A7) + +(defconstant HANGUL-SCOUNT 11172) +(defconstant HANGUL-LCOUNT 19) +(defconstant HANGUL-VCOUNT 21) +(defconstant HANGUL-TCOUNT 28) +(defconstant HANGUL-NCOUNT (* HANGUL-VCOUNT HANGUL-TCOUNT)) + +(defun combine-bmp-chars (base combiner) + (if (and (char>= combiner (code-char hangul-vbase)) + (char< combiner (code-char (+ hangul-tbase hangul-tcount)))) + (if (and (char< combiner (code-char (+ hangul-vbase hangul-vcount))) + (char>= base (code-char hangul-lbase)) + (char< base (code-char (+ hangul-lbase hangul-lcount)))) + (return-from combine-bmp-chars + (code-char (+ hangul-lbase + (* hangul-ncount (- (char-code base) hangul-lbase)) + (* hangul-tcount (- (char-code combiner) hangul-vbase)))))) + (if (and (char> combiner (code-char hangul-tbase)) + (char>= base (code-char hangul-sbase)) + (char< base (code-char (+ hangul-sbase hangul-scount)))) + (if (not (zerop (the fixnum (mod (- (char-code base) hangul-sbase) hangul-tcount)))) + (return-from combine-bmp-chars nil) + (return-from combine-bmp-chars + (code-char (+ (char-code base) (- (char-code combiner) hangul-tbase))))))) + + (let* ((idx (search-char-vector *bmp-combining-chars* combiner)) + (base-table (if idx (svref *bmp-combining-base-chars* idx)))) + (if base-table + (let* ((combined-idx (search-char-vector base-table base))) + (if combined-idx + (svref (svref *bmp-precombined-chars* idx) combined-idx)))))) + +(defun precompose-simple-string (s) + (let* ((n (length s))) + (or (dotimes (i n s) + (when (is-combinable (schar s i)) + (return nil))) + (let* ((new (make-string n))) + (declare (dynamic-extent new)) + (do* ((i 0 (1+ i)) + (nout -1) + (lastch nil)) + ((= i n) (subseq new 0 (1+ nout))) + (declare (fixnum nout i)) + (let* ((ch (schar s i))) + (if (or (not lastch) + (not (is-combinable ch))) + (setf lastch ch + (schar new (incf nout)) ch) + (let* ((combined (combine-bmp-chars lastch ch))) + (if combined + (setf (schar new nout) (setq lastch combined)) + (setf lastch ch + (schar new (incf nout)) ch)))))))))) Index: /branches/new-random/level-1/l1-utils.lisp =================================================================== --- /branches/new-random/level-1/l1-utils.lisp (revision 13309) +++ /branches/new-random/level-1/l1-utils.lisp (revision 13309) @@ -0,0 +1,1175 @@ +;;;-*-Mode: LISP; Package: CCL -*- +;;; +;;; Copyright (C) 2009 Clozure Associates +;;; Copyright (C) 1994-2001 Digitool, Inc +;;; This file is part of Clozure CL. +;;; +;;; Clozure CL is licensed under the terms of the Lisp Lesser GNU Public +;;; License , known as the LLGPL and distributed with Clozure CL as the +;;; file "LICENSE". The LLGPL consists of a preamble and the LGPL, +;;; which is distributed with Clozure CL as the file "LGPL". Where these +;;; conflict, the preamble takes precedence. +;;; +;;; Clozure CL is referenced in the preamble as the "LIBRARY." +;;; +;;; The LLGPL is also available online at +;;; http://opensource.franz.com/preamble.html + +; L1-utils.lisp + +(in-package "CCL") + +;The following forms (up thru defn of %DEFUN) must come before any DEFUN's. +;Any (non-kernel) functions must be defined before they're used! +;In fact, ALL functions must be defined before they're used! How about that ? + + + +(setq %lisp-system-fixups% nil) + + +;;; Kludge for record-source-file bootstrapping + +(%fhave 'full-pathname (qlfun bootstrapping-full-pathname (name) name)) + + +; real one is in setf.lisp +(%fhave '%setf-method (qlfun bootstripping-setf-fsname (spec) + spec nil)) + +(fset 'physical-pathname-p (lambda (file)(declare (ignore file)) nil)) ; redefined later + +(setq *record-source-file* t) + +(fset 'level-1-record-source-file + (qlfun level-1-record-source-file (name def-type &optional (source (or *loading-toplevel-location* + *loading-file-source-file*))) + ;; Level-0 puts stuff on plist of name. Once we're in level-1, names can + ;; be more complicated than just a symbol, so just collect all calls until + ;; the real record-source-file is loaded. + (when *record-source-file* + (unless (listp *record-source-file*) + (setq *record-source-file* nil)) + (push (list name def-type source) *record-source-file*)))) + +(fset 'record-source-file #'level-1-record-source-file) + +(defun inherit-from-p (ob parent) + (memq (if (symbolp parent) (find-class parent nil) parent) + (%inited-class-cpl (class-of ob)))) + +;;; returns new plist with value spliced in or key, value consed on. +(defun setprop (plist key value &aux loc) + (if (setq loc (pl-search plist key)) + (progn (%rplaca (%cdr loc) value) plist) + (cons key (cons value plist)))) + +(defun getf-test (place indicator test &optional default) + (loop + (when (null place) + (return default)) + (when (funcall test indicator (car place)) + (return (cadr place))) + (setq place (cddr place)))) + +(defun setprop-test (plist indicator test value) + (let ((tail plist)) + (loop + (when (null tail) + (return (cons indicator (cons value plist)))) + (when (funcall test indicator (car tail)) + (setf (cadr tail) value) + (return plist)) + (setq tail (cddr tail))))) + +(defun plistp (p &aux len) + (and (listp p) + (setq len (list-length p)) + (not (%ilogbitp 0 len)))) ; (evenp p) + +(defun %imax (i1 i2) + (if (%i> i1 i2) i1 i2)) + +(defun %imin (i1 i2) + (if (%i< i1 i2) i1 i2)) + + + + +;|# + + +(eval-when (:compile-toplevel :execute) + (require "NUMBER-MACROS")) + + + + +(defun loading-file-source-file () + *loading-file-source-file*) + +(setq *save-local-symbols* t) + +(%fhave 'require-type (nfunction bootstrapping-require-type + (lambda (thing type) + (declare (ignore type)) + thing))) +(%fhave '%require-type + (nfunction bootstrapping-%require-type + (lambda (thing predicate) + (declare (ignore predicate)) + thing))) + +(setf (type-predicate 'macptr) 'macptrp) + + + + + + +(defun %pop-required-arg-ptr (ptr) + (if (atom (destructure-state.current ptr)) + (signal-program-error "Required arguments in ~s don't match lambda list ~s." + (destructure-state.whole ptr) (destructure-state.lambda ptr)) + (pop (destructure-state.current ptr)))) + +(defun %default-optional-value (ptr &optional default) + (let* ((tail (destructure-state.current ptr))) + (if tail + (if (atom tail) + (signal-program-error "Optional arguments in ~s don't match lambda list ~s." + (destructure-state.whole ptr) (destructure-state.lambda ptr)) + (pop (destructure-state.current ptr))) + default))) + +(defun %check-extra-arguments (ptr) + (when (destructure-state.current ptr) + (signal-program-error "Extra arguments in ~s don't match lambda list ~s." + (destructure-state.whole ptr) (destructure-state.lambda ptr)))) + +(defun %keyword-present-p (keys keyword) + (let* ((not-there (cons nil nil))) + (declare (dynamic-extent not-there)) + (not (eq (getf keys keyword not-there) not-there)))) + +(defun check-keywords (keys actual allow-others) + (let* ((len (ignore-errors (list-length actual)))) + (if (null len) + (signal-simple-program-error "Circular or dotted keyword list: ~s" actual) + (if (oddp len) + (signal-simple-program-error "Odd length keyword list: ~s" actual)))) + (setq allow-others (or allow-others (getf actual :allow-other-keys))) + (do* ((a actual (cddr a)) + (k (car a) (car a))) + ((null a)) + (unless (typep k 'symbol) + (signal-simple-program-error + "Invalid keyword argument ~s in ~s. ~&Valid keyword arguments are ~s." k actual keys)) + (unless (or allow-others + (eq k :allow-other-keys) + (member k keys)) + (signal-simple-program-error "Unknown keyword argument ~s in ~s. ~&Valid keyword arguments are ~s." k actual keys)))) + +(%fhave 'set-macro-function #'%macro-have) ; redefined in sysutils. + +;;; Define special forms. +(dolist (sym '(block catch compiler-let eval-when + flet function go if labels let let* macrolet + multiple-value-call multiple-value-prog1 + progn progv quote return-from setq tagbody + the throw unwind-protect locally load-time-value + symbol-macrolet + ;; These are implementation-specific special forms : + nfunction + ppc-lap-function fbind + with-c-frame with-variable-c-frame)) + (%macro-have sym sym)) + + +(defun %macro (named-fn &optional doc &aux arglist) + ;; "doc" is either a string or a list of the form : + ;; (doc-string-or-nil . (body-pos-or-nil . arglist-or-nil)) + (if (listp doc) + (setq arglist (cddr doc) + doc (car doc))) + (let* ((name (function-name named-fn))) + (record-source-file name 'function) + (set-macro-function name named-fn) + (when (and doc *save-doc-strings*) + (set-documentation name 'function doc)) + (when arglist + (record-arglist name arglist)) + (when *fasload-print* (format t "~&~S~%" name)) + name)) + + +(defun %defvar (var &optional doc) + "Returns boundp" + (%proclaim-special var) + (record-source-file var 'variable) + (when (and doc *save-doc-strings*) + (set-documentation var 'variable doc)) + (cond ((not (boundp var)) + (when *fasload-print* (format t "~&~S~%" var)) + nil) + (t t))) + +(defun %defparameter (var value &optional doc) + (%proclaim-special var) + (record-source-file var 'variable) + (when (and doc *save-doc-strings*) + (set-documentation var 'variable doc)) + (when *fasload-print* (format t "~&~S~%" var)) + (set var value) + var) + + +(defun %defglobal (var value &optional doc) + (%symbol-bits var (logior (ash 1 $sym_vbit_global) (the fixnum (%symbol-bits var)))) + (%defparameter var value doc)) + +;Needed early for member etc. +(defun identity (x) + "This function simply returns what was passed to it." + x) + +(defun coerce-to-function (arg) + (if (functionp arg) + arg + (if (symbolp arg) + (%function arg) + (report-bad-arg arg 'function)))) + +;;; takes arguments in arg_x, arg_y, arg_z, returns "multiple values" +;;; Test(-not) arguments are NOT validated beyond what is done +;;; here. +;;; if both :test and :test-not supplied, signal error. +;;; if test provided as #'eq or 'eq, return first value 'eq. +;;; if test defaulted, provided as 'eql, or provided as #'eql, return +;;; first value 'eql. +;;; if test-not provided as 'eql or provided as #'eql, return second +;;; value 'eql. +;;; if key provided as either 'identity or #'identity, return third value nil. +(defun %key-conflict (test-fn test-not-fn key) + (let* ((eqfn #'eq) + (eqlfn #'eql) + (idfn #'identity)) + (if (or (eq key 'identity) (eq key idfn)) + (setq key nil)) + (if test-fn + (if test-not-fn + (%err-disp $xkeyconflict ':test test-fn ':test-not test-not-fn) + (if (eq test-fn eqfn) + (values 'eq nil key) + (if (eq test-fn eqlfn) + (values 'eql nil key) + (values test-fn nil key)))) + (if test-not-fn + (if (eq test-not-fn eqfn) + (values nil 'eq key) + (if (eq test-not-fn eqlfn) + (values nil 'eql key) + (values nil test-not-fn key))) + (values 'eql nil key))))) + + + + + +;;; Assoc. + +;;; (asseql item list) <=> (assoc item list :test #'eql :key #'identity) + + + +;;; (assoc-test item list test-fn) +;;; <=> +;;; (assoc item list :test test-fn :key #'identity) +;;; test-fn may not be FUNCTIONP, so we coerce it here. +(defun assoc-test (item list test-fn) + (dolist (pair list) + (if pair + (if (funcall test-fn item (car pair)) + (return pair))))) + + + +; (assoc-test-not item list test-not-fn) +; <=> +; (assoc item list :test-not test-not-fn :key #'identity) +; test-not-fn may not be FUNCTIONP, so we coerce it here. +(defun assoc-test-not (item list test-not-fn) + (dolist (pair list) + (if pair + (if (not (funcall test-not-fn item (car pair))) + (return pair))))) + +(defun assoc (item list &key test test-not key) + "Return the cons in ALIST whose car is equal (by a given test or EQL) to + the ITEM." + (multiple-value-bind (test test-not key) (%key-conflict test test-not key) + (if (null key) + (if (eq test 'eq) + (assq item list) + (if (eq test 'eql) + (asseql item list) + (if test + (assoc-test item list test) + (assoc-test-not item list test-not)))) + (if test + (dolist (pair list) + (if pair + (if (funcall test item (funcall key (car pair))) + (return pair)))) + (dolist (pair list) + (if pair + (unless (funcall test-not item (funcall key (car pair))) + (return pair)))))))) + + + +;;;; Member. + +;;; (member-test-not item list test-not-fn) +;;; <=> +;;; (member item list :test-not test-not-fn :key #'identity) +(defun member-test-not (item list test-not-fn) + (do* ((l list (cdr l))) + ((endp l)) + (unless (funcall test-not-fn item (%car l)) (return l)))) + +(defun member (item list &key test test-not key) + "Return the tail of LIST beginning with first element satisfying EQLity, + :TEST, or :TEST-NOT with the given ITEM." + (multiple-value-bind (test test-not key) (%key-conflict test test-not key) + (if (null key) + (if (eq test 'eq) + (memq item list) + (if (eq test 'eql) + (memeql item list) + (if test + (member-test item list test) + (member-test-not item list test-not)))) + (if test + (do* ((l list (cdr l))) + ((endp l)) + (if (funcall test item (funcall key (car l))) + (return l))) + (do* ((l list (cdr l))) + ((null l)) + (unless (funcall test-not item (funcall key (car l))) + (return l))))))) + + +(defun adjoin (item list &key test test-not key) + "Add ITEM to LIST unless it is already a member" + (if (and (not test)(not test-not)(not key)) + (if (not (memeql item list))(cons item list) list) + (multiple-value-bind (test test-not key) (%key-conflict test test-not key) + (if + (if (null key) + (if (eq test 'eq) + (memq item list) + (if (eq test 'eql) + (memeql item list) + (if test + (member-test item list test) + (member-test-not item list test-not)))) + (if test + (member (funcall key item) list :test test :key key) + (member (funcall key item) list :test-not test-not :key key))) + list + (cons item list))))) + +(defun adjoin-eq (elt list) + (if (memq elt list) + list + (cons elt list))) + +(defun adjoin-eql (elt list) + (if (memeql elt list) + list + (cons elt list))) + +(defun union-eq (list1 list2) + (let ((res list2)) + (dolist (elt list1) + (unless (memq elt res) + (push elt res))) + res)) + +(defun union-eql (list1 list2) + (let ((res list2)) + (dolist (elt list1) + (unless (memeql elt res) + (push elt res))) + res)) + +;;; Fix this someday. Fix EQUALP, while you're at it ... +(defun similar-as-constants-p (x y) + (or (eq x y) ; Redefinition of constants to themselves. + (if (and (stringp x) (stringp y)) ;The most obvious case where equalp & s-a-c-p need to differ... + (string= x y) + (equalp x y)))) + +(defun undefine-constant (var) + (%set-sym-global-value var (%unbound-marker-8))) + +(defparameter *cerror-on-constant-redefinition* t) + +(defun define-constant (var value) + (block nil + (if (constant-symbol-p var) + (let* ((old-value (%sym-global-value var))) + (unless (eq old-value (%unbound-marker-8)) + (if (or (eql old-value value) + (and (not *strict-checking*) (similar-as-constants-p old-value value))) + (return) + ;; This should really be a cell error, allow options other than + ;; redefining (such as don't redefine and continue)... + (when *cerror-on-constant-redefinition* + (cerror "Redefine ~S to have new value ~*~s" + "Constant ~S is already defined with a different value (~s)" + var old-value value)))))) + (%symbol-bits var + (%ilogior (%ilsl $sym_bit_special 1) (%ilsl $sym_bit_const 1) + (%symbol-bits var))) + (%set-sym-global-value var value)) + var) + +(defun %defconstant (var value &optional doc) + (%proclaim-special var) + (record-source-file var 'constant) + (define-constant var value) + (when (and doc *save-doc-strings*) + (set-documentation var 'variable doc)) + (when *fasload-print* (format t "~&~S~%" var)) + var) + +(defparameter *nx1-compiler-special-forms* ()) +(defparameter *nx-proclaimed-types* ()) +(defparameter *nx-proclaimed-ftypes* nil) + +(defun compiler-special-form-p (sym) + (or (eq sym 'quote) + (if (memq sym *nx1-compiler-special-forms*) t))) + + + +(defparameter *nx-known-declarations* ()) +(defparameter *nx-proclaimed-inline* ()) +(defparameter *nx-proclaimed-ignore* ()) +(defparameter *nx-globally-inline* ()) + + + +(defconstant *cl-types* '( +array +atom +base-char +bignum +bit +bit-vector +character +#| +lisp:common +|# +compiled-function +complex +cons +double-float +extended-char +fixnum +float +function +hash-table +integer +keyword +list +long-float +nil +null +number +package +pathname +random-state +ratio +rational +readtable +real +sequence +short-float +signed-byte +simple-array +simple-bit-vector +simple-string +simple-base-string +simple-vector +single-float +standard-char +stream +string +#| +lisp:string-char +|# +symbol +t +unsigned-byte +vector +)) + +;; Redefined in sysutils. +(%fhave 'specifier-type-if-known + (qlfun bootstrapping-type-specifier-p (name &optional env &key &allow-other-keys) + (declare (ignore env)) + (memq name *cl-types*))) + + + +(defun proclaim (spec) + (case (car spec) + (special (apply #'proclaim-special (%cdr spec))) + (notspecial (apply #'proclaim-notspecial (%cdr spec))) + (optimize (%proclaim-optimize (%cdr spec))) + (inline (apply #'proclaim-inline t (%cdr spec))) + (notinline (apply #'proclaim-inline nil (%cdr spec))) + (declaration (apply #'proclaim-declaration (%cdr spec))) + (ignore (apply #'proclaim-ignore t (%cdr spec))) + (unignore (apply #'proclaim-ignore nil (%cdr spec))) + (type (apply #'proclaim-type (%cdr spec))) + (ftype (apply #'proclaim-ftype (%cdr spec))) + (function (apply #'proclaim-type spec)) + (t (unless (memq (%car spec) *nx-known-declarations*) + ;; Any type name is now (ANSI CL) a valid declaration. + (if (specifier-type-if-known (%car spec)) + (apply #'proclaim-type spec) + (signal-program-error "Unknown declaration specifier ~s in ~S" (%car spec) spec)))))) + +(defun bad-proclaim-spec (spec) + (signal-program-error "Invalid declaration specifier ~s" spec)) + +(defun proclaim-type (type &rest vars) + (declare (dynamic-extent vars)) + ;; Called too early to use (every #'symbolp vars) + (unless (loop for v in vars always (symbolp v)) (bad-proclaim-spec `(,type ,@vars))) + (when *type-system-initialized* + ;; Check the type. This will signal program-error's in case of invalid types, let it. + ;; Do not signal anything about unknown types though -- it should be ok to have forward + ;; references here, before anybody needs the info. + (specifier-type type)) + (dolist (var vars) + (let ((spec (assq var *nx-proclaimed-types*))) + (if spec + (rplacd spec type) + (push (cons var type) *nx-proclaimed-types*))))) + +(defun proclaim-ftype (ftype &rest names) + (declare (dynamic-extent names)) + (unless (every (lambda (v) (or (symbolp v) (setf-function-name-p v))) names) + (bad-proclaim-spec `(ftype ,ftype ,@names))) + (unless *nx-proclaimed-ftypes* + (setq *nx-proclaimed-ftypes* (make-hash-table :test #'eq))) + ;; Check the type. This will signal program-error's in case of invalid types, let it. + ;; Do not signal anything about unknown types though -- it should be ok to have forward + ;; references here, before anybody needs the info. + (let* ((ctype (specifier-type ftype))) + ;; If know enough to complain now, do so. + (when (types-disjoint-p ctype (specifier-type 'function)) + (bad-proclaim-spec `(ftype ,ftype ,@names)))) + (dolist (name names) + (setf (gethash (maybe-setf-function-name name) *nx-proclaimed-ftypes*) ftype))) + + + +(defun proclaimed-ftype (name) + (when *nx-proclaimed-ftypes* + (gethash (ensure-valid-function-name name) *nx-proclaimed-ftypes*))) + + +(defun proclaim-special (&rest vars) + (declare (dynamic-extent vars)) + (unless (every #'symbolp vars) (bad-proclaim-spec `(special ,@vars))) + (dolist (sym vars) (%proclaim-special sym))) + + +(defun proclaim-notspecial (&rest vars) + (declare (dynamic-extent vars)) + (unless (every #'symbolp vars) (bad-proclaim-spec `(special ,@vars))) + (dolist (sym vars) (%proclaim-notspecial sym))) + +(defun proclaim-inline (t-or-nil &rest names) + (declare (dynamic-extent names)) + ;;This is just to make it more likely to detect forgetting about the + ;;first arg... + (unless (or (eq nil t-or-nil) (eq t t-or-nil)) (report-bad-arg t-or-nil '(member t nil))) + (unless (loop for v in names always (or (symbolp v) (setf-function-name-p v))) + (bad-proclaim-spec `(,(if t-or-nil 'inline 'notinline) ,@names))) + (dolist (name names) + (setq name (maybe-setf-function-name name)) + (if (listp *nx-proclaimed-inline*) + (setq *nx-proclaimed-inline* + (alist-adjoin name + (or t-or-nil (if (compiler-special-form-p name) t)) + *nx-proclaimed-inline*)) + (setf (gethash name *nx-proclaimed-inline*) + (or t-or-nil (if (compiler-special-form-p name) t)))))) + +(defun proclaim-declaration (&rest syms) + (declare (dynamic-extent syms)) + (unless (every #'symbolp syms) (bad-proclaim-spec `(declaration ,@syms))) + (dolist (sym syms) + (when (type-specifier-p sym) + (error "Cannot define declaration ~s because it is the name of a type" sym)) + (setq *nx-known-declarations* + (adjoin sym *nx-known-declarations* :test 'eq)))) + +(defun check-declaration-redefinition (name why) + (when (memq name *nx-known-declarations*) + (cerror "Undeclare the declaration ~*~s" + "Cannot ~a ~s because ~:*~s has been declared as a declaration name" why name) + (setq *nx-known-declarations* (remove name *nx-known-declarations*)))) + +(defun proclaim-ignore (t-or-nil &rest syms) + (declare (dynamic-extent syms)) + ;;This is just to make it more likely to detect forgetting about the + ;;first arg... + (unless (or (eq nil t-or-nil) (eq t t-or-nil)) (report-bad-arg t-or-nil '(member t nil))) + (unless (every #'symbolp syms) (bad-proclaim-spec `(,(if t-or-nil 'ignore 'unignore) ,@syms))) + (dolist (sym syms) + (setq *nx-proclaimed-ignore* + (alist-adjoin sym t-or-nil *nx-proclaimed-ignore*)))) + + +(queue-fixup + (when (listp *nx-proclaimed-inline*) + (let ((table (make-hash-table :size 100 :test #'eq))) + (dolist (x *nx-proclaimed-inline*) + (let ((name (car x)) (value (cdr x))) + (when (symbolp name) + (setf (gethash name table) value)))) + (setq *nx-proclaimed-inline* table)))) + +(defun proclaimed-special-p (sym) + (%ilogbitp $sym_vbit_special (%symbol-bits sym))) + +(defun proclaimed-inline-p (sym) + (if (listp *nx-proclaimed-inline*) + (%cdr (assq sym *nx-proclaimed-inline*)) + (gethash sym *nx-proclaimed-inline*))) + +(defun proclaimed-notinline-p (sym) + (if (listp *nx-proclaimed-inline*) + (and (setq sym (assq sym *nx-proclaimed-inline*)) + (null (%cdr sym))) + (null (gethash sym *nx-proclaimed-inline* t)))) + + +(defun self-evaluating-p (form) + (and (atom form) + (or (not (non-nil-symbol-p form)) + (eq form t) + (keywordp form)))) + +(defun constantp (form &optional env) + "True of any Lisp object that has a constant value: types that eval to + themselves, keywords, constants, and list whose car is QUOTE." + (or (self-evaluating-p form) + (quoted-form-p form) + (constant-symbol-p form) + (and env + (symbolp form) + (eq :constant (variable-information form env))))) + + +(defun eval-constant (form) + (if (quoted-form-p form) (%cadr form) + (if (constant-symbol-p form) (symbol-value form) + (if (self-evaluating-p form) form + (report-bad-arg form '(satisfies constantp)))))) + +(defvar *lfun-names*) + + +(defvar %lambda-lists% (make-hash-table :test #'eq :weak t)) +(defparameter *save-arglist-info* t) + + +(defun record-arglist (name args) + "Used by defmacro & defgeneric" + (when (or *save-arglist-info* *save-local-symbols*) + (setf (gethash name %lambda-lists%) args))) + + +;;;Support the simple case of defsetf. +(%fhave 'store-setf-method + (qlfun bootstrapping-store-setf-method (name fn &optional doc) + (declare (ignore doc)) + (put name 'bootstrapping-setf-method (require-type fn 'symbol)))) +(%fhave '%setf-method + (qlfun bootstrapping-%setf-method (name) + (get name 'bootstrapping-setf-method))) + + +;;; defmacro uses (setf (assq ...) ...) for &body forms. +(defun adjoin-assq (indicator alist value) + (let ((cell (assq indicator alist))) + (if cell + (setf (cdr cell) value) + (push (cons indicator value) alist))) + alist) + +(defmacro setf-assq (indicator place value) + (let ((res (gensym))) + `(let (,res) + (setf ,place (adjoin-assq ,indicator ,place (setq ,res ,value))) + ,res))) + +(defsetf assq setf-assq) +(defsetf %typed-miscref %typed-miscset) + +(defun quoted-form-p (form) + (and (consp form) + (eq (%car form) 'quote) + (consp (%cdr form)) + (null (%cdr (%cdr form))))) + +(defun lambda-expression-p (form) + (and (consp form) + (eq (%car form) 'lambda) + (consp (%cdr form)) + (listp (%cadr form)))) + +;;;;;FUNCTION BINDING Functions + +;;; A symbol's entrypoint contains: +;;; 1) something tagged as $t_lfun if the symbol is +;;; not fbound as a macro or special form; +;;; 2) a cons, otherwise, where the cdr is a fixnum +;;; whose value happens to be the same bit-pattern +;;; as a "jsr_subprim $sp-apply-macro" instruction. +;;; The car of this cons is either: +;;; a) a function -> macro-function; +;;; b) a symbol: special form not redefined as a macro. +;;; c) a cons whose car is a function -> macro function defined +;;; on a special form. + + + + +(defun symbol-function (name) + "Return the definition of NAME, even if it is a macro or a special form. + Error if NAME doesn't have a definition." + (or (fboundp name) ;Our fboundp returns the binding + (prog1 (%err-disp $xfunbnd name)))) + +(%fhave 'fdefinition #'symbol-function) + + +(defun kernel-function-p (f) + (declare (ignore f)) + nil) + +(defun %make-function (name fn env) + (compile-user-function fn name env)) + +;;;;;;;;; VALUE BINDING Functions + +(defun gensym (&optional (string-or-integer nil string-or-integer-p)) + "Creates a new uninterned symbol whose name is a prefix string (defaults + to \"G\"), followed by a decimal number. Thing, when supplied, will + alter the prefix if it is a string, or be used for the decimal number + if it is a number, of this symbol. The default value of the number is + the current value of *gensym-counter* which is incremented each time + it is used." + (let ((prefix "G") + (counter nil)) + (when string-or-integer-p + (etypecase string-or-integer + (integer (setq counter string-or-integer)) ; & emit-style-warning + (string (setq prefix (ensure-simple-string string-or-integer))))) + (unless counter + (setq *gensym-counter* (1+ (setq counter *gensym-counter*)))) + (make-symbol (%str-cat prefix (%integer-to-string counter))))) + +(defun make-keyword (name) + (if (and (symbolp name) (eq (symbol-package name) *keyword-package*)) + name + (values (intern (string name) *keyword-package*)))) + + + + +; destructive, removes first match only +(defun remove-from-alist (thing alist) + (let ((start alist)) + (if (eq thing (%caar alist)) + (%cdr alist) + (let* ((prev start) + (this (%cdr prev)) + (next (%cdr this))) + (while this + (if (eq thing (%caar this)) + (progn + (%rplacd prev next) + (return-from remove-from-alist start)) + (setq prev this + this next + next (%cdr next)))) + start)))) + +;destructive +(defun add-to-alist (thing val alist &aux (pair (assq thing alist))) + (if pair + (progn (%rplacd pair thing) alist) + (cons (cons thing val) alist))) + +;non-destructive... +(defun alist-adjoin (thing val alist &aux (pair (assq thing alist))) + (if (and pair (eq (%cdr pair) val)) + alist + (cons (cons thing val) alist))) + +(defun %str-assoc (str alist) + (assoc str alist :test #'string-equal)) + +(defstatic *pathname-escape-character* + #+windows-target #\' + #-windows-target #\\ + "Not CL. A Coral addition for compatibility between CL spec and the shell.") + + +(defun caar (x) + "Return the car of the 1st sublist." + (car (car x))) + +(defun cadr (x) + "Return the 2nd object in a list." + (car (cdr x))) + +(defun cdar (x) + "Return the cdr of the 1st sublist." + (cdr (car x))) + +(defun cddr (x) + "Return all but the 1st two objects of a list." + + (cdr (cdr x))) + +(defun caaar (x) + "Return the 1st object in the caar of a list." + (car (car (car x)))) + +(defun caadr (x) + "Return the 1st object in the cadr of a list." + (car (car (cdr x)))) + +(defun cadar (x) + "Return the car of the cdar of a list." + (car (cdr (car x)))) + +(defun caddr (x) + "Return the 1st object in the cddr of a list." + (car (cdr (cdr x)))) + +(defun cdaar (x) + "Return the cdr of the caar of a list." + (cdr (car (car x)))) + +(defun cdadr (x) + "Return the cdr of the cadr of a list." + (cdr (car (cdr x)))) + +(defun cddar (x) + "Return the cdr of the cdar of a list." + (cdr (cdr (car x)))) + +(defun cdddr (x) + "Return the cdr of the cddr of a list." + (cdr (cdr (cdr x)))) + +(defun cadddr (x) + "Return the car of the cdddr of a list." + (car (cdr (cdr (cdr x))))) + +(%fhave 'type-of #'%type-of) + + + +(defun pointerp (thing &optional errorp) + (if (macptrp thing) + t + (if errorp (error "~S is not a pointer" thing) nil))) + + +;Add an item to a dialog items list handle. HUH ? +(defun %rsc-string (n) + (or (cdr (assq n *error-format-strings*)) + (%str-cat "Error #" (%integer-to-string n)))) + +(defun string-arg (arg) + (or (string-argp arg) (error "~S is not a string" arg))) + +(defun string-argp (arg) + (cond ((symbolp arg) (symbol-name arg)) + ((typep arg 'character) (string arg)) + ((stringp arg) (ensure-simple-string arg)) + (t nil))) + +(defun symbol-arg (arg) + (unless (symbolp arg) + (report-bad-arg arg 'symbol)) + arg) + +(defun %cstrlen (ptr) + ;;(#_strlen ptr) + (do* ((i 0 (1+ i))) + ((zerop (the fixnum (%get-byte ptr i))) i) + (declare (fixnum i)))) + + +(defun %set-cstring (ptr string) + (%cstr-pointer string ptr) + string) + +(defsetf %get-cstring %set-cstring) + +;;; Deprecated, but used by UFFI. +(defun %put-cstring (ptr str &optional (offset 0)) + (setf (%get-cstring (%inc-ptr ptr offset)) str) + ;; 0 is the traditional, not-very-useful return value ... + 0) + + + + + + +;;; Returns a simple string and adjusted start and end, such that +;;; 0<= start <= end <= (length simple-string). +(defun get-sstring (str &optional (start 0) (end (length (require-type str 'string)))) + (multiple-value-bind (sstr offset) (array-data-and-offset (string str)) + (setq start (+ start offset) end (+ end offset)) + (when (< (length sstr) end)(setq end (length sstr))) + (when (< end start) (setq start end)) + (values sstr start end))) + +;e.g. (bad-named-arg :key key 'function) +(defun bad-named-arg (name arg &optional (type nil type-p)) + (if type-p + (%err-disp $err-bad-named-arg-2 name arg type) + (%err-disp $err-bad-named-arg name arg))) + +(defun verify-arg-count (call min &optional max) + "If call contains less than MIN number of args, or more than MAX + number of args, error. Otherwise, return call. + If Max is NIL, the maximum args for the fn are infinity." + (or (verify-call-count (car call) (%cdr call) min max) call)) + +(defun verify-call-count (sym args min &optional max &aux argcount) + (if (%i< (setq argcount (list-length args)) min) + (%err-disp $xtoofew (cons sym args)) + (if (if max (%i> argcount max)) + (%err-disp $xtoomany (cons sym args))))) + +(defun getf (place key &optional (default ())) + "Search the property list stored in Place for an indicator EQ to INDICATOR. + If one is found, return the corresponding value, else return DEFAULT." + (let ((p (pl-search place key))) (if p (%cadr p) default))) + +(defun remprop (symbol key) + "Look on property list of SYMBOL for property with specified + INDICATOR. If found, splice this indicator and its value out of + the plist, and return the tail of the original list starting with + INDICATOR. If not found, return () with no side effects. + + NOTE: The ANSI specification requires REMPROP to return true (not false) + or false (the symbol NIL). Portable code should not rely on any other value." + (do* ((prev nil plist) + (plist (symbol-plist symbol) tail) + (tail (cddr plist) (cddr tail))) + ((null plist)) + (when (eq (car plist) key) + (if prev + (rplacd (cdr prev) tail) + (setf (symbol-plist symbol) tail)) + (return t)))) + + + +;;; If this returns non-nil, safe to do %rplaca of %cdr to update. +(defun pl-search (plist key) + (unless (plistp plist) + (report-bad-arg plist '(satisfies plistp))) + (%pl-search plist key)) + + +(defun rassoc (item alist &key (test #'eql test-p) test-not (key #'identity)) + (declare (list alist)) + "Return the cons in ALIST whose CDR is equal (by a given test or EQL) to + the ITEM." + (if (or test-p (not test-not)) + (progn + (if test-not (error "Cannot specify both :TEST and :TEST-NOT.")) + (dolist (pair alist) + (if (atom pair) + (if pair (error "Invalid alist containing ~S: ~S" pair alist)) + (when (funcall test item (funcall key (cdr pair))) (return pair))))) + (progn + (unless test-not (error "Must specify at least one of :TEST or :TEST-NOT")) + (dolist (pair alist) + (if (atom pair) + (if pair (error "Invalid alist containing ~S: ~S" pair alist)) + (unless (funcall test-not item (funcall key (cdr pair))) (return pair))))))) + +(defun *%saved-method-var%* () + (declare (special %saved-method-var%)) + %saved-method-var%) + +(defun set-*%saved-method-var%* (new-value) + (declare (special %saved-method-var%)) + (setq %saved-method-var% new-value)) + +(defsetf *%saved-method-var%* set-*%saved-method-var%*) + + + + + + +(setf (symbol-function 'clear-type-cache) #'false) ; bootstrapping + +(defun make-array-1 (dims element-type element-type-p + displaced-to + displaced-index-offset + adjustable + fill-pointer + initial-element initial-element-p + initial-contents initial-contents-p + size) + (let ((subtype (element-type-subtype element-type))) + (when (and element-type (null subtype)) + (error "Unknown element-type ~S" element-type)) + (when (null size) + (cond ((listp dims) + (setq size 1) + (dolist (dim dims) + (when (< dim 0) + (report-bad-arg dim '(integer 0 *))) + (setq size (* size dim)))) + (t (setq size dims)))) ; no need to check vs. array-dimension-limit + (cond + (displaced-to + (when (or initial-element-p initial-contents-p) + (error "Cannot specify initial values for displaced arrays")) + (when (and element-type-p + (neq (array-element-subtype displaced-to) subtype)) + (error "The ~S array ~S is not of ~S ~S" + :displaced-to displaced-to :element-type element-type)) + (%make-displaced-array dims displaced-to + fill-pointer adjustable displaced-index-offset t)) + (t + (when displaced-index-offset + (error "Cannot specify ~S for non-displaced-array" :displaced-index-offset)) + (when (null subtype) + (error "Cannot make an array of empty type ~S" element-type)) + (make-uarray-1 subtype dims adjustable fill-pointer + initial-element initial-element-p + initial-contents initial-contents-p + nil size))))) + +(defun %make-simple-array (subtype dims) + (let* ((size (if (listp dims) (apply #'* dims) dims)) + (vector (%alloc-misc size subtype))) + (if (and (listp dims) + (not (eql (length dims) 1))) + (let* ((array (%make-displaced-array dims vector))) + (%set-simple-array-p array) + array) + vector))) + +(defun make-uarray-1 (subtype dims adjustable fill-pointer + initial-element initial-element-p + initial-contents initial-contents-p + temporary + size) + (declare (ignore temporary)) + (when (null size)(setq size (if (listp dims)(apply #'* dims) dims))) + (let ((vector (%alloc-misc size subtype))) ; may not get here in that case + (if initial-element-p + (dotimes (i (uvsize vector)) (declare (fixnum i))(uvset vector i initial-element)) + (if initial-contents-p + (if (null dims) (uvset vector 0 initial-contents) + (init-uvector-contents vector 0 dims initial-contents)))) + (if (and (null fill-pointer) + (not adjustable) + dims + (or (atom dims) (null (%cdr dims)))) + vector + (let ((array (%make-displaced-array dims vector + fill-pointer adjustable nil))) + (when (and (null fill-pointer) (not adjustable)) + (%set-simple-array-p array)) + array)))) + +(defun init-uvector-contents (vect offset dims contents + &aux (len (length contents))) + "Returns final offset. Assumes dims not ()." + (unless (eq len (if (atom dims) dims (%car dims))) + (error "~S doesn't match array dimensions of ~S ." contents vect)) + (cond ((or (atom dims) (null (%cdr dims))) + (if (listp contents) + (let ((contents-tail contents)) + (dotimes (i len) + (declare (fixnum i)) + (uvset vect offset (pop contents-tail)) + (setq offset (%i+ offset 1)))) + (dotimes (i len) + (declare (fixnum i)) + (uvset vect offset (elt contents i)) + (setq offset (%i+ offset 1))))) + (t (setq dims (%cdr dims)) + (if (listp contents) + (let ((contents-tail contents)) + (dotimes (i len) + (declare (fixnum i)) + (setq offset + (init-uvector-contents vect offset dims (pop contents-tail))))) + (dotimes (i len) + (declare (fixnum i)) + (setq offset + (init-uvector-contents vect offset dims (elt contents i))))))) + offset) + +(defun %get-signed-long-long (ptr &optional (offset 0)) + (%%get-signed-longlong ptr offset)) + +(defun %set-signed-long-long (ptr arg1 + &optional + (arg2 (prog1 arg1 (setq arg1 0)))) + (%%set-signed-longlong ptr arg1 arg2)) + +(defun %get-unsigned-long-long (ptr &optional (offset 0)) + (%%get-unsigned-longlong ptr offset)) + +(defun %set-unsigned-long-long (ptr arg1 + &optional + (arg2 (prog1 arg1 (setq arg1 0)))) + (%%set-unsigned-longlong ptr arg1 arg2)) + +(defun %composite-pointer-ref (size pointer offset) + (declare (ignorable size)) + (%inc-ptr pointer offset)) + +(defun %set-composite-pointer-ref (size pointer offset new) + (#_memmove (%inc-ptr pointer offset) + new + size)) + + +(defsetf %composite-pointer-ref %set-composite-pointer-ref) + + +(defsetf pathname-encoding-name set-pathname-encoding-name) + +;end of L1-utils.lisp + Index: /branches/new-random/level-1/level-1.lisp =================================================================== --- /branches/new-random/level-1/level-1.lisp (revision 13309) +++ /branches/new-random/level-1/level-1.lisp (revision 13309) @@ -0,0 +1,107 @@ +;;-*-Mode: LISP; Package: CCL -*- +;;; +;;; Copyright (C) 2009 Clozure Associates +;;; Copyright (C) 1994-2001 Digitool, Inc +;;; This file is part of Clozure CL. +;;; +;;; Clozure CL is licensed under the terms of the Lisp Lesser GNU Public +;;; License , known as the LLGPL and distributed with Clozure CL as the +;;; file "LICENSE". The LLGPL consists of a preamble and the LGPL, +;;; which is distributed with Clozure CL as the file "LGPL". Where these +;;; conflict, the preamble takes precedence. +;;; +;;; Clozure CL is referenced in the preamble as the "LIBRARY." +;;; +;;; The LLGPL is also available online at +;;; http://opensource.franz.com/preamble.html + +; Level-1.lisp + +(in-package "CCL") + +(macrolet ((l1-load (name) + (let* ((namestring + (concatenate 'simple-base-string + "./l1-fasls/" + (string name) + (namestring (backend-target-fasl-pathname + *target-backend*))))) + `(%fasload ,namestring))) + (bin-load (name) + (let* ((namestring + (concatenate 'simple-base-string + "./bin/" + (string name) + (namestring (backend-target-fasl-pathname + *target-backend*))))) + `(%fasload ,namestring)))) + + (l1-load "l1-cl-package") + (l1-load "l1-utils") + (l1-load "l1-init") + (l1-load "l1-symhash") + (l1-load "l1-numbers") + (l1-load "l1-aprims") + #+ppc-target + (l1-load "ppc-callback-support") + #+x86-target + (l1-load "x86-callback-support") + (l1-load "l1-callbacks") + (l1-load "l1-sort") + (bin-load "lists") + (bin-load "sequences") + (l1-load "l1-dcode") + (l1-load "l1-clos-boot") + (bin-load "hash") + (l1-load "l1-clos") + (bin-load "defstruct") + (bin-load "dll-node") + (l1-load "l1-unicode") + (l1-load "l1-streams") + (l1-load "linux-files") + (bin-load "chars") + (l1-load "l1-files") + (provide "SEQUENCES") + (provide "DEFSTRUCT") + (provide "CHARS") + (provide "LISTS") + (provide "DLL-NODE") + (l1-load "l1-typesys") + (l1-load "sysutils") + #+ppc-target + (l1-load "ppc-threads-utils") + #+x86-target + (l1-load "x86-threads-utils") + (l1-load "l1-lisp-threads") + (l1-load "l1-application") + (l1-load "l1-processes") + (l1-load "l1-io") + (l1-load "l1-reader") + (l1-load "l1-readloop") + (l1-load "l1-readloop-lds") + (l1-load "l1-error-system") + + (l1-load "l1-events") + #+ppc-target + (l1-load "ppc-trap-support") + #+x86-target + (l1-load "x86-trap-support") + (l1-load "l1-format") + (l1-load "l1-sysio") + (l1-load "l1-pathnames") + (l1-load "l1-boot-lds") + + (l1-load "l1-boot-1") + (l1-load "l1-boot-2") + (l1-load "l1-boot-3") + + ) + +(require "PREPARE-MCL-ENVIRONMENT") +(progn + (%set-toplevel #'(lambda () + (setq *loading-file-source-file* nil + *loading-toplevel-location* nil) + (toplevel-loop))) + (set-user-environment t) + (toplevel)) Index: /branches/new-random/level-1/linux-files.lisp =================================================================== --- /branches/new-random/level-1/linux-files.lisp (revision 13309) +++ /branches/new-random/level-1/linux-files.lisp (revision 13309) @@ -0,0 +1,2385 @@ +;;;-*- Mode: Lisp; Package: CCL -*- +;;; +;;; Copyright (C) 2009 Clozure Associates +;;; Copyright (C) 1994-2001 Digitool, Inc +;;; This file is part of Clozure CL. +;;; +;;; Clozure CL is licensed under the terms of the Lisp Lesser GNU Public +;;; License , known as the LLGPL and distributed with Clozure CL as the +;;; file "LICENSE". The LLGPL consists of a preamble and the LGPL, +;;; which is distributed with Clozure CL as the file "LGPL". Where these +;;; conflict, the preamble takes precedence. +;;; +;;; Clozure CL is referenced in the preamble as the "LIBRARY." +;;; +;;; The LLGPL is also available online at +;;; http://opensource.franz.com/preamble.html + +(in-package "CCL") + +(defconstant unix-to-universal-time 2208988800) + +#+windows-target +(progn + + + + +(defun nbackslash-to-forward-slash (namestring) + (dotimes (i (length namestring) namestring) + (when (eql (schar namestring i) #\\) + (setf (schar namestring i) #\/)))) + +(defconstant univeral-time-start-in-windows-seconds 9435484800) + +(defun windows-filetime-to-universal-time (ft) + (let* ((100-ns (dpb (pref ft #>FILETIME.dwHighDateTime) (byte 32 32) + (pref ft #>FILETIME.dwLowDateTime))) + (seconds-since-windows-epoch (floor 100-ns 10000000))) + (- seconds-since-windows-epoch univeral-time-start-in-windows-seconds))) +) + +(defun get-foreign-namestring (pointer) + ;; On Darwin, foreign namestrings are encoded in UTF-8 and + ;; are canonically decomposed (NFD). Use PRECOMPOSE-SIMPLE-STRING + ;; to ensure that the string is "precomposed" (NFC), like the + ;; rest of the world and most sane people would expect. + #+darwin-target + (precompose-simple-string (%get-utf-8-cstring pointer)) + #+windows-target (nbackslash-to-forward-slash + (%get-native-utf-16-cstring pointer)) + ;; On some other platforms, the namestring is assumed to + ;; be encoded according to the current locale's character + ;; encoding (though FreeBSD seems to be moving towards + ;; precomposed UTF-8.). + #-(or darwin-target windows-target) + (let* ((encoding-name (pathname-encoding-name))) + (if encoding-name + (get-encoded-cstring encoding-name pointer) + (%get-cstring pointer)))) + +(defun nanoseconds (n) + (unless (and (typep n 'fixnum) + (>= (the fixnum n) 0)) + (check-type n (real 0 #.(1- (ash 1 (1- target::nbits-in-word)))))) + (multiple-value-bind (q r) + (floor n) + (if (zerop r) + (setq r 0) + (setq r (floor (* r 1000000000)))) + (values q r))) + +(defun milliseconds (n) + (unless (and (typep n 'fixnum) + (>= (the fixnum n) 0)) + (check-type n (real 0 #.(1- (ash 1 (1- target::nbits-in-word)))))) + (multiple-value-bind (q r) + (floor n) + (if (zerop r) + (setq r 0) + (setq r (floor (* r 1000)))) + (values q r))) + +(defun microseconds (n) + (unless (and (typep n 'fixnum) + (>= (the fixnum n) 0)) + (check-type n (real 0 #.(1- (ash 1 (1- target::nbits-in-word)))))) + (multiple-value-bind (q r) + (floor n) + (if (zerop r) + (setq r 0) + (setq r (floor (* r 1000000)))) + (values q r))) + +(defun semaphore-value (s) + (if (istruct-typep s 'semaphore) + (semaphore.value s) + (semaphore-value (require-type s 'semaphore)))) + +(defun %wait-on-semaphore-ptr (s seconds milliseconds &optional flag) + (if flag + (if (istruct-typep flag 'semaphore-notification) + (setf (semaphore-notification.status flag) nil) + (report-bad-arg flag 'semaphore-notification))) + (without-interrupts + (let* ((status (ff-call + (%kernel-import target::kernel-import-wait-on-semaphore) + :address s + :unsigned seconds + :unsigned milliseconds + :signed)) + (result (zerop status))) + (declare (fixnum status)) + (when flag (setf (semaphore-notification.status flag) result)) + (values result status)))) + +(defun %process-wait-on-semaphore-ptr (s seconds milliseconds &optional + (whostate "semaphore wait") flag) + (or (%wait-on-semaphore-ptr s 0 0 flag) + (with-process-whostate (whostate) + (loop + (when (%wait-on-semaphore-ptr s seconds milliseconds flag) + (return)))))) + + +(defun wait-on-semaphore (s &optional flag (whostate "semaphore wait")) + "Wait until the given semaphore has a positive count which can be +atomically decremented." + (%process-wait-on-semaphore-ptr (semaphore-value s) #xffffff 0 whostate flag) + t) + + +(defun %timed-wait-on-semaphore-ptr (semptr duration notification) + (or (%wait-on-semaphore-ptr semptr 0 0 notification) + (with-process-whostate ("Semaphore timed wait") + (multiple-value-bind (secs millis) (milliseconds duration) + (let* ((now (get-internal-real-time)) + (stop (+ now + (* secs 1000) + millis))) + (loop + (multiple-value-bind (success err) + (progn + (%wait-on-semaphore-ptr semptr secs millis notification)) + (when success + (return t)) + (when (or (not (eql err #$EINTR)) + (>= (setq now (get-internal-real-time)) stop)) + (return nil)) + (unless (zerop duration) + (let* ((diff (- stop now))) + (multiple-value-bind (remaining-seconds remaining-millis) + (floor diff 1000) + (setq secs remaining-seconds + millis remaining-millis))))))))))) + +(defun timed-wait-on-semaphore (s duration &optional notification) + "Wait until the given semaphore has a postive count which can be +atomically decremented, or until a timeout expires." + (%timed-wait-on-semaphore-ptr (semaphore-value s) duration notification)) + + +(defun %signal-semaphore-ptr (p) + (ff-call + (%kernel-import target::kernel-import-signal-semaphore) + :address p + :signed-fullword)) + +(defun signal-semaphore (s) + "Atomically increment the count of a given semaphore." + (%signal-semaphore-ptr (semaphore-value s))) + +(defun %os-getcwd (buf noctets) + ;; Return N < 0, if error + ;; N < noctets: success, string is of length N (octets). + ;; N >= noctets: buffer needs to be larger. + (let* ((p #+windows-target + (#__wgetcwd buf (ash noctets -1)) + #-windows-target + (#_getcwd buf noctets))) + (declare (dynamic-extent p)) + (if (%null-ptr-p p) + (let* ((err (%get-errno))) + (if (eql err (- #$ERANGE)) + (+ noctets noctets) + err)) + #+windows-target + (do* ((i 0 (+ i 2))) + ((= i noctets) (+ noctets noctets)) + (when (eql (%get-unsigned-word buf i) 0) + (return i))) + #-windows-target + (dotimes (i noctets (+ noctets noctets)) + (when (eql 0 (%get-byte buf i)) + (return i)))))) + +(defun temp-pathname () + "Return a suitable pathname for a temporary file. A different name is returned +each time this is called in a session. No file by that name existed when last +checked, though no guarantee is given that one hasn't been created since." + (native-to-pathname + #-windows-target (get-foreign-namestring (#_tmpnam (%null-ptr))) + #+windows-target (rlet ((buffer (:array :wchar_t #.#$MAX_PATH))) + (#_GetTempPathW #$MAX_PATH buffer) + (with-filename-cstrs ((c-prefix "ccl")) + (#_GetTempFileNameW buffer c-prefix 0 buffer) + (#_DeleteFileW buffer) + (%get-native-utf-16-cstring buffer))))) + +(defun current-directory-name () + "Look up the current working directory of the Clozure CL process; unless +it has been changed, this is the directory Clozure CL was started in." + (flet ((try-getting-dirname (bufsize) + (%stack-block ((buf bufsize)) + (let* ((len (%os-getcwd buf bufsize))) + (cond ((< len 0) (%errno-disp len)) + ((< len bufsize) + (setf (%get-unsigned-byte buf len) 0) + (values (get-foreign-namestring buf) len)) + (t (values nil len))))))) + (do* ((string nil) + (len #+windows-target 128 #-windows-target 64) + (bufsize len len)) + ((multiple-value-setq (string len) (try-getting-dirname bufsize)) + string)))) + + +(defun current-directory () + (mac-default-directory)) + +(defun (setf current-directory) (path) + (cwd path) + path) + +(defun cd (path) + (cwd path)) + + + + +(defun %chdir (dirname) + (with-filename-cstrs ((dirname dirname)) + (int-errno-call (#+windows-target #__wchdir #-windows-target #_chdir dirname)))) + +(defun %mkdir (name mode) + #+windows-target (declare (ignore mode)) + (let* ((name name) + (len (length name))) + (when (and (> len 0) (eql (char name (1- len)) #\/)) + (setq name (subseq name 0 (1- len)))) + (with-filename-cstrs ((name name)) + (int-errno-call (#+windows-target #__wmkdir #-windows-target #_mkdir name #-windows-target mode))))) + +(defun %rmdir (name) + (let* ((last (1- (length name)))) + (with-filename-cstrs ((name name)) + (when (and (>= last 0) + (eql (%get-byte name last) (char-code #\/))) + (setf (%get-byte name last) 0)) + (int-errno-call (#+windows-target #__wrmdir #-windows-target #_rmdir name))))) + + +(defun getenv (key) + "Look up the value of the environment variable named by name, in the +OS environment." + (with-cstrs ((key (string key))) + (let* ((env-ptr (%null-ptr))) + (declare (dynamic-extent env-ptr)) + (%setf-macptr env-ptr (#_getenv key)) + (unless (%null-ptr-p env-ptr) + (%get-cstring env-ptr)))) + ) + +(defun setenv (key value &optional (overwrite t)) + "Set the value of the environment variable named by name, in the OS +environment. If there is no such environment variable, create it." + #+windows-target (declare (ignore overwrite)) + #-windows-target + (with-cstrs ((ckey key) + (cvalue value)) + (#_setenv ckey cvalue (if overwrite 1 0))) + #+windows-target + (with-cstrs ((pair (format nil "~a=~a" key value))) + (#__putenv pair)) + ) + +#-windows-target ; Windows "impersonation" crap ? +(defun setuid (uid) + "Attempt to change the current user ID (both real and effective); +fails unless the Clozure CL process has super-user privileges or the ID +given is that of the current user." + (int-errno-call (#_setuid uid))) + +#-windows-target +(defun setgid (uid) + "Attempt to change the current group ID (both real and effective); +fails unless the Clozure CL process has super-user privileges or the ID +given is that of a group to which the current user belongs." + (int-errno-call (#_setgid uid))) + + +;;; On Linux, "stat" & friends are implemented in terms of deeper, +;;; darker things that need to know what version of the stat buffer +;;; they're talking about. + +#-windows-target +(defun %stat-values (result stat) + (if (eql 0 (the fixnum result)) + (values + t + (pref stat :stat.st_mode) + (pref stat :stat.st_size) + #+(or linux-target solaris-target) + (pref stat :stat.st_mtim.tv_sec) + #-(or linux-target solaris-target) + (pref stat :stat.st_mtimespec.tv_sec) + (pref stat :stat.st_ino) + (pref stat :stat.st_uid) + (pref stat :stat.st_blksize) + #+(or linux-target solaris-target) + (round (pref stat :stat.st_mtim.tv_nsec) 1000) + #-(or linux-target solaris-target) + (round (pref stat :stat.st_mtimespec.tv_nsec) 1000) + (pref stat :stat.st_gid)) + (values nil nil nil nil nil nil nil))) + +#+win64-target +(defun %stat-values (result stat) + (if (eql 0 (the fixnum result)) + (values + t + (pref stat :_stat64.st_mode) + (pref stat :_stat64.st_size) + (pref stat :_stat64.st_mtime) + (pref stat :_stat64.st_ino) + (pref stat :_stat64.st_uid) + #$BUFSIZ + (pref stat :_stat64.st_mtime) ; ??? + (pref stat :_stat64.st_gid)) + (values nil nil nil nil nil nil nil nil nil))) + +#+win32-target +(defun %stat-values (result stat) + (if (eql 0 (the fixnum result)) + (values + t + (pref stat :__stat64.st_mode) + (pref stat :__stat64.st_size) + (pref stat :__stat64.st_mtime) + (pref stat :__stat64.st_ino) + (pref stat :__stat64.st_uid) + #$BUFSIZ + (pref stat :__stat64.st_mtime) ; ??? + (pref stat :__stat64.st_gid)) + (values nil nil nil nil nil nil nil nil nil))) + +#+windows-target +(defun windows-strip-trailing-slash (namestring) + (do* ((len (length namestring) (length namestring))) + ((<= len 3) namestring) + (let* ((p (1- len)) + (ch (char namestring p))) + (unless (or (eql ch #\\) + (eql ch #\/)) + (return namestring)) + (setq namestring (subseq namestring 0 p))))) + + +(defun %%stat (name stat) + (with-filename-cstrs ((cname #+windows-target (windows-strip-trailing-slash name) #-windows-target name)) + (%stat-values + #+linux-target + (#_ __xstat #$_STAT_VER_LINUX cname stat) + #-linux-target + (int-errno-ffcall (%kernel-import target::kernel-import-lisp-stat) + :address cname + :address stat + :int) + stat))) + +(defun %%fstat (fd stat) + (%stat-values + #+linux-target + (#_ __fxstat #$_STAT_VER_LINUX fd stat) + #-linux-target + (int-errno-ffcall (%kernel-import target::kernel-import-lisp-fstat) + :int fd + :address stat + :int) + stat)) + +#-windows-target +(defun %%lstat (name stat) + (with-filename-cstrs ((cname name)) + (%stat-values + #+linux-target + (#_ __lxstat #$_STAT_VER_LINUX cname stat) + #-linux-target + (#_lstat cname stat) + stat))) + + +;;; Returns: (values t mode size mtime inode uid blksize) on success, +;;; (values nil nil nil nil nil nil nil) otherwise +;;; NAME should be a "native namestring", e.g,, have all lisp pathname +;;; escaping removed. +#-windows-target +(defun %stat (name &optional link-p) + (rlet ((stat :stat)) + (if link-p + (%%lstat name stat) + (%%stat name stat)))) + +#+windows-target +(defun %stat (name &optional link-p) + (declare (ignore link-p)) + (rlet ((stat #+win64-target #>_stat64 #+win32-target #>__stat64)) + (%%stat name stat))) + +(defun %fstat (fd) + (rlet ((stat #+win64-target #>_stat64 #+win32-target #>__stat64 #-windows-target :stat)) + (%%fstat fd stat))) + + +(defun %file-kind (mode &optional fd) + (declare (ignorable fd)) + (when mode + (let* ((kind (logand mode #$S_IFMT))) + (cond ((eql kind #$S_IFDIR) :directory) + ((eql kind #$S_IFREG) :file) + #-windows-target + ((eql kind #$S_IFLNK) :link) + ((eql kind #$S_IFIFO) + #-windows-target :pipe + ;; Windows doesn't seem to be able to distinguish between + ;; sockets and pipes. Since this function is currently + ;; (mostly) used for printing streams and since we've + ;; already done something fairly expensive (stat, fstat) + ;; to get here. try to distinguish between pipes and + ;; sockets by calling #_getsockopt. If that succeeds, + ;; we've got a socket; otherwise, we're probably got a pipe. + #+windows-target (rlet ((ptype :int) + (plen :int 4)) + (if (and fd (eql 0 (#_getsockopt fd #$SOL_SOCKET #$SO_TYPE ptype plen))) + :socket + :pipe))) + #-windows-target + ((eql kind #$S_IFSOCK) :socket) + ((eql kind #$S_IFCHR) :character-special) + (t :special))))) + +(defun %unix-file-kind (native-namestring &optional check-for-link) + (%file-kind (nth-value 1 (%stat native-namestring check-for-link)))) + +(defun %unix-fd-kind (fd) + (if (isatty fd) + :tty + (%file-kind (nth-value 1 (%fstat fd)) fd))) + +#-windows-target +(defun %uts-string (result idx buf) + (if (>= result 0) + (%get-cstring (%inc-ptr buf (* #+linux-target #$_UTSNAME_LENGTH + #+darwin-target #$_SYS_NAMELEN + #+(or freebsd-target solaris-target) #$SYS_NMLN + idx))) + "unknown")) + +#-windows-target +(defun copy-file-attributes (source-path dest-path) + "Copy the mode, owner, group and modification time of source-path to dest-path. + Returns T if succeeded, NIL if some of the attributes couldn't be copied due to + permission problems. Any other failures cause an error to be signalled" + (multiple-value-bind (win mode ignore mtime-sec ignore uid ignore mtime-usec gid) + (%stat (native-translated-namestring source-path) t) + (declare (ignore ignore)) + (unless win + (error "Cannot get attributes of ~s" source-path)) + (with-filename-cstrs ((cnamestr (native-translated-namestring dest-path))) + (macrolet ((errchk (form) + `(let ((err ,form)) + (unless (eql err 0) + (setq win nil) + (when (eql err -1) + (setq err (- (%get-errno)))) + (unless (eql err #$EPERM) (%errno-disp err dest-path)))))) + (errchk (#_chmod cnamestr mode)) + (errchk (%stack-block ((times (record-length (:array (:struct :timeval) 2)))) + (setf (pref times :timeval.tv_sec) mtime-sec) + (setf (pref times :timeval.tv_usec) mtime-usec) + (%incf-ptr times (record-length :timeval)) + (setf (pref times :timeval.tv_sec) mtime-sec) + (setf (pref times :timeval.tv_usec) mtime-usec) + (%incf-ptr times (- (record-length :timeval))) + (#_utimes cnamestr times))) + (errchk (#_chown cnamestr uid gid)))) + win)) + +#+windows-target +(defun copy-file-attributes (source-path dest-path) + "could at least copy the file times" + (declare (ignore source-path dest-path))) + + +#+linux-target +(defun %uname (idx) + (%stack-block ((buf (* #$_UTSNAME_LENGTH 6))) + (%uts-string (#_uname buf) idx buf))) + +#+darwin-target +(defun %uname (idx) + (%stack-block ((buf (* #$_SYS_NAMELEN 5))) + (%uts-string (#_uname buf) idx buf))) + +#+freebsd-target +(defun %uname (idx) + (%stack-block ((buf (* #$SYS_NMLN 5))) + (%uts-string (#___xuname #$SYS_NMLN buf) idx buf))) + +#+solaris-target +(defun %uname (idx) + (%stack-block ((buf (* #$SYS_NMLN 5))) + (%uts-string (#_uname buf) idx buf))) + +#-windows-target +(defun fd-dup (fd) + (int-errno-call (#_dup fd))) + +#+windows-target +(defun fd-dup (fd &key direction inheritable) + (declare (ignore direction)) + (rlet ((handle #>HANDLE)) + (if (eql 0 (#_DuplicateHandle (#_GetCurrentProcess) + (%int-to-ptr fd) + (#_GetCurrentProcess) + handle + 0 + (if inheritable #$TRUE #$FALSE) + #$DUPLICATE_SAME_ACCESS)) + (%windows-error-disp (#_GetLastError)) + (pref handle #>DWORD)))) + + +(defun fd-fsync (fd) + #+windows-target (#_FlushFileBuffers (%int-to-ptr fd)) + #-windows-target + (int-errno-call (#_fsync fd))) + +#-windows-target +(progn +(defun fd-get-flags (fd) + (int-errno-call (#_fcntl fd #$F_GETFL))) + +(defun fd-set-flags (fd new) + (int-errno-call (#_fcntl fd #$F_SETFL :int new))) + +(defun fd-set-flag (fd mask) + (let* ((old (fd-get-flags fd))) + (if (< old 0) + old + (fd-set-flags fd (logior old mask))))) + +(defun fd-clear-flag (fd mask) + (let* ((old (fd-get-flags fd))) + (if (< old 0) + old + (fd-set-flags fd (logandc2 old mask))))) +) + +;;; Assume that any quoting's been removed already. +(defun tilde-expand (namestring) + (let* ((len (length namestring))) + (if (or (zerop len) + (not (eql (schar namestring 0) #\~))) + namestring + (if (or (= len 1) + (eql (schar namestring 1) #\/)) + (concatenate 'string (get-user-home-dir (getuid)) (if (= len 1) "/" (subseq namestring 1))) + #+windows-target namestring + #-windows-target + (let* ((slash-pos (position #\/ namestring)) + (user-name (subseq namestring 1 slash-pos)) + (uid (or (get-uid-from-name user-name) + (error "Unknown user ~s in namestring ~s" user-name namestring)))) + (concatenate 'string (get-user-home-dir uid) (if slash-pos (subseq namestring slash-pos) "/"))))))) + + +#+windows-target +(defun %windows-realpath (namestring) + (with-filename-cstrs ((path namestring)) + (do* ((bufsize 256)) + () + (%stack-block ((buf bufsize)) + (let* ((nchars (#_GetFullPathNameW path (ash bufsize -1) buf (%null-ptr)))) + (if (eql 0 nchars) + (return nil) + (let* ((max (+ nchars nchars 2))) + (if (> max bufsize) + (setq bufsize max) + (let* ((real (get-foreign-namestring buf))) + (return (and (%stat real) real))))))))))) + + +;;; This doesn't seem to exist on VxWorks. It's a POSIX +;;; function AFAIK, so the source should be somewhere ... + +(defun %realpath (namestring) + ;; It's not at all right to just return the namestring here. + (when (zerop (length namestring)) + (setq namestring (current-directory-name))) + #+windows-target (%windows-realpath namestring) + #-windows-target + (%stack-block ((resultbuf #$PATH_MAX)) + (with-filename-cstrs ((name namestring #|(tilde-expand namestring)|#)) + (let* ((result (#_realpath name resultbuf))) + (declare (dynamic-extent result)) + (unless (%null-ptr-p result) + (get-foreign-namestring result)))))) + +;;; Return fully resolved pathname & file kind, or (values nil nil) + +(defun %probe-file-x (namestring) + (let* ((realpath (%realpath namestring)) + (kind (if realpath (%unix-file-kind realpath)))) + (if kind + (values realpath kind) + (values nil nil)))) + +;;; The mingw headers define timeval.tv_sec and timeval.tv_usec to be +;;; signed 32-bit quantities. +(macrolet ((timeval-ref (ptr accessor) + #+windows-target `(logand #xfffffffff (pref ,ptr ,accessor)) + #-windows-target `(pref ,ptr ,accessor)) + (set-timeval-ref (ptr accessor new) + `(setf (pref ,ptr ,accessor) + #+windows-target (u32->s32 ,new) + #-windows-target ,new))) + +(defun timeval->milliseconds (tv) + (+ (* 1000 (timeval-ref tv :timeval.tv_sec)) (round (timeval-ref tv :timeval.tv_usec) 1000))) + +(defun timeval->microseconds (tv) + (+ (* 1000000 (timeval-ref tv :timeval.tv_sec)) (timeval-ref tv :timeval.tv_usec))) + +(defun %add-timevals (result a b) + (let* ((seconds (+ (timeval-ref a :timeval.tv_sec) (timeval-ref b :timeval.tv_sec))) + (micros (+ (timeval-ref a :timeval.tv_usec) (timeval-ref b :timeval.tv_usec)))) + (if (>= micros 1000000) + (setq seconds (1+ seconds) micros (- micros 1000000))) + (set-timeval-ref result :timeval.tv_sec seconds) + (set-timeval-ref result :timeval.tv_usec micros) + result)) + +(defun %sub-timevals (result a b) + (let* ((seconds (- (timeval-ref a :timeval.tv_sec) (timeval-ref b :timeval.tv_sec))) + (micros (- (timeval-ref a :timeval.tv_usec) (timeval-ref b :timeval.tv_usec)))) + (if (< micros 0) + (setq seconds (1- seconds) micros (+ micros 1000000))) + (set-timeval-ref result :timeval.tv_sec seconds) + (set-timeval-ref result :timeval.tv_usec micros) + result)) + +;;; Return T iff the time denoted by the timeval a is not later than the +;;; time denoted by the timeval b. +(defun %timeval<= (a b) + (let* ((asec (timeval-ref a :timeval.tv_sec)) + (bsec (timeval-ref b :timeval.tv_sec))) + (or (< asec bsec) + (and (= asec bsec) + (< (timeval-ref a :timeval.tv_usec) + (timeval-ref b :timeval.tv_usec)))))) + +); windows signed nonsense. + +#-windows-target +(defun %%rusage (usage &optional (who #$RUSAGE_SELF)) + (int-errno-call (#_getrusage who usage))) + + + + +(defun %file-write-date (namestring) + (let* ((date (nth-value 3 (%stat namestring)))) + (if date + (+ date unix-to-universal-time)))) + +#-windows-target +(defun %file-author (namestring) + (let* ((uid (nth-value 5 (%stat namestring)))) + (if uid + (with-macptrs ((pw (#_getpwuid uid))) + (unless (%null-ptr-p pw) + (without-interrupts + (%get-cstring (pref pw :passwd.pw_name)))))))) + +#+windows-target +(defun %file-author (namestring) + (declare (ignore namestring)) + nil) + +#-windows-target +(defun %utimes (namestring) + (with-filename-cstrs ((cnamestring namestring)) + (let* ((err (#_utimes cnamestring (%null-ptr)))) + (declare (fixnum err)) + (or (eql err 0) + (%errno-disp err namestring))))) + +#+windows-target +(defun %utimes (namestring) + (with-filename-cstrs ((cnamestring namestring)) + (let* ((handle (#_CreateFileW + cnamestring + #$FILE_WRITE_ATTRIBUTES + (logior #$FILE_SHARE_READ #$FILE_SHARE_WRITE) + (%null-ptr) + #$OPEN_EXISTING + #$FILE_FLAG_BACKUP_SEMANTICS + (%null-ptr)))) + (if (eql handle *windows-invalid-handle*) + (%windows-error-disp (#_GetLastError)) + (rlet ((st #>SYSTEMTIME) + (ft #>FILETIME)) + (#_GetSystemTime st) + (#_SystemTimeToFileTime st ft) + (let* ((result (#_SetFileTime handle (%null-ptr) (%null-ptr) ft)) + (err (when (eql 0 result) (#_GetLastError)))) + (#_CloseHandle handle) + (if err + (%windows-error-disp err) + t))))))) + + + + +#-windows-target +(defun get-uid-from-name (name) + (with-cstrs ((name name)) + (let* ((pwent (#_getpwnam name))) + (unless (%null-ptr-p pwent) + (pref pwent :passwd.pw_uid))))) + + +(defun isatty (fd) + #+windows-target (declare (ignore fd)) + #+windows-target nil + #-windows-target + (= 1 (#_isatty fd))) + +(defun %open-dir (namestring) + (with-filename-cstrs ((name namestring)) + (let* ((DIR (ff-call (%kernel-import target::kernel-import-lisp-opendir) + :address name + :address))) + (unless (%null-ptr-p DIR) + DIR)))) + +(defun close-dir (dir) + (ff-call (%kernel-import target::kernel-import-lisp-closedir) + :address dir + :int)) + +(defun %read-dir (dir) + (let* ((res (ff-call (%kernel-import target::kernel-import-lisp-readdir) + :address dir + :address))) + (unless (%null-ptr-p res) + (get-foreign-namestring (pref res + #+windows-target :_wdirent.d_name + #-windows-target :dirent.d_name))))) + + +#-windows-target +(defun tcgetpgrp (fd) + (#_tcgetpgrp fd)) + +(defun getpid () + "Return the ID of the Clozure CL OS process." + #-windows-target + (int-errno-call (#_getpid)) + #+windows-target (#_GetCurrentProcessId)) + + +(defun getuid () + "Return the (real) user ID of the current user." + #+windows-target 0 + #-windows-target (int-errno-call (#_getuid))) + +(defun get-user-home-dir (userid) + "Look up and return the defined home directory of the user identified +by uid. This value comes from the OS user database, not from the $HOME +environment variable. Returns NIL if there is no user with the ID uid." + #+windows-target + (declare (ignore userid)) + #+windows-target + (dolist (k '(#||"HOME"||# "USERPROFILE")) + (with-native-utf-16-cstrs ((key k)) + (let* ((p (#__wgetenv key))) + (unless (%null-ptr-p p) + (return (get-foreign-namestring p)))))) + #-windows-target + (rlet ((pwd :passwd) + (result :address pwd)) + (do* ((buflen 512 (* 2 buflen))) + () + (%stack-block ((buf buflen)) + (let* ((err + #-solaris-target + (#_getpwuid_r userid pwd buf buflen result) + #+solaris-target + (external-call "__posix_getpwuid_r" + :uid_t userid + :address pwd + :address buf + :int buflen + :address result + :int))) + (if (eql 0 err) + (let* ((rp (%get-ptr result)) + (dir (and (not (%null-ptr-p rp)) + (get-foreign-namestring (pref rp :passwd.pw_dir))))) + (return (if (and dir (eq (%unix-file-kind dir) :directory)) + dir))) + (unless (eql err #$ERANGE) + (return nil)))))))) + +(defun %delete-file (name) + (with-cstrs ((n name)) + (int-errno-call (#+windows-target #__unlink #-windows-target #_unlink n)))) + +(defun os-command (string) + "Invoke the Posix function system(), which invokes the user's default +system shell (such as sh or tcsh) as a new process, and has that shell +execute command-line. + +If the shell was able to find the command specified in command-line, then +exit-code is the exit code of that command. If not, it is the exit code +of the shell itself." + (with-cstrs ((s string)) + (#_system s))) + +(defun %strerror (errno) + (declare (fixnum errno)) + (if (< errno 0) + (setq errno (- errno))) + (with-macptrs (p) + (%setf-macptr p (#_strerror errno)) + (if (%null-ptr-p p) + (format nil "OS Error ~d" errno) + (%get-cstring p)))) + +#+windows-target +(defun %windows-error-string (error-number) + (rlet ((pbuffer :address (%null-ptr))) + (if (eql 0 + (#_FormatMessageW (logior #$FORMAT_MESSAGE_ALLOCATE_BUFFER + #$FORMAT_MESSAGE_FROM_SYSTEM + #$FORMAT_MESSAGE_IGNORE_INSERTS + #$FORMAT_MESSAGE_MAX_WIDTH_MASK) + (%null-ptr) + (abs error-number) + 0 ; default langid, more-or-less + pbuffer + 0 + (%null-ptr))) + (format nil "Windows error ~d" (abs error-number)) + (let* ((p (%get-ptr pbuffer)) + (q (%get-native-utf-16-cstring p))) + (#_LocalFree p) + q)))) + + + +;;; Kind of has something to do with files, and doesn't work in level-0. +#+(or linux-target freebsd-target solaris-target) +(defun close-shared-library (lib &key (completely t)) + "If completely is T, set the reference count of library to 0. Otherwise, +decrements it by 1. In either case, if the reference count becomes 0, +close-shared-library frees all memory resources consumed library and causes +any EXTERNAL-ENTRY-POINTs known to be defined by it to become unresolved." + (let* ((lib (if (typep lib 'string) + (or (shared-library-with-name lib) + (error "Shared library ~s not found." lib)) + (require-type lib 'shlib))) + (handle (shlib.handle lib))) + (when handle + (let* ((found nil) + (base (shlib.base lib))) + (do* () + ((progn + (#_dlclose handle) + (or (not (setq found (shlib-containing-address base))) + (not completely))))) + (when (not found) + (setf (shlib.pathname lib) nil + (shlib.base lib) nil + (shlib.handle lib) nil + (shlib.map lib) nil) + (unload-foreign-variables lib) + (unload-library-entrypoints lib)))))) + +#+darwin-target +;; completely specifies whether to remove it totally from our list +(defun close-shared-library (lib &key (completely nil)) + "If completely is T, set the reference count of library to 0. Otherwise, +decrements it by 1. In either case, if the reference count becomes 0, +close-shared-library frees all memory resources consumed library and causes +any EXTERNAL-ENTRY-POINTs known to be defined by it to become unresolved." + (let* ((lib (if (typep lib 'string) + (or (shared-library-with-name lib) + (error "Shared library ~s not found." lib)) + (require-type lib 'shlib)))) + ;; no possible danger closing libsystem since dylibs can't be closed + (cond + ((or (not (shlib.map lib)) (not (shlib.base lib))) + (error "Shared library ~s uninitialized." (shlib.soname lib))) + ((and (not (%null-ptr-p (shlib.map lib))) + (%null-ptr-p (shlib.base lib))) + (warn "Dynamic libraries cannot be closed on Darwin.")) + ((and (%null-ptr-p (shlib.map lib)) + (not (%null-ptr-p (shlib.base lib)))) + ;; we have a bundle type library not sure what to do with the + ;; completely flag when we open the same bundle more than once, + ;; Darwin gives back a new module address, so we have multiple + ;; entries on *shared-libraries* the best we can do is unlink + ;; the module asked for (or our best guess based on name) and + ;; invalidate any entries which refer to this container + (if (= 0 (#_NSUnLinkModule (shlib.base lib) #$NSUNLINKMODULE_OPTION_NONE)) + (error "Unable to close shared library, NSUnlinkModule failed.") + (progn + (setf (shlib.map lib) nil + (shlib.base lib) nil) + (unload-library-entrypoints lib) + (when completely + (setq *shared-libraries* (delete lib *shared-libraries*))))))))) + + + + +;;; Foreign (unix) processes. + +(defun call-with-string-vector (function strings) + (let ((bufsize (reduce #'+ strings + :key #'(lambda (s) (1+ (length (string s)))))) + (argvsize (ash (1+ (length strings)) target::word-shift)) + (bufpos 0) + (argvpos 0)) + (%stack-block ((buf bufsize) (argv argvsize)) + (flet ((init (s) + (multiple-value-bind (sstr start end) (get-sstring s) + (declare (fixnum start end)) + (let ((len (- end start))) + (declare (fixnum len)) + (do* ((i 0 (1+ i)) + (start start (1+ start)) + (bufpos bufpos (1+ bufpos))) + ((= i len)) + (setf (%get-unsigned-byte buf bufpos) + (logand #xff (%scharcode sstr start)))) + (setf (%get-byte buf (%i+ bufpos len)) 0) + (setf (%get-ptr argv argvpos) (%inc-ptr buf bufpos)) + (setq bufpos (%i+ bufpos len 1)) + (setq argvpos (%i+ argvpos target::node-size)))))) + (declare (dynamic-extent #'init)) + (map nil #'init strings)) + (setf (%get-ptr argv argvpos) (%null-ptr)) + (funcall function argv)))) + +(defmacro with-string-vector ((var strings) &body body) + `(call-with-string-vector #'(lambda (,var) ,@body) ,strings)) + +(defloadvar *max-os-open-files* #-windows-target (#_getdtablesize) #+windows-target 32) + +(defun pipe () + ;; (rlet ((filedes (:array :int 2))) + (%stack-block ((filedes 8)) + (let* ((status (ff-call (%kernel-import target::kernel-import-lisp-pipe) + :address filedes :int)) + (errno (if (eql status 0) 0 (%get-errno)))) + (unless (zerop status) + (when (or (eql errno (- #$EMFILE)) + (eql errno (- #$ENFILE))) + (gc) + (drain-termination-queue) + (setq status (ff-call (%kernel-import target::kernel-import-lisp-pipe) + :address filedes :int) + errno (if (zerop status) 0 (%get-errno))))) + (if (zerop status) + (values (paref filedes (:array :int) 0) (paref filedes (:array :int) 1)) + (%errno-disp errno))))) + +#-windows-target +(progn + (defun %execvp (argv) + (#_execvp (%get-ptr argv) argv) + (#_exit #$EX_OSERR)) + + (defun exec-with-io-redirection (new-in new-out new-err argv) + (#_setpgid 0 0) + (if new-in (#_dup2 new-in 0)) + (if new-out (#_dup2 new-out 1)) + (if new-err (#_dup2 new-err 2)) + (do* ((fd 3 (1+ fd))) + ((= fd *max-os-open-files*) (%execvp argv)) + (declare (fixnum fd)) + (#_close fd))) + + + + + + (defstruct external-process + pid + %status + %exit-code + pty + input + output + error + status-hook + plist + token + core + args + (signal (make-semaphore)) + (completed (make-semaphore)) + watched-fds + watched-streams + external-format + ) + + (defmethod print-object ((p external-process) stream) + (print-unreadable-object (p stream :type t :identity t) + (let* ((status (external-process-%status p))) + (let* ((*print-length* 3)) + (format stream "~a" (external-process-args p))) + (format stream "[~d] (~a" (external-process-pid p) status) + (unless (eq status :running) + (format stream " : ~d" (external-process-%exit-code p))) + (format stream ")")))) + + (defun get-descriptor-for (object proc close-in-parent close-on-error + &rest keys + &key direction (element-type 'character) + (sharing :private) + external-format + &allow-other-keys) + (etypecase object + ((eql t) + (values nil nil close-in-parent close-on-error)) + (null + (let* ((null-device #+windows-target "nul" #-windows-target "/dev/null") + (fd (fd-open null-device (case direction + (:input #$O_RDONLY) + (:output #$O_WRONLY) + (t #$O_RDWR))))) + (if (< fd 0) + (signal-file-error fd null-device)) + (values fd nil (cons fd close-in-parent) (cons fd close-on-error)))) + ((eql :stream) + (multiple-value-bind (read-pipe write-pipe) (pipe) + (case direction + (:input + (values read-pipe + (make-fd-stream write-pipe + :direction :output + :element-type element-type + :interactive nil + :sharing sharing + :basic t + :encoding (external-format-character-encoding external-format) + :line-termination (external-format-line-termination external-format) + :auto-close t) + (cons read-pipe close-in-parent) + (cons write-pipe close-on-error))) + (:output + (values write-pipe + (make-fd-stream read-pipe + :direction :input + :element-type element-type + :interactive nil + :basic t + :sharing sharing + :encoding (external-format-character-encoding external-format) + :line-termination (external-format-line-termination external-format) + :auto-close t) + (cons write-pipe close-in-parent) + (cons read-pipe close-on-error))) + (t + (fd-close read-pipe) + (fd-close write-pipe) + (report-bad-arg direction '(member :input :output)))))) + ((or pathname string) + (with-open-stream (file (apply #'open object keys)) + (let* ((fd (fd-dup (ioblock-device (stream-ioblock file t))))) + (values fd + nil + (cons fd close-in-parent) + (cons fd close-on-error))))) + #|| + ;; What's an FD-STREAM ? + (fd-stream + (let ((fd (fd-dup (ioblock-device (stream-ioblock object t))))) + (values fd + nil + (cons fd close-in-parent) + (cons fd close-on-error)))) + ||# + (stream + (ecase direction + (:input + (with-cstrs ((template "/tmp/lisp-tempXXXXXX")) + (let* ((fd (#_mkstemp template))) + (if (< fd 0) + (%errno-disp fd)) + (#_unlink template) + (let* ((out (make-fd-stream (fd-dup fd) + :direction :output + :encoding (external-format-character-encoding external-format) + :line-termination (external-format-line-termination external-format)))) + (loop + (multiple-value-bind (line no-newline) + (read-line object nil nil) + (unless line + (return)) + (if no-newline + (write-string line out) + (write-line line out)))) + (close out)) + (fd-lseek fd 0 #$SEEK_SET) + (values fd nil (cons fd close-in-parent) (cons fd close-on-error))))) + (:output + (multiple-value-bind (read-pipe write-pipe) (pipe) + (push read-pipe (external-process-watched-fds proc)) + (push object (external-process-watched-streams proc)) + (incf (car (external-process-token proc))) + (values write-pipe + nil + (cons write-pipe close-in-parent) + (cons read-pipe close-on-error)))))))) + + (let* ((external-processes ()) + (external-processes-lock (make-lock))) + (defun add-external-process (p) + (with-lock-grabbed (external-processes-lock) + (push p external-processes))) + (defun remove-external-process (p) + (with-lock-grabbed (external-processes-lock) + (setq external-processes (delete p external-processes)))) + ;; Likewise + (defun external-processes () + (with-lock-grabbed (external-processes-lock) + (copy-list external-processes))) + ) + + + (defmacro wtermsig (status) + `(ldb (byte 7 0) ,status)) + + (defmacro wexitstatus (status) + `(ldb (byte 8 8) (the fixnum ,status))) + + (defmacro wstopsig (status) + `(wexitstatus ,status)) + + (defmacro wifexited (status) + `(eql (wtermsig ,status) 0)) + + (defmacro wifstopped (status) + `(eql #x7f (ldb (byte 7 0) (the fixnum ,status)))) + + (defun monitor-external-process (p) + (let* ((in-fds (external-process-watched-fds p)) + (out-streams (external-process-watched-streams p)) + (token (external-process-token p)) + (terminated) + (changed) + (maxfd 0) + (external-format (external-process-external-format p)) + (encoding (external-format-character-encoding external-format)) + (line-termination (external-format-line-termination external-format)) + (pairs (pairlis + (mapcar (lambda (fd) + (cons fd + (make-fd-stream fd + :direction :input + :sharing :private + :encoding encoding + :line-termination line-termination))) + in-fds) out-streams))) + (%stack-block ((in-fd-set *fd-set-size*)) + (rlet ((tv #>timeval)) + (loop + (when changed + (setq pairs (delete nil pairs :key #'car) + changed nil)) + (when (and terminated (null pairs)) + (signal-semaphore (external-process-completed p)) + (return)) + (when pairs + (fd-zero in-fd-set) + (setq maxfd 0) + (dolist (p pairs) + (let* ((fd (caar p))) + (when (> fd maxfd) + (setq maxfd fd)) + (fd-set fd in-fd-set))) + (setf (pref tv #>timeval.tv_sec) 1 + (pref tv #>timeval.tv_usec) 0) + (when (> (#_select (1+ maxfd) in-fd-set (%null-ptr) (%null-ptr) tv) + 0) + (dolist (p pairs) + (let* ((in-fd (caar p)) + (in-stream (cdar p)) + (out-stream (cdr p))) + (when (fd-is-set in-fd in-fd-set) + (let* ((buf (make-string 1024)) + (n (ignore-errors (read-sequence buf in-stream)))) + (declare (dynamic-extent buf)) + (if (or (null n) (eql n 0)) + (without-interrupts + (decf (car token)) + (close in-stream) + (setf (car p) nil changed t)) + (write-sequence buf out-stream :end n)))))))) + (let* ((statusflags (check-pid (external-process-pid p) + (logior + (if in-fds #$WNOHANG 0) + #$WUNTRACED))) + (oldstatus (external-process-%status p))) + (cond ((null statusflags) + (remove-external-process p) + (setq terminated t)) + ((eq statusflags t)) ; Running. + (t + (multiple-value-bind (status code core) + (cond ((wifstopped statusflags) + (values :stopped (wstopsig statusflags))) + ((wifexited statusflags) + (values :exited (wexitstatus statusflags))) + (t + (let* ((signal (wtermsig statusflags))) + (declare (fixnum signal)) + (values + (if (or (= signal #$SIGSTOP) + (= signal #$SIGTSTP) + (= signal #$SIGTTIN) + (= signal #$SIGTTOU)) + :stopped + :signaled) + signal + (logtest #-solaris-target #$WCOREFLAG + #+solaris-target #$WCOREFLG + statusflags))))) + (setf (external-process-%status p) status + (external-process-%exit-code p) code + (external-process-core p) core) + (let* ((status-hook (external-process-status-hook p))) + (when (and status-hook (not (eq oldstatus status))) + (funcall status-hook p))) + (when (or (eq status :exited) + (eq status :signaled)) + (remove-external-process p) + (setq terminated t))))))))))) + + (defun run-external-process (proc in-fd out-fd error-fd argv &optional env) + (let* ((signaled nil)) + (unwind-protect + (let* ((child-pid (#-solaris-target #_fork #+solaris-target #_forkall))) + (declare (fixnum child-pid)) + (cond ((zerop child-pid) + ;; Running in the child; do an exec + (setq signaled t) + (dolist (pair env) + (setenv (string (car pair)) (cdr pair))) + (without-interrupts + (exec-with-io-redirection + in-fd out-fd error-fd argv))) + ((> child-pid 0) + ;; Running in the parent: success + (setf (external-process-pid proc) child-pid) + (add-external-process proc) + (signal-semaphore (external-process-signal proc)) + (setq signaled t) + (monitor-external-process proc)) + (t + ;; Fork failed + (setf (external-process-%status proc) :error + (external-process-%exit-code proc) (%get-errno)) + (signal-semaphore (external-process-signal proc)) + (setq signaled t)))) + (unless signaled + (setf (external-process-%status proc) :error + (external-process-%exit-code proc) -1) + (signal-semaphore (external-process-signal proc)))))) + + (defparameter *silently-ignore-catastrophic-failure-in-run-program* + #+ccl-0711 t #-ccl-0711 nil + "If NIL, signal an error if run-program is unable to start the program. +If non-NIL, treat failure to start the same as failure from the program +itself, by setting the status and exit-code fields.") + + (defun run-program (program args &key + (wait t) pty + input if-input-does-not-exist + output (if-output-exists :error) + (error :output) (if-error-exists :error) + status-hook (element-type 'character) + env + (sharing :private) + (external-format `(:character-encoding ,*terminal-character-encoding-name*)) + (silently-ignore-catastrophic-failures + *silently-ignore-catastrophic-failure-in-run-program*)) + "Invoke an external program as an OS subprocess of lisp." + (declare (ignore pty)) + (unless (every #'(lambda (a) (typep a 'simple-string)) args) + (error "Program args must all be simple strings : ~s" args)) + (dolist (pair env) + (destructuring-bind (var . val) pair + (check-type var (or string symbol character)) + (check-type val string))) + (push (native-untranslated-namestring program) args) + (let* ((token (list 0)) + (in-fd nil) + (in-stream nil) + (out-fd nil) + (out-stream nil) + (error-fd nil) + (error-stream nil) + (close-in-parent nil) + (close-on-error nil) + (proc + (make-external-process + :pid nil + :args args + :%status :running + :input nil + :output nil + :error nil + :token token + :status-hook status-hook + :external-format (setq external-format (normalize-external-format t external-format))))) + (unwind-protect + (progn + (multiple-value-setq (in-fd in-stream close-in-parent close-on-error) + (get-descriptor-for input proc nil nil :direction :input + :if-does-not-exist if-input-does-not-exist + :element-type element-type + :sharing sharing + :external-format external-format)) + (multiple-value-setq (out-fd out-stream close-in-parent close-on-error) + (get-descriptor-for output proc close-in-parent close-on-error + :direction :output + :if-exists if-output-exists + :element-type element-type + :sharing sharing + :external-format external-format)) + (multiple-value-setq (error-fd error-stream close-in-parent close-on-error) + (if (eq error :output) + (values out-fd out-stream close-in-parent close-on-error) + (get-descriptor-for error proc close-in-parent close-on-error + :direction :output + :if-exists if-error-exists + :sharing sharing + :element-type element-type + :external-format external-format))) + (setf (external-process-input proc) in-stream + (external-process-output proc) out-stream + (external-process-error proc) error-stream) + (call-with-string-vector + #'(lambda (argv) + (process-run-function + (list :name + (format nil "Monitor thread for external process ~a" args) + :stack-size (ash 128 10) + :vstack-size (ash 128 10) + :tstack-size (ash 128 10)) + #'run-external-process proc in-fd out-fd error-fd argv env) + (wait-on-semaphore (external-process-signal proc))) + args)) + (dolist (fd close-in-parent) (fd-close fd)) + (unless (external-process-pid proc) + (dolist (fd close-on-error) (fd-close fd))) + (when (and wait (external-process-pid proc)) + (with-interrupts-enabled + (wait-on-semaphore (external-process-completed proc))))) + (unless (external-process-pid proc) + ;; something is wrong + (if (eq (external-process-%status proc) :error) + ;; Fork failed + (unless silently-ignore-catastrophic-failures + (cerror "Pretend the program ran and failed" 'external-process-creation-failure :proc proc)) + ;; Currently can't happen. + (error "Bug: fork failed but status field not set?"))) + proc)) + + + + (defmacro wifsignaled (status) + (let* ((statname (gensym))) + `(let* ((,statname ,status)) + (and (not (wifstopped ,statname)) (not (wifexited ,statname)))))) + + + (defun check-pid (pid &optional (flags (logior #$WNOHANG #$WUNTRACED))) + (declare (fixnum pid)) + (rlet ((status :signed)) + (let* ((retval (ff-call-ignoring-eintr (#_waitpid pid status flags)))) + (declare (fixnum retval)) + (if (= retval pid) + (pref status :signed) + (zerop retval))))) + + + + + + (defun external-process-wait (proc &optional check-stopped) + (process-wait "external-process-wait" + #'(lambda () + (case (external-process-%status proc) + (:running) + (:stopped + (when check-stopped + t)) + (t + (when (zerop (car (external-process-token proc))) + t)))))) + + + + + + (defun external-process-error-stream (proc) + "Return the stream which is used to read error output from a given OS +subprocess, if it has one." + (require-type proc 'external-process) + (external-process-error proc)) + + + + (defun signal-external-process (proc signal) + "Send the specified signal to the specified external process. (Typically, +it would only be useful to call this function if the EXTERNAL-PROCESS was +created with :WAIT NIL.) Return T if successful; NIL if the process wasn't +created successfully, and signal an error otherwise." + (require-type proc 'external-process) + (let* ((pid (external-process-pid proc))) + (when pid + (let ((error (int-errno-call (#_kill pid signal)))) + (or (eql error 0) + (%errno-disp error)))))) + + ) ; #-windows-target (progn + +#+windows-target +(progn + (defun temp-file-name (prefix) + "Returns a unique name for a temporary file, residing in system temp +space, and prefixed with PREFIX." + (rlet ((buffer (:array :wchar_t #.#$MAX_PATH))) + (#_GetTempPathW #$MAX_PATH buffer) + (with-filename-cstrs ((c-prefix prefix)) + (#_GetTempFileNameW buffer c-prefix 0 buffer) + (%get-native-utf-16-cstring buffer)))) + + (defun get-descriptor-for (object proc close-in-parent close-on-error + &rest keys + &key + direction (element-type 'character) + (sharing :private) + external-format + &allow-other-keys) + (etypecase object + ((eql t) + (values nil nil close-in-parent close-on-error)) + (null + (let* ((null-device "nul") + (fd (fd-open null-device (case direction + (:input #$O_RDONLY) + (:output #$O_WRONLY) + (t #$O_RDWR))))) + (if (< fd 0) + (signal-file-error fd null-device)) + (values fd nil (cons fd close-in-parent) (cons fd close-on-error)))) + ((eql :stream) + (multiple-value-bind (read-pipe write-pipe) (pipe) + (case direction + (:input + (values read-pipe + (make-fd-stream (fd-uninheritable write-pipe :direction :output) + :direction :output + :element-type element-type + :interactive nil + :basic t + :sharing sharing + :encoding (external-format-character-encoding external-format) + :line-termination (external-format-line-termination external-format) + :auto-close t) + (cons read-pipe close-in-parent) + (cons write-pipe close-on-error))) + (:output + (values write-pipe + (make-fd-stream (fd-uninheritable read-pipe :direction :input) + :direction :input + :element-type element-type + :interactive nil + :basic t + :sharing sharing + :encoding (external-format-character-encoding external-format) + :line-termination (external-format-line-termination external-format) + :auto-close t) + (cons write-pipe close-in-parent) + (cons read-pipe close-on-error))) + (t + (fd-close read-pipe) + (fd-close write-pipe) + (report-bad-arg direction '(member :input :output)))))) + ((or pathname string) + (with-open-stream (file (apply #'open object keys)) + (let* ((fd (fd-dup (ioblock-device (stream-ioblock file t)) :direction direction :inheritable t))) + (values fd + nil + (cons fd close-in-parent) + (cons fd close-on-error))))) + (stream + (ecase direction + (:input + (let* ((tempname (temp-file-name "lisp-temp")) + (fd (fd-open tempname #$O_RDWR))) + (if (< fd 0) + (%errno-disp fd)) + (let* ((out (make-fd-stream (fd-dup fd) + :direction :output + :encoding (external-format-character-encoding external-format) + :line-termination (external-format-line-termination external-format)))) + (loop + (multiple-value-bind (line no-newline) + (read-line object nil nil) + (unless line + (return)) + (if no-newline + (write-string line out) + (write-line line out)) + )) + (close out)) + (fd-lseek fd 0 #$SEEK_SET) + (values fd nil (cons fd close-in-parent) (cons fd close-on-error)))) + (:output + (multiple-value-bind (read-pipe write-pipe) (pipe) + (push read-pipe (external-process-watched-fds proc)) + (push object (external-process-watched-streams proc)) + (incf (car (external-process-token proc))) + (values write-pipe + nil + (cons write-pipe close-in-parent) + (cons read-pipe close-on-error)))))))) + + (defstruct external-process + pid + %status + %exit-code + pty + input + output + error + status-hook + plist + token + core + args + (signal (make-semaphore)) + (completed (make-semaphore)) + watched-fds + watched-streams + external-format + ) + + + + (defmethod print-object ((p external-process) stream) + (print-unreadable-object (p stream :type t :identity t) + (let* ((status (external-process-%status p))) + (let* ((*print-length* 3)) + (format stream "~a" (external-process-args p))) + (format stream "[~d] (~a" (external-process-pid p) status) + (unless (eq status :running) + (format stream " : ~d" (external-process-%exit-code p))) + (format stream ")")))) + + (defun run-program (program args &key + (wait t) pty + input if-input-does-not-exist + output (if-output-exists :error) + (error :output) (if-error-exists :error) + status-hook (element-type 'character) + (sharing :private) + (external-format `(:character-encoding ,*terminal-character-encoding-name* :line-termination :crlf)) + env) + "Invoke an external program as an OS subprocess of lisp." + (declare (ignore pty)) + (unless (every #'(lambda (a) (typep a 'simple-string)) args) + (error "Program args must all be simple strings : ~s" args)) + (push program args) + (let* ((token (list 0)) + (in-fd nil) + (in-stream nil) + (out-fd nil) + (out-stream nil) + (error-fd nil) + (error-stream nil) + (close-in-parent nil) + (close-on-error nil) + (proc + (make-external-process + :pid nil + :args args + :%status :running + :input nil + :output nil + :error nil + :token token + :external-format (setq external-format (normalize-external-format t external-format)) + :status-hook status-hook))) + (unwind-protect + (progn + (multiple-value-setq (in-fd in-stream close-in-parent close-on-error) + (get-descriptor-for input proc nil nil :direction :input + :if-does-not-exist if-input-does-not-exist + :sharing sharing + :element-type element-type + :external-format external-format)) + (multiple-value-setq (out-fd out-stream close-in-parent close-on-error) + (get-descriptor-for output proc close-in-parent close-on-error + :direction :output + :if-exists if-output-exists + :sharing sharing + :element-type element-type + :external-format external-format)) + (multiple-value-setq (error-fd error-stream close-in-parent close-on-error) + (if (eq error :output) + (values out-fd out-stream close-in-parent close-on-error) + (get-descriptor-for error proc close-in-parent close-on-error + :direction :output + :if-exists if-error-exists + :sharing sharing + :element-type element-type + :external-format external-format))) + (setf (external-process-input proc) in-stream + (external-process-output proc) out-stream + (external-process-error proc) error-stream) + (process-run-function + (format nil "Monitor thread for external process ~a" args) + + #'run-external-process proc in-fd out-fd error-fd env) + (wait-on-semaphore (external-process-signal proc)) + ) + (dolist (fd close-in-parent) (fd-close fd)) + (if (external-process-pid proc) + (when (and wait (external-process-pid proc)) + (with-interrupts-enabled + (wait-on-semaphore (external-process-completed proc)))) + (progn + (dolist (fd close-on-error) (fd-close fd))))) + proc)) + + (let* ((external-processes ()) + (external-processes-lock (make-lock))) + (defun add-external-process (p) + (with-lock-grabbed (external-processes-lock) + (push p external-processes))) + (defun remove-external-process (p) + (with-lock-grabbed (external-processes-lock) + (setq external-processes (delete p external-processes)))) + ;; Likewise + (defun external-processes () + (with-lock-grabbed (external-processes-lock) + (copy-list external-processes))) + ) + + + + + (defun run-external-process (proc in-fd out-fd error-fd &optional env) + (let* ((args (external-process-args proc)) + (child-pid (exec-with-io-redirection in-fd out-fd error-fd args proc env))) + (when child-pid + (setf (external-process-pid proc) child-pid) + (add-external-process proc) + (signal-semaphore (external-process-signal proc)) + (monitor-external-process proc)))) + + (defun join-strings (strings) + (reduce (lambda (left right) (concatenate 'string left " " right)) strings)) + + (defun create-windows-process (new-in new-out new-err cmdstring env) + (declare (ignore env)) ; until we can do better. + (with-filename-cstrs ((command cmdstring)) + (rletz ((proc-info #>PROCESS_INFORMATION) + (si #>STARTUPINFO)) + (setf (pref si #>STARTUPINFO.cb) (record-length #>STARTUPINFO)) + (setf (pref si #>STARTUPINFO.dwFlags) + (logior #$STARTF_USESTDHANDLES #$STARTF_USESHOWWINDOW)) + (setf (pref si #>STARTUPINFO.wShowWindow) #$SW_HIDE) + (setf (pref si #>STARTUPINFO.hStdInput) + (if new-in + (%int-to-ptr new-in) + (#_GetStdHandle #$STD_INPUT_HANDLE))) + (setf (pref si #>STARTUPINFO.hStdOutput) + (if new-out + (%int-to-ptr new-out) + (#_GetStdHandle #$STD_OUTPUT_HANDLE))) + (setf (pref si #>STARTUPINFO.hStdError) + (if new-err + (%int-to-ptr new-err) + (#_GetStdHandle #$STD_ERROR_HANDLE))) + (if (zerop (#_CreateProcessW (%null-ptr) + command + (%null-ptr) + (%null-ptr) + 1 + #$CREATE_NEW_CONSOLE + (%null-ptr) + (%null-ptr) + si + proc-info)) + (values nil (#_GetLastError)) + (progn + (#_CloseHandle (pref proc-info #>PROCESS_INFORMATION.hThread)) + (values t (pref proc-info #>PROCESS_INFORMATION.hProcess))))))) + + (defun exec-with-io-redirection (new-in new-out new-err args proc &optional env) + (multiple-value-bind (win handle-to-process-or-error) + (create-windows-process new-in new-out new-err (join-strings args) env) + (if win + handle-to-process-or-error + (progn + (setf (external-process-%status proc) :error + (external-process-%exit-code proc) handle-to-process-or-error) + (signal-semaphore (external-process-signal proc)) + (signal-semaphore (external-process-completed proc)) + nil)))) + + (defun fd-uninheritable (fd &key direction) + (let ((new-fd (fd-dup fd :direction direction))) + (fd-close fd) + new-fd)) + + + (defun data-available-on-pipe-p (hpipe) + (rlet ((navail #>DWORD 0)) + (unless (eql 0 (#_PeekNamedPipe (if (typep hpipe 'macptr) + hpipe + (%int-to-ptr hpipe)) + (%null-ptr) + 0 + (%null-ptr) + navail + (%null-ptr))) + (not (eql 0 (pref navail #>DWORD)))))) + + + ;;; There doesn't seem to be any way to wait on input from an + ;;; anonymous pipe in Windows (that would, after all, make too + ;;; much sense.) We -can- check for pending unread data on + ;;; pipes, and can expect to eventually get EOF on a pipe. + ;;; So, this tries to loop until the process handle is signaled and + ;;; all data has been read. + (defun monitor-external-process (p) + (let* ((in-fds (external-process-watched-fds p)) + (out-streams (external-process-watched-streams p)) + (token (external-process-token p)) + (terminated) + (changed) + (external-format (external-process-external-format p)) + (encoding (external-format-character-encoding external-format)) + (line-termination (external-format-line-termination external-format)) + (pairs (pairlis (mapcar (lambda (fd) + (cons fd + (make-fd-stream fd + :direction :input + :sharing :private + :encoding encoding + :line-termination line-termination))) + in-fds) + out-streams)) + ) + (loop + (when changed + (setq pairs (delete nil pairs :key #'car) + changed nil)) + (when (and terminated (null pairs)) + (without-interrupts + (rlet ((code #>DWORD)) + (loop + (#_GetExitCodeProcess (external-process-pid p) code) + (unless (eql (pref code #>DWORD) #$STILL_ACTIVE) + (return)) + (#_SleepEx 10 #$TRUE)) + (setf (external-process-%exit-code p) (pref code #>DWORD))) + (#_CloseHandle (external-process-pid p)) + (setf (external-process-pid p) nil) + (setf (external-process-%status p) :exited) + (let ((status-hook (external-process-status-hook p))) + (when status-hook + (funcall status-hook p))) + (remove-external-process p) + (signal-semaphore (external-process-completed p)) + (return))) + (dolist (p pairs) + (let* ((in-fd (caar p)) + (in-stream (cdar p)) + (out-stream (cdr p))) + (when (or terminated (data-available-on-pipe-p in-fd)) + (let* ((buf (make-string 1024))) + (declare (dynamic-extent buf)) + (let* ((n (ignore-errors (read-sequence buf in-stream)))) + (if (or (null n) (eql n 0)) + (progn + (without-interrupts + (decf (car token)) + (fd-close in-fd) + (setf (car p) nil changed t))) + (progn + (write-sequence buf out-stream :end n) + (force-output out-stream)))))))) + (unless terminated + (setq terminated (eql (#_WaitForSingleObjectEx + (external-process-pid p) + 1000 + #$true) + #$WAIT_OBJECT_0)))))) + + + (defun signal-external-process (proc signal) + "Does nothing on Windows" + (declare (ignore signal)) + (require-type proc 'external-process) + nil) + + + ) + ;#+windows-target (progn + + +(defun external-process-input-stream (proc) + "Return the lisp stream which is used to write input to a given OS +subprocess, if it has one." + (require-type proc 'external-process) + (external-process-input proc)) + +(defun external-process-output-stream (proc) + "Return the lisp stream which is used to read output from a given OS +subprocess, if there is one." + (require-type proc 'external-process) + (external-process-output proc)) + + +(defun external-process-id (proc) + "Return the process id of an OS subprocess, a positive integer which +identifies it." + (require-type proc 'external-process) + (external-process-pid proc)) + +(defun external-process-status (proc) + "Return information about whether an OS subprocess is running; or, if +not, why not; and what its result code was if it completed." + (require-type proc 'external-process) + (values (external-process-%status proc) + (external-process-%exit-code proc))) + +;;; EOF on a TTY is transient, but I'm less sure of other cases. +(defun eof-transient-p (fd) + (case (%unix-fd-kind fd) + (:tty t) + #+windows-target (:character-special t) + (t nil))) + + +(defstruct (shared-resource (:constructor make-shared-resource (name))) + (name) + (lock (make-lock)) + (primary-owner *current-process*) + (primary-owner-notify (make-semaphore)) + (current-owner nil) + (requestors (make-dll-header))) + +(defstruct (shared-resource-request + (:constructor make-shared-resource-request (process)) + (:include dll-node)) + process + (signal (make-semaphore))) + + +;; Returns NIL if already owned by calling thread, T otherwise +(defun %acquire-shared-resource (resource &optional verbose) + (let* ((current *current-process*)) + (with-lock-grabbed ((shared-resource-lock resource)) + (let* ((secondary (shared-resource-current-owner resource))) + (if (or (eq current secondary) + (and (null secondary) + (eq current (shared-resource-primary-owner resource)))) + (return-from %acquire-shared-resource nil)))) + (let* ((request (make-shared-resource-request *current-process*))) + (when verbose + (format t "~%~%;;;~%;;; ~a requires access to ~a~%;;; Type (:y ~D) to yield control to this thread.~%;;;~%" + *current-process* (shared-resource-name resource) + (process-serial-number *current-process*))) + (with-lock-grabbed ((shared-resource-lock resource)) + (append-dll-node request (shared-resource-requestors resource))) + (wait-on-semaphore (shared-resource-request-signal request)) + (assert (eq current (shared-resource-current-owner resource))) + (when verbose + (format t "~%~%;;;~%;;; ~a is now owned by ~a~%;;;~%~%" + (shared-resource-name resource) current)) + t))) + +;;; If we're the primary owner and there is no secondary owner, do nothing. +;;; If we're the secondary owner, cease being the secondary owner. +(defun %release-shared-resource (r) + (let* ((not-any-owner ())) + (with-lock-grabbed ((shared-resource-lock r)) + (let* ((current *current-process*) + (primary (shared-resource-primary-owner r)) + (secondary (shared-resource-current-owner r))) + (unless (setq not-any-owner + (not (or (eq current secondary) + (and (null secondary) + (eq current primary))))) + (when (eq current secondary) + (setf (shared-resource-current-owner r) nil) + (signal-semaphore (shared-resource-primary-owner-notify r)))))) + (when not-any-owner + (signal-program-error "Process ~a does not own ~a" *current-process* + (shared-resource-name r))))) + +;;; The current thread should be the primary owner; there should be +;;; no secondary owner. Wakeup the specified (or first) requesting +;;; process, then block on our semaphore +(defun %yield-shared-resource (r &optional to) + (let* ((request nil)) + (with-lock-grabbed ((shared-resource-lock r)) + (let* ((current *current-process*) + (primary (shared-resource-primary-owner r))) + (when (and (eq current primary) + (null (shared-resource-current-owner r))) + (setq request + (let* ((header (shared-resource-requestors r))) + (if to + (do-dll-nodes (node header) + (when (eq to (shared-resource-request-process node)) + (return node))) + (let* ((first (dll-header-first header))) + (unless (eq first header) + first))))) + (when request + (remove-dll-node request) + (setf (shared-resource-current-owner r) + (shared-resource-request-process request)) + (signal-semaphore (shared-resource-request-signal request)))))) + (when request + (wait-on-semaphore (shared-resource-primary-owner-notify r)) + (format t "~%;;;~%;;;control of ~a restored to ~a~%;;;~&" + (shared-resource-name r) + *current-process*)))) + + + + +(defun %shared-resource-requestor-p (r proc) + (with-lock-grabbed ((shared-resource-lock r)) + (do-dll-nodes (node (shared-resource-requestors r)) + (when (eq proc (shared-resource-request-process node)) + (return t))))) + +(defparameter *resident-editor-hook* nil + "If non-NIL, should be a function that takes an optional argument + (like ED) and invokes a \"resident\" editor.") + +(defun ed (&optional arg) + (if *resident-editor-hook* + (funcall *resident-editor-hook* arg) + (error "This implementation doesn't provide a resident editor."))) + +(defun running-under-emacs-p () + (not (null (getenv "EMACS")))) + +(defloadvar *cpu-count* nil) + +(defun cpu-count () + (or *cpu-count* + (setq *cpu-count* + #+darwin-target + (rlet ((info :host_basic_info) + (count :mach_msg_type_number_t #$HOST_BASIC_INFO_COUNT)) + (if (eql #$KERN_SUCCESS (#_host_info (#_mach_host_self) + #$HOST_BASIC_INFO + info + count)) + (pref info :host_basic_info.max_cpus) + 1)) + #+(or linux-target solaris-target) + (or + (let* ((n (#_sysconf #$_SC_NPROCESSORS_ONLN))) + (declare (fixnum n)) + (if (> n 0) n)) + #+linux-target + (ignore-errors + (with-open-file (p "/proc/cpuinfo") + (let* ((ncpu 0) + (match "processor") + (matchlen (length match))) + (do* ((line (read-line p nil nil) (read-line p nil nil))) + ((null line) ncpu) + (let* ((line-length (length line))) + (when (and + (> line-length matchlen) + (string= match line + :end2 matchlen) + (whitespacep (schar line matchlen))) + (incf ncpu))))))) + 1) + #+freebsd-target + (rlet ((ret :uint)) + (%stack-block ((mib (* (record-length :uint) 2))) + (setf (paref mib (:array :uint) 0) + #$CTL_HW + (paref mib (:array :uint) 1) + #$HW_NCPU) + (rlet ((oldsize :uint (record-length :uint))) + (if (eql 0 (#_sysctl mib 2 ret oldsize (%null-ptr) 0)) + (pref ret :uint) + 1)))) + #+windows-target + (rlet ((procmask #>DWORD_PTR) + (sysmask #>DWORD_PTR)) + (if (eql 0 (#_GetProcessAffinityMask (#_GetCurrentProcess) procmask sysmask)) + 1 + (logcount (pref sysmask #>DWORD_PTR))))))) + +(def-load-pointers spin-count () + (if (eql 1 (cpu-count)) + (%defglobal '*spin-lock-tries* 1) + (%defglobal '*spin-lock-tries* 1024)) + (%defglobal '*spin-lock-timeouts* 0)) + +(defun yield () + (process-allow-schedule)) + +(defloadvar *host-page-size* + #-windows-target (#_getpagesize) + #+windows-target + (rlet ((info #>SYSTEM_INFO)) + (#_GetSystemInfo info) + (pref info #>SYSTEM_INFO.dwPageSize)) + ) + +;;(assert (= (logcount *host-page-size*) 1)) + +(defun get-universal-time () + "Return a single integer for the current time of + day in universal time format." + (rlet ((tv :timeval)) + (gettimeofday tv) + (+ (pref tv :timeval.tv_sec) unix-to-universal-time))) + +#+windows-target +(defloadvar *windows-allocation-granularity* + (rlet ((info #>SYSTEM_INFO)) + (#_GetSystemInfo info) + (pref info #>SYSTEM_INFO.dwAllocationGranularity))) + +#-windows-target +(defun %memory-map-fd (fd len bits-per-element) + (let* ((nbytes (+ *host-page-size* + (logandc2 (+ len + (1- *host-page-size*)) + (1- *host-page-size*)))) + (ndata-elements + (ash len + (ecase bits-per-element + (1 3) + (8 0) + (16 -1) + (32 -2) + (64 -3)))) + (nalignment-elements + (ash target::nbits-in-word + (ecase bits-per-element + (1 0) + (8 -3) + (16 -4) + (32 -5) + (64 -6))))) + (if (>= (+ ndata-elements nalignment-elements) + array-total-size-limit) + (progn + (fd-close fd) + (error "Can't make a vector with ~s elements in this implementation." (+ ndata-elements nalignment-elements))) + (let* ((addr (#_mmap (%null-ptr) + nbytes + #$PROT_NONE + (logior #$MAP_ANON #$MAP_PRIVATE) + -1 + 0))) + (if (eql addr (%int-to-ptr (1- (ash 1 target::nbits-in-word)))) ; #$MAP_FAILED + (let* ((errno (%get-errno))) + (fd-close fd) + (error "Can't map ~d bytes: ~a" nbytes (%strerror errno))) + ;;; Remap the first page so that we can put a vector header + ;;; there; use the first word on the first page to remember + ;;; the file descriptor. + (progn + (#_mmap addr + *host-page-size* + (logior #$PROT_READ #$PROT_WRITE) + (logior #$MAP_ANON #$MAP_PRIVATE #$MAP_FIXED) + -1 + 0) + (setf (pref addr :int) fd) + (let* ((header-addr (%inc-ptr addr (- *host-page-size* + (* 2 target::node-size))))) + + (when (> len 0) + (let* ((target-addr (%inc-ptr header-addr (* 2 target::node-size)))) + (unless (eql target-addr + (#_mmap target-addr + len + #$PROT_READ + (logior #$MAP_PRIVATE #$MAP_FIXED) + fd + 0)) + (let* ((errno (%get-errno))) + (fd-close fd) + (#_munmap addr nbytes) + (error "Mapping failed: ~a" (%strerror errno)))))) + (values header-addr ndata-elements nalignment-elements)))))))) + +#+windows-target +(defun %memory-map-fd (fd len bits-per-element) + (let* ((nbytes (+ *windows-allocation-granularity* + (logandc2 (+ len + (1- *windows-allocation-granularity*)) + (1- *windows-allocation-granularity*)))) + (ndata-elements + (ash len + (ecase bits-per-element + (1 3) + (8 0) + (16 -1) + (32 -2) + (64 -3)))) + (nalignment-elements + (ash target::nbits-in-word + (ecase bits-per-element + (1 0) + (8 -3) + (16 -4) + (32 -5) + (64 -6))))) + (if (>= (+ ndata-elements nalignment-elements) + array-total-size-limit) + (progn + (fd-close fd) + (error "Can't make a vector with ~s elements in this implementation." (+ ndata-elements nalignment-elements))) + (let* ((mapping (#_CreateFileMappingA (%int-to-ptr fd) (%null-ptr) #$PAGE_READONLY 0 0 (%null-ptr)))) + (if (%null-ptr-p mapping) + (let* ((err (#_GetLastError))) + (fd-close fd) + (error "Couldn't create a file mapping - ~a." (%windows-error-string err))) + (loop + (let* ((base (#_VirtualAlloc (%null-ptr) nbytes #$MEM_RESERVE #$PAGE_NOACCESS))) + (if (%null-ptr-p base) + (let* ((err (#_GetLastError))) + (#_CloseHandle mapping) + (fd-close fd) + (error "Couldn't reserve ~d bytes of address space for mapped file - ~a" + nbytes (%windows-error-string err))) + ;; Now we have to free the memory and hope that we can reallocate it ... + (progn + (#_VirtualFree base 0 #$MEM_RELEASE) + (unless (%null-ptr-p (#_VirtualAlloc base *windows-allocation-granularity* #$MEM_RESERVE #$PAGE_NOACCESS)) + (let* ((fptr (%inc-ptr base *windows-allocation-granularity*))) + (if (%null-ptr-p (#_MapViewOfFileEx mapping #$FILE_MAP_READ 0 0 0 fptr)) + (#_VirtualFree base 0 #$MEM_RELEASE) + (let* ((prefix-page (%inc-ptr base (- *windows-allocation-granularity* + *host-page-size*)))) + (#_VirtualAlloc prefix-page *host-page-size* #$MEM_COMMIT #$PAGE_READWRITE) + (setf (paref prefix-page (:* :address) 0) mapping + (paref prefix-page (:* :address) 1) (%int-to-ptr fd)) + (return (values + (%inc-ptr prefix-page (- *host-page-size* + (* 2 target::node-size))) + ndata-elements + nalignment-elements))))))))))))))) + + + +(defun map-file-to-ivector (pathname element-type) + (let* ((upgraded-type (upgraded-array-element-type element-type)) + (upgraded-ctype (specifier-type upgraded-type))) + (unless (and (typep upgraded-ctype 'numeric-ctype) + (eq 'integer (numeric-ctype-class upgraded-ctype))) + (error "Invalid element-type: ~s" element-type)) + (let* ((bits-per-element (integer-length (- (numeric-ctype-high upgraded-ctype) + (numeric-ctype-low upgraded-ctype)))) + (fd (fd-open (native-translated-namestring pathname) #$O_RDONLY))) + (if (< fd 0) + (signal-file-error fd pathname) + (let* ((len (fd-size fd))) + (if (< len 0) + (signal-file-error fd pathname) + (multiple-value-bind (header-address ndata-elements nalignment-elements) + (%memory-map-fd fd len bits-per-element) + (setf (%get-natural header-address 0) + (logior (element-type-subtype upgraded-type) + (ash (+ ndata-elements nalignment-elements) target::num-subtag-bits))) + (with-macptrs ((v (%inc-ptr header-address target::fulltag-misc))) + (let* ((vector (rlet ((p :address v)) (%get-object p 0)))) + ;; Tell some parts of Clozure CL - notably the + ;; printer - that this thing off in foreign + ;; memory is a real lisp object and not + ;; "bogus". + (with-lock-grabbed (*heap-ivector-lock*) + (push vector *heap-ivectors*)) + (make-array ndata-elements + :element-type upgraded-type + :displaced-to vector + :adjustable t + :displaced-index-offset nalignment-elements)))))))))) + +(defun map-file-to-octet-vector (pathname) + (map-file-to-ivector pathname '(unsigned-byte 8))) + +(defun mapped-vector-data-address-and-size (displaced-vector) + (let* ((v (array-displacement displaced-vector)) + (element-type (array-element-type displaced-vector))) + (if (or (eq v displaced-vector) + (not (with-lock-grabbed (*heap-ivector-lock*) + (member v *heap-ivectors*)))) + (error "~s doesn't seem to have been allocated via ~s and not yet unmapped" displaced-vector 'map-file-to-ivector)) + (let* ((pv (rlet ((x :address)) (%set-object x 0 v) (pref x :address))) + (ctype (specifier-type element-type)) + (arch (backend-target-arch *target-backend*))) + (values (%inc-ptr pv (- (* 2 target::node-size) target::fulltag-misc)) + (- (funcall (arch::target-array-data-size-function arch) + (ctype-subtype ctype) + (length v)) + target::node-size))))) + + +#-windows-target +(defun %unmap-file (data-address size-in-octets) + (let* ((base-address (%inc-ptr data-address (- *host-page-size*))) + (fd (pref base-address :int))) + (#_munmap base-address (+ *host-page-size* size-in-octets)) + (fd-close fd))) + +#+windows-target +(defun %unmap-file (data-address size-in-octets) + (declare (ignore size-in-octets)) + (let* ((prefix-page (%inc-ptr data-address (- *host-page-size*))) + (prefix-allocation (%inc-ptr data-address (- *windows-allocation-granularity*))) + (mapping (paref prefix-page (:* :address) 0)) + (fd (%ptr-to-int (paref prefix-page (:* :address) 1)))) + (#_UnmapViewOfFile data-address) + (#_CloseHandle mapping) + (#_VirtualFree prefix-allocation 0 #$MEM_RELEASE) + (fd-close fd))) + + + +;;; Argument should be something returned by MAP-FILE-TO-IVECTOR; +;;; this should be called at most once for any such object. +(defun unmap-ivector (displaced-vector) + (multiple-value-bind (data-address size-in-octets) + (mapped-vector-data-address-and-size displaced-vector) + (let* ((v (array-displacement displaced-vector))) + (let* ((element-type (array-element-type displaced-vector))) + (adjust-array displaced-vector 0 + :element-type element-type + :displaced-to (make-array 0 :element-type element-type) + :displaced-index-offset 0)) + (with-lock-grabbed (*heap-ivector-lock*) + (setq *heap-ivectors* (delete v *heap-ivectors*))) + (%unmap-file data-address size-in-octets) + t))) + +(defun unmap-octet-vector (v) + (unmap-ivector v)) + +#-windows-target +(progn +(defun lock-mapped-vector (v) + (multiple-value-bind (address nbytes) + (mapped-vector-data-address-and-size v) + (eql 0 (#_mlock address nbytes)))) + +(defun unlock-mapped-vector (v) + (multiple-value-bind (address nbytes) + (mapped-vector-data-address-and-size v) + (eql 0 (#_munlock address nbytes)))) + +(defun bitmap-for-mapped-range (address nbytes) + (let* ((npages (ceiling nbytes *host-page-size*))) + (%stack-block ((vec npages)) + (when (eql 0 (#_mincore address nbytes vec)) + (let* ((bits (make-array npages :element-type 'bit))) + (dotimes (i npages bits) + (setf (sbit bits i) + (logand 1 (%get-unsigned-byte vec i))))))))) + +(defun percentage-of-resident-pages (address nbytes) + (let* ((npages (ceiling nbytes *host-page-size*))) + (%stack-block ((vec npages)) + (when (eql 0 (#_mincore address nbytes vec)) + (let* ((nresident 0)) + (dotimes (i npages (* 100.0 (/ nresident npages))) + (when (logbitp 0 (%get-unsigned-byte vec i)) + (incf nresident)))))))) + +(defun mapped-vector-resident-pages (v) + (multiple-value-bind (address nbytes) + (mapped-vector-data-address-and-size v) + (bitmap-for-mapped-range address nbytes))) + +(defun mapped-vector-resident-pages-percentage (v) + (multiple-value-bind (address nbytes) + (mapped-vector-data-address-and-size v) + (percentage-of-resident-pages address nbytes))) +) + + +#+windows-target +(defun cygpath (winpath) + "Try to use the Cygwin \"cygpath\" program to map a Windows-style + pathname to a POSIX-stype Cygwin pathname." + (let* ((posix-path winpath)) + (with-output-to-string (s) + (multiple-value-bind (status exit-code) + (external-process-status + (run-program "cygpath" (list "-u" winpath) :output s)) + (when (and (eq status :exited) + (eql exit-code 0)) + (with-input-from-string (output (get-output-stream-string s)) + (setq posix-path (read-line output nil nil)))))) + posix-path)) + +#-windows-target (defun cygpath (path) path) + + + + +#+x86-target +(progn +(defloadvar *last-rdtsc-time* 0) + +(defstatic *rdtsc-estimated-increment* 1 "Should be positive ...") + +(defun rdtsc-monotonic () + "Return monotonically increasing values, partly compensating for + OSes that don't keep the TSCs of all processorsin synch." + (loop + (let* ((old *last-rdtsc-time*) + (new (rdtsc))) + (when (< new old) + ;; We're running on a CPU whose TSC is behind the one + ;; on the last CPU we were scheduled on. + (setq new (+ old *rdtsc-estimated-increment*))) + (when (%store-node-conditional target::symbol.vcell *last-rdtsc-time* old new) + (return new))))) + +(defun estimate-rdtsc-skew (&optional (niter 1000000)) + (do* ((i 0 (1+ i)) + (last (rdtsc) next) + (next (rdtsc) (rdtsc)) + (skew 1)) + ((>= i niter) (setq *rdtsc-estimated-increment* skew)) + (declare (fixnum last next skew)) + (when (> last next) + (let* ((s (- last next))) + (declare (fixnum s)) + (when (> s skew) (setq skew s)))))) +) + + Index: /branches/new-random/level-1/ppc-callback-support.lisp =================================================================== --- /branches/new-random/level-1/ppc-callback-support.lisp (revision 13309) +++ /branches/new-random/level-1/ppc-callback-support.lisp (revision 13309) @@ -0,0 +1,64 @@ +;;;-*- Mode: Lisp; Package: CCL -*- +;;; +;;; Copyright (C) 2009 Clozure Associates +;;; Copyright (C) 1994-2001 Digitool, Inc +;;; This file is part of Clozure CL. +;;; +;;; Clozure CL is licensed under the terms of the Lisp Lesser GNU Public +;;; License , known as the LLGPL and distributed with Clozure CL as the +;;; file "LICENSE". The LLGPL consists of a preamble and the LGPL, +;;; which is distributed with Clozure CL as the file "LGPL". Where these +;;; conflict, the preamble takes precedence. +;;; +;;; Clozure CL is referenced in the preamble as the "LIBRARY." +;;; +;;; The LLGPL is also available online at +;;; http://opensource.franz.com/preamble.html + +;;; ppc-callback-support.lisp +;;; +;;; Support for PPC callbacks + +(in-package "CCL") + + + +;;; This is machine-dependent (it conses up a piece of "trampoline" code +;;; which calls a subprim in the lisp kernel.) +#-(and linuxppc-target poweropen-target) +(defun make-callback-trampoline (index &optional info) + (declare (ignorable info)) + (macrolet ((ppc-lap-word (instruction-form) + (uvref (uvref (compile nil `(lambda (&lap 0) (ppc-lap-function () ((?? 0)) ,instruction-form))) 0) #+ppc32-host 0 #+ppc64-host 1))) + (let* ((subprim + #+eabi-target + #.(subprim-name->offset '.SPeabi-callback) + #-eabi-target + #.(subprim-name->offset '.SPpoweropen-callback)) + (p (%allocate-callback-pointer 12))) + (setf (%get-long p 0) (logior (ldb (byte 8 16) index) + (ppc-lap-word (lis 11 ??))) ; unboxed index + (%get-long p 4) (logior (ldb (byte 16 0) index) + (ppc-lap-word (ori 11 11 ??))) + + (%get-long p 8) (logior subprim + (ppc-lap-word (ba ??)))) + (ff-call (%kernel-import #.target::kernel-import-makedataexecutable) + :address p + :unsigned-fullword 12 + :void) + p))) + +;;; In the 64-bit LinuxPPC ABI, functions are "transfer vectors": +;;; two-word vectors that contain the entry point in the first word +;;; and a pointer to the global variables ("table of contents", or +;;; TOC) the function references in the second word. We can use the +;;; TOC word in the transfer vector to store the callback index. +#+(and linuxppc-target poweropen-target) +(defun make-callback-trampoline (index &optional info) + (declare (ignorable info)) + (let* ((p (%allocate-callback-pointer 16))) + (setf (%%get-unsigned-longlong p 0) #.(subprim-name->offset '.SPpoweropen-callback) + (%%get-unsigned-longlong p 8) index) + p)) + Index: /branches/new-random/level-1/ppc-error-signal.lisp =================================================================== --- /branches/new-random/level-1/ppc-error-signal.lisp (revision 13309) +++ /branches/new-random/level-1/ppc-error-signal.lisp (revision 13309) @@ -0,0 +1,157 @@ +;;; PPC-specific code to handle trap and uuo callbacks. +;;; +;;; Copyright (C) 2009 Clozure Associates +;;; Copyright (C) 1994-2001 Digitool, Inc +;;; This file is part of Clozure CL. +;;; +;;; Clozure CL is licensed under the terms of the Lisp Lesser GNU Public +;;; License , known as the LLGPL and distributed with Clozure CL as the +;;; file "LICENSE". The LLGPL consists of a preamble and the LGPL, +;;; which is distributed with Clozure CL as the file "LGPL". Where these +;;; conflict, the preamble takes precedence. +;;; +;;; Clozure CL is referenced in the preamble as the "LIBRARY." +;;; +;;; The LLGPL is also available online at +;;; http://opensource.franz.com/preamble.html + +(in-package "CCL") + + + +;;; callback here from C exception handler + +(defcallback + %xerr-disp + (:address xp :unsigned-fullword fn-reg :unsigned-fullword pc-or-index :signed-fullword errnum :unsigned-fullword rb :signed-fullword continuable) + (block %err-disp + (let ((fn (unless (eql fn-reg 0) (xp-gpr-lisp xp fn-reg))) + (err-fn (if (eql continuable 0) '%err-disp-internal '%kernel-restart-internal))) + (if (eql errnum arch::error-stack-overflow) + (handle-stack-overflow xp fn rb) + (with-xp-stack-frames (xp fn frame-ptr) ; execute body with dummy stack frame(s) + (with-error-reentry-detection + (let* ((rb-value (xp-gpr-lisp xp rb)) + (res + (cond ((< errnum 0) + (%err-disp-internal errnum nil frame-ptr)) + ((logtest errnum arch::error-type-error) + (funcall err-fn + #.(car (rassoc 'type-error *kernel-simple-error-classes*)) + (list rb-value (logandc2 errnum arch::error-type-error)) + frame-ptr)) + ((eql errnum arch::error-udf) + (funcall err-fn $xfunbnd (list rb-value) frame-ptr)) + ((eql errnum arch::error-throw-tag-missing) + (%error (make-condition 'cant-throw-error + :tag rb-value) + nil frame-ptr)) + ((eql errnum arch::error-cant-call) + (%error (make-condition 'type-error + :datum rb-value + :expected-type '(or symbol function) + :format-control + "~S is not of type ~S, and can't be FUNCALLed or APPLYed") + nil frame-ptr)) + ((eql errnum arch::error-udf-call) + (return-from %err-disp + (handle-udf-call xp frame-ptr))) + ((eql errnum arch::error-alloc-failed) + (%error (make-condition + 'simple-storage-condition + :format-control (%rsc-string $xmemfull)) + nil frame-ptr)) + ((eql errnum arch::error-memory-full) + (%error (make-condition + 'simple-storage-condition + :format-control (%rsc-string $xnomem)) + nil frame-ptr)) + ((or (eql errnum arch::error-fpu-exception-double) + (eql errnum arch::error-fpu-exception-single)) + (let* ((code-vector (and fn (uvref fn 0))) + (instr (if code-vector + (uvref code-vector pc-or-index) + (%get-long (%int-to-ptr pc-or-index))))) + (let* ((minor (ldb (byte 5 1) instr)) + (fra (ldb (byte 5 16) instr)) + (frb (ldb (byte 5 11) instr)) + (frc (ldb (byte 5 6) instr))) + (declare (fixnum minor fra frb frc)) + (if (= minor 12) ; FRSP + (%err-disp-internal $xcoerce (list (xp-double-float xp frc) 'short-float) frame-ptr) + (flet ((coerce-to-op-type (double-arg) + (if (eql errnum arch::error-fpu-exception-double) + double-arg + (handler-case (coerce double-arg 'short-float) + (error (c) (declare (ignore c)) double-arg))))) + (multiple-value-bind (status control) (xp-fpscr-info xp) + (%error (make-condition (fp-condition-from-fpscr status control) + :operation (fp-minor-opcode-operation minor) + :operands + (if (= minor 22) + (list (coerce-to-op-type (xp-double-float xp frb))) + (list (coerce-to-op-type + (xp-double-float xp fra)) + (if (= minor 25) + (coerce-to-op-type + (xp-double-float xp frc)) + (coerce-to-op-type + (xp-double-float xp frb)))))) + nil + frame-ptr))))))) + ((eql errnum arch::error-excised-function-call) + (%error "~s: code has been excised." (list (xp-gpr-lisp xp ppc::nfn)) frame-ptr)) + ((eql errnum arch::error-too-many-values) + (%err-disp-internal $xtoomanyvalues (list rb-value) frame-ptr)) + (t (%error "Unknown error #~d with arg: ~d" (list errnum rb-value) frame-ptr))))) + (setf (xp-gpr-lisp xp rb) res) ; munge register for continuation + ))))))) + + + +(defun handle-udf-call (xp frame-ptr) + (let* ((args (xp-argument-list xp)) + (values (multiple-value-list + (%kernel-restart-internal + $xudfcall + (list (maybe-setf-name (xp-gpr-lisp xp ppc::fname)) args) + frame-ptr))) + (stack-argcnt (max 0 (- (length args) 3))) + (vsp (%i+ (xp-gpr-lisp xp ppc::vsp) stack-argcnt)) + (f #'(lambda (values) (apply #'values values)))) + (setf (xp-gpr-lisp xp ppc::vsp) vsp + (xp-gpr-lisp xp ppc::nargs) 1 + (xp-gpr-lisp xp ppc::arg_z) values + (xp-gpr-lisp xp ppc::nfn) f) + ;; handle_uuo() (in the lisp kernel) will not bump the PC here. + (setf (xp-gpr-lisp xp #+linuxppc-target #$PT_NIP #+darwinppc-target -2) + (uvref f 0)))) + + + + + + +;;; rb is the register number of the stack that overflowed. +;;; xp & fn are passed so that we can establish error context. +(defun handle-stack-overflow (xp fn rb) + (unwind-protect + (with-xp-stack-frames (xp fn frame-ptr) ; execute body with dummy stack frame(s) + (%error + (make-condition + 'stack-overflow-condition + :format-control "Stack overflow on ~a stack." + :format-arguments (list + (if (eql rb ppc::sp) + "control" + (if (eql rb ppc::vsp) + "value" + (if (eql rb ppc::tsp) + "temp" + "unknown"))))) + nil frame-ptr)) + (ff-call (%kernel-import target::kernel-import-restore-soft-stack-limit) + :unsigned-fullword rb + :void))) + + Index: /branches/new-random/level-1/ppc-threads-utils.lisp =================================================================== --- /branches/new-random/level-1/ppc-threads-utils.lisp (revision 13309) +++ /branches/new-random/level-1/ppc-threads-utils.lisp (revision 13309) @@ -0,0 +1,210 @@ +;;;-*- Mode: Lisp; Package: CCL -*- +;;; +;;; Copyright (C) 2009 Clozure Associates +;;; Copyright (C) 1994-2001 Digitool, Inc +;;; This file is part of Clozure CL. +;;; +;;; Clozure CL is licensed under the terms of the Lisp Lesser GNU Public +;;; License , known as the LLGPL and distributed with Clozure CL as the +;;; file "LICENSE". The LLGPL consists of a preamble and the LGPL, +;;; which is distributed with Clozure CL as the file "LGPL". Where these +;;; conflict, the preamble takes precedence. +;;; +;;; Clozure CL is referenced in the preamble as the "LIBRARY." +;;; +;;; The LLGPL is also available online at +;;; http://opensource.franz.com/preamble.html + +; low-level support for PPC threads and stack-backtrace printing + +(in-package "CCL") + + +;;; Sure would be nice to have &optional in defppclapfunction arglists +;;; Sure would be nice not to do this at runtime. + +(let ((bits (lfun-bits #'(lambda (x &optional y) (declare (ignore x y)))))) + (lfun-bits #'%fixnum-ref + (dpb (ldb $lfbits-numreq bits) + $lfbits-numreq + (dpb (ldb $lfbits-numopt bits) + $lfbits-numopt + (lfun-bits #'%fixnum-ref))))) + +(let ((bits (lfun-bits #'(lambda (x &optional y) (declare (ignore x y)))))) + (lfun-bits #'%fixnum-ref-natural + (dpb (ldb $lfbits-numreq bits) + $lfbits-numreq + (dpb (ldb $lfbits-numopt bits) + $lfbits-numopt + (lfun-bits #'%fixnum-ref-natural))))) + +(let ((bits (lfun-bits #'(lambda (x y &optional z) (declare (ignore x y z)))))) + (lfun-bits #'%fixnum-set + (dpb (ldb $lfbits-numreq bits) + $lfbits-numreq + (dpb (ldb $lfbits-numopt bits) + $lfbits-numopt + (lfun-bits #'%fixnum-set))))) + +(let ((bits (lfun-bits #'(lambda (x y &optional z) (declare (ignore x y z)))))) + (lfun-bits #'%fixnum-set-natural + (dpb (ldb $lfbits-numreq bits) + $lfbits-numreq + (dpb (ldb $lfbits-numopt bits) + $lfbits-numopt + (lfun-bits #'%fixnum-set-natural))))) + + + + +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; +;;; + + + + + +(defun %frame-backlink (p &optional context) + (cond ((fake-stack-frame-p p) + (%fake-stack-frame.next-sp p)) + ((fixnump p) + (let ((backlink (%%frame-backlink p)) + (fake-frame + (if context (bt.fake-frames context) *fake-stack-frames*))) + (loop + (when (null fake-frame) (return backlink)) + (when (eq backlink (%fake-stack-frame.sp fake-frame)) + (return fake-frame)) + (setq fake-frame (%fake-stack-frame.link fake-frame))))) + (t (error "~s is not a valid stack frame" p)))) + + + + +(defun catch-frame-sp (catch) + (uvref catch target::catch-frame.csp-cell)) + +(defun bottom-of-stack-p (p context) + (and (fixnump p) + (locally (declare (fixnum p)) + (let* ((tcr (if context (bt.tcr context) (%current-tcr))) + (cs-area (%fixnum-ref tcr target::tcr.cs-area))) + (not (%ptr-in-area-p p cs-area)))))) + +(defun lisp-frame-p (p context) + (or (fake-stack-frame-p p) + (locally (declare (fixnum p)) + (let ((next-frame (%frame-backlink p context))) + (when (fake-stack-frame-p next-frame) + (setq next-frame (%fake-stack-frame.sp next-frame))) + (locally (declare (fixnum next-frame)) + (if (bottom-of-stack-p next-frame context) + (values nil t) + (and + (eql (ash target::lisp-frame.size (- target::fixnum-shift)) + (the fixnum (- next-frame p))) + ;; EABI C functions keep their saved LRs where we save FN or 0 + ;; The saved LR of such a function would be fixnum-tagged and never 0. + (let* ((fn (%fixnum-ref p target::lisp-frame.savefn))) + (or (eql fn 0) (typep fn 'function)))))))))) + + + + + +#+ppc32-target +(defun valid-subtag-p (subtag) + (declare (fixnum subtag)) + (let* ((tagval (ldb (byte (- ppc32::num-subtag-bits ppc32::ntagbits) ppc32::ntagbits) subtag))) + (declare (fixnum tagval)) + (case (logand subtag ppc32::fulltagmask) + (#. ppc32::fulltag-immheader (not (eq (%svref *immheader-types* tagval) 'bogus))) + (#. ppc32::fulltag-nodeheader (not (eq (%svref *nodeheader-types* tagval) 'bogus))) + (t nil)))) + +#+ppc64-target +(defun valid-subtag-p (subtag) + (declare (fixnum subtag)) + (let* ((tagval (ash subtag (- ppc64::nlowtagbits)))) + (declare (fixnum tagval)) + (case (logand subtag ppc64::lowtagmask) + (#. ppc64::lowtag-immheader (not (eq (%svref *immheader-types* tagval) 'bogus))) + (#. ppc64::lowtag-nodeheader (not (eq (%svref *nodeheader-types* tagval) 'bogus))) + (t nil)))) + +#+ppc32-target +(defun valid-header-p (thing) + (let* ((fulltag (fulltag thing))) + (declare (fixnum fulltag)) + (case fulltag + (#.ppc32::fulltag-misc (valid-subtag-p (typecode thing))) + ((#.ppc32::fulltag-immheader #.ppc32::fulltag-nodeheader) nil) + (t t)))) + + + +#+ppc64-target +(defun valid-header-p (thing) + (let* ((fulltag (fulltag thing))) + (declare (fixnum fulltag)) + (case fulltag + (#.ppc64::fulltag-misc (valid-subtag-p (typecode thing))) + ((#.ppc64::fulltag-immheader-0 + #.ppc64::fulltag-immheader-1 + #.ppc64::fulltag-immheader-2 + #.ppc64::fulltag-immheader-3 + #.ppc64::fulltag-nodeheader-0 + #.ppc64::fulltag-nodeheader-1 + #.ppc64::fulltag-nodeheader-2 + #.ppc64::fulltag-nodeheader-3) nil) + (t t)))) + + + + +#+ppc32-target +(defun bogus-thing-p (x) + (when x + #+cross-compiling (return-from bogus-thing-p nil) + (or (not (valid-header-p x)) + (let ((tag (lisptag x))) + (unless (or (eql tag ppc32::tag-fixnum) + (eql tag ppc32::tag-imm) + (in-any-consing-area-p x)) + ;; This is terribly complicated, should probably write some LAP + (let ((typecode (typecode x))) + (not (or (case typecode + (#.ppc32::tag-list + (temporary-cons-p x)) + ((#.ppc32::subtag-symbol #.ppc32::subtag-code-vector) + t) ; no stack-consed symbols or code vectors + (#.ppc32::subtag-value-cell + (on-any-vstack x)) + (t + (on-any-tsp-stack x))) + (%heap-ivector-p x))))))))) + + + +#+ppc64-target +(defun bogus-thing-p (x) + (when x + (or (not (valid-header-p x)) + (let ((tag (lisptag x))) + (unless (or (eql tag ppc64::tag-fixnum) + (eql tag ppc64::tag-imm-0) + (eql tag ppc64::tag-imm-2) + (in-any-consing-area-p x)) + ;; This is terribly complicated, should probably write some LAP + (let ((typecode (typecode x))) + (not (or (case typecode + (#.ppc64::fulltag-cons + (temporary-cons-p x)) + ((#.ppc64::subtag-symbol #.ppc64::subtag-code-vector) + t) ; no stack-consed symbols or code vectors + (#.ppc64::subtag-value-cell + (on-any-vstack x)) + (t + (on-any-tsp-stack x))) + (%heap-ivector-p x))))))))) Index: /branches/new-random/level-1/ppc-trap-support.lisp =================================================================== --- /branches/new-random/level-1/ppc-trap-support.lisp (revision 13309) +++ /branches/new-random/level-1/ppc-trap-support.lisp (revision 13309) @@ -0,0 +1,1004 @@ +;;; ppc-trap-support +;;; +;;; Copyright (C) 2009 Clozure Associates +;;; Copyright (C) 1994-2001 Digitool, Inc +;;; This file is part of Clozure CL. +;;; +;;; Clozure CL is licensed under the terms of the Lisp Lesser GNU Public +;;; License , known as the LLGPL and distributed with Clozure CL as the +;;; file "LICENSE". The LLGPL consists of a preamble and the LGPL, +;;; which is distributed with Clozure CL as the file "LGPL". Where these +;;; conflict, the preamble takes precedence. +;;; +;;; Clozure CL is referenced in the preamble as the "LIBRARY." +;;; +;;; The LLGPL is also available online at +;;; http://opensource.franz.com/preamble.html + +;;; Support for PPC traps, this includes the event-poll trap +;;; and all the trxxx traps for type checks & arg count checks. + +(in-package "CCL") + +(eval-when (:compile-toplevel :execute) + (require "NUMBER-MACROS") + + + (defparameter *ppc-instruction-fields* + `((:opcode . ,(byte 6 26)) + (:rt . ,(byte 5 21)) + (:to . ,(byte 5 21)) + (:ra . ,(byte 5 16)) + (:rb . ,(byte 5 11)) + (:d . ,(byte 16 0)) + (:ds . ,(byte 14 2)) + (:ds-xo . ,(byte 2 0)) + (:sh . ,(byte 5 11)) + (:mb . ,(byte 5 6)) + (:me . ,(byte 5 1)) + (:mb6 . ,(byte 6 5)) + (:me6 . ,(byte 6 5)) + (:sh6 . ,(byte 1 1)) + (:x-minor . ,(byte 10 1)) + (:fulltag32 . ,(byte ppc32::ntagbits 0)) + (:lisptag32 . ,(byte ppc32::nlisptagbits 0)) + (:fulltag64 . ,(byte ppc64::ntagbits 0)) + (:lisptag64 . ,(byte ppc64::nlisptagbits 0)) + (:lowtag64 . ,(byte ppc64::nlowtagbits 0)))) + + (defun ppc-instruction-field (field-name) + (or (cdr (assoc field-name *ppc-instruction-fields*)) + (error "Unknown PPC instruction field: ~s" field-name))) + + (defun ppc-instruction-field-mask (field-spec) + (let* ((name (if (atom field-spec) field-spec (car field-spec))) + (value (if (atom field-spec) -1 (cadr field-spec)))) + (dpb value (ppc-instruction-field name) 0))) + + #+darwinppc-target + (progn + (def-foreign-type nil + (:struct :darwin-ppc-float-state + (:fpregs (:array :double 32)) + (:fpscr-pad (:unsigned 32)) + (:fpscr (:unsigned 32)))) + (def-foreign-type nil + (:struct :darwin-ppc-vector-state + (:save-vr (:array (:array (:unsigned 32) 4) 32)) + (:save-vscr (:array (:unsigned 32) 4)) + (:save-pad5 (:array (:unsigned 32) 4)) + (:save-vrvalid (:unsigned 32)) + (:save-pad6 (:array (:unsigned 32) 7)))) + #+ppc64-target + (progn + (def-foreign-type nil + (:struct :darwin-ppc-exception-state64 + (:dar (:unsigned 64)) + (:dsisr (:unsigned 32)) + (:exception (:unsigned 32)) + (:pad1 (:array (:unsigned 32) 4)))) + (def-foreign-type nil + ;; The real record type is defined with + ;; #pragma pack(4) in effect. + ;; The :struct parser should really accept + ;; some option to deal with that, but Apple + ;; should also stop mis-aligning things. + (:struct :darwin-ppc-thread-state64 + (:srr0 (:unsigned 64)) + (:srr1 (:unsigned 64)) + (:r0 (:unsigned 64)) + (:r1 (:unsigned 64)) + (:r2 (:unsigned 64)) + (:r3 (:unsigned 64)) + (:r4 (:unsigned 64)) + (:r5 (:unsigned 64)) + (:r6 (:unsigned 64)) + (:r7 (:unsigned 64)) + (:r8 (:unsigned 64)) + (:r9 (:unsigned 64)) + (:r10 (:unsigned 64)) + (:r11 (:unsigned 64)) + (:r12 (:unsigned 64)) + (:r13 (:unsigned 64)) + (:r14 (:unsigned 64)) + (:r15 (:unsigned 64)) + (:r16 (:unsigned 64)) + (:r17 (:unsigned 64)) + (:r18 (:unsigned 64)) + (:r19 (:unsigned 64)) + (:r20 (:unsigned 64)) + (:r21 (:unsigned 64)) + (:r22 (:unsigned 64)) + (:r23 (:unsigned 64)) + (:r24 (:unsigned 64)) + (:r25 (:unsigned 64)) + (:r26 (:unsigned 64)) + (:r27 (:unsigned 64)) + (:r28 (:unsigned 64)) + (:r29 (:unsigned 64)) + (:r30 (:unsigned 64)) + (:r31 (:unsigned 64)) + (:cr (:unsigned 32)) + (:xer (:unsigned 32)) + (:xer-low (:unsigned 32)) + (:lr (:unsigned 32)) + (:lr-low (:unsigned 32)) + (:ctr (:unsigned 32)) + (:ctr-low (:unsigned 32)) + (:vrsave (:unsigned 32)))) + (def-foreign-type nil + (:struct :darwin-sigaltstack64 + (:ss-sp (:* :void)) + (:ss-size (:unsigned 64)) + (:ss-flags (:unsigned 32)))) + (def-foreign-type nil + (:struct :darwin-mcontext64 + (:es (:struct :darwin-ppc-exception-state64)) + (:ss (:struct :darwin-ppc-thread-state64)) + (:fs (:struct :darwin-ppc-float-state)) + (:vs (:struct :darwin-ppc-vector-state)))) + (def-foreign-type nil + (:struct :darwin-ucontext64 + (:uc-onstack (:signed 32)) + (:uc-sigmask (:signed 32)) + (:uc-stack (:struct :darwin-sigaltstack64)) + (:uc-link (:* (:struct :darwin-ucontext64))) + (:uc-mcsize (:signed 64)) + (:uc-mcontext64 (:* (:struct :darwin-mcontext64))))) + ) + #+ppc32-target + (progn + (def-foreign-type nil + (:struct :darwin-ppc-exception-state32 + (:dar (:unsigned 32)) + (:dsisr (:unsigned 32)) + (:exception (:unsigned 32)) + (:pad0 (:unsigned 32)) + (:pad1 (:array (:unsigned 32) 4)))) + (def-foreign-type nil + (:struct :darwin-ppc-thread-state32 + (:srr0 (:unsigned 32)) + (:srr1 (:unsigned 32)) + (:r0 (:unsigned 32)) + (:r1 (:unsigned 32)) + (:r2 (:unsigned 32)) + (:r3 (:unsigned 32)) + (:r4 (:unsigned 32)) + (:r5 (:unsigned 32)) + (:r6 (:unsigned 32)) + (:r7 (:unsigned 32)) + (:r8 (:unsigned 32)) + (:r9 (:unsigned 32)) + (:r10 (:unsigned 32)) + (:r11 (:unsigned 32)) + (:r12 (:unsigned 32)) + (:r13 (:unsigned 32)) + (:r14 (:unsigned 32)) + (:r15 (:unsigned 32)) + (:r16 (:unsigned 32)) + (:r17 (:unsigned 32)) + (:r18 (:unsigned 32)) + (:r19 (:unsigned 32)) + (:r20 (:unsigned 32)) + (:r21 (:unsigned 32)) + (:r22 (:unsigned 32)) + (:r23 (:unsigned 32)) + (:r24 (:unsigned 32)) + (:r25 (:unsigned 32)) + (:r26 (:unsigned 32)) + (:r27 (:unsigned 32)) + (:r28 (:unsigned 32)) + (:r29 (:unsigned 32)) + (:r30 (:unsigned 32)) + (:r31 (:unsigned 32)) + (:cr (:unsigned 32)) + (:xer (:unsigned 32)) + (:lr (:unsigned 32)) + (:ctr (:unsigned 32)) + (:mq (:unsigned 32)) ; ppc 601! + (:vrsave (:unsigned 32)))) + (def-foreign-type nil + (:struct :darwin-sigaltstack32 + (:ss-sp (:* :void)) + (:ss-size (:unsigned 32)) + (:ss-flags (:unsigned 32)))) + (def-foreign-type nil + (:struct :darwin-mcontext32 + (:es (:struct :darwin-ppc-exception-state32)) + (:ss (:struct :darwin-ppc-thread-state32)) + (:fs (:struct :darwin-ppc-float-state)) + (:vs (:struct :darwin-ppc-vector-state)))) + (def-foreign-type nil + (:struct :darwin-ucontext32 + (:uc-onstack (:signed 32)) + (:uc-sigmask (:signed 32)) + (:uc-stack (:struct :darwin-sigaltstack32)) + (:uc-link (:* (:struct :darwin-ucontext32))) + (:uc-mcsize (:signed 32)) + (:uc-mcontext32 (:* (:struct :darwin-mcontext32))))) + ) + ) + + + + + (defmacro with-xp-registers-and-gpr-offset ((xp register-number) (registers offset) &body body) + (let* ((regform #+linuxppc-target + `(pref ,xp :ucontext.uc_mcontext.regs) + #+darwinppc-target + (target-arch-case + ;; Gak. Apple gratuitously renamed things + ;; for Leopard. Hey, it's not as if anyone + ;; has better things to do than to deal with + ;; this crap ... + (:ppc32 `(pref ,xp :darwin-ucontext32.uc-mcontext32.ss)) + (:ppc64 `(pref ,xp :darwin-ucontext64.uc-mcontext64.ss))))) + `(with-macptrs ((,registers ,regform)) + (let ((,offset (xp-gpr-offset ,register-number))) + ,@body)))) + + (defmacro RA-field (instr) + `(ldb (byte 5 16) ,instr)) + + (defmacro RB-field (instr) + `(ldb (byte 5 11) ,instr)) + + (defmacro D-field (instr) + `(ldb (byte 16 0) ,instr)) + + (defmacro RS-field (instr) + `(ldb (byte 5 21) ,instr)) + + (defmacro lisp-reg-p (reg) + `(>= ,reg ppc::fn)) + + (defmacro ppc-lap-word (instruction-form) + (uvref (uvref (compile nil + `(lambda (&lap 0) + (ppc-lap-function () ((?? 0)) + ,instruction-form))) + + 0) #+ppc32-host 0 #+ppc64-host 1)) + + (defmacro ppc-instruction-mask (&rest fields) + `(logior ,@(mapcar #'ppc-instruction-field-mask (cons :opcode fields)))) + + ) + + + +(defun xp-gpr-offset (register-number) + (unless (and (fixnump register-number) + (<= -2 (the fixnum register-number)) + (< (the fixnum register-number) 48)) + (setq register-number (require-type register-number '(integer -2 48)))) + (the fixnum + (* (the fixnum #+linuxppc-target register-number + #+darwinppc-target (+ register-number 2)) + target::node-size))) + + + +(defun xp-gpr-lisp (xp register-number) + (with-xp-registers-and-gpr-offset (xp register-number) (registers offset) + (values (%get-object registers offset)))) + +(defun (setf xp-gpr-lisp) (value xp register-number) + (with-xp-registers-and-gpr-offset (xp register-number) (registers offset) + (%set-object registers offset value))) + +(defun xp-gpr-signed-long (xp register-number) + (with-xp-registers-and-gpr-offset (xp register-number) (registers offset) + (values (%get-signed-long registers offset)))) + +(defun xp-gpr-signed-doubleword (xp register-number) + (with-xp-registers-and-gpr-offset (xp register-number) (registers offset) + (values (%%get-signed-longlong registers offset)))) + + +(defun xp-gpr-macptr (xp register-number) + (with-xp-registers-and-gpr-offset (xp register-number) (registers offset) + (values (%get-ptr registers offset)))) + +(defun xp-argument-list (xp) + (let ((nargs (xp-gpr-lisp xp ppc::nargs)) ; tagged as a fixnum (how convenient) + (arg-x (xp-gpr-lisp xp ppc::arg_x)) + (arg-y (xp-gpr-lisp xp ppc::arg_y)) + (arg-z (xp-gpr-lisp xp ppc::arg_z))) + (cond ((eql nargs 0) nil) + ((eql nargs 1) (list arg-z)) + ((eql nargs 2) (list arg-y arg-z)) + (t (let ((args (list arg-x arg-y arg-z))) + (if (eql nargs 3) + args + (let ((vsp (xp-gpr-macptr xp ppc::vsp))) + (dotimes (i (- nargs 3)) + (push (%get-object vsp (* i target::node-size)) args)) + args))))))) + +(defun xp-fpscr-info (xp) + (let* ((fpscr #+(and linuxppc-target 32-bit-target) (%get-unsigned-long (pref xp :ucontext.uc_mcontext.regs) (ash #$PT_FPSCR 2)) + #+(and linuxppc-target 64-bit-target) + (%get-unsigned-long (pref xp :ucontext.uc_mcontext.fp_regs) (ash 65 2)) + #+(and darwinppc-target ppc32-target) + (pref xp :darwin-ucontext32.uc-mcontext32.fs.fpscr) + #+(and darwinppc-target ppc64-target) + (pref xp :darwin-ucontext64.uc-mcontext64.fs.fpscr))) + (values (ldb (byte 24 8) fpscr) (ldb (byte 8 0) fpscr)))) + +#+linuxppc-target +(defun xp-double-float (xp fpr) + #+32-bit-target + (%get-double-float (pref xp :ucontext.uc_mcontext.regs) (+ (ash #$PT_FPR0 2) (ash fpr 3))) + #+64-bit-target + (%get-double-float (pref xp :ucontext.uc_mcontext.fp_regs) (ash fpr 3)) + ) + +#+darwinppc-target +(defun xp-double-float (xp fpr) + (%get-double-float + #+ppc32-target (pref xp :darwin-ucontext32.uc-mcontext32.fs) + #+ppc64-target (pref xp :darwin-ucontext64.uc-mcontext64.fs) + (ash fpr 3))) + + +(defparameter *trap-lookup-tries* 5) + + + +(defun %scan-for-instr (mask opcode fn pc-index tries) + (let ((code-vector (and fn (uvref fn 0))) + (offset 0)) + (declare (fixnum offset)) + (flet ((get-instr () + (if code-vector + (let ((index (+ pc-index offset))) + (when (< index 0) (return-from %scan-for-instr nil)) + (uvref code-vector index)) + (%get-long pc-index (the fixnum (* 4 offset)))))) + (declare (dynamic-extent #'get-instr)) + (dotimes (i tries) + (decf offset) + (let ((instr (get-instr))) + (when (match-instr instr mask opcode) + (return instr)) + (when (codevec-header-p instr) + (return nil))))))) + + + + + + +(defun return-address-offset (xp fn machine-state-offset) + (with-macptrs ((regs (pref xp #+linuxppc-target :ucontext.uc_mcontext.regs + #+(and darwinppc-target ppc32-target) + :darwin-ucontext32.uc-mcontext32 + #+(and darwinppc-target ppc64-target) + :darwin-ucontext64.uc-mcontext64))) + (if (functionp fn) + (or (%code-vector-pc (uvref fn 0) (%inc-ptr regs machine-state-offset)) + (%get-ptr regs machine-state-offset)) + (%get-ptr regs machine-state-offset)))) + +(defconstant lr-offset-in-register-context + #+linuxppc-target (ash #$PT_LNK target::word-shift) + #+(and darwinppc-target ppc32-target) + (+ (get-field-offset :darwin-mcontext32.ss) + (get-field-offset :darwin-ppc-thread-state32.lr)) + #+(and darwinppc-target ppc64-target) + (+ (get-field-offset :darwin-mcontext64.ss) + (get-field-offset :darwin-ppc-thread-state64.lr))) + +(defconstant pc-offset-in-register-context + #+linuxppc-target (ash #$PT_NIP target::word-shift) + #+(and darwinppc-target ppc32-target) + (+ (get-field-offset :darwin-mcontext32.ss) + (get-field-offset :darwin-ppc-thread-state32.srr0)) + #+(and darwinppc-target ppc64-target) + (+ (get-field-offset :darwin-mcontext64.ss) + (get-field-offset :darwin-ppc-thread-state64.srr0))) + +;;; When a trap happens, we may have not yet created control +;;; stack frames for the functions containing PC & LR. +;;; If that is the case, we add fake-stack-frame's to *fake-stack-frames* +;;; There are 4 cases: +;;; +;;; PC in FN +;;; Push 1 stack frame: PC/FN +;;; This might miss one recursive call, but it won't miss any variables +;;; PC in NFN +;;; Push 2 stack frames: +;;; 1) PC/NFN/VSP +;;; 2) LR/FN/VSP +;;; This might think some of NFN's variables are part of FN's stack frame, +;;; but that's the best we can do. +;;; LR in FN +;;; Push 1 stack frame: LR/FN +;;; None of the above +;;; Push no new stack frames +;;; +;;; The backtrace support functions in "ccl:l1;l1-lisp-threads.lisp" know how +;;; to find the fake stack frames and handle them as arguments. +(defun funcall-with-xp-stack-frames (xp trap-function thunk) + (cond ((null trap-function) + ; Maybe inside a subprim from a lisp function + (let* ((fn (xp-gpr-lisp xp ppc::fn)) + (lr (return-address-offset + xp fn lr-offset-in-register-context))) + (if (fixnump lr) + (let* ((sp (xp-gpr-lisp xp ppc::sp)) + (vsp (xp-gpr-lisp xp ppc::vsp)) + (frame (%cons-fake-stack-frame sp sp fn lr vsp xp *fake-stack-frames*)) + (*fake-stack-frames* frame)) + (declare (dynamic-extent frame)) + (funcall thunk frame)) + (funcall thunk (xp-gpr-lisp xp ppc::sp))))) + ((eq trap-function (xp-gpr-lisp xp ppc::fn)) + (let* ((sp (xp-gpr-lisp xp ppc::sp)) + (fn trap-function) + (lr (return-address-offset + xp fn pc-offset-in-register-context)) + (vsp (xp-gpr-lisp xp ppc::vsp)) + (frame (%cons-fake-stack-frame sp sp fn lr vsp xp *fake-stack-frames*)) + (*fake-stack-frames* frame)) + (declare (dynamic-extent frame)) + (funcall thunk frame))) + ((eq trap-function (xp-gpr-lisp xp ppc::nfn)) + (let* ((sp (xp-gpr-lisp xp ppc::sp)) + (fn (xp-gpr-lisp xp ppc::fn)) + (lr (return-address-offset + xp fn lr-offset-in-register-context)) + (vsp (xp-gpr-lisp xp ppc::vsp)) + (lr-frame (%cons-fake-stack-frame sp sp fn lr vsp xp)) + (pc-fn trap-function) + (pc-lr (return-address-offset + xp pc-fn pc-offset-in-register-context)) + (pc-frame (%cons-fake-stack-frame sp lr-frame pc-fn pc-lr vsp xp *fake-stack-frames*)) + (*fake-stack-frames* pc-frame)) + (declare (dynamic-extent lr-frame pc-frame)) + (funcall thunk pc-frame))) + (t (funcall thunk (xp-gpr-lisp xp ppc::sp))))) + + + +;;; Enter here from handle-trap in "lisp-exceptions.c". +;;; xp is a pointer to an ExceptionInformationPowerPC record. +;;; the-trap is the trap instruction that got us here. +;;; fn-reg is either fn, nfn or 0. If it is fn or nfn, then +;;; the trap occcurred in that register's code vector. +;;; If it is 0, then the trap occurred somewhere else. +;;; pc-index is either the index in fn-reg's code vector +;;; or, if fn-reg is 0, the address of the PC at the trap instruction. +;;; This code parallels the trap decoding code in +;;; "lisp-exceptions.c" that runs if (symbol-value 'cmain) +;;; is not a macptr. +;;; Some of these could probably call %err-disp instead of error, +;;; but I was too lazy to look them up. + +#+ppc32-target +(defcallback xcmain (:without-interrupts t + :address xp + :unsigned-fullword fn-reg + :address pc-or-index + :unsigned-fullword the-trap + :signed-fullword arg-0 + :signed-fullword arg-1) + ;; twgti nargs,0 + ;; time for event polling. + ;; This used to happen a lot so we test for it first. + (let ((fn (unless (eql fn-reg 0) (xp-gpr-lisp xp fn-reg)))) + (with-xp-stack-frames (xp fn frame-ptr) + (if (eql the-trap (ppc-lap-word (twgti nargs 0))) + (cmain) + (with-error-reentry-detection + (let ((pc-index (if (eql fn-reg 0) pc-or-index (%ptr-to-int pc-or-index))) + instr ra temp rs condition) + (cond + ((= the-trap #$SIGBUS) + (%error (make-condition 'invalid-memory-access + :address arg-0 + :write-p (not (zerop arg-1))) + () + frame-ptr)) + ;; tweqi RA nil-value - resolve-eep, or resolve-foreign-variable + ((and (match-instr the-trap + (ppc-instruction-mask :opcode :to :d) + (ppc-lap-word (tweqi ?? (target-nil-value)))) + (setq instr (scan-for-instr + (ppc-instruction-mask :opcode :d) + (ppc-lap-word (lwz ?? + (+ 4 ppc32::misc-data-offset) + ??)) + fn pc-index))) + (let* ((eep-or-fv (xp-gpr-lisp xp (RA-field instr)))) + (etypecase eep-or-fv + (external-entry-point + (resolve-eep eep-or-fv) + (setf (xp-gpr-lisp xp (RA-field the-trap)) + (eep.address eep-or-fv))) + (foreign-variable + (resolve-foreign-variable eep-or-fv) + (setf (xp-gpr-lisp xp (RA-field the-trap)) + (fv.addr eep-or-fv)))))) + ;; twnei RA,N; RA = nargs + ;; nargs check, no optional or rest involved + ((match-instr the-trap + (ppc-instruction-mask :opcode :to :ra) + (ppc-lap-word (twnei nargs ??))) + (%error (if (< (xp-GPR-signed-long xp ppc::nargs) (D-field the-trap)) + 'too-few-arguments + 'too-many-arguments ) + (list :nargs (ash (xp-GPR-signed-long xp ppc::nargs) + (- ppc32::fixnumshift)) + :fn fn) + frame-ptr)) + + ;; twnei RA,N; RA != nargs, N = fulltag_node/immheader + ;; type check; look for "lbz rt-imm,-3(ra-node)" + ((and (or (match-instr the-trap + (ppc-instruction-mask :opcode :to :fulltag32) + (ppc-lap-word (twnei ?? ppc32::fulltag-nodeheader))) + (match-instr the-trap + (ppc-instruction-mask :opcode :to :fulltag32) + (ppc-lap-word (twnei ?? ppc32::fulltag-immheader)))) + (setq instr (scan-for-instr (ppc-instruction-mask :opcode :d) + (ppc-lap-word (lbz ?? ppc32::misc-subtag-offset ??)) + fn pc-index)) + (lisp-reg-p (setq ra (RA-field instr)))) + (let* ((typecode (D-field the-trap)) + (type-tag (logand typecode ppc32::fulltagmask)) + (type-name (svref (if (eql type-tag ppc32::fulltag-nodeheader) + *nodeheader-types* + *immheader-types*) + (ldb (byte (- ppc32::num-subtag-bits ppc32::ntagbits) ppc32::ntagbits) typecode)))) + (%error (make-condition 'type-error + :format-control (%rsc-string $XWRONGTYPE) + :datum (xp-GPR-lisp xp ra) + :expected-type type-name) + nil + frame-ptr))) + + ;; twnei RA,N; RA != nargs, N = subtag_character + ;; type check; look for "clrlwi rs-node,ra-imm,24" = "rlwinm rs,ra,0,24,31" + ((and (match-instr the-trap + (ppc-instruction-mask :opcode :to :d) + (ppc-lap-word (twnei ?? ppc32::subtag-character))) + (setq instr (scan-for-instr (ppc-instruction-mask :opcode :rb :mb :me) + (ppc-lap-word (rlwinm ?? ?? 0 24 31)) + fn pc-index)) + (lisp-reg-p (setq rs (RS-field instr)))) + (%error (make-condition 'type-error + :datum (xp-GPR-lisp xp rs) + :expected-type 'character) + nil + frame-ptr)) + + ;; twnei RA,N; RA != nargs, N != fulltag_node/immheader + ;; (since that case was handled above.) + ;; type check; look for "clrlwi rs-node,ra-imm,29/30" = "rlwinm rs,ra,0,29/30,31" + ((and (match-instr the-trap + (ppc-instruction-mask :opcode :to) + (ppc-lap-word (twnei ?? ??))) + (setq instr (scan-for-instr (ppc-instruction-mask :opcode :rb (:mb 28) :me) + (ppc-lap-word (rlwinm ?? ?? 0 28 31)) + fn pc-index)) + (or (eql (- 32 ppc32::ntagbits) (setq temp (ldb #.(ppc-instruction-field :mb) instr))) + (eql (- 32 ppc32::nlisptagbits) temp)) + (lisp-reg-p (setq rs (RS-field instr)))) + (let* ((tag (logand the-trap ppc32::tagmask)) + (type-name + (case tag + (#.ppc32::tag-fixnum 'fixnum) + (#.ppc32::tag-list (if (eql temp (- 32 ppc32::ntagbits)) 'cons 'list)) + (#.ppc32::tag-misc 'uvector) + (#.ppc32::tag-imm 'immediate)))) + (%error (make-condition 'type-error + :datum (xp-GPR-lisp xp rs) + :expected-type type-name) + nil + frame-ptr))) + + ;; twlgti RA,N; RA = nargs (xy = 01) + ;; twllti RA,N; RA = nargs (xy = 10) + ;; nargs check, optional or rest involved + ((and (match-instr the-trap + (ppc-instruction-mask :opcode (:to #x1c) :ra) + (ppc-lap-word (twi ?? ppc::nargs ??))) + (or (eql #b01 (setq temp (ldb #.(ppc-instruction-field :to) the-trap))) + (eql #b10 temp))) + (%error (if (eql temp #b10) + 'too-few-arguments + 'too-many-arguments) + (list :nargs (ash (xp-GPR-signed-long xp ppc::nargs) + (- ppc32::fixnumshift)) + :fn fn) + frame-ptr)) + + ;; tweqi RA,N; N = unbound + ;; symeval boundp check; look for "lwz RA,symbol.vcell(nodereg)" + ((and (match-instr the-trap + (ppc-instruction-mask :opcode :to :d) + (ppc-lap-word (tweqi ?? ppc32::unbound-marker))) + (setq instr (scan-for-instr (ppc-instruction-mask :opcode :d) + (ppc-lap-word (lwz ?? ppc32::symbol.vcell ??)) + fn pc-index)) + (lisp-reg-p (setq ra (RA-field instr)))) + (setf (xp-GPR-lisp xp (RA-field the-trap)) + (%kernel-restart-internal $xvunbnd (list (xp-GPR-lisp xp ra)) frame-ptr))) + ;; tweqi RA,N: n = (%slot-unbound-marker) + ;; slot-unbound trap. Look for preceding "lwzx RA,rx,ry". + ;; rx = slots-vector, ry = scaled index in slots vector. + ((and (match-instr the-trap + (ppc-instruction-mask :opcode :to :d) + (ppc-lap-word (tweqi ?? ppc32::slot-unbound-marker))) + (setq instr (scan-for-instr (ppc-instruction-mask + :opcode :rt :x-minor) + (dpb + (RA-field the-trap) + (byte 5 21) + (ppc-lap-word + (lwzx ?? ?? ??))) + fn pc-index))) + (setq *error-reentry-count* 0) ; succesfully reported error + + ;; %SLOT-UNBOUND-TRAP will decode the arguments further, + ;; then call the generic function SLOT-UNBOUND. That + ;; might return a value; if so, set the value of the + ;; register that caused the trap to that value. + (setf (xp-gpr-lisp xp (ra-field the-trap)) + (%slot-unbound-trap (xp-gpr-lisp xp (RA-field instr)) + (ash (- (xp-gpr-signed-long xp (RB-field instr)) + ppc32::misc-data-offset) + (- ppc32::word-shift)) + frame-ptr))) + ;; twlge RA,RB + ;; vector bounds check; look for "lwz immreg, misc_header_offset(nodereg)" + ((and (match-instr the-trap + (ppc-instruction-mask :opcode :to :x-minor) + (ppc-lap-word (twlge 0 0))) + (setq instr (scan-for-instr (ppc-instruction-mask :opcode #|:d|#) + (ppc-lap-word (lwz ?? ?? #|ppc32::misc-header-offset|# ??)) + fn pc-index)) + (lisp-reg-p (setq ra (RA-field instr)))) + (%error (%rsc-string $xarroob) + (list (xp-GPR-lisp xp (RA-field the-trap)) + (xp-GPR-lisp xp ra)) + frame-ptr)) + ;; twi 27 ra d - array header rank check + ((and (match-instr the-trap + (ppc-instruction-mask :opcode :to) + (ppc-lap-word (twi 27 ?? ??))) + (setq instr (scan-for-instr (ppc-instruction-mask :opcode :d) + (ppc-lap-word (lwz ?? ppc32::arrayH.rank ??)) + fn pc-index)) + (lisp-reg-p (setq ra (RA-field instr)))) + (%error (%rsc-string $xndims) + (list (xp-gpr-lisp xp ra) + (ash (ldb (byte 16 0) the-trap) (- ppc32::fixnumshift))) + frame-ptr)) + ;; tw 27 ra rb - array flags check + ((and (match-instr the-trap + (ppc-instruction-mask :opcode :to :x-minor) + (ppc-lap-word (tw 27 ?? ??))) + (setq instr (scan-for-instr (ppc-instruction-mask :opcode :d) + (ppc-lap-word (lwz ?? ppc32::arrayH.flags ??)) + fn pc-index)) + (lisp-reg-p (setq ra (RA-field instr))) + (let* ((expected (xp-gpr-lisp xp (RB-field the-trap))) + (expected-subtype (ldb + ppc32::arrayH.flags-cell-subtag-byte + expected)) + (expect-simple (= + (ldb ppc32::arrayH.flags-cell-bits-byte + expected) + (ash 1 $arh_simple_bit))) + (type-name + (case expected-subtype + (#.ppc32::subtag-double-float-vector 'double-float)))) + + (and type-name expect-simple + (setq condition + (make-condition 'type-error + :datum (xp-gpr-lisp xp ra) + :expected-type + `(simple-array ,type-name)))))) + (%error condition nil frame-ptr)) + + ;; Unknown trap + (t (%error "Unknown trap: #x~x~%xp: ~s, fn: ~s, pc: #x~x" + (list the-trap xp fn (ash pc-index ppc32::fixnumshift)) + frame-ptr))))))))) + +#+ppc64-target +(defcallback xcmain (:without-interrupts t + :address xp + :unsigned-fullword fn-reg + :address pc-or-index + :unsigned-fullword the-trap + :signed-doubleword arg0 + :signed-doubleword arg1) + ;; tdgti nargs,0 + ;; time for event polling. + ;; This used to happen a lot so we test for it first. + (let ((fn (unless (eql fn-reg 0) (xp-gpr-lisp xp fn-reg)))) + (with-xp-stack-frames (xp fn frame-ptr) + (if (eql the-trap (ppc-lap-word (tdgti nargs 0))) + (cmain) + (with-error-reentry-detection + (let ((pc-index (if (eql fn-reg 0) pc-or-index (%ptr-to-int pc-or-index))) + instr ra temp rs condition) + (cond + ;; tdeqi RA nil-value - resolve-eep, or resolve-foreign-variable + ((and (match-instr the-trap + (ppc-instruction-mask :opcode :to :d) + (ppc-lap-word (tdeqi ?? (target-nil-value)))) + (setq instr (scan-for-instr + (ppc-instruction-mask :opcode :ds :ds-xo) + (ppc-lap-word (ld ?? + (+ 8 ppc64::misc-data-offset) + ??)) + fn pc-index))) + (let* ((eep-or-fv (xp-gpr-lisp xp (RA-field instr)))) + (etypecase eep-or-fv + (external-entry-point + (resolve-eep eep-or-fv) + (setf (xp-gpr-lisp xp (RA-field the-trap)) + (eep.address eep-or-fv))) + (foreign-variable + (resolve-foreign-variable eep-or-fv) + (setf (xp-gpr-lisp xp (RA-field the-trap)) + (fv.addr eep-or-fv)))))) + ((= the-trap #$SIGBUS) + (%error (make-condition 'invalid-memory-access + :address arg0 + :write-p (not (zerop arg1))) + () + frame-ptr)) + ;; tdnei RA,N; RA = nargs + ;; nargs check, no optional or rest involved + ((match-instr the-trap + (ppc-instruction-mask :opcode :to :ra) + (ppc-lap-word (tdnei nargs ??))) + (%error (if (< (xp-GPR-signed-doubleword xp ppc::nargs) (D-field the-trap)) + 'too-few-arguments + 'too-many-arguments ) + (list :nargs (ash (xp-GPR-signed-doubleword xp ppc::nargs) + (- ppc64::fixnumshift)) + :fn fn) + frame-ptr)) + + ;; tdnei RA,N; RA != nargs, N = lowtag_node/immheader + ;; type check; look for "lbz rt-imm,-5(ra-node)" + ((and (or (match-instr the-trap + (ppc-instruction-mask :opcode :to :lowtag64) + (ppc-lap-word (tdnei ?? ppc64::lowtag-nodeheader))) + (match-instr the-trap + (ppc-instruction-mask :opcode :rt :lowtag64) + (ppc-lap-word (tdnei ?? ppc64::lowtag-immheader)))) + (setq instr (scan-for-instr (ppc-instruction-mask :opcode :d) + (ppc-lap-word (lbz ?? ppc64::misc-subtag-offset ??)) + fn pc-index)) + (lisp-reg-p (setq ra (RA-field instr)))) + (let* ((typecode (D-field the-trap)) + (type-tag (logand typecode ppc64::lowtagmask)) + (type-name (svref (if (eql type-tag ppc64::lowtag-nodeheader) + *nodeheader-types* + *immheader-types*) + (ash typecode (- ppc64::nlowtagbits))))) + (%error (make-condition 'type-error + :format-control (%rsc-string $XWRONGTYPE) + :datum (xp-GPR-lisp xp ra) + :expected-type type-name) + nil + frame-ptr))) + ;; tdnei RA,N; RA != nargs, N = subtag_character type + ;; check; look for "clrldi rs-node,ra-imm,56" = "rldicl + ;; rs,ra,0,55" + ((and (match-instr the-trap + (ppc-instruction-mask :opcode :rt :d) + (ppc-lap-word (tdnei ?? ppc64::subtag-character))) + (setq instr (scan-for-instr (ppc-instruction-mask :opcode :sh :mb6 :sh6) + (ppc-lap-word (rldicl ?? ?? 0 56)) + fn pc-index)) + (lisp-reg-p (setq rs (RS-field instr)))) + (%error (make-condition 'type-error + :datum (xp-GPR-lisp xp rs) + :expected-type 'character) + nil + frame-ptr)) + + ;; tdnei RA,N; RA != nargs, N = ppc64::tag-fixnum. type + ;; check; look for "clrldi rs-node,ra-imm,61" = "rldicl + ;; rs,ra,61" + ((and (match-instr the-trap + (ppc-instruction-mask :opcode :rt) + (ppc-lap-word (tdnei ?? ppc64::tag-fixnum))) + (setq instr (scan-for-instr (ppc-instruction-mask :opcode :sh :mb6 :sh6) + (ppc-lap-word (rldicl ?? ?? 0 61)) + fn pc-index)) + + (lisp-reg-p (setq rs (RS-field instr)))) + (%error (make-condition 'type-error + :datum (xp-GPR-lisp xp rs) + :expected-type 'fixnum) + nil + frame-ptr)) + ;; tdi 3,RA,ppc64::fulltag-cons; RA != nargs type check; + ;; look for "clrldi rs-node,ra-imm,60" = "rldicl + ;; rs,ra,60" + ((and (match-instr the-trap + (ppc-instruction-mask :opcode :to :d) + (ppc-lap-word (tdi 3 ?? ppc64::fulltag-cons))) + (setq instr (scan-for-instr (ppc-instruction-mask :opcode :sh :mb6 :sh6) + (ppc-lap-word (rldicl ?? ?? 0 60)) + fn pc-index)) + + (lisp-reg-p (setq rs (RS-field instr)))) + (%error (make-condition 'type-error + :datum (xp-GPR-lisp xp rs) + :expected-type 'list) + nil + frame-ptr)) + ;; tdnei RA,ppc64::fulltag-cons; RA != nargs type check; + ;; look for "clrldi rs-node,ra-imm,60" = "rldicl + ;; rs,ra,60" + ((and (match-instr the-trap + (ppc-instruction-mask :opcode :to :d) + (ppc-lap-word (tdnei ?? ppc64::fulltag-cons))) + (setq instr (scan-for-instr (ppc-instruction-mask :opcode :sh :mb6 :sh6) + (ppc-lap-word (rldicl ?? ?? 0 60)) + fn pc-index)) + + (lisp-reg-p (setq rs (RS-field instr)))) + (%error (make-condition 'type-error + :datum (xp-GPR-lisp xp rs) + :expected-type 'cons) + nil + frame-ptr)) + ;; tdnei RA,ppc64::subtag-single-float; RA != nargs type check; + ;; look for "clrldi rs-node,ra-imm,60" = "rldicl + ;; rs,ra,60" + ((and (match-instr the-trap + (ppc-instruction-mask :opcode :to :d) + (ppc-lap-word (tdnei ?? ppc64::subtag-single-float))) + (setq instr (scan-for-instr (ppc-instruction-mask :opcode :sh :mb6 :sh6) + (ppc-lap-word (rldicl ?? ?? 0 60)) + fn pc-index)) + + (lisp-reg-p (setq rs (RS-field instr)))) + (%error (make-condition 'type-error + :datum (xp-GPR-lisp xp rs) + :expected-type 'short-float) + nil + frame-ptr)) + ;; tdnei RA,ppc64::fulltag-misc; RA != nargs type check; + ;; look for "clrldi rs-node,ra-imm,60" = "rldicl + ;; rs,ra,60" + ((and (match-instr the-trap + (ppc-instruction-mask :opcode :to :d) + (ppc-lap-word (tdnei ?? ppc64::fulltag-misc))) + (setq instr (scan-for-instr (ppc-instruction-mask :opcode :sh :mb6 :sh6) + (ppc-lap-word (rldicl ?? ?? 0 60)) + fn pc-index)) + + (lisp-reg-p (setq rs (RS-field instr)))) + (%error (make-condition 'type-error + :datum (xp-GPR-lisp xp rs) + :expected-type 'uvector) + nil + frame-ptr)) + ;; tdlgti RA,N; RA = nargs (xy = 01) + ;; tdllti RA,N; RA = nargs (xy = 10) + ;; nargs check, optional or rest involved + ((and (match-instr the-trap + (ppc-instruction-mask :opcode (:to #x1c) :ra) + (ppc-lap-word (tdi ?? ppc::nargs ??))) + (or (eql #b01 (setq temp (ldb #.(ppc-instruction-field :to) the-trap))) + (eql #b10 temp))) + (%error (if (eql temp #b10) + 'too-few-arguments + 'too-many-arguments) + (list :nargs (ash (xp-GPR-signed-doubleword xp ppc::nargs) + (- ppc64::fixnumshift)) + :fn fn) + frame-ptr)) + + ;; tdeqi RA,N; N = unbound + ;; symeval boundp check; look for "ld RA,symbol.vcell(nodereg)" + ((and (match-instr the-trap + (ppc-instruction-mask :opcode :to :d) + (ppc-lap-word (tdeqi ?? ppc64::unbound-marker))) + (setq instr (scan-for-instr (ppc-instruction-mask :opcode :ds :ds-xo) + (ppc-lap-word (ld ?? ppc64::symbol.vcell ??)) + fn pc-index)) + (lisp-reg-p (setq ra (RA-field instr)))) + (setf (xp-GPR-lisp xp (RA-field the-trap)) + (%kernel-restart-internal $xvunbnd (list (xp-GPR-lisp xp ra)) frame-ptr))) + ;; tdeqi RA,N: n = (%slot-unbound-marker) + ;; slot-unbound trap. Look for preceding "ldx RA,rx,ry". + ;; rx = slots-vector, ry = scaled index in slots vector. + ((and (match-instr the-trap + (ppc-instruction-mask :opcode :to :d) + (ppc-lap-word (tdeqi ?? ppc64::slot-unbound-marker))) + (setq instr (scan-for-instr (ppc-instruction-mask + :opcode :rt :x-minor) + (dpb + (RA-field the-trap) + (byte 5 21) + (ppc-lap-word + (ldx ?? ?? ??))) + fn pc-index))) + (setq *error-reentry-count* 0) ; succesfully reported error + ;; %SLOT-UNBOUND-TRAP will decode the arguments further, + ;; then call the generic function SLOT-UNBOUND. That + ;; might return a value; if so, set the value of the + ;; register that caused the trap to that value. + (setf (xp-gpr-lisp xp (ra-field the-trap)) + (%slot-unbound-trap (xp-gpr-lisp xp (RA-field instr)) + (ash (- (xp-gpr-signed-doubleword xp (RB-field instr)) + ppc64::misc-data-offset) + (- ppc64::word-shift)) + frame-ptr))) + ;; tdlge RA,RB + ;; vector bounds check; look for "ld immreg, misc_header_offset(nodereg)" + ((and (match-instr the-trap + (ppc-instruction-mask :opcode :to :x-minor) + (ppc-lap-word (tdlge ?? ??))) + (setq instr (scan-for-instr (ppc-instruction-mask :opcode #|:d|# :ds-xo) + (ppc-lap-word (ld ?? ?? #|ppc32::misc-header-offset|# ??)) + fn pc-index)) + (lisp-reg-p (setq ra (RA-field instr)))) + (%error (%rsc-string $xarroob) + (list (xp-GPR-lisp xp (RA-field the-trap)) + (xp-GPR-lisp xp ra)) + frame-ptr)) + ;; tdi 27 ra d - array header rank check + ((and (match-instr the-trap + (ppc-instruction-mask :opcode :to) + (ppc-lap-word (tdi 27 ?? ??))) + (setq instr (scan-for-instr (ppc-instruction-mask :opcode :ds :ds-xo) + (ppc-lap-word (ld ?? ppc64::arrayH.rank ??)) + fn pc-index)) + (lisp-reg-p (setq ra (RA-field instr)))) + (%error (%rsc-string $xndims) + (list (xp-gpr-lisp xp ra) + (ash (ldb (byte 16 0) the-trap) (- ppc64::fixnumshift))) + frame-ptr)) + ;; td 27 ra rb - array flags check + ((and (match-instr the-trap + (ppc-instruction-mask :opcode :to :x-minor) + (ppc-lap-word (td 27 ?? ??))) + (setq instr (scan-for-instr (ppc-instruction-mask :opcode :ds :ds-xo) + (ppc-lap-word (ld ?? ppc64::arrayH.flags ??)) + fn pc-index)) + (lisp-reg-p (setq ra (RA-field instr))) + (let* ((expected (xp-gpr-lisp xp (RB-field the-trap))) + (expected-subtype (ldb + ppc64::arrayH.flags-cell-subtag-byte + expected)) + (expect-simple (= + (ldb ppc64::arrayH.flags-cell-bits-byte + expected) + (ash 1 $arh_simple_bit))) + (type-name + (case expected-subtype + (#.ppc64::subtag-double-float-vector 'double-float)))) + + (and type-name expect-simple + (setq condition + (make-condition 'type-error + :datum (xp-gpr-lisp xp ra) + :expected-type + `(simple-array ,type-name)))))) + (%error condition nil frame-ptr)) + + ;; Unknown trap + (t (%error "Unknown trap: #x~x~%xp: ~s, fn: ~s, pc: #x~x" + (list the-trap xp fn (ash pc-index ppc64::fixnumshift)) + frame-ptr))))))))) + + + + + Index: /branches/new-random/level-1/runtime.lisp =================================================================== --- /branches/new-random/level-1/runtime.lisp (revision 13309) +++ /branches/new-random/level-1/runtime.lisp (revision 13309) @@ -0,0 +1,159 @@ +;;-*-Mode: LISP; Package: CCL -*- +;;; +;;; Copyright (C) 2009 Clozure Associates +;;; Copyright (C) 1994-2001 Digitool, Inc +;;; This file is part of Clozure CL. +;;; +;;; Clozure CL is licensed under the terms of the Lisp Lesser GNU Public +;;; License , known as the LLGPL and distributed with Clozure CL as the +;;; file "LICENSE". The LLGPL consists of a preamble and the LGPL, +;;; which is distributed with Clozure CL as the file "LGPL". Where these +;;; conflict, the preamble takes precedence. +;;; +;;; Clozure CL is referenced in the preamble as the "LIBRARY." +;;; +;;; The LLGPL is also available online at +;;; http://opensource.franz.com/preamble.html + +;;; Load .pfsl files, create a "runtime" (compiler- & development-tools-less) +;;; image. + +(in-package "CCL") + +(%fasload "./l1-pfsls/l1-cl-package.pfsl") +(%fasload "./l1-pfsls/l1-utils.pfsl") +(%fasload "./l1-pfsls/l1-init.pfsl") +(%fasload "./l1-pfsls/l1-symhash.pfsl") +(%fasload "./l1-pfsls/l1-numbers.pfsl") +(%fasload "./l1-pfsls/l1-aprims.pfsl") +(%fasload "./l1-pfsls/ppc-callback-support.pfsl") +(%fasload "./l1-pfsls/l1-sort.pfsl") +(%fasload "./l1-pfsls/l1-dcode.pfsl") +(%fasload "./l1-pfsls/l1-clos.pfsl") +(%fasload "./binppc/defstruct.pfsl") +(%fasload "./l1-pfsls/l1-streams.pfsl") +(%fasload "./l1-pfsls/linux-files.pfsl") +(%fasload "./binppc/lists.pfsl") +(%fasload "./binppc/sequences.pfsl") +(%fasload "./binppc/chars.pfsl") +(%fasload "./l1-pfsls/l1-files.pfsl") +(provide "SEQUENCES") +(provide "DEFSTRUCT") +(provide "CHARS") +(provide "LISTS") +(%fasload "./l1-pfsls/ppc-stack-groups.pfsl") +(%fasload "./l1-pfsls/l1-stack-groups.pfsl") +(%fasload "./l1-pfsls/l1-processes.pfsl") +(%fasload "./l1-pfsls/l1-io.pfsl") +(%fasload "./l1-pfsls/l1-reader.pfsl") +(%fasload "./l1-pfsls/l1-readloop.pfsl") +(%fasload "./l1-pfsls/l1-readloop-lds.pfsl") +(%fasload "./l1-pfsls/l1-error-system.pfsl") + +(%fasload "./l1-pfsls/l1-events.pfsl") +(%fasload "./l1-pfsls/ppc-trap-support.pfsl") +(%fasload "./l1-pfsls/l1-format.pfsl") +(%fasload "./l1-pfsls/l1-sysio.pfsl") +(%fasload "./l1-pfsls/l1-pathnames.pfsl") +(%fasload "./l1-pfsls/version.pfsl") +(%fasload "./l1-pfsls/l1-boot-lds.pfsl") + +(%fasload "./l1-pfsls/l1-boot-1.pfsl") +(catch :toplevel + (%fasload "./l1-pfsls/l1-typesys.pfsl") + (%fasload "./l1-pfsls/sysutils.pfsl") + (%fasload "./l1-pfsls/l1-error-signal.pfsl") + (setq *LEVEL-1-LOADED* t)) + +(def-ccl-pointers fd-streams () + (let* ((in (make-fd-stream 0 :direction :input)) + (out (make-fd-stream 1 :direction :output)) + (error out)) + (setq *terminal-io* (make-echoing-two-way-stream in out)) + (setq *debug-io* (make-echoing-two-way-stream in error) + *query-io* *debug-io*) + (setq *standard-input* in + *standard-output* out + *error-output* error + *trace-output* error))) + +(catch :toplevel + (flet ((load-provide (module path) + (let* ((*package* *package*)) + (%fasload path) + (provide module)))) + (load-provide "SORT" "./binppc/sort.pfsl") + (load-provide "NUMBERS" "./binppc/numbers.pfsl") + (load-provide "HASH" "./binppc/hash.pfsl") +;;; (load-provide "DLL-NODE" "./binppc/dll-node.pfsl") +;;; (load-provide "PPC32-ARCH" "./binppc/ppc32-arch.pfsl") +;;; (load-provide "VREG" "./binppc/vreg.pfsl") +;;; (load-provide "PPC-ASM" "./binppc/ppc-asm.pfsl") +;;; (load-provide "VINSN" "./binppc/vinsn.pfsl") +;;; (load-provide "PPC-VINSNS" "./binppc/ppc-vinsns.pfsl") +;;; (load-provide "PPC-REG" "./binppc/ppc-reg.pfsl") +;;; (load-provide "SUBPRIMS" "./binppc/subprims.pfsl") +;;; (load-provide "PPC-LAP" "./binppc/ppc-lap.pfsl") +;;; (provide "PPC2") ; Lie, load the module manually +;;; (load-provide "NX" "./l1-pfsls/nx.pfsl") +;;; (%fasload "./binppc/ppc2.pfsl") + (load-provide "LEVEL-2" "./binppc/level-2.pfsl") +;;; (load-provide "SETF" "./binppc/setf.pfsl") + (load-provide "SETF-RUNTIME" "./binppc/setf-runtime.pfsl") + (load-provide "FORMAT" "./binppc/format.pfsl") + (load-provide "STREAMS" "./binppc/streams.pfsl") +;;; (load-provide "OPTIMIZERS" "./binppc/optimizers.pfsl") +;;; (load-provide "PPC-OPTIMIZERS" "./binppc/ppc-optimizers.pfsl") +;;; (load-provide "LISPEQU" "./library/lispequ.pfsl") ; Shouldn't need this at load time ... +;;; (load-provide "DEFSTRUCT-MACROS" "./binppc/defstruct-macros.pfsl") ; ... but this file thinks it does. +;;; (load-provide "DEFSTRUCT-LDS" "./binppc/defstruct-lds.pfsl") +;;; (load-provide "NFCOMP" "./binppc/nfcomp.pfsl") +;;; (load-provide "BACKQUOTE" "./binppc/backquote.pfsl") + (load-provide "BACKTRACE-LDS" "./binppc/backtrace-lds.pfsl") + (load-provide "BACKTRACE" "./binppc/backtrace.pfsl") + (load-provide "READ" "./binppc/read.pfsl") + (load-provide "ARRAYS-FRY" "./binppc/arrays-fry.pfsl") +;;; (load-provide "APROPOS" "./binppc/apropos.pfsl") +;;; (load-provide "PPC-DISASSEMBLE" "./binppc/ppc-disassemble.pfsl") +;;; (load-provide "PPC-LAPMACROS" "./binppc/ppc-lapmacros.pfsl") +;;; (load-provide "MACTYPES" "./binppc/mactypes.pfsl") +;;; (load-provide "DEFRECORD" "./binppc/defrecord.pfsl") +;;; (load-provide "LINUX-RECORDS" "./library/linux-records.pfsl") + (load-provide "CASE-ERROR" "./binppc/case-error.pfsl") +;;; (load-provide "ENCAPSULATE" "./binppc/encapsulate.pfsl") + (load-provide "METHOD-COMBINATION" "./binppc/method-combination.pfsl") + (load-provide "MISC" "./binppc/misc.pfsl") + (load-provide "PPRINT" "./binppc/pprint.pfsl") + (load-provide "DUMPLISP" "./binppc/dumplisp.pfsl") + (load-provide "PATHNAMES" "./binppc/pathnames.pfsl") + (load-provide "TIME" "./binppc/time.pfsl") +;;; (load-provide "COMPILE-CCL" "./binppc/compile-ccl.pfsl") +;;; (load-provide "SOURCE-FILES" "./binppc/source-files.pfsl") + (load-provide "CCL-EXPORT-SYMS" "./binppc/ccl-export-syms.pfsl") + ) + (setq *%fasload-verbose* nil) + ) +(catch :toplevel + (or (find-package "COMMON-LISP-USER") + (make-package "COMMON-LISP-USER" :use '("COMMON-LISP" "CCL") :NICKNAMES '("CL-USER"))) +) + +(defvar *LISTENER-PROCESS-STACKSEG-SIZE* (* 4 16384)) + +(setf (interrupt-level) 0) + +(setq *warn-if-redefine* t) + +(setq *level-1-loaded* t) + +(set-periodic-task-interval 1) + +(do-all-symbols (s) + (setf (symbol-plist s) nil)) + +(progn (%set-toplevel #'toplevel-loop) (save-application "RUNTIME")) + + + + + Index: /branches/new-random/level-1/sysutils.lisp =================================================================== --- /branches/new-random/level-1/sysutils.lisp (revision 13309) +++ /branches/new-random/level-1/sysutils.lisp (revision 13309) @@ -0,0 +1,893 @@ +;;;-*-Mode: LISP; Package: CCL -*- +;;; +;;; Copyright (C) 2009 Clozure Associates +;;; Copyright (C) 1994-2001 Digitool, Inc +;;; This file is part of Clozure CL. +;;; +;;; Clozure CL is licensed under the terms of the Lisp Lesser GNU Public +;;; License , known as the LLGPL and distributed with Clozure CL as the +;;; file "LICENSE". The LLGPL consists of a preamble and the LGPL, +;;; which is distributed with Clozure CL as the file "LGPL". Where these +;;; conflict, the preamble takes precedence. +;;; +;;; Clozure CL is referenced in the preamble as the "LIBRARY." +;;; +;;; The LLGPL is also available online at +;;; http://opensource.franz.com/preamble.html + + +;; sysutils.lisp - things which have outgrown l1-utils + +(in-package "CCL") + +(eval-when (:execute :compile-toplevel) + (require 'level-2) + (require 'optimizers) + (require 'backquote) + (require 'defstruct-macros) + ) + +;;; things might be clearer if this stuff were in l1-typesys? +;;; Translation from type keywords to specific predicates. +(eval-when (:execute :compile-toplevel) + +(defconstant type-pred-pairs + '((array . arrayp) + (atom . atom) + (base-string . base-string-p) + (bignum . bignump) + (bit . bitp) + (bit-vector . bit-vector-p) + (character . characterp) + (compiled-function . compiled-function-p) + (complex . complexp) + (cons . consp) + (double-float . double-float-p) + (fixnum . fixnump) ;not cl + (float . floatp) + (function . functionp) + (hash-table . hash-table-p) + (integer . integerp) + (real . realp) + (keyword . keywordp) + (list . listp) + (long-float . double-float-p) + (nil . false) + (null . null) + (number . numberp) + (package . packagep) + (pathname . pathnamep) + (logical-pathname . logical-pathname-p) + (random-state . random-state-p) + (ratio . ratiop) + (rational . rationalp) + (readtable . readtablep) + (sequence . sequencep) + (short-float . short-float-p) + (signed-byte . integerp) + (simple-array . simple-array-p) + (simple-base-string . simple-base-string-p) + (simple-bit-vector . simple-bit-vector-p) + (simple-string . simple-string-p) + (simple-vector . simple-vector-p) + (single-float . short-float-p) + (stream . streamp) + (string . stringp) + (base-char . base-char-p) + (extended-char . extended-char-p) + (structure-object . structurep) + (symbol . symbolp) + (t . true) + (unsigned-byte . unsigned-byte-p) + (vector . vectorp) + )) + +(defmacro init-type-predicates () + `(dolist (pair ',type-pred-pairs) + (setf (type-predicate (car pair)) (cdr pair)) + (let ((ctype (info-type-builtin (car pair)))) + (if (typep ctype 'numeric-ctype) + (setf (numeric-ctype-predicate ctype) (cdr pair)))))) + +) + +(init-type-predicates) + +(defun unsigned-byte-8-p (n) + (and (fixnump n) + (locally (declare (fixnum n)) + (and + (>= n 0) + (< n #x100))))) + +(defun signed-byte-8-p (n) + (and (fixnump n) + (locally (declare (fixnum n)) + (and + (>= n -128) + (<= n 127))))) + +(defun unsigned-byte-16-p (n) + (and (fixnump n) + (locally (declare (fixnum n)) + (and + (>= n 0) + (< n #x10000))))) + +(defun signed-byte-16-p (n) + (and (fixnump n) + (locally (declare (fixnum n)) + (and + (>= n -32768) + (<= n 32767))))) + +(defun unsigned-byte-32-p (n) + (and (integerp n) + (>= n 0) + (<= n #xffffffff))) + +(defun signed-byte-32-p (n) + (and (integerp n) + (>= n -2147483648) + (<= n 2147483647))) + +(eval-when (:load-toplevel :execute) + (let ((more-pairs + '(((unsigned-byte 8) . unsigned-byte-8-p) + ((signed-byte 8) . signed-byte-8-p) + ((unsigned-byte 16) . unsigned-byte-16-p) + ((signed-byte 16) . signed-byte-16-p) + ((unsigned-byte 32) . unsigned-byte-32-p) + ((signed-byte 32) . signed-byte-32-p)))) + (dolist (pair more-pairs) + (let ((ctype (info-type-builtin (car pair)))) + (if (typep ctype 'numeric-ctype) (setf (numeric-ctype-predicate ctype) (cdr pair)))))) + ) + + +(defun specifier-type-known (type) + (let ((ctype (specifier-type type))) + (if (typep ctype 'unknown-ctype) + (error "Unknown type specifier ~s." type) + (if (and (typep ctype 'numeric-ctype) ; complexp?? + (eq 'integer (numeric-ctype-class ctype)) + (not (numeric-ctype-predicate ctype))) + (setf (numeric-ctype-predicate ctype)(make-numeric-ctype-predicate ctype)))) + ctype)) + + +(defun find-builtin-cell (type &optional (create t)) + (let ((cell (gethash type %builtin-type-cells%))) + (or cell + (when create + (setf (gethash type %builtin-type-cells%) + (cons type (or (info-type-builtin type)(specifier-type-known type)))))))) + + +; for now only called for builtin types or car = unsigned-byte, signed-byte, mod or integer + +(defun builtin-typep (form cell) + (unless (listp cell) + (setq cell (require-type cell 'list))) + (locally (declare (type list cell)) + (let ((ctype (cdr cell)) + (name (car cell))) + (when (not ctype) + (setq ctype (or (info-type-builtin name)(specifier-type-known name))) + (when ctype (setf (gethash (car cell) %builtin-type-cells%) cell)) + (rplacd cell ctype)) + (if ctype + (if (and (typep ctype 'numeric-ctype) + (numeric-ctype-predicate ctype)) + ; doing this inline is a winner - at least if true + (funcall (numeric-ctype-predicate ctype) form) + (%%typep form ctype)) + (typep form name))))) + +#| +(defvar %find-classes% (make-hash-table :test 'eq)) + +(defun find-class-cell (name create?) + (let ((cell (gethash name %find-classes%))) + (or cell + (and create? + (setf (gethash name %find-classes%) (cons name nil)))))) +|# + +;(setq *type-system-initialized* t) + + +;; Type-of, typep, and a bunch of other predicates. + +;;; Data type predicates. + +;;; things might be clearer if this stuff were in l1-typesys? +;;; Translation from type keywords to specific predicates. + + + + +;necessary since standard-char-p, by definition, errors if not passed a char. +(setf (type-predicate 'standard-char) + #'(lambda (form) (and (characterp form) (standard-char-p form)))) + +(defun type-of (form) + "Return the type of OBJECT." + (case form + ((t) 'boolean) + ((0 1) 'bit) + (t + (typecase form + (standard-char 'standard-char) + (keyword 'keyword) + ;; Partition integers so that the negative cases + ;; are SIGNED-BYTE and the positive are UNSIGNED-BYTE + (fixnum + (if (< (the fixnum form) 0) + 'fixnum + '(integer 0 #.target::target-most-positive-fixnum))) + (bignum + (if (< form 0) + 'bignum + '(integer #.(1+ target::target-most-positive-fixnum)))) + ((or array complex) (type-specifier (ctype-of form))) + (single-float 'single-float) + (double-float 'double-float) + (t + (if (eql (typecode form) target::subtag-istruct) + (istruct-type-name form) + (let* ((class (class-of form))) + (or (%class-proper-name class) + class)))))))) + +;;; Create the list-style description of an array. + +;made more specific by fry. slisp used (mod 2) , etc. +;Oh. +; As much fun as this has been, I think it'd be really neat if +; it returned a type specifier. + +(defun describe-array (array) + (if (arrayp array) + (type-specifier + (specifier-type + `(,(if (simple-array-p array) 'simple-array 'array) + ,(array-element-type array) + ,(array-dimensions array)))) + (report-bad-arg array 'array))) + + +;;;; TYPEP and auxiliary functions. + + + +(defun type-specifier-p (form &aux sym) + (cond ((symbolp form) + (or (type-predicate form) + (structure-class-p form) + (%deftype-expander form) + (find-class form nil) + )) + ((consp form) + (setq sym (%car form)) + (or (type-specifier-p sym) + (memq sym '(member satisfies mod)) + (and (memq sym '(and or not)) + (dolist (spec (%cdr form) t) + (unless (type-specifier-p spec) (return nil)))))) + (t (typep form 'class)))) + +(defun built-in-type-p (type) + (if (symbolp type) + (or (type-predicate type) + (let ((class (find-class type nil))) + (and class (typep class 'built-in-class)))) + (and (consp type) + (or (and (memq (%car type) '(and or not)) + (every #'built-in-type-p (%cdr type))) + (memq (%car type) '(array simple-array vector simple-vector + string simple-string bit-vector simple-bit-vector + complex integer mod signed-byte unsigned-byte + rational float short-float single-float + double-float long-float real member)))))) + +(defun typep (object type &optional env) + "Is OBJECT of type TYPE?" + (let* ((pred (if (symbolp type) (type-predicate type)))) + (if pred + (funcall pred object) + (values (%typep object (if env (specifier-type type env) type)))))) + + + +;;; This is like check-type, except it returns the value rather than setf'ing +;;; anything, and so can be done entirely out-of-line. +(defun require-type (arg type) + (multiple-value-bind (win sure) + (ctypep arg (specifier-type type)) + (if (or win (not sure)) + arg + (%kernel-restart $xwrongtype arg type)))) + +;;; Might want to use an inverted mapping instead of (satisfies ccl::obscurely-named) +(defun %require-type (arg predsym) + (if (funcall predsym arg) + arg + (%kernel-restart $xwrongtype arg (type-for-predicate predsym)))) + +(defun %require-type-builtin (arg type-cell) + (if (builtin-typep arg type-cell) + arg + (%kernel-restart $xwrongtype arg (car type-cell)))) + + + +;;; In lieu of an inverted mapping, at least try to find cases involving +;;; builtin numeric types and predicates associated with them. +(defun type-for-predicate (pred) + (or (block find + (maphash #'(lambda (type ctype) (when (and (typep ctype 'numeric-ctype) + (eq (numeric-ctype-predicate ctype) + pred)) + (return-from find type))) + *builtin-type-info*)) + `(satisfies ,pred))) + + + + +; Subtypep. + +(defun subtypep (type1 type2 &optional env) + "Return two values indicating the relationship between type1 and type2. + If values are T and T, type1 definitely is a subtype of type2. + If values are NIL and T, type1 definitely is not a subtype of type2. + If values are NIL and NIL, it couldn't be determined." + (csubtypep (specifier-type type1 env) (specifier-type type2 env))) + +(defun types-disjoint-p (type1 type2 &optional env) + ;; Return true if types are guaranteed to be disjoint, nil if not disjoint or unknown. + (let ((ctype1 (if (typep type1 'ctype) type1 (specifier-type type1 env))) + (ctype2 (if (typep type2 'ctype) type2 (specifier-type type2 env)))) + (eq *empty-type* (type-intersection ctype1 ctype2)))) + + + +(defun preload-all-functions () + nil) + + + ; used by arglist +(defun temp-cons (a b) + (cons a b)) + + + + +(defun copy-into-float (src dest) + (%copy-double-float src dest)) + +(queue-fixup + (defun fmakunbound (name) + "Make NAME have no global function definition." + (let* ((fname (validate-function-name name))) + (remhash fname %structure-refs%) + (%unfhave fname)) + name)) + +(defun frozen-definition-p (name) + (if (symbolp name) + (%ilogbitp $sym_fbit_frozen (%symbol-bits name)))) + +(defun redefine-kernel-function (name) + (when (and *warn-if-redefine-kernel* + (frozen-definition-p name) + (or (lfunp (fboundp name)) + (and (not (consp name)) (macro-function name))) + (or (and (consp name) (neq (car name) 'setf)) + (let ((pkg (symbol-package (if (consp name) (cadr name) name)))) + (or (eq *common-lisp-package* pkg) (eq *ccl-package* pkg))))) + (cerror "Replace the definition of ~S." + "The function ~S is predefined in Clozure CL." name) + (unless (consp name) + (proclaim-inline nil name)))) + +(defun fset (name function) + (setq function (require-type function 'function)) + (when (symbolp name) + (when (special-operator-p name) + (error "Can not redefine a special-form: ~S ." name)) + (when (macro-function name) + (cerror "Redefine the macro ~S as a function" + "The macro ~S is being redefined as a function." name))) +; This lets us redefine %FHAVE. Big fun. + (let ((fhave #'%fhave)) + (redefine-kernel-function name) + (fmakunbound name) + (funcall fhave name function) + function)) + +(defsetf symbol-function fset) +(defsetf fdefinition fset) + +(defun (setf macro-function) (macro-fun name &optional env) + (declare (ignore env)) + (unless (typep macro-fun 'function) + (report-bad-arg macro-fun 'function)) + (if (special-operator-p name) + (error "Can not redefine a special-form: ~S ." name)) + (when (and (fboundp name) (not (macro-function name))) + (warn "The function ~S is being redefined as a macro." name)) + (redefine-kernel-function name) + (fmakunbound name) + (%macro-have name macro-fun) + macro-fun) + +(defun set-macro-function (name def) + (setf (macro-function name) def)) + + + + + +;;; Arrays and vectors, including make-array. + + + + + + + +(defun char (string index) + "Given a string and a non-negative integer index less than the length of + the string, returns the character object representing the character at + that position in the string." + (if (typep string 'simple-string) + (schar (the simple-string string) index) + (if (stringp string) + (multiple-value-bind (data offset) (array-data-and-offset string) + (schar (the simple-string data) (+ index offset))) + (report-bad-arg string 'string)))) + +(defun set-char (string index new-el) + (if (typep string 'simple-string) + (setf (schar string index) new-el) + (if (stringp string) + (multiple-value-bind (data offset) (array-data-and-offset string) + (setf (schar (the simple-string data) (+ index offset)) new-el)) + (report-bad-arg string 'string)))) + +(defun equalp (x y) + "Just like EQUAL, but more liberal in several respects. + Numbers may be of different types, as long as the values are identical + after coercion. Characters may differ in alphabetic case. Vectors and + arrays must have identical dimensions and EQUALP elements, but may differ + in their type restriction. + If one of x or y is a pathname and one is a string with the name of the + pathname then this will return T." + (cond ((eql x y) t) + ((characterp x) (and (characterp y) (eq (char-upcase x) (char-upcase y)))) + ((numberp x) (and (numberp y) (= x y))) + ((consp x) + (and (consp y) + (equalp (car x) (car y)) + (equalp (cdr x) (cdr y)))) + ((pathnamep x) (equal x y)) + ((vectorp x) + (and (vectorp y) + (let ((length (length x))) + (when (eq length (length y)) + (dotimes (i length t) + (declare (fixnum i)) + (let ((x-el (aref x i)) + (y-el (aref y i))) + (unless (or (eq x-el y-el) (equalp x-el y-el)) + (return nil)))))))) + ((arrayp x) + (and (arrayp y) + (let ((rank (array-rank x)) x-el y-el) + (and (eq (array-rank y) rank) + (if (%izerop rank) (equalp (aref x) (aref y)) + (and + (dotimes (i rank t) + (declare (fixnum i)) + (unless (eq (array-dimension x i) + (array-dimension y i)) + (return nil))) + (multiple-value-bind (x0 i) (array-data-and-offset x) + (multiple-value-bind (y0 j) (array-data-and-offset y) + (dotimes (count (array-total-size x) t) + (declare (fixnum count)) + (setq x-el (uvref x0 i) y-el (uvref y0 j)) + (unless (or (eq x-el y-el) (equalp x-el y-el)) + (return nil)) + (setq i (%i+ i 1) j (%i+ j 1))))))))))) + ((and (structurep x) (structurep y)) + (let ((size (uvsize x))) + (and (eq size (uvsize y)) + (dotimes (i size t) + (declare (fixnum i)) + (unless (equalp (uvref x i) (uvref y i)) + (return nil)))))) + ((and (hash-table-p x) (hash-table-p y)) + (%hash-table-equalp x y)) + (t nil))) + + +; The compiler (or some transforms) might want to do something more interesting +; with these, but they have to exist as functions anyhow. + + + +(defun complement (function) + "Return a new function that returns T whenever FUNCTION returns NIL and + NIL whenever FUNCTION returns non-NIL." + (let ((f (coerce-to-function function))) ; keep poor compiler from consing value cell + #'(lambda (&rest args) + (declare (dynamic-extent args)) ; not tail-recursive anyway + (not (apply f args))))) + +; Special variables are evil, but I can't think of a better way to do this. + +(defparameter *outstanding-deferred-warnings* nil) + +(defun call-with-compilation-unit (thunk &key override) + (let* ((*outstanding-deferred-warnings* (%defer-warnings override))) + (multiple-value-prog1 (funcall thunk) + (report-deferred-warnings)))) + +(defun %defer-warnings (override &aux (parent *outstanding-deferred-warnings*)) + (when parent + (ensure-merged-deferred-warnings parent)) + (%istruct 'deferred-warnings + (unless override parent) + nil + (make-hash-table :test #'eq) + nil)) + +(defun ensure-merged-deferred-warnings (parent &aux (last (deferred-warnings.last-file parent))) + (when last + (setf (deferred-warnings.last-file parent) nil) + (let* ((child (car last)) ;; last = (deferred-warnings . file) + (warnings (deferred-warnings.warnings child)) + (defs (deferred-warnings.defs child)) + (parent-defs (deferred-warnings.defs parent)) + (parent-warnings (deferred-warnings.warnings parent))) + (maphash (lambda (key val) (setf (gethash key parent-defs) val)) defs) + (setf (deferred-warnings.warnings parent) (append warnings parent-warnings)))) + parent) + + +;; Should be a generic function but compiler-warning class not defined yet. +(defun verify-deferred-warning (w) + (etypecase w + (undefined-type-reference (verify-deferred-type-warning w)) + (undefined-function-reference (verify-deferred-function-warning w)) + (undefined-keyword-reference (verify-deferred-keyword-warning w)) + (compiler-warning nil))) + +(defun verify-deferred-type-warning (w) + (let* ((args (compiler-warning-args w)) + (typespec (car args)) + (defs (deferred-warnings.defs *outstanding-deferred-warnings*))) + (handler-bind ((parse-unknown-type + (lambda (c) + (let* ((type (parse-unknown-type-specifier c)) + (spec (if (consp type) (car type) type)) + (cell (and (symbolp spec) (gethash spec defs)))) + (unless (and cell (def-info.deftype (cdr cell))) + (when (and args (neq type typespec)) + (setf (car args) type)) + (return-from verify-deferred-type-warning w)) + ;; Else got defined. TODO: Should check syntax, but don't have enuff info. + ;; TODO: should note if got defined as a deftype (rather than class or struct) and + ;; warn about forward reference, akin to the macro warning? Might be missing out on + ;; some intended optimizations. + ))) + (program-error ;; got defined, but turns out it's being used wrong + (lambda (c) + (let ((w2 (make-condition 'invalid-type-warning + :function-name (compiler-warning-function-name w) + :source-note (compiler-warning-source-note w) + :warning-type :invalid-type + :args (list typespec c)))) + (return-from verify-deferred-type-warning w2))))) + (values-specifier-type typespec) + nil))) + + +(defun deferred-function-def (name) + (let* ((defs (deferred-warnings.defs *outstanding-deferred-warnings*)) + (def (or (let ((cell (gethash name defs))) + (and cell (def-info.function-p (cdr cell)) cell)) + (let* ((global (fboundp name))) + (and (typep global 'function) global))))) + def)) + +(defun check-deferred-call-args (w def wargs) + (destructuring-bind (arglist spread-p) wargs + (multiple-value-bind (deftype reason) (nx1-check-call-args def arglist spread-p) + (when (and (eq deftype :deferred-mismatch) + (eq (car reason) :unknown-gf-keywords) + (consp def) + (not (logbitp $lfbits-gfn-bit (def-info.lfbits (cdr def))))) + ;; If didn't have a defgeneric, check against global defn + (let* ((global-def (fboundp (car def))) + (bad-keys (cadr reason))) + (when (typep global-def 'generic-function) + (setq bad-keys + (multiple-value-bind (bits keyvect) (innermost-lfun-bits-keyvect global-def) + (when (and bits + (logbitp $lfbits-keys-bit bits) + (not (logbitp $lfbits-aok-bit bits))) + (loop for key in bad-keys + unless (or (find key keyvect) + (nx1-valid-gf-keyword-p global-def key)) + collect key))))) + (if bad-keys + (setq reason (list* :unknown-gf-keys bad-keys (cddr reason))) + (setq deftype nil)))) + (when deftype + (when (eq deftype :deferred-mismatch) + (setq deftype (if (consp def) :environment-mismatch :global-mismatch))) + (make-condition + 'invalid-arguments + :function-name (compiler-warning-function-name w) + :source-note (compiler-warning-source-note w) + :warning-type deftype + :args (list (car (compiler-warning-args w)) reason arglist spread-p)))))) + +(defun verify-deferred-function-warning (w) + (let* ((args (compiler-warning-args w)) + (wfname (car args)) + (def (deferred-function-def wfname))) + (cond ((null def) w) + ((or (typep def 'function) + (and (consp def) + (def-info.lfbits (cdr def)))) + ;; Check args in call to forward-referenced function. + (when (cdr args) + (check-deferred-call-args w def (cdr args)))) + ((def-info.macro-p (cdr def)) + (let* ((w2 (make-condition + 'macro-used-before-definition + :function-name (compiler-warning-function-name w) + :source-note (compiler-warning-source-note w) + :warning-type :macro-used-before-definition + :args (list (car args))))) + w2))))) + +(defun verify-deferred-keyword-warning (w) + (let* ((args (compiler-warning-args w)) + (wfname (car args)) + (def (deferred-function-def wfname))) + (when def + (check-deferred-call-args w def (cddr args))))) + + +(defun report-deferred-warnings (&optional (file nil)) + (let* ((current (ensure-merged-deferred-warnings *outstanding-deferred-warnings*)) + (parent (deferred-warnings.parent current)) + (warnings (deferred-warnings.warnings current)) + (any nil) + (harsh nil)) + (if parent + (progn + (setf (deferred-warnings.last-file parent) (cons current file)) + (unless file ;; don't defer merge for non-file units. + (ensure-merged-deferred-warnings parent)) + (setq parent t)) + (let* ((file nil) + (init t)) + (dolist (w warnings) + (when (setq w (verify-deferred-warning w)) + (multiple-value-setq (harsh any file) (signal-compiler-warning w init file harsh any)) + (setq init nil))))) + (values any harsh parent))) + +(defun print-nested-name (name-list stream) + (if (null name-list) + (princ "a toplevel form" stream) + (progn + (if (car name-list) + (prin1 (%car name-list) stream) + (princ "an anonymous lambda form" stream)) + (when (%cdr name-list) + (princ " inside " stream) + (print-nested-name (%cdr name-list) stream))))) + +(defparameter *suppress-compiler-warnings* nil) + +(defun signal-compiler-warning (w init-p last-w-file harsh-p any-p &optional eval-p) + (let ((muffled *suppress-compiler-warnings*) + (w-file (compiler-warning-file-name w)) + (s *error-output*)) + (unless muffled + (restart-case (signal w) + (muffle-warning () (setq muffled t)))) + (unless muffled + (setq any-p t) + (unless (typep w 'style-warning) + (unless (eq harsh-p :very) + (setq harsh-p t) + (when (and (typep w 'compiler-warning) + (eq (compiler-warning-warning-type w) :program-error) + (typep (car (compiler-warning-args w)) 'error)) + (setq harsh-p :very)))) + (when (or init-p (not (equalp w-file last-w-file))) + (format s "~&;~A warnings " (if (null eval-p) "Compiler" "Interpreter")) + (if w-file (format s "for ~S :" w-file) (princ ":" s))) + (let* ((indenting-stream (make-indenting-string-output-stream #\; 4))) + (format indenting-stream "~%~a" w) + (format s "~a" (get-output-stream-string indenting-stream)))) + (values harsh-p any-p w-file))) + +;;;; Assorted mumble-P type predicates. +;;;; No functions have been in the kernel for the last year or so. +;;;; (Just thought you'd like to know.) + +(defun sequencep (form) + "Not CL. SLISP Returns T if form is a sequence, NIL otherwise." + (or (listp form) (vectorp form))) + +;;; The following are not defined at user level, but are necessary for +;;; internal use by TYPEP. + +(defun bitp (form) + "Not CL. SLISP" + (or (eq form 0) (eq form 1))) + +(defun unsigned-byte-p (form) + (and (integerp form) (not (< form 0)))) + +;This is false for internal structures. +;;; ---- look at defenv.structures, not defenv.structrefs + +(defun structure-class-p (form &optional env) + (and (symbolp form) + (let ((sd (or (and env + (let ((defenv (definition-environment env))) + (and defenv + (%cdr (assq form (defenv.structures defenv)))))) + (gethash form %defstructs%)))) + (and sd + (null (sd-type sd)) + sd)))) + + + + + +(defun type-keyword-code (type-keyword &optional target) + (let* ((backend (if target (find-backend target) *target-backend*)) + (alist (arch::target-uvector-subtags (backend-target-arch backend))) + (entry (assq type-keyword alist))) + (if entry + (let* ((code (cdr entry))) + (or code (error "Vector type ~s invalid," type-keyword))) + (error "Unknown type-keyword ~s. " type-keyword)))) + + +(defstruct id-map + (vector (make-array 1 :initial-element nil)) + (free 0) + (lock (make-lock))) + +;;; Caller owns the lock on the id-map. +(defun id-map-grow (id-map) + (without-interrupts + (let* ((old-vector (id-map-vector id-map)) + (old-size (length old-vector)) + (new-size (+ old-size old-size)) + (new-vector (make-array new-size))) + (declare (fixnum old-size new-size)) + (dotimes (i old-size) + (setf (svref new-vector i) (svref old-vector i))) + (let* ((limit (1- new-size))) + (declare (fixnum limit)) + (do* ((i old-size (1+ i))) + ((= i limit) (setf (svref new-vector i) nil)) + (declare (fixnum i)) + (setf (svref new-vector i) (the fixnum (1+ i))))) + (setf (id-map-vector id-map) new-vector + (id-map-free id-map) old-size)))) + +;;; Map an object to a small fixnum ID in id-map. +;;; Object can't be NIL or a fixnum itself. +(defun assign-id-map-id (id-map object) + (if (or (null object) (typep object 'fixnum)) + (setq object (require-type object '(not (or null fixnum))))) + (with-lock-grabbed ((id-map-lock id-map)) + (let* ((free (or (id-map-free id-map) (id-map-grow id-map))) + (vector (id-map-vector id-map)) + (newfree (svref vector free))) + (setf (id-map-free id-map) newfree + (svref vector free) object) + free))) + +;;; Referemce the object with id ID in ID-MAP. Leave the object in +;;; the map. +(defun id-map-object (id-map id) + (let* ((object (with-lock-grabbed ((id-map-lock id-map)) + (svref (id-map-vector id-map) id)))) + (if (or (null object) (typep object 'fixnum)) + (error "invalid index ~d for ~s" id id-map) + object))) + +;;; Referemce the object with id ID in ID-MAP. Remove the object from +;;; the map. +(defun id-map-free-object (id-map id) + (with-lock-grabbed ((id-map-lock id-map)) + (let* ((vector (id-map-vector id-map)) + (object (svref vector id))) + (if (or (null object) (typep object 'fixnum)) + (error "invalid index ~d for ~s" id id-map)) + (setf (svref vector id) (id-map-free id-map) + (id-map-free id-map) id) + object))) + +(defun id-map-modify-object (id-map id old-value new-value) + (with-lock-grabbed ((id-map-lock id-map)) + (let* ((vector (id-map-vector id-map)) + (object (svref vector id))) + (if (or (null object) (typep object 'fixnum)) + (error "invalid index ~d for ~s" id id-map)) + (if (eq object old-value) + (setf (svref vector id) new-value))))) + + + + +(setq *type-system-initialized* t) + +;;; Try to map from a CTYPE describing some array/stream +;;; element-type to a target-specific typecode, catching +;;; cases that CTYPE-SUBTYPE missed. + +(defun harder-ctype-subtype (ctype) + (cond ((csubtypep ctype (load-time-value (specifier-type 'bit))) + target::subtag-bit-vector) + ((csubtypep ctype (load-time-value (specifier-type '(unsigned-byte 8)))) + target::subtag-u8-vector) + ((csubtypep ctype (load-time-value (specifier-type '(unsigned-byte 16)))) + target::subtag-u16-vector) + ((csubtypep ctype (load-time-value (specifier-type '(unsigned-byte 32)))) + target::subtag-u32-vector) + #+64-bit-target + ((csubtypep ctype (load-time-value (specifier-type '(unsigned-byte 64)))) + target::subtag-u64-vector) + ((csubtypep ctype (load-time-value (specifier-type '(signed-byte 8)))) + target::subtag-s8-vector) + ((csubtypep ctype (load-time-value (specifier-type '(signed-byte 16)))) + target::subtag-s16-vector) + #+32-bit-target + ((csubtypep ctype (load-time-value (specifier-type `(integer ,target::target-most-negative-fixnum ,target::target-most-positive-fixnum)))) + target::subtag-fixnum-vector) + ((csubtypep ctype (load-time-value (specifier-type '(signed-byte 32)))) + target::subtag-s32-vector) + #+64-bit-target + ((csubtypep ctype (load-time-value (specifier-type `(integer ,target::target-most-negative-fixnum ,target::target-most-positive-fixnum)))) + target::subtag-fixnum-vector) + #+64-bit-target + ((csubtypep ctype (load-time-value (specifier-type '(signed-byte 64)))) + target::subtag-s64-vector) + (t target::subtag-simple-vector))) + + +#+count-gf-calls +(progn +;;; Call-counting for generic functions. We overload the +;;; (previously unused +(defmethod generic-function-call-count ((gf generic-function)) + (gf.hash gf)) + + +(defun (setf generic-function-call-count) (count gf) + (setf (gf.hash gf) (require-type count 'fixnum))) + +(defun clear-all-generic-function-call-counts () + (dolist (gf (population.data %all-gfs%)) + (setf (gf.hash gf) 0))) +);#+count-gf-calls + + Index: /branches/new-random/level-1/version.lisp =================================================================== --- /branches/new-random/level-1/version.lisp (revision 13309) +++ /branches/new-random/level-1/version.lisp (revision 13309) @@ -0,0 +1,41 @@ +;;;-*-Mode: LISP; Package: CCL -*- +;;; +;;; Copyright (C) 2009 Clozure Associates +;;; Copyright (C) 1994-2001 Digitool, Inc +;;; This file is part of Clozure CL. +;;; +;;; Clozure CL is licensed under the terms of the Lisp Lesser GNU Public +;;; License , known as the LLGPL and distributed with Clozure CL as the +;;; file "LICENSE". The LLGPL consists of a preamble and the LGPL, +;;; which is distributed with Clozure CL as the file "LGPL". Where these +;;; conflict, the preamble takes precedence. +;;; +;;; Clozure CL is referenced in the preamble as the "LIBRARY." +;;; +;;; The LLGPL is also available online at +;;; http://opensource.franz.com/preamble.html + +(in-package "CCL") + +(defparameter *openmcl-major-version* 1) +(defparameter *openmcl-minor-version* 5) +(defparameter *openmcl-revision* "dev") +;;; May be set by xload-level-0 +(defvar *openmcl-svn-revision* nil) +(defparameter *openmcl-dev-level* nil) + +(defparameter *openmcl-version* (format nil "~d.~d~@[-~a~]~@[-r~a~] ~@[+~s~] (~@[~A: ~]~~A)" + *openmcl-major-version* + *openmcl-minor-version* + (unless (null *openmcl-revision*) + *openmcl-revision*) + (if (and (typep *openmcl-svn-revision* 'string) + (> (length *openmcl-svn-revision*) 0)) + *openmcl-svn-revision*) + *optional-features* + *openmcl-dev-level*)) + + + + +;;; end Index: /branches/new-random/level-1/x86-callback-support.lisp =================================================================== --- /branches/new-random/level-1/x86-callback-support.lisp (revision 13309) +++ /branches/new-random/level-1/x86-callback-support.lisp (revision 13309) @@ -0,0 +1,76 @@ +;;; +;;; Copyright (C) 2005-2009 Clozure Associates and contributors +;;; This file is part of Clozure CL. +;;; +;;; Clozure CL is licensed under the terms of the Lisp Lesser GNU Public +;;; License , known as the LLGPL and distributed with Clozure CL as the +;;; file "LICENSE". The LLGPL consists of a preamble and the LGPL, +;;; which is distributed with Clozure CL as the file "LGPL". Where these +;;; conflict, the preamble takes precedence. +;;; +;;; Clozure CL is referenced in the preamble as the "LIBRARY." +;;; +;;; The LLGPL is also available online at +;;; http://opensource.franz.com/preamble.html + + +(in-package "CCL") + + +#+x8664-target +(defun make-callback-trampoline (index &optional info) + (declare (ignore info)) + (let* ((p (%allocate-callback-pointer 16)) + (addr #.(subprim-name->offset '.SPcallback))) + (setf (%get-unsigned-byte p 0) #x41 ; movl $n,%r11d + (%get-unsigned-byte p 1) #xc7 + (%get-unsigned-byte p 2) #xc3 + (%get-unsigned-byte p 3) (ldb (byte 8 0) index) + (%get-unsigned-byte p 4) (ldb (byte 8 8) index) + (%get-unsigned-byte p 5) (ldb (byte 8 16) index) + (%get-unsigned-byte p 6) (ldb (byte 8 24) index) + (%get-unsigned-byte p 7) #xff ; jmp * + (%get-unsigned-byte p 8) #x24 + (%get-unsigned-byte p 9) #x25 + (%get-unsigned-byte p 10) (ldb (byte 8 0) addr) + (%get-unsigned-byte p 11) (ldb (byte 8 8) addr) + (%get-unsigned-byte p 12) (ldb (byte 8 16) addr) + (%get-unsigned-byte p 13) (ldb (byte 8 24) addr)) + p)) + +#+x8632-target +(defun make-callback-trampoline (index &optional info) + (let* ((p (%allocate-callback-pointer 12)) + (addr #.(subprim-name->offset '.SPcallback))) + ;; If the optional info parameter is supplied, it will contain + ;; some stuff in bits 23 through 31. + ;; + ;; If bit 23 is set, that indicates that the caller will pass a + ;; "hidden" argument which is a pointer to appropriate storage for + ;; holding a returned structure. .SPcallback will have to discard + ;; this extra argument upon return. + ;; + ;; The high 8 bits denote the number of words that .SPcallback + ;; will have to discard upon return (used for _stdcall on + ;; Windows). Bit 23 won't be set in this case: we will have + ;; already added in the extra word to discard if that's necessary. + ;; + ;; These bits are be packed into the value that .SPcallback + ;; receives in %eax. Bits 0 through 22 are the callback index. + (if info + (setf (ldb (byte 23 0) info) index) + (setq info index)) + (setf (%get-unsigned-byte p 0) #xb8 ; movl $n,%eax + (%get-unsigned-byte p 1) (ldb (byte 8 0) info) + (%get-unsigned-byte p 2) (ldb (byte 8 8) info) + (%get-unsigned-byte p 3) (ldb (byte 8 16) info) + (%get-unsigned-byte p 4) (ldb (byte 8 24) info) + (%get-unsigned-byte p 5) #xff ; jmp * + (%get-unsigned-byte p 6) #x24 + (%get-unsigned-byte p 7) #x25 + (%get-unsigned-byte p 8) (ldb (byte 8 0) addr) + (%get-unsigned-byte p 9) (ldb (byte 8 8) addr) + (%get-unsigned-byte p 10) (ldb (byte 8 16) addr) + (%get-unsigned-byte p 11) (ldb (byte 8 24) addr)) + p)) + Index: /branches/new-random/level-1/x86-error-signal.lisp =================================================================== --- /branches/new-random/level-1/x86-error-signal.lisp (revision 13309) +++ /branches/new-random/level-1/x86-error-signal.lisp (revision 13309) @@ -0,0 +1,445 @@ +;;; x86-trap-support +;;; +;;; Copyright (C) 2005-2009 Clozure Associates and contributors +;;; This file is part of Clozure CL. +;;; +;;; Clozure CL is licensed under the terms of the Lisp Lesser GNU Public +;;; License , known as the LLGPL and distributed with Clozure CL as the +;;; file "LICENSE". The LLGPL consists of a preamble and the LGPL, +;;; which is distributed with Clozure CL as the file "LGPL". Where these +;;; conflict, the preamble takes precedence. +;;; +;;; Clozure CL is referenced in the preamble as the "LIBRARY." +;;; +;;; The LLGPL is also available online at +;;; http://opensource.franz.com/preamble.html + + +(in-package "CCL") + +#+x8664-target +(defun xp-argument-count (xp) + (ldb (byte (- 16 x8664::fixnumshift) 0) + (encoded-gpr-lisp xp x8664::nargs.q))) + +#+x8632-target +(defun xp-argument-count (xp) + (encoded-gpr-lisp xp target::nargs)) + +#+x8664-target +(defun xp-argument-list (xp) + (let ((nargs (xp-argument-count xp)) + (arg-x (encoded-gpr-lisp xp x8664::arg_x)) + (arg-y (encoded-gpr-lisp xp x8664::arg_y)) + (arg-z (encoded-gpr-lisp xp x8664::arg_z))) + (cond ((eql nargs 0) nil) + ((eql nargs 1) (list arg-z)) + ((eql nargs 2) (list arg-y arg-z)) + (t + (let ((args (list arg-x arg-y arg-z))) + (if (eql nargs 3) + args + (let ((sp (%inc-ptr (encoded-gpr-macptr xp x8664::rsp) + (+ x8664::node-size x8664::xcf.size)))) + (dotimes (i (- nargs 3)) + (push (%get-object sp (* i x8664::node-size)) args)) + args))))))) + +#+x8632-target +(defun xp-argument-list (xp) + (let ((nargs (xp-argument-count xp)) + (arg-y (encoded-gpr-lisp xp x8632::arg_y)) + (arg-z (encoded-gpr-lisp xp x8632::arg_z))) + (cond ((eql nargs 0) nil) + ((eql nargs 1) (list arg-z)) + (t + (let ((args (list arg-y arg-z))) + (if (eql nargs 2) + args + (let ((sp (%inc-ptr (encoded-gpr-macptr xp x8632::ebp) + (+ x8632::node-size x8632::xcf.size)))) + (dotimes (i (- nargs 2)) + (push (%get-object sp (* i x8632::node-size)) args)) + args))))))) + +;;; Making this be continuable is hard, because of the xcf on the +;;; stack and the way that the kernel saves/restores rsp and rbp +;;; before calling out. If we get around those problems, then +;;; we have to also deal with the fact that the return address +;;; is on the stack. Easiest to make the kernel deal with that, +;;; and just set %fn to the function that returns the values +;;; returned by the (newly defined) function and %arg_z to +;;; that list of values. +(defun handle-udf-call (xp frame-ptr) + (let* ((args (xp-argument-list xp)) + (values (multiple-value-list + (%kernel-restart-internal + $xudfcall + (list (maybe-setf-name (encoded-gpr-lisp xp target::fname)) args) + frame-ptr))) + (f #'(lambda (values) (apply #'values values)))) + (setf (encoded-gpr-lisp xp target::arg_z) values + (encoded-gpr-lisp xp target::fn) f))) + +#+x8664-target +(defcallback %xerr-disp (:address xp :address xcf :int) + (with-error-reentry-detection + (let* ((frame-ptr (macptr->fixnum xcf)) + (fn (%get-object xcf x8664::xcf.nominal-function)) + (op0 (%get-xcf-byte xcf 0)) + (op1 (%get-xcf-byte xcf 1)) + (op2 (%get-xcf-byte xcf 2))) + (declare (type (unsigned-byte 8) op0 op1 op2)) + (let* ((skip 2)) + (if (and (= op0 #xcd) + (>= op1 #x70)) + (cond ((< op1 #x90) + (setq skip (%check-anchored-uuo xcf 3)) + (setq *error-reentry-count* 0) + (setf (encoded-gpr-lisp xp (ldb (byte 4 0) op1)) + (%slot-unbound-trap + (encoded-gpr-lisp xp (ldb (byte 4 4) op2)) + (encoded-gpr-lisp xp (ldb (byte 4 0) op2)) + frame-ptr))) + ((= op1 #x90) + (setq skip (%check-anchored-uuo xcf 3)) + (setf (encoded-gpr-lisp xp (ldb (byte 4 4) op2)) + (%kernel-restart-internal $xvunbnd + (list + (encoded-gpr-lisp + xp + (ldb (byte 4 0) op2))) + frame-ptr))) + ((< op1 #xa0) + (setq skip (%check-anchored-uuo xcf 2)) + ;; #x9x, x>0 - register X is a symbol. It's unbound, + ;; but we don't have enough info to offer USE-VALUE, + ;; STORE-VALUE, or CONTINUE restarts. + (%error (make-condition 'unbound-variable + :name + (encoded-gpr-lisp + xp + (ldb (byte 4 0) op1))) + () + frame-ptr)) + ((< op1 #xb0) + (setq skip (%check-anchored-uuo xcf 2)) + (%err-disp-internal $xfunbnd + (list (encoded-gpr-lisp + xp + (ldb (byte 4 0) op1))) + frame-ptr)) + ((< op1 #xc0) + (setq skip (%check-anchored-uuo xcf 3)) + (%err-disp-internal + #.(car (rassoc 'type-error *kernel-simple-error-classes*)) + (list (encoded-gpr-lisp + xp + (ldb (byte 4 0) op1)) + (logandc2 op2 arch::error-type-error)) + frame-ptr)) + ((= op1 #xc0) + (setq skip (%check-anchored-uuo xcf 2)) + (%error 'too-few-arguments + (list :nargs (xp-argument-count xp) + :fn fn) + frame-ptr)) + ((= op1 #xc1) + (setq skip (%check-anchored-uuo xcf 2)) + (%error 'too-many-arguments + (list :nargs (xp-argument-count xp) + :fn fn) + frame-ptr)) + ((= op1 #xc2) + (setq skip (%check-anchored-uuo xcf 2)) + (let* ((flags (xp-flags-register xp)) + (nargs (xp-argument-count xp)) + (carry-bit (logbitp x86::x86-carry-flag-bit flags))) + (if carry-bit + (%error 'too-few-arguments + (list :nargs nargs + :fn fn) + frame-ptr) + (%error 'too-many-arguments + (list :nargs nargs + :fn fn) + frame-ptr)))) + ((= op1 #xc3) ;array rank + (setq skip (%check-anchored-uuo xcf 3)) + (%err-disp-internal $XNDIMS + (list (encoded-gpr-lisp xp (ldb (byte 4 4) op2)) + (encoded-gpr-lisp xp (ldb (byte 4 0) op2))) + frame-ptr)) + ((= op1 #xc6) + (setq skip (%check-anchored-uuo xcf 2)) + (%error (make-condition 'type-error + :datum (encoded-gpr-lisp xp x8664::temp0) + :expected-type '(or symbol function) + :format-control + "~S is not of type ~S, and can't be FUNCALLed or APPLYed") + nil frame-ptr)) + ((= op1 #xc7) + (handle-udf-call xp frame-ptr) + (setq skip 0)) + ((or (= op1 #xc8) (= op1 #xcb)) + (setq skip (%check-anchored-uuo xcf 3)) + (%error (%rsc-string $xarroob) + (list (encoded-gpr-lisp xp (ldb (byte 4 4) op2)) + (encoded-gpr-lisp xp (ldb (byte 4 0) op2))) + frame-ptr)) + ((= op1 #xc9) + (setq skip (%check-anchored-uuo xcf 2)) + (%err-disp-internal $xnotfun + (list (encoded-gpr-lisp xp x8664::temp0)) + frame-ptr)) + ;; #xca = uuo-error-debug-trap + ((= op1 #xcc) + ;; external entry point or foreign variable + (setq skip (%check-anchored-uuo xcf 3)) + (let* ((eep-or-fv (encoded-gpr-lisp xp (ldb (byte 4 4) op2)))) + (etypecase eep-or-fv + (external-entry-point + (resolve-eep eep-or-fv) + (setf (encoded-gpr-lisp xp (ldb (byte 4 0) op2)) + (eep.address eep-or-fv))) + (foreign-variable + (resolve-foreign-variable eep-or-fv) + (setf (encoded-gpr-lisp xp (ldb (byte 4 0) op2)) + (fv.addr eep-or-fv)))))) + ((< op1 #xe0) + (setq skip (%check-anchored-uuo xcf 3)) + (if (= op2 x8664::subtag-catch-frame) + (%error (make-condition 'cant-throw-error + :tag (encoded-gpr-lisp + xp + (ldb (byte 4 0) op1))) + nil frame-ptr) + (let* ((typename + (cond ((= op2 x8664::tag-fixnum) 'fixnum) + ((= op2 x8664::tag-single-float) 'single-float) + ((= op2 x8664::subtag-character) 'character) + ((= op2 x8664::fulltag-cons) 'cons) + ((= op2 x8664::tag-misc) 'uvector) + ((= op2 x8664::fulltag-symbol) 'symbol) + ((= op2 x8664::fulltag-function) 'function) + (t (let* ((class (logand op2 x8664::fulltagmask)) + (high4 (ash op2 (- x8664::ntagbits)))) + (cond ((= class x8664::fulltag-nodeheader-0) + (svref *nodeheader-0-types* high4)) + ((= class x8664::fulltag-nodeheader-1) + (svref *nodeheader-1-types* high4)) + ((= class x8664::fulltag-immheader-0) + (svref *immheader-0-types* high4)) + ((= class x8664::fulltag-immheader-1) + (svref *immheader-1-types* high4)) + ((= class x8664::fulltag-immheader-2) + (svref *immheader-2-types* high4)) + (t (list 'bogus op2)))))))) + (%error (make-condition 'type-error + :datum (encoded-gpr-lisp + xp + (ldb (byte 4 0) op1)) + :expected-type typename) + nil + frame-ptr)))) + ((< op1 #xf0) + (setq skip (%check-anchored-uuo xcf 2)) + (%error (make-condition 'type-error + :datum (encoded-gpr-lisp + xp + (ldb (byte 4 0) op1)) + :expected-type 'list) + nil + frame-ptr)) + (t + (setq skip (%check-anchored-uuo xcf 2)) + (%error (make-condition 'type-error + :datum (encoded-gpr-lisp + xp + (ldb (byte 4 0) op1)) + :expected-type 'fixnum) + nil + frame-ptr))) + (%error "Unknown trap: #x~x~%xp=~s" + (list (list op0 op1 op2) xp) + frame-ptr)) + skip)))) + +;;; lots of duplicated code here +#+x8632-target +(defcallback %xerr-disp (:address xp :address xcf :int) + (with-error-reentry-detection + (let* ((frame-ptr (macptr->fixnum xcf)) + (fn (%get-object xcf x8632::xcf.nominal-function)) + (op0 (%get-xcf-byte xcf 0)) + (op1 (%get-xcf-byte xcf 1)) + (op2 (%get-xcf-byte xcf 2))) + (declare (type (unsigned-byte 8) op0 op1 op2)) + (let* ((skip 2)) + (if (and (= op0 #xcd) + (>= op1 #x70)) + (cond ((< op1 #x90) + (setq skip (%check-anchored-uuo xcf 3)) + (setq *error-reentry-count* 0) + (setf (encoded-gpr-lisp xp (ldb (byte 3 0) op1)) + (%slot-unbound-trap + (encoded-gpr-lisp xp (ldb (byte 4 4) op2)) + (encoded-gpr-lisp xp (ldb (byte 4 0) op2)) + frame-ptr))) + ((= op1 #x90) + (setq skip (%check-anchored-uuo xcf 3)) + (setf (encoded-gpr-lisp + xp + (ldb (byte 3 0) op2)) + (%kernel-restart-internal $xvunbnd + (list + (encoded-gpr-lisp + xp + (ldb (byte 3 0) op2))) + frame-ptr))) + ((< op1 #xa0) + (setq skip (%check-anchored-uuo xcf 2)) + ;; #x9x, x>- - register X is a symbol. It's unbound, + ;; but we don't have enough info to offer USE-VALUE, + ;; STORE-VALUE, or CONTINUE restart + (%error (make-condition 'unbound-variable + :name + (encoded-gpr-lisp + xp + (ldb (byte 3 0) op1))) + () + frame-ptr)) + ((< op1 #xb0) + (setq skip (%check-anchored-uuo xcf 2)) + (%err-disp-internal $xfunbnd + (list (encoded-gpr-lisp + xp + (ldb (byte 3 0) op1))) + frame-ptr)) + ((< op1 #xc0) + (setq skip (%check-anchored-uuo xcf 3)) + (%err-disp-internal + #.(car (rassoc 'type-error *kernel-simple-error-classes*)) + (list (encoded-gpr-lisp + xp + (ldb (byte 3 0) op1)) + (logandc2 op2 arch::error-type-error)) + frame-ptr)) + ((= op1 #xc0) + (setq skip (%check-anchored-uuo xcf 2)) + (%error 'too-few-arguments + (list :nargs (xp-argument-count xp) + :fn fn) + frame-ptr)) + ((= op1 #xc1) + (setq skip (%check-anchored-uuo xcf 2)) + (%error 'too-many-arguments + (list :nargs (xp-argument-count xp) + :fn fn) + frame-ptr)) + ((= op1 #xc2) + (setq skip (%check-anchored-uuo xcf 2)) + (let* ((flags (xp-flags-register xp)) + (nargs (xp-argument-count xp)) + (carry-bit (logbitp x86::x86-carry-flag-bit flags))) + (if carry-bit + (%error 'too-few-arguments + (list :nargs nargs + :fn fn) + frame-ptr) + (%error 'too-many-arguments + (list :nargs nargs + :fn fn) + frame-ptr)))) + ((= op1 #xc3) ;array rank + (setq skip (%check-anchored-uuo xcf 3)) + (%err-disp-internal $XNDIMS + (list (encoded-gpr-lisp xp (ldb (byte 4 4) op2)) + (encoded-gpr-lisp xp (ldb (byte 4 0) op2))) + frame-ptr)) + ((= op1 #xc6) + (setq skip (%check-anchored-uuo xcf 2)) + (%error (make-condition 'type-error + :datum (encoded-gpr-lisp xp x8632::temp0) + :expected-type '(or symbol function) + :format-control + "~S is not of type ~S, and can't be FUNCALLed or APPLYed") + nil frame-ptr)) + ((= op1 #xc7) + (handle-udf-call xp frame-ptr) + (setq skip 0)) + ((or (= op1 #xc8) (= op1 #xcb)) + (setq skip (%check-anchored-uuo xcf 3)) + (%error (%rsc-string $xarroob) + (list (encoded-gpr-lisp xp (ldb (byte 4 4) op2)) + (encoded-gpr-lisp xp (ldb (byte 4 0) op2))) + frame-ptr)) + ((= op1 #xc9) + (setq skip (%check-anchored-uuo xcf 2)) + (%err-disp-internal $xnotfun + (list (encoded-gpr-lisp xp x8632::temp0)) + frame-ptr)) + ;; #xca = uuo-error-debug-trap + ((= op1 #xcc) + ;; external entry point or foreign variable + (setq skip (%check-anchored-uuo xcf 3)) + (let* ((eep-or-fv (encoded-gpr-lisp xp (ldb (byte 4 4) op2)))) + (etypecase eep-or-fv + (external-entry-point + (resolve-eep eep-or-fv) + (setf (encoded-gpr-lisp xp (ldb (byte 4 0) op2)) + (eep.address eep-or-fv))) + (foreign-variable + (resolve-foreign-variable eep-or-fv) + (setf (encoded-gpr-lisp xp (ldb (byte 4 0) op2)) + (fv.addr eep-or-fv)))))) + ((< op1 #xe0) + (setq skip (%check-anchored-uuo xcf 3)) + (if (= op2 x8632::subtag-catch-frame) + (%error (make-condition 'cant-throw-error + :tag (encoded-gpr-lisp + xp + (ldb (byte 3 0) op1))) + nil frame-ptr) + (let* ((typename + (cond ((= op2 x8632::tag-fixnum) 'fixnum) + ((= op2 x8632::subtag-character) 'character) + ((= op2 x8632::fulltag-cons) 'cons) + ((= op2 x8632::tag-misc) 'uvector) + (t (let* ((class (logand op2 x8632::fulltagmask)) + (high5 (ash op2 (- x8632::ntagbits)))) + (cond ((= class x8632::fulltag-nodeheader) + (svref *nodeheader-types* high5)) + ((= class x8632::fulltag-immheader) + (svref *immheader-types* high5)) + (t (list 'bogus op2)))))))) + (%error (make-condition 'type-error + :datum (encoded-gpr-lisp + xp + (ldb (byte 3 0) op1)) + :expected-type typename) + nil + frame-ptr)))) + ((< op1 #xf0) + (setq skip (%check-anchored-uuo xcf 2)) + (%error (make-condition 'type-error + :datum (encoded-gpr-lisp + xp + (ldb (byte 3 0) op1)) + :expected-type 'list) + nil + frame-ptr)) + (t + (setq skip (%check-anchored-uuo xcf 2)) + (%error (make-condition 'type-error + :datum (encoded-gpr-lisp + xp + (ldb (byte 3 0) op1)) + :expected-type 'fixnum) + nil + frame-ptr))) + (%error "Unknown trap: #x~x~%xp=~s" + (list (list op0 op1 op2) xp) + frame-ptr)) + skip)))) + Index: /branches/new-random/level-1/x86-threads-utils.lisp =================================================================== --- /branches/new-random/level-1/x86-threads-utils.lisp (revision 13309) +++ /branches/new-random/level-1/x86-threads-utils.lisp (revision 13309) @@ -0,0 +1,208 @@ +;;; x86-trap-support +;;; +;;; Copyright (C) 2005-2009 Clozure Associates and contributors +;;; This file is part of Clozure CL. +;;; +;;; Clozure CL is licensed under the terms of the Lisp Lesser GNU Public +;;; License , known as the LLGPL and distributed with Clozure CL as the +;;; file "LICENSE". The LLGPL consists of a preamble and the LGPL, +;;; which is distributed with Clozure CL as the file "LGPL". Where these +;;; conflict, the preamble takes precedence. +;;; +;;; Clozure CL is referenced in the preamble as the "LIBRARY." +;;; +;;; The LLGPL is also available online at +;;; http://opensource.franz.com/preamble.html + + +(in-package "CCL") + + +(defun %frame-backlink (p &optional context) + (declare (ignore context)) + (cond ((fixnump p) (%%frame-backlink p)) + (t (error "~s is not a valid stack frame" p)))) + +(defun bottom-of-stack-p (p context) + (and (fixnump p) + (locally (declare (fixnum p)) + (let* ((tcr (if context (bt.tcr context) (%current-tcr))) + (vs-area (%fixnum-ref tcr target::tcr.vs-area))) + (not (%ptr-in-area-p p vs-area)))))) + + +(defun lisp-frame-p (p context) + (declare (fixnum p)) + (let ((next-frame (%frame-backlink p context))) + (declare (fixnum next-frame)) + (if (bottom-of-stack-p next-frame context) + (values nil t) + (values t nil)))) + + +(defun catch-frame-sp (catch) + (uvref catch + #+x8632-target x8632::catch-frame.ebp-cell + #+x8664-target x8664::catch-frame.rbp-cell)) + +;;; Sure would be nice to have &optional in defppclapfunction arglists +;;; Sure would be nice not to do this at runtime. + +(let ((bits (lfun-bits #'(lambda (x &optional y) (declare (ignore x y)))))) + (lfun-bits #'%fixnum-ref + (dpb (ldb $lfbits-numreq bits) + $lfbits-numreq + (dpb (ldb $lfbits-numopt bits) + $lfbits-numopt + (lfun-bits #'%fixnum-ref))))) + +(let ((bits (lfun-bits #'(lambda (x &optional y) (declare (ignore x y)))))) + (lfun-bits #'%fixnum-ref-natural + (dpb (ldb $lfbits-numreq bits) + $lfbits-numreq + (dpb (ldb $lfbits-numopt bits) + $lfbits-numopt + (lfun-bits #'%fixnum-ref-natural))))) + + +;;; Sure would be nice to have &optional in defppclapfunction arglists +;;; Sure would be nice not to do this at runtime. + +(let ((bits (lfun-bits #'(lambda (x &optional y) (declare (ignore x y)))))) + (lfun-bits #'%fixnum-ref + (dpb (ldb $lfbits-numreq bits) + $lfbits-numreq + (dpb (ldb $lfbits-numopt bits) + $lfbits-numopt + (lfun-bits #'%fixnum-ref))))) + +(let ((bits (lfun-bits #'(lambda (x &optional y) (declare (ignore x y)))))) + (lfun-bits #'%fixnum-ref-natural + (dpb (ldb $lfbits-numreq bits) + $lfbits-numreq + (dpb (ldb $lfbits-numopt bits) + $lfbits-numopt + (lfun-bits #'%fixnum-ref-natural))))) + +(let ((bits (lfun-bits #'(lambda (x y &optional z) (declare (ignore x y z)))))) + (lfun-bits #'%fixnum-set + (dpb (ldb $lfbits-numreq bits) + $lfbits-numreq + (dpb (ldb $lfbits-numopt bits) + $lfbits-numopt + (lfun-bits #'%fixnum-set))))) + +(let ((bits (lfun-bits #'(lambda (x y &optional z) (declare (ignore x y z)))))) + (lfun-bits #'%fixnum-set-natural + (dpb (ldb $lfbits-numreq bits) + $lfbits-numreq + (dpb (ldb $lfbits-numopt bits) + $lfbits-numopt + (lfun-bits #'%fixnum-set-natural))))) + + +#+x8632-target +(defun valid-subtag-p (subtag) + (declare (fixnum subtag)) + (let* ((tagval (ldb (byte (- x8632::num-subtag-bits x8632::ntagbits) x8632::ntagbits) subtag))) + (declare (fixnum tagval)) + (case (logand subtag x8632::fulltagmask) + (#. x8632::fulltag-immheader (not (eq (%svref *immheader-types* tagval) 'bogus))) + (#. x8632::fulltag-nodeheader (not (eq (%svref *nodeheader-types* tagval) 'bogus))) + (t nil)))) + +#+x8664-target +(defun valid-subtag-p (subtag) + (declare (fixnum subtag)) + (let* ((tagval (logand x8664::fulltagmask subtag)) + (high4 (ash subtag (- x8664::ntagbits)))) + (declare (fixnum tagval high4)) + (not (eq 'bogus + (case tagval + (#.x8664::fulltag-immheader-0 + (%svref *immheader-0-types* high4)) + (#.x8664::fulltag-immheader-1 + (%svref *immheader-1-types* high4)) + (#.x8664::fulltag-immheader-2 + (%svref *immheader-2-types* high4)) + (#.x8664::fulltag-nodeheader-0 + (%svref *nodeheader-0-types* high4)) + (#.x8664::fulltag-nodeheader-1 + (%svref *nodeheader-1-types* high4)) + (t 'bogus)))))) + +#+x8632-target +(defun valid-header-p (thing) + (let* ((fulltag (fulltag thing))) + (declare (fixnum fulltag)) + (case fulltag + (#.x8632::fulltag-misc (valid-subtag-p (typecode thing))) + ((#.x8632::fulltag-immheader #.x8632::fulltag-nodeheader) nil) + (t t)))) + +#+x8664-target +(defun valid-header-p (thing) + (let* ((fulltag (fulltag thing))) + (declare (fixnum fulltag)) + (case fulltag + ((#.x8664::fulltag-even-fixnum + #.x8664::fulltag-odd-fixnum + #.x8664::fulltag-imm-0 + #.x8664::fulltag-imm-1) + t) + (#.x8664::fulltag-function + (= x8664::subtag-function (typecode (%function-to-function-vector thing)))) + (#.x8664::fulltag-symbol + (= x8664::subtag-symbol (typecode (%symptr->symvector thing)))) + (#.x8664::fulltag-misc + (valid-subtag-p (typecode thing))) + ((#.x8664::fulltag-tra-0 + #.x8664::fulltag-tra-1) + (let* ((disp (%return-address-offset thing))) + (and disp + (let* ((f (%return-address-function thing))) + (and (typep f 'function) (valid-header-p f)))))) + (#.x8664::fulltag-cons t) + (#.x8664::fulltag-nil (null thing)) + (t nil)))) + +#+x8632-target +(defun bogus-thing-p (x) + (when x + (or (not (valid-header-p x)) + (let ((tag (lisptag x)) + (fulltag (fulltag x))) + (unless (or (eql tag x8632::tag-fixnum) + (eql tag x8632::tag-imm) + (in-any-consing-area-p x) + (temporary-cons-p x) + (and (or (typep x 'function) + (typep x 'gvector)) + (on-any-tsp-stack x)) + (and (eql fulltag x8632::fulltag-tra) + (%return-address-offset x)) + (and (typep x 'ivector) + (on-any-csp-stack x)) + (%heap-ivector-p x)) + t))))) + +#+x8664-target +(defun bogus-thing-p (x) + (when x + (or (not (valid-header-p x)) + (let* ((tag (lisptag x))) + (unless (or (eql tag x8664::tag-fixnum) + (eql tag x8664::tag-imm-0) + (eql tag x8664::tag-imm-1) + (in-any-consing-area-p x) + (temporary-cons-p x) + (and (or (typep x 'function) + (typep x 'gvector)) + (on-any-tsp-stack x)) + (and (eql tag x8664::tag-tra) + (eql 0 (%return-address-offset x))) + (and (typep x 'ivector) + (on-any-csp-stack x)) + (%heap-ivector-p x)) + t))))) + Index: /branches/new-random/level-1/x86-trap-support.lisp =================================================================== --- /branches/new-random/level-1/x86-trap-support.lisp (revision 13309) +++ /branches/new-random/level-1/x86-trap-support.lisp (revision 13309) @@ -0,0 +1,507 @@ +;;; x86-trap-support +;;; +;;; Copyright (C) 2005-2009 Clozure Associates and contributors +;;; This file is part of Clozure CL. +;;; +;;; Clozure CL is licensed under the terms of the Lisp Lesser GNU Public +;;; License , known as the LLGPL and distributed with Clozure CL as the +;;; file "LICENSE". The LLGPL consists of a preamble and the LGPL, +;;; which is distributed with Clozure CL as the file "LGPL". Where these +;;; conflict, the preamble takes precedence. +;;; +;;; Clozure CL is referenced in the preamble as the "LIBRARY." +;;; +;;; The LLGPL is also available online at +;;; http://opensource.franz.com/preamble.html + + +(in-package "CCL") + +;;; The order in which GPRs appear in an exception context generally +;;; has nothing to do with how they're encoded in instructions/uuos, +;;; and is OS-dependent. + +#+linuxx8664-target +(progn + (defconstant gp-regs-offset (+ (get-field-offset :ucontext.uc_mcontext) + (get-field-offset :mcontext_t.gregs))) + (defmacro xp-gp-regs (xp) xp) + (defconstant flags-register-offset #$REG_EFL) + (defconstant rip-register-offset #$REG_RIP) + (defun xp-mxcsr (xp) + (pref xp :ucontext.uc_mcontext.fpregs.mxcsr)) + (defparameter *encoded-gpr-to-indexed-gpr* + #(13 ;rax + 14 ;rcx + 12 ;rdx + 11 ;rbx + 15 ;rsp + 10 ;rbp + 9 ;rsi + 8 ;rdi + 0 ;r8 + 1 ;r9 + 2 ;r10 + 3 ;r11 + 4 ;r12 + 5 ;r13 + 6 ;r14 + 7 ;r15 + ))) + +#+freebsdx8664-target +(progn + (defconstant gp-regs-offset (get-field-offset :ucontext_t.uc_mcontext)) + (defmacro xp-gp-regs (xp) xp) + (defconstant flags-register-offset 22) + (defconstant rip-register-offset 20) + (defun xp-mxcsr (xp) + (with-macptrs ((state (pref xp :__ucontext.uc_mcontext.mc_fpstate))) + (pref state :savefpu.sv_env.en_mxcsr))) + (defparameter *encoded-gpr-to-indexed-gpr* + #(7 ;rax + 4 ;rcx + 3 ;rdx + 8 ;rbx + 23 ;rsp + 9 ;rbp + 2 ;rsi + 1 ;rdi + 5 ;r8 + 6 ;r9 + 10 ;r10 + 11 ;r11 + 12 ;r12 + 13 ;r13 + 14 ;r14 + 15 ;r15 + ))) + +#+darwinx8664-target +;;; Apple has decided that compliance with some Unix standard or other +;;; requires gratuitously renaming ucontext/mcontext structures and +;;; their components. Do you feel more compliant now ? +(progn + (eval-when (:compile-toplevel :execute) + (def-foreign-type nil + (:struct :portable_mcontext64 + (:es :x86_exception_state64_t) + (:ss :x86_thread_state64_t) + (:fs :x86_float_state64_t))) + (def-foreign-type nil + (:struct :portable_uc_stack + (:ss_sp (:* :void)) + (:ss_size (:unsigned 64)) + (:ss_flags (:signed 32)))) + (def-foreign-type nil + (:struct :portable_ucontext64 + (:onstack (:signed 32)) + (:sigmask (:unsigned 32)) + (:stack (:struct :portable_uc_stack)) + (:link :address) + (:uc_mcsize (:unsigned 64)) + (:uc_mcontext64 (:* (:struct :portable_mcontext64)))))) + (defun xp-mxcsr (xp) + (%get-unsigned-long + (pref (pref xp :portable_ucontext64.uc_mcontext64) :portable_mcontext64.fs) 32)) + (defconstant gp-regs-offset 0) + (defmacro xp-gp-regs (xp) + `(pref (pref ,xp :portable_ucontext64.uc_mcontext64) :portable_mcontext64.ss)) + + (defconstant flags-register-offset 17) + (defconstant rip-register-offset 16) + (defparameter *encoded-gpr-to-indexed-gpr* + #(0 ;rax + 2 ;rcx + 3 ;rdx + 1 ;rbx + 7 ;rsp + 6 ;rbp + 5 ;rsi + 4 ;rdi + 8 ;r8 + 9 ;r9 + 10 ;r10 + 11 ;r11 + 12 ;r12 + 13 ;r13 + 14 ;r14 + 15 ;r15 + ))) + +#+solarisx8664-target +(progn + (defconstant gp-regs-offset (+ (get-field-offset :ucontext.uc_mcontext) + (get-field-offset :mcontext_t.gregs))) + (defmacro xp-gp-regs (xp) xp) + (defconstant flags-register-offset #$REG_RFL) + (defconstant rip-register-offset #$REG_RIP) + (defun xp-mxcsr (xp) + (pref xp :ucontext.uc_mcontext.fpregs.fp_reg_set.fpchip_state.mxcsr)) + (defparameter *encoded-gpr-to-indexed-gpr* + #(14 ;rax + 13 ;rcx + 12 ;rdx + 11 ;rbx + 20 ;rsp + 10 ;rbp + 9 ;rsi + 8 ;rdi + 7 ;r8 + 6 ;r9 + 5 ;r10 + 4 ;r11 + 3 ;r12 + 2 ;r13 + 1 ;r14 + 0 ;r15 + ))) + +#+win64-target +(progn + (defconstant gp-regs-offset (get-field-offset #>CONTEXT.Rax)) + (defmacro xp-gp-regs (xp) xp) + (defconstant rip-register-offset 16) + (defun xp-mxcsr (xp) + (pref xp #>CONTEXT.MxCsr)) + (defparameter *encoded-gpr-to-indexed-gpr* + #(0 ;rax + 1 ;rcx + 2 ;rdx + 3 ;rbx + 4 ;rsp + 5 ;rbp + 6 ;rsi + 7 ;rdi + 8 ;r8 + 9 ;r9 + 10 ;r10 + 11 ;r11 + 12 ;r12 + 13 ;r13 + 14 ;r14 + 15 ;r15 + ))) + +#+darwinx8632-target +(progn + (defconstant gp-regs-offset 0) + (defmacro xp-gp-regs (xp) + `(pref (pref ,xp :ucontext.uc_mcontext) :mcontext.ss)) + (defun xp-mxcsr (xp) + (%get-unsigned-long (pref (pref xp :ucontext.uc_mcontext) :mcontext.fs) 32)) + (defconstant flags-register-offset 9) + (defconstant eip-register-offset 10) + (defparameter *encoded-gpr-to-indexed-gpr* + #(0 ;eax + 2 ;ecx + 3 ;edx + 1 ;ebx + 7 ;esp + 6 ;ebp + 5 ;esi + 4 ;edi + ))) + +#+linuxx8632-target +(progn + (defconstant gp-regs-offset 0) + (defmacro xp-gp-regs (xp) + `(pref (pref ,xp :ucontext.uc_mcontext) :mcontext_t.gregs)) + (defun xp-mxcsr (xp) + (pref (pref (pref xp :ucontext.uc_mcontext) :mcontext_t.fpregs) + :_fpstate.mxcsr)) + (defconstant flags-register-offset #$REG_EFL) + (defconstant eip-register-offset #$REG_EIP) + (defparameter *encoded-gpr-to-indexed-gpr* + (vector + #$REG_EAX ;eax + #$REG_ECX ;ecx + #$REG_EDX ;edx + #$REG_EBX ;ebx + #$REG_ESP ;esp + #$REG_EBP ;ebp + #$REG_ESI ;esi + #$REG_EDI ;edi + ))) + +#+win32-target +(progn + (defconstant gp-regs-offset 0) + (defmacro xp-gp-regs (xp) + `,xp) + (defun xp-mxcsr (xp) + (%get-unsigned-long (pref xp #>CONTEXT.ExtendedRegisters) 24)) + (defconstant flags-register-offset 48) + (defconstant eip-register-offset 45) + (defparameter *encoded-gpr-to-indexed-gpr* + #( + 44 ;eax + 43 ;ecx + 42 ;edx + 41 ;ebx + 49 ;esp + 45 ;ebp + 40 ;esi + 39 ;edi + ))) + +#+solarisx8632-target +(progn + (defconstant gp-regs-offset 0) + (defmacro xp-gp-regs (xp) + `(pref (pref ,xp :ucontext.uc_mcontext) :mcontext_t.gregs)) + (defun xp-mxcsr (xp) + (pref xp :ucontext.uc_mcontext.fpregs.fp_reg_set.fpchip_state.mxcsr)) + (defconstant flags-register-offset #$EFL) + (defconstant eip-register-offset #$EIP) + (defparameter *encoded-gpr-to-indexed-gpr* + (vector + #$EAX + #$ECX + #$EDX + #$EBX + #$ESP + #$EBP + #$ESI + #$EDI) + )) + +#+freebsdx8632-target +(progn + (defconstant gp-regs-offset 0) + (defmacro xp-gp-regs (xp) + `(pref ,xp :ucontext_t.uc_mcontext)) + (defun xp-mxcsr (xp) + (pref (pref xp :ucontext_t.uc_mcontext.mc_fpstate) :savexmm.sv_env.en_mxcsr) +) + (defconstant flags-register-offset 17) + (defconstant eip-register-offset 15) + (defparameter *encoded-gpr-to-indexed-gpr* + #( + 12 ;eax + 11 ;ecx + 10 ;edx + 9 ;ebx + 18 ;esp + 7 ;ebp + 6 ;esi + 5 ;edi + ) + )) + +(defun indexed-gpr-lisp (xp igpr) + (%get-object (xp-gp-regs xp) (+ gp-regs-offset (ash igpr target::word-shift)))) +(defun (setf indexed-gpr-lisp) (new xp igpr) + (%set-object (xp-gp-regs xp) (+ gp-regs-offset (ash igpr target::word-shift)) new)) +(defun encoded-gpr-lisp (xp gpr) + (indexed-gpr-lisp xp (aref *encoded-gpr-to-indexed-gpr* gpr))) +(defun (setf encoded-gpr-lisp) (new xp gpr) + (setf (indexed-gpr-lisp xp (aref *encoded-gpr-to-indexed-gpr* gpr)) new)) +(defun indexed-gpr-integer (xp igpr) + #+x8664-target + (%get-signed-long-long (xp-gp-regs xp) (+ gp-regs-offset (ash igpr x8664::word-shift))) + #+x8632-target + (%get-signed-long (xp-gp-regs xp) (+ gp-regs-offset (ash igpr x8632::word-shift)))) +(defun (setf indexed-gpr-integer) (new xp igpr) + (setf + #+x8664-target + (%get-signed-long-long (xp-gp-regs xp) (+ gp-regs-offset (ash igpr x8664::word-shift))) + #+x8632-target + (%get-signed-long (xp-gp-regs xp) (+ gp-regs-offset (ash igpr x8632::word-shift))) + new)) +(defun encoded-gpr-integer (xp gpr) + (indexed-gpr-integer xp (aref *encoded-gpr-to-indexed-gpr* gpr))) +(defun (setf encoded-gpr-integer) (new xp gpr) + (setf (indexed-gpr-integer xp (aref *encoded-gpr-to-indexed-gpr* gpr)) new)) +(defun indexed-gpr-macptr (xp igpr) + (%get-ptr (xp-gp-regs xp) (+ gp-regs-offset (ash igpr target::word-shift)))) +(defun (setf indexed-gpr-macptr) (new xp igpr) + (setf (%get-ptr (xp-gp-regs xp) (+ gp-regs-offset (ash igpr target::word-shift))) new)) +(defun encoded-gpr-macptr (xp gpr) + (indexed-gpr-macptr xp (aref *encoded-gpr-to-indexed-gpr* gpr))) +(defun (setf encoded-gpr-macptr) (new xp gpr) + (setf (indexed-gpr-macptr xp (aref *encoded-gpr-to-indexed-gpr* gpr)) new)) +(defun xp-flags-register (xp) + #+windows-target (pref xp #>CONTEXT.EFlags) + #-windows-target + (progn + #+x8664-target + (%get-signed-long-long (xp-gp-regs xp) (+ gp-regs-offset (ash flags-register-offset x8664::fixnumshift))) + #+x8632-target + (%get-signed-long (xp-gp-regs xp) (+ gp-regs-offset (ash flags-register-offset x8632::fixnumshift))))) + + + +(defun %get-xcf-byte (xcf-ptr delta) + (let* ((containing-object (%get-object xcf-ptr target::xcf.containing-object)) + (byte-offset (%get-object xcf-ptr target::xcf.relative-pc))) + (if containing-object + (locally (declare (optimize (speed 3) (safety 0)) + (type (simple-array (unsigned-byte 8) (*)) containing-object)) + (aref containing-object (the fixnum (+ byte-offset delta)))) + (%get-unsigned-byte (%int-to-ptr byte-offset) delta)))) + +;;; If the byte following a uuo (which is "skip" bytes long, set +;;; the xcf's relative PC to the value contained in the 32-bit +;;; word preceding the current relative PC and return -1, else return skip. +(defun %check-anchored-uuo (xcf skip) + (if (eql 0 (%get-xcf-byte xcf skip)) + (let* ((new-rpc (+ #+x8664-target target::tag-function + #+x8632-target target::fulltag-misc + (logior (ash (%get-xcf-byte xcf -1) 24) + (ash (%get-xcf-byte xcf -2) 16) + (ash (%get-xcf-byte xcf -3) 8) + (%get-xcf-byte xcf -4))))) + (%set-object xcf target::xcf.relative-pc new-rpc) + -1) + skip)) + + +(defun decode-arithmetic-error (xp xcf) + (declare (ignore xp xcf)) + (values 'unknown nil)) + +(eval-when (:compile-toplevel :execute) + (progn + (defun conditional-os-constant (alternatives) + (dolist (c alternatives (error "None of the constants in ~s could be loaded" alternatives)) + (if (load-os-constant c t) + (return (load-os-constant c))))) + + (defconstant integer-divide-by-zero-code + (conditional-os-constant '(os::EXCEPTION_INT_DIVIDE_BY_ZERO os::FPE_INTDIV)) +) + (defconstant float-divide-by-zero-code + (conditional-os-constant '(os::EXCEPTION_FLT_DIVIDE_BY_ZERO os::FPE_FLTDIV))) + (defconstant float-overflow-code + (conditional-os-constant '(os::FPE_FLTOVF os::EXCEPTION_FLT_OVERFLOW))) + (defconstant float-underflow-code + (conditional-os-constant '(os::FPE_FLTUND os::EXCEPTION_FLT_UNDERFLOW))) + (defconstant float-inexact-code + (conditional-os-constant '(os::FPE_FLTRES os::EXCEPTION_FLT_INEXACT_RESULT))))) + +;;; UUOs are handled elsewhere. This should handle all signals other than +;;; those generated by UUOs (and the non-UUO cases of things like SIGSEGV.) +;;; If the signal number is 0, other arguments (besides the exception context XP) +;;; may not be meaningful. +(defcallback xcmain (:address xp :address xcf :int signal :long code :long addr :long other :int) + (let* ((frame-ptr (macptr->fixnum xcf)) + (skip 0)) + (cond ((zerop signal) ;thread interrupt + (cmain)) + ((< signal 0) + (%err-disp-internal code () frame-ptr)) + ((= signal #$SIGFPE) + (setq code (logand #xffffffff code)) + (multiple-value-bind (operation operands) + (decode-arithmetic-error xp xcf) + (let* ((condition-name + (cond ((or (= code integer-divide-by-zero-code) + (= code float-divide-by-zero-code)) + 'division-by-zero) + ((= code float-overflow-code) + 'floating-point-overflow) + ((= code float-underflow-code) + 'floating-point-underflow) + ((= code float-inexact-code) + 'floating-point-inexact) + (t + 'floating-point-invalid-operation)))) + (%error (make-condition condition-name + :operation operation + :operands operands + :status (xp-mxcsr xp)) + () + frame-ptr)))) + ((= signal #$SIGSEGV) + (cond + ((or (= code 0) (= code 1)) + ;; Stack overflow. + (let* ((on-tsp (= code 1))) + (unwind-protect + (%error + (make-condition + 'stack-overflow-condition + :format-control "Stack overflow on ~a stack." + :format-arguments (list (if on-tsp "temp" "value"))) + nil frame-ptr) + (ff-call (%kernel-import target::kernel-import-restore-soft-stack-limit) + :unsigned-fullword code + :void)))) + ((= code 2) + ;; Write to a watched object. + (let* ((offset other) + ;; The kernel exception handler leaves the + ;; watched object on the lisp stack under the + ;; xcf. + (object (%get-object xcf target::xcf.size))) + (multiple-value-bind (insn insn-length) + (ignore-errors (x86-faulting-instruction xp)) + (restart-case (%error (make-condition + 'write-to-watched-object + :offset offset + :object object + :instruction insn) + nil frame-ptr) + #-windows-target + (emulate () + :test (lambda (c) + (declare (ignore c)) + (x86-can-emulate-instruction insn)) + :report + "Emulate this instruction, leaving the object watched." + (flet ((watchedp (object) + (%map-areas #'(lambda (x) + (when (eq object x) + (return-from watchedp t))) + area-watched))) + (let ((result nil)) + (with-other-threads-suspended + (when (watchedp object) + ;; We now trust that the object is in a + ;; static gc area. + (let* ((a (+ (%address-of object) offset)) + (ptr (%int-to-ptr + (logandc2 a (1- *host-page-size*))))) + (#_mprotect ptr *host-page-size* #$PROT_WRITE) + (setq result (x86-emulate-instruction xp insn)) + (#_mprotect ptr *host-page-size* + (logior #$PROT_READ #$PROT_EXEC))))) + (if result + (setq skip insn-length) + (error "could not emulate the instrution"))))) + (skip () + :test (lambda (c) + (declare (ignore c)) + insn) + :report "Skip over this write instruction." + (setq skip insn-length)) + (unwatch () + :report "Unwatch the object and retry the write." + (unwatch object)))))))) + ((= signal #+win32-target 10 #-win32-target #$SIGBUS) + (if (= code -1) + (%error (make-condition 'invalid-memory-operation) + () + frame-ptr) + (%error (make-condition 'invalid-memory-access + :address addr + :write-p (not (zerop code))) + () + frame-ptr)))) + skip)) + +(defun x86-faulting-instruction (xp) + (let* ((code-bytes (make-array 15 :element-type '(unsigned-byte 8))) + (pc (indexed-gpr-macptr xp #+x8632-target eip-register-offset + #+x8664-target rip-register-offset))) + (dotimes (i (length code-bytes)) + (setf (aref code-bytes i) (%get-unsigned-byte pc i))) + (let* ((ds (make-x86-disassembly-state + :mode-64 #+x8664-target t #+x8632-target nil + :code-vector code-bytes + :code-pointer 0)) + (insn (x86-disassemble-instruction ds nil)) + (len (- (x86-ds-code-pointer ds) (x86-ds-insn-start ds)))) + (values insn len)))) Index: /branches/new-random/lib/.cvsignore =================================================================== --- /branches/new-random/lib/.cvsignore (revision 13309) +++ /branches/new-random/lib/.cvsignore (revision 13309) @@ -0,0 +1,1 @@ +*~.* Index: /branches/new-random/lib/apropos.lisp =================================================================== --- /branches/new-random/lib/apropos.lisp (revision 13309) +++ /branches/new-random/lib/apropos.lisp (revision 13309) @@ -0,0 +1,248 @@ +;;;-*-Mode: LISP; Package: CCL -*- +;;; +;;; Copyright (C) 2009 Clozure Associates +;;; Copyright (C) 1994-2001 Digitool, Inc +;;; This file is part of Clozure CL. +;;; +;;; Clozure CL is licensed under the terms of the Lisp Lesser GNU Public +;;; License , known as the LLGPL and distributed with Clozure CL as the +;;; file "LICENSE". The LLGPL consists of a preamble and the LGPL, +;;; which is distributed with Clozure CL as the file "LGPL". Where these +;;; conflict, the preamble takes precedence. +;;; +;;; Clozure CL is referenced in the preamble as the "LIBRARY." +;;; +;;; The LLGPL is also available online at +;;; http://opensource.franz.com/preamble.html + +;; Apropos.lisp + +(in-package "CCL") + +(eval-when (:execute :compile-toplevel) + (require :level-2) + ) + +(defun apropos-list (string &optional package &aux list) + "Like APROPOS, except that it returns a list of the symbols found instead + of describing them." + (setq string (string-arg string)) + (if package + (do-symbols (sym package) + (when (%apropos-substring-p string (symbol-name sym)) + (push sym list))) + (do-all-symbols (sym) + (when (%apropos-substring-p string (symbol-name sym)) + (push sym list)))) + (let* ((last 0) ; not a symbol + (junk #'(lambda (item) + (declare (debugging-function-name nil)) + (or (eq item last) (progn (setq last item) nil))))) + (declare (dynamic-extent junk)) + (setq list (delete-if junk (sort list #'string-lessp)))) + list) + +(defvar *apropos-indent-to-search-string* nil) +(defun apropos-list-aux (theString package indent-to-search-string &aux theList) + (setq theString (string-arg theString)) + (if package + (do-symbols (sym package) + (when (%apropos-substring-p theString (symbol-name sym)) + (pushnew sym theList))) + (do-all-symbols (sym) + (when (%apropos-substring-p theString (symbol-name sym)) + (pushnew sym theList)))) + (let* ((last 0) ; not a symbol + (junk #'(lambda (item) + (declare (debugging-function-name nil)) + (or (eq item last) (progn (setq last item) nil))))) + (declare (dynamic-extent junk)) + (sort-symbol-list (delete-if junk theList) (if indent-to-search-string + theString + nil)))) + +(defun apropos-string-indented (symTuple indent) + (let ((pr-string (prin1-to-string (aref symTuple 0))) + (displayOffset (aref symTuple 3))) + (format nil "~v@a~a" + indent + (subseq pr-string 0 displayOffset) + (subseq pr-string displayOffset)))) + + +(defun apropos-aux (theString symtuple indent) + (declare (ignore theString)) + (let ((sym (aref symtuple 0)) + val) + (format t "~a" (apropos-string-indented symtuple indent)) + (when (setq val (fboundp sym)) + (cond ((functionp val) + (princ ", Def: ") + (prin1 (type-of val))) + ((setq val (macro-function sym)) + (princ ", Def: MACRO ") + (prin1 (type-of val))) + (t (princ ", Special form")))) + (when (boundp sym) + (princ ", Value: ") + (prin1 (symbol-value sym))) + (terpri))) + + +(defun apropos (theString &optional package) + (multiple-value-bind (symVector indent) (apropos-list-aux theString package *apropos-indent-to-search-string*) + (loop for symtuple across symVector + do (apropos-aux theString symtuple indent)) + (values))) + +#| +(defun apropos (string &optional package) + "Briefly describe all symbols which contain the specified STRING. + If PACKAGE is supplied then only describe symbols present in + that package. If EXTERNAL-ONLY then only describe + external symbols in the specified package." + (setq string (string-arg string)) + (if package + (do-symbols (sym package) (apropos-aux string sym)) + (do-all-symbols (sym) (apropos-aux string sym))) + (values)) + +(defun apropos-aux (string sym &aux val) + (when (%apropos-substring-p string (symbol-name sym)) + (prin1 sym) + (when (setq val (fboundp sym)) + (cond ((functionp val) + (princ ", Def: ") + (prin1 (type-of val))) + ((setq val (macro-function sym)) + (princ ", Def: MACRO ") + (prin1 (type-of val))) + (t (princ ", Special form")))) + (when (boundp sym) + (princ ", Value: ") + (prin1 (symbol-value sym))) + (terpri))) +|# + +; (%apropos-substring-p a b) +; Returns true iff a is a substring (case-sensitive) of b. +; Internal subroutine of apropos, does no type-checking. Assumes strings no +; longer than 64K... + + + + +(defun %apropos-substring-p (a b) + (let ((charA0 (%schar a 0)) + (alen (length a)) + (blen (length b))) + (declare (fixnum alen blen) (optimize (speed 3)(safety 0))) + (if (= alen 0) ; "" is substring of every string + t + (if *apropos-case-sensitive-p* + (dotimes (i (the fixnum (%imin blen (%i+ 1 (%i- blen alen))))) + (declare (fixnum i)) + (when (eq (%schar b i) chara0) + (when + (do ((j 1 (1+ j))) + ((>= j alen) t) + (declare (fixnum j)) + (when (neq (%schar a j)(%schar b (%i+ j i))) + (return nil))) + (return (%i- blen i alen))))) + (dotimes (i (the fixnum (%imin blen (%i+ 1 (%i- blen alen))))) + (declare (fixnum i)) + (when (eq (char-upcase (%schar b i)) (char-upcase chara0)) + (when + (do ((j 1 (1+ j))) + ((>= j alen) t) + (declare (fixnum j)) + (unless (eq (char-upcase (%schar a j)) (char-upcase (%schar b (%i+ j i)))) + (return nil))) + (return (%i- blen i alen))))))))) + + +;;;;;;;;;;;;;;;;;;;;;;;;;; +;;; from Dave Yost +(defun find-sym-alpha-part (sym) + (let* ((str (prin1-to-string sym)) + (sortOffset (let ((sym-start (if (find #\: str) + (loop for ind from (1- (length str)) downto 0 + when (eql #\: (char str ind)) + return (1+ ind)) + 0))) + (+ sym-start (find-alpha-char (subseq str sym-start)))))) + (values str sortOffset sortOffset))) + +(defun find-str-in-sym (str sym) + (let* ((symStr (string-arg (prin1-to-string sym))) + (sortOffset (let ((sym-start (if (find #\: str) + (loop for ind from (1- (length str)) downto 0 + when (eql #\: (char str ind)) + return (1+ ind)) + 0))) + (+ sym-start (find-alpha-char (subseq str sym-start))))) + (displayOffset (let ((sym-start (if (find #\: symStr) + (or (loop for ind from (1- (length symStr)) downto 0 + when (eql #\| (schar symStr ind)) + do (setf ind (loop for ind2 from (1- ind) downto 0 + when (eql #\| (schar symStr ind2)) + return ind2)) + when (eql #\: (char symStr ind)) + return (1+ ind)) + 0) + 0))) + (+ sym-start (search (string-upcase str) (string-upcase (subseq symStr sym-start))))))) + (values symStr sortOffset displayOffset))) + +(defun find-alpha-char (str) + "returns the character position of the first +alphabetic character in str, or the length of str +if it contains no alphabetic characters." + (setq str (string-arg str)) + (dotimes (ind (length str) ind) + (when (alpha-char-p (schar str ind)) + (return ind)))) + +(defun sort-symbol-list (theList search-string) + ;;; First precompute the stylized string form of the symbols as they will be compared + ;;; and calculate the maximum indent + (multiple-value-bind (tmpVector indentation) + (let (sortOffset + displayOffset + str) + (loop for x in thelist do + (multiple-value-setq (str sortOffset displayOffset) + (if search-string + (find-str-in-sym search-string x) + (find-sym-alpha-part x))) + + + maximize displayOffset into indentation1 + collect `#(,x ,(string-arg (subseq str sortOffset)) ,sortOffset ,displayOffset) into tmpList1 + finally (return (values `#(,@tmpList1) indentation1)))) + (setq TMPVECTor (sort tmpVector #'(lambda (symPair1 symPair2) + (string-lessp (aref symPair1 1) (aref symPair2 1))))) + (values tmpVector ; each element is a vector of `#(,sym sortable-string-for-sym) + indentation))) + + +#| +(defun %apropos-substring-p (a b &aux (alen (length a)) + (xlen (%i- (length b) alen))) + (if (%iminusp xlen) nil + (if (eq alen 0) alen + (let ((a0 (schar a 0)) (i 0) j) + (tagbody loop + (when (eq (schar b i) a0) + (setq j 1) + (tagbody subloop + (when (eq j alen) (return-from %apropos-substring-p i)) + (when (eq (schar b (%i+ i j)) (schar a j)) + (setq j (%i+ j 1)) + (go subloop)))) + (unless (eq i xlen) + (setq i (%i+ i 1)) + (go loop))) + nil)))) +|# Index: /branches/new-random/lib/arglist.lisp =================================================================== --- /branches/new-random/lib/arglist.lisp (revision 13309) +++ /branches/new-random/lib/arglist.lisp (revision 13309) @@ -0,0 +1,286 @@ +;;;-*-Mode: LISP; Package: CCL -*- +;;; +;;; Copyright (C) 2009 Clozure Associates +;;; Copyright (C) 1994-2001 Digitool, Inc +;;; This file is part of Clozure CL. +;;; +;;; Clozure CL is licensed under the terms of the Lisp Lesser GNU Public +;;; License , known as the LLGPL and distributed with Clozure CL as the +;;; file "LICENSE". The LLGPL consists of a preamble and the LGPL, +;;; which is distributed with Clozure CL as the file "LGPL". Where these +;;; conflict, the preamble takes precedence. +;;; +;;; Clozure CL is referenced in the preamble as the "LIBRARY." +;;; +;;; The LLGPL is also available online at +;;; http://opensource.franz.com/preamble.html + +(in-package "CCL") + +;;; Record pseudo-arglist info for special operators. +(record-arglist 'catch "tag &body body") +(record-arglist 'progn "&BODY BODY") +(record-arglist 'function "NAME-OR-LAMBDA-EXPRESSION") +(record-arglist 'go "TAG") +(record-arglist 'symbol-macrolet "(&REST BINDINGS) &BODY BODY") +(record-arglist 'locally "DECLARATION* &BODY BODY") +(record-arglist 'setq "[SYMBOL VALUE]*") +(record-arglist 'tagbody "&REST TAGS-OR-FORMS") +(record-arglist 'return-from "BLOCK VALUES") +(record-arglist 'quote '(form)) +(record-arglist 'macrolet "(&REST BINDINGS) &BODY BODY") +(record-arglist 'the '(type-specifier form)) +(record-arglist 'eval-when "(&REST SITUATIONS) &BODY BODY") +(record-arglist 'let* "(&REST BINDINGS) &BODY BODY") +(record-arglist 'let "(&REST BINDINGS) &BODY BODY") +(record-arglist 'load-time-value '(form)) +(record-arglist 'throw '(tag value)) +(record-arglist 'unwind-protect "PROTECTED-FORM &BODY CLEANUP-FORMS") +(record-arglist 'flet "(&REST BINDINGS) &BODY BODY") +(record-arglist 'multiple-value-call '(function &rest values-producing-forms)) +(record-arglist 'block "NAME &BODY BODY") +(record-arglist 'labels "(&REST BINDINGS) &BODY BODY") +(record-arglist 'multiple-value-prog1 "VALUES-PRODUCING-FORM &BODY FORMS-FOR-EFFECT") +(record-arglist 'if '(test true &optional false)) +(record-arglist 'progv "(&REST VARS) (&REST VALUES) &BODY BODY") +(record-arglist 'nfunction '(function-name lambda-expression)) + + +; Returns two values: the arglist & it's functions binding. +; If the second arg is NIL, there was no function binding. +(defun arglist (sym &optional include-bindings) + (%arglist sym include-bindings)) + +(defun arglist-string (sym &optional include-bindings) + (multiple-value-bind (res type) + (%arglist-internal sym include-bindings) + (values + (if (stringp res) + res + (and res (princ-to-string res))) + type))) + +(defun set-arglist (sym arglist) + (let ((real-sym (arglist-sym-and-def sym))) + (when (or real-sym (null sym)) + (if (eq arglist t) + (remhash real-sym %lambda-lists%) + (setf (gethash real-sym %lambda-lists%) arglist))))) + +(defsetf arglist set-arglist) + +; Same as ARGLIST, but has the option of using TEMP-CONS instead of CONS +; to cons up the list. +(defun %arglist (sym &optional include-bindings) + (multiple-value-bind (res type) + (%arglist-internal + sym include-bindings) + (when (stringp res) + (with-input-from-string (stream res) + (setq res nil) + (let ((eof (list nil)) + val errorp) + (declare (dynamic-extent eof)) + (loop + (multiple-value-setq (val errorp) + (ignore-errors (values (read stream nil eof)))) + (when errorp + (push '&rest res) + (push ':unparseable res) + (return)) + (when (eq val eof) + (return)) + (push val res)) + (setq res + (if (and (null (cdr res)) (listp (car res))) + (car res) + (nreverse res)))))) + (values res type))) + +(defun %arglist-internal (sym include-bindings + &aux def type) + (multiple-value-setq (sym def) (arglist-sym-and-def sym)) + (if (generic-function-p def) + (values (generic-function-lambda-list def) :declaration) + (let ((ll (gethash sym %lambda-lists% *eof-value*)) + (macrop (and (symbolp sym) (eq (macro-function sym) def)))) + (flet ((strip (f) (if (stringp f) f (strip-bindings f include-bindings)))) + (declare (dynamic-extent #'strip)) + (cond ((neq ll *eof-value*) (values (strip ll) :declaration)) + ((consp def) + ;; Presumably (lambda (... arglist) ...) + (values (strip (cadr def)) :definition)) + ((neq (setq ll (getf (%lfun-info def) 'arglist *eof-value*)) *eof-value*) + (values ll :definition)) + ((and (not macrop) (setq ll (uncompile-function def))) + (values (strip (cadr ll)) (or type :definition))) + ((lfunp def) + (multiple-value-bind (arglist gotit) + (unless macrop (arglist-from-map def)) + (if gotit + (values arglist :analysis) + (cond (macrop (values nil :unknown)) + (t (values (arglist-from-compiled-def def) :analysis)))))) + (t (values nil nil))))))) + + + +(defun strip-bindings (arglist include-bindings) + (if include-bindings + arglist + (let ((res nil)) + (do ((args arglist (%cdr args))) + ((not (consp args)) (nreconc res args)) + (let ((arg (car args))) + (cond ((atom arg) + (push arg res)) + ((atom (car arg)) + (push (car arg) res)) + (t (push (caar arg) res)))))))) + +(defun arglist-sym-and-def (sym &aux def) + (cond ((functionp sym) + (setq def sym + sym (function-name def)) + (unless (and (symbolp sym) (eq def (fboundp sym))) + (setq sym nil))) + ((listp sym) + (if (eq (car sym) 'setf) + (setq sym (setf-function-name (cadr sym)) + def (find-unencapsulated-definition (fboundp sym))) + (setq sym nil def nil))) + ((standard-method-p sym) + (setq def (closure-function + (find-unencapsulated-definition (%method-function sym))))) + ((and (macro-function sym)) + (setq def (macro-function sym))) + ((special-operator-p sym) + nil) + (t (setq def (find-unencapsulated-definition (fboundp sym))))) + (values sym (if (standard-generic-function-p def) def (closure-function def)))) + +(defun arglist-from-map (lfun) + (multiple-value-bind (nreq nopt restp nkeys allow-other-keys + optinit lexprp + ncells nclosed) + (function-args lfun) + (declare (ignore optinit)) + (if lexprp + (setq restp t)) + (let ((map (car (function-symbol-map lfun)))) + (if map + (let ((total (+ nreq nopt (if restp 1 0) (or nkeys 0))) + (idx (- (length map) nclosed)) + (res nil)) + (if (%izerop total) + (values nil t) + (progn + (dotimes (x nreq) + (declare (fixnum x)) + (push (if (> idx 0) (elt map (decf idx)) (make-arg "ARG" x)) res)) + (when (neq nopt 0) + (push '&optional res) + (dotimes (x (the fixnum nopt)) + (push (if (> idx 0) (elt map (decf idx)) (make-arg "OPT" x)) res))) + + (when restp + (push (if lexprp '&lexpr '&rest) res) + (push (if (> idx 0) (elt map (decf idx)) 'the-rest) res)) + (when nkeys + (push '&key res) + (let ((keyvect (lfun-keyvect lfun))) + (dotimes (i (length keyvect)) + (push (elt keyvect i) res)))) + (when allow-other-keys + (push '&allow-other-keys res)))) + (values (nreverse res) t)) + (values nil (zerop ncells)))))) + +(defun arg-names-from-map (lfun pc) + (when lfun + (multiple-value-bind (nreq nopt restp nkeys allow-other-keys + optinit lexprp + ncells nclosed) + (function-args lfun) + (declare (ignore optinit ncells allow-other-keys)) + (collect ((req) + (opt) + (keys)) + (let* ((rest nil) + (map (if (and pc (> pc target::arg-check-trap-pc-limit)) + (car (function-symbol-map lfun))))) + (if (and map pc) + (let ((total (+ nreq nopt (if (or restp lexprp) 1 0) (or nkeys 0))) + (idx (- (length map) nclosed))) + (unless (zerop total) + (progn + (dotimes (x (the fixnum nreq)) + (declare (fixnum x)) + (req (if (> idx 0) (elt map (decf idx)) (make-arg "ARG" x)))) + (when (neq nopt 0) + (dotimes (x (the fixnum nopt)) + (opt (if (> idx 0) (elt map (decf idx)) (make-arg "OPT" x))))) + (when (or restp lexprp) + (setq rest (if (> idx 0) (elt map (decf idx)) 'the-rest))) + (when nkeys + (dotimes (i (the fixnum nkeys)) + (keys (if (> idx 0) (elt map (decf idx)) (make-arg "KEY" i))))))))) + (values (or (not (null map)) + (and (eql 0 nreq) (eql 0 nopt) (not restp) (null nkeys))) + (req) (opt) rest (keys))))))) + + + + +(defvar *req-arg-names* + #(arg-0 arg-1 arg-2 arg-3 arg-4 arg-5 arg-6 arg-7 arg-8 arg-9)) + +(defvar *opt-arg-names* + #(opt-0 opt-1 opt-2 opt-3 opt-4 opt-5 opt-6 opt-7 opt-8 opt-9)) + + +(defun make-arg (prefix count) + (cond ((and (string= prefix "ARG") (< count (length *req-arg-names*))) + (svref *req-arg-names* count)) + ((and (string= prefix "OPT") (< count (length *opt-arg-names*))) + (svref *opt-arg-names* count)) + (t (intern (format nil "~a-~d" prefix count) :CCL)))) + +(defun arglist-from-compiled-def (lfun &aux (res nil) argnames) + (multiple-value-bind (nreq nopt restp nkeys allow-other-keys + optinit lexprp + ncells nclosed) + (function-args lfun) + (declare (ignore optinit ncells nclosed)) + (flet ((push-various-args (prefix count) + (dotimes (i (the fixnum count)) + (push (make-arg prefix i) res)))) + (declare (dynamic-extent #'push-various-args)) + ;; Treat &LEXPR like &REST. + (if lexprp (setq restp t lexprp nil)) + (cond ((and (eq 0 (+ nreq nopt (or nkeys 0))) (not restp)) + nil) + (t + (if argnames + (setq res (reverse (butlast argnames (- (length argnames) nreq)))) + (push-various-args "ARG" nreq)) + (when (> nopt 0) + (push '&optional res) + (if argnames + (setq res (append (reverse (subseq argnames nreq (+ nreq nopt))) res)) + (push-various-args "OPT" nopt))) + (when restp + (push '&rest res) + (if argnames + (push (nth (+ nreq nopt) argnames) res) + (push 'the-rest res))) + (when nkeys + (push '&key res) + (let ((keyvect (lfun-keyvect lfun))) + (dotimes (i (length keyvect)) + (push (elt keyvect i) res)))) + (when allow-other-keys + (push '&allow-other-keys res)) + (nreverse res)))))) + +; End of arglist.lisp Index: /branches/new-random/lib/arrays-fry.lisp =================================================================== --- /branches/new-random/lib/arrays-fry.lisp (revision 13309) +++ /branches/new-random/lib/arrays-fry.lisp (revision 13309) @@ -0,0 +1,465 @@ +; -*- Mode:Lisp; Package:CCL; -*- +;;; +;;; Copyright (C) 2009 Clozure Associates +;;; Copyright (C) 1994-2001 Digitool, Inc +;;; This file is part of Clozure CL. +;;; +;;; Clozure CL is licensed under the terms of the Lisp Lesser GNU Public +;;; License , known as the LLGPL and distributed with Clozure CL as the +;;; file "LICENSE". The LLGPL consists of a preamble and the LGPL, +;;; which is distributed with Clozure CL as the file "LGPL". Where these +;;; conflict, the preamble takes precedence. +;;; +;;; Clozure CL is referenced in the preamble as the "LIBRARY." +;;; +;;; The LLGPL is also available online at +;;; http://opensource.franz.com/preamble.html + +(in-package "CCL") + +(defun bit (bit-array &rest subscripts) + "Return the bit from the BIT-ARRAY at the specified SUBSCRIPTS." + (declare (dynamic-extent subscripts)) + (unless (eq (array-element-type bit-array) 'bit) + (report-bad-arg bit-array '(array bit))) + (apply #'aref bit-array subscripts)) + +(defun %bitset (bit-array &rest stuff) + (declare (dynamic-extent stuff)) + (unless (eq (array-element-type bit-array) 'bit) + (report-bad-arg bit-array '(array bit))) + (apply #'aset bit-array stuff)) + +(defun sbit (v &optional (sub0 nil sub0-p) &rest others) + "Return the bit from SIMPLE-BIT-ARRAY at the specified SUBSCRIPTS." + (declare (dynamic-extent others)) + (if sub0-p + (if others + (apply #'bit v sub0 others) + ( sbit (require-type v 'simple-bit-vector) sub0)) + (bit v))) + +(defun %sbitset (v sub0 &optional (newval nil newval-p) &rest newval-was-really-sub1) + (declare (dynamic-extent newval-was-really-sub1)) + (if newval-p + (if newval-was-really-sub1 + (apply #'%bitset v sub0 newval newval-was-really-sub1) + (progn + (unless (typep v 'simple-bit-vector) + (report-bad-arg v 'simple-bit-vector)) + (uvset v sub0 newval))) + (%bitset v sub0))) + +(defun bit-and (bit-array1 bit-array2 &optional result-bit-array) + "Perform a bit-wise LOGAND on the elements of BIT-ARRAY-1 and BIT-ARRAY-2, + putting the results in RESULT-BIT-ARRAY. If RESULT-BIT-ARRAY is T, + BIT-ARRAY-1 is used. If RESULT-BIT-ARRAY is NIL or omitted, a new array is + created. All the arrays must have the same rank and dimensions." + (bit-boole boole-and bit-array1 bit-array2 result-bit-array)) + +(defun bit-ior (bit-array1 bit-array2 &optional result-bit-array) + "Perform a bit-wise LOGIOR on the elements of BIT-ARRAY-1 and BIT-ARRAY-2, + putting the results in RESULT-BIT-ARRAY. If RESULT-BIT-ARRAY is T, + BIT-ARRAY-1 is used. If RESULT-BIT-ARRAY is NIL or omitted, a new array is + created. All the arrays must have the same rank and dimensions." + (bit-boole boole-ior bit-array1 bit-array2 result-bit-array)) + +(defun bit-xor (bit-array1 bit-array2 &optional result-bit-array) + "Perform a bit-wise LOGXOR on the elements of BIT-ARRAY-1 and BIT-ARRAY-2, + putting the results in RESULT-BIT-ARRAY. If RESULT-BIT-ARRAY is T, + BIT-ARRAY-1 is used. If RESULT-BIT-ARRAY is NIL or omitted, a new array is + created. All the arrays must have the same rank and dimensions." + (bit-boole boole-xor bit-array1 bit-array2 result-bit-array)) + +(defun bit-eqv (bit-array1 bit-array2 &optional result-bit-array) + "Perform a bit-wise LOGEQV on the elements of BIT-ARRAY-1 and BIT-ARRAY-2, + putting the results in RESULT-BIT-ARRAY. If RESULT-BIT-ARRAY is T, + BIT-ARRAY-1 is used. If RESULT-BIT-ARRAY is NIL or omitted, a new array is + created. All the arrays must have the same rank and dimensions." + (bit-boole boole-eqv bit-array1 bit-array2 result-bit-array)) + +(defun bit-nand (bit-array1 bit-array2 &optional result-bit-array) + "Perform a bit-wise LOGNAND on the elements of BIT-ARRAY-1 and BIT-ARRAY-2, + putting the results in RESULT-BIT-ARRAY. If RESULT-BIT-ARRAY is T, + BIT-ARRAY-1 is used. If RESULT-BIT-ARRAY is NIL or omitted, a new array is + created. All the arrays must have the same rank and dimensions." + (bit-boole boole-nand bit-array1 bit-array2 result-bit-array)) + +(defun bit-nor (bit-array1 bit-array2 &optional result-bit-array) + "Perform a bit-wise LOGNOR on the elements of BIT-ARRAY-1 and BIT-ARRAY-2, + putting the results in RESULT-BIT-ARRAY. If RESULT-BIT-ARRAY is T, + BIT-ARRAY-1 is used. If RESULT-BIT-ARRAY is NIL or omitted, a new array is + created. All the arrays must have the same rank and dimensions." + (bit-boole boole-nor bit-array1 bit-array2 result-bit-array)) + +(defun bit-andc1 (bit-array1 bit-array2 &optional result-bit-array) + "Perform a bit-wise LOGANDC1 on the elements of BIT-ARRAY-1 and BIT-ARRAY-2, + putting the results in RESULT-BIT-ARRAY. If RESULT-BIT-ARRAY is T, + BIT-ARRAY-1 is used. If RESULT-BIT-ARRAY is NIL or omitted, a new array is + created. All the arrays must have the same rank and dimensions." + (bit-boole boole-andc1 bit-array1 bit-array2 result-bit-array)) + +(defun bit-andc2 (bit-array1 bit-array2 &optional result-bit-array) + "Perform a bit-wise LOGANDC2 on the elements of BIT-ARRAY-1 and BIT-ARRAY-2, + putting the results in RESULT-BIT-ARRAY. If RESULT-BIT-ARRAY is T, + BIT-ARRAY-1 is used. If RESULT-BIT-ARRAY is NIL or omitted, a new array is + created. All the arrays must have the same rank and dimensions." + (bit-boole boole-andc2 bit-array1 bit-array2 result-bit-array)) + +(defun bit-orc1 (bit-array1 bit-array2 &optional result-bit-array) + "Perform a bit-wise LOGORC1 on the elements of BIT-ARRAY-1 and BIT-ARRAY-2, + putting the results in RESULT-BIT-ARRAY. If RESULT-BIT-ARRAY is T, + BIT-ARRAY-1 is used. If RESULT-BIT-ARRAY is NIL or omitted, a new array is + created. All the arrays must have the same rank and dimensions." + (bit-boole boole-orc1 bit-array1 bit-array2 result-bit-array)) + +(defun bit-orc2 (bit-array1 bit-array2 &optional result-bit-array) + "Perform a bit-wise LOGORC2 on the elements of BIT-ARRAY-1 and BIT-ARRAY-2, + putting the results in RESULT-BIT-ARRAY. If RESULT-BIT-ARRAY is T, + BIT-ARRAY-1 is used. If RESULT-BIT-ARRAY is NIL or omitted, a new array is + created. All the arrays must have the same rank and dimensions." + (bit-boole boole-orc2 bit-array1 bit-array2 result-bit-array)) + +(defun bit-not (bit-array &optional result-bit-array) + "Performs a bit-wise logical NOT on the elements of BIT-ARRAY, + putting the results in RESULT-BIT-ARRAY. If RESULT-BIT-ARRAY is T, + BIT-ARRAY is used. If RESULT-BIT-ARRAY is NIL or omitted, a new array is + created. Both arrays must have the same rank and dimensions." + (bit-boole boole-nor bit-array bit-array result-bit-array)) + +(defun result-bit-array (bit-array-1 bit-array-2 result) + ; Check that the two bit-array args are bit-arrays with + ; compatible dimensions. If "result" is specified as T, + ; return bit-array-1. If result is unspecified, return + ; a new bit-array of the same dimensions as bit-array-2. + ; Otherwise, make sure that result is a bit-array of the + ; same dimensions as the other two arguments and return + ; it. + (let* ((typecode-1 (typecode bit-array-1)) + (typecode-2 (typecode bit-array-2))) + (declare (fixnum typecode-1 typecode-2)) + (flet ((bit-array-dimensions (bit-array typecode) + (declare (fixnum typecode)) + (if (= typecode target::subtag-bit-vector) + (uvsize bit-array) + (let* ((array-p (= typecode target::subtag-arrayH)) + (vector-p (= typecode target::subtag-vectorH))) + (if (and (or array-p vector-p) + (= (the fixnum (%array-header-subtype bit-array)) target::subtag-bit-vector)) + (if vector-p + (array-dimension bit-array 0) + (array-dimensions bit-array)) + (report-bad-arg bit-array '(array bit)))))) + (check-matching-dimensions (a1 d1 a2 d2) + (unless (equal d1 d2) + (error "~s and ~s have different dimensions." a1 a2)) + a2)) + (let* ((dims-1 (bit-array-dimensions bit-array-1 typecode-1)) + (dims-2 (bit-array-dimensions bit-array-2 typecode-2))) + (check-matching-dimensions bit-array-1 dims-1 bit-array-2 dims-2) + (if result + (if (eq result t) + bit-array-1 + (check-matching-dimensions bit-array-2 dims-2 result (bit-array-dimensions result (typecode result)))) + (make-array dims-2 :element-type 'bit :initial-element 0)))))) + + + + + +(defun bit-boole (opcode array1 array2 result-array) + (unless (eql opcode (logand 15 opcode)) + (setq opcode (require-type opcode '(mod 16)))) + (let* ((result (result-bit-array array1 array2 result-array))) + (if (and (typep array1 'simple-bit-vector) + (typep array2 'simple-bit-vector) + (typep result 'simple-bit-vector)) + (%simple-bit-boole opcode array1 array2 result) + (multiple-value-bind (v1 i1) (array-data-and-offset array1) + (declare (simple-bit-vector v1) (fixnum i1)) + (multiple-value-bind (v2 i2) (array-data-and-offset array2) + (declare (simple-bit-vector v2) (fixnum i2)) + (multiple-value-bind (v3 i3) (array-data-and-offset result) + (declare (simple-bit-vector v3) (fixnum i3)) + (let* ((e3 (+ i3 (the fixnum (array-total-size result))))) + (declare (fixnum e3)) + (do* ( ) + ((= i3 e3) result) + (setf (sbit v3 i3) + (logand (boole opcode (sbit v1 i1) (sbit v2 i2)) 1)) + (incf i1) + (incf i2) + (incf i3))))))))) + + + + + + + + +; shrink-vector is called only in sequences-2. None of the calls depend on +; the side affect of setting the passed-in symbol to the [possibly new] +; returned vector +; Since there hasn't been such a thing as sequences-2 in about 7 years, +; this is especially puzzling. +(eval-when (:compile-toplevel :execute :load-toplevel) + (defmacro shrink-vector (vector to-size) + `(setq ,vector (%shrink-vector ,vector ,to-size))) + ) + + +; new and faulty def +(defun %shrink-vector (vector to-size) + (cond ((eq (length vector) to-size) + vector) + ((array-has-fill-pointer-p vector) + (setf (fill-pointer vector) to-size) + vector) + (t (subseq vector 0 to-size)))) + + +; this could be put into print-db as it was in ccl-pr-4.2 +; Or it (and print-db) could just be flushed ... tough one. +(defun multi-dimension-array-to-list (array) + "Produces a nested list of the elements in array." + (mdal-aux array (array-dimensions array) nil + (array-dimensions array))) + +(defun mdal-aux (array all-dimensions use-dimensions + remaining-dimensions) + (if (= (length all-dimensions) (length use-dimensions)) + (apply 'aref array use-dimensions) + (do ((index 0 (1+ index)) + (d-length (car remaining-dimensions)) + (result nil)) + ((= d-length index) result) + (setq result + (append result (list (mdal-aux array all-dimensions + (append use-dimensions + (list index)) + (cdr remaining-dimensions)))))))) + +(defun adjust-array (array dims + &key (element-type nil element-type-p) + (initial-element nil initial-element-p) + (initial-contents nil initial-contents-p) + (fill-pointer nil fill-pointer-p) + displaced-to + displaced-index-offset + &aux (subtype (array-element-subtype array))) + "Adjust ARRAY's dimensions to the given DIMENSIONS and stuff." + (when (and element-type-p + (neq (element-type-subtype element-type) subtype)) + (error "~S is not of element type ~S" array element-type)) + (when (integerp dims)(setq dims (list dims))) ; because %displace-array wants the list + (if (neq (list-length dims)(array-rank array)) + (error "~S has wrong rank for adjusting to dimensions ~S" array dims)) + (let ((size 1) + (explicitp nil)) + (dolist (dim dims) + (when (< dim 0)(report-bad-arg dims '(integer 0 *))) + (setq size (* size dim))) + (when (and (neq fill-pointer t) + (array-has-fill-pointer-p array) + (< size (or fill-pointer (fill-pointer array)))) + (error "Cannot adjust array ~S to size less than fill pointer ~S" + array (or fill-pointer (fill-pointer array)))) + (when (and fill-pointer (not (array-has-fill-pointer-p array))) + (error "~S does not have a fill pointer" array)) + (when (and displaced-index-offset (null displaced-to)) + (error "Cannot specify ~S without ~S" :displaced-index-offset :displaced-to)) + (when (and initial-element-p initial-contents-p) + (error "Cannot specify both ~S and ~S" :initial-element :initial-contents)) + (cond + ((not (adjustable-array-p array)) + (let ((new-array (make-array-1 dims + (array-element-type array) T + displaced-to + displaced-index-offset + nil + (or fill-pointer + (and (array-has-fill-pointer-p array) + (fill-pointer array))) + initial-element initial-element-p + initial-contents initial-contents-p + size))) + + (when (and (null initial-contents-p) + (null displaced-to)) + (multiple-value-bind (array-data offs) (array-data-and-offset array) + (let ((new-array-data (array-data-and-offset new-array))) + (cond ((null dims) + (uvset new-array-data 0 (uvref array-data offs))) + (T + (init-array-data array-data offs (array-dimensions array) + new-array-data 0 dims)))))) + (setq array new-array))) + (T (cond + (displaced-to + (if (and displaced-index-offset + (or (not (fixnump displaced-index-offset)) + (< displaced-index-offset 0))) + (report-bad-arg displaced-index-offset '(integer 0 #.most-positive-fixnum))) + (when (or initial-element-p initial-contents-p) + (error "Cannot specify initial values for displaced arrays")) + (unless (eq subtype (array-element-subtype displaced-to)) + (error "~S is not of element type ~S" + displaced-to (array-element-type array))) + (do* ((vec displaced-to (displaced-array-p vec))) + ((null vec) ()) + (when (eq vec array) + (error "Array cannot be displaced to itself."))) + (setq explicitp t)) + (T + (setq displaced-to (%alloc-misc size subtype)) + (cond (initial-element-p + (dotimes (i (the fixnum size)) (uvset displaced-to i initial-element))) + (initial-contents-p + (if (null dims) (uvset displaced-to 0 initial-contents) + (init-uvector-contents displaced-to 0 dims initial-contents)))) + (cond ((null dims) + (uvset displaced-to 0 (aref array))) + ((not initial-contents-p) + (multiple-value-bind (vec offs) (array-data-and-offset array) + (init-array-data vec offs (array-dimensions array) displaced-to 0 dims)))))) + (%displace-array array dims size displaced-to (or displaced-index-offset 0) explicitp))) + (when fill-pointer-p + (cond + ((eq fill-pointer t) + (set-fill-pointer array size)) + (fill-pointer + (set-fill-pointer array fill-pointer)))) + array)) + +(defun array-dims-sizes (dims) + (if (or (atom dims) (null (%cdr dims))) dims + (let ((ndims (array-dims-sizes (%cdr dims)))) + (cons (* (%car dims) (%car ndims)) ndims)))) + +(defun init-array-data (vec off dims nvec noff ndims) + (init-array-data-aux vec off dims (array-dims-sizes (cdr dims)) + nvec noff ndims (array-dims-sizes (cdr ndims)))) + +(defun init-array-data-aux (vec off dims siz nvec noff ndims nsiz) + (when (null siz) + (return-from init-array-data-aux + (init-vector-data vec off (car dims) nvec noff (car ndims)))) + (let ((count (pop dims)) + (size (pop siz)) + (ncount (pop ndims)) + (nsize (pop nsiz))) + (dotimes (i (if (%i< count ncount) count ncount)) + (declare (fixnum i)) + (init-array-data-aux vec off dims siz nvec noff ndims nsiz) + (setq off (%i+ off size) noff (%i+ noff nsize))))) + +(defun init-vector-data (vec off len nvec noff nlen) + (dotimes (i (if (%i< len nlen) len nlen)) + (declare (fixnum i)) + (uvset nvec noff (uvref vec off)) + (setq off (%i+ off 1) noff (%i+ noff 1)))) + +;;; only caller is adjust-array + +(defun %displace-array (array dims size data offset explicitp) + (let* ((typecode (typecode array)) + (array-p (eql typecode target::subtag-arrayH)) + (vector-p (eql typecode target::subtag-vectorH))) + (unless (or array-p vector-p) + (error "Array ~S cannot be displaced" array)) + (unless (fixnump offset) (report-bad-arg offset '(integer 0 #.most-positive-fixnum))) + (unless (adjustable-array-p data) + (multiple-value-bind (ndata noffset) (displaced-array-p data) + (if ndata (setq data ndata offset (%i+ offset noffset))))) + (unless (and (fixnump size) (%i<= (%i+ offset size) (array-total-size data))) + (error "Offset ~S + size ~S must be less than size of array displaced-to" offset size)) + (let* ((flags (%svref array target::vectorH.flags-cell))) + (declare (fixnum flags)) + (setf (%svref array target::vectorH.flags-cell) + (if (> (the fixnum (typecode data)) target::subtag-vectorH) + (bitclr $arh_disp_bit flags) + (bitset $arh_disp_bit flags))) + (setf (%svref array target::vectorH.flags-cell) + (if explicitp + (bitset $arh_exp_disp_bit flags) + (bitclr $arh_exp_disp_bit flags))) + (setf (%svref array target::arrayH.data-vector-cell) data) + (if array-p + (progn + (do ((i target::arrayH.dim0-cell (1+ i))) + ((null dims)) + (declare (fixnum i)) + (setf (%svref array i) (pop dims))) + (setf (%svref array target::arrayH.physsize-cell) size) + (setf (%svref array target::arrayH.displacement-cell) offset)) + (progn + (if (or (not (logbitp $arh_fill_bit flags)) + (> (the fixnum (%svref array target::vectorH.logsize-cell)) size)) + (setf (%svref array target::vectorH.logsize-cell) size)) + (setf (%svref array target::vectorH.physsize-cell) size) + (setf (%svref array target::vectorH.displacement-cell) offset))) + array))) + + + +(defun array-row-major-index (array &lexpr subscripts) + (let ((rank (array-rank array)) + (nsubs (%lexpr-count subscripts)) + (sum 0)) + (declare (fixnum sum rank)) + (unless (eql rank nsubs) + (%err-disp $xndims array nsubs)) + (if (eql 0 rank) + 0 + (do* ((i (1- rank) (1- i)) + (dim (array-dimension array i) (array-dimension array i)) + (last-size 1 size) + (size dim (* dim size))) + (nil) + (declare (fixnum i last-size size)) + (let ((s (%lexpr-ref subscripts nsubs i))) + (unless (fixnump s) + (setq s (require-type s 'fixnum))) + (when (or (< s 0) (>= s dim)) + (%err-disp $XARROOB (%apply-lexpr 'list subscripts) array)) + (incf sum (the fixnum (* s last-size))) + (when (eql i 0) (return sum))))))) + +(defun array-in-bounds-p (array &lexpr subscripts) + "Return T if the SUBSCIPTS are in bounds for the ARRAY, NIL otherwise." + (let ((rank (array-rank array)) + (nsubs (%lexpr-count subscripts))) + (declare (fixnum nsubs rank)) + (if (not (eql nsubs rank)) + (%err-disp $xndims array nsubs) + (if (eql 0 rank) + 0 + (do* ((i (1- rank) (1- i)) + (dim (array-dimension array i) (array-dimension array i))) + (nil) + (declare (fixnum i dim)) + (let ((s (%lexpr-ref subscripts nsubs i))) + (if (typep s 'fixnum) + (locally (declare (fixnum s)) + (if (or (< s 0)(>= s dim)) (return nil))) + (if (typep s 'bignum) + (return nil) + (report-bad-arg s 'integer))) + (when (eql i 0) (return t)))))))) + +(defun row-major-aref (array index) + "Return the element of array corressponding to the row-major index. This is + SETF'able." + (multiple-value-bind (displaced-to offset) (displaced-array-p array) + (aref (or displaced-to array) (+ index offset)))) + +(defun row-major-aset (array index new) + (multiple-value-bind (displaced-to offset) (displaced-array-p array) + (setf (aref (or displaced-to array) (+ index offset)) new))) + +(defsetf row-major-aref row-major-aset) + + + +; end Index: /branches/new-random/lib/backquote.lisp =================================================================== --- /branches/new-random/lib/backquote.lisp (revision 13309) +++ /branches/new-random/lib/backquote.lisp (revision 13309) @@ -0,0 +1,394 @@ +; -*- Mode:Lisp; Package:CCL; -*- +;;; +;;; Copyright (C) 2009 Clozure Associates +;;; Copyright (C) 1994-2001 Digitool, Inc +;;; This file is part of Clozure CL. +;;; +;;; Clozure CL is licensed under the terms of the Lisp Lesser GNU Public +;;; License , known as the LLGPL and distributed with Clozure CL as the +;;; file "LICENSE". The LLGPL consists of a preamble and the LGPL, +;;; which is distributed with Clozure CL as the file "LGPL". Where these +;;; conflict, the preamble takes precedence. +;;; +;;; Clozure CL is referenced in the preamble as the "LIBRARY." +;;; + +; Backquote.lisp + +(in-package "CCL") + +#+nil +(progn +;;; Common Lisp backquote implementation, written in Common Lisp. +;;; Author: Guy L. Steele Jr. Date: 27 December 1985 +;;; Texted under Symbolics Common Lisp and Lucid Common Lisp. +;;; This software is in the public domain. + +;;; The following are unique tokens used during processing +;;; They need not be symbols; they need not even be atoms. + +(defvar *comma* (make-symbol "`,")) +(defvar *comma-atsign* (make-symbol "`,@")) +(defvar *comma-dot* (make-symbol "`,.")) +(defvar *bq-list* (make-symbol "BQ-LIST")) +(defvar *bq-append* (make-symbol "BQ-APPEND")) +(defvar *bq-list** (make-symbol "BQ-LIST*")) +(defvar *bq-nconc* (make-symbol "BQ-NCONC")) +(defvar *bq-clobberable* (make-symbol "BQ-CLOBBERABLE")) +(defvar *bq-quote* (make-symbol "BQ-QUOTE")) +(defvar *bq-quote-nil* (list *bq-quote* nil)) + +;;; Reader macro characters: +;;; `foo is read in as (BACKQUOTE foo) +;;; ,foo is read in as (#:COMMA foo) +;;; ,@foo is read in as (#:COMMA-ATSIGN foo) +;;; ,.foo is read in as (#:COMMA-DOT foo) +;;; where #:COMMA is the value of the variable *COMMA* etc. + +;;; BACKQUOTE is an ordinary macro (not a read-macro) that +;;; processes the expression foo, looking for occurrences of +;;; #:COMMA, #:COMMA-ATSIGN, and #:COMMA-DOT. It constructs code +;;; in strict accordance with the rules on pages 349-350 of +;;; of the first edition (pages 528-529 of this second edition). +;;; It then optionally applies a code simplifier. + +(set-macro-character #\` + #'(lambda (stream char) + (declare (ignore char)) + (list 'backquote (read stream t nil t)))) + +(set-macro-character #\, + #'(lambda (stream char) + (declare (ignore char)) + (case (peek-char nil stream t nil t) + (#\@ (read-char stream t nil t) + (list *comma-atsign* (read stream t nil t))) + (#\. (read-char stream t nil t) + (list *comma-dot* (read stream t nil t))) + (otherwise (list *comma* (read stream t nil t)))))) + +;;; if the value of *BQ-SIMPLIFY* is non-nil, then BACKQUOTE +;;; processing applies the code simplifier. If the value is NIL, +;;; then the code resulting from BACKQUOTE is exactly that +;;; specified by the official rules. + +(defvar *bq-simplify* t) + +(defmacro backquote (x) + (bq-completely-process x)) + +;;; Backquote processing proceeds in three stages: +;;; +;;; (1) BQ-PROCESS applies the rules to remove occurrences of +;;; #:COMMA, #:COMMA-ATSIGN, and #:COMMA-DOT corresponding to +;;; this level of BACKQUOTE. (It also causes embedded calls to +;;; BACKQUOTE to be expanded so that nesting is properly handled.) +;;; Code is produced that is expressed in terms of functions +;;; #:BQ-LIST, #:BQ-APPEND, and #:BQ-CLOBBERABLE. This is done +;;; so that the simplifier will simplify only list construction +;;; functions actually generated by backquote and will not involve +;;; any user code in the simplification. #:BQ-LIST means LIST, +;;; #:BQ-APPEND means APPEND, and #:BQ-CLOBBERABLE means IDENTITY +;;; but indicates places where ",." was used and where NCONC may +;;; therefore be introduced by the simplifier for efficiency. +;;; +;;; (2) BQ-SIMPLIFY, if used, rewrites the code produced by +;;; BQ-PROCESS to produce equivalent but faster code. The +;;; additional functions #:BQ-LIST* and #:BQ-NCONC may be +;;; introduced into the code. +;;; +;;; (3) BQ-REMOVE-TOKENS goes through the code and replaces +;;; #:BQ-LIST with LIST, #:BQ-APPEND with APPEND, and so on. +;;; #:BQ-CLOBBERABLE is simply eliminated (a call to it being +;;; replaced by its argument). #:BQ-LIST* is replaced by either +;;; LIST* or CONS (the latter is used in the two-argument case, +;;; purely to make the resulting code a tad more readable). + +(defun bq-completely-process (x) + (let ((raw-result (bq-process x))) + (bq-remove-tokens (if *bq-simplify* + (bq-simplify raw-result) + raw-result)))) + +; Portable code could just say (coerce list 'vector) +(defun list-to-vector (list) + (unless (listp list) + (setq list (require-type list 'list))) + (%list-to-uvector nil list)) + +(define-compiler-macro list-to-vector (&whole whole form) + (if (quoted-form-p form) + (list-to-vector (cadr form)) + whole)) + +(defun bq-process (x) + (cond ((atom x) + (if (simple-vector-p x) + (list 'list-to-vector (bq-process (coerce x 'list))) + (list *bq-quote* x))) + ((eq (car x) 'backquote) + (bq-process (bq-completely-process (cadr x)))) + ((eq (car x) *comma*) (cadr x)) + ((eq (car x) *comma-atsign*) + (error ",@~S after `" (cadr x))) + ((eq (car x) *comma-dot*) + (error ",.~S after `" (cadr x))) + (t (do ((p x (cdr p)) + (q '() (cons (bracket (car p)) q))) + ((atom p) + (cons *bq-append* + (nreconc q (list (list *bq-quote* p))))) + (when (eq (car p) *comma*) + (unless (null (cddr p)) (error "Malformed ,~S" p)) + (return (cons *bq-append* + (nreconc q (list (cadr p)))))) + (when (eq (car p) *comma-atsign*) + (error "Dotted ,@~S" p)) + (when (eq (car p) *comma-dot*) + (error "Dotted ,.~S" p)))))) + +;;; This implements the bracket operator of the formal rules + +(defun bracket (x) + (cond ((atom x) + (list *bq-list* (bq-process x))) + ((eq (car x) *comma*) + (list *bq-list* (cadr x))) + ((eq (car x) *comma-atsign*) + (cadr x)) + ((eq (car x) *comma-dot*) + (list *bq-clobberable* (cadr x))) + (t (list *bq-list* (bq-process x))))) + +;;; This auxiliary function is like MAPCAR but has two extra +;;; purpoess: (1) it handles dotted lists; (2) it tries to make +;;; the result share with the argument x as much as possible. + +(defun maptree (fn x) + (if (atom x) + (funcall fn x) + (let ((a (funcall fn (car x))) + (d (maptree fn (cdr x)))) + (if (and (eql a (car x)) (eql d (cdr x))) + x + (cons a d))))) + +;;; This predicate is true of a form that when read looked +;;; like ,@foo or ,.foo + +(defun bq-splicing-frob (x) + (and (consp x) + (or (eq (car x) *comma-atsign*) + (eq (car x) *comma-dot*)))) + +;;; This predicate is true of a form that when read +;;; looked like ,@foo or just plain ,foo. + +(defun bq-frob (x) + (and (consp x) + (or (eq (car x) *comma*) + (eq (car x) *comma-atsign*) + (eq (car x) *comma-dot*)))) + +;;; The simplifier essentially looks for calls to #:BQ-APPEND and +;;; tries to simplify them. The arguments to #:BQ-APPEND are +;;; processed from right to left, building up a replacement for. +;;; At each step a number of special cases are handled that, +;;; loosely speaking, look like this: +;;; +;;; (APPEND (LIST a b c) foo) => (LIST* a b c foo) +;;; provided a, b, c are not splicing frobs +;;; (APPEND (LIST* a b c) foo) => (LIST* a b (APPEND c foo)) +;;; provided a, b, c are not splicing frobs +;;; (APPEND (QUOTE (x)) foo) => (LIST* (QUOTE x) foo) +;;; (APPEND (CLOBBERABLE x) foo) => (NCONC x foo) + +(defun bq-simplify (x) + (if (atom x) + x + (let ((x (if (eq (car x) *bq-quote*) + x + (maptree #'bq-simplify x)))) + (if (not (eq (car x) *bq-append*)) + x + (bq-simplify-args x))))) + +(defun bq-simplify-args (x) + (do ((args (reverse (cdr x)) (cdr args)) + (result + nil + (cond ((atom (car args)) + (bq-attach-append *bq-append* (car args) result)) + ((and (eq (caar args) *bq-list*) + (notany #'bq-splicing-frob (cdar args))) + (bq-attach-conses (cdar args) result)) + ((and (eq (caar args) *bq-list**) + (notany #'bq-splicing-frob (cdar args))) + (bq-attach-conses + (reverse (cdr (reverse (cdar args)))) + (bq-attach-append *bq-append* + (car (last (car args))) + result))) + ((and (eq (caar args) *bq-quote*) + (consp (cadar args)) + (not (bq-frob (cadar args))) + (null (cddar args))) + (bq-attach-conses (list (list *bq-quote* + (caadar args))) + result)) + ((eq (caar args) *bq-clobberable*) + (bq-attach-append *bq-nconc* (cadar args) result)) + (t (bq-attach-append *bq-append* + (car args) + result))))) + ((null args) result))) + +(defun null-or-quoted (x) + (or (null x) (and (consp x) (eq (car x) *bq-quote*)))) + +;;; When BQ-ATTACH-APPEND is called, the OP should be #:BQ-APPEND +;;; or #:BQ-NCONC. This produces a form (op item result) but +;;; some simplifications are done on the fly: +;;; +;;; (op '(a b c) '(d e f g)) => '(a b c d e f g) +;;; (op item 'nil) => item, provided item is not a splicable frob +;;; (op item 'nil) => (op item), if item is a splicable frob +;;; (op item (op a b c)) => (op item a b c) + +(defun bq-attach-append (op item result) + (cond ((and (null-or-quoted item) (null-or-quoted result)) + (list *bq-quote* (append (cadr item) (cadr result)))) + ((or (null result) (equal result *bq-quote-nil*)) + (if (bq-splicing-frob item) (list op item) item)) + ((and (consp result) (eq (car result) op)) + (list* (car result) item (cdr result))) + (t (list op item result)))) + +;;; The effec tof BQ-ATTACH-CONSES is to produce a form as if by +;;; `(LIST* ,@items ,result) but some simplifications are done +;;; on the fly. +;;; +;;; (LIST* 'a 'b 'c 'd) => '(a b c . d) +;;; (LIST* a b c 'nil) => (LIST a b c) +;;; (LIST* a b c (LIST* d e f g)) => (LIST* a b c d e f g) +;;; (LIST* a b c (LIST d e f g)) => (LIST a b c d e f g) + +(defun bq-attach-conses (items result) + (cond ((and (every #'null-or-quoted items) + (null-or-quoted result)) + (list *bq-quote* + (append (mapcar #'cadr items) (cadr result)))) + ((or (null result) (equal result *bq-quote-nil*)) + (cons *bq-list* items)) + ((and (consp result) + (or (eq (car result) *Bq-list*) + (eq (car result) *bq-list**))) + (cons (car result) (append items (cdr result)))) + (t (cons *bq-list** (append items (list result)))))) + +;;; Removes funny toeksn and changes (#:BQ-LIST* a b) into +;;; (CONS a b) instead of (LIST* a b), purely for readability. + +(defun bq-remove-tokens (x) + (cond ((eq x *bq-list*) 'list) + ((eq x *bq-append*) 'append) + ((eq x *bq-nconc*) 'nconc) + ((eq x *bq-list**) 'list*) + ((eq x *bq-quote*) 'quote) + ((atom x) x) + ((eq (car x) *bq-clobberable*) + (bq-remove-tokens (cadr x))) + ((and (eq (car x) *bq-list**) + (consp (cddr x)) + (null (cdddr x))) + (cons 'cons (maptree #'bq-remove-tokens (cdr x)))) + (t (maptree #'bq-remove-tokens x)))) + +) + +#-nil +(progn +(declaim (special *|`,|* *|`,.|* *|`,@|*)) + +;;;Backquote reads in as a call to the BACKQUOTE-EXPANDER macro. +;;;This makes it a little obscure to look at raw, but makes it possible for +;;;the pretty-printer to print things read in with backquote. + +(defvar *backquote-expand* t "If non-NIL, expand at read-time") + +(defmacro backquote-expander (*|`,|* *|`,.|* *|`,@|* form) + (declare (special *|`,|* *|`,.|* *|`,@|*)) + (multiple-value-bind (form constantp) (backquote-aux form) + (backq-form form constantp))) + +(defun backquote-aux (form) + ;;Doesn't try to optimize multiple CONS's into LIST/LIST*'s, leaving it up + ;;to the compiler. The code here is mainly concerned with folding + ;;constants, since the compiler is not allowed to do that in general. + (cond + ((simple-vector-p form) + (let ((elts ()) (i (length form))) + (until (%izerop i) (push (svref form (setq i (%i- i 1))) elts)) + (multiple-value-bind (elts quotedp) (backquote-aux elts) + (if quotedp + (values (list-to-vector elts) t) + (list 'list-to-vector elts))))) + ((self-evaluating-p form) (values form t)) + ((atom form) (values form t)) + ((eq (%car form) 'backquote-expander) (backquote-aux (macroexpand-1 form))) + ((eq (%car form) *|`,|*) (%cdr form)) + ((eq (%car form) *|`,@|*) (error "Misplaced ,@~S after backquote" (%cdr form))) + ((eq (%car form) *|`,.|*) (error "Misplaced ,.~S after backquote" (%cdr form))) + (t (let* ((car (%car form)) + (splice (and (consp car) (if (eq (%car car) *|`,@|*) 'append + (if (eq (%car car) *|`,.|*) 'nconc))))) + (multiple-value-bind (cdr qd) (backquote-aux (%cdr form)) + (if splice + (cond ((null (%cdr car)) (values cdr qd)) + ((null cdr) (values (%cdr car) (self-evaluating-p (%cdr car)))) + (t (list splice (%cdr car) (backq-form cdr qd)))) + (multiple-value-bind (car qa) (backquote-aux car) + (cond ((and qa qd) (values (cons car cdr) t)) + ((null cdr) (list 'list car)) + (t (list 'list* ; was CONS + (backq-form car qa) (backq-form cdr qd))))))))))) + +(defun backq-form (form constantp) + (if (and constantp (not (self-evaluating-p form))) (list 'quote form) form)) + +(defparameter *backquote-stack* ()) + +(set-macro-character + #\` + (nfunction + |` reader| + (lambda (stream char &aux form) + (declare (ignore char)) + (setq form + (let* ((|`,| (make-symbol "`,")) + (|`,.| (make-symbol "`,.")) + (|`,@| (make-symbol "`,@"))) + (list 'backquote-expander |`,| |`,.| |`,@| + (let ((*backquote-stack* (list* |`,| |`,.| |`,@| *backquote-stack*))) + (read stream t nil t))))) + (if *backquote-expand* (values (macroexpand-1 form)) form)))) + +(set-macro-character + #\, + (nfunction + |, reader| + (lambda (stream char &aux (stack *backquote-stack*)) + (when (null stack) + (signal-reader-error stream "Comma not inside backquote")) + (let ((*backquote-stack* (cdddr stack))) + (setq char (tyi stream)) + (cond ((eq char #\@) + (cons (%caddr stack) (read stream t nil t))) + ((eq char #\.) + (cons (%cadr stack) (read stream t nil t))) + (t + (untyi char stream) + (cons (%car stack) (read stream t nil t)))))))) +) + +(provide 'backquote) Index: /branches/new-random/lib/backtrace-lds.lisp =================================================================== --- /branches/new-random/lib/backtrace-lds.lisp (revision 13309) +++ /branches/new-random/lib/backtrace-lds.lisp (revision 13309) @@ -0,0 +1,141 @@ +;;;-*-Mode: LISP; Package: CCL -*- +;;; +;;; Copyright (C) 2009 Clozure Associates +;;; Copyright (C) 1994-2001 Digitool, Inc +;;; This file is part of Clozure CL. +;;; +;;; Clozure CL is licensed under the terms of the Lisp Lesser GNU Public +;;; License , known as the LLGPL and distributed with Clozure CL as the +;;; file "LICENSE". The LLGPL consists of a preamble and the LGPL, +;;; which is distributed with Clozure CL as the file "LGPL". Where these +;;; conflict, the preamble takes precedence. +;;; +;;; Clozure CL is referenced in the preamble as the "LIBRARY." +;;; +;;; The LLGPL is also available online at +;;; http://opensource.franz.com/preamble.html + +;;; backtrace-lds.lisp +;;; low-level support for stack-backtrace dialog (Lisp Development System) + +(in-package "CCL") + + +(defparameter *saved-register-count* + #+x8632-target 0 + #+x8664-target 4 + #+ppc-target 8) + +(defparameter *saved-register-names* + #+x8632-target nil + #+x8664-target #(save3 save2 save1 save0) + #+ppc-target #(save7 save6 save5 save4 save3 save2 save1 save0)) + +(defun frame-function (frame context) + "Returns the function using the frame, and pc offset within the function, if known" + (declare (ignore context)) + (cfp-lfun (require-type frame 'integer))) + +(defun frame-supplied-arguments (frame context &key (unknown-marker (%unbound-marker))) + "Return a list of supplied arguments to the call which opened this frame, as best we can reconstruct it" + (multiple-value-bind (lfun pc) (cfp-lfun frame) + (multiple-value-bind (args valid) (supplied-argument-list context frame lfun pc) + (if (not valid) + unknown-marker + (if (eq unknown-marker (%unbound-marker)) + args + (substitute unknown-marker (%unbound-marker) args)))))) + +(defun frame-named-variables (frame context &key (unknown-marker (%unbound-marker))) + "Returns an alist of (NAME . VALUE) of all named variables in this frame." + (multiple-value-bind (lfun pc) (cfp-lfun frame) + (multiple-value-bind (args locals) (arguments-and-locals context frame lfun pc unknown-marker) + (if (eq unknown-marker (%unbound-marker)) + (append args locals) + (substitute unknown-marker (%unbound-marker) (append args locals)))))) + + +(defun frame-arguments-and-locals (frame context &key unknown-marker) + "Return two values, the arguments and the locals, known for this frame, as alists of (name . value)" + (multiple-value-bind (lfun pc) (cfp-lfun frame) + (arguments-and-locals context frame lfun pc unknown-marker))) + +;;; Returns three values: (ARG-VALUES TYPES NAMES), solely for the benefit +;;; of the FRAME-ARGUMENTS function in SLIME's swank-openmcl.lisp. +;;; ARG-VALUES is a list of the values of the args supplied to the function +;;; TYPES is a list of (for bad historical reasons) strings .describing +;;; whether they're "required", "optional", etc. SLIME only really +;;; cares about whether this is equal to "keyword" or not. +;;; NAMES is a list of symbols which name the args. +;; 7/13/2009: This is now deprecated. Use frame-supplied-arguments. +(defun frame-supplied-args (frame lfun pc child context) + (declare (ignore child)) + (if (null pc) + (values nil nil nil) + (if (<= pc target::arg-check-trap-pc-limit) + (values (arg-check-call-arguments frame lfun) nil nil) + (multiple-value-bind (arglist valid) (arglist-from-map lfun) + (if (not valid) + (values nil nil nil) + (let* ((args (arguments-and-locals context frame lfun pc)) + (state :required)) + (collect ((arg-values) + (types) + (names)) + (dolist (arg arglist) + (if (or (member arg lambda-list-keywords) + (eq arg '&lexpr)) + (setq state arg) + (let* ((pair (pop args))) + (case state + (&lexpr + (with-list-from-lexpr (rest (cdr pair)) + (dolist (r rest) (arg-values r) (names nil) (types nil))) + (return)) + (&rest + (dolist (r (cdr pair)) (arg-values r) (names nil) (types nil)) + (return)) + (&key + (arg-values arg) + (names nil) + (types nil))) + (let* ((value (cdr pair))) + (if (eq value (%unbound-marker)) + (return)) + (names (car pair)) + (arg-values value) + (types nil))))) + (values (arg-values) (types) (names))))))))) + + +#| +(setq *save-local-symbols* t) + +(defun test (flip flop &optional bar) + (let ((another-one t) + (bar 'quux)) + (break))) + +(test '(a b c d) #\a) + +(defun closure-test (flim flam) + (labels ((inner (x) + (let ((ret (list x flam))) + (break)))) + (inner flim) + (break))) + +(closure-test '(a b c) 'quux) + +(defun set-test (a b) + (break) + (+ a b)) + +(set-test 1 'a) + +||# + + +(provide 'backtrace-lds) + +; End of backtrace-lds.lisp Index: /branches/new-random/lib/backtrace.lisp =================================================================== --- /branches/new-random/lib/backtrace.lisp (revision 13309) +++ /branches/new-random/lib/backtrace.lisp (revision 13309) @@ -0,0 +1,702 @@ +;;;-*-Mode: LISP; Package: CCL -*- +;;; +;;; Copyright (C) 2009 Clozure Associates +;;; Copyright (C) 1994-2001 Digitool, Inc +;;; This file is part of Clozure CL. +;;; +;;; Clozure CL is licensed under the terms of the Lisp Lesser GNU Public +;;; License , known as the LLGPL and distributed with Clozure CL as the +;;; file "LICENSE". The LLGPL consists of a preamble and the LGPL, +;;; which is distributed with Clozure CL as the file "LGPL". Where these +;;; conflict, the preamble takes precedence. +;;; +;;; Clozure CL is referenced in the preamble as the "LIBRARY." +;;; +;;; The LLGPL is also available online at +;;; http://opensource.franz.com/preamble.html + +;;; backtrace.lisp +;;; low-level support for stack-backtrace printing + +(in-package "CCL") + +#+ppc-target (require "PPC-BACKTRACE") +#+x86-target (require "X86-BACKTRACE") + + +(defparameter *backtrace-show-internal-frames* nil) +(defparameter *backtrace-print-level* 2) +(defparameter *backtrace-print-length* 5) + +(defparameter *backtrace-format* #+ccl-0711 :direct #-ccl-0711 :traditional + "If :TRADITIONAL, shows calls to non-toplevel functions using FUNCALL, and shows frame address values. + If :DIRECT, uses a more streamlined format.") + +(defun context-for-suspended-tcr (tcr) + (let ((frame-ptr (%tcr-frame-ptr tcr))) + (new-backtrace-info nil + frame-ptr ;; youngest - not used + frame-ptr ;; oldest - not used + tcr + nil ;; condition - not used + frame-ptr ;; current + #+ppc-target *fake-stack-frames* + #+x86-target frame-ptr + (%fixnum-ref tcr target::tcr.db-link) + 0 ;; break level - not used + ))) + + +(defun backtrace-as-list (&key + context + process + origin + (count target::target-most-positive-fixnum) + (start-frame-number 0) + (print-level *backtrace-print-level*) + (print-length *backtrace-print-length*) + (show-internal-frames *backtrace-show-internal-frames*)) + "Returns a list representing the backtrace. +Each element in the list is a list that describes the call in one stack frame: + (function arg1 arg2 ...) +The arguments are represented by strings, the function is a symbol or a function +object." + (let* ((*backtrace-print-level* print-level) + (*backtrace-print-length* print-length) + (*backtrace-format* :list) + (result nil)) + (map-call-frames (lambda (p context) + (multiple-value-bind (lfun pc) (cfp-lfun p) + (push (if lfun + (backtrace-call-arguments context p lfun pc) + "?????") + result))) + :context context + :process process + :origin origin + :count count + :start-frame-number start-frame-number + :test (and (not show-internal-frames) 'function-frame-p)) + (nreverse result))) + +(defun print-call-history (&key context + process + origin + (detailed-p t) + (count target::target-most-positive-fixnum) + (start-frame-number 0) + (stream *debug-io*) + (print-level *backtrace-print-level*) + (print-length *backtrace-print-length*) + (show-internal-frames *backtrace-show-internal-frames*) + (format *backtrace-format*)) + (let ((*backtrace-print-level* print-level) + (*backtrace-print-length* print-length) + (*backtrace-format* format) + (*standard-output* stream) + (*print-circle* nil) + (frame-number (or start-frame-number 0))) + (map-call-frames (lambda (p context) + (multiple-value-bind (lfun pc) (cfp-lfun p) + (unless (and (typep detailed-p 'fixnum) + (not (= (the fixnum detailed-p) frame-number))) + (%show-stack-frame-label frame-number p context lfun pc detailed-p) + (when detailed-p + (if (or (eq detailed-p :raw) (null lfun)) + (%show-stack-frame p context lfun pc) + (%show-args-and-locals p context lfun pc))) + (incf frame-number)))) + :context context + :process process + :origin origin + :count count + :start-frame-number start-frame-number + :test (and (not show-internal-frames) 'function-frame-p)) + (values))) + +(defun function-frame-p (p context) + (and (not (catch-csp-p p context)) (cfp-lfun p))) + +(defun map-call-frames (fn &key context + process + origin + (count target::target-most-positive-fixnum) + (start-frame-number 0) + test) + (when (and context process (neq (bt.tcr context) (process-tcr process))) + (error "Context ~s doesn't correspond to the process ~s" context process)) + (let ((tcr (cond (context (bt.tcr context)) + (process (process-tcr process)) + (t (%current-tcr)))) + (*print-catch-errors* t) + (*signal-printing-errors* nil)) + (if (eq tcr (%current-tcr)) + (%map-call-frames-internal fn context (or origin (%get-frame-ptr)) count start-frame-number test) + (unwind-protect + (progn + (%suspend-tcr tcr) + (when (null context) + (setq context (context-for-suspended-tcr tcr))) + (%map-call-frames-internal fn context (or origin (bt.current context)) count start-frame-number test)) + (%resume-tcr tcr)))) + nil) + +; RAW case +(defun %show-stack-frame (p context lfun pc) + (handler-case + (multiple-value-bind (count vsp parent-vsp) (count-values-in-frame p context) + (declare (fixnum count)) + (dotimes (i count) + (multiple-value-bind (var type name) + (nth-value-in-frame p i context lfun pc vsp parent-vsp) + (format t "~& ~D " i) + (when name (format t "~s" name)) + (let* ((*print-length* *backtrace-print-length*) + (*print-level* *backtrace-print-level*)) + (format t ": ~s" var)) + (when type (format t " (~S)" type))))) + (error () (format t "#"))) + (terpri) + (terpri)) + +(defun %show-args-and-locals (p context lfun pc) + (handler-case + (let* ((unavailable (cons nil nil))) + (multiple-value-bind (args locals) (arguments-and-locals context p lfun pc unavailable) + (case *backtrace-format* + (:direct + (format t "~& Arguments: ~:s" (arglist-from-map lfun))) + (t (format t "~& ~s" (arglist-from-map lfun)))) + (let* ((*print-length* *backtrace-print-length*) + (*print-level* *backtrace-print-level*)) + (flet ((show-pair (pair prefix) + (destructuring-bind (name . val) pair + (format t "~&~a~s: " prefix name) + (if (eq val unavailable) + (format t "#") + (format t "~s" val))))) + (case *backtrace-format* + (:direct + (when args + (dolist (arg args) + (show-pair arg " "))) + (when locals + ;; This shows all bindings (including specials), but help on debugger + ;; commands refers to "locals", so say both words... + (format t "~& Local bindings:") + (dolist (loc locals) + (show-pair loc " ")))) + (t + (dolist (arg args) + (show-pair arg " ")) + (terpri) + (terpri) + (dolist (loc locals) + (show-pair loc " ")))))))) + (error () (format t "#"))) + (terpri) + (terpri)) + + +(defun backtrace-call-arguments (context cfp lfun pc) + (nconc (let* ((name (function-name lfun))) + (if (function-is-current-definition? lfun) + (list name) + (case *backtrace-format* + (:direct + (list (format nil "~s" (or name lfun)))) + (:list + (list 'funcall (format nil "~s" (or name lfun)))) + (t (list 'funcall `(function ,(concatenate 'string "#<" (%lfun-name-string lfun) ">"))))))) + (backtrace-supplied-args context cfp lfun pc))) + +(defun backtrace-supplied-args (context frame lfun pc) + (multiple-value-bind (args valid) (supplied-argument-list context frame lfun pc) + (if (not valid) + '("???") + (loop for arg in args + collect (if (eq arg (%unbound-marker)) + "?" + (let* ((*print-length* *backtrace-print-length*) + (*print-level* *backtrace-print-level*)) + (format nil "~s" arg))))))) + +;;; Return a list of "interesting" frame addresses in context, most +;;; recent first. +(defun %stack-frames-in-context (context &optional (include-internal *backtrace-show-internal-frames*)) + (collect ((frames)) + (do* ((p (bt.youngest context) (parent-frame p context)) + (q (bt.oldest context))) + ((eql p q) (frames)) + (when (or (not (catch-csp-p p context)) include-internal) + (when (or (cfp-lfun p) include-internal) + (frames p)))))) + +(defun %map-call-frames-internal (fn context origin count skip-initial test) + (when (null skip-initial) (setq skip-initial 0)) + (when (null count) (setq count target::target-most-positive-fixnum)) + (unless (eq (last-frame-ptr context origin) (last-frame-ptr context)) + (error "Origin ~s is not in the stack of ~s" origin context)) + (let ((q (last-frame-ptr context)) + (frame-number 0)) + (do ((p origin (parent-frame p context))) + ((or (null p) (eq p q) (%stack< q p context) (<= count 0)) nil) + (when (or (null test) (funcall test p context)) + (when (<= skip-initial frame-number) + (funcall fn p context) + (decf count)) + (incf frame-number))))) + +(defun %show-stack-frame-label (frame-number p context lfun pc detailed-p) + (case *backtrace-format* + (:direct + (let ((call (backtrace-call-arguments context p lfun pc))) + (format t "~&~3D: ~a ~a~@d~:[~; [Exception]~]" + frame-number + (if lfun + (if detailed-p (car call) call) + "") + "at pc " + pc + (exception-frame-p p)))) + (t (format t "~&~c(~x) : ~D ~a ~d" + (if (exception-frame-p p) #\* #\space) + (index->address p) frame-number + (if lfun (backtrace-call-arguments context p lfun pc)) + pc)))) + + +(defun %access-lisp-data (vstack-index) + (%fixnum-ref vstack-index)) + +(defun %store-lisp-data (vstack-index value) + (setf (%fixnum-ref vstack-index) value)) + +(defun closed-over-value (data) + (if (closed-over-value-p data) + (uvref data 0) + data)) + +(defun set-closed-over-value (value-cell value) + (setf (uvref value-cell 0) value)) + + + +;;; Act as if VSTACK-INDEX points at some lisp data & return that data. +(defun access-lisp-data (vstack-index) + (closed-over-value (%access-lisp-data vstack-index))) + +(defun find-local-name (cellno lfun pc) + (let* ((n cellno)) + (when lfun + (multiple-value-bind (mask where) (registers-used-by lfun pc) + (if (and where (< (1- where) n (+ where (logcount mask)))) + (let ((j *saved-register-count*)) + (decf n where) + (loop (loop (if (logbitp (decf j) mask) (return))) + (if (< (decf n) 0) (return))) + (values (format nil "saved ~a" (aref *saved-register-names* j)) + nil)) + (multiple-value-bind (nreq nopt restp nkeys junk optinitp junk ncells nclosed) + (if lfun (function-args lfun)) + (declare (ignore junk optinitp)) + (if nkeys (setq nkeys (+ nkeys nkeys))) + (values + (if (and ncells (< n ncells)) + (if (< n nclosed) + :inherited + (if (< (setq n (- n nclosed)) nreq) + "required" + (if (< (setq n (- n nreq)) nopt) + "optional" + (progn + (setq n (- n nopt)) + (progn + (if (and nkeys (< n nkeys)) + (if (not (logbitp 0 n)) ; a keyword + "keyword" + "key-supplied-p") + (progn + (if nkeys (setq n (- n nkeys))) + (if (and restp (zerop n)) + "rest" + "opt-supplied-p"))))))))) + (match-local-name cellno (function-symbol-map lfun) pc)))))))) + +(defun map-entry-value (context cfp lfun pc idx unavailable) + (declare (fixnum pc idx)) + (let* ((info (function-symbol-map lfun))) + (if (null info) + unavailable + (let* ((addrs (cdr info)) + (i (* 3 idx)) + (addr (svref addrs i)) + (startpc (svref addrs (the fixnum (+ i 1)))) + (endpc (svref addrs (the fixnum (+ i 2))))) + (declare (fixnum i addr startpc endpc)) + (if (or (< pc startpc) + (>= pc endpc)) + unavailable + (let* ((value (if (= #o77 (ldb (byte 6 0) addr)) + (raw-frame-ref cfp context (ash addr (- (+ target::word-shift 6))) + unavailable) + (find-register-argument-value context cfp addr unavailable)))) + (if (typep value 'value-cell) + (uvref value 0) + value))))))) + +;;; Returns non-nil on success (not newval) +(defun set-map-entry-value (context cfp lfun pc idx newval) + (declare (fixnum pc idx)) + (let* ((unavailable (cons nil nil)) + (value (map-entry-value context cfp lfun pc idx unavailable))) + (if (eq value unavailable) + nil + (if (typep value 'value-cell) + (progn (setf (uvref value 0) newval) t) + + (let* ((addrs (cdr (function-symbol-map lfun))) + (addr (svref addrs (the fixnum (* 3 idx))))) + (declare (fixnum addr)) + (if (= #o77 (ldb (byte 6 0) addr)) + (raw-frame-set cfp context (ash addr (- (+ target::word-shift 6))) newval) + (set-register-argument-value context cfp addr newval)) + t))))) + + +(defun argument-value (context cfp lfun pc name &optional (quote t)) + (declare (fixnum pc)) + (let* ((info (function-symbol-map lfun)) + (unavailable (%unbound-marker))) + (if (null info) + unavailable + (let* ((names (car info)) + (addrs (cdr info))) + (do* ((nname (1- (length names)) (1- nname)) + (naddr (- (length addrs) 3) (- naddr 3))) + ((or (< nname 0) (< naddr 0)) unavailable) + (declare (fixnum nname naddr)) + (when (eq (svref names nname) name) + (let* ((value + (let* ((addr (svref addrs naddr)) + (startpc (svref addrs (the fixnum (1+ naddr)))) + (endpc (svref addrs (the fixnum (+ naddr 2))))) + (declare (fixnum addr startpc endpc)) + (if (or (< pc startpc) + (>= pc endpc)) + unavailable + (if (= #o77 (ldb (byte 6 0) addr)) + (raw-frame-ref cfp context (ash addr (- (+ target::word-shift 6))) + unavailable) + (find-register-argument-value context cfp addr unavailable)))))) + (if (typep value 'value-cell) + (setq value (uvref value 0))) + (if (or (not quote) (self-evaluating-p value)) + (return value) + (return (list 'quote value)))))))))) + + + +(defun raw-frame-ref (cfp context index bad) + (%raw-frame-ref cfp context index bad)) + +(defun raw-frame-set (cfp context index new) + (%raw-frame-set cfp context index new)) + +(defun find-register-argument-value (context cfp regval bad) + (%find-register-argument-value context cfp regval bad)) + +(defun set-register-argument-value (context cfp regval newval) + (%set-register-argument-value context cfp regval newval)) + + + +(defun dbg-form (frame-number) + (when *break-frame* + (let* ((cfp (nth-raw-frame frame-number *break-frame* nil))) + (if (and cfp (not (catch-csp-p cfp nil))) + (multiple-value-bind (function pc) + (cfp-lfun cfp) + (if (and function + (function-is-current-definition? function)) + (block %cfp-form + (collect ((form)) + (multiple-value-bind (nreq nopt restp keys allow-other-keys + optinit lexprp ncells nclosed) + (function-args function) + (declare (ignore ncells)) + (unless (or lexprp restp (> 0 nclosed) (> 0 nopt) keys allow-other-keys + optinit) + (let* ((name (function-name function))) + (multiple-value-bind (arglist win) + (arglist-from-map function) + (when (and win name (symbolp name)) + (form name) + (dotimes (i nreq) + (let* ((val (argument-value nil cfp function pc (pop arglist)))) + (if (closed-over-value-p val) + (setq val (%svref val target::value-cell.value-cell))) + (if (eq val (%unbound-marker)) + (return-from %cfp-form nil)) + (form val)))))))) + (form))))))))) + +(defun function-args (lfun) + "Returns 9 values, as follows: + req = number of required arguments + opt = number of optional arguments + restp = t if rest arg + keys = number of keyword arguments or NIL if &key not mentioned + allow-other-keys = t if &allow-other-keys present + optinit = t if any optional arg has non-nil default value or supplied-p + variable + lexprp = t if function is a lexpr, in which case all other values are + undefined. + ncells = number of stack frame cells used by all arguments. + nclosed = number of inherited values (now counted distinctly from required) + All numeric values (but ncells) are mod 64." + (let* ((bits (lfun-bits lfun)) + (req (ldb $lfbits-numreq bits)) + (opt (ldb $lfbits-numopt bits)) + (restp (logbitp $lfbits-rest-bit bits)) + (keyvect (lfun-keyvect lfun)) + (keys (and keyvect (length keyvect))) + (allow-other-keys (logbitp $lfbits-aok-bit bits)) + (optinit (logbitp $lfbits-optinit-bit bits)) + (lexprp (logbitp $lfbits-restv-bit bits)) + (nclosed (ldb $lfbits-numinh bits))) + (values req opt restp keys allow-other-keys optinit lexprp + (unless (or lexprp) + (+ req opt (if restp 1 0) (if keys (+ keys keys) 0) + (if optinit opt 0) nclosed)) + nclosed))) + +;;; If we can tell reliably, return the function's minimum number of +;;; non-inherited arguments, the maximum number of such arguments (or NIL), +;;; and the actual number of such arguments. We "can't tell" if either +;;; of the arguments to this function are null, and we can't tell reliably +;;; if any of the lfbits fields are full. +(defun min-max-actual-args (fn nargs) + (let* ((lfbits (if (and fn nargs) + (lfun-bits fn) + -1)) + (raw-req (ldb $lfbits-numreq lfbits)) + (raw-opt (ldb $lfbits-numopt lfbits)) + (raw-inh (ldb $lfbits-numinh lfbits))) + (declare (fixnum raw-req raw-opt raw-inh)) + (if (or (eql raw-req (1- (ash 1 (byte-size $lfbits-numreq)))) + (eql raw-opt (1- (ash 1 (byte-size $lfbits-numopt)))) + (eql raw-inh (1- (ash 1 (byte-size $lfbits-numinh))))) + (values nil nil nil) + (values raw-req + (unless (or (lfun-keyvect fn) + (logbitp $lfbits-rest-bit lfbits) + (logbitp $lfbits-restv-bit lfbits)) + (+ raw-req raw-opt)) + (- nargs raw-inh))))) + + + +(defun closed-over-value-p (value) + (eql target::subtag-value-cell (typecode value))) + + +(defun variables-in-scope (lfun pc) + ;; Return a list of all symbol names "in scope" in the function lfun + ;; at relative program counter PC, using the function's symbol map. + ;; The list will be ordered so that least-recent bindings appear first. + ;; Return a list of the matching symbol map entries as a second value + (when pc + (locally (declare (fixnum pc)) + (let* ((map (function-symbol-map lfun)) + (names (car map)) + (info (cdr map))) + (when map + (let* ((vars ()) + (indices ())) + (dotimes (i (length names) (values vars indices)) + (let* ((start-pc (aref info (1+ (* 3 i)))) + (end-pc (aref info (+ 2 (* 3 i))))) + (declare (fixnum start-pc end-pc)) + (when (and (>= pc start-pc) + (< pc end-pc)) + (push i indices) + (push (svref names i) vars)))))))))) + + +(defun arg-value (context cfp lfun pc unavailable name) + (multiple-value-bind (vars map-indices) (variables-in-scope lfun pc) + (multiple-value-bind (valid req opt rest keys) + (arg-names-from-map lfun pc) + (if valid + (let* ((nargs (+ (length req) (length opt) (if rest 1 0) (length keys))) + (pos (position name vars))) + (if (and pos (< pos nargs)) + (map-entry-value context cfp lfun pc (nth pos map-indices) unavailable) + unavailable)) + unavailable)))) + +(defun local-value (context cfp lfun pc unavailable name) + (multiple-value-bind (vars map-indices) (variables-in-scope lfun pc) + (multiple-value-bind (valid req opt rest keys) + (arg-names-from-map lfun pc) + (if valid + (let* ((nargs (+ (length req) (length opt) (if rest 1 0) (length keys))) + (names (nthcdr nargs vars)) + (indices (nthcdr nargs map-indices)) + (pos (if (typep name 'unsigned-byte) + name + (position name names :from-end t)))) + (if pos + (map-entry-value context cfp lfun pc (nth pos indices) unavailable) + unavailable)) + unavailable)))) + +(defun set-arg-value (context cfp lfun pc name new) + (multiple-value-bind (vars map-indices) (variables-in-scope lfun pc) + (multiple-value-bind (valid req opt rest keys) + (arg-names-from-map lfun pc) + (if valid + (let* ((nargs (+ (length req) (length opt) (if rest 1 0) (length keys))) + (pos (position name vars))) + (when (and pos (< pos nargs)) + (set-map-entry-value context cfp lfun pc (nth pos map-indices) new))))))) + +(defun set-local-value (context cfp lfun pc name new) + (multiple-value-bind (vars map-indices) (variables-in-scope lfun pc) + (multiple-value-bind (valid req opt rest keys) + (arg-names-from-map lfun pc) + (if valid + (let* ((nargs (+ (length req) (length opt) (if rest 1 0) (length keys))) + (names (nthcdr nargs vars)) + (indices (nthcdr nargs map-indices)) + (pos (if (typep name 'unsigned-byte) + name + (position name names :from-end t)))) + (if (and pos (< pos nargs)) + (set-map-entry-value context cfp lfun pc (nth pos indices) new))))))) + + +(defun arguments-and-locals (context cfp lfun pc &optional unavailable) + (multiple-value-bind (vars map-indices) (variables-in-scope lfun pc) + (collect ((args) + (inherited-indices) + (inherited-vars) + (locals)) + (multiple-value-bind (valid req opt rest keys) + (arg-names-from-map lfun pc) + (when valid + (let* ((numinh (ldb $lfbits-numinh (lfun-bits lfun)))) + (dotimes (i numinh) + (inherited-indices (pop map-indices)) + (inherited-vars (pop vars)))) + (let* ((nargs (+ (length req) (length opt) (if rest 1 0) (length keys))) + (nlocals (- (length vars) nargs)) + (local-vars (append (nthcdr nargs vars) (inherited-vars))) + (local-indices (append (nthcdr nargs map-indices) (inherited-indices))) + (arg-vars (if (<= nlocals 0) vars (nbutlast vars nlocals))) + (arg-indices (if (<= nlocals 0) map-indices (nbutlast map-indices nlocals)))) + (flet ((get-arg-value (name) + (let* ((pos (position name arg-vars :test #'eq))) + (when pos + (args (cons name (map-entry-value context cfp lfun pc (nth pos arg-indices) unavailable)))))) + (get-local-value (name) + (when name + (locals (cons name (map-entry-value context cfp lfun pc (pop local-indices) unavailable)))))) + (dolist (name req) + (get-arg-value name)) + (dolist (name opt) + (get-arg-value name)) + (when rest + (get-arg-value rest)) + (dolist (name keys) + (get-arg-value name)) + (dolist (name local-vars) + (get-local-value name))))) + (values (args) (locals)))))) + +;; Return list of supplied arguments, as best we can reconstruct it. +(defun supplied-argument-list (context frame lfun pc) + (if (null pc) + (values nil nil) + (if (<= pc target::arg-check-trap-pc-limit) + (values (arg-check-call-arguments frame lfun) t) + (multiple-value-bind (params valid) (arglist-from-map lfun) + (if (not valid) + (values nil nil) + (let* ((args (arguments-and-locals context frame lfun pc)) ;overkill, but will do. + (state :required) + (result ())) + (dolist (param params) + (if (or (member param lambda-list-keywords) (eq param '&lexpr)) + (setq state param) + (let* ((pair (pop args)) + (value (cdr pair))) + (case state + (&lexpr + (with-list-from-lexpr (rest value) + (dolist (r rest) (push r result))) + (return)) + (&rest + (dolist (r value) (push r result)) + (return)) + (&key (push param result))) + (push value result)))) + (values (nreverse result) t))))))) + + +(defun safe-cell-value (val) + val) + +(defun closure-closed-over-values (closure) + (when (typep closure 'compiled-lexical-closure) + (let* ((inner (closure-function closure)) + (nclosed (nth-value 8 (function-args inner))) + (names (car (function-symbol-map inner)))) + (when nclosed + (collect ((cells)) + (do* ((i (1- (length names)) (1- i)) + (k 0 (1+ k)) + (idx 2 (1+ idx))) + ((= k nclosed) (reverse (cells))) + (let* ((name (svref names i)) + (imm (nth-immediate closure idx))) + (cells (list name (if (closed-over-value-p imm) + (closed-over-value imm) + imm)))))))))) + + +;;; Find the oldest binding frame that binds the same symbol as +;;; FRAME in context. If found, return the saved value of that +;;; binding, else the value of the symbol in the context's thread. +(defun oldest-binding-frame-value (context frame) + (let* ((oldest nil) + (binding-index (%fixnum-ref frame (ash 1 target::fixnum-shift)))) + (do* ((db (db-link context) (%fixnum-ref db 0))) + ((eq frame db) + (if oldest + (%fixnum-ref oldest (ash 2 target::fixnum-shift)) + (let* ((symbol (binding-index-symbol binding-index))) + (if context + (symbol-value-in-tcr symbol (bt.tcr context)) + (%sym-value symbol))))) + (if (eq (%fixnum-ref db (ash 1 target::fixnum-shift)) binding-index) + (setq oldest db))))) + +(defun (setf oldest-binding-frame-value) (new context frame) + (let* ((oldest nil) + (binding-index (%fixnum-ref frame (ash 1 target::fixnum-shift)))) + (do* ((db (db-link context) (%fixnum-ref db 0))) + ((eq frame db) + (if oldest + (setf (%fixnum-ref oldest (ash 2 target::fixnum-shift)) new) + (let* ((symbol (binding-index-symbol binding-index))) + (if context + (setf (symbol-value-in-tcr symbol (bt.tcr context)) new) + (%set-sym-value symbol new))))) + (if (eq (%fixnum-ref db (ash 1 target::fixnum-shift)) binding-index) + (setq oldest db))))) + + + +;;; End of backtrace.lisp Index: /branches/new-random/lib/case-error.lisp =================================================================== --- /branches/new-random/lib/case-error.lisp (revision 13309) +++ /branches/new-random/lib/case-error.lisp (revision 13309) @@ -0,0 +1,70 @@ +; -*- Mode:Lisp; Package:CCL; -*- +;;; +;;; Copyright (C) 2009 Clozure Associates +;;; Copyright (C) 1994-2001 Digitool, Inc +;;; This file is part of Clozure CL. +;;; +;;; Clozure CL is licensed under the terms of the Lisp Lesser GNU Public +;;; License , known as the LLGPL and distributed with Clozure CL as the +;;; file "LICENSE". The LLGPL consists of a preamble and the LGPL, +;;; which is distributed with Clozure CL as the file "LGPL". Where these +;;; conflict, the preamble takes precedence. +;;; +;;; Clozure CL is referenced in the preamble as the "LIBRARY." +;;; +;;; The LLGPL is also available online at +;;; http://opensource.franz.com/preamble.html + +(in-package "CCL") + +;I wanted a read that would not error even when given a #< +; and also allow backspace and such. +(defun read-line-no-error (&optional (stream *standard-output*) &aux result) + (ignore-errors + (setq result (read-from-string (read-line stream) nil)) + (return-from read-line-no-error (values result t))) + (values nil nil)) + + + +;;;; Assert & Check-Type + +;;; Assert-Value-Prompt -- Internal +;;; +;;; Prompt for a new value to set a place to. We do a read-line, +;;; and if there is anything there, we eval it and return the second +;;; value true, otherwise it is false. +;;; +(defun assertion-value-prompt (place) + (let* ((nvals (length (nth-value 2 (get-setf-method-multiple-value place)))) + (vals nil)) + (dotimes (i nvals) + (if (eq nvals 1) + (format *query-io* "Value for ~S: " place) + (format *query-io* "Value ~D for ~S: " i place)) + (let* ((line (read-line *query-io*)) + (object (read-from-string line nil *eof-value*))) + (if (eq object *eof-value*) + (return) + (push (eval object) vals)))) + (values (nreverse vals) (not (null vals))))) + +(defun %assertion-failure (setf-places-p test-form string &rest condition-args) + (cerror + (if setf-places-p + "allow some places to be set and test the assertion again." + "test the assertion again.") + (cond + ((stringp string) + (make-condition 'simple-error + :format-control string + :format-arguments condition-args)) + ((null string) + (make-condition 'simple-error + :format-control "Failed assertion: ~S" + :format-arguments (list test-form))) + ((typep string 'condition) + (when condition-args (error "No args ~S allowed with a condition ~S" condition-args string)) + string) + (t (apply #'make-condition string condition-args))))) + Index: /branches/new-random/lib/ccl-export-syms.lisp =================================================================== --- /branches/new-random/lib/ccl-export-syms.lisp (revision 13309) +++ /branches/new-random/lib/ccl-export-syms.lisp (revision 13309) @@ -0,0 +1,951 @@ +;;-*-Mode: LISP; Package: CCL -*- +;;; +;;; Copyright (C) 2009 Clozure Associates +;;; Copyright (C) 1994-2001 Digitool, Inc +;;; This file is part of Clozure CL. +;;; +;;; Clozure CL is licensed under the terms of the Lisp Lesser GNU Public +;;; License , known as the LLGPL and distributed with Clozure CL as the +;;; file "LICENSE". The LLGPL consists of a preamble and the LGPL, +;;; which is distributed with Clozure CL as the file "LGPL". Where these +;;; conflict, the preamble takes precedence. +;;; +;;; Clozure CL is referenced in the preamble as the "LIBRARY." +;;; +;;; The LLGPL is also available online at +;;; http://opensource.franz.com/preamble.html + +(in-package "CCL") + +(eval-when (:compile-toplevel :load-toplevel :execute) + (export ;remember "CCL" at end of list + ;setq %ccl-package-export-syms + '( + local + set-local + @ + *elements-per-buffer* + save-application + def-load-pointers + *save-exit-functions* + *restore-lisp-functions* + *lisp-cleanup-functions* + *lisp-startup-functions* + defloadvar + defstatic + *break-on-warnings* + ; misc + record-source-file + get-source-files + edit-definition + edit-definition-p + *loading-file-source-file* + find-definition-sources + define-definition-type + definition-type + definition-type-name + *save-source-locations* + function-source-note + source-note + source-note-p + source-note-filename + source-note-start-pos + source-note-end-pos + source-note-text + ensure-source-note-text + *record-pc-mapping* + find-source-note-at-pc + caller-functions + *svn-program* + + show-documentation + %set-toplevel + toplevel-loop + toplevel-function + repl-function-name + toplevel + *listener-prompt-format* + cancel + catch-cancel + throw-cancel + *backtrace-on-break* + *show-restarts-on-break* + print-call-history + dbg-form + *backtrace-print-level* + *backtrace-print-length* + *backtrace-show-internal-frames* + *backtrace-format* + map-call-frames + frame-function + frame-supplied-arguments + frame-named-variables + apply-in-frame + *quit-on-eof* + *quit-interrupt-hook* + *break-hook* + *top-error-frame* + *select-interactive-process-hook* + interrupt-signal-condition + macroexpand-all + compiler-macroexpand + compiler-macroexpand-1 + compile-user-function + uncompile-function + report-compiler-warning + compiler-warning + style-warning + compiler-warning-source-note + compiler-warning-function-name + *merge-compiler-warnings* + abort-break + *trace-print-level* + *trace-print-length* + *trace-bar-frequency* + trace-function + *ignore-extra-close-parenthesis* + advise + unadvise + advisedp + nfunction + function-name + setf-function-p + setf-function-spec-name + name-of + + assq + bignump + bitp + constant-symbol-p + proclaimed-special-p + delq + fixnump + quit + include + memq + nremove + ;put + ratiop + structure-typep + structurep + type-specifier-p + displaced-array-p + without-interrupts + with-interrupts-enabled + true + false + neq + whitespacep + *print-structure* + *print-simple-vector* + *print-simple-bit-vector* + *print-string-length* + *print-abbreviate-quote* + *signal-printing-errors* + unignore + *warn-if-redefine-kernel* + without-duplicate-definition-warnings + require-type + dovector + debugging-function-name + *make-package-use-defaults* + *autoload-lisp-package* + tyo + tyi + untyi + compiled-lexical-closure ; the type name + lsh + + ;; Arguments, image name, etc. + *command-line-argument-list* + *unprocessed-command-line-arguments* + *heap-image-name* + + ; The MOP + accessor-method-slot-definition + add-dependent + add-direct-method + add-direct-subclass + add-method + class-default-initargs + class-direct-default-initargs + class-direct-slots + class-direct-subclasses + class-direct-superclasses + class-finalized-p + class-precedence-list + class-prototype + class-slots + compute-applicable-methods + compute-applicable-methods-using-classes + compute-class-precedence-list + compute-default-initargs + compute-discriminating-function + compute-effective-method + compute-effective-slot-definition + compute-slots + direct-slot-definition-class + effective-slot-definition-class + ensure-class + ensure-class-using-class + ensure-generic-function-using-class + eql-specializer + eql-specializer-object + extract-lambda-list + extract-specializer-names + finalize-inheritance + find-method-combination + funcallable-standard-instance-access + generic-function-argument-precedence-order + generic-function-declarations + generic-function-lambda-list + generic-function-method-class + generic-function-method-combination + generic-function-methods + generic-function-name + intern-eql-specializer + make-method-lambda + map-dependents + method-function + method-generic-function + method-lambda-list + method-name + method-specializers + method-qualifiers + slot-definition-documentation + slot-definition-allocation + slot-definition-initargs + slot-definition-initform + slot-definition-initfunction + slot-definition-name + slot-definition-type + slot-definition-readers + slot-definition-writers + slot-definition-location + reader-method-class + remove-dependent + remove-direct-method + remove-direct-subclass + remove-method + set-funcallable-instance-function + slot-boundp-using-class + slot-makunbound-using-class + slot-value-using-class + specializer-direct-generic-functions + specializer-direct-methods + standard-instance-access + update-dependent + validate-superclass + writer-method-class + + metaobject + long-method-combination + short-method-combination + standard-accessor-method + standard-reader-method + standard-writer-method + specializer + + funcallable-standard-class + funcallable-standard-object + forward-referenced-class + standard-direct-slot-definition + standard-effective-slot-definition + + standard-slot-definition + slot-definition + effective-slot-definition + direct-slot-definition + + clear-specializer-direct-methods-caches + *check-call-next-method-with-args* + clear-gf-cache + clear-all-gf-caches + clear-clos-caches + + method-exists-p + method-specializers + class-own-wrapper + specializer-direct-methods + specializer-direct-generic-functions + copy-instance + + override-one-method-one-arg-dcode + optimize-generic-function-dispatching + + ;; Not MOP + string-studlify ;** DO NOT REMOVE, DO NOT DOCUMENT + nstring-studlify ;** DO NOT REMOVE, DO NOT DOCUMENT + + ; User Options + *compile-definitions* + *record-source-file* + *save-doc-strings* + *fasl-save-doc-strings* + *warn-if-redefine* + *break-on-errors* + *save-definitions* + *fasl-save-definitions* + *save-local-symbols* + *fasl-save-local-symbols* + *save-arglist-info* + *always-eval-user-defvars* + + ;These 3 need to be set by the user in order for the correspondingly named + ;functions to return something other than "unspecified". + *short-site-name* + *long-site-name* + machine-owner + + init-list-default + fset + + ; Files. + mac-default-directory + current-directory + directory-pathname-p + full-pathname + temp-pathname + create-file + create-directory + file-create-date + set-file-write-date + set-file-create-date + copy-file + lock-file + unlock-file + file-locked-p + directoryp + + + *module-search-path* + *module-provider-functions* + *.lisp-pathname* + *.fasl-pathname* + *pathname-translations-pathname* + *default-external-format* + *default-line-termination* + pathname-encoding-name + with-filename-cstrs + get-foreign-namestring + native-translated-namestring + native-to-pathname + fasl-concatenate + event-ticks + set-event-ticks + event-dispatch + *ticks-per-second* + + *application* + arglist + arglist-string + arglist-to-stream + function-args + + + get-string-from-user + with-terminal-input + *request-terminal-input-via-break* + add-auto-flush-stream + remove-auto-flush-stream + select-item-from-list + + + ; Low-level + %stack-block + %vstack-block + %get-byte + %get-signed-byte + %get-unsigned-byte + %get-word + %get-signed-word + %get-unsigned-word + %get-long + %get-unsigned-long + %get-signed-long + %%get-signed-longlong + %%get-unsigned-longlong + %get-fixnum + %get-point + %get-ptr + %get-string + %get-cstring + %str-from-ptr + %get-double-float + %get-single-float + %inc-ptr + %incf-ptr + %setf-macptr + %null-ptr + %null-ptr-p + %ptr-eql + %ptr-to-int + %int-to-ptr + %word-to-int + %address-of + ensure-simple-string + %copy-float + with-macptrs + pointerp + macptrp + macptr + rlet + rletz + make-record + pref + rref + paref + with-cstrs + with-encoded-cstrs + with-string-vector + with-pointer-to-ivector + get-encoded-string + +null-ptr+ + free + define-entry-point + define-callback + defcallback + ff-call + %ff-call + %reference-external-entry-point + foreign-symbol-entry + foreign-symbol-address + def-foreign-type + + uvref + uvectorp + uvsize + + ;;Streams (should be made more complete sometime) + input-stream + output-stream + stream-eofp + + open-file-streams + note-open-file-stream + remove-open-file-stream + clear-open-file-streams + stream-line-length + string-output-stream + truncating-string-stream + make-truncating-string-stream + stream-rubout-handler + + + ; Tools + gc + egc + egc-enabled-p + egc-active-p + configure-egc + egc-configuration + gccounts + gctime + lisp-heap-gc-threshold + use-lisp-heap-gc-threshold + set-lisp-heap-gc-threshold + gc-retain-pages + gc-retaining-pages + gc-verbose + gc-verbose-p + weak-gc-method + *trace-max-indent* + *trace-level* + static-cons + free-static-conses + reserved-static-conses + + population + make-population + population-type + population-contents + + hash-table-weak-p + + compiler-let + + + COMPILER-POLICY + CURRENT-COMPILER-POLICY + CURRENT-FILE-COMPILER-POLICY + FIND-MACTYPE + NEW-COMPILER-POLICY + SET-CURRENT-COMPILER-POLICY + SET-CURRENT-FILE-COMPILER-POLICY + STANDARD-METHOD-COMBINATION + STREAM-DEVICE + STREAM-DIRECTION + *current-process* + PROCESS + all-processes + process-preset + process-reset + process-reset-and-enable + process-enable + process-abort + process-kill + process-interrupt + process-name + process-run-function + make-process + process-suspend-count + process-serial-number + process-initial-form + process-whostate + process-priority + process-total-run-time + process-creation-time + clear-process-run-time + process-resume + process-suspend + process-exhausted-p + let-globally + process-wait + process-wait-with-timeout + process-allow-schedule + process-kill-issued + process-termination-semaphore + process-allocation-quantum + default-allocation-quantum + current-process-allocation-quantum + join-process + + *HOST-PAGE-SIZE* + + make-lock + lock-name + with-lock-grabbed + grab-lock + release-lock + try-lock + lock + read-write-lock + lock-not-owner + + lock-acquisition-status + clear-lock-acquisition-status + lock-acquisition + make-lock-acquisition + + semaphore-notification-status + clear-semaphore-notification-status + semaphore-notification + make-semaphore-notification + + make-read-write-lock + with-read-lock + with-write-lock + symbol-value-in-process + + make-semaphore + wait-on-semaphore + timed-wait-on-semaphore + signal-semaphore + semaphore + + process-input-wait + process-output-wait + ; termination + terminate-when-unreachable + terminate + drain-termination-queue + cancel-terminate-when-unreachable + termination-function + *enable-automatic-termination* + + get-fpu-mode + set-fpu-mode + + ; There's more. Like... + + *listener-indent* + *error-print-circle* + *break-loop-when-uninterruptable* + + application-error + application-name + application-init-file + + cwd + + ;; Old CLtL2 stuff: + + *applyhook* + *evalhook* + applyhook + augment-environment + declaration-information + define-declaration + define-setf-method + evalhook + enclose + function-information + generic-flet + generic-labels + get-setf-method + get-setf-method-multiple-value + parse-macro + variable-information + with-added-methods + + ;; Gray Streams + fundamental-stream + fundamental-input-stream + fundamental-output-stream + fundamental-character-stream + fundamental-character-input-stream + fundamental-character-output-stream + fundamental-binary-stream + fundamental-binary-input-stream + fundamental-binary-output-stream + + stream-read-char + stream-unread-char + stream-read-char-no-hang + stream-peek-char + stream-listen + stream-read-line + stream-clear-input + + stream-write-char + stream-line-column + stream-start-line-p + stream-write-string + stream-terpri + stream-fresh-line + stream-force-output + stream-clear-output + stream-advance-to-column + + stream-read-byte + stream-write-byte + + stream-read-ivector + stream-write-ivector + + stream-read-list + stream-write-list + stream-read-vector + stream-write-vector + + stream-input-timeout + stream-output-timeout + with-input-timeout + with-output-timeout + stream-deadline + + input-timeout + output-timeout + communication-deadline-expired + + make-heap-ivector + dispose-heap-ivector + ;; + external + external-call + open-shared-library + close-shared-library + shlib + external-entry-point + use-interface-dir + unuse-interface-dir + create-interfaces + ;; + run-program + external-process + signal-external-process + external-process-id + external-process-input-stream + external-process-output-stream + external-process-error-stream + external-process-status + ;; + *altivec-available* + altivec-available-p + *altivec-lapmacros-maintain-vrsave-p* + ;; + *alternate-line-terminator* + ;; + set-user-environment + set-development-environment + *resident-editor-hook* + cpu-count + *report-time-function* + ;; + compile-ccl + xcompile-ccl + xload-level-0 + rebuild-ccl + update-ccl + test-ccl + defglobal + + getenv + setenv + + external-format + make-external-format + external-format-character-encoding + external-format-line-termination + character-encoding + define-character-encoding + describe-character-encoding + describe-character-encodings + get-character-encoding + lookup-character-encoding + string-size-in-octets + encode-string-to-octets + count-characters-in-octet-vector + decode-string-from-octets + *terminal-character-encoding-name* + *default-file-character-encoding* + *default-socket-character-encoding* + ;; Mapped files. + map-file-to-ivector + map-file-to-octet-vector + unmap-ivector + unmap-octet-vector + ;; Miscellany + heap-utilization + collect-heap-utilization + + external-process-creation-failure + + ) "CCL" + ) + ) + +;;; Define a package for MOP extensions. +(defpackage "OPENMCL-MOP" + (:use) + (:import-from + "CCL" + "ACCESSOR-METHOD-SLOT-DEFINITION" + "ADD-DEPENDENT" + "ADD-DIRECT-METHOD" + "ADD-DIRECT-SUBCLASS" + "ADD-METHOD" + "CLASS-DEFAULT-INITARGS" + "CLASS-DIRECT-DEFAULT-INITARGS" + "CLASS-DIRECT-SLOTS" + "CLASS-DIRECT-SUBCLASSES" + "CLASS-DIRECT-SUPERCLASSES" + "CLASS-FINALIZED-P" + "CLASS-PRECEDENCE-LIST" + "CLASS-PROTOTYPE" + "CLASS-SLOTS" + "COMPUTE-APPLICABLE-METHODS" + "COMPUTE-APPLICABLE-METHODS-USING-CLASSES" + "COMPUTE-CLASS-PRECEDENCE-LIST" + "COMPUTE-DEFAULT-INITARGS" + "COMPUTE-DISCRIMINATING-FUNCTION" + "COMPUTE-EFFECTIVE-METHOD" + "COMPUTE-EFFECTIVE-SLOT-DEFINITION" + "COMPUTE-SLOTS" + "DIRECT-SLOT-DEFINITION-CLASS" + "EFFECTIVE-SLOT-DEFINITION-CLASS" + "ENSURE-CLASS" + "ENSURE-CLASS-USING-CLASS" + "ENSURE-GENERIC-FUNCTION-USING-CLASS" + "EQL-SPECIALIZER" + "EQL-SPECIALIZER-OBJECT" + "EXTRACT-LAMBDA-LIST" + "EXTRACT-SPECIALIZER-NAMES" + "FINALIZE-INHERITANCE" + "FIND-METHOD-COMBINATION" + "FUNCALLABLE-STANDARD-INSTANCE-ACCESS" + "GENERIC-FUNCTION-ARGUMENT-PRECEDENCE-ORDER" + "GENERIC-FUNCTION-DECLARATIONS" + "GENERIC-FUNCTION-LAMBDA-LIST" + "GENERIC-FUNCTION-METHOD-CLASS" + "GENERIC-FUNCTION-METHOD-COMBINATION" + "GENERIC-FUNCTION-METHODS" + "GENERIC-FUNCTION-NAME" + "INTERN-EQL-SPECIALIZER" + "MAKE-METHOD-LAMBDA" + "MAP-DEPENDENTS" + "METHOD-FUNCTION" + "METHOD-GENERIC-FUNCTION" + "METHOD-LAMBDA-LIST" + "METHOD-NAME" + "METHOD-SPECIALIZERS" + "METHOD-QUALIFIERS" + "SLOT-DEFINITION-DOCUMENTATION" + "SLOT-DEFINITION-ALLOCATION" + "SLOT-DEFINITION-INITARGS" + "SLOT-DEFINITION-INITFORM" + "SLOT-DEFINITION-INITFUNCTION" + "SLOT-DEFINITION-NAME" + "SLOT-DEFINITION-TYPE" + "SLOT-DEFINITION-READERS" + "SLOT-DEFINITION-WRITERS" + "SLOT-DEFINITION-LOCATION" + "READER-METHOD-CLASS" + "REMOVE-DEPENDENT" + "REMOVE-DIRECT-METHOD" + "REMOVE-DIRECT-SUBCLASS" + "REMOVE-METHOD" + "SET-FUNCALLABLE-INSTANCE-FUNCTION" + "SLOT-BOUNDP-USING-CLASS" + "SLOT-MAKUNBOUND-USING-CLASS" + "SLOT-VALUE-USING-CLASS" + "SPECIALIZER-DIRECT-GENERIC-FUNCTIONS" + "SPECIALIZER-DIRECT-METHODS" + "STANDARD-DIRECT-SLOT-DEFINITION" + "STANDARD-EFFECTIVE-SLOT-DEFINITION" + "STANDARD-INSTANCE-ACCESS" + "UPDATE-DEPENDENT" + "VALIDATE-SUPERCLASS" + "WRITER-METHOD-CLASS" + + "METAOBJECT" + "LONG-METHOD-COMBINATION" + "SHORT-METHOD-COMBINATION" + "STANDARD-ACCESSOR-METHOD" + "STANDARD-READER-METHOD" + "STANDARD-WRITER-METHOD" + "SPECIALIZER" + + "FUNCALLABLE-STANDARD-CLASS" + "FUNCALLABLE-STANDARD-OBJECT" + "FORWARD-REFERENCED-CLASS" + + "CLEAR-SPECIALIZER-DIRECT-METHODS-CACHES" + "*CHECK-CALL-NEXT-METHOD-WITH-ARGS*" + "CLEAR-GF-CACHE" + "CLEAR-ALL-GF-CACHES" + "CLEAR-CLOS-CACHES" + + "METHOD-EXISTS-P" + "METHOD-SPECIALIZERS" + "CLASS-OWN-WRAPPER" + "SPECIALIZER-DIRECT-METHODS" + "SPECIALIZER-DIRECT-GENERIC-FUNCTIONS" + "COPY-INSTANCE" + "STANDARD-SLOT-DEFINITION" + "SLOT-DEFINITION" + "EFFECTIVE-SLOT-DEFINITION" + "DIRECT-SLOT-DEFINITION" + ) + (:export + "ACCESSOR-METHOD-SLOT-DEFINITION" + "ADD-DEPENDENT" + "ADD-DIRECT-METHOD" + "ADD-DIRECT-SUBCLASS" + "ADD-METHOD" + "CLASS-DEFAULT-INITARGS" + "CLASS-DIRECT-DEFAULT-INITARGS" + "CLASS-DIRECT-SLOTS" + "CLASS-DIRECT-SUBCLASSES" + "CLASS-DIRECT-SUPERCLASSES" + "CLASS-FINALIZED-P" + "CLASS-PRECEDENCE-LIST" + "CLASS-PROTOTYPE" + "CLASS-SLOTS" + "COMPUTE-APPLICABLE-METHODS" + "COMPUTE-APPLICABLE-METHODS-USING-CLASSES" + "COMPUTE-CLASS-PRECEDENCE-LIST" + "COMPUTE-DEFAULT-INITARGS" + "COMPUTE-DISCRIMINATING-FUNCTION" + "COMPUTE-EFFECTIVE-METHOD" + "COMPUTE-EFFECTIVE-SLOT-DEFINITION" + "COMPUTE-SLOTS" + "DIRECT-SLOT-DEFINITION-CLASS" + "EFFECTIVE-SLOT-DEFINITION-CLASS" + "ENSURE-CLASS" + "ENSURE-CLASS-USING-CLASS" + "ENSURE-GENERIC-FUNCTION-USING-CLASS" + "EQL-SPECIALIZER" + "EQL-SPECIALIZER-OBJECT" + "EXTRACT-LAMBDA-LIST" + "EXTRACT-SPECIALIZER-NAMES" + "FINALIZE-INHERITANCE" + "FIND-METHOD-COMBINATION" + "FUNCALLABLE-STANDARD-INSTANCE-ACCESS" + "GENERIC-FUNCTION-ARGUMENT-PRECEDENCE-ORDER" + "GENERIC-FUNCTION-DECLARATIONS" + "GENERIC-FUNCTION-LAMBDA-LIST" + "GENERIC-FUNCTION-METHOD-CLASS" + "GENERIC-FUNCTION-METHOD-COMBINATION" + "GENERIC-FUNCTION-METHODS" + "GENERIC-FUNCTION-NAME" + "INTERN-EQL-SPECIALIZER" + "MAKE-METHOD-LAMBDA" + "MAP-DEPENDENTS" + "METHOD-FUNCTION" + "METHOD-GENERIC-FUNCTION" + "METHOD-LAMBDA-LIST" + "METHOD-NAME" + "METHOD-SPECIALIZERS" + "METHOD-QUALIFIERS" + "SLOT-DEFINITION-DOCUMENTATION" + "SLOT-DEFINITION-ALLOCATION" + "SLOT-DEFINITION-INITARGS" + "SLOT-DEFINITION-INITFORM" + "SLOT-DEFINITION-INITFUNCTION" + "SLOT-DEFINITION-NAME" + "SLOT-DEFINITION-TYPE" + "SLOT-DEFINITION-READERS" + "SLOT-DEFINITION-WRITERS" + "SLOT-DEFINITION-LOCATION" + "READER-METHOD-CLASS" + "REMOVE-DEPENDENT" + "REMOVE-DIRECT-METHOD" + "REMOVE-DIRECT-SUBCLASS" + "REMOVE-METHOD" + "SET-FUNCALLABLE-INSTANCE-FUNCTION" + "SLOT-BOUNDP-USING-CLASS" + "SLOT-MAKUNBOUND-USING-CLASS" + "SLOT-VALUE-USING-CLASS" + "SPECIALIZER-DIRECT-GENERIC-FUNCTIONS" + "SPECIALIZER-DIRECT-METHODS" + "STANDARD-DIRECT-SLOT-DEFINITION" + "STANDARD-EFFECTIVE-SLOT-DEFINITION" + "STANDARD-INSTANCE-ACCESS" + "UPDATE-DEPENDENT" + "VALIDATE-SUPERCLASS" + "WRITER-METHOD-CLASS" + + "METAOBJECT" + "LONG-METHOD-COMBINATION" + "SHORT-METHOD-COMBINATION" + "STANDARD-ACCESSOR-METHOD" + "STANDARD-READER-METHOD" + "STANDARD-WRITER-METHOD" + "SPECIALIZER" + + "FUNCALLABLE-STANDARD-CLASS" + "FORWARD-REFERENCED-CLASS" + + + "CLEAR-SPECIALIZER-DIRECT-METHODS-CACHES" + "*CHECK-CALL-NEXT-METHOD-WITH-ARGS*" + "CLEAR-GF-CACHE" + "CLEAR-ALL-GF-CACHES" + "CLEAR-CLOS-CACHES" + + "METHOD-EXISTS-P" + "METHOD-SPECIALIZERS" + "CLASS-OWN-WRAPPER" + "SPECIALIZER-DIRECT-METHODS" + "SPECIALIZER-DIRECT-GENERIC-FUNCTIONS" + "COPY-INSTANCE" + "STANDARD-SLOT-DEFINITION" + "SLOT-DEFINITION" + "EFFECTIVE-SLOT-DEFINITION" + "DIRECT-SLOT-DEFINITION" + )) + +(unless (eq %lisp-system-fixups% T) + (while %lisp-system-fixups% + (let* ((fn.source (car %lisp-system-fixups%)) + (*loading-toplevel-location* (and (source-note-p (cdr fn.source)) (cdr fn.source))) + (*loading-file-source-file* (source-note-filename (cdr fn.source))) + ) + (funcall (car fn.source))) + (setq %lisp-system-fixups% (cdr %lisp-system-fixups%))) + (setq %lisp-system-fixups% T)) + + + + Index: /branches/new-random/lib/chars.lisp =================================================================== --- /branches/new-random/lib/chars.lisp (revision 13309) +++ /branches/new-random/lib/chars.lisp (revision 13309) @@ -0,0 +1,748 @@ +; -*- Mode: Lisp; Package: CCL -*- +;;; +;;; Copyright (C) 2009 Clozure Associates +;;; Copyright (C) 1994-2001 Digitool, Inc +;;; This file is part of Clozure CL. +;;; +;;; Clozure CL is licensed under the terms of the Lisp Lesser GNU Public +;;; License , known as the LLGPL and distributed with Clozure CL as the +;;; file "LICENSE". The LLGPL consists of a preamble and the LGPL, +;;; which is distributed with Clozure CL as the file "LGPL". Where these +;;; conflict, the preamble takes precedence. +;;; +;;; Clozure CL is referenced in the preamble as the "LIBRARY." +;;; +;;; The LLGPL is also available online at +;;; http://opensource.franz.com/preamble.html +;; chars.lisp + +(in-package "CCL") + +(defun character-designator-p (thing) + (or (typep thing 'character) + (typep thing '(string 1)) + (and (typep thing 'symbol) (typep (symbol-name thing) '(string 1))))) + +;;; If object is a character, it is returned. If it is a string of +;;; length 1, then the sole element of the string is returned. If it +;;; is a symbol whose pname is of length 1, then the sole element of +;;; the pname is returned. Else error. + +(defun character (arg) + "Coerce OBJECT into a CHARACTER if possible. Legal inputs are + characters, strings and symbols of length 1." + (if (typep arg 'character) + arg + (if (and (typep arg 'string) + (= (the fixnum (length arg)) 1)) + (char arg 0) + (let* ((pname (if (typep arg 'symbol) (symbol-name arg)))) + (if (and pname (= (the fixnum (length pname)) 1)) + (char pname 0) + (report-bad-arg arg '(satisfies character-designator-p))))))) + + + +(defun digit-char (weight &optional radix) + "All arguments must be integers. Returns a character object that + represents a digit of the given weight in the specified radix. Returns + NIL if no such character exists." + (let* ((r (if radix (require-type radix 'integer) 10))) + (if (and (typep (require-type weight 'integer) 'fixnum) + (>= r 2) + (<= r 36) + (>= weight 0) + (< weight r)) + (locally (declare (fixnum weight)) + (if (< weight 10) + (code-char (the fixnum (+ weight (char-code #\0)))) + (code-char (the fixnum (+ weight (- (char-code #\A) 10))))))))) + + +(declaim (inline %control-char-p)) + +(defun %control-char-p (char) + (let* ((code (char-code char))) + (declare (type (mod #x110000) code)) + ;; If we believe that "most" characters will have relatively + ;; small codes, then doing a linear search on this short + ;; list is probably faster than binary search on a vector + ;; or other approaches. + (dolist (pair '((0 . #x1f) ;c0 + (#x7f . #x9f) ;#\rubout, c1 + (#x34f . #x34f) ;combining grapheme joiner. + (#x200c . #x200f) + (#x202a . #x202e) + (#x2060 . #x2063) + (#x206a . #x206f) + #+darwin-target + (#xf700 . #xf7ff) + (#xfe00 . #xfe0f) + (#xfeff . #xfeff) ;byte-order mark (0-width space). + (#xfff0 . #xfffd) + + (#xe0000 . #xefffd))) + (let* ((low (car pair)) + (high (cdr pair))) + (declare (type (mod #x110000) low high)) + (if (> low code) + (return nil) + (if (<= code high) + (return t))))))) + + + +;;; Characters that aren't control/formatting characters are graphic. +(defun graphic-char-p (c) + "The argument must be a character object. GRAPHIC-CHAR-P returns NIL if the + argument is a Unicode control character, otherwise returns T." + (not (%control-char-p c))) + + +;True for ascii codes 10 and 32-126 inclusive. +(defun standard-char-p (c) + "The argument must be a character object. STANDARD-CHAR-P returns T if the + argument is a standard character -- one of the 95 ASCII printing characters + or ." + (let* ((code (char-code c))) + (or (eq c #\newline) + (and + (>= code (char-code #\space)) + (< code (char-code #\rubout)))))) + + + + + + + +(defun upper-case-p (c) + "The argument must be a character object; UPPER-CASE-P returns T if the + argument is an upper-case character, NIL otherwise." + (let* ((code (char-code c)) + (to-lower *upper-to-lower*)) + (declare (type (mod #x110000) code) + (type (simple-array (signed-byte 16) (*)) to-lower)) + (and (< code (length to-lower)) + (not (zerop (aref to-lower code)))))) + + + + +(defun both-case-p (c) + "The argument must be a character object. BOTH-CASE-P returns T if the + argument is an alphabetic character and if the character exists in + both upper and lower case. For ASCII, this is the same as ALPHA-CHAR-P." + (let* ((code (char-code c)) + (to-upper *lower-to-upper*) + (to-lower *upper-to-lower*)) + (declare (type (mod #x110000) code) + (type (simple-array (signed-byte 16) (*)) to-lower to-upper)) + (or (and (< code (length to-upper)) + (not (zerop (aref to-upper code)))) + (and (< code (length to-lower)) + (not (zerop (aref to-lower code))))))) + +(defun alphanumericp (c) + "Given a character-object argument, ALPHANUMERICP returns T if the + argument is either numeric or alphabetic." + (let ((code (char-code c))) + (declare (type (mod #x110000) code)) + (or + (and (>= code (char-code #\0)) + (<= code (char-code #\9))) + (let* ((bits *alpha-char-bits*)) + (declare (simple-bit-vector bits)) + (and (< code (length bits)) + (not (eql 0 (sbit bits code)))))))) + +(defun char= (ch &rest others) + "Return T if all of the arguments are the same character." + (declare (dynamic-extent others)) + (unless (typep ch 'character) + (setq ch (require-type ch 'character))) + (dolist (other others t) + (unless (eq other ch) + (unless (typep other 'character) + (setq other (require-type other 'character))) + (return)))) + +(defun char/= (ch &rest others) + "Return T if no two of the arguments are the same character." + (declare (dynamic-extent others)) + (unless (typep ch 'character) + (setq ch (require-type ch 'character))) + (do* ((rest others (cdr rest))) + ((null rest) t) + (let ((other (car rest))) + (if (eq other ch) (return)) + (unless (typep other 'character) + (setq other (require-type other 'character))) + (dolist (o2 (cdr rest)) + (if (eq o2 other)(return-from char/= nil)))))) + + +(defun char-equal (char &rest others) + "Return T if all of the arguments are the same character. + Font, bits, and case are ignored." + (declare (dynamic-extent others)) + (locally (declare (optimize (speed 3)(safety 0))) + (dolist (c others t) + (when (not (eq c char)) + (unless (eq (char-upcase char) (char-upcase c)) + (return)))))) + +;;; Compares each char against all following chars, not just next one. Tries +;;; to be fast for one or two args. +(defun char-not-equal (char &rest others) + "Return T if no two of the arguments are the same character. + Font, bits, and case are ignored." + (declare (dynamic-extent others)) + (locally (declare (optimize (speed 3) (safety 0))) + (let* ((rest (cdr others))) + (cond + (rest + (setq char (char-code (char-upcase char))) + (do ((list others (cdr list))) + ((null list)) + (rplaca list (char-code (char-upcase (car list))))) + (while others + (when (memq char others) + (return-from char-not-equal nil)) + (setq char (car others) + others rest + rest (cdr others))) + t) + (others ; 2 args, no table + (not (eq (char-upcase char) (char-upcase (car others))))) + (t t))))) + + +(defun char-lessp (char &rest others) + "Return T if the arguments are in strictly increasing alphabetic order. + Font, bits, and case are ignored." + (declare (dynamic-extent others)) + (locally (declare (optimize (speed 3)(safety 0))) + (let* ((code (char-code (char-upcase char)))) + (dolist (c others t) + (unless (< code (setq code (char-code (char-upcase c)))) + (return)))))) + +(defun char-not-lessp (char &rest others) + "Return T if the arguments are in strictly non-increasing alphabetic order. + Font, bits, and case are ignored." + (declare (dynamic-extent others)) + (locally (declare (optimize (speed 3)(safety 0))) + (let* ((code (char-code (char-upcase char)))) + (dolist (c others t) + (when (< code (setq code (char-code (char-upcase c)))) + (return)))))) + +(defun char-greaterp (char &rest others) + "Return T if the arguments are in strictly decreasing alphabetic order. + Font, bits, and case are ignored." + (declare (dynamic-extent others)) + (locally (declare (optimize (speed 3)(safety 0))) + (let* ((code (char-code (char-upcase char)))) + (dolist (c others t) + (unless (> code (setq code (char-code (char-upcase c)))) + (return)))))) + +(defun char-not-greaterp (char &rest others) + "Return T if the arguments are in strictly non-decreasing alphabetic order. + Font, bits, and case are ignored." + (declare (dynamic-extent others)) + (locally (declare (optimize (speed 3)(safety 0))) + (let* ((code (char-code (char-upcase char)))) + (dolist (c others t) + (when (> code (setq code (char-code (char-upcase c)))) + (return)))))) + + +(defun char> (char &rest others) + "Return T if the arguments are in strictly decreasing alphabetic order." + (declare (dynamic-extent others)) + (locally (declare (optimize (speed 3)(safety 0))) + (let* () + (setq char (char-code char)) + (dolist (c others t) + (let ((code (char-code c))) + (when (not (%i> char (setq char code))) + (return))))))) + +(defun char>= (char &rest others) + "Return T if the arguments are in strictly non-increasing alphabetic order." + (declare (dynamic-extent others)) + (locally (declare (optimize (speed 3)(safety 0))) + (let* () + (setq char (char-code char)) + (dolist (c others t) + (let ((code (char-code c))) + (when (not (%i>= char (setq char code))) + (return))))))) + + +(defun char< (char &rest others) + "Return T if the arguments are in strictly increasing alphabetic order." + (declare (dynamic-extent others)) + (locally (declare (optimize (speed 3)(safety 0))) + (let* () + (setq char (char-code char)) + (dolist (c others t) + (let ((code (char-code c))) + (when (not (%i< char (setq char code))) + (return))))))) + +(defun char<= (char &rest others) + "Return T if the arguments are in strictly non-decreasing alphabetic order." + (declare (dynamic-extent others)) + (locally (declare (optimize (speed 3)(safety 0))) + (let* () + (setq char (char-code char)) + (dolist (c others t) + (let ((code (char-code c))) + (when (not (%i<= char (setq char code))) + (return))))))) + +; This is Common Lisp +(defun char-int (c) + "Return the integer code of CHAR." + (char-code c)) + + +;If char has an entry in the *NAME-CHAR-ALIST*, return first such entry. +;Otherwise, if char is a graphics character, return NIL +;Otherwise, if char code is < 128, return "^C", otherwise "1nn" + +(defun char-name (c) + "Return the name (a STRING) for a CHARACTER object." + (let* ((code (char-code c))) + (declare (type (mod #x110000) code)) + (or (gethash c *char->name*) + (cond ((< code #x7f) + (when (< code (char-code #\space)) + (let ((str (make-string 2 :element-type 'base-char))) + (declare (simple-base-string str)) + (setf (schar str 0) #\^) + (setf (schar str 1)(code-char (logxor code #x40))) + str))) + ((and (< code #x100)(graphic-char-p c)) nil) + (t (format nil "U+~4,'0x" code)))))) + + +(defun string-downcase (string &key (start 0) end) + (setq string (copy-string-arg string)) + (setq end (check-sequence-bounds string start end)) + (%strdown string start end)) + + +(defun %strdown (string start end) + (declare (fixnum start end) + (optimize (speed 3) (safety 0))) + (unless (typep string 'simple-string) + (check-type string simple-string)) + (do* ((i start (1+ i)) + (to-lower *upper-to-lower*) + (n (length to-lower))) + ((>= i end) string) + (declare (fixnum i n) (type (simple-array (signed-byte 16) (*)) to-lower)) + (let* ((ch (schar string i)) + (code (char-code ch)) + (delta (if (< code n) (aref to-lower code) 0))) + (declare (character ch) + (type (mod #x110000) code) + (type (signed-byte 16) delta)) + (unless (zerop delta) + (setf (schar string i) + (code-char (the valid-char-code (+ code delta)))))))) + + + + +(defun copy-string-arg (string &aux (org 0) len) + (etypecase string + (string + (setq len (length string)) + (multiple-value-setq (string org)(array-data-and-offset string))) + (symbol + (setq string (symbol-name string)) + (setq len (length string))) + (character + (return-from copy-string-arg + (make-string 1 :initial-element string )))) + (%substr string org (+ len org))) + +(defun string-upcase (string &key (start 0) end) + (setq string (copy-string-arg string)) + (setq end (check-sequence-bounds string start end)) + (%strup string start end)) + +(defun %strup (string start end) + (declare (fixnum start end) + (optimize (speed 3) (safety 0))) + (unless (typep string 'simple-string) + (check-type string simple-string)) + (do* ((i start (1+ i)) + (to-upper *lower-to-upper*) + (n (length to-upper))) + ((>= i end) string) + (declare (fixnum i n) (type (simple-array (signed-byte 16) (*)) to-upper)) + (let* ((ch (schar string i)) + (code (char-code ch)) + (delta (if (< code n) (aref to-upper code) 0))) + (declare (character ch) + (type (mod #x110000) code) + (type (signed-byte 16) delta)) + (unless (zerop delta) + (setf (schar string i) (code-char (the valid-char-code (+ code delta)))))))) + + + +(defun string-capitalize (string &key (start 0) end) + (setq string (copy-string-arg string)) + (setq end (check-sequence-bounds string start end)) + (%strcap string start end)) + +(defun %strcap (string start end) + (declare (fixnum start end)) + (let ((state :up) + (i start)) + (declare (fixnum i)) + (while (< i end) + (let* ((c (%schar string i)) + (alphap (alphanumericp c))) ; makes no sense + (if alphap + (progn + (setf (%schar string i) + (case state + (:up (char-upcase c)) + (t (char-downcase c)))) + (setq state :down)) + (setq state :up))) + (setq i (1+ i))) + string)) + + + + +(defun nstring-downcase (string &key (start 0) end) + (etypecase string + (string + (setq end (check-sequence-bounds string start end)) + (if (typep string 'simple-string) + (%strdown string start end) + (multiple-value-bind (data offset) (array-data-and-offset string) + (%strdown data (+ start offset) (+ end offset)))) + string))) + +(defun nstring-upcase (string &key (start 0) end) + (etypecase string + (string + (setq end (check-sequence-bounds string start end)) + (if (typep string 'simple-string) + (%strup string start end) + (multiple-value-bind (data offset) (array-data-and-offset string) + (%strup data (+ start offset) (+ end offset)))) + string))) + + +(defun nstring-capitalize (string &key (start 0) end) + (etypecase string + (string + (setq end (check-sequence-bounds string start end)) + (if (typep string 'simple-string) + (%strcap string start end) + (multiple-value-bind (data offset) (array-data-and-offset string) + (%strcap data (+ start offset) (+ end offset)))) + string))) + + + +(defun nstring-studlify (string &key start end) + (declare (ignore start end)) + string) + + +(defun string-compare (string1 start1 end1 string2 start2 end2) + (let ((istart1 (or start1 0))) + (if (and (typep string1 'simple-string)(null start1)(null end1)) + (setq start1 0 end1 (length string1)) + (multiple-value-setq (string1 start1 end1)(string-start-end string1 start1 end1))) + (if (and (typep string2 'simple-string)(null start2)(null end2)) + (setq start2 0 end2 (length string2)) + (multiple-value-setq (string2 start2 end2)(string-start-end string2 start2 end2))) + (setq istart1 (%i- start1 istart1)) + (let* ((val t)) + (declare (optimize (speed 3)(safety 0))) + (do* ((i start1 (%i+ 1 i)) + (j start2 (%i+ 1 j))) + () + (when (eq i end1) + (when (neq j end2) + (setq val -1)) + (return)) + (when (eq j end2) + (setq end1 i) + (setq val 1) + (return)) + (let ((code1 (%scharcode string1 i)) + (code2 (%scharcode string2 j))) + (declare (fixnum code1 code2)) + (if (and (>= code1 (char-code #\a)) + (<= code1 (char-code #\z))) + (setq code1 (- code1 (- (char-code #\a) (char-code #\A))))) + (if (and (>= code2 (char-code #\a)) + (<= code2 (char-code #\z))) + (setq code2 (- code2 (- (char-code #\a) (char-code #\A))))) + (unless (= code1 code2) + (setq val (if (%i< code1 code2) -1 1)) + (setq end1 i) + (return)))) + (values val (%i- end1 istart1))))) + + +(defun string-greaterp (string1 string2 &key start1 end1 start2 end2) + "Given two strings, if the first string is lexicographically greater than + the second string, returns the longest common prefix (using char-equal) + of the two strings. Otherwise, returns ()." + (multiple-value-bind (result pos) (string-compare string1 start1 end1 string2 start2 end2) + (if (eq result 1) pos nil))) + +(defun string-not-greaterp (string1 string2 &key start1 end1 start2 end2) + "Given two strings, if the first string is lexicographically less than + or equal to the second string, returns the longest common prefix + (using char-equal) of the two strings. Otherwise, returns ()." + (multiple-value-bind (result pos) (string-compare string1 start1 end1 string2 start2 end2) + (if (eq result 1) nil pos))) + +(defun string-not-equal (string1 string2 &key start1 end1 start2 end2) + "Given two strings, if the first string is not lexicographically equal + to the second string, returns the longest common prefix (using char-equal) + of the two strings. Otherwise, returns ()." + (multiple-value-bind (result pos) (string-compare string1 start1 end1 string2 start2 end2) + (if (eq result t) nil pos))) + +(defun string-not-lessp (string1 string2 &key start1 end1 start2 end2) + "Given two strings, if the first string is lexicographically greater + than or equal to the second string, returns the longest common prefix + (using char-equal) of the two strings. Otherwise, returns ()." + (multiple-value-bind (result pos) (string-compare string1 start1 end1 string2 start2 end2) + (if (eq result -1) nil pos))) + +(declaim (inline %string-start-end)) +(defun %string-start-end (string) + (etypecase string + (string (multiple-value-bind (data offset) + (array-data-and-offset string) + (declare (fixnum offset)) + (values data offset (+ offset (length string))))) + (symbol (let* ((pname (symbol-name string))) + (values pname 0 (length pname)))) + (character (let* ((data (make-string 1))) + (setf (schar data 0) string) + (values data 0 1))))) + +;;; This is generally a bit faster then the version that deals with +;;; user-supplied bounds, both because the caller avoids passing +;;; some extra arguments and because those bounds don't need to be +;;; validated. +(defun %fixed-string-equal (string1 string2) + (let* ((start1 0) + (end1 0) + (start2 0) + (end2 0)) + (declare (fixnum start1 end1 start2 end2)) + (if (typep string1 'simple-string) + (setq end1 (uvsize string1)) + (multiple-value-setq (string1 start1 end1) + (%string-start-end string1))) + (if (typep string2 'simple-string) + (setq end2 (uvsize string2)) + (multiple-value-setq (string2 start2 end2) + (%string-start-end string2))) + (locally + (declare (optimize (speed 3)(safety 0)) + (simple-string string1 string2)) + (when (= (the fixnum (- end1 start1)) + (the fixnum (- end2 start2))) + (do* ((i start1 (1+ i)) + (j start2 (1+ j)) + (map *lower-to-upper*)) + ((= i end1) t) + (declare (fixnum i j)) + (let ((code1 (%scharcode string1 i)) + (code2 (%scharcode string2 j))) + (declare (type (mod #x110000) code1 code2)) + (unless (= code1 code2) + (unless (= (the (mod #x110000) (%char-code-case-fold code1 map)) + (the (mod #x110000) (%char-code-case-fold code2 map))) + (return))))))))) + +;;; Some of the start1/end1/start2/end2 args may be bogus. +(defun %bounded-string-equal (string1 string2 start1 end1 start2 end2) + (let* ((disp1 nil) + (len1 0) + (disp2 nil) + (len2 0)) + (declare (fixnum len1 len2)) + (if (typep string1 'simple-string) + (setq len1 (length (the simple-string string1))) + (etypecase string1 + (string (setq len1 (length string1)) + (multiple-value-setq (string1 disp1) + (array-data-and-offset string1))) + (symbol (setq string1 (symbol-name string1) + len1 (length (the simple-string string1)))) + (character (setq string1 (make-string 1 :initial-element string1) + len1 1)))) + (if (typep string2 'simple-string) + (setq len2 (length (the simple-string string2))) + (etypecase string2 + (string (setq len2 (length string2)) + (multiple-value-setq (string2 disp2) + (array-data-and-offset string2))) + (symbol (setq string2 (symbol-name string2) + len1 (length (the simple-string string2)))) + (character (setq string2 (make-string 1 :initial-element string2) + len1 1)))) + (flet ((bad-index (index vector) (error "Index ~s is invalid for ~s" index vector))) + (if (null start1) + (setq start1 0) + (when (or (not (typep start1 'fixnum)) + (< (the fixnum start1) 0)) + (bad-index start1 string1))) + (if (null end1) + (setq end1 len1) + (when (or (not (typep end1 'fixnum)) + (< (the fixnum end1) 0) + (> (the fixnum end1) len1)) + (bad-index end1 string1))) + (locally (declare (fixnum start1 end1)) + (if (> start1 end1) + (error ":start1 argument ~s exceeds :end1 argument ~s" start1 end1)) + (when disp1 + (locally (declare (fixnum disp1)) + (incf start1 disp1) + (incf end1 disp1))) + (if (null start2) + (setq start2 0) + (when (or (not (typep start2 'fixnum)) + (< (the fixnum start2) 0)) + (bad-index start2 string2))) + (if (null end2) + (setq end2 len2) + (when (or (not (typep end2 'fixnum)) + (< (the fixnum end2) 0) + (> (the fixnum end2) len2)) + (bad-index end2 string2))) + (locally (declare (fixnum start2 end2)) + (if (> start2 end2) + (error ":start2 argument ~s exceeds :end2 argument ~s" start1 end1)) + (when disp2 + (locally (declare (fixnum disp2)) + (incf start2 disp2) + (incf end2 disp2))) + (locally + (declare (optimize (speed 3)(safety 0)) + (simple-string string1 string2)) + (when (= (the fixnum (- end1 start1)) + (the fixnum (- end2 start2))) + (do* ((i start1 (1+ i)) + (j start2 (1+ j)) + (map *lower-to-upper*)) + ((= i end1) t) + (declare (fixnum i j)) + (let ((code1 (%scharcode string1 i)) + (code2 (%scharcode string2 j))) + (declare (type (mod #x110000) code1 code2)) + (unless (= code1 code2) + (unless (= (the (mod #x110000) (%char-code-case-fold code1 map)) + (the (mod #x110000) (%char-code-case-fold code2 map))) + (return)))))))))))) + +(defun string-equal (string1 string2 &key start1 end1 start2 end2) + "Given two strings (string1 and string2), and optional integers start1, + start2, end1 and end2, compares characters in string1 to characters in + string2 (using char-equal)." + (if (or start1 end1 start2 end2) + (%bounded-string-equal string1 string2 start1 end1 start2 end2) + (%fixed-string-equal string1 string2))) + + + +(defun string-lessp (string1 string2 &key start1 end1 start2 end2) + "Given two strings, if the first string is lexicographically less than + the second string, returns the longest common prefix (using char-equal) + of the two strings. Otherwise, returns ()." + (multiple-value-bind (result pos)(string-compare string1 start1 end1 string2 start2 end2) + (if (eq result -1) pos nil))) + +;;; forget script-manager - just do codes +(defun string-cmp (string1 start1 end1 string2 start2 end2) + (let ((istart1 (or start1 0))) + (if (and (typep string1 'simple-string)(null start1)(null end1)) + (setq start1 0 end1 (length string1)) + (multiple-value-setq (string1 start1 end1)(string-start-end string1 start1 end1))) + (if (and (typep string2 'simple-string)(null start2)(null end2)) + (setq start2 0 end2 (length string2)) + (multiple-value-setq (string2 start2 end2)(string-start-end string2 start2 end2))) + (setq istart1 (%i- start1 istart1)) + (let* ((val t)) + (declare (optimize (speed 3)(safety 0))) + (do* ((i start1 (%i+ 1 i)) + (j start2 (%i+ 1 j))) + () + (when (eq i end1) + (when (neq j end2)(setq val -1)) + (return)) + (when (eq j end2) + (setq end1 i) + (setq val 1)(return)) + (let ((code1 (%scharcode string1 i)) + (code2 (%scharcode string2 j))) + (declare (fixnum code1 code2)) + (unless (= code1 code2) + (setq val (if (%i< code1 code2) -1 1)) + (setq end1 i) + (return)))) + (values val (%i- end1 istart1))))) + +(defun string> (string1 string2 &key start1 end1 start2 end2) + "Given two strings, if the first string is lexicographically greater than + the second string, returns the longest common prefix (using char=) + of the two strings. Otherwise, returns ()." + (multiple-value-bind (result pos) (string-cmp string1 start1 end1 string2 start2 end2) + (if (eq result 1) pos nil))) + +(defun string>= (string1 string2 &key start1 end1 start2 end2) + "Given two strings, if the first string is lexicographically greater + than or equal to the second string, returns the longest common prefix + (using char=) of the two strings. Otherwise, returns ()." + (multiple-value-bind (result pos) (string-cmp string1 start1 end1 string2 start2 end2) + (if (eq result -1) nil pos))) + +(defun string< (string1 string2 &key start1 end1 start2 end2) + "Given two strings, if the first string is lexicographically less than + the second string, returns the longest common prefix (using char=) + of the two strings. Otherwise, returns ()." + (multiple-value-bind (result pos) (string-cmp string1 start1 end1 string2 start2 end2) + (if (eq result -1) pos nil))) + +(defun string<= (string1 string2 &key start1 end1 start2 end2) + "Given two strings, if the first string is lexicographically less than + or equal to the second string, returns the longest common prefix + (using char=) of the two strings. Otherwise, returns ()." + (multiple-value-bind (result pos) (string-cmp string1 start1 end1 string2 start2 end2) + (if (eq result 1) nil pos))) + +; this need not be so fancy? +(defun string/= (string1 string2 &key start1 end1 start2 end2) + "Given two strings, if the first string is not lexicographically equal + to the second string, returns the longest common prefix (using char=) + of the two strings. Otherwise, returns ()." + (multiple-value-bind (result pos) (string-cmp string1 start1 end1 string2 start2 end2) + (if (eq result t) nil pos))) + + + +(provide 'chars) Index: /branches/new-random/lib/compile-ccl.lisp =================================================================== --- /branches/new-random/lib/compile-ccl.lisp (revision 13309) +++ /branches/new-random/lib/compile-ccl.lisp (revision 13309) @@ -0,0 +1,805 @@ +;;;-*-Mode: LISP; Package: CCL -*- +;;; +;;; Copyright (C) 2009 Clozure Associates +;;; Copyright (C) 1994-2001 Digitool, Inc +;;; This file is part of Clozure CL. +;;; +;;; Clozure CL is licensed under the terms of the Lisp Lesser GNU Public +;;; License , known as the LLGPL and distributed with Clozure CL as the +;;; file "LICENSE". The LLGPL consists of a preamble and the LGPL, +;;; which is distributed with Clozure CL as the file "LGPL". Where these +;;; conflict, the preamble takes precedence. +;;; +;;; Clozure CL is referenced in the preamble as the "LIBRARY." +;;; +;;; The LLGPL is also available online at +;;; http://opensource.franz.com/preamble.html + +(in-package "CCL") + +(require 'systems) + +(defparameter *sysdef-modules* + '(systems compile-ccl)) + +(defparameter *level-1-modules* + '(level-1 + l1-cl-package + l1-boot-1 l1-boot-2 l1-boot-3 + l1-utils l1-init l1-symhash l1-numbers l1-aprims + l1-sort l1-dcode l1-clos-boot l1-clos + l1-unicode l1-streams l1-files l1-io + l1-format l1-readloop l1-reader + l1-sysio l1-pathnames l1-events + l1-boot-lds l1-readloop-lds + l1-lisp-threads l1-application l1-processes + l1-typesys sysutils l1-error-system + l1-error-signal version l1-callbacks + l1-sockets linux-files + )) + +(defparameter *compiler-modules* + '(nx optimizers dll-node arch vreg vinsn + reg subprims backend nx2)) + + +(defparameter *ppc-compiler-modules* + '(ppc32-arch + ppc64-arch + ppc-arch + ppcenv + ppc-asm + risc-lap + ppc-lap + ppc-backend +)) + +(defparameter *x86-compiler-modules* + '(x8632-arch + x8664-arch + x86-arch + x8632env + x8664env + x86-asm + x86-lap + x86-backend +)) + +(defparameter *ppc32-compiler-backend-modules* + '(ppc32-backend ppc32-vinsns)) + +(defparameter *ppc64-compiler-backend-modules* + '(ppc64-backend ppc64-vinsns)) + + +(defparameter *ppc-compiler-backend-modules* + '(ppc2)) + + +(defparameter *x8632-compiler-backend-modules* + '(x8632-backend x8632-vinsns)) + +(defparameter *x8664-compiler-backend-modules* + '(x8664-backend x8664-vinsns)) + +(defparameter *x86-compiler-backend-modules* + '(x862)) + + + + +(defparameter *ppc-xload-modules* '(xppcfasload xfasload heap-image )) +(defparameter *x8632-xload-modules* '(xx8632fasload xfasload heap-image )) +(defparameter *x8664-xload-modules* '(xx8664fasload xfasload heap-image )) + + +;;; Not too OS-specific. +(defparameter *ppc-xdev-modules* '(ppc-lapmacros )) +(defparameter *x86-xdev-modules* '(x86-lapmacros )) + +(defun target-xdev-modules (&optional (target + (backend-target-arch-name + *host-backend*))) + (case target + ((:ppc32 :ppc64) *ppc-xdev-modules*) + ((:x8632 :x8664) *x86-xdev-modules*))) + +(defun target-xload-modules (&optional (target + (backend-target-arch-name *host-backend*))) + (case target + ((:ppc32 :ppc64) *ppc-xload-modules*) + (:x8632 *x8632-xload-modules*) + (:x8664 *x8664-xload-modules*))) + + + + + + +(defparameter *env-modules* + '(hash backquote lispequ level-2 macros + defstruct-macros lists chars setf setf-runtime + defstruct defstruct-lds + foreign-types + db-io + nfcomp + )) + +(defun target-env-modules (&optional (target + (backend-name *host-backend*))) + (append *env-modules* + (list + (ecase target + (:linuxppc32 'ffi-linuxppc32) + (:darwinppc32 'ffi-darwinppc32) + (:darwinppc64 'ffi-darwinppc64) + (:linuxppc64 'ffi-linuxppc64) + (:darwinx8632 'ffi-darwinx8632) + (:linuxx8664 'ffi-linuxx8664) + (:darwinx8664 'ffi-darwinx8664) + (:freebsdx8664 'ffi-freebsdx8664) + (:solarisx8664 'ffi-solarisx8664) + (:win64 'ffi-win64) + (:linuxx8632 'ffi-linuxx8632) + (:win32 'ffi-win32) + (:solarisx8632 'ffi-solarisx8632) + (:freebsdx8632 'ffi-freebsdx8632))))) + + +(defun target-compiler-modules (&optional (target + (backend-target-arch-name + *host-backend*))) + (case target + (:ppc32 (append *ppc-compiler-modules* + *ppc32-compiler-backend-modules* + *ppc-compiler-backend-modules*)) + (:ppc64 (append *ppc-compiler-modules* + *ppc64-compiler-backend-modules* + *ppc-compiler-backend-modules*)) + (:x8632 (append *x86-compiler-modules* + *x8632-compiler-backend-modules* + *x86-compiler-backend-modules*)) + (:x8664 (append *x86-compiler-modules* + *x8664-compiler-backend-modules* + *x86-compiler-backend-modules*)))) + +(defparameter *other-lib-modules* + '(streams pathnames backtrace + apropos + numbers + dumplisp source-files)) + +(defun target-other-lib-modules (&optional (target + (backend-target-arch-name + *host-backend*))) + (append *other-lib-modules* + (case target + ((:ppc32 :ppc64) '(ppc-backtrace ppc-disassemble)) + ((:x8632 :x8664) '(x86-backtrace x86-disassemble x86-watch))))) + + +(defun target-lib-modules (&optional (backend-name + (backend-name *host-backend*))) + (let* ((backend (or (find-backend backend-name) *host-backend*)) + (arch-name (backend-target-arch-name backend))) + (append (target-env-modules backend-name) (target-other-lib-modules arch-name)))) + + +(defparameter *code-modules* + '(encapsulate + read misc arrays-fry + sequences sort + method-combination + case-error pprint + format time +; eval step + backtrace-lds ccl-export-syms prepare-mcl-environment)) + + + +(defparameter *aux-modules* + '(number-macros number-case-macro + loop + runtime + mcl-compat + arglist + edit-callers + describe + cover + leaks + core-files + asdf + defsystem + jp-encode + )) + + + + + + + +(defun target-level-1-modules (&optional (target (backend-name *host-backend*))) + (append *level-1-modules* + (case target + ((:linuxppc32 :darwinppc32 :linuxppc64 :darwinppc64) + '(ppc-error-signal ppc-trap-support + ppc-threads-utils ppc-callback-support)) + ((:linuxx8664 :freebsdx8664 :darwinx8664 :solarisx8664 + :darwinx8632 :win64 :linuxx8632 :win32 :solarisx8632 + :freebsdx8632) + '(x86-error-signal x86-trap-support + x86-threads-utils x86-callback-support))))) + + +;;; Needed to cross-dump an image + + +(unless (fboundp 'xload-level-0) + (%fhave 'xload-level-0 + #'(lambda (&rest rest) + (in-development-mode + (require-modules (target-xload-modules))) + (apply 'xload-level-0 rest)))) + +(defun find-module (module &optional (target (backend-name *host-backend*)) &aux data fasl sources) + (if (setq data (assoc module *ccl-system*)) + (let* ((backend (or (find-backend target) *host-backend*))) + (setq fasl (cadr data) sources (caddr data)) + (setq fasl (merge-pathnames (backend-target-fasl-pathname + backend) fasl)) + (values fasl (if (listp sources) sources (list sources)))) + (error "Module ~S not defined" module))) + +;compile if needed. +(defun target-compile-modules (modules target force-compile) + (if (not (listp modules)) (setq modules (list modules))) + (in-development-mode + (dolist (module modules t) + (multiple-value-bind (fasl sources) (find-module module target) + (if (needs-compile-p fasl sources force-compile) + (progn + (require'nfcomp) + (compile-file (car sources) + :output-file fasl + :verbose t + :target target))))))) + + +(defun needs-compile-p (fasl sources force-compile) + (if fasl + (if (eq force-compile t) + t + (if (not (probe-file fasl)) + t + (let ((fasldate (file-write-date fasl))) + (if (if (integerp force-compile) (> force-compile fasldate)) + t + (dolist (source sources nil) + (if (> (file-write-date source) fasldate) + (return t))))))))) + + + +;;;compile if needed, load if recompiled. + +(defun update-modules (modules &optional force-compile) + (if (not (listp modules)) (setq modules (list modules))) + (in-development-mode + (dolist (module modules t) + (multiple-value-bind (fasl sources) (find-module module) + (if (needs-compile-p fasl sources force-compile) + (progn + (require'nfcomp) + (let* ((*warn-if-redefine* nil)) + (compile-file (car sources) :output-file fasl :verbose t :load t)) + (provide module))))))) + +(defun compile-modules (modules &optional force-compile) + (target-compile-modules modules (backend-name *host-backend*) force-compile) +) + +(defun compile-ccl (&optional force-compile) + (with-compilation-unit () + (update-modules *sysdef-modules* force-compile) + (update-modules 'nxenv force-compile) + (update-modules *compiler-modules* force-compile) + (update-modules (target-compiler-modules) force-compile) + (update-modules (target-xdev-modules) force-compile) + (update-modules (target-xload-modules) force-compile) + (let* ((env-modules (target-env-modules)) + (other-lib (target-other-lib-modules))) + (require-modules env-modules) + (update-modules env-modules force-compile) + (compile-modules (target-level-1-modules) force-compile) + (update-modules other-lib force-compile) + (require-modules other-lib) + (require-update-modules *code-modules* force-compile)) + (compile-modules *aux-modules* force-compile))) + + + +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; + +(defun require-env (&optional force-load) + (require-modules (target-env-modules) + force-load)) + +(defun compile-level-1 (&optional force-compile) + (require-env) + (compile-modules (target-level-1-modules (backend-name *host-backend*)) + force-compile)) + + + + + +(defun compile-lib (&optional force-compile) + (compile-modules (target-lib-modules) + force-compile)) + +(defun compile-code (&optional force-compile) + (compile-modules *code-modules* force-compile)) + + +;Compile but don't load + +(defun xcompile-ccl (&optional force) + (with-compilation-unit () + (compile-modules *sysdef-modules* force) + (compile-modules 'nxenv force) + (compile-modules *compiler-modules* force) + (compile-modules (target-compiler-modules) force) + (compile-modules (target-xdev-modules) force) + (compile-modules (target-xload-modules) force) + (compile-modules (target-env-modules) force) + (compile-modules (target-level-1-modules) force) + (compile-modules (target-other-lib-modules) force) + (compile-modules *code-modules* force) + (compile-modules *aux-modules* force))) + +(defun require-update-modules (modules &optional force-compile) + (if (not (listp modules)) (setq modules (list modules))) + (in-development-mode + (dolist (module modules) + (require-modules module) + (update-modules module force-compile)))) + + +(defun target-xcompile-ccl (target &optional force) + (require-update-modules *sysdef-modules* force) ;in the host + (let* ((backend (or (find-backend target) *target-backend*)) + (arch (backend-target-arch-name backend)) + (*defstruct-share-accessor-functions* nil)) + (target-compile-modules 'nxenv target force) + (target-compile-modules *compiler-modules* target force) + (target-compile-modules (target-compiler-modules arch) target force) + (target-compile-modules (target-level-1-modules target) target force) + (target-compile-modules (target-lib-modules target) target force) + (target-compile-modules *sysdef-modules* target force) + (target-compile-modules *aux-modules* target force) + (target-compile-modules *code-modules* target force) + (target-compile-modules (target-xdev-modules arch) target force))) + +(defun cross-compile-ccl (target &optional force) + (with-cross-compilation-target (target) + (let* ((*target-backend* (find-backend target))) + (target-xcompile-ccl target force)))) + + +(defun require-module (module force-load) + (multiple-value-bind (fasl source) (find-module module) + (setq source (car source)) + (if (if fasl (probe-file fasl)) + (if force-load + (progn + (load fasl) + (provide module)) + (require module fasl)) + (if (probe-file source) + (progn + (if fasl (format t "~&Can't find ~S so requiring ~S instead" + fasl source)) + (if force-load + (progn + (load source) + (provide module)) + (require module source))) + (error "Can't find ~S or ~S" fasl source))))) + +(defun require-modules (modules &optional force-load) + (if (not (listp modules)) (setq modules (list modules))) + (let ((*package* (find-package :ccl))) + (dolist (m modules t) + (require-module m force-load)))) + + +(defun target-xcompile-level-1 (target &optional force) + (target-compile-modules (target-level-1-modules target) target force)) + +(defun standard-boot-image-name (&optional (target (backend-name *host-backend*))) + (ecase target + (:darwinppc32 "ppc-boot.image") + (:linuxppc32 "ppc-boot") + (:darwinppc64 "ppc-boot64.image") + (:linuxppc64 "ppc-boot64") + (:darwinx8632 "x86-boot32.image") + (:linuxx8664 "x86-boot64") + (:freebsdx8664 "fx86-boot64") + (:darwinx8664 "x86-boot64.image") + (:solarisx8664 "sx86-boot64") + (:win64 "wx86-boot64.image") + (:linuxx8632 "x86-boot32") + (:win32 "wx86-boot32.image") + (:solarisx8632 "sx86-boot32") + (:freebsdx8632 "fx86-boot32"))) + +(defun standard-kernel-name (&optional (target (backend-name *host-backend*))) + (ecase target + (:darwinppc32 "dppccl") + (:linuxppc32 "ppccl") + (:darwinppc64 "dppccl64") + (:darwinx8632 "dx86cl") + (:linuxppc64 "ppccl64") + (:linuxx8664 "lx86cl64") + (:freebsdx8664 "fx86cl64") + (:darwinx8664 "dx86cl64") + (:solarisx8664 "sx86cl64") + (:win64 "wx86cl64.exe") + (:linuxx8632 "lx86cl") + (:win32 "wx86cl.exe") + (:solarisx8632 "sx86cl") + (:freebsdx8632 "fx86cl"))) + +(defun standard-image-name (&optional (target (backend-name *host-backend*))) + (concatenate 'string (pathname-name (standard-kernel-name target)) ".image")) + +(defun kernel-build-directory (&optional (target (backend-name *host-backend*))) + (ecase target + (:darwinppc32 "darwinppc") + (:linuxppc32 "linuxppc") + (:darwinppc64 "darwinppc64") + (:linuxppc64 "linuxppc64") + (:darwinx8632 "darwinx8632") + (:linuxx8664 "linuxx8664") + (:freebsdx8664 "freebsdx8664") + (:darwinx8664 "darwinx8664") + (:solarisx8664 "solarisx64") + (:win64 "win64") + (:linuxx8632 "linuxx8632") + (:win32 "win32") + (:solarisx8632 "solarisx86") + (:freebsdx8632 "freebsdx8632"))) + +;;; If we distribute (e.g.) 32- and 64-bit versions for the same +;;; machine and OS in the same svn directory, return the name of the +;;; peer backend, or NIL. For example., the peer of :linuxppc64 is +;;; :linuxppc32. Note that this may change over time. +;;; Return NIL if the concept doesn't apply. +(defun peer-platform (&optional (target (backend-name *host-backend*))) + (let* ((pairs '((:darwinppc32 . :darwinppc64) + (:linuxppc32 . :linuxppc64) + (:darwinx8632 . :darwinx8664) + (:linuxx8632 . :linuxx8664) + (:win32 . :win64) + (:solarisx8632 . :solarisx8664) + (:freebsdx8632 . :freebsdx8664)))) + (or (cdr (assoc target pairs)) + (car (rassoc target pairs))))) + +(defun make-program (&optional (target (backend-name *host-backend*))) + ;; The Solaris "make" program is too clever to understand -C, so + ;; use GNU make (installed as "gmake"). + (case target + ((:solarisx8664 :solarisx8632) "gmake") + (t "make"))) + + +(defun describe-external-process-failure (proc reminder) + "If it appears that the external-process PROC failed in some way, +try to return a string that describes that failure. If it seems +to have succeeded or if we can't tell why it failed, return NIL. +This is mostly intended to describe process-creation/fork/exec failures, +not runtime errors reported by a successfully created process." + (multiple-value-bind (status exit-code) + (external-process-status proc) + (let* ((procname (car (external-process-args proc))) + (string + (case status + (:error + (%strerror exit-code)) + #-windows-target + (:exited + (when(= exit-code #$EX_OSERR) + "generic OS error in fork/exec"))))) + (when string + (format nil "Error executing ~a: ~a~&~a" procname string reminder))))) + +(defparameter *known-optional-features* '(:count-gf-calls :monitor-futex-wait :unique-dcode)) +(defvar *build-time-optional-features* nil) +(defvar *ccl-save-source-locations* :no-text) + +(defun rebuild-ccl (&key update full clean kernel force (reload t) exit reload-arguments verbose optional-features (save-source-locations *ccl-save-source-locations*)) + (let* ((*build-time-optional-features* (intersection *known-optional-features* optional-features)) + (*features* (append *build-time-optional-features* *features*)) + (*save-source-locations* save-source-locations)) + (when *build-time-optional-features* + (setq full t)) + (when full + (setq clean t kernel t reload t)) + (when update + (multiple-value-bind (changed conflicts new-binaries) + (update-ccl :verbose (not (eq update :quiet))) + (declare (ignore changed conflicts)) + (when new-binaries + (format t "~&There are new bootstrapping binaries. Please restart +the lisp and run REBUILD-CCL again.") + (return-from rebuild-ccl nil)))) + (when (or clean force) + ;; for better bug reports... + (format t "~&Rebuilding ~a using ~a" + (lisp-implementation-type) + (lisp-implementation-version))) + (let* ((cd (current-directory))) + (unwind-protect + (progn + (setf (current-directory) "ccl:") + (when clean + (dolist (f (directory + (merge-pathnames + (make-pathname :name :wild + :type (pathname-type *.fasl-pathname*)) + "ccl:**;"))) + (delete-file f))) + (when kernel + (when (or clean force) + ;; Do a "make -k clean". + (run-program "make" + (list "-k" + "-C" + (format nil "lisp-kernel/~a" + (kernel-build-directory)) + "clean"))) + (format t "~&;Building lisp-kernel ...") + (with-output-to-string (s) + (let* ((proc (run-program (make-program) + (list "-k" "-C" + (format nil "lisp-kernel/~a" + (kernel-build-directory)) + "-j" + + (format nil "~d" (1+ (cpu-count)))) + :output s + :error :output))) + (multiple-value-bind (status exit-code) + (external-process-status proc) + (if (and (eq :exited status) (zerop exit-code)) + (progn + (format t "~&;Kernel built successfully.") + (when verbose + (format t "~&;kernel build output:~%~a" + (get-output-stream-string s))) + (sleep 1)) + (error "Error(s) during kernel compilation.~%~a" + (or + (describe-external-process-failure + proc + "Developer tools may not be installed correctly.") + (get-output-stream-string s)))))))) + (compile-ccl (not (null force))) + (if force (xload-level-0 :force) (xload-level-0)) + (when reload + (with-input-from-string (cmd (format nil + "(save-application ~s)" + (standard-image-name))) + (with-output-to-string (output) + (multiple-value-bind (status exit-code) + (external-process-status + (run-program + (format nil "./~a" (standard-kernel-name)) + (list* "--image-name" (standard-boot-image-name) + "--batch" + reload-arguments) + :input cmd + :output output + :error output)) + (if (and (eq status :exited) + (eql exit-code 0)) + (progn + (format t "~&;Wrote heap image: ~s" + (truename (format nil "ccl:~a" + (standard-image-name)))) + (when verbose + (format t "~&;Reload heap image output:~%~a" + (get-output-stream-string output)))) + (error "Errors (~s ~s) reloading boot image:~&~a" + status exit-code + (get-output-stream-string output))))))) + (when exit + (quit))) + (setf (current-directory) cd))))) + + +(defun create-interfaces (dirname &key target populate-arg) + (let* ((backend (if target (find-backend target) *target-backend*)) + (*default-pathname-defaults* nil) + (ftd (backend-target-foreign-type-data backend)) + (d (use-interface-dir dirname ftd)) + (populate (merge-pathnames "C/populate.sh" + (merge-pathnames + (interface-dir-subdir d) + (ftd-interface-db-directory ftd)))) + (cdir (make-pathname :directory (pathname-directory (translate-logical-pathname populate)))) + (args (list "-c" + (format nil "cd ~a && /bin/sh ~a ~@[~a~]" + (native-translated-namestring cdir) + (native-translated-namestring populate) + populate-arg)))) + (format t "~&;[Running interface translator via ~s to produce .ffi file(s) from headers]~&" populate) + (force-output t) + (multiple-value-bind (status exit-code) + (external-process-status + (run-program "/bin/sh" args :output t)) + (if (and (eq status :exited) + (eql exit-code 0)) + (let* ((f 'parse-standard-ffi-files)) + (require "PARSE-FFI") + (format t "~%~%;[Parsing .ffi files; may create new .cdb files for ~s]" dirname) + (funcall f dirname target) + (format t "~%~%;[Parsing .ffi files again to resolve forward-referenced constants]") + (funcall f dirname target)))))) + +(defun update-ccl (&key (verbose t)) + (let* ((changed ()) + (new-binaries ()) + (conflicts ())) + (with-output-to-string (out) + (with-preserved-working-directory ("ccl:") + (when verbose (format t "~&;Running 'svn update'.")) + (multiple-value-bind (status exit-code) + (external-process-status + (run-program "svn" '("update" "--non-interactive") :output out :error t)) + (when verbose (format t "~&;'svn update' complete.")) + (if (not (and (eq status :exited) + (eql exit-code 0))) + (error "Running \"svn update\" produced exit status ~s, code ~s." status exit-code) + (let* ((sout (get-output-stream-string out)) + (added ()) + (deleted ()) + (updated ()) + (merged ()) + (binaries (list (standard-kernel-name) (standard-image-name ))) + (peer (peer-platform))) + (when peer + (push (standard-kernel-name peer) binaries) + (push (standard-image-name peer) binaries)) + (flet ((svn-revert (string) + (multiple-value-bind (status exit-code) + (external-process-status (run-program "svn" `("revert" ,string))) + (when (and (eq status :exited) (eql exit-code 0)) + (setq conflicts (delete string conflicts :test #'string=)) + (push string updated))))) + (with-input-from-string (in sout) + (do* ((line (read-line in nil nil) (read-line in nil nil))) + ((null line)) + (when (and (> (length line) 2) + (eql #\space (schar line 1))) + (let* ((path (string-trim " " (subseq line 2)))) + (case (schar line 0) + (#\A (push path added)) + (#\D (push path deleted)) + (#\U (push path updated)) + (#\G (push path merged)) + (#\C (push path conflicts))))))) + ;; If the kernel and/or image conflict, use "svn revert" + ;; to replace the working copies with the (just updated) + ;; repository versions. + (setq changed (if (or added deleted updated merged conflicts) t)) + (dolist (f binaries) + (cond ((member f conflicts :test #'string=) + (svn-revert f) + (setq new-binaries t)) + ((or (member f updated :test #'string=) + (member f merged :test #'string=)) + (setq new-binaries t)))) + + ;; If there are any remaining conflicts, offer + ;; to revert them. + (when conflicts + (with-preserved-working-directory () + (cerror "Discard local changes to these files (using 'svn revert')." + "'svn update' was unable to merge local changes to the following file~p with the updated versions:~{~&~s~}" (length conflicts) conflicts) + (dolist (c (copy-list conflicts)) + (svn-revert c)))) + ;; Report other changes, if verbose. + (when (and verbose + (or added deleted updated merged conflicts)) + (format t "~&;Changes from svn update:") + (flet ((show-changes (herald files) + (when files + (format t "~&; ~a:~{~&; ~a~}" + herald files)))) + (show-changes "Conflicting files" conflicts) + (show-changes "New files/directories" added) + (show-changes "Deleted files/directories" deleted) + (show-changes "Updated files" updated) + (show-changes "Files with local changes, successfully merged" merged))))))))) + (values changed conflicts new-binaries))) + +(defmacro with-preserved-working-directory ((&optional dir) &body body) + (let ((wd (gensym))) + `(let ((,wd (mac-default-directory))) + (unwind-protect + (progn + ,@(when dir `((cwd ,dir))) + ,@body) + (cwd ,wd))))) + +(defun ensure-tests-loaded (&key force update ansi ccl) + (unless (and (find-package "REGRESSION-TEST") (not force)) + (if (probe-file "ccl:tests;ansi-tests;") + (when update + (cwd "ccl:tests;") + (run-program "svn" '("update"))) + (let* ((svn (probe-file "ccl:.svn;entries")) + (repo (and svn (svn-repository))) + (s (make-string-output-stream))) + (when repo + (format t "~&Checking out test suite into ccl:tests;~%") + (cwd "ccl:") + (multiple-value-bind (status exit-code) + (external-process-status + (run-program "svn" (list "checkout" (format nil "~a/trunk/tests" repo) "tests") + :output s + :error s)) + (unless (and (eq status :exited) + (eql exit-code 0)) + (error "Failed to check out test suite: ~%~a" (get-output-stream-string s))))))) + (cwd "ccl:tests;ansi-tests;") + (run-program "make" '("-k" "clean")) + (map nil 'delete-file (directory "*.*fsl")) + ;; Muffle the typecase "clause ignored" warnings, since there is really nothing we can do about + ;; it without making the test suite non-portable across platforms... + (handler-bind ((warning (lambda (c) + (when (let ((w (or (and (typep c 'compiler-warning) + (eq (compiler-warning-warning-type c) :program-error) + (car (compiler-warning-args c))) + c))) + (and (typep w 'simple-warning) + (or + (string-equal + (simple-condition-format-control w) + "Clause ~S ignored in ~S form - shadowed by ~S .") + ;; Might as well ignore these as well, they're intentional. + (string-equal + (simple-condition-format-control w) + "Duplicate keyform ~s in ~s statement.")))) + (muffle-warning c))))) + ;; This loads the infrastructure + (load "ccl:tests;ansi-tests;gclload1.lsp") + ;; This loads the actual tests + (let ((redef-var (find-symbol "*WARN-IF-REDEFINE-TEST*" :REGRESSION-TEST))) + (progv (list redef-var) (list (if force nil (symbol-value redef-var))) + (when ansi + (load "ccl:tests;ansi-tests;gclload2.lsp")) + ;; And our own tests + (when ccl + (load "ccl:tests;ansi-tests;ccl.lsp"))))))) + +(defun test-ccl (&key force (update t) verbose (catch-errors t) (ansi t) (ccl t) + optimization-settings) + (with-preserved-working-directory () + (let* ((*package* (find-package "CL-USER"))) + (ensure-tests-loaded :force force :update update :ansi ansi :ccl ccl) + (cwd "ccl:tests;ansi-tests;") + (let ((do-tests (find-symbol "DO-TESTS" "REGRESSION-TEST")) + (failed (find-symbol "*FAILED-TESTS*" "REGRESSION-TEST")) + (*print-catch-errors* nil)) + (prog1 + (time (funcall do-tests :verbose verbose :compile t + :catch-errors catch-errors + :optimization-settings (or optimization-settings '((safety 2))))) + ;; Clean up a little + (map nil #'delete-file + (directory (merge-pathnames *.fasl-pathname* "ccl:tests;ansi-tests;temp*")))) + (symbol-value failed))))) Index: /branches/new-random/lib/db-io.lisp =================================================================== --- /branches/new-random/lib/db-io.lisp (revision 13309) +++ /branches/new-random/lib/db-io.lisp (revision 13309) @@ -0,0 +1,1898 @@ +;;;-*-Mode: LISP; Package: CCL -*- +;;; +;;; Copyright (C) 2009 Clozure Associates +;;; Copyright (C) 2001 Clozure Associates +;;; This file is part of Clozure CL. +;;; +;;; Clozure CL is licensed under the terms of the Lisp Lesser GNU Public +;;; License , known as the LLGPL and distributed with Clozure CL as the +;;; file "LICENSE". The LLGPL consists of a preamble and the LGPL, +;;; which is distributed with Clozure CL as the file "LGPL". Where these +;;; conflict, the preamble takes precedence. +;;; +;;; Clozure CL is referenced in the preamble as the "LIBRARY." +;;; +;;; The LLGPL is also available online at +;;; http://opensource.franz.com/preamble.html + +;;; The "CDB" files used here are similar (but not identical) to those +;;; used in the Unix CDB package . The primary +;;; known & intentional differences are: +;;; +;;; a) key values, record positions, and other 32-bit metadata in the +;;; files are stored in native (vice little-endian) order. +;;; b) hash values are always non-negative fixnums. +;;; +;;; I haven't thought of a compelling reason to attempt full compatibility. +;;; +;;; The basic idea is that the database files are created in a batch +;;; process and are henceforth read-only (e.g., lookup is optimized by +;;; making insertion & deletion impractical or impossible.) That's +;;; just about exactly what we want here. +;;; +;;; Those of you keeping score may notice that this is the third or forth +;;; database format that Clozure CL has used for its interface database. +;;; As always, this will hopefully be the last format change; the fact +;;; that this code is self-contained (doesn't depend on any Unix database +;;; library) should make it easier to port to other platforms. + +(in-package "CCL") + +(defparameter *interface-abi-version* 2) +(defparameter *min-interface-abi-version* 1) + +(defconstant cdb-hash-mask (1- (ash 1 29))) + +(defun cdb-hash (buf len) + (declare (fixnum len)) + (let* ((h 5381)) + (declare (fixnum h)) + (dotimes (i len (logand h cdb-hash-mask)) + (setq h (+ h (the fixnum (logand cdb-hash-mask (ash h 5))))) + (setq h (logxor (the (unsigned-byte 8) (%get-unsigned-byte buf i)) h))))) + +(defconstant cdbm-hplist 1000) + +(defmacro hp-h (v n) + `(aref ,v (* ,n 2))) + +(defmacro hp-p (v n) + `(aref ,v (1+ (* ,n 2)))) + +(defstruct cdbm-hplist + (hp (make-array (* 2 cdbm-hplist) + :element-type '(unsigned-byte 32) + :initial-element 0)) + (next nil) + (num 0)) + + + + + +#+openmcl +(progn + ;;; Given a (possibly logical) PATHNAME, return a corresponding namestring + ;;; suitable for passing to an OS file-open call. + (defun cdb-native-namestring (pathname) + (native-translated-namestring pathname)) + + ;;; Open the file specified by PATHNAME for output and return a + ;;; small integer "file id" (fid). + (defun fid-open-output (pathname) + (let ((dir (make-pathname :type nil :name nil :defaults pathname))) + (unless (probe-file dir) + (error "The directory ~S does not exist, cannot open/create ~S" + dir pathname))) + (let* ((id (fd-open (cdb-native-namestring pathname) + (logior #$O_WRONLY #$O_CREAT #$O_TRUNC)))) + (if (< id 0) + (%errno-disp id pathname) + id))) + + ;;; Open the file specified by PATHNAME for input and return a + ;;; file id. + #-windows-target + (defun fid-open-input (pathname) + (let* ((id (fd-open (cdb-native-namestring pathname) #$O_RDONLY))) + (if (< id 0) + (%errno-disp id pathname) + id))) + ;; On Windows, open() can't open the same file twice, which breaks + ;; bootstrapping. Use CreateFile instead, and tell it to share. + #+windows-target + (defun fid-open-input (pathname) + (with-filename-cstrs ((name (cdb-native-namestring pathname))) + (let* ((handle (#_CreateFileW + name + #$GENERIC_READ + #$FILE_SHARE_READ + (%null-ptr) + #$OPEN_EXISTING + #$FILE_ATTRIBUTE_NORMAL + (%null-ptr)))) + (if (eql handle *windows-invalid-handle*) + (error "Error opening CDB database ~S" pathname) + (%ptr-to-int handle))))) + + ;;; Read N octets from FID into BUF. Return #of octets read or error. + (defun fid-read (fid buf n) + (let* ((count (fd-read fid buf n))) + (if (< count 0) + (%errno-disp count "reading from file") + count))) + + ;;; Write N octets to FID from BUF. Return #of octets written or error. + (defun fid-write (fid buf n) + (let* ((count (fd-write fid buf n))) + (if (< count 0) + (%errno-disp count "writing to file") + count))) + + ;;; Return the absolute (octet) position of FID. + (defun fid-pos (fid) + (fd-tell fid)) + + ;;; Return the current size of the file referenced by FID, in + ;;; octets. + (defun fid-size (fid) + (fd-size fid)) + + ;;; Seek to specified position (relative to file start.) + (defun fid-seek (fid pos) + (fd-lseek fid pos #$SEEK_SET)) + + ;;; Guess what this does ? + (defun fid-close (fid) + (fd-close fid)) + + ;;; Allocate a block of size N bytes (via malloc, #_NewPtr, etc.) + (defun cdb-alloc (n) + (malloc n)) + + ;;; Free a block allocated by cdb-alloc. + (defun cdb-free (block) + (free block)) + ) + +;;; I suppose that if we wanted to store these things in little-endian +;;; order this'd be the place to swap bytes ... +(defun fid-write-u32 (fid val) + (%stack-block ((valptr 4)) + (setf (%get-unsigned-long valptr) val) + (fid-write fid valptr 4) + val)) + +(defun fid-read-u32 (fid) + (%stack-block ((valptr 4)) + (fid-read fid valptr 4) + (%get-unsigned-long valptr))) + + + +;;; Write N elements of a vector of type (UNSIGNED-BYTE 32) to file-id +;;; FID, starting at element START. The vector should be a simple +;;; (non-displaced) array. +(defun fid-write-u32-vector (fid v n start) + (let* ((remaining-octets (* n 4)) + (start-octet (* start 4)) + (bufsize 2048)) + (%stack-block ((buf bufsize)) + (do* () + ((zerop remaining-octets)) + (let* ((chunksize (min remaining-octets bufsize))) + (%copy-ivector-to-ptr v start-octet buf 0 chunksize) + (fid-write fid buf chunksize) + (incf start-octet chunksize) + (decf remaining-octets chunksize)))))) + +(defstruct cdbx + fid ;a small integer denoting a file + pathname) ;that file's pathname + +;;; A CDBM is used to create a database. +(defstruct (cdbm (:include cdbx)) + (final (make-array (* 256 2) + :element-type '(unsigned-byte 32) + :initial-element 0)) + (count (make-array 256 :element-type '(unsigned-byte 32) :initial-element 0)) + (start (make-array 256 :element-type '(unsigned-byte 32) :initial-element 0)) + (head nil) + (split nil) + (hash nil) + (numentries 0) + ) + +(defun cdbm-open (pathname) + (let* ((fid (fid-open-output pathname)) + (cdbm (make-cdbm :fid fid :pathname pathname)) + (final (cdbm-final cdbm))) + ;;; Write the (empty) final table to the start of the file. Twice. + (fid-write-u32-vector fid final (length final) 0) + (fid-write-u32-vector fid final (length final) 0) + cdbm)) + +;;; Note a newly-added pair's file position and hash code. +(defun %cdbm-add-hash-pos (cdbm hash pos) + (let* ((head (cdbm-head cdbm))) + (when (or (null head) + (>= (cdbm-hplist-num head) cdbm-hplist)) + (setq head (make-cdbm-hplist)) + (setf (cdbm-hplist-next head) (cdbm-head cdbm) + (cdbm-head cdbm) head)) + (let* ((num (cdbm-hplist-num head)) + (hp (cdbm-hplist-hp head))) + (setf (hp-h hp num) hash + (hp-p hp num) pos)) + (incf (cdbm-hplist-num head)) + (incf (cdbm-numentries cdbm)))) + +(defun cdbm-put (cdbm key data) + (let* ((fid (cdbm-fid cdbm)) + (pos (fid-pos fid)) + (keylen (pref key :cdb-datum.size)) + (keyptr (pref key :cdb-datum.data)) + (datalen (pref data :cdb-datum.size)) + (hash (cdb-hash keyptr keylen))) + (fid-write-u32 fid keylen) + (fid-write-u32 fid datalen) + (fid-write fid keyptr keylen) + (fid-write fid (pref data :cdb-datum.data) datalen) + (%cdbm-add-hash-pos cdbm hash pos))) + +(defun %cdbm-split (cdbm) + (let* ((count (cdbm-count cdbm)) + (start (cdbm-start cdbm)) + (numentries (cdbm-numentries cdbm))) + (dotimes (i 256) (setf (aref count i) 0)) + (do* ((x (cdbm-head cdbm) (cdbm-hplist-next x))) + ((null x)) + (do* ((i (cdbm-hplist-num x)) + (hp (cdbm-hplist-hp x))) + ((zerop i)) + (decf i) + (incf (aref count (logand 255 (hp-h hp i)))))) + (let* ((memsize 1)) + (dotimes (i 256) + (let* ((u (* 2 (aref count i)))) + (if (> u memsize) + (setq memsize u)))) + (incf memsize numentries) + (let* ((split (make-array (the fixnum (* 2 memsize)) + :element-type '(unsigned-byte 32)))) + (setf (cdbm-split cdbm) split) + (setf (cdbm-hash cdbm) + (make-array (- (* 2 memsize) + (* 2 numentries)) + :element-type '(unsigned-byte 32) + :displaced-to split + :displaced-index-offset (* 2 numentries))) + (let* ((u 0)) + (dotimes (i 256) + (incf u (aref count i)) + (setf (aref start i) u))) + + (do* ((x (cdbm-head cdbm) (cdbm-hplist-next x))) + ((null x)) + (do* ((i (cdbm-hplist-num x)) + (hp (cdbm-hplist-hp x))) + ((zerop i)) + (decf i) + (let* ((idx (decf (aref start (logand 255 (hp-h hp i)))))) + (setf (hp-h split idx) (hp-h hp i) + (hp-p split idx) (hp-p hp i))))))))) + +(defun %cdbm-throw (cdbm pos b) + (let* ((count (aref (cdbm-count cdbm) b)) + (len (* 2 count)) + (hash (cdbm-hash cdbm)) + (split (cdbm-split cdbm))) + (let* ((final (cdbm-final cdbm))) + (setf (aref final (* 2 b)) pos + (aref final (1+ (* 2 b))) len)) + (unless (zerop len) + (dotimes (j len) + (setf (hp-h hash j) 0 + (hp-p hash j) 0)) + (let* ((hpi (aref (cdbm-start cdbm) b))) + (dotimes (j count) + (let* ((where (mod (ash (hp-h split hpi) -8) len))) + (do* () + ((zerop (hp-p hash where))) + (incf where) + (if (= where len) + (setq where 0))) + (setf (hp-p hash where) (hp-p split hpi) + (hp-h hash where) (hp-h split hpi) + hpi (1+ hpi)))))) + len)) + +;;; Write data structures to the file, then close the file. +(defun cdbm-close (cdbm) + (when (cdbm-fid cdbm) + (%cdbm-split cdbm) + (let* ((hash (cdbm-hash cdbm)) + (fid (cdbm-fid cdbm)) + (pos (fid-pos fid))) + (dotimes (i 256) + (let* ((len (%cdbm-throw cdbm pos i))) + (dotimes (u len) + (fid-write-u32 fid (hp-h hash u)) + (fid-write-u32 fid (hp-p hash u)) + (incf pos 8)))) + (write-cdbm-trailer cdbm) + (fid-seek fid (* 256 2 4)) ; skip the empty "final" table, write the new one + (let* ((final (cdbm-final cdbm))) + (fid-write-u32-vector fid final (length final) 0)) + (fid-close fid) + (setf (cdbm-fid cdbm) nil)))) + +(defun write-cdbm-trailer (cdbm) + (let* ((string (format nil "~s ~s ~d " "OpenMCL Interface File" (backend-name *target-backend*) *interface-abi-version*))) + (%stack-block ((buf 512)) + (%cstr-pointer string buf) + (fid-write (cdbm-fid cdbm) buf 512)))) + + +;;; A CDB is used to access a database. +(defstruct (cdb (:include cdbx)) + (lock (make-lock))) + + +;;; Do the bytes on disk match KEY ? +(defun %cdb-match (fid key keylen) + (%stack-block ((buf keylen)) + (fid-read fid buf keylen) + (dotimes (i keylen t) + (unless (= (the fixnum (%get-unsigned-byte key i)) + (the fixnum (%get-unsigned-byte buf i))) + (return))))) + +;;; Seek to file position of data associated with key. Return length +;;; of data (or NIL if no matching key.) +(defun %cdb-seek (fid key keylen) + (let* ((hash (cdb-hash key keylen))) + (fid-seek fid (+ (* 256 2 4) (* 8 (logand hash 255)))) + (let* ((pos (fid-read-u32 fid)) + (lenhash (fid-read-u32 fid))) + (unless (zerop lenhash) + (let* ((h2 (mod (ash hash -8) lenhash))) + (dotimes (i lenhash) + (fid-seek fid (+ pos (* 8 h2))) + (let* ((hashed-key (fid-read-u32 fid)) + (poskd (fid-read-u32 fid))) + (when (zerop poskd) + (return-from %cdb-seek nil)) + (when (= hashed-key hash) + (fid-seek fid poskd) + (let* ((hashed-key-len (fid-read-u32 fid)) + (data-len (fid-read-u32 fid))) + (when (= hashed-key-len keylen) + (if (%cdb-match fid key keylen) + (return-from %cdb-seek data-len))))) + (if (= (incf h2) lenhash) + (setq h2 0))))))))) + +;;; This should only be called with the cdb-lock of the containing cdb +;;; held. +(defun %cdb-get (fid key value) + (setf (pref value :cdb-datum.size) 0 + (pref value :cdb-datum.data) (%null-ptr)) + (when fid + (let* ((datalen (%cdb-seek fid + (pref key :cdb-datum.data) + (pref key :cdb-datum.size)))) + (when datalen + (let* ((buf (cdb-alloc datalen))) + (fid-read fid buf datalen) + (setf (pref value :cdb-datum.size) datalen + (pref value :cdb-datum.data) buf))) + value))) + +(defun cdb-get (cdb key value) + (with-lock-grabbed ((cdb-lock cdb)) + (%cdb-get (cdb-fid cdb) key value))) + +(defun cdb-subdirectory-path (&optional (ftd *target-ftd*)) + (let* ((ftd-name (ftd-interface-db-directory ftd)) + (ftd-dir (pathname-directory ftd-name))) + (assert (equalp (pathname-host ftd-name) "ccl")) + (assert (eq (car ftd-dir) :absolute)) + (cdr ftd-dir))) + +(defvar *interfaces-root* "ccl:") + +(defun open-interface-db-pathname (name d) + (let* ((db-path (make-pathname :host (pathname-host *interfaces-root*) + :directory (append + (or (pathname-directory *interfaces-root*) + '(:absolute)) + (cdb-subdirectory-path *target-ftd*)))) + (path (merge-pathnames name + (merge-pathnames (interface-dir-subdir d) db-path)))) + (cdb-open path))) + +(defun cdb-open (pathname) + (if (probe-file pathname) + (let* ((cdb (make-cdb :fid (fid-open-input (cdb-native-namestring pathname)) + :pathname (namestring pathname)))) + (cdb-check-trailer cdb)) + (progn + (if (probe-file (make-pathname :name nil :type nil :defaults pathname)) + (warn "Interface file ~s does not exist." pathname) + (warn "Interface file ~s does not exist, and the containing directory does not exist.~%This may mean that that the \"ccl:\" logical-pathname host has not been properly initialized. " (translate-logical-pathname pathname))) + (make-cdb :fid nil :pathname (namestring pathname))))) + +(defun cdb-check-trailer (cdb) + (flet ((error-with-cdb (string &rest args) + (error "Error in interface file at ~s: ~a" + (cdb-pathname cdb) (apply #'format nil string args)))) + (let* ((fid (cdb-fid cdb))) + (fid-seek fid (- (fid-size fid) 512)) + (%stack-block ((buf 512)) + (fid-read fid buf 512) + (let* ((string (make-string 512))) + (dotimes (i 512) + (setf (%scharcode string i) (%get-unsigned-byte buf i))) + (with-input-from-string (s string) + (let* ((sig (ignore-errors (read s))) + (target (ignore-errors (read s))) + (version (ignore-errors (read s)))) + (if (equal sig "OpenMCL Interface File") + (if (eq target (backend-name *target-backend*)) + (if (and version + (>= version *min-interface-abi-version*) + (<= version *interface-abi-version*)) + cdb + (error-with-cdb "Wrong interface ABI version. Expected ~d, got ~d" *interface-abi-version* version)) + cdb #+nil(error-with-cdb "Wrong target.")) + (error-with-cdb "Missing interface file signature. Obsolete version?"))))))))) + + + +(defun cdb-close (cdb) + (let* ((fid (cdb-fid cdb))) + (setf (cdb-fid cdb) nil) + (when fid + (fid-close fid)) + t)) + +(defmethod print-object ((cdb cdbx) stream) + (print-unreadable-object (cdb stream :type t :identity t) + (let* ((fid (cdb-fid cdb))) + (format stream "~s [~a]" (cdb-pathname cdb) (or fid "closed"))))) + + +(defun cdb-enumerate-keys (cdb &optional (predicate #'true)) + "Returns a list of all keys (strings) in the open .cdb file CDB which +satisfy the optional predicate PREDICATE." + (with-lock-grabbed ((cdb-lock cdb)) + (let* ((keys ()) + (fid (cdb-fid cdb))) + (dotimes (i 256 keys) + (fid-seek fid (+ (* 256 2 4) (* 8 i))) + (let* ((pos (fid-read-u32 fid)) + (n (fid-read-u32 fid))) + (dotimes (j n) + (fid-seek fid (+ pos (* 8 j) 4)) + (let* ((posk (fid-read-u32 fid))) + (unless (zerop posk) + (fid-seek fid posk) + (let* ((hashed-key-len (fid-read-u32 fid))) + ;; Skip hashed data length + (fid-read-u32 fid) + (let* ((string (make-string hashed-key-len))) + (%stack-block ((buf hashed-key-len)) + (fid-read fid buf hashed-key-len) + (dotimes (k hashed-key-len) + (setf (schar string k) + (code-char (%get-unsigned-byte buf k))))) + (when (funcall predicate string) + (push (copy-seq string) keys)))))))))))) + ; + + + +(defstruct ffi-type + (ordinal nil) + (defined nil) + (string) + (name) ; a keyword, uppercased or NIL +) + +(defmethod print-object ((x ffi-type) out) + (print-unreadable-object (x out :type t :identity t) + (format out "~a" (ffi-type-string x)))) + +(defvar *ffi-prefix* "") + +(defstruct (ffi-mem-block (:include ffi-type)) + fields + (anon-global-id ) + (alt-alignment-bits nil)) + +(defstruct (ffi-union (:include ffi-mem-block) + (:constructor + make-ffi-union (&key + string name + &aux + (anon-global-id + (unless name + (concatenate 'string + *ffi-prefix* + "-" string))))))) + + +(defstruct (ffi-transparent-union (:include ffi-mem-block) + (:constructor + make-ffi-transparent-union (&key + string name + &aux + (anon-global-id + (unless name + (concatenate 'string + *ffi-prefix* + "-" string))))))) +(defstruct (ffi-struct (:include ffi-mem-block) + (:constructor + make-ffi-struct (&key + string name + &aux + (anon-global-id + (unless name + (concatenate 'string + *ffi-prefix* + "-" string))))))) + +(defstruct (ffi-typedef (:include ffi-type)) + (type)) + +(defstruct (ffi-objc-class (:include ffi-type)) + super-foreign-name + protocol-names + own-ivars + ) + +(defstruct (ffi-objc-method) + class-name + arglist + result-type + flags) + +(defstruct (ffi-objc-message (:include ffi-type)) + methods) + + +(defun ffi-struct-reference (s) + (or (ffi-struct-name s) (ffi-struct-anon-global-id s))) + +(defun ffi-union-reference (u) + (or (ffi-union-name u) (ffi-union-anon-global-id u))) + +(defun ffi-transparent-union-reference (u) + (or (ffi-transparent-union-name u) (ffi-transparent-union-anon-global-id u))) + +(defstruct (ffi-function (:include ffi-type)) + arglist + return-value) + + +(eval-when (:compile-toplevel :load-toplevel :execute) +(defconstant db-string-constant 0) +(defconstant db-read-string-constant 1) +(defconstant db-s32-constant 2) +(defconstant db-u32-constant 3) +(defconstant db-float-constant 4) +(defconstant db-double-constant 5) +(defconstant db-char-constant 6) +(defconstant db-pointer-constant 7) +) + +(defparameter *arg-spec-encoding* + '((#\Space . :void) + (#\a . :address) + (#\F . :signed-fullword) + (#\f . :unsigned-fullword) + (#\H . :signed-halfword) + (#\h . :unsigned-halfword) + (#\B . :signed-byte) + (#\b . :unsigned-byte) + (#\s . :single-float) + (#\d . :double-float) + (#\L . :signed-doubleword) + (#\l . :unsigned-doubleword) + (#\r . :record))) + + + +(defun decode-arguments (string) + (let* ((result nil)) + (collect ((args)) + (do* ((i 0 (1+ i))) + ((= i (length string)) (values (args) result)) + (declare (fixnum i)) + (let* ((ch (schar string i)) + (val (if (or (eql ch #\r) (eql ch #\u) (eql ch #\t)) + (let* ((namelen (char-code (schar string (incf i)))) + (name (make-string namelen))) + (dotimes (k namelen) + (setf (schar name k) + (schar string (incf i)))) + (setq name (escape-foreign-name name)) + (if (eql ch #\r) + `(:struct ,name) + (if (eql ch #\u) + `(:union ,name) + (if (eql ch #\U) + `(:transparent-union ,name) + name)))) + (cdr (assoc ch *arg-spec-encoding*))))) + (if result + (args val) + (setq result val))))))) + + +;;; encoded external function looks like: +;;; byte min-args +;;; byte name-length +;;; name-length bytes of name +;;; result+arg specs + +(defun extract-db-function (datum) + (let* ((val nil) + (dsize (pref datum :cdb-datum.size))) + (with-macptrs ((dptr)) + (%setf-macptr dptr (pref datum :cdb-datum.data)) + (unless (%null-ptr-p dptr) + (let* ((min-args (%get-byte dptr)) + (name-len (%get-byte dptr 1)) + (external-name (%str-from-ptr (%inc-ptr dptr 2) name-len)) + (encoding-len (- dsize (+ 2 name-len))) + (encoding (make-string encoding-len))) + (declare (dynamic-extent encoding)) + (%str-from-ptr (%inc-ptr dptr (+ 2 name-len)) encoding-len encoding) + (cdb-free (pref datum :cdb-datum.data)) + (multiple-value-bind (args result) + (decode-arguments encoding) + (setq val (make-external-function-definition + :entry-name external-name + :arg-specs args + :result-spec result + :min-args min-args)))))) + val)) + +(defun db-lookup-function (cdb name) + (when cdb + (rletZ ((value :cdb-datum) + (key :cdb-datum)) + (with-cstrs ((keyname (string name))) + (setf (pref key :cdb-datum.data) keyname + (pref key :cdb-datum.size) (length (string name)) + (pref value :cdb-datum.data) (%null-ptr) + (pref value :cdb-datum.size) 0) + (cdb-get cdb key value) + (extract-db-function value))))) + + + + + +(defun extract-db-constant-value (datum) + (let* ((val nil) + (dsize (pref datum :cdb-datum.size))) + (with-macptrs ((dptr)) + (%setf-macptr dptr (pref datum :cdb-datum.data)) + (unless (%null-ptr-p dptr) + (let* ((class (pref dptr :dbm-constant.class))) + (setq val + (ecase class + ((#.db-string-constant #.db-read-string-constant) + (let* ((str (%str-from-ptr (%inc-ptr dptr 4) (- dsize 4)))) + (if (eql class db-read-string-constant) + (read-from-string str) + str))) + (#.db-s32-constant (pref dptr :dbm-constant.value.s32)) + (#.db-u32-constant (pref dptr :dbm-constant.value.u32)) + (#.db-float-constant (pref dptr :dbm-constant.value.single-float)) + (#.db-double-constant (pref dptr :dbm-constant.value.double-float)) + (#.db-char-constant (code-char (pref dptr :dbm-constant.value.u32))) + (#.db-pointer-constant + (let* ((val (pref dptr :dbm-constant.value.u32))) + #+64-bit-target + (if (logbitp 31 val) + (setq val (logior val (ash #xffffffff 32)))) + (%int-to-ptr val ))))) + (cdb-free (pref datum :cdb-datum.data))))) + val)) + + + +(defun db-lookup-constant (cdb name) + (when cdb + (rletZ ((value :cdb-datum) + (key :cdb-datum)) + (with-cstrs ((keyname (string name))) + (setf (pref key :cdb-datum.data) keyname + (pref key :cdb-datum.size) (length (string name)) + (pref value :cdb-datum.data) (%null-ptr) + (pref value :cdb-datum.size) 0) + (cdb-get cdb key value) + (extract-db-constant-value value))))) + + + +(defun db-define-string-constant (cdbm name val &optional (class db-string-constant)) + (let* ((dsize (+ 4 (length val)))) + (%stack-block ((valbuf dsize)) + (dotimes (i (length val)) + (setf (%get-unsigned-byte valbuf (the fixnum (+ 4 i))) + (%scharcode val i))) + (setf (%get-long valbuf) class) + (rletZ ((content :cdb-datum) + (key :cdb-datum)) + (setf (pref content :cdb-datum.size) dsize + (pref content :cdb-datum.data) valbuf) + (with-cstrs ((keyname (string name))) + (setf (pref key :cdb-datum.size) (length (string name)) + (pref key :cdb-datum.data) keyname) + (cdbm-put cdbm key content)))))) + +(defun db-define-constant (cdbm name val) + (typecase val + (string (db-define-string-constant cdbm name val)) + ((or (unsigned-byte 32) + (signed-byte 32) + short-float + double-float + character + macptr) + (rletZ ((constant :dbm-constant) + (content :cdb-datum) + (key :cdb-datum)) + (etypecase val + ((signed-byte 32) + (setf (pref constant :dbm-constant.value.s32) val) + (setf (pref constant :dbm-constant.class) db-s32-constant)) + ((unsigned-byte 32) + (setf (pref constant :dbm-constant.value.u32) val) + (setf (pref constant :dbm-constant.class) db-u32-constant)) + (short-float + (setf (pref constant :dbm-constant.value.single-float) val) + (setf (pref constant :dbm-constant.class) db-float-constant)) + (double-float + (setf (pref constant :dbm-constant.value.double-float) val) + (setf (pref constant :dbm-constant.class) db-double-constant)) + (character + (setf (pref constant :dbm-constant.value.u32) (char-code val)) + (setf (pref constant :dbm-constant.class) db-char-constant)) + (macptr + (setf (pref constant :dbm-constant.value.u32) (logand #xffffffff (%ptr-to-int val))) + (setf (pref constant :dbm-constant.class) db-pointer-constant)) + ) + (setf (pref content :cdb-datum.data) constant + (pref content :cdb-datum.size) (record-length :dbm-constant)) + (with-cstrs ((keyname (string name))) + (setf (pref key :cdb-datum.data) keyname + (pref key :cdb-datum.size) (length (string name))) + (cdbm-put cdbm key content)))) + (t (db-define-string-constant cdbm name (format nil "~a" val) db-read-string-constant)))) + + + + +(defmacro with-new-db-file ((var pathname) &body body) + (let* ((db (gensym))) + `(let* (,db) + (unwind-protect + (let* ((,var (setq ,db (cdbm-open ,pathname)))) + ,@body) + (when ,db (cdbm-close ,db)))))) + + + +(defun interface-db-pathname (name d &optional (ftd *target-ftd*)) + (merge-pathnames name + (merge-pathnames (interface-dir-subdir d) + (ftd-interface-db-directory ftd)))) + +(def-ccl-pointers reset-db-files () + (do-interface-dirs (d) + (setf (interface-dir-constants-interface-db-file d) nil + (interface-dir-functions-interface-db-file d) nil + (interface-dir-records-interface-db-file d) nil + (interface-dir-types-interface-db-file d) nil + (interface-dir-vars-interface-db-file d) nil + (interface-dir-objc-classes-interface-db-file d) nil + (interface-dir-objc-methods-interface-db-file d) nil))) + +(defun db-constants (dir) + (or (interface-dir-constants-interface-db-file dir) + (setf (interface-dir-constants-interface-db-file dir) + (open-interface-db-pathname "constants.cdb" dir)))) + +(defun db-objc-classes (dir) + (or (interface-dir-objc-classes-interface-db-file dir) + (setf (interface-dir-objc-classes-interface-db-file dir) + (open-interface-db-pathname "objc-classes.cdb" dir)))) + +(defun db-objc-methods (dir) + (or (interface-dir-objc-methods-interface-db-file dir) + (setf (interface-dir-objc-methods-interface-db-file dir) + (open-interface-db-pathname "objc-methods.cdb" dir)))) + +(defun db-vars (dir) + (or (interface-dir-vars-interface-db-file dir) + (setf (interface-dir-vars-interface-db-file dir) + (open-interface-db-pathname "vars.cdb" dir)))) + +(defun db-types (dir) + (or (interface-dir-types-interface-db-file dir) + (setf (interface-dir-types-interface-db-file dir) + (open-interface-db-pathname "types.cdb" dir)))) + +(defun db-records (dir) + (or (interface-dir-records-interface-db-file dir) + (setf (interface-dir-records-interface-db-file dir) + (open-interface-db-pathname "records.cdb" dir)))) + +(defun db-functions (dir) + (or (interface-dir-functions-interface-db-file dir) + (setf (interface-dir-functions-interface-db-file dir) + (open-interface-db-pathname "functions.cdb" dir)))) + +(defun load-os-constant (sym &optional query) + (let* ((val (do-interface-dirs (d) + (let* ((v (db-lookup-constant (db-constants d) sym))) + (when v (return v)))))) + (if query + (not (null val)) + (if val + (let* ((*record-source-file* nil)) + (%defconstant sym val) + val) + (error "Constant not found: ~s" sym))))) + +(defun %load-var (name &optional query-only) + (let* ((ftd *target-ftd*) + (string (if (getf (ftd-attributes ftd) + :prepend-underscores) + (concatenate 'string "_" (string name)) + (string name))) + (fv (gethash string (fvs)))) + (unless fv + (with-cstrs ((cstring string)) + (let* ((type + (do-interface-dirs (d) + (let* ((vars (db-vars d))) + (when vars + (rletZ ((value :cdb-datum) + (key :cdb-datum)) + (setf (pref key :cdb-datum.data) cstring + (pref key :cdb-datum.size) (length string) + (pref value :cdb-datum.data) (%null-ptr) + (pref value :cdb-datum.size) 0) + (cdb-get vars key value) + (let* ((vartype (extract-db-type value ftd))) + (when vartype (return vartype))))))))) + (when type + (setq fv (%cons-foreign-variable string type)) + (resolve-foreign-variable fv nil) + (setf (gethash string (fvs)) fv))))) + (if query-only + (not (null fv)) + (or fv (error "Foreign variable ~s not found" string))))) + + +(set-dispatch-macro-character + #\# #\& + (qlfun |#&-reader| (stream char arg) + (declare (ignore char arg)) + (let* ((package (find-package (ftd-interface-package-name *target-ftd*)))) + (multiple-value-bind (sym query source) + (%read-symbol-preserving-case + stream + package) + (unless *read-suppress* + (let* ((fv (%load-var sym query))) + (values (if query + fv + (%foreign-access-form `(%reference-external-entry-point (load-time-value ,fv)) + (fv.type fv) + 0 + nil)) + source))))))) + + + + +(defstruct objc-message-info + message-name + methods ; all methods + ambiguous-methods ; partitioned by signature + req-args + flags + protocol-methods + lisp-name + selector) + + + + +(defstruct objc-method-info + message-info + class-name + class-pointer ;canonical, in some sense + arglist + result-type + flags + signature + signature-info + ) + + + +(defmethod print-object ((m objc-method-info) stream) + (print-unreadable-object (m stream :type t :identity t) + (format stream "~c[~a ~a]" + (if (getf (objc-method-info-flags m) :class) + #\+ + #\-) + (let* ((name (objc-method-info-class-name m))) + (if (getf (objc-method-info-flags m) :protocol) + (format nil "<~a>" name) + name)) + (objc-message-info-message-name + (objc-method-info-message-info m))))) + +(defun extract-db-objc-message-info (datum message-name info &optional + (ftd *target-ftd*)) + (with-macptrs ((buf)) + (%setf-macptr buf (pref datum :cdb-datum.data)) + (unless (%null-ptr-p buf) + (unless info + (setq info + (make-objc-message-info + :message-name (string message-name)))) + (let* ((p 0) + (nmethods 0) + (nargs 0)) + (multiple-value-setq (nmethods p) (%decode-uint buf p)) + (multiple-value-setq (nargs p) (%decode-uint buf p)) + (dotimes (i nmethods) + (let* ((flag-byte (prog1 (%get-unsigned-byte buf p) + (incf p))) + (is-class-method (logbitp 0 flag-byte)) + (is-protocol-method (logbitp 1 flag-byte)) + (class-name ()) + (result-type ()) + (arg-types ()) + (arg-type ())) + (multiple-value-setq (class-name p) (%decode-name buf p t)) + (multiple-value-setq (result-type p) (%decode-type buf p ftd t)) + (dotimes (i nargs) + (multiple-value-setq (arg-type p) (%decode-type buf p ftd t)) + (push arg-type arg-types)) + (unless (dolist (m (objc-message-info-methods info)) + (when (and (eq (getf (objc-method-info-flags m) :class) is-class-method) + (string= (objc-method-info-class-name m) + class-name)) + (return t))) + (let* ((flags ())) + (if is-class-method + (setf (getf flags :class) t)) + (if is-protocol-method + (setf (getf flags :protocol) t)) + (push (make-objc-method-info + :message-info info + :class-name class-name + :arglist (nreverse arg-types) + :result-type result-type + :flags flags) + (objc-message-info-methods info)))))) + (cdb-free (pref datum :cdb-datum.data)))) + info)) + +(defun db-note-objc-method-info (cdb message-name message-info) + (when cdb + (rletZ ((value :cdb-datum) + (key :cdb-datum)) + (with-cstrs ((keyname (string message-name))) + (setf (pref key :cdb-datum.data) keyname + (pref key :cdb-datum.size) (length (string message-name)) + (pref value :cdb-datum.data) (%null-ptr) + (pref value :cdb-datum.size) 0) + (cdb-get cdb key value) + (extract-db-objc-message-info value message-name message-info))))) + +(defun lookup-objc-message-info (message-name &optional message-info) + (do-interface-dirs (d) + (setq message-info + (db-note-objc-method-info (db-objc-methods d) message-name message-info))) + message-info) + +(defun %find-objc-class-info (name) + (do-interface-dirs (d) + (let* ((info (db-lookup-objc-class (db-objc-classes d) name))) + (when info (return info))))) + +(defun load-external-function (sym query) + (let* ((def (or (do-interface-dirs (d) + (let* ((f (db-lookup-function (db-functions d) sym))) + (when f (return f)))) + (unless query + (error "Foreign function not found: ~s" sym))))) + (if query + (not (null def)) + (progn + (setf (gethash sym (ftd-external-function-definitions + *target-ftd*)) def) + (setf (macro-function sym) #'%external-call-expander) + sym)))) + +(defun %read-symbol-preserving-case (stream package) + (let* ((case (readtable-case *readtable*)) + (query nil) + (error nil) + (sym nil) + (source nil)) + (let* ((*package* package)) + (unwind-protect + (progn + (setf (readtable-case *readtable*) :preserve) + (when (eq #\? (peek-char t stream nil nil)) + (setq query t) + (read-char stream)) + (multiple-value-setq (sym source error) + (handler-case (read-internal stream nil nil nil) + (error (condition) (values nil nil condition))))) + (setf (readtable-case *readtable*) case))) + (when error + (error error)) + (values sym query source))) + +(set-dispatch-macro-character + #\# #\$ + (qlfun |#$-reader| (stream char arg) + (declare (ignore char)) + (let* ((package (find-package (ftd-interface-package-name *target-ftd*)))) + (multiple-value-bind (sym query source) + (%read-symbol-preserving-case + stream + package) + (unless *read-suppress* + (etypecase sym + (symbol + (let* ((const (load-os-constant sym t))) + (if query + (values const source) + (progn + (if const + (progn + (when (eq (symbol-package sym) package) + (unless arg (setq arg 0)) + (ecase arg + (0 + (unless (and (constant-symbol-p sym) + (not (eq (%sym-global-value sym) + (%unbound-marker-8)))) + (load-os-constant sym))) + (1 (makunbound sym) (load-os-constant sym)))) + (values sym source)) + (let* ((fv (%load-var sym nil))) + (values + (%foreign-access-form `(%reference-external-entry-point (load-time-value ,fv)) + (fv.type fv) + 0 + nil) + source))))))) + (string + (let* ((val 0) + (len (length sym))) + (dotimes (i 4 (values val source)) + (let* ((ch (if (< i len) (char sym i) #\space))) + (setq val (logior (ash val 8) (char-code ch))))))))))))) + +(set-dispatch-macro-character #\# #\_ + (qlfun |#_-reader| (stream char arg) + (declare (ignore char)) + (unless arg (setq arg 0)) + (multiple-value-bind (sym query source) + (%read-symbol-preserving-case + stream + (find-package (ftd-interface-package-name *target-ftd*))) + (unless *read-suppress* + (unless (and sym (symbolp sym)) (report-bad-arg sym 'symbol)) + (if query + (values (load-external-function sym t) source) + (let* ((def (if (eql arg 0) + (gethash sym (ftd-external-function-definitions + *target-ftd*))))) + (values (if (and def (eq (macro-function sym) #'%external-call-expander)) + sym + (load-external-function sym nil)) + source))))))) + +(set-dispatch-macro-character + #\# #\> + (qlfun |#>-reader| (stream char arg) + (declare (ignore char arg)) + (if *read-suppress* + (progn + (%read-list-expression stream nil) + nil) + (let* ((readtable *readtable*) + (case (readtable-case readtable)) + (string nil) + (error nil)) + (unwind-protect + (progn + (setf (readtable-case readtable) :preserve) + (multiple-value-setq (string error) + (handler-case (read-symbol-token stream) + (error (condition) (values nil condition))))) + (setf (readtable-case *readtable*) case)) + (when error + (error error)) + (escape-foreign-name string))))) + + + + +(eval-when (:compile-toplevel :execute) + (defconstant encoded-type-void 0) + (defconstant encoded-type-signed-32 1) + (defconstant encoded-type-unsigned-32 2) + (defconstant encoded-type-signed-8 3) + (defconstant encoded-type-unsigned-8 4) + (defconstant encoded-type-signed-16 5) + (defconstant encoded-type-unsigned-16 6) + (defconstant encoded-type-signed-n 7) ;N + (defconstant encoded-type-unsigned-n 8) ;N + (defconstant encoded-type-single-float 9) + (defconstant encoded-type-double-float 10) + (defconstant encoded-type-pointer 11) ; + (defconstant encoded-type-array 12) ; + (defconstant encoded-type-named-struct-ref 13); + (defconstant encoded-type-named-union-ref 14) ; + (defconstant encoded-type-named-type-ref 15) ; + (defconstant encoded-type-anon-struct-ref 16) ; + (defconstant encoded-type-anon-union-ref 17) ; + (defconstant encoded-type-bitfield-marker 18) ; + (defconstant encoded-type-named-transparent-union-ref 19) ; + (defconstant encoded-type-anon-transparent-union-ref 20) ; + ) + + +(defconstant encoded-type-type-byte (byte 5 0)) +(defconstant encoded-type-align-byte (byte 3 5) + "alignment in octets, if other than \"natural\" alignment,") + +;;; Constants & function names get saved verbatim. +;;; Record, type, and field names get escaped. + +(defun encode-name (name &optional verbatim) + (if (null name) + (list 0) + (let* ((string + (if (and (typep name 'keyword) + (not verbatim)) + (unescape-foreign-name name) + (string name))) + (length (length string))) + (cons length (map 'list #'char-code string))))) + +(defun encode-ffi-field (field) + (destructuring-bind (name type offset width) field + `(,@(encode-name name) + ,@(encode-ffi-type type) + ,@(encode-uint offset) + ,@(encode-uint width)))) + +(defun encode-ffi-field-list (fields) + (let* ((len (length fields))) + (labels ((encode-fields (fields) + (if fields + `(,@(encode-ffi-field (car fields)) ,@(encode-fields (cdr fields)))))) + `(,@(encode-uint len) ,@(encode-fields fields))))) + +(defun encode-ffi-union (u) + (let* ((name (ffi-union-name u)) + (alt-align-in-bytes-mask (ash (or (ffi-union-alt-alignment-bits u) + 0) + (- 5 3)))) + (if name + `(,(logior encoded-type-named-union-ref alt-align-in-bytes-mask) + ,@(encode-name name) + ,@(encode-ffi-field-list (ffi-union-fields u))) + `(,(logior encoded-type-anon-union-ref alt-align-in-bytes-mask) + ,@(encode-ffi-field-list (ffi-union-fields u)))))) + +(defun encode-ffi-transparent-union (u) + (let* ((name (ffi-transparent-union-name u)) + (alt-align-in-bytes-mask (ash (or (ffi-transparent-union-alt-alignment-bits u) + 0) + (- 5 3)))) + (if name + `(,(logior encoded-type-named-transparent-union-ref alt-align-in-bytes-mask) + ,@(encode-name name) + ,@(encode-ffi-field-list (ffi-union-fields u))) + `(,(logior encoded-type-anon-transparent-union-ref alt-align-in-bytes-mask) + ,@(encode-ffi-field-list (ffi-union-fields u)))))) + +(defun encode-ffi-struct (s) + (let* ((name (ffi-struct-name s)) + (alt-align-in-bytes-mask (ash (or (ffi-struct-alt-alignment-bits s) + 0) + (- 5 3)))) + (if name + `(,(logior encoded-type-named-struct-ref alt-align-in-bytes-mask) + ,@(encode-name (ffi-struct-name s)) + ,@(encode-ffi-field-list (ffi-struct-fields s))) + `(,(logior encoded-type-anon-struct-ref alt-align-in-bytes-mask) + ,@(encode-ffi-field-list (ffi-struct-fields s)))))) + +(defun encode-ffi-objc-class (c) + (let* ((protocols (ffi-objc-class-protocol-names c))) + (labels ((encode-name-list (names) + (if names + `(,@(encode-name (car names) t) + ,@(encode-name-list (cdr names)))))) + `(,@(encode-name (ffi-objc-class-string c)) + ,@(encode-name (ffi-objc-class-super-foreign-name c)) + ,@(encode-uint (length protocols)) + ,@(encode-name-list protocols) + ,@(encode-ffi-field-list (ffi-objc-class-own-ivars c)))))) + + +(defstruct db-objc-class-info + class-name + superclass-name + protocols + ivars + instance-methods + class-methods + ) + +(defun extract-db-objc-class (datum &optional (ftd *target-ftd*)) + (let* ((val nil)) + (with-macptrs ((buf)) + (%setf-macptr buf (pref datum :cdb-datum.data)) + (unless (%null-ptr-p buf) + (let* ((p 0) + (protocol-count 0) + (class-name ()) + (superclass-name ()) + (protocol-name ()) + (ivars ())) + (collect ((protocols)) + (multiple-value-setq (class-name p) (%decode-name buf p t)) + (multiple-value-setq (superclass-name p) (%decode-name buf p t)) + (multiple-value-setq (protocol-count p) (%decode-uint buf p)) + (dotimes (i protocol-count) + (multiple-value-setq (protocol-name p) (%decode-name buf p t)) + (protocols protocol-name)) + (setq ivars (%decode-field-list buf p ftd)) + (cdb-free (pref datum :cdb-datum.data)) + (setq val (make-db-objc-class-info + :class-name class-name + :superclass-name superclass-name + :ivars ivars + :protocols (protocols) + )))))) + val)) + +(defun db-lookup-objc-class (cdb name) + (when cdb + (rletZ ((value :cdb-datum) + (key :cdb-datum)) + (with-cstrs ((keyname (string name))) + (setf (pref key :cdb-datum.data) keyname + (pref key :cdb-datum.size) (length (string name)) + (pref value :cdb-datum.data) (%null-ptr) + (pref value :cdb-datum.size) 0) + (cdb-get cdb key value) + (extract-db-objc-class value))))) + +(defun encode-u32 (val) + `(,(ldb (byte 8 24) val) + ,(ldb (byte 8 16) val) + ,(ldb (byte 8 8) val) + ,(ldb (byte 8 0) val))) + +(defun encode-uint (val) + (collect ((bytes)) + (do* ((b (ldb (byte 7 0) val) (ldb (byte 7 0) val)) + (done nil)) + (done (bytes)) + (when (zerop (setq val (ash val -7))) + (setq b (logior #x80 b) done t)) + (bytes b)))) + + + +(defun encode-ffi-type (spec) + (case (car spec) + (:primitive + (let ((primtype (cadr spec))) + (if (atom primtype) + (case primtype + (:float `(,encoded-type-single-float)) + (:double `(,encoded-type-double-float)) + (:void `(,encoded-type-void)) + (:signed `(,encoded-type-signed-32)) + (:unsigned `(,encoded-type-unsigned-32)) + ((:long-double :complex-int + :complex-float :complex-double :complex-long-double) + (encode-ffi-type `(:struct ,primtype)))) + (ecase (car primtype) + (* `(,encoded-type-pointer ,@(encode-ffi-type + (if (eq (cadr primtype) t) + `(:primitive :void) + (cadr primtype))))) + (:signed + (case (cadr primtype) + (32 `(,encoded-type-signed-32)) + (16 `(,encoded-type-signed-16)) + (8 `(,encoded-type-signed-8)) + (t `(,encoded-type-signed-n ,(cadr primtype))))) + (:unsigned + (case (cadr primtype) + (32 `(,encoded-type-unsigned-32)) + (16 `(,encoded-type-unsigned-16)) + (8 `(,encoded-type-unsigned-8)) + (t `(,encoded-type-unsigned-n ,(cadr primtype))))))))) + (:struct + (let* ((s (cadr spec)) + (name (ffi-struct-name s)) + (alt-align-bytes-mask (ash (or (ffi-struct-alt-alignment-bits s) + 0) + (- 5 3)))) + `(,(if name + (logior encoded-type-named-struct-ref alt-align-bytes-mask) + (logior encoded-type-anon-struct-ref alt-align-bytes-mask)) + ,@(encode-name (ffi-struct-reference s))))) + (:union + (let* ((u (cadr spec)) + (name (ffi-union-name u)) + (alt-align-bytes-mask (ash (or (ffi-union-alt-alignment-bits u) + 0) + (- 5 3))) ) + `(,(if name + (logior encoded-type-named-union-ref alt-align-bytes-mask) + (logior encoded-type-anon-union-ref alt-align-bytes-mask)) + ,@(encode-name (ffi-union-reference u))))) + (:transparent-union + (let* ((u (cadr spec)) + (name (ffi-transparent-union-name u)) + (alt-align-bytes-mask (ash (or (ffi-union-alt-alignment-bits u) + 0) + (- 5 3))) ) + `(,(if name + (logior encoded-type-named-transparent-union-ref alt-align-bytes-mask) + (logior encoded-type-anon-transparent-union-ref alt-align-bytes-mask)) + ,@(encode-name (ffi-transparent-union-reference u))))) + (:typedef + `(,encoded-type-named-type-ref ,@(encode-name (ffi-typedef-name (cadr spec))))) + (:pointer + `(,encoded-type-pointer ,@(encode-ffi-type + (if (eq (cadr spec) t) + '(:primitive :void) + (cadr spec))))) + (:array + `(,encoded-type-array ,@(encode-uint (cadr spec)) ,@(encode-ffi-type (caddr spec)))) + (t + (break "Type spec = ~s" spec)))) + +(defun encode-ffi-arg-type (spec) + (case (car spec) + (:primitive + (let ((primtype (cadr spec))) + (if (atom primtype) + (case primtype + (:float `(#\s)) + (:double `(#\d)) + (:void `(#\Space)) + (:signed `(#\F)) + (:unsigned `(f)) + ((:long-double :complex-int + :complex-float :complex-double :complex-long-double) + #|(encode-ffi-arg-type `(:struct ,primtype))|# + `(#\?))) + (ecase (car primtype) + (* `(#\a)) + (:signed + (let* ((nbits (cadr primtype))) + (if (<= nbits 8) + '(#\B) + (if (<= nbits 16) + '(#\H) + (if (<= nbits 32) + '(#\F) + (if (<= nbits 64) + `(#\L) + '(#\?))))))) + (:unsigned + (let* ((nbits (cadr primtype))) + (if (<= nbits 8) + '(#\b) + (if (<= nbits 16) + '(#\h) + (if (<= nbits 32) + '(#\f) + (if (<= nbits 64) + `(#\l) + '(#\?))))))))))) + ((:struct :union :transparent-union) + `(,(ecase (car spec) + (:struct #\r) + (:union #\u) + (:transparent-union #\U)) + ,@(encode-name (ffi-struct-reference (cadr spec))))) + (:typedef + `(#\t ,@(encode-name (ffi-typedef-name (cadr spec))))) + (:pointer + `(#\a)) + (:array + `(#\?)))) + +(defun encode-ffi-arg-list (args) + (if args + `(,@(encode-ffi-arg-type (car args)) ,@(encode-ffi-arg-list (cdr args))))) + +(defvar *prepend-underscores-to-ffi-function-names* nil) + +(defun encode-ffi-function (f) + (let* ((args (ffi-function-arglist f)) + (string (ffi-function-string f)) + (name (if *prepend-underscores-to-ffi-function-names* + (concatenate 'string "_" string) + string)) + (min-args (length args)) + (result (ffi-function-return-value f))) + `(,min-args + ,@(encode-name name t) ; verbatim + ,@(encode-ffi-arg-type result) + ,@(encode-ffi-arg-list args)))) + +(defun encode-ffi-objc-method (m) + (let* ((flag-byte (logior (if (getf (ffi-objc-method-flags m) :class) 1 0) + (if (getf (ffi-objc-method-flags m) :protocol) 2 0)))) + `(,flag-byte + ,@(encode-name (ffi-objc-method-class-name m) t) + ,@(encode-ffi-type (ffi-objc-method-result-type m)) + ,@(apply #'append (mapcar #'encode-ffi-type (ffi-objc-method-arglist m)))))) + +(defun save-ffi-objc-message (cdbm message) + (let* ((methods (ffi-objc-message-methods message)) + (nmethods (length methods)) + (nargs (length (ffi-objc-method-arglist (car methods))))) + (labels ((encode-objc-method-list (ml) + (when ml + `(,@(encode-ffi-objc-method (car ml)) + ,@(encode-objc-method-list (cdr ml)))))) + (db-write-byte-list cdbm + (ffi-objc-message-string message) + `(,@(encode-uint nmethods) + ,@(encode-uint nargs) + ,@(encode-objc-method-list methods)) + t)))) + + +(defun save-byte-list (ptr l) + (do* ((l l (cdr l)) + (i 0 (1+ i))) + ((null l)) + (let* ((b (car l))) + (if (typep b 'character) + (setq b (char-code b))) + (setf (%get-unsigned-byte ptr i) b)))) + +(defun db-write-byte-list (cdbm keyname bytes &optional verbatim) + (let* ((len (length bytes))) + (%stack-block ((p len)) + (save-byte-list p bytes) + (rletZ ((contents :cdb-datum) + (key :cdb-datum)) + (let* ((foreign-name + (if verbatim + keyname + (unescape-foreign-name keyname)))) + (with-cstrs ((keystring foreign-name)) + (setf (pref contents :cdb-datum.data) p + (pref contents :cdb-datum.size) len + (pref key :cdb-datum.data) keystring + (pref key :cdb-datum.size) (length foreign-name)) + (cdbm-put cdbm key contents))))))) + +(defun save-ffi-function (cdbm fun) + (let* ((encoding (encode-ffi-function fun))) + (db-write-byte-list cdbm + (ffi-function-string fun) + encoding + t))) + +(defun save-ffi-typedef (cdbm def) + (db-write-byte-list cdbm + (ffi-typedef-string def) + (encode-ffi-type (ffi-typedef-type def)) + t)) + +(defun save-ffi-struct (cdbm s) + (db-write-byte-list cdbm (ffi-struct-reference s) (encode-ffi-struct s))) + +(defun save-ffi-union (cdbm u) + (db-write-byte-list cdbm (ffi-union-reference u) (encode-ffi-union u))) + +(defun save-ffi-transparent-union (cdbm u) + (db-write-byte-list cdbm (ffi-transparent-union-reference u) (encode-ffi-transparent-union u))) + + +(defun db-define-var (cdbm name type) + (db-write-byte-list cdbm + (if *prepend-underscores-to-ffi-function-names* + (concatenate 'string "_" name) + name) + (encode-ffi-type type) t)) + +(defun save-ffi-objc-class (cdbm c) + (db-write-byte-list cdbm (ffi-objc-class-name c) (encode-ffi-objc-class c))) + + +;;; An "uppercase-sequence" is a maximal substring of a string that +;;; starts with an uppercase character and doesn't contain any +;;; lowercase characters. +(defun count-uppercase-sequences (string) + (let* ((state :lower) + (nupper 0)) + (declare (fixnum nupper)) + (dotimes (i (length string) nupper) + (let* ((ch (char string i))) + (case state + (:lower + (when (upper-case-p ch) + (incf nupper) + (setq state :upper))) + (:upper + (unless (upper-case-p ch) + (setq state :lower)))))))) + +(defun escape-foreign-name (in &optional + (count (count-uppercase-sequences in))) + (intern + (if (zerop count) + (string-upcase in) + (let* ((len (length in)) + (j 0) + (out (make-string (+ len (* 2 count)))) + (state :lower)) + (flet ((outch (ch) + (setf (schar out j) ch) + (incf j) + ch)) + (dotimes (i len (progn (if (eq state :upper) (outch #\>)) out)) + (let* ((ch (char in i))) + (cond ((and (upper-case-p ch) (eq state :lower)) + (outch #\<) + (setq state :upper)) + ((and (not (upper-case-p ch)) (eq state :upper)) + (outch #\>) + (setq state :lower))) + (outch (char-upcase ch))))))) + *keyword-package*)) + +(defun unescape-foreign-name (key) + (let* ((string (if (typep key 'symbol) + (string-downcase key) + (string key))) + (nleftbrackets (count #\< string)) + (nrightbrackets (count #\> string)) + (nbrackets (+ nleftbrackets nrightbrackets))) + (declare (fixnum nleftbrackets nrightbrackets nbrackets)) + (if (zerop nbrackets) + string + (if (/= nleftbrackets nrightbrackets) + (error "Mismatched brackets in ~s." key) + (let* ((len (length string)) + (out (make-string (- len nbrackets))) + (j 0) + (state :lower)) + (dotimes (i len out) + (let* ((ch (schar string i))) + (if (or (and (eq ch #\<) + (eq state :upper)) + (and (eq ch #\>) + (eq state :lower))) + (error "Mismatched brackets in ~s." key)) + (case ch + (#\< (setq state :upper)) + (#\> (setq state :lower)) + (t (setf (schar out j) (if (eq state :upper) + (char-upcase ch) + (char-downcase ch)) + j (1+ j))))))))))) + + + +(defun %decode-name (buf p &optional verbatim) + (declare (type macptr buf) (fixnum p)) + (let* ((n (%get-unsigned-byte buf p))) + (declare (fixnum n)) + (if (zerop n) + (values nil (1+ p)) + (let* ((pname (%str-from-ptr (%inc-ptr buf (1+ p)) n))) + (values (if verbatim pname (escape-foreign-name pname)) + (+ p (1+ n))))))) + +(defun %decode-u32 (buf p) + (declare (fixnum p) (type macptr buf)) + (values (dpb + (%get-unsigned-byte buf p) + (byte 8 24) + (dpb + (%get-unsigned-byte buf (+ p 1)) + (byte 8 16) + (dpb + (%get-unsigned-byte buf (+ p 2)) + (byte 8 8) + (%get-unsigned-byte buf (+ p 3))))) + (+ p 4))) + +(defun %decode-uint (buf p) + (do* ((val 0) + (p p (1+ p)) + (shift 0 (+ shift 7)) + (done nil)) + (done (values val p)) + (let* ((b (%get-unsigned-byte buf p))) + (setq done (logbitp 7 b) val (logior val (ash (logand b #x7f) shift)))))) + + +;; Should return a FOREIGN-TYPE structure (except if suppress-typedef-expansion is true, may +;; return a symbol for encoded-type-named-type-ref) +(defun %decode-type (buf p ftd &optional suppress-typedef-expansion) + (declare (type macptr buf) (fixnum p)) + (let* ((q (1+ p))) + (ecase (ldb encoded-type-type-byte (%get-unsigned-byte buf p)) + (#.encoded-type-void (values (parse-foreign-type :void) q)) + (#.encoded-type-signed-32 (values (svref *signed-integer-types* 32) q)) + (#.encoded-type-unsigned-32 (values (svref *unsigned-integer-types* 32) q)) + (#.encoded-type-signed-8 (values (svref *signed-integer-types* 8) q)) + (#.encoded-type-unsigned-8 (values (svref *unsigned-integer-types* 8) q)) + (#.encoded-type-signed-16 (values (svref *signed-integer-types* 16) q)) + (#.encoded-type-unsigned-16 (values (svref *unsigned-integer-types* 16) q)) + (#.encoded-type-signed-n (values (let* ((bits (%get-unsigned-byte buf q))) + (if (<= bits 32) + (svref *signed-integer-types* bits) + (make-foreign-integer-type + :signed t + :bits bits))) + (1+ q))) + (#.encoded-type-unsigned-n (values (let* ((bits (%get-unsigned-byte buf q))) + (if (<= bits 32) + (svref *unsigned-integer-types* bits) + (make-foreign-integer-type + :signed nil + :bits bits))) + (1+ q))) + (#.encoded-type-single-float (values (parse-foreign-type :float) q)) + (#.encoded-type-double-float (values (parse-foreign-type :double) q)) + (#.encoded-type-pointer (multiple-value-bind (target qq) + (%decode-type buf q ftd suppress-typedef-expansion) + (values (make-foreign-pointer-type + :to target + :bits (getf (ftd-attributes ftd) + :bits-per-word) + ) + qq))) + (#.encoded-type-array + (multiple-value-bind (size qq) (%decode-uint buf q) + (multiple-value-bind (target qqq) (%decode-type buf qq ftd) + (let* ((type-alignment (foreign-type-alignment target)) + (type-bits (foreign-type-bits target))) + (values (make-foreign-array-type + :element-type target + :dimensions (list size) + :alignment type-alignment + :bits (if type-bits + (* (align-offset type-bits type-alignment) size))) + qqq))))) + (#.encoded-type-named-type-ref + (multiple-value-bind (name qq) (%decode-name buf q) + (values (if suppress-typedef-expansion + name + (%parse-foreign-type name)) + qq))) + (#.encoded-type-named-struct-ref + (multiple-value-bind (name qq) (%decode-name buf q) + (values (or (info-foreign-type-struct name) + (setf (info-foreign-type-struct name) + (make-foreign-record-type :kind :struct + :name name))) + qq))) + (#.encoded-type-named-union-ref + (multiple-value-bind (name qq) (%decode-name buf q) + (values (or (info-foreign-type-union name) + (setf (info-foreign-type-union name) + (make-foreign-record-type :kind :union + :name name))) + qq))) + (#.encoded-type-named-transparent-union-ref + (multiple-value-bind (name qq) (%decode-name buf q) + (let* ((already (info-foreign-type-union name))) + (when already + (setf (foreign-record-type-kind already) :transparent-union)) + (values (or already + (setf (info-foreign-type-union name) + (make-foreign-record-type :kind :transparent-union + :name name))) + qq)))) + ((#.encoded-type-anon-struct-ref + #.encoded-type-anon-union-ref + #.encoded-type-anon-transparent-union-ref) + (multiple-value-bind (tag qq) (%decode-name buf q t) + (values (load-record tag) qq)))))) + +(defun extract-db-type (datum ftd) + (let* ((data (pref datum :cdb-datum.data))) + (unless (%null-ptr-p data) + (prog1 + (%decode-type data 0 ftd) + (cdb-free data))))) + +(defun %load-foreign-type (cdb name ftd) + (when cdb + (with-cstrs ((string (string name))) + (rletZ ((contents :cdb-datum) + (key :cdb-datum)) + (setf (pref key :cdb-datum.size) (length (string name)) + (pref key :cdb-datum.data) string + (pref contents :cdb-datum.data) (%null-ptr) + (pref contents :cdb-datum.size) 0) + (cdb-get cdb key contents) + (let* ((type (extract-db-type contents ftd))) + (if type + (%def-foreign-type (escape-foreign-name name) type ftd))))))) + +(defun load-foreign-type (name &optional (ftd *target-ftd*)) + (let* ((name (unescape-foreign-name name))) + (do-interface-dirs (d ftd) + (let* ((type (%load-foreign-type (db-types d) name ftd))) + (when type (return type)))))) + +(defun %decode-field (buf p ftd) + (declare (type macptr buf) (fixnum p)) + (multiple-value-bind (name p) (%decode-name buf p) + (multiple-value-bind (type p) (%decode-type buf p ftd) + (multiple-value-bind (offset p) (%decode-uint buf p) + (multiple-value-bind (width p) (%decode-uint buf p) + (values (make-foreign-record-field :type type + :name name + :bits width + :offset offset) + p)))))) + +(defun %decode-field-list (buf p ftd) + (declare (type macptr buf) (fixnum p)) + (let* ((n nil) + (fields nil)) + (multiple-value-setq (n p) (%decode-uint buf p)) + (dotimes (i n (values (nreverse fields) p)) + (multiple-value-bind (field q) (%decode-field buf p ftd) + (push field fields) + (setq p q))))) + +(defun %determine-record-attributes (rtype parsed-fields &optional alt-align) + (let* ((total-bits 0) + (overall-alignment 1) + #+(and darwinppc-target ppc32-target) + (first-field-p t) + (kind (foreign-record-type-kind rtype))) + (dolist (field parsed-fields) + (let* ((field-type (foreign-record-field-type field)) + (bits (ensure-foreign-type-bits field-type)) + (natural-alignment (foreign-type-alignment field-type)) + (alignment (if alt-align + (min natural-alignment alt-align) + #+(and darwinppc-target ppc32-target) + (if first-field-p + (progn + (setq first-field-p nil) + natural-alignment) + (min 32 natural-alignment)) + #-(and darwinppc-target ppc32-target) + natural-alignment))) + (unless bits + (error "Unknown size: ~S" + (unparse-foreign-type field-type))) + (unless alignment + (error "Unknown alignment: ~S" + (unparse-foreign-type field-type))) + (setq overall-alignment (max overall-alignment (if (= alignment 1) 32 alignment))) + (ecase kind + (:struct (let* ((imported-offset (foreign-record-field-offset field)) + (offset (or imported-offset (align-offset total-bits alignment)))) + (unless imported-offset + (setf (foreign-record-field-offset field) offset)) + (setq total-bits (+ offset bits)))) + ((:union :transparent-union) (setq total-bits (max total-bits bits)))))) + (setf (foreign-record-type-fields rtype) parsed-fields + (foreign-record-type-alignment rtype) (or + alt-align + overall-alignment) + (foreign-record-type-bits rtype) (align-offset + total-bits + (or alt-align overall-alignment)) + (foreign-record-type-alt-align rtype) alt-align) + rtype)) + +(defun %decode-record-type (buf p ftd already) + (declare (type macptr buf) (fixnum p)) + (let* ((rbyte (%get-unsigned-byte buf p)) + (rcode (ldb encoded-type-type-byte rbyte)) + (ralign-in-bytes (ldb encoded-type-align-byte rbyte)) + (alt-align (unless (zerop ralign-in-bytes) + (the fixnum (ash ralign-in-bytes 3))))) + (declare (fixnum rbyte rcode ralign-in-bytes)) + (multiple-value-bind (name q) + (case rcode + ((#.encoded-type-anon-struct-ref + #.encoded-type-anon-union-ref + #.encoded-type-anon-transparent-union-ref) + (values nil (1+ p))) + (t + (%decode-name buf (1+ p)))) + (%determine-record-attributes + (or already + (if name + (if (eql rcode encoded-type-named-struct-ref) + (or (info-foreign-type-struct name) + (setf (info-foreign-type-struct name) + (make-foreign-record-type :kind :struct :name name))) + (or (info-foreign-type-union name) + (setf (info-foreign-type-union name) + (make-foreign-record-type :kind + (if (eql rcode encoded-type-named-union-ref) + :union + :transparent-union) + :name name)))) + (make-foreign-record-type + :kind (if (eql rcode encoded-type-anon-struct-ref) + :struct + (if (eql rcode encoded-type-anon-union-ref) + :union + :transparent-union)) + :name name))) + (%decode-field-list buf q ftd) + alt-align)))) + +(defun extract-db-record (datum ftd already) + (let* ((data (pref datum :cdb-datum.data))) + (unless (%null-ptr-p data) + (prog1 + (%decode-record-type data 0 ftd already) + (cdb-free data))))) + + +(defun %load-foreign-record (cdb name ftd already) + (when cdb + (with-cstrs ((string (string name))) + (rlet ((contents :cdb-datum) + (key :cdb-datum)) + (setf (pref key :cdb-datum.size) (length (string name)) + (pref key :cdb-datum.data) string + (pref contents :cdb-datum.data) (%null-ptr) + (pref contents :cdb-datum.size) 0) + (cdb-get cdb key contents) + (extract-db-record contents ftd already))))) + +(defun load-record (name &optional (ftd *target-ftd*)) + ;; Try to destructively modify any info we already have. Use the + ;; "escaped" name (keyword) for the lookup here. + (let* ((already (or (info-foreign-type-struct name ftd) + (info-foreign-type-union name ftd))) + (name (unescape-foreign-name name))) + (do-interface-dirs (d ftd) + (let* ((r (%load-foreign-record (db-records d) name ftd already))) + (when r (return r)))))) + + Index: /branches/new-random/lib/defstruct-lds.lisp =================================================================== --- /branches/new-random/lib/defstruct-lds.lisp (revision 13309) +++ /branches/new-random/lib/defstruct-lds.lisp (revision 13309) @@ -0,0 +1,406 @@ +;;;-*-Mode: LISP; Package: CCL -*- +;;; +;;; Copyright (C) 2009 Clozure Associates +;;; Copyright (C) 1994-2001 Digitool, Inc +;;; This file is part of Clozure CL. +;;; +;;; Clozure CL is licensed under the terms of the Lisp Lesser GNU Public +;;; License , known as the LLGPL and distributed with Clozure CL as the +;;; file "LICENSE". The LLGPL consists of a preamble and the LGPL, +;;; which is distributed with Clozure CL as the file "LGPL". Where these +;;; conflict, the preamble takes precedence. +;;; +;;; Clozure CL is referenced in the preamble as the "LIBRARY." +;;; +;;; The LLGPL is also available online at +;;; http://opensource.franz.com/preamble.html + +; defstruct-lds.lisp + +(in-package "CCL") + +(eval-when (eval compile) + (require 'defstruct-macros) +) + + + + +(defun uvector-subtype-p (thing subtype-number) + (= (the fixnum (typecode thing)) subtype-number)) + +(defun uvector (subtype &rest p) + (declare (dynamic-extent p)) + (let ((n (length p)) (uv)) + (setq uv (%alloc-misc n subtype)) + (dotimes (i (the fixnum n)) (declare (fixnum i)) (uvset uv i (pop p))) + uv)) + +;(defmacro test (&rest args) `(macroexpand-1 (defstruct ,@args))) + +;--> To do: compiler transform for copier, possibly constructor. +(defmacro defstruct (options &rest slots &environment env) + "DEFSTRUCT {Name | (Name Option*)} {Slot | (Slot [Default] {Key Value}*)} + Define the structure type Name. Instances are created by MAKE-, + which takes &KEY arguments allowing initial slot values to the specified. + A SETF'able function - is defined for each slot to read and + write slot values. -p is a type predicate. + + Popular DEFSTRUCT options (see manual for others): + + (:CONSTRUCTOR Name) + (:PREDICATE Name) + Specify the name for the constructor or predicate. + + (:CONSTRUCTOR Name Lambda-List) + Specify the name and arguments for a BOA constructor + (which is more efficient when keyword syntax isn't necessary.) + + (:INCLUDE Supertype Slot-Spec*) + Make this type a subtype of the structure type Supertype. The optional + Slot-Specs override inherited slot options. + + Slot options: + + :TYPE Type-Spec + Asserts that the value of this slot is always of the specified type. + + :READ-ONLY {T | NIL} + If true, no setter function is defined for this slot." + ;There's too much state to keep around here to break it up into little + ;functions, so what the hell, let's do it all inline... + (prog (struct-name type conc-name constructor copier predicate include + print-function print-object named initial-offset boa-constructors print-p + documentation (slot-list ()) (offset 0) superclasses sd + refnames) + ;Parse options + (if (atom options) + (setq struct-name options options ()) + (setq struct-name (pop options))) + (unless (symbolp struct-name) (signal-program-error $XNotSym struct-name)) + (let (name args constructor-p predicate-p) + (while options + (if (atom (car options)) + (setq name (%car options) args ()) + (setq name (%caar options) args (%cdar options))) + (case name + (:conc-name + (when conc-name (go dup-options)) + (when (cdr args) (go bad-options)) + (setq conc-name (or args (list nil)))) + (:constructor + (when (cddr args) (go bad-options)) + (cond ((cdr args) (push args boa-constructors)) + (t (when constructor (go dup-options)) + (unless (symbolp (%car args)) (go bad-options)) + (setq constructor-p t constructor args)))) + (:copier + (when copier (go dup-options)) + (when (or (cdr args) (not (symbolp (%car args)))) (go bad-options)) + (setq copier args)) + (:predicate + (when predicate (go dup-options)) + (when (or (cdr args) (not (symbolp (%car args)))) (go bad-options)) + (setq predicate-p t predicate args)) + (:include + (when include (go dup-options)) + (when (or (null args) (not (symbolp (car args)))) (go bad-options)) + (setq include args)) + ((:print-function :print-object) + (when print-function (go dup-options)) + (when (or (cdr args) + (not (or (symbolp (%car args)) + (and (consp (%car args)) (eq (%caar args) 'lambda))))) + (go bad-options)) + (setq print-p t + print-function (%car args) + print-object (eq name :print-object))) + (:type + (when type (go dup-options)) + (when (cdr args) (go bad-options)) + (unless (eq (setq type (%car args)) 'list) + (when (eq type 'vector) (setq type '(vector t))) + (when (or (atom type) (neq (%car type) 'vector) (cdr (%cdr type))) + (go bad-options)))) + (:named + (when args (go bad-options)) + (setq named t)) + (:initial-offset + (when initial-offset (go dup-options)) + (when (or (cdr args) (not (fixnump (%car args))) (%i< (%car args) 0)) + (go bad-options)) + (setq initial-offset (%car args))) + (t (go bad-options))) + (setq options (%cdr options))) + ;Options parsed! Do defaulting and some consistency checking. + (cond (type + (when (null (defstruct-reftype type)) ;e.g. (vector NIL) + (bad-named-arg :type type)) + (when print-p + (error "Cannot specify ~S with ~S" :print-function :type)) + (if (and named (consp type) (eq (car type) 'vector) + (cadr type) (not (subtypep 'symbol (cadr type)))) + (error "Cannot specify ~S with type: ~S" :named type)) + ) + ((built-in-type-p struct-name) + (error "Cannot redefine built-in type ~S" struct-name)) + (initial-offset + (error "Cannot use ~S without ~S" :initial-offset :type)) + (t (setq named t))) + (if (not named) + (when predicate-p + (unless (null (setq predicate (%car predicate))) + (error "Cannot specify :PREDICATE for an unnamed structure"))) + (setq predicate (if (null predicate) + (concat-pnames struct-name "-P") + (%car predicate)))) + (setq conc-name + (if (null conc-name) (%str-cat (symbol-name struct-name) "-") + (if (%car conc-name) (string (%car conc-name))))) + (unless (and boa-constructors (not constructor-p)) + (setq constructor + (if (null constructor) + (concat-pnames "MAKE-" struct-name) (%car constructor)))) + (setq copier + (if (null copier) (concat-pnames "COPY-" struct-name) (%car copier)))) + ;Process included slots + (when include + (let* ((included-name (%car include)) + (sub-sd (or (let* ((defenv (definition-environment env))) + (when defenv (%cdr (assq included-name (defenv.structures defenv))))) + (gethash included-name %defstructs%))) + (slots (%cdr include)) + name args ssd) + (unless sub-sd (error "No such structure: ~S" (cons :include include))) + (unless (eq (defstruct-reftype type) + (defstruct-reftype (sd-type sub-sd))) + (error "Incompatible structure type ~S for ~S" + (sd-type sub-sd) (cons :include include))) + (dolist (ssd (sd-slots sub-sd)) (push + (let* ((new-ssd (copy-ssd ssd))) + (ssd-set-inherited new-ssd) + new-ssd) + slot-list)) + (while slots + (if (atom (car slots)) + (setq name (%car slots) args ()) + (setq name (%caar slots) args (%cdar slots))) + (unless (symbolp name) (signal-program-error $XNotSym name)) + (unless (setq ssd (named-ssd name slot-list)) + (error "~S has no ~S slot, in ~S" + (sd-name sub-sd) name (cons :include include))) + (ssd-set-initform ssd (pop args)) + (while args + (when (atom (cdr args)) (signal-program-error "~S is not a proper list" (cdr args))) + (cond ((eq (%car args) :type) ) + ((eq (%car args) :read-only) + (when (and (not (%cadr args)) (ssd-r/o ssd)) + (signal-program-error "Slot ~S in ~S must be read-only" name (sd-name sub-sd))) + (when (%cadr args) (ssd-set-r/o ssd))) + (t (signal-program-error "~S must be (member :type :read-only)." (%car args)))) + (setq args (%cddr args))) + (setq slots (%cdr slots))) + (setq offset (sd-size sub-sd)) + (setq superclasses (sd-superclasses sub-sd)))) + (push struct-name superclasses) + ;Now add own slots + (setq offset (%i+ offset (or initial-offset 0))) + (when (and named (or type (not include))) + (push (make-ssd 0 (if type `',struct-name `',superclasses) offset t) slot-list) + (setq named offset offset (%i+ offset 1))) + (when (stringp (%car slots)) + (setq documentation (%car slots) slots (%cdr slots))) + (let (name args read-only initform slot-type) + (while slots + (if (atom (%car slots)) + (setq name (%car slots) args ()) + (setq name (%caar slots) args (%cdar slots))) + (unless (symbolp name) (go bad-slot)) + (setq read-only nil initform (pop args) slot-type t) + (while args + (when (atom (cdr args)) (go bad-slot)) + ;; To do: check for multiple/incompatible options. + (cond ((eq (%car args) :type) + (setq slot-type (%cadr args))) + ((eq (%car args) :read-only) + (setq read-only (%cadr args))) + (t (go bad-slot))) + (setq args (%cddr args))) + (specifier-type slot-type env) ;; Check for validity (signals program error) + (push (make-ssd name initform offset read-only slot-type) slot-list) + (setq slots (%cdr slots) offset (%i+ offset 1)))) + (setq slot-list (nreverse slot-list)) + (when (and (null type) include) + (ssd-set-initform (car slot-list) `',superclasses)) + (progn ;when conc-name + (dolist (slot slot-list) + (unless (fixnump (ssd-name slot)) + (push (if conc-name + (concat-pnames conc-name (ssd-name slot)) + (ssd-name slot)) + refnames))) + (setq refnames (nreverse refnames))) + (setq sd (vector type slot-list superclasses offset constructor () refnames)) + (return + `(progn + ,@(when (null (sd-type sd)) + `((when (memq ',struct-name *nx-known-declarations*) + (check-declaration-redefinition ',struct-name 'defstruct)))) + (remove-structure-defs ',struct-name) ; lose any previous defs + ,.(defstruct-slot-defs sd refnames env) + ,.(if constructor (list (defstruct-constructor sd constructor))) + ,.(defstruct-boa-constructors sd boa-constructors) + ,.(if copier (defstruct-copier sd copier env)) + ,.(if predicate (defstruct-predicate sd named predicate env)) + (eval-when (:compile-toplevel) + (define-compile-time-structure + ',sd + ',refnames + ,(if (and predicate (null (sd-type sd))) `',predicate) + ,env)) + (%defstruct-do-load-time + ',sd + ,(if (and predicate (null (sd-type sd))) `',predicate) + ,.(if documentation (list documentation))) + ,.(%defstruct-compile sd refnames env) + ;; Wait until slot accessors are defined, to avoid + ;; undefined function warnings in the print function/method. + (%defstruct-set-print-function + ',sd + ,(if print-function + (if (symbolp print-function) + `',print-function + `#',print-function) + (unless print-p (if include 0))) + ,print-object) + ',struct-name)) + + dup-options + (error "Duplicate ~S options not allowed" (%car options)) + bad-options + (signal-program-error "Bad defstruct option ~S." (%car options)) + bad-slot + (signal-program-error "Bad defstruct slot spec ~S." (%car slots)))) + +(defun concat-pnames (name1 name2) + (intern (%str-cat (string name1) (string name2)))) + +(defun wrap-with-type-check (value slot &aux (slot-type (ssd-type slot))) + (if (eq t slot-type) + value + `(require-type ,value ',slot-type))) + +(defun make-class-cells-list (class-names) + (if (and (consp class-names) + (eq (car class-names) 'quote) + (consp (cdr class-names)) + (null (cddr class-names)) + (listp (cadr class-names)) + (every #'symbolp (cadr class-names))) + `',(mapcar (lambda (name) (find-class-cell name t)) (cadr class-names)) + class-names)) + +(defun defstruct-constructor (sd constructor &aux (offset 0) + (args ()) + (values ()) + slot-offset + name) + (dolist (slot (sd-slots sd)) + (setq slot-offset (ssd-offset slot)) + #-bccl (when (%i< slot-offset offset) + (error "slots out of order! ~S" (sd-slots sd))) + (while (%i< offset slot-offset) + (push nil values) + (setq offset (%i+ offset 1))) + (if (fixnump (setq name (ssd-name slot))) + (if (eql 0 name) + (push (make-class-cells-list (ssd-initform slot)) values) + (push (wrap-with-type-check (ssd-initform slot) slot) values)) + (let* ((temp (make-symbol (symbol-name name)))) + (push (list (list (make-keyword name) temp) (ssd-initform slot)) args) + (push (wrap-with-type-check temp slot) values))) + (setq offset (%i+ offset 1))) + (setq values (nreverse values)) + `(defun ,constructor (&key ,@(nreverse args)) + ,(case (setq name (defstruct-reftype (sd-type sd))) + (#.$defstruct-nth `(list ,@values)) + (#.target::subtag-simple-vector `(vector ,@values)) + ((#.target::subtag-struct #.$defstruct-struct) + `(gvector :struct ,@values)) + (t `(uvector ,name ,@values))))) + +(defun defstruct-boa-constructors (sd boas &aux (list ())) + (dolist (boa boas list) + (push (defstruct-boa-constructor sd boa) list))) + +(defun defstruct-boa-constructor (sd boa &aux (args ()) + (used-slots ()) + (values ()) + (offset 0) + arg-kind slot slot-offset) + (unless (verify-lambda-list (cadr boa)) + (error "Invalid lambda-list in ~S ." (cons :constructor boa))) + (dolist (arg (cadr boa)) + (cond ((memq arg lambda-list-keywords) + (setq arg-kind arg)) + ((setq slot (named-ssd arg (sd-slots sd))) + (when (or (eq arg-kind '&optional) (eq arg-kind '&key) + ;; for &aux variables, init value is + ;; implementation-defined, however it's not + ;; supposed to signal a type error until slot is + ;; assigned, so might as well just use the + ;; initform. + (eq arg-kind '&aux)) + (setq arg (list arg (ssd-initform slot)))) + (push slot used-slots)) + ((and (consp arg) (setq slot (named-ssd (if (consp (%car arg)) (%cadar arg) (%car arg)) (sd-slots sd)))) + (push slot used-slots)) + (t nil)) + (push arg args)) + (dolist (slot (sd-slots sd)) + (setq slot-offset (ssd-offset slot)) + #-bccl (when (%i< slot-offset offset) (error "slots out of order! ~S" sd)) + (while (%i< offset slot-offset) + (push nil values) + (setq offset (%i+ offset 1))) + (push (if (memq slot used-slots) (ssd-name slot) + (if (eql 0 (ssd-name slot)) + (make-class-cells-list (ssd-initform slot)) + (if (constantp (ssd-initform slot)) (ssd-initform slot) + (progn + (unless (eq arg-kind '&aux) + (push (setq arg-kind '&aux) args)) + (push (list (ssd-name slot) (ssd-initform slot)) args) + (ssd-name slot))))) + values) + (setq offset (%i+ offset 1))) + (setq values (mapcar #'wrap-with-type-check (nreverse values) (sd-slots sd))) + `(defun ,(car boa) ,(nreverse args) + ,(case (setq slot (defstruct-reftype (sd-type sd))) + (#.$defstruct-nth `(list ,@values)) + (#.target::subtag-simple-vector `(vector ,@values)) + ((#.target::subtag-struct #.$defstruct-struct) + `(gvector :struct ,@values)) + (t `(uvector ,slot ,@values))))) + +(defun defstruct-copier (sd copier env) + `((eval-when (:compile-toplevel) + (record-function-info ',copier ',*one-arg-defun-def-info* ,env)) + (fset ',copier + ,(if (eq (sd-type sd) 'list) '#'copy-list '#'copy-uvector)) + (record-source-file ',copier 'function))) + +(defun defstruct-predicate (sd named predicate env) + (declare (ignore env)) + (let* ((arg (gensym)) + (sd-name (sd-name sd)) + (body + (case (sd-type sd) + ((nil) `(structure-typep ,arg ',(find-class-cell sd-name t))) + ((list) `(and (consp ,arg) (eq (nth ,named ,arg) ',sd-name))) + (t `(and (uvector-subtype-p ,arg ,(defstruct-reftype (sd-type sd))) + (< ,named (uvsize ,arg)) + (eq (uvref ,arg ,named) ',sd-name)))))) + `((defun ,predicate (,arg) ,body)))) + +; End of defstruct-lds.lisp Index: /branches/new-random/lib/defstruct-macros.lisp =================================================================== --- /branches/new-random/lib/defstruct-macros.lisp (revision 13309) +++ /branches/new-random/lib/defstruct-macros.lisp (revision 13309) @@ -0,0 +1,110 @@ +;;;-*-Mode: LISP; Package: CCL -*- +;;; +;;; Copyright (C) 2009 Clozure Associates +;;; Copyright (C) 1994-2001 Digitool, Inc +;;; This file is part of Clozure CL. +;;; +;;; Clozure CL is licensed under the terms of the Lisp Lesser GNU Public +;;; License , known as the LLGPL and distributed with Clozure CL as the +;;; file "LICENSE". The LLGPL consists of a preamble and the LGPL, +;;; which is distributed with Clozure CL as the file "LGPL". Where these +;;; conflict, the preamble takes precedence. +;;; +;;; Clozure CL is referenced in the preamble as the "LIBRARY." +;;; +;;; The LLGPL is also available online at +;;; http://opensource.franz.com/preamble.html + +; This file is needed to compile DEFSTRUCT and anything accessing defstruct +; data structures. + +(in-package "CCL") + +(eval-when (:execute :compile-toplevel) + (require "LISPEQU")) + +(defconstant $struct-r/o 24) ; Read-only bit in refinfo fixnum +(defconstant $struct-inherited 25) ; Struct slot is inherited. + + +(defconstant $defstruct-nth 0) ; Anything that won't conflict with array types... +(defconstant $defstruct-struct 8) +(defconstant $defstruct-simple-vector 16) + + +(defmacro ssd-name (ssd) `(car ,ssd)) +;(defmacro ssd-type (ssd) (declare (ignore ssd)) t) +(defmacro ssd-initform (ssd) `(cadr ,ssd)) +;(defmacro ssd-refinfo (ssd) `(cddr ,ssd)) + +(defmacro ssd-update-refinfo ((ssd refinfo-var) new-refinfo-form) + (check-type refinfo-var symbol) + (let ((refinfo-cons (gensym))) + `(let* ((,refinfo-cons (cdr ,ssd)) + (,refinfo-var (cdr ,refinfo-cons))) + (when (consp ,refinfo-var) + (setq ,refinfo-cons ,refinfo-var) + (setq ,refinfo-var (%cdr ,refinfo-cons))) + (%rplacd ,refinfo-cons ,new-refinfo-form)))) + +(defmacro refinfo-offset (refinfo) `(%ilogand2 #xFFFF ,refinfo)) +(defmacro refinfo-r/o (refinfo) `(%ilogbitp $struct-r/o ,refinfo)) +(defmacro refinfo-reftype (refinfo) `(%ilogand2 #xFF (%ilsr 16 ,refinfo))) + +(defmacro ssd-offset (ssd) `(refinfo-offset (ssd-refinfo ,ssd))) +(defmacro ssd-r/o (ssd) `(refinfo-r/o (ssd-refinfo ,ssd))) +(defmacro ssd-reftype (ssd) `(refinfo-reftype (ssd-refinfo ,ssd))) + +(defmacro ssd-set-initform (ssd value) `(rplaca (cdr ,ssd) ,value)) + +#| these are fns now +(defmacro ssd-set-reftype (ssd reftype) ;-> ssd multiply evaluated + `(rplacd (cdr ,ssd) (%ilogior2 (%ilogand2 #x100FFFF (cdr (%cdr ,ssd))) + (%ilsl 16 ,reftype)))) + +(defmacro ssd-set-r/o (ssd) ;-> ssd multiply evaluated + `(rplacd (cdr ,ssd) (%ilogior2 #x1000000 (cdr (%cdr ,ssd))))) + +(defmacro copy-ssd (ssd) ;-> ssd multiply evaluated + `(list* (car ,ssd) (car (%cdr ,ssd)) (%cddr ,ssd))) +|# + +(defmacro named-ssd (name slot-list) `(assq ,name ,slot-list)) + +(defmacro sd-name (sd) `(car (svref ,sd 2))) +(defmacro sd-type (sd) `(svref ,sd 0)) +(defmacro sd-slots (sd) `(svref ,sd 1)) +(defmacro sd-superclasses (sd) `(svref ,sd 2)) +(defmacro sd-size (sd) `(svref ,sd 3)) +(defmacro sd-constructor (sd) `(svref ,sd 4)) +(defmacro sd-print-function (sd) `(svref ,sd 5)) +(defmacro sd-set-print-function (sd value) `(svset ,sd 5 ,value)) +(defmacro sd-refnames (sd) `(svref ,sd 6)) + +(defmacro struct-name (struct) `(class-cell-name (car (uvref ,struct 0)))) +(defmacro struct-def (struct) `(gethash (struct-name ,struct) %defstructs%)) + +;Can use this to let the printer print with print-function, reader read with +;constructor and slot-names, inspector inspect with slot-names. +;Everything else you have to arrange yourself. +#+ignore +(defmacro pretend-i-am-a-structure (name constructor print-function &rest slot-names) + (let ((slots slot-names) (offset 1) (supers (list name))) + (while slots + (%rplaca slots (make-ssd (%car slots) () offset t)) + (ssd-set-reftype (%car slots) $v_struct) + (setq slots (%cdr slots) offset (1+ offset))) + (push (make-ssd 0 `',supers 0 t) slot-names) + (ssd-set-reftype (%car slot-names) $v_struct) + `(puthash ',name %defstructs% + '#(internal-structure ;Make structure-class-p false. + ,slot-names + ,supers + ,offset + ,constructor + ,print-function + nil)))) + +(provide 'defstruct-macros) + +; End of defstruct-macros.lisp Index: /branches/new-random/lib/defstruct.lisp =================================================================== --- /branches/new-random/lib/defstruct.lisp (revision 13309) +++ /branches/new-random/lib/defstruct.lisp (revision 13309) @@ -0,0 +1,305 @@ +;;;-*-Mode: LISP; Package: CCL -*- +;;; +;;; Copyright (C) 2009 Clozure Associates +;;; Copyright (C) 1994-2001 Digitool, Inc +;;; This file is part of Clozure CL. +;;; +;;; Clozure CL is licensed under the terms of the Lisp Lesser GNU Public +;;; License , known as the LLGPL and distributed with Clozure CL as the +;;; file "LICENSE". The LLGPL consists of a preamble and the LGPL, +;;; which is distributed with Clozure CL as the file "LGPL". Where these +;;; conflict, the preamble takes precedence. +;;; +;;; Clozure CL is referenced in the preamble as the "LIBRARY." +;;; +;;; The LLGPL is also available online at +;;; http://opensource.franz.com/preamble.html + +(in-package "CCL") + +;;; Defstruct.lisp + +(eval-when (eval compile) + (require 'defstruct-macros) + +) + +(defvar %structure-refs% (make-hash-table :test #'eq)) +(defvar %defstructs% (make-hash-table :test #'eq)) + +(defun make-ssd (name initform offset r/o &optional (type t)) + (let ((refinfo (%ilogior2 offset (if r/o #x1000000 0)))) + (list* name initform + (if (eq type 't) + refinfo + (cons type refinfo))))) + +(declaim (inline type-and-refinfo-p)) +(defun type-and-refinfo-p (object) + (or (fixnump object) (consp object))) + +(defun ssd-set-reftype (ssd reftype) + (ssd-update-refinfo (ssd refinfo) + (%ilogior2 (%ilogand2 #x300FFFF refinfo) + (%ilsl 16 reftype)))) + +(defun ssd-set-r/o (ssd) + (ssd-update-refinfo (ssd refinfo) + (%ilogior2 #x1000000 refinfo))) + +(defun ssd-set-inherited (ssd) + (ssd-update-refinfo (ssd refinfo) + (bitset $struct-inherited refinfo))) + +(defun copy-ssd (ssd) + (let* ((cdr (cdr ssd)) + (cddr (cdr cdr))) + (list* (%car ssd) (%car cdr) + (if (consp cddr) + (list* (%car cddr) (%cdr cddr)) + cddr)))) + +(declaim (inline ssd-type-and-refinfo)) +(defun ssd-type-and-refinfo (ssd) + (cddr ssd)) + +(defun ssd-type (ssd) + (let ((type-and-refinfo (ssd-type-and-refinfo ssd))) + (if (consp type-and-refinfo) + (%car type-and-refinfo) + 't))) + +(defun ssd-refinfo (ssd) + (let ((type-and-refinfo (ssd-type-and-refinfo ssd))) + (if (consp type-and-refinfo) (%cdr type-and-refinfo) type-and-refinfo))) + +(defun %structure-class-of (thing) + (let* ((cell (car (uvref thing 0)))) + (or (class-cell-class cell) + (setf (class-cell-class cell) + (find-class (class-cell-name cell)))))) + +;These might want to compiler-transform into non-typechecking versions... +(defun struct-ref (struct offset) + (if (structurep struct) (uvref struct offset) + (report-bad-arg struct 'structure-object))) + +(defun struct-set (struct offset value) + (if (structurep struct) (uvset struct offset value) + (report-bad-arg struct 'structure-object))) + +(defsetf struct-ref struct-set) + + +; things for defstruct to do - at load time +(defun %defstruct-do-load-time (sd predicate &optional doc &aux (name (sd-name sd))) + ;(declare (ignore refnames)) + (when (null (sd-type sd)) + (%define-structure-class sd)) + (when (and doc *save-doc-strings*) + (set-documentation name 'type doc)) + (puthash name %defstructs% sd) + (record-source-file name 'structure) + (when (and predicate (null (sd-type sd))) + (puthash predicate %structure-refs% name)) + (when *fasload-print* (format t "~&~S~%" name)) + name) + +(defun %defstruct-set-print-function (sd print-function print-object-p) + (sd-set-print-function sd (if print-object-p + (list print-function) + print-function))) + + +(defun sd-refname-pos-in-included-struct (sd name) + (dolist (included-type (cdr (sd-superclasses sd))) + (let ((sub-sd (gethash included-type %defstructs%))) + (when sub-sd + (let ((refnames (sd-refnames sub-sd))) + (if refnames + (let ((pos (position name refnames :test 'eq))) + (and pos (1+ pos))) + (dolist (slot (sd-slots sub-sd)) + (let ((ssd-name (ssd-name slot))) + (unless (fixnump ssd-name) + (when (eq name ssd-name) + (return-from sd-refname-pos-in-included-struct + (ssd-offset slot)))))))))))) + +;;; return stuff for defstruct to compile +(defun %defstruct-compile (sd refnames env) + (let ((stuff)) + (dolist (slot (sd-slots sd)) + (unless (fixnump (ssd-name slot)) + (let* ((accessor (if refnames (pop refnames) (ssd-name slot))) + (pos (sd-refname-pos-in-included-struct sd accessor))) + (if pos + (let ((offset (ssd-offset slot))) + (unless (eql pos offset) + ; This should be a style-warning + (warn "Accessor ~s at different position than in included structure" + accessor))) + (let ((fn (slot-accessor-fn slot accessor env))) + (push + `(progn + ,.fn + (puthash ',accessor %structure-refs% ',(ssd-type-and-refinfo slot)) + (record-source-file ',accessor 'structure-accessor)) + stuff)))))) + (nreverse stuff))) + + +; no #. for cross compile +(defvar *struct-ref-vector* + (vector #'(lambda (x) (struct-ref x 0)) + #'(lambda (x) (struct-ref x 1)) + #'(lambda (x) (struct-ref x 2)) + #'(lambda (x) (struct-ref x 3)) + #'(lambda (x) (struct-ref x 4)) + #'(lambda (x) (struct-ref x 5)) + #'(lambda (x) (struct-ref x 6)) + #'(lambda (x) (struct-ref x 7)) + #'(lambda (x) (struct-ref x 8)) + #'(lambda (x) (struct-ref x 9)))) + +(defvar *svref-vector* + (vector #'(lambda (x) (svref x 0)) + #'(lambda (x) (svref x 1)) + #'(lambda (x) (svref x 2)) + #'(lambda (x) (svref x 3)) + #'(lambda (x) (svref x 4)) + #'(lambda (x) (svref x 5)) + #'(lambda (x) (svref x 6)) + #'(lambda (x) (svref x 7)) + #'(lambda (x) (svref x 8)) + #'(lambda (x) (svref x 9)))) + + +;;; too bad there isnt a way to suppress generating these darn +;;; functions when you dont want them. Makes no sense to fetch +;;; functions from a vector of 68K functions and send them over to +;;; PPC. So can use that space optimization iff host and target are +;;; the same. + + +(defparameter *defstruct-share-accessor-functions* t) ;; TODO: isn't it time to get rid of this? + +(defun slot-accessor-fn (slot name env &aux (ref (ssd-reftype slot)) (offset (ssd-offset slot))) + (cond ((eq ref $defstruct-nth) + (if (and (%i< offset 10) *defstruct-share-accessor-functions*) + `((eval-when (:compile-toplevel) + (record-function-info ',name ',*one-arg-defun-def-info* ,env)) + (fset ',name + ,(symbol-function + (%svref '#(first second third fourth fifth + sixth seventh eighth ninth tenth) offset)))) + `((defun ,name (x) (nth ,offset x))))) + ((eq ref $defstruct-struct) + (if (and (%i< offset 10) *defstruct-share-accessor-functions*) + `((eval-when (:compile-toplevel) + (record-function-info ',name ',*one-arg-defun-def-info* ,env)) + (fset ',name , (%svref *struct-ref-vector* offset))) + `((defun ,name (x) (struct-ref x ,offset))))) + ((or (eq ref target::subtag-simple-vector) + (eq ref $defstruct-simple-vector)) + (if (and (%i< offset 10) *defstruct-share-accessor-functions*) + `((eval-when (:compile-toplevel) + (record-function-info ',name ',*one-arg-defun-def-info* ,env)) + (fset ',name ,(%svref *svref-vector* offset))) + `((defun ,name (x) (svref x ,offset))))) + (t `((defun ,name (x) (uvref x ,offset)))))) + +(defun defstruct-reftype (type) + (cond ((null type) $defstruct-struct) + ((eq type 'list) $defstruct-nth) + (t (element-type-subtype (cadr type))))) + +(defun defstruct-slot-defs (sd refnames env) + (declare (ignore env)) + (let ((ref (defstruct-reftype (sd-type sd))) name defs) + (dolist (slot (sd-slots sd)) + (ssd-set-reftype slot ref) + (unless (fixnump (setq name (ssd-name slot))) ;Ignore fake 'name' slots + (when refnames (setq name (pop refnames))) + (unless (sd-refname-pos-in-included-struct sd name) + (push name defs)))) + (setq defs (nreverse defs)) + `((declaim (inline ,@defs))))) + +;;;Used by nx-transform, setf, and whatever... +(defun defstruct-ref-transform (predicate-or-type-and-refinfo args &optional env) + (if (type-and-refinfo-p predicate-or-type-and-refinfo) + (multiple-value-bind (type refinfo) + (if (consp predicate-or-type-and-refinfo) + (values (%car predicate-or-type-and-refinfo) + (%cdr predicate-or-type-and-refinfo)) + (values 't predicate-or-type-and-refinfo)) + (let* ((offset (refinfo-offset refinfo)) + (ref (refinfo-reftype refinfo)) + (accessor + (cond ((eq ref $defstruct-nth) + `(nth ,offset ,@args)) + ((eq ref $defstruct-struct) + `(struct-ref ,@args ,offset)) + ((eq ref target::subtag-simple-vector) + `(svref ,@args ,offset)) + (ref + `(aref (the (simple-array ,(element-subtype-type ref) (*)) + ,@args) ,offset)) + (t `(uvref ,@args ,offset))))) + (if (eq type 't) + accessor + (if (specifier-type-if-known type env) + `(the ,type ,accessor) + (if (nx-declarations-typecheck env) + `(require-type ,accessor ',type) + ;; Otherwise just ignore the type, it's most likely a forward reference, + ;; and while it means we might be missing out on a possible optimization, + ;; most of the time it's not worth warning about. + accessor))))) + `(structure-typep ,@args ',predicate-or-type-and-refinfo))) + +;;; Should probably remove the constructor, copier, and predicate as +;;; well. Can't remove the inline proclamations for the refnames, +;;; as the user may have explicitly said this. Questionable - but surely +;;; must delete the inline definitions. +;;; Doesn't remove the copier because we don't know for sure what it's name is +(defmethod change-class ((from structure-class) + (to class) + &rest initargs &key &allow-other-keys) + (declare (dynamic-extent initargs)) + (let ((class-name (class-name from))) + (unless (eq from to) ; shouldn't be + (remove-structure-defs class-name) + (remhash class-name %defstructs%))) + (%change-class from to initargs)) + +;;; if redefining a structure as another structure or redefining a +;;; structure as a class +(defun remove-structure-defs (class-name) + (let ((sd (gethash class-name %defstructs%))) + (when sd + (dolist (refname (sd-refnames sd)) + (remhash refname %structure-refs%) + (let ((def (assq refname *nx-globally-inline*))) + (when def (set-function-info refname nil))) + (when (symbolp refname)(fmakunbound refname))) + (let ((print-fn (sd-print-function sd))) + (when (symbolp print-fn) (fmakunbound print-fn))) + (let ((constructor (sd-constructor sd))) + (when (symbolp constructor) (fmakunbound constructor))) + (let ((delete-match #'(lambda (pred struct-name) + (when (eq struct-name class-name) + (remhash pred %structure-refs%) + (fmakunbound pred))))) + (declare (dynamic-extent delete-match)) + ; get rid of the predicate + (maphash delete-match %structure-refs%))))) + +(defun copy-structure (source) + "Return a copy of STRUCTURE with the same (EQL) slot values." + (copy-uvector (require-type source 'structure-object))) + +(provide 'defstruct) + +; End of defstruct.lisp Index: /branches/new-random/lib/describe.lisp =================================================================== --- /branches/new-random/lib/describe.lisp (revision 13309) +++ /branches/new-random/lib/describe.lisp (revision 13309) @@ -0,0 +1,1955 @@ +;;; -*- Mode:Lisp; Package:INSPECTOR -*- +;;; +;;; Copyright (C) 2009 Clozure Associates +;;; Copyright (C) 1994-2001 Digitool, Inc +;;; This file is part of Clozure CL. +;;; +;;; Clozure CL is licensed under the terms of the Lisp Lesser GNU Public +;;; License , known as the LLGPL and distributed with Clozure CL as the +;;; file "LICENSE". The LLGPL consists of a preamble and the LGPL, +;;; which is distributed with Clozure CL as the file "LGPL". Where these +;;; conflict, the preamble takes precedence. +;;; +;;; Clozure CL is referenced in the preamble as the "LIBRARY." +;;; +;;; The LLGPL is also available online at +;;; http://opensource.franz.com/preamble.html + +(defpackage "INSPECTOR" + (:use "CL" "CCL") + (:export "MAKE-INSPECTOR" + "COMPUTE-LINE-COUNT" + "LINE-N" + "INSPECTOR-OBJECT" + "INSPECTOR-LINE-COUNT" + + "*INSPECTOR-DISASSEMBLY*")) + + + +(in-package "INSPECTOR") + +(defvar ccl::@) + +;;; The basic inspector object. +;;; Note that this knows nothing about windows. +;;; It merely knows how to number the constituent parts of an object, +;;; How to access a constituent, and how to print a constituent to a stream. +(defclass inspector () + ((object :accessor inspector-object :initarg :object) + (line-count :accessor inspector-line-count :initarg :line-count :initform nil) + ;; so can refresh. + (initargs :reader inspector-initargs :initform nil))) + +(defmethod initialize-instance :before ((i inspector) &rest initargs) + (setf (slot-value i 'initargs) initargs)) + +;;; The usual way to cons up an inspector +(defmethod make-inspector (object) + (multiple-value-bind (class alias) (inspector-class object) + (make-instance class :object (or alias object)))) + +(defmethod initialize-instance :after ((i inspector) &key update-line-count) + (when update-line-count + (update-line-count i))) + +(defmethod refresh-inspector ((i inspector)) + (apply #'make-instance (class-of i) (slot-value i 'initargs))) + +;; New protocol, used by gui inspector instead of the line-n protocol, which isn't quite right. +;; Perhaps tty inspector should use it as well. Returns the line inspector rather than object, +;; and returns the value string rather than having the caller print it. +(defmethod inspector-line ((i inspector) index) + (let ((line-i (multiple-value-bind (value label type) (inspector::line-n i index) + (and (not (eq (parse-type i type) :comment)) + (line-n-inspector i index value label type))))) + (multiple-value-bind (label-string value-string) (line-n-strings i index) + (values line-i label-string value-string)))) + +;; for a comment value = nil, label = "the comment" type = :comment +;;; => line-i = nil + +;;;;;;; +;;; +;;; The protocol for an inspector. +;;; Change these to defgeneric's when it exists. +;;; +;;; Usually, you need to define methods only for +;;; inspector-class, compute-line-count, line-n, and (setf line-n) + +;;; Return the type of inspector for an object +(defmethod inspector-class (object) + (cond ((method-exists-p #'line-n object 0) 'usual-inspector) + ((and (uvectorp object) + (find-class 'uvector-inspector nil)) + 'uvector-inspector) + (t 'basic-inspector))) + +;;; Return three values: the value, label, and type of the nth line of the object +;;; Valid types are: +;;; :NORMAL or NIL - a normal constituent line: changeable +;;; :COLON - a normal line with ": " between the label and the value +;;; :COMMENT - a commentary line - Print only the label +;;; :STATIC - a commentary line with an inspectable value: not changeable +(defmethod line-n ((i inspector) n) + (declare (ignore n))) + +; set the value of line n of the object (the label is fixed) +(defmethod (setf line-n) (value (i inspector) n) + (declare (ignore value n))) + +; Compute the number of lines in the object +(defmethod compute-line-count ((i inspector)) + 0 + ) + +; Compute the number of lines in the object and set the line-count slot +; If the length is greater than the limit, return (list limit) +(defun update-line-count (inspector) + (setf (inspector-line-count inspector) (compute-line-count inspector))) + +; Print the nth line to a stream +(defmethod prin1-line-n ((i inspector) stream n) + (multiple-value-call #'prin1-line i stream (line-n i n))) + +(defmethod prin1-line ((i inspector) stream value &optional label type function) + (unless function + (setq function (inspector-print-function i type))) + (funcall function i stream value label type)) + +(defvar *collect-labels-if-list* t) + +(defmethod end-of-label ((stream string-output-stream)) + (when (listp *collect-labels-if-list*) + (push (get-output-stream-string stream) *collect-labels-if-list*))) + +(defmethod line-n-strings ((i inspector) n) + (let* ((*collect-labels-if-list* ()) + (value-string (with-output-to-string (stream) + (prin1-line-n i stream n))) + (label-string (pop *collect-labels-if-list*)) + (end (or (position-if-not #'whitespacep label-string :from-end t) -1))) + (assert (null *collect-labels-if-list*)) + (unless (and (>= end 0) (eql (char label-string end) #\:)) (incf end)) + (setq label-string (subseq label-string 0 end)) + (values label-string value-string))) + +(defmethod inspector-print-function ((i inspector) type) + (declare (ignore type)) + 'prin1-normal-line) + +; Print a value to a stream. +(defmethod prin1-normal-line ((i inspector) stream value &optional label type + colon-p) + (let* ((type-sym (parse-type i type))) + (if (eq type-sym :colon) (setq colon-p t)) + (when label + (prin1-label i stream value label type) + (if colon-p (princ ": " stream))) + (end-of-label stream) ; used by cacheing code + (unless (eq type-sym :comment) + (prin1-value i stream value label type)))) + +(defun prin1-colon-line (i stream value &optional label type) + (prin1-normal-line i stream value label type t)) + +(defmethod prin1-label ((i inspector) stream value &optional label type) + (declare (ignore value type)) + (if (stringp label) + (write-string label stream) + (princ label stream))) + +(defmethod prin1-value ((i inspector) stream value &optional label type) + (declare (ignore label type)) + (prin1 value stream)) + +;;; Call function on the inspector object and its value, label, & type, for +;;; each line in the selected range (default to the whole thing). +;;; This can avoid (e.g.) doing NTH for each element of a list. +;;; This is the generic-function which the inspector-window uses to +;;; display a screenful. +(defmethod map-lines ((i inspector) function &optional + (start 0) + end) + (when (null (inspector-line-count i)) + (update-line-count i)) + (unless end + (setq end (inspector-line-count i))) + (when (and start end) + (let ((index start)) + (dotimes (c (- end start)) + (multiple-value-call function i index (inspector-line i index)) + (incf index))))) + +;;;;;;; +;;; +;;; Dealing with unbound slots and bogus objects +;;; +(defclass unbound-marker () ()) + +(defvar *unbound-marker* (make-instance 'unbound-marker)) +(defvar *slot-unbound-marker* (make-instance 'unbound-marker)) + +(defmethod print-object ((x unbound-marker) stream) + (print-object (ccl::%unbound-marker) stream)) + +(defclass bogus-object-wrapper () + ((address :initarg :address))) + +(defmethod print-object ((x bogus-object-wrapper) stream) + (print-unreadable-object (x stream) + (format stream "BOGUS object @ #x~x" (slot-value x 'address)))) + +(defvar *bogus-object-hash* + (make-hash-table :test 'eql :weak :value :size 0)) + +(defun bogus-object-wrapper (x) + (let ((address (%address-of x))) + (or (gethash address *bogus-object-hash*) + (setf (gethash address *bogus-object-hash*) + (make-instance 'bogus-object-wrapper :address address))))) + +(defun eliminate-unbound (x) + (cond ((eq x (ccl::%unbound-marker)) + *unbound-marker*) + ((eq x (ccl::%slot-unbound-marker)) + *slot-unbound-marker*) + ((ccl::bogus-thing-p x) + (bogus-object-wrapper x)) + (t x))) + +(defun restore-unbound (x) + (if (eq x *unbound-marker*) + (ccl::%unbound-marker) + (if (eq x *slot-unbound-marker*) + (ccl::%slot-unbound-marker) + x))) + +(defmethod line-n :around ((i inspector) n) + (declare (ignore n)) + (let ((res (multiple-value-list (call-next-method)))) + (declare (dynamic-extent res)) + (apply #'values (eliminate-unbound (car res)) (cdr res)))) + +(defmethod (setf line-n) :around (new-value (i inspector) n) + (call-next-method (restore-unbound new-value) i n)) + + +;;;;;;; +;;; +;;; describe-object +;;; Eventually, this wants to reuse a global inspector rather than +;;; consing one. +(defparameter *describe-pretty* t) + +(defmacro with-errorfree-printing (&body body) + `(let ((*print-readably* nil) + (*signal-printing-errors* nil)) + ,@body)) + +(defun format-line-for-tty (stream label-string value-string) + (when (equal label-string "") (setq label-string nil)) + (when (equal value-string "") (setq value-string nil)) + (format stream "~@[~a~]~@[~a~]~@[~a~]" + label-string + (and label-string + value-string + (not (eql #\space (char label-string (1- (length label-string))))) + ": ") + value-string)) + +(defun describe (object &optional stream) + "Print a description of the object X." + (cond ((null stream) (setq stream *standard-output*)) + ((eq stream t) (setq stream *terminal-io*))) + (setq stream (require-type stream 'stream)) + (let* ((*print-circle* t) + (*print-length* 20)) + (describe-object object stream) + (values))) + +(defmethod describe-object (object stream) + (let ((inspector (make-inspector object))) + (with-errorfree-printing + (let* ((*print-pretty* (or *print-pretty* *describe-pretty*)) + (temp #'(lambda (i index child &optional label-string value-string) + (declare (ignore i index child)) + (format-line-for-tty stream label-string value-string) + (terpri stream)))) + (declare (dynamic-extent temp)) + (map-lines inspector temp)))) + (values)) + +;;; usual-inspector +;;; Objects that know how to inspect themselves but don't need any +;;; special info other than the object can be a usual-inspector. +;;; This class exists mostly to save consing a class for every type +;;; of object in the world. +(defclass usual-inspector (inspector) + ()) + +;;;;;;; +;; +;; formatting-inspector +;; This one prints using a format string. +;; Expects line-n to return (values value label type format-string) + +(defclass formatting-inspector (inspector) ()) +(defclass usual-formatting-inspector (usual-inspector formatting-inspector) ()) + +(defmethod prin1-line ((i formatting-inspector) stream value + &optional label type (format-string "~s")) + (funcall (if (listp format-string) #'apply #'funcall) + #'format-normal-line i stream value label type format-string)) + +(defmethod format-normal-line ((i inspector) stream value &optional + label type (format-string "~s") colon-p) + (let* ((type-sym (parse-type i type))) + (if (eq type-sym :colon) (setq colon-p t)) + (when label + (prin1-label i stream value label type) + (if colon-p (princ ": " stream))) + (end-of-label stream) ; used by cacheing code + (unless (eq type-sym :comment) + (format stream format-string value)))) + +;;;;;;; +;; +;; inspectors for CCL objects +;; + + +(defmethod parse-type ((i inspector) type &optional default1 default2) + (declare (ignore default1 default2)) + (values (if (consp type) (car type) type))) + +;;; Used by the cache-entry-stream class to save the column where the label ends. +(defmethod end-of-label (stream) + (declare (ignore stream))) + + + +;;;;; +;; +;; The default inspector class +;; Used when we don't know what else to do +;; + +(defclass basic-inspector (inspector) ()) + +(defmethod compute-line-count ((i basic-inspector)) + 3) ; type, class, value + +(defun line-n-out-of-range (i n) + (error "~s is not a valid index for line-n of ~s" n i)) + +(defun setf-line-n-out-of-range (i n) + (error "~s is not a valid index for setf-line-n of ~s" n i)) + +(defmethod line-n ((i basic-inspector) n) + (let ((object (inspector-object i))) + (case n + (0 (values object nil :static)) + (1 (values (type-of object) "Type: " :static)) + (2 (values (class-of object) "Class: " :static)) + (t (line-n-out-of-range i n))))) + +;;;;;;; +;; +;; Automate the object being the first line +;; +(defclass object-first-mixin () ()) +(defclass object-first-inspector (object-first-mixin inspector) ()) + +(defmethod compute-line-count :around ((i object-first-mixin)) + (1+ (call-next-method))) + +(defmethod line-n :around ((i object-first-mixin) n) + (if (eql 0 n) + (values (inspector-object i) nil) + (call-next-method i (1- n)))) + +(defmethod (setf line-n) :around (value (i object-first-mixin) n) + (if (eql n 0) + (replace-object i value) + (call-next-method value i (1- n)))) + +(defun replace-object (inspector new-object) + (declare (ignore inspector)) + (make-inspector new-object)) + + +; A mixin that displays the object, its type, and its class as the first three lines. +(defclass basics-first-mixin () ()) + +(defmethod compute-line-count :around ((i basics-first-mixin)) + (+ 3 (call-next-method))) + +(defmethod line-n :around ((i basics-first-mixin) n) + (let ((object (inspector-object i))) + (case n + (0 (values object nil)) + (1 (values (type-of object) "Type: " :static)) + (2 (values (class-of object) "Class: " :static)) + (t (call-next-method i (- n 3)))))) + +(defmethod line-n-inspector :around ((i basics-first-mixin) n value label type) + (if (< n 3) + (make-inspector value) + (call-next-method i (- n 3) value label type))) + +(defmethod (setf line-n) :around (new-value (i basics-first-mixin) n) + (case n + (0 (replace-object i new-value)) + ((1 2) (setf-line-n-out-of-range i n)) + (t (call-next-method new-value i (- n 3))))) + +;;;;;;; +;; +(defclass usual-object-first-inspector (object-first-mixin usual-inspector) + ()) +(defclass usual-basics-first-inspector (basics-first-mixin usual-inspector) + ()) + +(defvar *inspector*) + +(defmethod compute-line-count ((i usual-inspector)) + (let ((*inspector* i)) + (compute-line-count (inspector-object i)))) + +(defmethod line-n ((i usual-inspector) n) + (let ((*inspector* i)) + (line-n (inspector-object i) n))) + +(defmethod (setf line-n) (value (i usual-inspector) n) + (let ((*inspector* i)) + (setf (line-n (inspector-object i) n) value))) + +(defmethod inspector-commands ((i usual-inspector)) + (let ((*inspector* i)) + (inspector-commands (inspector-object i)))) + +(defmethod inspector-commands (random) + (declare (ignore random)) + nil) + +;;;;;;; +;; +;; Bogus objects +;; + +(defclass bogus-object-inspector (object-first-inspector) + ()) + +(defmethod compute-line-count ((i bogus-object-inspector)) + 3) + +(defmethod line-n ((i bogus-object-inspector) n) + (values + nil + (case n + (0 "One cause of a bogus object is when a stack consed object is stored") + (1 "in a register and then control exits the dynamic-extent of the object.") + (2 "The compiler doesn't bother to clear the register since it won't be used again.")) + '(:comment :plain :plain))) + +(defmethod inspector-class :around (object) + (if (ccl::bogus-thing-p object) + 'bogus-object-inspector + (call-next-method))) + +;;;;;;; +;; +;; A general sequence inspector +;; +(defclass sequence-inspector (inspector) + ((print-function :initarg :print-function :initform #'prin1 :reader print-function) + (commands :initarg :commands :initform nil :accessor inspector-commands) + (line-n-inspector :initform nil :initarg :line-n-inspector + :accessor line-n-inspector-function) + (replace-object-p :initform nil :initarg :replace-object-p + :reader replace-object-p) + (resample-function :initform nil :initarg :resample-function + :reader resample-function) + (line-n-function :initform nil :initarg :line-n-function + :reader line-n-function) + (setf-line-n-p :initform t :initarg :setf-line-n-p + :reader setf-line-n-p)) + (:default-initargs :update-line-count t)) + + + +(defmethod compute-line-count ((i sequence-inspector)) + (let ((resample-function (resample-function i))) + (when resample-function + (setf (inspector-object i) (funcall resample-function i)))) + (length (inspector-object i))) + +(defmethod line-n ((i sequence-inspector) n) + (let ((f (line-n-function i))) + (if f + (funcall f i n) + (values (elt (inspector-object i) n) nil (unless (setf-line-n-p i) :static))))) + +(defmethod (setf line-n) (new-value (i sequence-inspector) n) + (if (setf-line-n-p i) + (setf (elt (inspector-object i) n) new-value) + (setf-line-n-out-of-range i n))) + +(defmethod prin1-value ((inspector sequence-inspector) stream value + &optional label type) + (declare (ignore label type)) + (funcall (print-function inspector) value stream)) + +(defmethod line-n-inspector ((i sequence-inspector) n value label type) + (let ((f (line-n-inspector-function i))) + (or (and f (funcall f i n value label type)) (call-next-method)))) + +;;;;;;; +;; +;; standard-object +;; This should be redone to use the exported class query functions +;; (as soon as they exist) +;; +(defclass standard-object-inspector (object-first-inspector) + ()) + +(defmethod inspector-class ((o standard-object)) + 'standard-object-inspector) + +(defmethod compute-line-count ((i standard-object-inspector)) + (standard-object-compute-line-count i)) + +(defun standard-object-compute-line-count (i) + (let* ((object (ccl::maybe-update-obsolete-instance (inspector-object i))) + (class (class-of object)) + (all-slots (ccl::class-slots class))) + (multiple-value-bind (instance-slots class-slots other-slots) (ccl::extract-instance-class-and-other-slotds all-slots) + (let* ((ninstance-slots (length instance-slots)) + (nclass-slots (length class-slots)) + (nother-slots (length other-slots))) + (+ 2 ; class, wrapper + (if (eql 0 ninstance-slots) + 0 + (1+ ninstance-slots)) + (if (eql 0 nclass-slots) + 0 + (1+ nclass-slots)) + (if (eql 0 nother-slots) + 0 + (1+ nother-slots)) + (if (eql 0 (+ nclass-slots ninstance-slots nother-slots)) + 1 + 0)))))) + +(defun slot-value-or-unbound (instance slot-name) + (eliminate-unbound (ccl::slot-value-if-bound instance slot-name + (ccl::%slot-unbound-marker)))) + +(defparameter *standard-object-type* (list nil)) +(defparameter *standard-object-static-type* + (cons :static (cdr *standard-object-type*))) +(defparameter *standard-object-comment-type* + (list :comment)) + +(defmethod line-n ((i standard-object-inspector) n) + (standard-object-line-n i n)) + +(defmethod prin1-label ((i standard-object-inspector) stream value &optional label type) + (declare (ignore value type)) + (if (symbolp label) + (prin1 label stream) + (call-next-method))) + +; Looks like +; Class: +; Wrapper: +; [Instance slots: +; slots...] +; [Class slots: +; slots...] +; [Other slots: +; slots...] + +(defun standard-object-line-n (i n) + (let* ((instance (inspector-object i)) + (class (class-of instance)) + (all-slots (class-slots class)) + (wrapper (or (ccl::standard-object-p instance) + (if (typep instance 'ccl::funcallable-standard-object) + (ccl::gf.instance.class-wrapper instance)))) + (instance-start 2)) + (if (< n instance-start) + (if (eql n 0) + (values class "Class: " :normal) + (values wrapper "Wrapper: " :static)) + (multiple-value-bind (instance-slotds class-slotds other-slotds) + (ccl::extract-instance-class-and-other-slotds all-slots) + (let* ((instance-count (length instance-slotds)) + (shared-start (+ instance-start instance-count + (if (eql 0 instance-count) 0 1)))) + (if (< n shared-start) + (if (eql n instance-start) + (values nil "Instance slots" :comment) + (let ((slot-name (slot-definition-name + (elt instance-slotds (- n instance-start 1))))) + (values (slot-value-or-unbound instance slot-name) + slot-name + :colon))) + (let* ((shared-count (length class-slotds)) + (shared-end (+ shared-start shared-count + (if (eql shared-count 0) 0 1)))) + (if (< n shared-end) + (if (eql n shared-start) + (values nil "Class slots" :comment) + (let ((slot-name (slot-definition-name + (elt class-slotds (- n shared-start 1))))) + (values (slot-value-or-unbound instance slot-name) + slot-name + :colon))) + (let* ((other-start shared-end) + (other-end (+ other-start (if other-slotds (1+ (length other-slotds)) 0)))) + (if (< n other-end) + (if (eql n other-start) + (values nil "Other slots" :comment) + (let ((slot-name (slot-definition-name + (elt other-slotds (- n other-start 1))))) + (values (slot-value-or-unbound instance slot-name) + slot-name + :colon))) + (if (and (eql 0 instance-count) (eql 0 shared-count) (null other-slotds) (eql n other-end)) + (values nil "No Slots" :comment) + (line-n-out-of-range i n)))))))))))) + +(defmethod (setf line-n) (value (i standard-object-inspector) n) + (standard-object-setf-line-n value i n)) + +(defun standard-object-setf-line-n (value i n) + (let* ((instance (inspector-object i)) + (class (class-of instance)) + (instance-start 2)) + (if (< n instance-start) + (cond + ((eql n 0) (change-class instance value) + (update-line-count i)) + (t (setf-line-n-out-of-range i n))) + (let* ((slotds (ccl::extract-instance-effective-slotds class)) + (instance-count (length slotds)) + (shared-start (+ instance-start instance-count + (if (eql 0 instance-count) 0 1)))) + (if (< n shared-start) + (if (eql n instance-start) + (setf-line-n-out-of-range i n) + (let ((slot-name (slot-definition-name + (elt slotds (- n instance-start 1))))) + (setf (slot-value instance slot-name) (restore-unbound value)))) + (let* ((slotds (ccl::extract-class-effective-slotds class)) + (shared-count (length slotds)) + (shared-end (+ shared-start shared-count + (if (eql shared-count 0) 0 1)))) + (if (< n shared-end) + (if (eql n shared-start) + (setf-line-n-out-of-range i n) + (let ((slot-name (slot-definition-name + (elt slotds (- n shared-start 1))))) + (setf (slot-value instance slot-name) + (restore-unbound value)))) + (setf-line-n-out-of-range i n)))))))) + + + +;;;;;;;;;;; Inspector objects for common classes. + +(defparameter *plain-comment-type* '(:comment (:plain))) +(defparameter *bold-comment-type* '(:comment (:bold))) + +(defun resample-it () + ) + +;;;;;;; +;; +;; Lists +;; +(defclass cons-inspector (basics-first-mixin inspector) ()) + +(defclass list-inspector (basics-first-mixin inspector) + ((length :accessor list-inspector-length) + (dotted-p :accessor list-inspector-dotted-p) + (nthcdr :accessor list-inspector-nthcdr) + (n :accessor list-inspector-n))) + +(defmethod inspector-class ((o list)) + (if (listp (cdr o)) + 'list-inspector + 'cons-inspector)) + +; Same as list-length-and-final-cdr, but computes the real length of the list +(defun real-list-length (list) + (multiple-value-bind (len final-cdr max-circ-len) + (ccl::list-length-and-final-cdr list) + (if (null max-circ-len) + (values len final-cdr nil) + (let ((middle (nthcdr max-circ-len list)) + (n 1)) + (loop (when (eq list middle) (return)) + (pop list) + (incf n)) + (pop list) + (loop (when (eq list middle) (return)) + (pop list) + (incf n)) + (values nil nil n))))) + +(defmethod compute-line-count ((i list-inspector)) + (multiple-value-bind (len final-cdr circ-len) (real-list-length (inspector-object i)) + (setf (list-inspector-dotted-p i) final-cdr) + (setf (list-inspector-nthcdr i) (inspector-object i)) + (setf (list-inspector-n i) 0) + (+ 1 ; regular, dotted, or circular + 1 ; length + (abs (setf (list-inspector-length i) + (or len (- circ-len)))) ; the elements + (if final-cdr 2 0)))) ; the final-cdr and it's label + +(defmethod compute-line-count ((i cons-inspector)) + 2) ; car & cdr + +(defmethod line-n ((i list-inspector) en &aux (n en)) + (let* ((circ? (list-inspector-length i)) + (length (abs circ?))) + (cond ((eql 0 n) + (values nil (cond ((list-inspector-dotted-p i) "Dotted List") + ((< circ? 0) "Circular List") + (t "Normal List")) + *plain-comment-type*)) + ((eql 0 (decf n)) (values length "Length: ")) + ((>= (decf n) (setq length length)) ; end of dotted list + (let ((final-cdr (list-inspector-dotted-p i))) + (unless final-cdr (line-n-out-of-range i en)) + (if (eql n length) + (values nil "Non-nil final cdr" *plain-comment-type*) + (values final-cdr (- length 0.5) :colon)))) + (t (let* ((saved-n (list-inspector-n i)) + (nthcdr (if (>= n saved-n) + (nthcdr (- n saved-n) (list-inspector-nthcdr i)) + (nthcdr n (inspector-object i))))) + (setf (list-inspector-nthcdr i) nthcdr + (list-inspector-n i) n) + (values (car nthcdr) n :colon)))))) + +(defmethod line-n ((i cons-inspector) n) + (let ((object (inspector-object i))) + (ecase n + (0 (values (car object) "Car: ")) + (1 (values (cdr object) "Cdr: "))))) + +(defmethod (setf line-n) (value (i list-inspector) n) + (when (< n 2) + (setf-line-n-out-of-range i n)) + (decf n 2) + (setf (elt (inspector-object i) n) value) + (resample-it)) + +(defmethod (setf line-n) (value (i cons-inspector) n) + (let ((object (inspector-object i))) + (ecase n + (0 (setf (car object) value)) + (1 (setf (cdr object) value)))) + (resample-it)) + +;;;;;;; +;; +;; General uvector's +;; +(defclass uvector-inspector (basics-first-mixin inspector) + ((name-list :initarg :name-list :initform nil :accessor name-list))) + +(defmethod uvector-name-list (object) + (let* ((type (type-of object)) + (names (cdr (assq type ccl::*def-accessor-types*))) + (names-size (length names)) + res) + (when names + (dotimes (i (uvsize object)) + (declare (fixnum i)) + (let ((name (and (> names-size i) (aref names i)))) + (if name + (push (if (listp name) (car name) name) res) + (if (and (eql i 0) (typep object 'ccl::internal-structure)) + (push 'type res) + (push i res))))) + (nreverse res)))) + +(defmethod compute-line-count ((i uvector-inspector)) + (setf (name-list i) (uvector-name-list (inspector-object i))) + (uvsize (inspector-object i))) + +(defmethod line-n ((i uvector-inspector) n) + (values (uvref (inspector-object i) n) + (or (let ((name-list (name-list i))) (and name-list (nth n (name-list i)))) + n) + :colon)) + +(defmethod (setf line-n) (new-value (i uvector-inspector) n) + (setf (uvref (inspector-object i) n) new-value)) + +(defmethod inspector-commands ((i uvector-inspector)) + (let ((object (inspector-object i))) + (if (method-exists-p #'inspector-commands object) + (inspector-commands object)))) + +;;;;;;; +;; +;; Vectors & Arrays +;; +(defmethod inspector-class ((v ccl::simple-1d-array)) + 'usual-basics-first-inspector) + +(defmethod compute-line-count ((v ccl::simple-1d-array)) + (+ 1 (length v))) + +(defmethod line-n ((v ccl::simple-1d-array) n) + (cond ((eql 0 n) (values (length v) "Length" :static 'prin1-colon-line)) + (t (decf n 1) + (values (aref v n) n :colon)))) + +(defmethod (setf line-n) (value (v ccl::simple-1d-array) n) + (when (<= n 0) + (setf-line-n-out-of-range v n)) + (decf n 1) + (prog1 (setf (aref v n) value) + (resample-it))) + +(defclass array-inspector (uvector-inspector) ()) + +(defmethod inspector-class ((v array)) + 'array-inspector) + +(defmethod uvector-name-list ((a array)) + (if (eql 1 (array-rank a)) + (if (array-has-fill-pointer-p a) + '("Fill Pointer" "Physical size" "Data vector" "Displacement" "Flags") + '("Logical size" "Physical size" "Data vector" "Displacement" "Flags")) + `("Rank" "Physical size" "Data vector" "Displacement" "Flags" "Dim0" "Dim1" "Dim2" "Dim3"))) + +(defmethod compute-line-count ((i array-inspector)) + (let* ((a (inspector-object i)) + (rank (array-rank a))) + (call-next-method) ; calculate name list + (+ (if (eql rank 1) (1+ (uvsize a)) 7) + (apply #'* (array-dimensions a))))) + +(defmethod line-n ((i array-inspector) n) + (let* ((v (inspector-object i)) + (rank (array-rank v)) + (uvsize (if (eql rank 1) + (+ (uvsize v) 1) + 7))) + (cond ((eql 0 n) (values (array-element-type v) + (if (adjustable-array-p v) + "Adjustable, Element type" + "Element type") + :static 'prin1-colon-line)) + ((eql 5 n) + (values (uvref v target::vectorH.flags-cell) + "Flags: " + :static + #'(lambda (i s v l type) + (format-normal-line i s v l type "#x~x")))) + ((and (eql 6 n) (not (eql rank 1))) + (values (array-dimensions v) "Dimensions: " :static)) + ((< n uvsize) (call-next-method i (1- n))) + (t (let ((index (- n uvsize))) + (values (row-major-aref v index) (array-indices v index) :colon)))))) + +(defmethod (setf line-n) (new-value (i array-inspector) n) + (let* ((v (inspector-object i)) + (rank (array-rank v)) + (uvsize (if (eql rank 1) + (+ (uvsize v) 1) + 7))) + (prog1 + (cond ((or (eql 0 n) (eql 1 n) (and (eql 4 n) (not (eql rank 1)))) + (setf-line-n-out-of-range i n)) + ((< n uvsize) + (if (eql 3 n) + (setq new-value (require-type new-value 'array)) + (setq new-value (require-type new-value 'fixnum))) + (call-next-method new-value i (1- n))) + (t (let ((index (- n uvsize))) + (setf (row-major-aref v index) new-value)))) + (resample-it)))) + +(defun array-indices (a row-major-index) + (let ((rank (array-rank a))) + (if (eql 1 rank) + row-major-index + (let ((res nil) + dim + (dividend row-major-index) + remainder) + (loop + (when (zerop rank) (return res)) + (setq dim (array-dimension a (decf rank))) + (multiple-value-setq (dividend remainder) (floor dividend dim)) + (push remainder res)))))) + +(defmethod prin1-line ((i array-inspector) stream value &optional + label type function) + (declare (ignore stream value type function)) + (if (or (numberp label) (listp label)) ; First line or contents lines + (call-next-method) + (let ((*print-array* nil)) + (call-next-method)))) + +;;;;;;; +;; +;; Numbers +;; +(defmethod inspector-class ((num number)) 'usual-formatting-inspector) + +; floats +(defmethod compute-line-count ((num float)) 5) + +(defmethod line-n ((num float) n) + (let ((type :static)) + (ecase n + (0 (values num "Float: " type)) + (1 (values num "Scientific: " type + (if (< num 0) "~8,2e" "~7,2e"))) + (2 (values (if (zerop num) "illegal" (log num 2)) + "Log base 2: " type "~d")) + (3 (values (rationalize num) + "Ratio equiv: " type)) + (4 (values (round num) + "Nearest integer: " type))))) + +; complex numbers +(defmethod compute-line-count ((num complex)) 3) + +(defmethod line-n ((num complex) n) + (let ((type :static)) + (ecase n + (0 (values num "Complex num: " type)) + (1 (values (realpart num) "Real part: " type)) + (2 (values (imagpart num) "Imaginary part: " type))))) + +; ratios +(defmethod compute-line-count ((num ratio)) 6) + +(defmethod line-n ((num ratio) n) + (let ((type :static)) + (ecase n + (0 (values num "Ratio: " type)) + (1 (values (float num) "Scientific: " type + (if (< num 0) "~8,2e" "~7,2E"))) + (2 (values (if (zerop num) "illegal" (log num 2)) + "Log base 2: " type "~d")) + (3 (values (round num) "Nearest integer: " type)) + (4 (values (numerator num) "Numerator: " type)) + (5 (values (denominator num) "Denominator: " type))))) + +; integers +(defmethod compute-line-count ((num integer)) + (let ((res 12)) + (unless (< 0 num 4000) (decf res)) ; not a roman number + (unless (<= 0 num 255) (decf res)) ; not a character + res)) + +(defmethod line-n ((num integer) n) + (if (and (>= n 7) (not (< 0 num 4000))) (incf n)) ; maybe skip roman. + (if (and (>= n 8) (not (<= 0 num 255))) (incf n)) ; maybe skip character. + (let* ((type :static) + (neg? (< num 0)) + (norm (if neg? + (+ num (expt 2 (max 32 (* 4 (round (+ (integer-length num) 4) 4))))) + num))) + (ecase n + (0 (values num + (if (fixnump num) + "Fixnum: " + "Bignum: ") + type "~s")) + (1 (let ((num (ignore-errors (float num)))) + (values num "Scientific: " type + (cond ((null num) "FLOATING-POINT-OVERFLOW") + ((< num 0) "~8,2e") + (t "~7,2e"))))) + (2 (values (if (zerop num) "illegal" (log num 2)) + "Log base 2: " type "~d")) + (3 (values norm + "Binary: " type + (if neg? "#b...~b" "#b~b"))) + (4 (values norm + "Octal: " type + (if neg? "#o...~o" "#o~o"))) + (5 (values num + "Decimal: " type "~d.")) + (6 (values norm + "Hex: " type + (if neg? "#x...~x" "#x~x"))) + (7 (values (format nil "~@r" num) + "Roman: " type "~a")) + (8 (values (code-char num) + "Character: " type "~s")) + (9 (values (ccl::ensure-simple-string (prin1-to-string num)) + "Abbreviated: " + type #'format-abbreviated-string)) + (10 (values (or (ignore-errors (universal-time-string num)) "#") + "As time: " type "~a")) + (11 (if (< num 0) + (values most-negative-fixnum 'most-negative-fixnum type '("~d." t)) + (values most-positive-fixnum 'most-positive-fixnum type '("~d." t))))))) + +(defun format-abbreviated-string (stream string) + (setq string (require-type string 'simple-string)) + (let ((length (length string))) + (if (< length 7) + (princ string stream) + (format stream "~a <- ~s digits -> ~a" + (subseq string 0 3) + (- length 6) + (subseq string (- length 3) length))))) + +(defun universal-time-string (num) + (multiple-value-bind (second minute hour date month year day) + (decode-universal-time num) + (with-output-to-string (s) + (format s "~d:~2,'0d:~2,'0d " hour minute second) + (princ (nth day '("Monday" "Tuesday" "Wednesday" "Thursday" "Friday" + "Saturday" "Sunday")) + s) + (format s ", ~d " date) + (princ (nth month '("" "January" "February" "March" "April" "May" "June" "July" + "August" "September" "October" "November" "December")) + s) + (format s ", ~d" year)))) + +; Characters +(defmethod compute-line-count ((ch character)) 2) + +(defmethod line-n ((ch character) n) + (let ((type :static)) + (ecase n + (0 (values ch "Character: " type)) + (1 (values (char-code ch) "char-code: " type))))) + +;;;;;;; +;; +;; Symbols +;; +(defun symbol-has-bindings-p (sym) + (or (constantp sym) (proclaimed-special-p sym) (boundp sym) + (special-operator-p sym) (macro-function sym) (fboundp sym) + (type-specifier-p sym) (record-type-p sym nil) + (find-class sym nil))) + +(defmethod inspector-class ((sym symbol)) 'usual-basics-first-inspector) + +(defmethod compute-line-count ((sym symbol)) + (+ (if (symbol-has-bindings-p sym) 1 0) + 1 ; package + 1 ; symbol-name + 1 ; symbol-value + 1 ; symbol-function + (if (fboundp sym) 1 0) ; arglist + 1 ; plist + (if (find-class sym nil) 1 0) ; class + )) + + +(defmethod normalize-line-number ((sym symbol) n) + (if (and (>= n 0) (not (symbol-has-bindings-p sym))) (incf n)) + (if (and (>= n 5) (not (fboundp sym))) (incf n)) + n) + +(defmethod line-n ((sym symbol) n) + (setq n (normalize-line-number sym n)) + (let ((type :normal) + (comment '(:comment (:bold))) + (static :static)) + (ecase n + (0 (values nil (symbol-type-line sym) comment)) + (1 (let ((p (symbol-package sym))) + (if (null p) + (values nil "No home package." comment) + (multiple-value-bind (found kind) (find-symbol (symbol-name sym) p) + (values p + (if (or (null kind) (neq found sym)) + "NOT PRESENT in home package: " + (format nil "~a in package: " kind)) + static))))) + (2 (values (symbol-name sym) "Print name: " static)) + (3 (values (if (boundp sym) (symbol-value sym) *unbound-marker*) + "Value: " type)) + (4 (values (if (fboundp sym) + (cond ((macro-function sym)) + ((special-operator-p sym) sym) + (t (symbol-function sym))) + *unbound-marker*) + "Function: " type)) + (5 (values (and (fboundp sym) (arglist sym)) + "Arglist: " static)) + (6 (values (symbol-plist sym) "Plist: " type)) + (7 (values (find-class sym) "Class: " static))))) + +(defmethod (setf line-n) (value (sym symbol) n) + (let (resample-p) + (setq n (normalize-line-number sym n)) + (setq value (restore-unbound value)) + (ecase n + ((0 1 2 5) (setf-line-n-out-of-range sym n)) + (3 (setf resample-p (not (boundp sym)) + (symbol-value sym) value)) + (4 (setf resample-p (not (fboundp sym)) + (symbol-function sym) value)) + (6 (setf (symbol-plist sym) value))) + (when resample-p (resample-it)) + value)) + +(defun record-type-p (name &optional check-database) + (declare (ignore check-database)) + (and (keywordp name) + (ignore-errors (ccl::%foreign-type-or-record name)))) + +; Add arglist here. +(defun symbol-type-line (sym) + (let ((types (list + (cond ((constantp sym) + "Constant") + ((proclaimed-special-p sym) + "Special Variable") + ((boundp sym) + "Non-special Variable") + (t nil)) + (cond ((special-operator-p sym) + "Special Operator") + ((macro-function sym) + "Macro") + ((fboundp sym) + "Function") + (t nil)) + (if (type-specifier-p sym) "Type Specifier") + (if (record-type-p sym nil) "Record Type") + (if (find-class sym nil) "Class Name"))) + flag) + (with-output-to-string (s) + (dolist (type types) + (when type + (if flag (write-string ", " s)) + (setq flag t) + (write-string type s)))))) + + +(defmethod inspector-commands ((sym symbol)) + (let ((res nil)) + '(push (list "Documentation" #'(lambda () (show-documentation sym))) + res) + (let ((class (find-class sym nil))) + (if class + (push (list "Inspect Class" #'(lambda () (inspect class))) res))) + (if (boundp sym) + (push (list "MAKUNBOUND" #'(lambda () (when (y-or-n-p (format nil "~s?" `(makunbound ',sym))) + (makunbound sym) (resample-it)))) + res)) + (if (fboundp sym) + (push (list "FMAKUNBOUND" #'(lambda () (when (y-or-n-p (format nil "~s?" `(fmakunbound ',sym))) + (fmakunbound sym) (resample-it)))) + res)) + '(if (record-type-p sym) + (push (list "Inspect Record Type" #'(lambda () (inspect-record-type sym))) + res)) + (nreverse res))) + + +(defmethod line-n-inspector ((sym symbol) n value label type) + (declare (ignore label type)) + (setq n (normalize-line-number sym n)) + (if (eql n 6) + (make-instance 'plist-inspector :symbol sym :object value) + (call-next-method))) + +(defclass plist-inspector (inspector) + ((symbol :initarg :symbol :reader plist-symbol))) + +(defmethod inspector-window-title ((i plist-inspector)) + (format nil "~a of ~s" 'plist (plist-symbol i))) + +(defmethod compute-line-count ((i plist-inspector)) + (+ 3 (/ (length (inspector-object i)) 2))) + +(defmethod line-n ((i plist-inspector) n) + (let* ((plist (inspector-object i))) + (cond ((eql 0 n) (values plist "Plist: ")) + ((eql 1 n) (values (plist-symbol i) "Symbol: " :static)) + ((eql 2 n) (values nil nil :comment)) + (t (let ((rest (nthcdr (* 2 (- n 3)) plist))) + (values (cadr rest) (car rest) :colon)))))) + +(defmethod (setf line-n) (new-value (i plist-inspector) n) + (let* ((plist (inspector-object i))) + (if (eql n 0) + (replace-object i new-value) + (if (< n 3) + (setf-line-n-out-of-range i n) + (let ((rest (nthcdr (* 2 (- n 3)) plist))) + (setf (cadr rest) new-value) + (resample-it)))))) + +(defparameter *inspector-disassembly* nil) + +;;;;;;; +;; +;; Functions +;; +(defclass function-inspector (inspector) + ((header-lines :initform nil :reader header-lines) + (disasm-p :accessor disasm-p :initform *inspector-disassembly*) + (disasm-info :accessor disasm-info) + (pc-width :accessor pc-width) + (pc :initarg :pc :initform nil :accessor pc))) + +(defmethod standard-header-count ((f function-inspector)) (length (header-lines f))) + +(defmethod header-count ((f function-inspector)) (standard-header-count f)) + +(defclass closure-inspector (function-inspector) + ((n-closed :accessor closure-n-closed))) + +(defmethod inspector-class ((f function)) 'function-inspector) +(defmethod inspector-class ((f compiled-lexical-closure)) 'closure-inspector) + +(defmethod compute-line-count :before ((f function-inspector)) + (let* ((o (inspector-object f)) + (doc (documentation o t)) + (sn (ccl::function-source-note o)) + (lines (nconc (list (list o "")) + (list (list (function-name o) "Name" :colon)) + (list (multiple-value-bind (arglist type) (arglist o) + (let ((label (if type + (format nil "Arglist (~(~a~))" type) + "Arglist unknown"))) + (list arglist label (if type :colon '(:comment (:plain))))))) + (when doc (list (list (substitute #\space #\newline doc) "Documentation" :colon))) + (when sn (list (list sn "Source Location" :colon)))))) + (setf (slot-value f 'header-lines) lines))) + +(defmethod compute-line-count ((f function-inspector)) + (+ (header-count f) (compute-disassembly-lines f))) + +(defmethod line-n-strings ((f function-inspector) n) + (if (< (decf n (header-count f)) 0) + (call-next-method) + (disassembly-line-n-strings f n))) + +(defmethod line-n-inspector ((f function-inspector) n value label type) + (declare (ignore value label type)) + (if (< (decf n (header-count f)) 0) + (call-next-method) + (disassembly-line-n-inspector f n))) + +(defmethod line-n ((f function-inspector) n) + (let* ((lines (header-lines f)) + (nlines (length lines))) + (if (< n nlines) + (apply #'values (nth n lines)) + (disassembly-line-n f (- n nlines))))) + +(defmethod compute-line-count :before ((f closure-inspector)) + (let* ((o (inspector-object f)) + (nclosed (nth-value 8 (function-args (ccl::closure-function o))))) + (setf (closure-n-closed f) nclosed))) + +(defmethod header-count ((f closure-inspector)) + (+ (standard-header-count f) + 1 ; the function we close over + 1 ; "Closed over values" + (closure-n-closed f))) + +(defmethod line-n ((f closure-inspector) n) + (let ((o (inspector-object f)) + (nclosed (closure-n-closed f))) + (if (< (decf n (standard-header-count f)) 0) + (call-next-method) + (cond ((< (decf n) 0) + (values (ccl::closure-function o) "Inner lfun: " :static)) + ((< (decf n) 0) + (values nclosed "Closed over values" :comment)) + ((< n nclosed) + (let* ((value (ccl::nth-immediate o (1+ (- nclosed n)))) + (map (car (ccl::function-symbol-map (ccl::closure-function o)))) + (label (or (and map (svref map (+ n (- (length map) nclosed)))) + n)) + (cellp (ccl::closed-over-value-p value))) + (when cellp + (setq value (ccl::closed-over-value value) + label (format nil "(~a)" label))) + (values value label (if cellp :normal :static) #'prin1-colon-line))) + (t (disassembly-line-n f (- n nclosed))))))) + +(defmethod (setf line-n) (new-value (f function-inspector) n) + (let ((o (inspector-object f)) + (standard-header-count (standard-header-count f))) + (if (< n standard-header-count) + (case n + (0 (replace-object f new-value)) + (1 (ccl::lfun-name o new-value) (resample-it)) + (t (setf-line-n-out-of-range f n))) + (set-disassembly-line-n f (- n standard-header-count) new-value))) + new-value) + +(defmethod (setf line-n) (new-value (f closure-inspector) en &aux (n en)) + (let ((o (inspector-object f)) + (nclosed (closure-n-closed f))) + (if (< (decf n (standard-header-count f)) 0) + (call-next-method) + (cond ((< (decf n 2) 0) ; inner-lfun or "Closed over values" + (setf-line-n-out-of-range f en)) + ((< n nclosed) ; closed-over variable + (let* ((value (ccl::nth-immediate o (1+ (- nclosed n)))) + (cellp (ccl::closed-over-value-p value))) + (unless cellp (setf-line-n-out-of-range f en)) + (ccl::set-closed-over-value value new-value))) + (t (set-disassembly-line-n f (- n nclosed) new-value)))))) + +(defun compute-disassembly-lines (f &optional (function (inspector-object f))) + (if (and (functionp function) (disasm-p f)) + (let* ((lines (ccl::disassemble-lines function)) ;; list of (object label instr) + (length (length lines)) + (last-label (loop for n from (1- length) downto 0 as line = (aref lines n) + thereis (and (consp line) (cadr line)))) + (max-pc (if (consp last-label) (cadr last-label) last-label))) + (setf (pc-width f) (length (format nil "~d" max-pc))) + (setf (disasm-info f) lines) + (1+ length)) + 0)) + +(defun disassembly-line-n (f n) + (if (< (decf n) 0) + (values nil "Disassembly:" :comment) + (let ((line (svref (disasm-info f) n))) + (if (consp line) + (destructuring-bind (object label instr) line + (values object (cons label instr) :static)) + (values nil (cons nil line) :static))))) + +(defun disassembly-line-n-inspector (f n) + (unless (< (decf n) 0) + (let ((line (svref (disasm-info f) n))) + (and (consp line) + (car line) + (make-inspector (car line)))))) + +(defun disassembly-line-n-strings (f n) + (if (< (decf n) 0) + (values "Disassembly:" nil) + (let ((line (svref (disasm-info f) n))) + (if (consp line) + (destructuring-bind (object label instr) line + (declare (ignore object)) + (unless (stringp label) + (setq label (with-output-to-string (stream) + (prin1-disassembly-label f stream label)))) + (values label instr)) + (values nil line))))) + +(defun set-disassembly-line-n (f n new-value &optional + (function (inspector-object f))) + (declare (ignore new-value function)) + (setf-line-n-out-of-range f n)) + +(defmethod prin1-label ((f function-inspector) stream value &optional data type) + (declare (ignore value type)) + (if (atom data) ; not a disassembly line + (call-next-method) + (prin1-disassembly-label f stream (car data)))) + +(defun prin1-disassembly-label (f stream label) + (let* ((pc label) + (label-p (and (consp pc) (setq pc (cadr pc)))) + (pc-mark (pc f)) + (pc-width (pc-width f))) + (when pc + (write-char (if (eql pc pc-mark) #\* #\Space) stream) + (format stream "~@[L~d~]~vT~v<[~d]~> " label-p (+ pc-width 3) (+ pc-width 2) pc)))) + +#+x86-target +(defmethod prin1-value ((f function-inspector) stream value &optional data type) + (declare (ignore value type)) + (if (atom data) ;; not a disassembly line + (call-next-method) + (princ (cdr data) stream))) + + +#+ppc-target +(defmethod prin1-value ((f function-inspector) stream value &optional label type) + (if (atom label) ; not a disassembly line + (unless (eq (if (consp type) (car type) type) :comment) + (call-next-method)) + (let ((q (cdr label))) + (write-char #$ stream) + (loop (if (null q) (return)) + (ccl::disasm-prin1 (pop q) stream) + (if q (write-char #\space stream))) + (write-char #$ stream))) + value) + +;; Generic-functions +;; Display the list of methods on a line of its own to make getting at them faster +;; (They're also inside the dispatch-table which is the first immediate in the disassembly). +(defclass gf-inspector (function-inspector) + ((method-count :accessor method-count))) + +(defmethod inspector-class ((f standard-generic-function)) + (if (functionp f) + 'gf-inspector + 'standard-object-inspector)) + +(defmethod compute-line-count :before ((f gf-inspector)) + (let* ((gf (inspector-object f)) + (count (length (generic-function-methods gf)))) + (setf (method-count f) count))) + +(defmethod header-count ((f gf-inspector)) + (+ (standard-header-count f) 1 (method-count f))) + +(defmethod line-n ((f gf-inspector) n) + (let* ((count (method-count f)) + (methods (generic-function-methods (inspector-object f)))) + (cond ((< (decf n (standard-header-count f)) 0) + (call-next-method)) + ((< (decf n) 0) + (values methods "Methods: " :comment)) + ((< n count) + (values (nth n methods) nil :static)) + (t (disassembly-line-n f (- n count)))))) + +(defmethod (setf line-n) (new-value (f gf-inspector) n) + (let* ((count (method-count f)) + (en n)) + (cond ((< (decf n (standard-header-count f)) 0) + (call-next-method)) + ((< (decf n) count) + (setf-line-n-out-of-range f en)) + (t (set-disassembly-line-n f (- n count) new-value))))) + +#| +(defmethod inspector-commands ((f gf-inspector)) + (let* ((function (inspector-object f)) + (method (selected-object (inspector-view f)))) + (if (typep method 'method) + (nconc + (call-next-method) + `(("Remove method" + ,#'(lambda () + (remove-method function method) + (resample-it))))) + (call-next-method)))) +|# + +;;;;;;; +;; +;; Structures +;; +(defmethod inspector-class ((s structure-object)) + 'usual-basics-first-inspector) + +(defun structure-slots (s) + (let ((slots (ccl::sd-slots (ccl::struct-def s)))) + (if (symbolp (caar slots)) + slots + (cdr slots)))) + +(defmethod compute-line-count ((s structure-object)) + (length (structure-slots s))) + +(defmethod line-n ((s structure-object) n) + (let ((slot (nth n (structure-slots s)))) + (if slot + (values (uvref s (ccl::ssd-offset slot)) (ccl::ssd-name slot) :colon) + (line-n-out-of-range s n)))) + +(defmethod (setf line-n) (new-value (s structure-object) n) + (let ((slot (nth n (structure-slots s)))) + (if slot + (setf (uvref s (ccl::ssd-offset slot)) new-value) + (setf-line-n-out-of-range s n)))) + + +(defclass basic-stream-inspector (uvector-inspector) ()) + +(defmethod inspector-class ((bs ccl::basic-stream)) 'basic-stream-inspector) + +;;;;;;; +;; +;; packages +;; +(defclass package-inspector (uvector-inspector) ()) + +(defmethod inspector-class ((p package)) 'package-inspector) + +(defmethod compute-line-count ((i package-inspector)) + (+ 2 (call-next-method))) + +(defmethod line-n ((i package-inspector) n) + (cond ((eql n 0) (values (ccl::%pkgtab-count (ccl::pkg.itab (inspector-object i))) + "Internal Symbols: " :static)) + ((eql n 1) (values (ccl::%pkgtab-count (ccl::pkg.etab (inspector-object i))) + "External Symbols: " :static)) + (t (call-next-method i (- n 2))))) + +(defmethod (setf line-n) (new-value (i package-inspector) n) + (if (< n 2) + (setf-line-n-out-of-range i n) + (call-next-method new-value i (- n 2)))) + +(defmethod inspector-commands ((i package-inspector)) + `(("Inspect all packages" ,#'(lambda () (inspect (list-all-packages)))) + (,(format nil "(setq *package* '~a" (inspector-object i)) + ,#'(lambda () (setq *package* (inspector-object i)))))) + +;;;;;;; +;; +;; Records +;; +(defclass record-inspector (object-first-inspector) + ((record-type :accessor record-type) + (field-names :accessor field-names) + (unlock :initform nil :accessor unlock))) + +(defmethod inspector-class ((o macptr)) + 'record-inspector) + + +;;; Still needs work. +;;; Lots of work. +(defclass thread-inspector (uvector-inspector) ()) + +(defmethod inspector-class ((thread ccl::lisp-thread)) + 'thread-inspector) + +(defmethod compute-line-count :before ((i thread-inspector)) +) + +(defmethod line-n ((thread thread-inspector) n) + (declare (ignorable n)) + (call-next-method) +) + +#| +(defmethod line-n-inspector ((i thread-inspector) n value label type) + (declare (ignore n type)) + (or (and value + (macptrp value) + (not (%null-ptr-p value))) + (call-next-method))) +|# + + +(defmethod line-n-inspector (i n value label type) + (declare (ignore i n label type)) + (make-inspector value)) + +(defmethod line-n-inspector ((i usual-inspector) n value label type) + (let ((object (inspector-object i))) + (if (typep object 'usual-inspector) + (make-inspector value) + (line-n-inspector (inspector-object i) n value label type)))) + + + + + +;;;;;;; +;; +;; an ERROR-FRAME stores the stack addresses that the backtrace window displays +;; + +;; set to list of function you don't want to see +;; Functions can be symbols, nil for kernel, or #'functions +(defparameter *backtrace-internal-functions* + (list :kernel)) + +(defvar *backtrace-hide-internal-functions-p* t) + +(defclass error-frame () + ((addresses :accessor addresses) + (restart-info :accessor restart-info) + (stack-start :initarg :stack-start :reader stack-start) + (stack-end :initarg :stack-end :reader stack-end) + (tcr :initarg :tcr :initform (ccl::%current-tcr) :reader tcr) + (context :initarg :context :reader context) + (frame-count :accessor frame-count) + (ignored-functions :accessor ignored-functions + :initform (and *backtrace-hide-internal-functions-p* + *backtrace-internal-functions*)) + (break-condition :accessor break-condition + :initarg :break-condition) + (unavailable-value-marker :initform (cons nil nil) + :accessor unavailable-value-marker))) + + + +(defmethod initialize-instance ((f error-frame) &key) + (call-next-method) + (initialize-addresses f)) + +(defmethod initialize-addresses ((f error-frame)) + (let* ((addresses (coerce (ccl::%stack-frames-in-context (context f)) 'vector))) + (setf (frame-count f) (length addresses) + (addresses f) addresses))) + +(defmethod compute-frame-info ((f error-frame) n) + (let* ((frame (svref (addresses f) n)) + (context (context f)) + (marker (unavailable-value-marker f))) + + (multiple-value-bind (lfun pc) (ccl::cfp-lfun frame) + (multiple-value-bind (args locals) (ccl::arguments-and-locals context frame lfun pc marker) + (list (ccl::arglist-from-map lfun) args locals))))) + +(defun print-error-frame-limits (f stream) + (format stream "#x~x - #x~x" (stack-start f) (stack-end f))) + +(defmethod print-object ((f error-frame) stream) + (print-unreadable-object (f stream :type 'frame-ptr) + (print-error-frame-limits f stream))) + + + +;;;;;;; +;; +;; The inspector for error-frame objects +;; + + + +;;; The "vsp-range" and "tsp-range" slots have to do with +;;; recognizing/validating stack-allocated objects +(defclass stack-inspector (inspector) + ((vsp-range :accessor vsp-range :initarg :vsp-range) + (tsp-range :accessor tsp-range :initarg :tsp-range) + (csp-range :accessor csp-range :initarg :csp-range))) + + + + +(defmethod initialize-instance ((i stack-inspector) &rest initargs &key context) + (declare (dynamic-extent initargs)) + (let* ((start (ccl::child-frame (ccl::parent-frame (ccl::bt.youngest context) context) context)) + (end (ccl::child-frame (ccl::parent-frame (ccl::bt.oldest context) context) context)) + (tcr (ccl::bt.tcr context))) + (apply #'call-next-method + i + :object + (make-instance 'error-frame + :stack-start start + :stack-end end + :tcr tcr + :context context + :break-condition (ccl::bt.break-condition context)) + :tsp-range (make-tsp-stack-range tcr context) + :vsp-range (make-vsp-stack-range tcr context) + :csp-range (make-csp-stack-range tcr context) + initargs))) + +(defmethod print-object ((i stack-inspector) stream) + (print-unreadable-object (i stream :type 'stack-inspector) + (print-error-frame-limits (inspector-object i) stream))) + +(defmethod addresses ((f stack-inspector)) + (addresses (inspector-object f))) + +(defmethod compute-line-count ((f stack-inspector)) + (frame-count (inspector-object f))) + +(defmethod line-n ((f stack-inspector) n) + (let* ((frame (svref (addresses (inspector-object f)) n))) + (ccl::cfp-lfun frame))) + + + + + + +;;; inspecting a single stack frame +;;; The inspector-object is expected to be an error-frame +(defclass stack-frame-inspector (inspector) + ((frame-number :initarg :frame-number :initform nil :reader frame-number) + (frame-info :initform nil :accessor frame-info))) + + +(defmethod initialize-instance ((i stack-frame-inspector) &rest initargs &key + object frame-number) + (declare (dynamic-extent initargs)) + (setq object (require-type object 'error-frame)) + (apply #'call-next-method i + :object object + initargs) + (setf (frame-number i) frame-number)) + + + +(defmethod compute-line-count ((i stack-frame-inspector)) + (let ((frame-number (frame-number i))) + (if (null frame-number) + 0 + (let* ((error-frame (inspector-object i)) + (frame-info (or (frame-info i) + (setf (frame-info i) (compute-frame-info error-frame frame-number))))) + (destructuring-bind (args locals) (cdr frame-info) + (+ 1 (length args) 1 (length locals))))))) + +(defmethod line-n ((i stack-frame-inspector) n) + (unless (< -1 n (inspector-line-count i)) + (line-n-out-of-range i n)) + (destructuring-bind (arglist args locals) (frame-info i) + (if (zerop n) + (values arglist nil :static) + (let* ((nargs (length args))) + (decf n) + (if (< n nargs) + (cons :arg (nth n args)) + (progn + (decf n nargs) + (if (zerop n) + nil + (cons :local (nth (1- n) locals))))))))) + +(defmethod (setf line-n) (value (i stack-frame-inspector) n) + (declare (ignorable value n)) + (error "not yet!")) + + + + + +(defmethod prin1-value ((i stack-frame-inspector) stream value &optional label type) + (declare (ignore label type)) + (when value + (if (or (atom value) (not (typep (car value) 'keyword))) + (prin1 value stream) + (progn + (if (eq (car value) :arg) + (format stream " ") + (format stream " ")) + (when (cdr value) + (destructuring-bind (label . val) (cdr value) + (format stream "~a: " label) + (if (eq val *unbound-marker*) + (format stream "??") + (prin1 val stream)))))))) + +(defmethod (setf frame-number) (frame-number (i stack-frame-inspector)) + (let ((max (1- (frame-count (inspector-object i))))) + (unless (or (null frame-number) + (and (<= 0 frame-number max))) + (setq frame-number (require-type frame-number `(or null (integer 0 ,max)))))) + (unless (eql frame-number (frame-number i)) + (setf (slot-value i 'frame-number) frame-number) + (setf (inspector-line-count i) nil) + frame-number)) + + +;;; Each of these stack ranges defines the entire range of (control/value/temp) +;;; addresses; they can be used to addresses of stack-allocated objects +;;; for printing. +(defun make-tsp-stack-range (tcr bt-info) + (list (cons (ccl::%catch-tsp (ccl::bt.top-catch bt-info)) + (ccl::%fixnum-ref (ccl::%fixnum-ref tcr target::tcr.ts-area) + target::area.high)))) + +#+ppc-target +(defun make-vsp-stack-range (tcr bt-info) + (list (cons (ccl::%fixnum-ref + (ccl::%svref (ccl::bt.top-catch bt-info) target::catch-frame.csp-cell) + target::lisp-frame.savevsp) + (ccl::%fixnum-ref (ccl::%fixnum-ref tcr target::tcr.vs-area) + target::area.high)))) +#+x8632-target +(defun make-vsp-stack-range (tcr bt-info) + (list (cons (ccl::%svref (ccl::bt.top-catch bt-info) target::catch-frame.esp-cell) + (ccl::%fixnum-ref (ccl::%fixnum-ref tcr target::tcr.vs-area) + target::area.high)))) + +#+x8664-target +(defun make-vsp-stack-range (tcr bt-info) + (list (cons (ccl::%svref (ccl::bt.top-catch bt-info) target::catch-frame.rsp-cell) + (ccl::%fixnum-ref (ccl::%fixnum-ref tcr target::tcr.vs-area) + target::area.high)))) + +#+ppc-target +(defun make-csp-stack-range (tcr bt-info) + (list (cons (ccl::%svref (ccl::bt.top-catch bt-info) target::catch-frame.csp-cell) + (ccl::%fixnum-ref (ccl::%fixnum-ref tcr target::tcr.cs-area) + target::area.high)))) + +#+x8632-target +(defun make-csp-stack-range (tcr bt-info) + (list (cons (ccl::%svref (ccl::bt.top-catch bt-info) target::catch-frame.foreign-sp-cell) + (ccl::%fixnum-ref (ccl::%fixnum-ref tcr target::tcr.cs-area) + target::area.high)))) + +#+x8664-target +(defun make-csp-stack-range (tcr bt-info) + (list (cons (ccl::%svref (ccl::bt.top-catch bt-info) target::catch-frame.foreign-sp-cell) + (ccl::%fixnum-ref (ccl::%fixnum-ref tcr target::tcr.cs-area) + target::area.high)))) + + +;;; Inspector + + +(defvar *inspector-ui* ()) +(defvar *previous-inspector-ui* nil) + +(defclass inspector-ui () + ((inspector :initarg :inspector :accessor inspector-ui-inspector) + (level :initarg :level :accessor inspector-ui-level))) + +(defclass inspector-tty-ui (inspector-ui) + ((origin :initarg :origin :initform 0 :accessor inspector-tty-ui-origin) + (pagesize :initarg :pagesize :initform 20 :accessor + inspector-tty-ui-pagesize))) + +(defmethod ui-initialize ((ui inspector-tty-ui))) + +(defmethod ui-present ((ui inspector-tty-ui)) + (let* ((inspector (inspector-ui-inspector ui))) + (with-errorfree-printing + (let* ((stream *debug-io*) + (origin (inspector-tty-ui-origin ui)) + (pagesize (inspector-tty-ui-pagesize ui)) + (page-end (+ origin pagesize)) + (n (compute-line-count inspector)) + (end (min page-end n)) + (tag -1) + (*print-pretty* (or *print-pretty* *describe-pretty*)) + (*print-length* 5) + (*print-level* 5) + (func #'(lambda (i index child &optional label-string value-string) + (declare (ignore i)) + (when child (incf tag)) + (unless (< index origin) + (format stream "~@[[~d]~]~8t" (and child tag)) + (format-line-for-tty stream label-string value-string) + (terpri stream))))) + (declare (dynamic-extent func)) + (map-lines inspector func 0 end))) + (values))) + +(ccl::define-toplevel-command + :tty-inspect i (n) + "inspect th item" + (inspector-ui-inspect-nth *inspector-ui* n)) + +(ccl::define-toplevel-command + :tty-inspect pop () + "exit current inspector level" + (invoke-restart 'exit-inspector)) + +(ccl::define-toplevel-command + :tty-inspect q () + "exit inspector" + (invoke-restart 'end-inspect)) + +(ccl::define-toplevel-command + :tty-inspect show () + "re-show currently inspected object (the value of CCL:@)" + (ui-present *inspector-ui*)) + +(defmethod inspector-ui-next-page ((ui inspector-tty-ui)) + (let* ((nlines (compute-line-count (inspector-ui-inspector ui))) + (origin (inspector-tty-ui-origin ui)) + (page-size (inspector-tty-ui-pagesize ui)) + (new-origin (+ origin page-size))) + (if (< new-origin nlines) + (setf (inspector-tty-ui-origin ui) new-origin)) + (ui-present ui))) + +(ccl::define-toplevel-command + :tty-inspect next () + "show next page of object data" + (inspector-ui-next-page *inspector-ui*)) + +(defmethod inspector-ui-prev-page ((ui inspector-tty-ui)) + (let* ((origin (inspector-tty-ui-origin ui)) + (page-size (inspector-tty-ui-pagesize ui)) + (new-origin (max 0 (- origin page-size)))) + (setf (inspector-tty-ui-origin ui) new-origin) + (ui-present ui))) + +(ccl::define-toplevel-command + :tty-inspect prev () + "show previous page of object data" + (inspector-ui-prev-page *inspector-ui*)) + +(ccl::define-toplevel-command + :tty-inspect home () + "show first page of object data" + (progn + (setf (inspector-tty-ui-origin *inspector-ui*) 0) + (ui-present *inspector-ui*))) + +(ccl::define-toplevel-command + :tty-inspect s (n v) + "set the th line of object data to value " + (let* ((ui *inspector-ui*)) + (setf (line-n (inspector-ui-inspector ui) n) v) + (ui-present ui))) + + +(defmethod ui-interact ((ui inspector-tty-ui)) + (let* ((level (inspector-ui-level ui)) + (ccl::*default-integer-command* `(:i 0 ,(1- (compute-line-count (inspector-ui-inspector ui)))))) + (declare (special ccl::*default-integer-command*)) + (restart-case + (ccl:with-terminal-input + (ccl::with-toplevel-commands :tty-inspect + (ccl::read-loop + :prompt-function #'(lambda (stream) + (if (eql level 0) + (format stream "~&Inspect> ") + (format stream "~&Inspect ~d> " level)))))) + (exit-inspector () + (if *previous-inspector-ui* + (ui-present *previous-inspector-ui*) + (terpri *debug-io*)))))) + +(defmethod inspector-ui-inspect-nth ((ui inspector-tty-ui) n) + (let* ((inspector (inspector-ui-inspector ui)) + (new-inspector (block nil + (let* ((tag -1) + (func #'(lambda (i index child &rest strings) + (declare (ignore i index strings)) + (when (and child (eql (incf tag) n)) (return child))))) + (declare (dynamic-extent func)) + (map-lines inspector func)))) + (ccl::@ (inspector-object new-inspector))) + (inspector-ui-inspect + (make-instance 'inspector-tty-ui + :level (1+ (inspector-ui-level ui)) + :inspector new-inspector)))) + +(defparameter *default-inspector-ui-class-name* 'inspector-tty-ui) + +(defmethod inspector-ui-inspect ((ui inspector-ui)) + (let* ((*previous-inspector-ui* *inspector-ui*) + (*inspector-ui* ui)) + (ui-initialize ui) + (ui-present ui) + (ui-interact ui) + (values))) + +(defun tty-inspect (thing) + (inspector-ui-inspect (make-instance *default-inspector-ui-class-name* + :inspector (make-inspector thing) + :level 0))) + +(defparameter *default-inspector-ui-creation-function* 'tty-inspect) + + +(defun inspect (thing) + (let* ((ccl::@ thing)) + (restart-case (funcall *default-inspector-ui-creation-function* thing) + (end-inspect () thing)))) Index: /branches/new-random/lib/distrib-inits.lisp =================================================================== --- /branches/new-random/lib/distrib-inits.lisp (revision 13309) +++ /branches/new-random/lib/distrib-inits.lisp (revision 13309) @@ -0,0 +1,29 @@ +; -*- Mode:Lisp; Package:CCL; -*- +;;; +;;; Copyright (C) 2009 Clozure Associates +;;; Copyright (C) 1994-2001 Digitool, Inc +;;; This file is part of Clozure CL. +;;; +;;; Clozure CL is licensed under the terms of the Lisp Lesser GNU Public +;;; License , known as the LLGPL and distributed with Clozure CL as the +;;; file "LICENSE". The LLGPL consists of a preamble and the LGPL, +;;; which is distributed with Clozure CL as the file "LGPL". Where these +;;; conflict, the preamble takes precedence. +;;; +;;; Clozure CL is referenced in the preamble as the "LIBRARY." +;;; +;;; The LLGPL is also available online at +;;; http://opensource.franz.com/preamble.html + +;; distrib-inits.lisp + +; Things that are in the development environment that need to be +; added to the distribution environment. + +; This needs to be compiled after everything is loaded. + +(in-package "CCL") + +; *def-accessor-types* is used by the inspector to name slots in uvectors +(dolist (cell '#.*def-accessor-types*) + (add-accessor-types (list (car cell)) (cdr cell))) Index: /branches/new-random/lib/dumplisp.lisp =================================================================== --- /branches/new-random/lib/dumplisp.lisp (revision 13309) +++ /branches/new-random/lib/dumplisp.lisp (revision 13309) @@ -0,0 +1,329 @@ +;;;-*-Mode: LISP; Package: CCL -*- +;;; +;;; Copyright (C) 2009 Clozure Associates +;;; Copyright (C) 1994-2001 Digitool, Inc +;;; This file is part of Clozure CL. +;;; +;;; Clozure CL is licensed under the terms of the Lisp Lesser GNU Public +;;; License , known as the LLGPL and distributed with Clozure CL as the +;;; file "LICENSE". The LLGPL consists of a preamble and the LGPL, +;;; which is distributed with Clozure CL as the file "LGPL". Where these +;;; conflict, the preamble takes precedence. +;;; +;;; Clozure CL is referenced in the preamble as the "LIBRARY." +;;; +;;; The LLGPL is also available online at +;;; http://opensource.franz.com/preamble.html + +; Dumplisp.lisp + +(in-package "CCL") + +(defvar *save-exit-functions* nil + "List of (0-arg)functions to call before saving memory image") + +(defvar *restore-lisp-functions* nil + "List of (0-arg)functions to call after restoring saved image") + + +(declaim (special *lisp-system-pointer-functions*)) ; defined in l1-init. + +(defun kill-lisp-pointers () + (setq * nil ** nil *** nil + nil ++ nil +++ nil - nil + / nil // nil /// nil + @ nil) + (clear-open-file-streams) + (setf (*%saved-method-var%*) nil) + (setq *%periodic-tasks%* nil) + (setq *event-dispatch-task* nil) + (setq *interactive-abort-process* nil) + ) + +(defun clear-ioblock-streams () + (%map-areas (lambda (o) + (if (typep o 'basic-stream) + (let ((s (basic-stream.state o))) + (when (and (typep s 'ioblock) + (ioblock-device s) + (>= (ioblock-device s) 0)) + (setf (basic-stream.state o) nil))) + ;; Have to be careful with use of TYPEP here (and + ;; in the little bit of Lisp code that runs before + ;; the image is saved.) We may have just done + ;; things to forget about (per-session) foreign + ;; class addresses, and calling TYPEP on a pointer + ;; to such a class might cause us to remember + ;; those per-session addresses and confuse the + ;; startup code. + (if (and (eql (typecode o) target::subtag-instance) + (typep o 'buffered-stream-mixin) + (slot-boundp o 'ioblock)) + (let ((s (slot-value o 'ioblock))) + (when (and (typep s 'ioblock) + (ioblock-device s) + (>= (ioblock-device s) 0)) + (setf (slot-value o 'ioblock) nil)))))))) + +(defun save-application (filename + &rest rest + &key toplevel-function + init-file + error-handler application-class + clear-clos-caches + (purify t) + impurify + (mode #o644) + prepend-kernel + #+windows-target (application-type :console)) + (declare (ignore toplevel-function error-handler application-class + clear-clos-caches init-file impurify)) + #+windows-target (check-type application-type (member :console :gui)) + (unless (probe-file (make-pathname :defaults nil + :directory (pathname-directory (translate-logical-pathname filename)))) + (error "Directory containing ~s does not exist." filename)) + (let* ((kind (%unix-file-kind (native-translated-namestring filename)))) + (when (and kind (not (eq kind :file ))) + (error "~S is not a regular file." filename))) + (let* ((watched (watch))) + (when watched + (cerror "Un-watch them." "There are watched objects.") + (mapc #'unwatch watched))) + (let* ((ip *initial-process*) + (cp *current-process*)) + (when (process-verify-quit ip) + (let* ((fd (open-dumplisp-file filename + :mode mode + :prepend-kernel prepend-kernel + #+windows-target #+windows-target + :application-type application-type))) + (process-interrupt ip + #'(lambda () + (process-exit-application + *current-process* + #'(lambda () + (apply #'%save-application-internal + fd + :purify purify + rest)))))) + (unless (eq cp ip) + (process-kill cp))))) + +(defun %save-application-internal (fd &key + toplevel-function ;???? + error-handler ; meaningless unless application-class or *application* not lisp-development.. + application-class + mode + (purify t) + (impurify nil) + (init-file nil init-file-p) + (clear-clos-caches t) + prepend-kernel + #+windows-target application-type) + (declare (ignore mode prepend-kernel #+windows-target application-type)) + (when (and application-class (neq (class-of *application*) + (if (symbolp application-class) + (find-class application-class) + application-class))) + (setq *application* (make-instance application-class))) + (if (not toplevel-function) + (setq toplevel-function + #'(lambda () + (toplevel-function *application* + (if init-file-p + init-file + (application-init-file *application*))))) + (let* ((user-toplevel-function (coerce-to-function toplevel-function))) + (setq toplevel-function + (lambda () + (process-run-function "toplevel" (lambda () + (funcall user-toplevel-function) + (quit))) + (%set-toplevel #'housekeeping-loop) + (toplevel))))) + (when error-handler + (make-application-error-handler *application* error-handler)) + + (if clear-clos-caches (clear-clos-caches)) + (save-image #'(lambda () (%save-application fd + (logior (if impurify 2 0) + (if purify 1 0)))) + toplevel-function)) + +(defun save-image (save-function toplevel-function) + (let ((toplevel #'(lambda () (#_exit -1)))) + (%set-toplevel #'(lambda () + (setf (interrupt-level) -1) + (%set-toplevel toplevel) ; in case *save-exit-functions* error + (dolist (f *save-exit-functions*) + (funcall f)) + (kill-lisp-pointers) + (clear-ioblock-streams) + (with-deferred-gc + (let* ((pop *termination-population*)) + (with-lock-grabbed (*termination-population-lock*) + (setf (population.data pop) nil + (population.termination-list pop) nil)))) + (%set-toplevel + #'(lambda () + (%set-toplevel #'(lambda () + (setf (interrupt-level) 0) + (funcall toplevel-function))) + (restore-lisp-pointers))) ; do startup stuff + (funcall save-function))) + (toplevel))) + +;;; If file in-fd contains an embedded lisp image, return the file position +;;; of the start of that image; otherwise, return the file's length. +(defun skip-embedded-image (in-fd) + (let* ((len (fd-lseek in-fd 0 #$SEEK_END))) + (if (< len 0) + (%errno-disp len) + (%stack-block ((trailer 16)) + (let* ((trailer-pos (fd-lseek in-fd -16 #$SEEK_CUR))) + (if (< trailer-pos 0) + len + (if (not (= 16 (the fixnum (fd-read in-fd trailer 16)))) + len + (if (not (dotimes (i 12 t) + (unless (eql (char-code (schar "OpenMCLImage" i)) + (%get-unsigned-byte trailer i)) + (return nil)))) + len + (let* ((header-pos (fd-lseek in-fd + (%get-signed-long + trailer + 12) + #$SEEK_CUR))) + (if (< header-pos 0) + len + header-pos)))))))))) + +;;; Note that Windows executable files are in what they call "PE" +;;; (= "Portable Executable") format, not to be confused with the "PEF" +;;; (= "PowerPC Executable Format" or "Preferred Executable Format") +;;; executable format that Apple used on Classic MacOS. +(defun %prepend-file (out-fd in-fd len #+windows-target application-type) + (declare (fixnum out-fd in-fd len)) + (fd-lseek in-fd 0 #$SEEK_SET) + (let* ((bufsize (ash 1 15)) + #+windows-target (first-buf t)) + (%stack-block ((buf bufsize)) + (loop + (when (zerop len) (return)) + (let* ((nread (fd-read in-fd buf (min len bufsize)))) + (declare (fixnum nread)) + (if (< nread 0) + (%errno-disp nread)) + #+windows-target + (when (shiftf first-buf nil) + (let* ((application-byte (ecase application-type + (:console #$IMAGE_SUBSYSTEM_WINDOWS_CUI) + (:gui #$IMAGE_SUBSYSTEM_WINDOWS_GUI))) + (offset (%get-long buf (get-field-offset #>IMAGE_DOS_HEADER.e_lfanew)))) + (assert (< offset bufsize) () "PE header not within first ~D bytes" bufsize) + (assert (= (%get-byte buf (+ offset 0)) (char-code #\P)) () + "File does not appear to be a PE file") + (assert (= (%get-byte buf (+ offset 1)) (char-code #\E)) () + "File does not appear to be a PE file") + (assert (= (%get-byte buf (+ offset 2)) 0) () + "File does not appear to be a PE file") + (assert (= (%get-byte buf (+ offset 3)) 0) () + "File does not appear to be a PE file") + ;; File is a PE file -- Windows subsystem byte goes at offset 68 in the + ;; "optional header" which appears right after the standard header (20 bytes) + ;; and the PE cookie (4 bytes) + (setf (%get-byte buf (+ offset 4 (record-length #>IMAGE_FILE_HEADER) (get-field-offset #>IMAGE_OPTIONAL_HEADER.Subsystem) )) application-byte))) + (let* ((nwritten (fd-write out-fd buf nread))) + (declare (fixnum nwritten)) + (unless (= nwritten nread) + (error "I/O error writing to fd ~d" out-fd))) + (decf len nread)))))) + + + +(defun kernel-path () + (let* ((p (%null-ptr))) + (declare (dynamic-extent p)) + (%get-kernel-global-ptr 'kernel-path p) + (if (%null-ptr-p p) + (%realpath (car *command-line-argument-list*)) + (let* ((string (%get-utf-8-cstring p))) + #+windows-target (nbackslash-to-forward-slash string) + #+darwin-target (precompose-simple-string string) + #-(or windows-target darwin-target) string)))) + + +(defun open-dumplisp-file (path &key (mode #o666) prepend-kernel + #+windows-target application-type) + (let* ((prepend-path (if prepend-kernel + (if (eq prepend-kernel t) + (kernel-path) + (native-translated-namestring + (pathname prepend-kernel))))) + (prepend-fd (if prepend-path (fd-open prepend-path #$O_RDONLY))) + (prepend-len (if prepend-kernel + (if (and prepend-fd (>= prepend-fd 0)) + (skip-embedded-image prepend-fd) + (signal-file-error prepend-fd prepend-path)))) + (filename (native-translated-namestring path))) + (when (probe-file filename) + (%delete-file filename)) + (when prepend-fd + ;; Copy the execute mode bits from the prepended "kernel". + (let ((prepend-fd-mode (nth-value 1 (%fstat prepend-fd)))) + (setq mode (logior (logand prepend-fd-mode #o111) mode)))) + (let* ((image-fd (fd-open filename (logior #$O_WRONLY #$O_CREAT) mode))) + (unless (>= image-fd 0) (signal-file-error image-fd filename)) + (when prepend-fd + (%prepend-file image-fd prepend-fd prepend-len #+windows-target application-type)) + (fd-chmod image-fd mode) + image-fd))) + + +(defun %save-application (fd &optional (flags 1)) + (let* ((err (%%save-application flags fd))) + (unless (eql err 0) + (%err-disp err)))) + + +(defun restore-lisp-pointers () + (setq *interactive-streams-initialized* nil) + (setq *heap-ivectors* nil) + (setq *batch-flag* (not (eql (%get-kernel-global 'batch-flag) 0))) + (%revive-system-locks) + (refresh-external-entrypoints) + (restore-pascal-functions) + (initialize-interactive-streams) + (let ((system-ptr-fns (reverse *lisp-system-pointer-functions*)) + (restore-lisp-fns *restore-lisp-functions*) + (user-pointer-fns *lisp-user-pointer-functions*) + (lisp-startup-fns *lisp-startup-functions*)) + (unwind-protect + (with-simple-restart (abort "Abort (possibly crucial) startup functions.") + (let ((call-with-restart + #'(lambda (f) + (with-simple-restart + (continue "Skip (possibly crucial) startup function ~s." + (if (symbolp f) f (function-name f))) + (funcall f))))) + (dolist (f system-ptr-fns) (funcall call-with-restart f)) + (dolist (f restore-lisp-fns) (funcall call-with-restart f)) + (dolist (f (reverse user-pointer-fns)) (funcall call-with-restart f)) + (dolist (f (reverse lisp-startup-fns)) (funcall call-with-restart f)))) + (setf (interrupt-level) 0))) + nil) + + +(defun restore-pascal-functions () + (reset-callback-storage) + (when (simple-vector-p %pascal-functions%) + (dotimes (i (length %pascal-functions%)) + (let ((pfe (%svref %pascal-functions% i))) + (when (vectorp pfe) + (let* ((name (pfe.sym pfe)) + (descriptor (pfe.routine-descriptor pfe))) + (%revive-macptr descriptor) + (%setf-macptr descriptor (make-callback-trampoline i (pfe.proc-info pfe))) + (when name + (set name descriptor)))))))) + Index: /branches/new-random/lib/edit-callers.lisp =================================================================== --- /branches/new-random/lib/edit-callers.lisp (revision 13309) +++ /branches/new-random/lib/edit-callers.lisp (revision 13309) @@ -0,0 +1,243 @@ +; -*- Mode:Lisp; Package:CCL; -*- +;;; +;;; Copyright (C) 2009 Clozure Associates +;;; Copyright (C) 1994-2001 Digitool, Inc +;;; This file is part of Clozure CL. +;;; +;;; Clozure CL is licensed under the terms of the Lisp Lesser GNU Public +;;; License , known as the LLGPL and distributed with Clozure CL as the +;;; file "LICENSE". The LLGPL consists of a preamble and the LGPL, +;;; which is distributed with Clozure CL as the file "LGPL". Where these +;;; conflict, the preamble takes precedence. +;;; +;;; Clozure CL is referenced in the preamble as the "LIBRARY." +;;; +;;; The LLGPL is also available online at +;;; http://opensource.franz.com/preamble.html + +; edit-callers.lisp + +(in-package "CCL") + +(defun global-function-p (random &optional name) + (let* ((thing random) + (name (or name (ignore-errors (function-name thing))))) + (and name + (or (not (or (symbolp name) (setf-function-name-p name))) ; maybe its (setf baz) + (let ((fn (fboundp name))) + (and fn + (progn + ; maybe this is enough for both cases? + (or (eq thing fn) + (and (symbolp name)(eq thing (macro-function name)))))))) + name))) + +(defvar *function-parent-table* nil) +(defvar *function-parent-pool* (%cons-pool)) + +(defun copying-gc-p () ; if nz copying gc is on + nil) + +(defun lfun-closure-p (lfun) + (logbitp $lfbits-trampoline-bit (lfun-bits lfun))) + +; make a macro ? +(defun puthash-parent (im fun) + (when (functionp im) ; was (or (functionp im)(eq imtype $sym.fapply)) + (if (global-function-p fun) + (setf (gethash im *function-parent-table*) fun) + (let ((ht (gethash im *function-parent-table*))) + (if (not ht) + (setf (gethash im *function-parent-table*) fun) + (unless (eq ht fun) + (if (consp ht) + (when (not (memq fun ht))(nconc ht (list fun))) + (if (not (global-function-p ht)) + (setf (gethash im *function-parent-table*) (list ht fun)))))))))) + + +(defun callers (function &aux cfun callers gccount retry) + ;(declare (special cfun function callers)) + (declare (optimize (speed 3)(safety 0))) + + (let ((*function-parent-table* nil)) + (if (setf-function-name-p function) + (let ((nm (cadr function))) + (setq function (or (%setf-method nm) + (and (symbolp nm) + (setq nm (setf-function-name nm)) + (fboundp nm) + nm) + function)))) + (if (and (symbolp function) (fboundp function)) + (setq cfun (symbol-function function))) + (when (copying-gc-p) (setq gccount (full-gccount))) + (flet ((do-it (fun) + (when (and gccount (neq gccount (full-gccount))) + (throw 'losing :lost)) + (when (possible-caller-function-p fun) + (let* ((nm (ignore-errors (lfun-name fun))) + (globalp (if nm (global-function-p fun nm)))) + (flet ((do-imm (im) + (when (and (or (eq function im) + (and cfun (eq cfun im))) + (neq im nm)) + (push fun callers)) + (when (functionp im) ; was (or (functionp im)(eq imtype $sym.fapply)) + (if globalp + (setf (gethash im *function-parent-table*) fun) + (let ((ht (gethash im *function-parent-table*))) + (if (not ht) + (setf (gethash im *function-parent-table*) fun) + (unless (eq ht fun) + (if (consp ht) + (when (not (memq fun ht))(nconc ht (list fun))) + (if (not (global-function-p ht)) + (setf (gethash im *function-parent-table*) + (list ht fun))))))))))) + (declare (dynamic-extent #'do-imm)) + (%map-lfimms fun #'do-imm )))))) + (declare (dynamic-extent #'do-it)) + (unwind-protect + (progn + (let* ((pool *function-parent-pool*) + (tbl (pool.data pool))) + (setf (pool.data pool) nil + *function-parent-table* + (if tbl + (clrhash tbl) + (make-hash-table :size 700 :test 'eq :weak :value)))) + (loop + (cond ((eq :lost (catch 'losing + (%map-lfuns #'do-it))) + (when retry (error "Callers is losing")) + (setq callers nil) + (setq retry t)) + (t (return)))) + (delete-if #'(lambda (thing) + (or (functionp thing) + (and (typep thing 'method) + (let ((gf (fboundp (method-name thing)))) + (not (and (typep gf 'standard-generic-function) + (memq thing (%gf-methods gf)))))))) + (delete-duplicates (mapcar 'top-level-caller callers)))) + (setf (pool.data *function-parent-pool*) *function-parent-table* + *function-parent-table* nil))))) + + +(defun top-level-caller (function &optional the-list) + (or (global-function-p function) + (pascal-function-p function) + (let ((name (function-name function))) + (and name (function-encapsulated-p name) name)) + (let ((caller function) next) + (loop + (setq next (gethash caller *function-parent-table*)) + (if next + (cond ((consp next) + (when (null the-list)(push function the-list)) + (return + (dolist (c next) + (when (not (memq c the-list)) + (let ((res (top-level-caller c the-list))) + (when (and res (not (functionp res))) + (return res))))))) + (t (let ((res (global-function-p next))) + (when res (return res))) + (when (null the-list)(push function the-list)) + (when (memq next the-list) (return)) + (push next the-list) + (setq caller next))) + (return caller)))) + function)) + +(defun possible-caller-function-p (fun) + (let ((bits (lfun-bits fun))) + (declare (fixnum bits)) + (not (or (and (logbitp $lfbits-cm-bit bits) + (not (logbitp $lfbits-method-bit bits))) ; combined method + (and (logbitp $lfbits-trampoline-bit bits) + (lfun-closure-p fun) + (not (global-function-p fun))))))) ; closure (interp or compiled) + + +(defun caller-functions (function &aux cfun callers gccount retry) + "Returns a list of all functions (actual function objects, not names) that reference FUNCTION" + (declare (optimize (speed 3)(safety 0)(debug 0))) + (when (setf-function-name-p function) + (let ((nm (cadr function))) + (setq function (or (%setf-method nm) + (and (setq nm (setf-function-name nm)) + (fboundp nm) + nm) + function)))) + (when (valid-function-name-p function) + (setq cfun (or (and (symbolp function) (macro-function function)) + (fboundp function)))) + (when (copying-gc-p) (setq gccount (full-gccount))) + (flet ((do-it (fun) + (when (and gccount (neq gccount (full-gccount))) + (throw 'losing :lost)) + (when (possible-caller-function-p fun) + (let* ((lfv (function-to-function-vector fun)) + (end (%i- (uvsize lfv) 1)) + (bits (%svref lfv end))) + ;; Don't count the function name slot as a reference. + (unless (logbitp $lfbits-noname-bit bits) + (decf end)) + ;; Don't count lfun-info either + (when (logbitp $lfbits-info-bit bits) + (decf end)) + (loop for i from #+ppc-target 1 #+x86-target (%function-code-words fun) below end + as im = (%svref lfv i) + when (or (eq function im) + (and cfun (eq cfun im))) + do (return (pushnew (if (%method-function-p fun) + (%method-function-method fun) + fun) + callers))))))) + (declare (dynamic-extent #'do-it)) + (loop while (eq :lost (catch 'losing + (%map-lfuns #'do-it))) + do (when retry (cerror "Try again" "Callers is losing")) + do (setq callers nil) + do (setq retry t)) + callers)) + +; in 3.x the function in pascal-functions calls the actual function +(defun pascal-function-p (function) + (if (find function %pascal-functions% + :test #'eq + :key #'(lambda (elt) + (if (consp elt) + (let ((one (cdr elt))) + (when (and (eq (function-name one)(function-name function)) + (block blob + (%map-lfimms one #'(lambda (imm) + (when (eq imm function) + (return-from blob function)))))) + function)) + (if elt (aref elt 2))))) + (function-name function))) + + +;;; Calls function f with args (imm) on each immediate in lfv. + +(defun %map-lfimms (function-object f) + (let* ((lfv (function-to-function-vector function-object)) + (n (- (uvsize lfv) 2))) + (declare (fixnum n)) + #+ppc-target + (dotimes (i n) + (funcall f (%svref lfv (%i+ 1 i)))) + #+x86-target + (do* ((i (1- (the fixnum (%function-code-words function-object))) (1+ i))) + ((= i n)) + (declare (fixnum i)) + (funcall f (%svref lfv (%i+ 1 i)))) + )) + + + + +(provide :edit-callers) Index: /branches/new-random/lib/encapsulate.lisp =================================================================== --- /branches/new-random/lib/encapsulate.lisp (revision 13309) +++ /branches/new-random/lib/encapsulate.lisp (revision 13309) @@ -0,0 +1,891 @@ +;;;-*-Mode: LISP; Package: CCL -*- +;;; +;;; Copyright (C) 2009 Clozure Associates +;;; Copyright (C) 1994-2001 Digitool, Inc +;;; This file is part of Clozure CL. +;;; +;;; Clozure CL is licensed under the terms of the Lisp Lesser GNU Public +;;; License , known as the LLGPL and distributed with Clozure CL as the +;;; file "LICENSE". The LLGPL consists of a preamble and the LGPL, +;;; which is distributed with Clozure CL as the file "LGPL". Where these +;;; conflict, the preamble takes precedence. +;;; +;;; Clozure CL is referenced in the preamble as the "LIBRARY." +;;; +;;; The LLGPL is also available online at +;;; http://opensource.franz.com/preamble.html + +(in-package "CCL") + +(defvar *loading-removes-encapsulation* nil + "If true, loading a new method definition from a file will remove any tracing and advice on the method") + +(defvar *trace-pfun-list* nil) +(defvar *trace-enable* t) +(defvar *trace-level* 0) +(defparameter *trace-max-indent* 40) +(defvar *trace-print-level* nil) +(defvar *trace-print-length* nil) +;(defparameter *trace-define-if-undefined* nil) +(defparameter *trace-bar-frequency* nil) +(defvar *trace-hook* nil) +(defvar *untrace-hook* nil) +(defvar *trace-print-hook* nil) + +;;; +;;; We support encapsulating three types of objects, i.e. modifying their definition +;;; without changing their identity: +;;; 1. symbol - via the symbol-function slot +;;; 2. method - via the %method-function slot +;;; 3. standard-generic-function - via the %gf-dcode slot +;;; +;;; Encapsulation is effected by creating a new compiled function and storing it in the +;;; slot above. The new function references a gensym fbound to the original definition +;;; (except in the case of a gf, the gensym is fbound to a copy of the gf which in +;;; turn contains the original dcode, since we can't invoke the dcode directly). +;;; In addition, an ENCAPSULATION struct describing the encapsulation is created and +;;; stored in the *encapsulation-table* with the new compiled function as the key. +;;; +;;; + +(defparameter *encapsulation-table* + (make-hash-table :test #'eq :rehash-size 2 :size 2 :weak t)) + +(defstruct (encapsulation) + symbol ; the uninterned name containing original def + type ; trace or advise + spec ; the original function spec + advice-name ; optional + advice-when ; :before, :after, :around + owner ; where encapsulation is installed (can change) +) + +(defun encapsulation-old-def (cap) + (fboundp (encapsulation-symbol cap))) + +(defun setf-function-spec-name (spec) + (if (setf-function-name-p spec) + (let ((name (%setf-method (cadr spec)))) + (if (non-nil-symbol-p name) ; this can be an anonymous function + name + (setf-function-name (cadr spec)))) + spec)) + +(defun trace-tab (direction &aux (n (min *trace-level* *trace-max-indent*))) + (fresh-line *trace-output*) + (dotimes (i (1- n)) + (declare (fixnum i)) + (write-char (if (and *trace-bar-frequency* + (eq 0 (mod i *trace-bar-frequency*))) + #\| #\Space) *trace-output*)) + (if (eq direction :in) + (format *trace-output* "~d> " (1- *trace-level*)) + (format *trace-output* "<~d " (1- *trace-level*)))) + +(defun trace-before (&rest args) + (declare (dynamic-extent args)) + (trace-tab :in) + (let* ((*print-level* *trace-print-level*) + (*print-length* *trace-print-length*) + (*print-readably* nil)) + (format *trace-output* "Calling ~S ~%" args) + (force-output *trace-output*))) + +(defun trace-after (sym &rest args &aux (n (length args))) + (declare (dynamic-extent args)) + (let* ((*print-level* *trace-print-level*) + (*print-length* *trace-print-length*) + (*print-readably* nil)) + (if (eq n 1) + (progn + (trace-tab :out) + (format *trace-output* "~S returned ~S~%" sym (%car args))) + (progn + (trace-tab :out) + (format *trace-output* "~S returned ~S values :" sym n) + (dolist (val args) + (trace-tab :out) + (format *trace-output* " ~S" val)))) + (force-output *trace-output*))) + +(defun forget-encapsulations (name) + (when (%traced-p name) + (format t "~%... Untracing ~a" name) + (%untrace-1 name)) + (when (%advised-p name) + (format t "~%... Unadvising ~a" name) + (%unadvise-1 name)) + nil) + +(defun function-encapsulated-p (fn-or-method) + (get-encapsulation fn-or-method)) + +(defun %encap-fboundp (thing) + (etypecase thing + (symbol (fboundp thing)) + (method (%method-function thing)))) + +(defun %encap-binding (thing) + (require-type (etypecase thing + (symbol (fboundp thing)) + (method (%method-function thing))) + 'function)) + +(defun get-encapsulation (spec) + (let* ((key (typecase spec + (symbol (let* ((def (fboundp spec))) + (if (generic-function-p def) + (%gf-dcode def) + def))) + (method (%method-function spec)) + (standard-generic-function (%gf-dcode spec)) + (function spec))) + (cap (gethash key *encapsulation-table*))) + #+gz (assert (or (null cap) + (let ((fn (%encap-binding (encapsulation-owner cap)))) + (eq (if (standard-generic-function-p fn) (%gf-dcode fn) fn) key)))) + cap)) + +(defun set-encapsulation-owner (fn owner) + (let ((cap (get-encapsulation fn))) + (when cap + (setf (encapsulation-owner cap) owner)))) + +(defun put-encapsulation (fn cap) + (let* ((owner (encapsulation-owner cap)) + (old-def (%encap-binding owner)) + (newsym (encapsulation-symbol cap))) + (setf (gethash fn *encapsulation-table*) cap) + (set-encapsulation-owner old-def newsym) + (etypecase owner + (symbol + (cond ((standard-generic-function-p old-def) + (%fhave newsym (%copy-function old-def)) + (setf (%gf-dcode old-def) fn)) + (t + (%fhave newsym old-def) + (%fhave owner fn)))) + (method + (%fhave newsym old-def) + (setf (%method-function owner) fn) + (remove-obsoleted-combined-methods owner))))) + +(defun remove-encapsulation (cap) + (let* ((owner (encapsulation-owner cap)) + (cur-def (%encap-fboundp owner)) + (old-def (encapsulation-old-def cap))) + (typecase owner + (symbol + (cond ((or (null cur-def) + (not (eq cap (get-encapsulation cur-def)))) + ;; rebound behind our back, oh well. + nil) + ((standard-generic-function-p cur-def) + (remhash (%gf-dcode cur-def) *encapsulation-table*) + (set-encapsulation-owner old-def owner) + (setf (%gf-dcode cur-def) (%gf-dcode old-def))) + (t + (remhash cur-def *encapsulation-table*) + (set-encapsulation-owner old-def owner) + (%fhave owner old-def)))) + (method + (remhash cur-def *encapsulation-table*) + (set-encapsulation-owner old-def owner) + (setf (%method-function owner) old-def) + (remove-obsoleted-combined-methods owner))))) + + +(defun encapsulate (owner newdef type trace-spec newsym &optional advice-name advice-when) + (let ((cap (make-encapsulation + :owner owner + :symbol newsym + :type type + :spec trace-spec + :advice-name advice-name + :advice-when advice-when))) + (put-encapsulation newdef cap) + cap)) + +(defun find-unencapsulated-definition (fn) + (when fn + (loop for cap = (get-encapsulation fn) while cap + do (setq fn (encapsulation-old-def cap))) + fn)) + +(defun set-unencapsulated-definition (cap newdef) + (loop for owner = (encapsulation-symbol cap) + do (setq cap (get-encapsulation owner)) while cap + finally (%fhave owner newdef))) + +(defun %encapsulation-thing (spec &optional define-if-not (error-p t)) + ;; Returns either an fboundp symbol or a method, or nil. + (typecase spec + (symbol + ;; weed out macros and special-forms + (if (or (null spec) (special-operator-p spec) (macro-function spec)) + (if error-p + (error "Cannot trace or advise ~a~S" + (cond ((null spec) "") + ((special-operator-p spec) "special operator ") + (t "macro ")) + spec) + nil) + (if (or (fboundp spec) + (and define-if-not + (progn + (warn "~S was undefined" spec) + (%fhave spec (%function 'trace-null-def)) + t))) + spec + (if error-p + (error "~S is undefined." spec) + nil)))) + (method spec) + (cons + (case (car spec) + (:method + (let ((gf (cadr spec)) + (qualifiers (butlast (cddr spec))) + (specializers (car (last (cddr spec)))) + method) + (setq specializers (require-type specializers 'list)) + (prog () + AGN + (cond ((setq method + (find-method-by-names gf qualifiers specializers)) + (return method)) + (define-if-not + (when (define-undefined-method spec gf qualifiers specializers) + (go AGN))) + (t (if error-p + (error "Method ~s qualifiers ~s specializers ~s not found." + gf qualifiers specializers) + (return nil))))))) + (setf + (let ((name-or-fn (setf-function-spec-name spec))) + (cond ((symbolp name-or-fn) (%encapsulation-thing name-or-fn)) + ((functionp name-or-fn) ; it's anonymous - give it a name + (let ((newname (gensym))) + (%fhave newname name-or-fn) + (store-setf-method (cadr spec) newname) + newname))))))) + (t (if error-p + (error "Invalid trace spec ~s" spec) + nil)))) + +(defun trace-null-def (&rest ignore) + (declare (ignore ignore))) + +(defun define-undefined-method (spec gf qualifiers specializers) + (let (vars def) + (flet ((blob (e) + (let ((v (gensym))) + (push v vars) + (list v e)))) + (declare (dynamic-extent #'blob)) + (setq def + (let ((lambda-list (mapcar #' blob specializers))) + (eval + `(defmethod ,gf ,@qualifiers (,@lambda-list &rest ignore) + (declare (ignore ignore ,@vars)))))) + (when def (warn "~S was undefined" spec)) + def))) + +(defun traceable-symbol-p (sym) + (and sym + (not (special-operator-p sym)) + (not (macro-function sym)) + (fboundp sym))) + +(defun %trace-package (pkg &rest args) + (declare (dynamic-extent args)) + (do-present-symbols (sym pkg) + ;; Don't auto-trace imported symbols, because too often these are imported + ;; system functions... + (when (eq (symbol-package sym) pkg) + (when (traceable-symbol-p sym) + (apply #'trace-function sym args)) + (when (or (%setf-method sym) + ;; Not really right. Should construct the name if doesn't exist. + ;; But that would create a lot of garbage for little gain... + (let ((name (existing-setf-function-name sym))) + (traceable-symbol-p name))) + (apply #'trace-function `(setf ,sym) args))))) + +(defun trace-print-body (print-form) + (when print-form + (if (and (consp print-form) (eq (car print-form) 'values)) + `((mapcar #'(lambda (name object) + (trace-tab :in) + (format *trace-output* "~s = ~s" name object)) + ',(cdr print-form) + (list ,@(cdr print-form)))) + `((let ((objects (multiple-value-list ,print-form)) + (i -1)) + (if (and objects (not (cdr objects))) + (progn + (trace-tab :in) + (format *trace-output* "~s = ~s" ',print-form (car objects))) + (dolist (object objects) + (trace-tab :in) + (format *trace-output* "~s [~d] = ~s" ',print-form (incf i) object)))))))) + +(defun trace-backtrace-body (test-form) + (when test-form + `((let ((test ,test-form)) + (when test + (multiple-value-bind (detailed-p count) + (cond ((memq test '(:detailed :verbose :full)) + (values t nil)) + ((integerp test) + (values nil test)) + ((and (consp test) + (keywordp (car test)) + (consp (cdr test)) + (null (cddr test))) + (values (memq (car test) '(:detailed :verbose :full)) + (and (integerp (cadr test)) (cadr test)))) + (t (values nil nil))) + (let ((*debug-io* *trace-output*)) + (print-call-history :detailed-p detailed-p + :count (or count most-positive-fixnum)) + (terpri *trace-output*)))))))) + +(defun trace-inside-frame-p (name) + (if (packagep name) + (map-call-frames #'(lambda (p) + (let* ((fn (cfp-lfun p)) + (fname (and fn (function-name fn))) + (sym (typecase fname + (method (method-name fname)) + (cons (and (setf-function-name-p fname) (cadr fname))) + (symbol fname) + (t nil)))) + (when (and sym (eq (symbol-package sym) name)) + (return-from trace-inside-frame-p t))))) + (let ((fn (%encap-binding name))) + (when fn + (map-call-frames #'(lambda (p) + (when (eq (cfp-lfun p) fn) + (return-from trace-inside-frame-p t)))))))) + +(defun trace-package-spec (spec) + (when (or (stringp spec) + (packagep spec) + (and (consp spec) (eq (car spec) :package))) + (let ((pkg (if (consp spec) + (destructuring-bind (pkg) (cdr spec) pkg) + spec))) + (pkg-arg pkg)))) + +(defun trace-function (spec &rest args &key before after methods + (if t) (before-if t) (after-if t) + print print-before print-after + eval eval-before eval-after + break break-before break-after + backtrace backtrace-before backtrace-after + inside + define-if-not + ;; Some synonyms, just to be nice + (condition t) (if-before t) (if-after t) (wherein nil)) + + (declare (dynamic-extent args)) + (let ((pkg (trace-package-spec spec))) + (when pkg + (return-from trace-function (apply #'%trace-package pkg args)))) + + ;; A little bit of dwim, after all this _is_ an interactive tool... + (unless (eq condition t) + (setq if (if (eq if t) condition `(and ,if ,condition)))) + (unless (eq if-before t) + (setq before-if (if (eq before-if t) if-before `(and ,before-if ,if-before)))) + (unless (eq if-after t) + (setq after-if (if (eq after-if t) if-after `(and ,after-if ,if-after)))) + (when (and inside (trace-spec-p inside)) + (setq inside (list inside))) + (when wherein + (setq inside (append inside (if (trace-spec-p wherein) (list wherein) wherein)))) + (case break + (:before (setq break-before (or break-before t) break nil)) + (:after (setq break-after (or break-after t) break nil))) + (case backtrace + (:before (setq backtrace-before (or backtrace-before t) backtrace nil)) + (:after (setq backtrace-after (or backtrace-after t) backtrace nil))) + (case before + (:break (setq before :print break-before t)) + (:backtrace (setq before :print backtrace-before t))) + (case after + (:break (setq after :print break-after t)) + (:backtrace (setq after :print backtrace-after t))) + + (when break + (setq break-before (if break-before + `(and ,break ,break-before) + break)) + (setq break-after (if break-after + `(and ,break ,break-after) + break))) + (unless backtrace-before + (setq backtrace-before backtrace)) + (when (and (consp backtrace-before) (keywordp (car backtrace-before))) + (setq backtrace-before `',backtrace-before)) + (when (and (consp backtrace-after) (keywordp (car backtrace-after))) + (setq backtrace-after `',backtrace-after)) + + (when (and (null before) (null after)) + (setq before :print) + (setq after :print)) + (when (and (null before) backtrace-before) + (setq before :print)) + + (case before + ((:print :default) (setq before #'trace-before))) + (case after + ((:print :default) (setq after #'trace-after))) + + (when (or (non-nil-symbol-p before) (functionp before)) + (setq before `',before)) + (when (or (non-nil-symbol-p after) (functionp after)) + (setq after `',after)) + + (when inside + (let ((tests (loop for spec in inside + as name = (or (trace-package-spec spec) + (%encapsulation-thing spec nil nil) + (error "Cannot trace inside ~s" spec)) + collect `(trace-inside-frame-p ',name)))) + (setq if `(and ,if (or ,@tests))))) + + (setq eval-before `(,@(trace-print-body print-before) + ,@(trace-print-body print) + ,@(and eval-before `(,eval-before)) + ,@(and eval `(,eval)) + ,@(and before `((apply ,before ',spec args))) + ,@(trace-backtrace-body backtrace-before) + ,@(and break-before `((when ,break-before + (force-output *trace-output*) + (break "~s trace entry: ~s" ',spec args)))))) + (setq eval-after `(,@(trace-backtrace-body backtrace-after) + ,@(and after `((apply ,after ',spec vals))) + ,@(and eval `(,eval)) + ,@(and eval-after `(,eval-after)) + ,@(trace-print-body print) + ,@(trace-print-body print-after) + ,@(and break-after `((when ,break-after + (force-output *trace-output*) + (break "~s trace exit: ~s" ',spec vals)))))) + + (prog1 + (block %trace-block + ;; + ;; see if we're a callback + ;; + (when (and (typep spec 'symbol) + (boundp spec) + (macptrp (symbol-value spec))) + (let ((len (length %pascal-functions%)) + (sym-name (symbol-name spec))) + (declare (fixnum len)) + (dotimes (i len) + (let ((pfe (%svref %pascal-functions% i))) + (when (and (vectorp pfe) + (string= sym-name (symbol-name (pfe.sym pfe)))) + (when backtrace + (if (null before) + (setq before :print))) + (setf (pfe.trace-p pfe) + `(,@(if before `((:before . ,before))) + ,@(if after `((:after . ,after))) + ,@(if backtrace `((:backtrace . ,backtrace))))) + (push spec *trace-pfun-list*))))) + (return-from %trace-block)) + ;; + ;; now look for traceable methods. + ;; It's possible, but not likely, that we will be both + ;; a callback and a function or method, if so we trace both. + ;; This isn't possible. + ;; If we're neither, signal an error. + ;; + (let* ((trace-thing (%encapsulation-thing spec define-if-not)) def) + (%untrace-1 trace-thing) + (setq def (%encap-binding trace-thing)) + (when (and methods (typep def 'standard-generic-function)) + (dolist (m (%gf-methods def)) + (apply #'trace-function m args))) + #+old + (when step ; just check if has interpreted def + (if (typep def 'standard-generic-function) + (let ((methods (%gf-methods def))) + ; should we complain if no methods? naah + (dolist (m methods) ; stick :step-gf in advice-when slot + (%trace m :step t) + (let ((e (function-encapsulation m))) + (when e (setf (encapsulation-advice-when e) :step-gf)))) + ; we choose to believe that before and after are intended for the gf + (if (or before after) + (setq step nil) + (return-from %trace-block))) + #|(uncompile-for-stepping trace-thing nil t)|#)) + (let* ((newsym (gensym "TRACE")) + (method-p (typep trace-thing 'method)) + (newdef (trace-global-def + spec newsym if before-if eval-before after-if eval-after method-p))) + (when method-p + (copy-method-function-bits def newdef)) + (encapsulate trace-thing newdef 'trace spec newsym)))) + (when *trace-hook* + (apply *trace-hook* spec args)))) + + +(defun %traced-p (thing) + (let ((cap (get-encapsulation thing))) + (and cap (eq (encapsulation-type cap) 'trace)))) + +(defmacro untrace (&rest syms) + "Remove tracing from the specified functions. With no args, untrace all + functions." + (if syms + `(%untrace-0 ',syms) + `(%untrace-all))) + +(defun %untrace-0 (syms) + (let (val x) + (dolist (symbol syms) + (setq x (%untrace symbol)) + (when x (push x val))) + val)) + +(defun %untrace-all () + (dolist (pfun *trace-pfun-list*) + (%untrace pfun) + (when *untrace-hook* + (funcall *untrace-hook* pfun))) + (loop for cap being the hash-value of *encapsulation-table* + when (eq (encapsulation-type cap) 'trace) + collect (let ((spec (encapsulation-spec cap))) + (remove-encapsulation cap) + (when *untrace-hook* + (funcall *untrace-hook* spec)) + spec))) + +(defun %untrace (sym &aux val) + (when (and (consp sym)(consp (car sym))) + (setq sym (car sym))) + (cond + ((and (typep sym 'symbol) + (boundp sym) + (macptrp (symbol-value sym))) + (%untrace-pfun sym)) + (t + (let* ((trace-thing (%encapsulation-thing sym)) + (def (%encap-binding trace-thing))) + (when (typep def 'standard-generic-function) + (let ((methods (%gf-methods def))) + (dolist (m methods) + (let ((cap (get-encapsulation m))) + (when (and cap (eq (encapsulation-advice-when cap) :step-gf)) + (remove-encapsulation cap) + (push m val)))))) + ; gf could have first been traced :step, and then just plain traced + ; maybe the latter trace should undo the stepping?? + (let ((spec (%untrace-1 trace-thing))) + (when spec + (push spec val)))))) + (when *untrace-hook* + (funcall *untrace-hook* sym)) + (if (null (cdr val)) (car val) val)) + +;; thing is a symbol or method - def is current definition +;; we already know its traced +(defun %untrace-1 (thing) + (let ((cap (get-encapsulation thing))) + (when (and cap (eq (encapsulation-type cap) 'trace)) + (remove-encapsulation cap) + (encapsulation-spec cap)))) + +(defun %untrace-pfun (sym) + (let ((len (length %pascal-functions%)) + (sym-name (symbol-name sym))) + (declare (fixnum len)) + (dotimes (i len) + (let ((pfe (%svref %pascal-functions% i))) + (when (and (vectorp pfe) + (string= sym-name (symbol-name (pfe.sym pfe)))) + (setf (pfe.trace-p pfe) nil + *trace-pfun-list* (remove sym *trace-pfun-list*)) + (return-from %untrace-pfun sym)))) + nil)) + + + +(defmacro trace (&rest syms) + "TRACE {Option Global-Value}* { Name | (Name {Option Value}*) }* + +TRACE is a debugging tool that provides information when specified +functions are called." + (if syms + (let ((options (loop while (keywordp (car syms)) + nconc (list (pop syms) (pop syms))))) + `(%trace-0 ',syms ',options)) + `(%trace-list))) + +(defun trace-spec-p (arg) + (or (atom arg) + (memq (car arg) '(:method setf :package)))) + + +(defun %trace-0 (syms &optional global-options) + (dolist (spec syms) + (if (trace-spec-p spec) + (apply #'trace-function spec global-options) + (apply #'trace-function (append spec global-options))))) + +(defun %trace-list () + (let (res) + (loop for x being the hash-value of *encapsulation-table* + when (eq (encapsulation-type x) 'trace) + do (push (encapsulation-spec x) res)) + (dolist (x *trace-pfun-list*) + (push x res)) + res)) + +(defmacro with-traces (syms &body body) + `(unwind-protect + (progn + (let ((*trace-output* (make-broadcast-stream))) + ;; if you're tracing ccl internals you'll get trace output as it encapsulates the + ;; functions so hide all the trace output while eval'ing the trace form itself. + (trace ,@syms)) + ,@body) + (untrace ,@syms))) + +;; this week def is the name of an uninterned gensym whose fn-cell is original def + +(defun trace-global-def (sym def if before-if eval-before after-if eval-after &optional method-p) + (let ((saved-method-var (gensym)) + (enable (gensym)) + do-it) + (setq do-it + (cond #+old (step + (setq step-it + `(step-apply-simple ',def args)) + (if (eq step t) + step-it + `(if (apply ',step ',sym args) ; gaak + ,step-it + ,(if (and before method-p) + `(apply-with-method-context ,saved-method-var (symbol-function ',def) args) + `(apply ',def args))))) + (t (if (and eval-before method-p) + `(apply-with-method-context ,saved-method-var (symbol-function ',def) args) + `(apply ',def args))))) + (compile-named-function-warn + `(lambda (,@(and eval-before method-p `(&method ,saved-method-var)) + &rest args) ; if methodp put &method on front of args - vs get-saved-method-var? + (declare (dynamic-extent args)) + (declare (ftype function ,def)) + (let ((*trace-level* (1+ *trace-level*)) + (,enable ,if)) + (declare (special *trace-enable* *trace-level*)) + ,(when eval-before + `(when (and ,enable ,before-if *trace-enable*) + (when *trace-print-hook* + (funcall *trace-print-hook* ',sym t)) + (let* ((*trace-enable* nil)) + ,@eval-before) + (when *trace-print-hook* + (funcall *trace-print-hook* ',sym nil)))) + ,(if eval-after + `(let ((vals (multiple-value-list ,do-it))) + (when (and ,enable ,after-if *trace-enable*) + (when *trace-print-hook* + (funcall *trace-print-hook* ',sym t)) + (let* ((*trace-enable* nil)) + ,@eval-after) + (when *trace-print-hook* + (funcall *trace-print-hook* ',sym nil))) + (values-list vals)) + do-it))) + `(traced ,sym) + :keep-symbols t))) + +; &method var tells compiler to bind var to contents of next-method-context +(defun advise-global-def (def when stuff &optional method-p dynamic-extent-arglist) + (let* ((saved-method-var (gensym))) + `(lambda (,@(if (and method-p (neq when :after)) + `(&method ,saved-method-var)) + &rest arglist) + ,@(and dynamic-extent-arglist '((declare (dynamic-extent arglist)))) + (declare (ftype function ,def)) + (let () + ,(ecase + when + (:before + `(block nil + ,stuff + (return ,(if method-p + `(apply-with-method-context ,saved-method-var (symbol-function ',def) arglist) + `(apply ',def arglist))))) + (:after + `(block nil + (let ((values (multiple-value-list (apply (function ,def) arglist)))) + ;(declare (dynamic-extent values)) + ,stuff + (return (values-list values))))) + (:around + ;; stuff is e.g. (+ 5 (:do-it)) + (if method-p + `(macrolet ((:do-it () + `(apply-with-method-context ,',saved-method-var + (symbol-function ',',def) + arglist))) + (block nil + (return ,stuff))) + `(macrolet ((:do-it () + `(apply (function ,',def) arglist))) + (block nil + (return ,stuff)))))))))) + + +(defun compile-named-function-warn (fn name &rest keys) + (declare (dynamic-extent keys)) + (multiple-value-bind (result warnings) (apply #'compile-named-function fn :name name keys) + (when warnings + (let ((first t)) + (dolist (w warnings) + (signal-compiler-warning w first nil nil nil) + (setq first nil)))) + result)) + + +(defun %advised-p (thing) + (loop for nx = thing then (encapsulation-symbol cap) + as cap = (get-encapsulation nx) while cap + thereis (eq (encapsulation-type cap) 'advice))) + +(defun %advice-encapsulations (thing when advice-name) + (loop for nx = thing then (encapsulation-symbol cap) + as cap = (get-encapsulation nx) while cap + when (and (eq (encapsulation-type cap) 'advice) + (or (null when) (eq when (encapsulation-advice-when cap))) + (or (null advice-name) (equal advice-name (encapsulation-advice-name cap)))) + collect cap)) + +(defun advise-2 (newdef newsym method-p function-spec when advice-name define-if-not) + (let* ((advise-thing (%encapsulation-thing function-spec define-if-not)) + orig-sym) + (let ((capsules (%advice-encapsulations advise-thing when advice-name))) + (when capsules + (unadvise-capsules capsules))) + (when (%traced-p advise-thing) + ; make traced call advised + (setq orig-sym + (encapsulation-symbol (get-encapsulation advise-thing)))) + (lfun-name newdef `(advised ',function-spec)) + (if method-p (copy-method-function-bits (%encap-binding advise-thing) newdef)) + (encapsulate (or orig-sym advise-thing) newdef 'advice function-spec newsym advice-name when) + newdef)) + +(defmacro advise (function form &key (when :before) name define-if-not dynamic-extent-arglist) + (let* ((newsym (gensym "ADVICE")) + ; WAS typep advise-thing 'method + (method-p (or (typep function 'method) ; can this happen? + (and (consp function)(eq (car function) :method)))) + (newdef (advise-global-def newsym when form method-p dynamic-extent-arglist))) + `(advise-2 ,newdef ',newsym ,method-p ',function ',when ',name + ,define-if-not))) + +(defmacro advisedp (function-spec &key when name) + `(advisedp-1 ',function-spec ',when ',name)) + +(defun encapsulation-advice-spec (cap) + (list (encapsulation-spec cap) + (encapsulation-advice-when cap) + (encapsulation-advice-name cap))) + +(defun advisedp-1 (function-spec when name) + (cond ((eq t function-spec) + (loop for c being the hash-value of *encapsulation-table* + when (and (eq (encapsulation-type c) 'advice) + (or (null when)(eq when (encapsulation-advice-when c))) + (or (null name)(equal name (encapsulation-advice-name c)))) + collect (encapsulation-advice-spec c))) + (t (let* ((advise-thing (%encapsulation-thing function-spec)) + (capsules (%advice-encapsulations advise-thing when name))) + (mapcar #'encapsulation-advice-spec capsules))))) + +(defun %unadvise-1 (function-spec &optional when advice-name ignore) + (declare (ignore ignore)) + (let ((advise-thing (%encapsulation-thing function-spec))) + (let ((capsules (%advice-encapsulations advise-thing when advice-name))) + (when capsules (unadvise-capsules capsules))))) + +(defun unadvise-capsules (capsules) + (let (val) + (dolist (capsule capsules) + (push (encapsulation-advice-spec capsule) val) + (remove-encapsulation capsule)) + val)) + +(defmacro unadvise (function &key when name) + (cond ((neq function t) + `(%unadvise-1 ',function ',when ',name)) + (t '(%unadvise-all)))) + +(defun %unadvise-all () + (loop for cap being the hash-value of *encapsulation-table* + when (eq (encapsulation-type cap) 'advice) + collect (progn + (remove-encapsulation cap) + (encapsulation-advice-spec cap)))) + +;; Called from %defun. Return t if we defined it, nil otherwise +(defun %defun-encapsulated-maybe (name newdef) + (assert (not (get-encapsulation newdef))) + (let ((old-def (fboundp name)) cap) + (when (and old-def (setq cap (get-encapsulation name))) + (cond ((or (and *loading-files* *loading-removes-encapsulation*) + ;; redefining a gf as a fn. + (typep old-def 'standard-generic-function)) + (forget-encapsulations name) + nil) + (t (set-unencapsulated-definition cap newdef) + T))))) + +;; Called from clos when change dcode +(defun %set-encapsulated-gf-dcode (gf new-dcode) + (loop with cap = (get-encapsulation gf) + for gf-copy = (encapsulation-old-def cap) + as cur-dcode = (%gf-dcode gf-copy) + do (setq cap (get-encapsulation cur-dcode)) + ;; refresh all the gf copies, in case other info in gf changed + do (%copy-function gf gf-copy) + do (setf (%gf-dcode gf-copy) (if cap cur-dcode new-dcode)) + while cap)) + +;; Called from clos when oldmethod is being replaced by newmethod in a gf. +(defun %move-method-encapsulations-maybe (oldmethod newmethod &aux cap) + (unless (eq oldmethod newmethod) + (cond ((and *loading-removes-encapsulation* *loading-files*) + (when (%traced-p oldmethod) + (warn "~%... Untracing ~s" (%untrace-1 oldmethod))) + (when (%advised-p oldmethod) + (format t "~%... Unadvising ~s" (%unadvise-1 oldmethod)))) + (t (when (setq cap (get-encapsulation oldmethod)) + (let* ((old-inner-def (find-unencapsulated-definition oldmethod)) + (newdef (%method-function newmethod)) + (olddef (%method-function oldmethod))) + ;; make last encapsulation call new definition + (set-unencapsulated-definition cap newdef) + (setf (%method-function newmethod) olddef) + (set-encapsulation-owner olddef newmethod) + (setf (%method-function oldmethod) old-inner-def) + (loop + for def = olddef then (encapsulation-old-def cap) + for cap = (get-encapsulation def) while cap + do (copy-method-function-bits newdef def)))))))) + +#| + Change History (most recent last): + 2 12/29/94 akh merge with d13 +|# ;(do not edit past this line!!) Index: /branches/new-random/lib/ffi-darwinppc32.lisp =================================================================== --- /branches/new-random/lib/ffi-darwinppc32.lisp (revision 13309) +++ /branches/new-random/lib/ffi-darwinppc32.lisp (revision 13309) @@ -0,0 +1,258 @@ +;;;-*- Mode: Lisp; Package: CCL -*- +;;; +;;; Copyright (C) 2007-2009 Clozure Associates and contributors +;;; This file is part of Clozure CL. +;;; +;;; Clozure CL is licensed under the terms of the Lisp Lesser GNU Public +;;; License , known as the LLGPL and distributed with Clozure CL as the +;;; file "LICENSE". The LLGPL consists of a preamble and the LGPL, +;;; which is distributed with Clozure CL as the file "LGPL". Where these +;;; conflict, the preamble takes precedence. +;;; +;;; Clozure CL is referenced in the preamble as the "LIBRARY." +;;; +;;; The LLGPL is also available online at +;;; http://opensource.franz.com/preamble.html + +(in-package "CCL") + +;;; If a record type has a single scalar field, return the type +;;; of that field. +(defun darwin32::record-type-has-single-scalar-field (record-type) + (when (eq (foreign-record-type-kind record-type) :struct) + (require-foreign-type-bits record-type) + (let* ((fields (foreign-record-type-fields record-type))) + (when (null (cdr fields)) + (let* ((f0 (car fields)) + (type (foreign-record-field-type f0))) + (typecase type + ((or foreign-record-type foreign-array-type) nil) + (otherwise type))))))) + +;;; If type denotes a foreign record type, return T if it would +;;; be "returned" by passing it as the first argument to the callee. +;;; On DarwinPPC32, this is true of all record types except for +;;; those for which RECORD-TYPE-HAS-SINGLE-SCALAR-FIELD returns +;;; true. +(defun darwin32::record-type-returns-structure-as-first-arg (rtype) + (when (and rtype + (not (typep rtype 'unsigned-byte)) + (not (member rtype *foreign-representation-type-keywords* + :test #'eq))) + (let* ((ftype (if (typep rtype 'foreign-type) + rtype + (parse-foreign-type rtype)))) + (and (typep ftype 'foreign-record-type) + (not (darwin32::record-type-has-single-scalar-field ftype)))))) + + +;;; Structures that contain a single scalar field are "returned" +;;; as a value with that field's type. +;;; Other structures are "returned" by passing a pointer to a structure +;;; of the appropriate type as the first argument. +;;; Structures that contain a single scalar field are passed by value +;;; by passing the value of that field as a scalar. +;;; Structures that contain more than one field are passed by value +;;; as a sequence of N 32-bit words; %ff-call understands an unsigned +;;; integer argument "type" specifier to denote this. + +(defun darwin32::expand-ff-call (callform args &key (arg-coerce #'null-coerce-foreign-arg) (result-coerce #'null-coerce-foreign-result)) + (let* ((result-type-spec (or (car (last args)) :void)) + (enclosing-form nil)) + (multiple-value-bind (result-type error) + (ignore-errors (parse-foreign-type result-type-spec)) + (if error + (setq result-type-spec :void result-type *void-foreign-type*) + (setq args (butlast args))) + (collect ((argforms)) + (when (eq (car args) :monitor-exception-ports) + (argforms (pop args))) + (when (typep result-type 'foreign-record-type) + (let* ((single-scalar (darwin32::record-type-has-single-scalar-field result-type)) + (result-form (pop args))) + (if single-scalar + (progn + (setq enclosing-form `(setf ,(%foreign-access-form result-form single-scalar 0 nil)) + result-type single-scalar + result-type-spec (foreign-type-to-representation-type result-type))) + + (progn + (argforms :address) + (argforms result-form) + (setq result-type *void-foreign-type* + result-type-spec :void))))) + (unless (evenp (length args)) + (error "~s should be an even-length list of alternating foreign types and values" args)) + (do* ((args args (cddr args))) + ((null args)) + (let* ((arg-type-spec (car args)) + (arg-value-form (cadr args))) + (if (or (member arg-type-spec *foreign-representation-type-keywords* + :test #'eq) + (typep arg-type-spec 'unsigned-byte)) + (progn + (argforms arg-type-spec) + (argforms arg-value-form)) + (let* ((ftype (parse-foreign-type arg-type-spec))) + (if (typep ftype 'foreign-record-type) + (let* ((single-scalar (darwin32::record-type-has-single-scalar-field ftype))) + (if single-scalar + (progn + (argforms (foreign-type-to-representation-type single-scalar)) + (argforms (%foreign-access-form arg-value-form single-scalar 0 nil))) + (let* ((bits (ensure-foreign-type-bits ftype))) + (argforms (ceiling bits 32)) + (argforms arg-value-form)))) + (progn + (argforms (foreign-type-to-representation-type ftype)) + (argforms (funcall arg-coerce arg-type-spec arg-value-form)))))))) + (argforms (foreign-type-to-representation-type result-type)) + (let* ((call (funcall result-coerce result-type-spec `(,@callform ,@(argforms))))) + (if enclosing-form + `(,@enclosing-form ,call) + call)))))) + + + +;;; Return 7 values: +;;; A list of RLET bindings +;;; A list of LET* bindings +;;; A list of DYNAMIC-EXTENT declarations for the LET* bindings +;;; A list of initializaton forms for (some) structure args +;;; A FOREIGN-TYPE representing the "actual" return type. +;;; A form which can be used to initialize FP-ARGS-PTR, relative +;;; to STACK-PTR. (This is unused on linuxppc32.) +;;; The byte offset of the foreign return address, relative to STACK-PTR + +(defun darwin32::generate-callback-bindings (stack-ptr fp-args-ptr argvars argspecs result-spec struct-result-name) + (collect ((lets) + (rlets) + (inits) + (dynamic-extent-names)) + (let* ((rtype (parse-foreign-type result-spec)) + (fp-regs-form nil)) + (flet ((set-fp-regs-form () + (unless fp-regs-form + (setq fp-regs-form `(%get-ptr ,stack-ptr ,(- ppc32::c-frame.unused-1 ppc32::c-frame.param0)))))) + (when (typep rtype 'foreign-record-type) + (if (darwin32::record-type-has-single-scalar-field rtype) + (rlets (list struct-result-name (foreign-record-type-name rtype))) + (setq argvars (cons struct-result-name argvars) + argspecs (cons :address argspecs) + rtype *void-foreign-type*))) + (when (typep rtype 'foreign-float-type) + (set-fp-regs-form)) + (do* ((argvars argvars (cdr argvars)) + (argspecs argspecs (cdr argspecs)) + (fp-arg-num 0) + (offset 0 (+ offset delta)) + (delta 4 4) + (bias 0 0) + (use-fp-args nil nil)) + ((null argvars) + (values (rlets) (lets) (dynamic-extent-names) (inits) rtype fp-regs-form (- ppc32::c-frame.savelr ppc32::c-frame.param0))) + (flet ((next-scalar-arg (argtype) + `(,(cond + ((typep argtype 'foreign-single-float-type) + (if (< (incf fp-arg-num) 14) + (progn + (setq use-fp-args t) + '%get-single-float-from-double-ptr) + (progn + '%get-single-float))) + ((typep argtype 'foreign-double-float-type) + (setq delta 8) + (if (< (incf fp-arg-num) 14) + (setq use-fp-args t)) + '%get-double-float) + ((and (typep argtype 'foreign-integer-type) + (= (foreign-integer-type-bits argtype) 64) + (foreign-integer-type-signed argtype)) + (setq delta 8) + '%%get-signed-longlong) + ((and (typep argtype 'foreign-integer-type) + (= (foreign-integer-type-bits argtype) 64) + (not (foreign-integer-type-signed argtype))) + (setq delta 8) + '%%get-unsigned-longlong) + ((or (typep argtype 'foreign-pointer-type) + (typep argtype 'foreign-array-type)) + '%get-ptr) + (t + (cond ((typep argtype 'foreign-integer-type) + (let* ((bits (foreign-integer-type-bits argtype)) + (signed (foreign-integer-type-signed argtype))) + (cond ((<= bits 8) + (setq bias 3) + (if signed + '%get-signed-byte + '%get-unsigned-byte)) + ((<= bits 16) + (setq bias 2) + (if signed + '%get-signed-word + '%get-unsigned-word)) + ((<= bits 32) + (if signed + '%get-signed-long + '%get-unsigned-long)) + (t + (error "Don't know how to access foreign argument of type ~s" (unparse-foreign-type argtype)))))) + (t + (error "Don't know how to access foreign argument of type ~s" (unparse-foreign-type argtype)))))) + ,(if use-fp-args fp-args-ptr stack-ptr) + ,(if use-fp-args (* 8 (1- fp-arg-num)) + (+ offset bias))))) + (let* ((name (car argvars)) + (spec (car argspecs)) + (argtype (parse-foreign-type spec))) + (if (typep argtype 'foreign-record-type) + (let* ((type0 (darwin32::record-type-has-single-scalar-field argtype))) + (if type0 + (progn + (when name (rlets (list name (foreign-record-type-name argtype)))) + (let* ((init `(setf ,(%foreign-access-form name type0 0 nil) + ,(next-scalar-arg type0)))) + (when name (inits init)))) + (progn + (setq delta (* (ceiling (foreign-record-type-bits argtype) 32) 4)) + (when name ; no side-efects hers + (lets (list name `(%inc-ptr ,stack-ptr ,offset))))))) + (let* ((pair (list name (next-scalar-arg argtype)))) + (when name (lets pair)))) + #+nil + (when (or (typep argtype 'foreign-pointer-type) + (typep argtype 'foreign-array-type)) + (dynamic-extent-names name)) + (when use-fp-args (set-fp-regs-form))))))))) + +(defun darwin32::generate-callback-return-value (stack-ptr fp-args-ptr result return-type struct-return-arg) + (unless (eq return-type *void-foreign-type*) + ;; Coerce SINGLE-FLOAT result to DOUBLE-FLOAT + (when (typep return-type 'foreign-single-float-type) + (setq result `(float ,result 0.0d0))) + (when (typep return-type 'foreign-record-type) + ;;; Would have been mapped to :VOID unless record-type contained + ;;; a single scalar field. + (let* ((field0 (car (foreign-record-type-fields return-type)))) + (setq result (%foreign-access-form struct-return-arg + (foreign-record-field-type field0) + 0 + nil) + return-type (foreign-record-field-type field0)))) + (let* ((return-type-keyword (foreign-type-to-representation-type return-type)) + (result-ptr (case return-type-keyword + ((:single-float :double-float) + fp-args-ptr) + (t stack-ptr)))) + `(setf (, + (case return-type-keyword + (:address '%get-ptr) + (:signed-doubleword '%%get-signed-longlong) + (:unsigned-doubleword '%%get-unsigned-longlong) + ((:double-float :single-float) + '%get-double-float) + (:unsigned-fullword '%get-unsigned-long) + (t '%get-long ) + ) ,result-ptr 0) ,result)))) + Index: /branches/new-random/lib/ffi-darwinppc64.lisp =================================================================== --- /branches/new-random/lib/ffi-darwinppc64.lisp (revision 13309) +++ /branches/new-random/lib/ffi-darwinppc64.lisp (revision 13309) @@ -0,0 +1,543 @@ +;;;-*- Mode: Lisp; Package: CCL -*- +;;; +;;; Copyright (C) 2007-2009 Clozure Associates and contributors +;;; This file is part of Clozure CL. +;;; +;;; Clozure CL is licensed under the terms of the Lisp Lesser GNU Public +;;; License , known as the LLGPL and distributed with Clozure CL as the +;;; file "LICENSE". The LLGPL consists of a preamble and the LGPL, +;;; which is distributed with Clozure CL as the file "LGPL". Where these +;;; conflict, the preamble takes precedence. +;;; +;;; Clozure CL is referenced in the preamble as the "LIBRARY." +;;; +;;; The LLGPL is also available online at +;;; http://opensource.franz.com/preamble.html + +(in-package "CCL") + +;;; On DarwinPPC64: +;;; Structures whose size is exactly 16 bytes are passed in 2 GPRs, +;;; regardless of the types of their elements, when they are passed +;;; by value. +;;; Structures which contain unions are passed in N GPRs when passed +;;; by value. +;;; All other structures passed by value are passed by passing their +;;; constituent elements as scalars. (Sort of.) GPR's are "consumed" +;;; for and possibly/partly loaded with the contents of each 64-bit +;;; word; FPRs (and vector registers) are consumed/loaded for each +;;; field of the indicated type. +;;; Structures whose size is exactly 16 bytes are returned in GPR3 +;;; and GPR4. +;;; Structures which contain unions are "returned" by passing a pointer +;;; to a structure instance in the first argument. +;;; All other structures are returned by returning their constituent +;;; elements as scalars. (Note that - in some cases - we may need +;;; to reserve space in the foreign stack frame to handle scalar +;;; return values that don't fit in registers. Need a way to tell +;;; %ff-call about this, as well as runtime support.) + + +(defun darwin64::record-type-contains-union (rtype) + ;;; RTYPE is a FOREIGN-RECORD-TYPE object. + ;;; If it, any of its fields, or any fields in an + ;;; embedded structure or array field is a union, + ;;; return true. + ;;; (If this function returns true, we can't + ;;; pass a structure of type RTYPE - or return one - + ;;; by passing or returning the values of all of + ;;; its fields, since some fields are aliased. + ;;; However, if the record's size is exactly 128 + ;;; bits, we can pass/return it in two GPRs.) + (ensure-foreign-type-bits rtype) + (or (eq (foreign-record-type-kind rtype) :union) + (dolist (f (foreign-record-type-fields rtype)) + (let* ((fieldtype (foreign-record-field-type f))) + (if (and (typep fieldtype 'foreign-record-type) + (darwin64::record-type-contains-union fieldtype)) + (return t)) + (if (typep fieldtype 'foreign-array-type) + (let* ((atype (foreign-array-type-element-type fieldtype))) + (if (and (typep atype 'foreign-record-type) + (darwin64::record-type-contains-union atype)) + (return t)))))))) + +;;; On DarwinPPC64, we only have to pass a structure as a first +;;; argument if the type contains a union +(defun darwin64::record-type-returns-structure-as-first-arg (rtype) + (when (and rtype + (not (typep rtype 'unsigned-byte)) + (not (member rtype *foreign-representation-type-keywords* + :test #'eq))) + (let* ((ftype (if (typep rtype 'foreign-type) + rtype + (parse-foreign-type rtype)))) + (and (typep ftype 'foreign-record-type) + (not (= (ensure-foreign-type-bits ftype) 128)) + (darwin64::record-type-contains-union ftype))))) + + + + + +;;; Generate code to set the fields in a structure R of record-type +;;; RTYPE, based on the register values in REGBUF (8 64-bit GPRs, +;;; followed by 13 64-bit GPRs.) +;;; This also handles the 16-byte structure case. +;;; (It doesn't yet handle embedded arrays or bitfields.) +(defun darwin64::struct-from-regbuf-values (r rtype regbuf) + (let* ((bits (ccl::ensure-foreign-type-bits rtype))) + (collect ((forms)) + (cond ((= bits 128) ;(and (eql day 'tuesday) ...) + (forms `(setf (ccl::%get-signed-long ,r 0) + (ccl::%get-signed-long ,regbuf 0) + (ccl::%get-signed-long ,r 4) + (ccl::%get-signed-long ,regbuf 4) + (ccl::%get-signed-long ,r 8) + (ccl::%get-signed-long ,regbuf 8) + (ccl::%get-signed-long ,r 12) + (ccl::%get-signed-long ,regbuf 12)))) + ;;; One (slightly naive) way to do this is to just + ;;; copy GPRs into the structure until it's full, + ;;; then go back and overwrite float-typed fields + ;;; with FPRs. That'd be very naive if all fields + ;;; were float-typed, slightly naive if some fields + ;;; were properly-aligned DOUBLE-FLOATs or if two + ;;; SINGLE-FLOATs were packed inro a 64-bit word, + ;;; and not that bad if a SINGLE-FLOAT shared a + ;;; 64-bit word with a non-FP field. + (t + (let* ((fpr-offset (* 8 8)) + (fields (foreign-record-type-fields rtype))) + (flet ((next-fpr-offset () + (prog1 fpr-offset + (incf fpr-offset 8)))) + (unless (all-floats-in-field-list fields) + (do* ((b 0 (+ b 32)) + (w 0 (+ w 4))) + ((>= b bits)) + (declare (fixnum b w)) + (forms `(setf (%get-unsigned-long ,r ,w) + (%get-unsigned-long ,regbuf ,w))))) + (when (some-floats-in-field-list fields) + (labels ((do-fp-fields (fields accessors) + (dolist (field fields) + (let* ((field-type (foreign-record-field-type field)) + (field-accessor-list (append accessors (list (foreign-record-field-name field)))) + (valform ())) + (etypecase field-type + (foreign-record-type + (do-fp-fields (foreign-record-type-fields field-type) + field-accessor-list)) + (foreign-double-float-type + (setq valform + `(%get-double-float ,regbuf ,(next-fpr-offset)))) + (foreign-single-float-type + (setq valform + `(%get-single-float-from-double-ptr + ,regbuf ,(next-fpr-offset)))) + (foreign-array-type + (error "Embedded array-type.")) + ) + (when valform + (forms `(setf ,(%foreign-access-form + r + rtype + 0 + field-accessor-list) + ,valform))))))) + (do-fp-fields (foreign-record-type-fields rtype) nil ))))))) + `(progn ,@(forms) nil)))) + +;;; "Return" the structure R of foreign type RTYPE, by storing the +;;; values of its fields in STACK-PTR and FP-ARG-PTR +(defun darwin64::return-struct-to-registers (r rtype stack-ptr fp-args-ptr) + (let* ((bits (require-foreign-type-bits rtype))) + (collect ((forms)) + (cond ((= bits 128) ;(and (eql day 'tuesday) ...) + (forms `(setf (ccl::%get-unsigned-long ,stack-ptr 0) + (ccl::%get-unsigned-long ,r 0) + (ccl::%get-unsigned-long ,stack-ptr 4) + (ccl::%get-unsigned-long ,r 4) + (ccl::%get-unsigned-long ,stack-ptr 8) + (ccl::%get-unsigned-long ,r 8) + (ccl::%get-unsigned-long ,stack-ptr 12) + (ccl::%get-unsigned-long ,r 12)))) + (t + (let* ((fpr-offset 0) + (fields (foreign-record-type-fields rtype))) + (unless (all-floats-in-field-list fields) + (do* ((b 0 (+ b 32)) + (w 0 (+ w 4))) + ((>= b bits)) + (declare (fixnum b w)) + (forms `(setf (%get-unsigned-long ,stack-ptr ,w) + (%get-unsigned-long ,r ,w))))) + (when (some-floats-in-field-list fields) + (flet ((next-fpr-offset () + (prog1 fpr-offset + (incf fpr-offset 8)))) + (labels ((do-fp-fields (fields accessors) + (dolist (field fields) + (let* ((field-type (foreign-record-field-type field)) + (field-accessor-list (append accessors (list (foreign-record-field-name field)))) + (valform ())) + (etypecase field-type + (foreign-record-type + (do-fp-fields (foreign-record-type-fields field-type) + field-accessor-list)) + (foreign-double-float-type + (setq valform + `(%get-double-float ,fp-args-ptr ,(next-fpr-offset)))) + (foreign-single-float-type + (setq valform + `(%get-double-float ,fp-args-ptr ,(next-fpr-offset)))) + + (foreign-array-type + (error "Embedded array-type.")) + ) + (when valform + (let* ((field-form (%foreign-access-form + r + rtype + 0 + field-accessor-list))) + (when (typep field-type 'foreign-single-float-type) + (setq field-form `(float ,field-form 0.0d0))) + (forms `(setf ,valform ,field-form)))))))) + (do-fp-fields fields nil ))))))) + `(progn ,@(forms) nil)))) + +;;; Return an ordered list of all scalar fields in the record type FTYPE. +(defun darwin64::flatten-fields (ftype) + (if (darwin64::record-type-contains-union ftype) + (error "Can't flatten fields in ~s: contains union" ftype)) + (collect ((fields)) + (labels ((flatten (field-list bit-offset) + (dolist (field field-list) + (let* ((field-type (foreign-record-field-type field)) + (next-offset (+ bit-offset (foreign-record-field-offset field)))) + (typecase field-type + (foreign-record-type + (flatten (foreign-record-type-fields field-type) next-offset)) + (foreign-array-type + (let* ((element-type (foreign-array-type-element-type field-type)) + (nbits (foreign-type-bits element-type)) + (align (foreign-type-alignment element-type)) + (dims (foreign-array-type-dimensions field-type)) + (n (or (and (null (cdr dims)) (car dims)) + (error "Can't handle multidimensional foreign arrays"))) + (pos next-offset)) + (dotimes (i n) + (fields (make-foreign-record-field :type element-type + :bits nbits + :offset pos)) + (setq pos (align-offset (+ pos nbits) align))))) + (t + (fields (make-foreign-record-field :type field-type + :bits (foreign-record-field-bits field) + :offset next-offset)))))))) + (flatten (foreign-record-type-fields ftype) 0) + (fields)))) + + + + +(defun darwin64::expand-ff-call (callform args &key (arg-coerce #'null-coerce-foreign-arg) (result-coerce #'null-coerce-foreign-result)) + (let* ((result-type-spec (or (car (last args)) :void)) + (regbuf nil) + (result-temp nil) + (result-form nil) + (struct-result-type nil) + (structure-arg-temp nil)) + (multiple-value-bind (result-type error) + (ignore-errors (parse-foreign-type result-type-spec)) + (if error + (setq result-type-spec :void result-type *void-foreign-type*) + (setq args (butlast args))) + (collect ((argforms)) + (when (eq (car args) :monitor-exception-ports) + (argforms (pop args))) + (when (typep result-type 'foreign-record-type) + (setq result-form (pop args) + struct-result-type result-type + result-type *void-foreign-type* + result-type-spec :void) + (if (darwin64::record-type-returns-structure-as-first-arg struct-result-type) + (progn + (argforms :address) + (argforms result-form)) + (progn + (setq regbuf (gensym) + result-temp (gensym)) + (argforms :registers) + (argforms regbuf)))) + (let* ((valform nil)) + (unless (evenp (length args)) + (error "~s should be an even-length list of alternating foreign types and values" args)) + (do* ((args args (cddr args))) + ((null args)) + (let* ((arg-type-spec (car args)) + (arg-value-form (cadr args))) + (if (or (member arg-type-spec *foreign-representation-type-keywords* + :test #'eq) + (typep arg-type-spec 'unsigned-byte)) + (progn + (argforms arg-type-spec) + (argforms arg-value-form)) + (let* ((ftype (parse-foreign-type arg-type-spec)) + (bits (foreign-type-bits ftype))) + (if (typep ftype 'foreign-record-type) + (if (or (darwin64::record-type-contains-union ftype) + (= bits 128)) + (progn + (argforms (ceiling (foreign-record-type-bits ftype) 64)) + (argforms arg-value-form)) + (let* ((flattened-fields (darwin64::flatten-fields ftype))) + + (flet ((single-float-at-offset (offset) + (dolist (field flattened-fields) + (let* ((field-offset (foreign-record-field-offset field))) + (when (> field-offset offset) + (return nil)) + (if (and (= field-offset offset) + (typep (foreign-record-field-type field) + 'foreign-single-float-type)) + (return t))))) + (double-float-at-offset (offset) + (dolist (field flattened-fields) + (let* ((field-offset (foreign-record-field-offset field))) + (when (> field-offset offset) + (return nil)) + (if (and (= field-offset offset) + (typep (foreign-record-field-type field) + 'foreign-double-float-type)) + (return t)))))) + (unless structure-arg-temp + (setq structure-arg-temp (gensym))) + (setq valform `(%setf-macptr ,structure-arg-temp ,arg-value-form)) + (do* ((bit-offset 0 (+ bit-offset 64)) + (byte-offset 0 (+ byte-offset 8))) + ((>= bit-offset bits)) + (if (double-float-at-offset bit-offset) + (progn + (argforms :double-float) + (argforms `(%get-double-float ,valform ,byte-offset))) + (let* ((high-single (single-float-at-offset bit-offset)) + (low-single (single-float-at-offset (+ bit-offset 32)))) + (if high-single + (if low-single + (argforms :hybrid-float-float) + (argforms :hybrid-float-int)) + (if low-single + (argforms :hybrid-int-float) + (argforms :unsigned-doubleword))) + (argforms `(%%get-unsigned-longlong ,valform ,byte-offset)))) + (setq valform structure-arg-temp))))) + (progn + (argforms (foreign-type-to-representation-type ftype)) + (argforms (funcall arg-coerce arg-type-spec arg-value-form)))))))) + (argforms (foreign-type-to-representation-type result-type)) + (let* ((call (funcall result-coerce result-type-spec `(,@callform ,@(argforms))))) + (when structure-arg-temp + (setq call `(let* ((,structure-arg-temp (%null-ptr))) + (declare (dynamic-extent ,structure-arg-temp) + (type macptr ,structure-arg-temp)) + ,call))) + (if regbuf + `(let* ((,result-temp (%null-ptr))) + (declare (dynamic-extent ,result-temp) + (type macptr ,result-temp)) + (%setf-macptr ,result-temp ,result-form) + (%stack-block ((,regbuf (+ (* 8 8) (* 8 13)))) + ,call + ,(darwin64::struct-from-regbuf-values result-temp struct-result-type regbuf))) + call))))))) + + +;;; Return 7 values: +;;; A list of RLET bindings +;;; A list of LET* bindings +;;; A list of DYNAMIC-EXTENT declarations for the LET* bindings +;;; A list of initializaton forms for (some) structure args +;;; A FOREIGN-TYPE representing the "actual" return type. +;;; A form which can be used to initialize FP-ARGS-PTR, relative +;;; to STACK-PTR. (This is unused on linuxppc32.) +;;; The byte offset of the foreign return address, relative to STACK-PTR + +(defun darwin64::generate-callback-bindings (stack-ptr fp-args-ptr argvars argspecs result-spec struct-result-name) + (collect ((lets) + (rlets) + (inits) + (dynamic-extent-names)) + (let* ((rtype (parse-foreign-type result-spec)) + (fp-regs-form nil)) + (flet ((set-fp-regs-form () + (unless fp-regs-form + (setq fp-regs-form `(%get-ptr ,stack-ptr ,(- ppc64::c-frame.unused-1 ppc64::c-frame.param0)))))) + (when (typep rtype 'foreign-record-type) + (if (darwin64::record-type-contains-union rtype) + (setq argvars (cons struct-result-name argvars) + argspecs (cons :address argspecs) + rtype *void-foreign-type*) + (rlets (list struct-result-name (or (foreign-record-type-name rtype) + result-spec))))) + (when (typep rtype 'foreign-float-type) + (set-fp-regs-form)) + (do* ((argvars argvars (cdr argvars)) + (argspecs argspecs (cdr argspecs)) + (fp-arg-num 0) + (offset 0) + (delta 0) + (bias 0) + (use-fp-args nil nil)) + ((null argvars) + (values (rlets) (lets) (dynamic-extent-names) (inits) rtype fp-regs-form (- ppc64::c-frame.savelr ppc64::c-frame.param0))) + (flet ((next-scalar-arg (argtype) + (setq delta 8 bias 0) + (prog1 + `(,(cond + ((typep argtype 'foreign-single-float-type) + (if (< (incf fp-arg-num) 14) + (progn + (setq use-fp-args t) + '%get-single-float-from-double-ptr) + (progn + '%get-single-float))) + ((typep argtype 'foreign-double-float-type) + (if (< (incf fp-arg-num) 14) + (setq use-fp-args t)) + '%get-double-float) + ((and (typep argtype 'foreign-integer-type) + (= (foreign-integer-type-bits argtype) 64) + (foreign-integer-type-signed argtype)) + (setq delta 8) + '%%get-signed-longlong) + ((and (typep argtype 'foreign-integer-type) + (= (foreign-integer-type-bits argtype) 64) + (not (foreign-integer-type-signed argtype))) + (setq delta 8) + '%%get-unsigned-longlong) + ((or (typep argtype 'foreign-pointer-type) + (typep argtype 'foreign-array-type)) + '%get-ptr) + (t + (cond ((typep argtype 'foreign-integer-type) + (let* ((bits (foreign-integer-type-bits argtype)) + (signed (foreign-integer-type-signed argtype))) + (cond ((<= bits 8) + (setq bias 7) + (if signed + '%get-signed-byte ' + '%get-unsigned-byte)) + ((<= bits 16) + (setq bias 6) + (if signed + '%get-signed-word + '%get-unsigned-word)) + ((<= bits 32) + (setq bias 4) + (if signed + '%get-signed-long + '%get-unsigned-long)) + (t + (error "Don't know how to access foreign argument of type ~s" (unparse-foreign-type argtype)))))) + (t + (error "Don't know how to access foreign argument of type ~s" (unparse-foreign-type argtype)))))) + ,(if use-fp-args fp-args-ptr stack-ptr) + ,(if use-fp-args (* 8 (1- fp-arg-num)) + (+ offset bias))) + (incf offset delta)))) + (let* ((name (car argvars)) + (spec (car argspecs)) + (argtype (parse-foreign-type spec)) + (bits (foreign-type-bits argtype))) + (if (typep argtype 'foreign-record-type) + (if (or (darwin64::record-type-contains-union argtype) + (= bits 128)) + (progn (setq delta (* (ceiling bits 64) 8)) + (when name (lets (list name `(%inc-ptr ,stack-ptr ,offset )))) + (incf offset delta)) + + (let* ((flattened-fields (darwin64::flatten-fields argtype))) + (flet ((double-float-at-offset (offset) + (dolist (field flattened-fields) + (let* ((field-offset (foreign-record-field-offset field))) + (when (> field-offset offset) (return)) + (if (and (= field-offset offset) + (typep (foreign-record-field-type field) + 'foreign-double-float-type)) + (return t))))) + (single-float-at-offset (offset) + (dolist (field flattened-fields) + (let* ((field-offset (foreign-record-field-offset field))) + (when (> field-offset offset) (return)) + (if (and (= field-offset offset) + (typep (foreign-record-field-type field) + 'foreign-single-float-type)) + (return t)))))) + (when name (rlets (list name (or (foreign-record-type-name argtype) + spec)))) + (do* ((bit-offset 0 (+ bit-offset 64)) + (byte-offset 0 (+ byte-offset 8))) + ((>= bit-offset bits)) + (if (double-float-at-offset bit-offset) + (let* ((init `(setf (%get-double-float ,name ,byte-offset) + ,(next-scalar-arg (parse-foreign-type :double-float))))) + (when name + (inits init))) + (let* ((high-single (single-float-at-offset bit-offset)) + (low-single (single-float-at-offset (+ bit-offset 32))) + (init `(setf (%%get-unsigned-longlong ,name ,byte-offset) + ,(next-scalar-arg (parse-foreign-type '(:unsigned 64)))))) + (when name (inits init)) + (when high-single + (when (< (incf fp-arg-num) 14) + (set-fp-regs-form) + (when name + (inits `(setf (%get-single-float ,name ,byte-offset) + (%get-single-float-from-double-ptr + ,fp-args-ptr + ,(* 8 (1- fp-arg-num)))))))) + (when low-single + (when (< (incf fp-arg-num) 14) + (set-fp-regs-form) + (when name + (inits `(setf (%get-single-float ,name ,(+ 4 byte-offset)) + (%get-single-float-from-double-ptr + ,fp-args-ptr + ,(* 8 (1- fp-arg-num)))))))))))))) + (let* ((form (next-scalar-arg argtype))) + (when name + (lets (list name form))))) + #+nil + (when (or (typep argtype 'foreign-pointer-type) + (typep argtype 'foreign-array-type)) + (dynamic-extent-names name)) + (when use-fp-args (set-fp-regs-form))))))))) + +(defun darwin64::generate-callback-return-value (stack-ptr fp-args-ptr result return-type struct-return-arg) + (unless (eq return-type *void-foreign-type*) + (when (typep return-type 'foreign-single-float-type) + (setq result `(float ,result 0.0d0))) + (if (typep return-type 'foreign-record-type) + ;;; Would have been mapped to :VOID unless record-type contained + ;;; a single scalar field. + (darwin64::return-struct-to-registers struct-return-arg return-type stack-ptr fp-args-ptr) + (let* ((return-type-keyword (foreign-type-to-representation-type return-type)) + (result-ptr (case return-type-keyword + ((:single-float :double-float) + fp-args-ptr) + (t stack-ptr)))) + `(setf (, + (case return-type-keyword + (:address '%get-ptr) + (:signed-doubleword '%%get-signed-longlong) + (:unsigned-doubleword '%%get-unsigned-longlong) + ((:double-float :single-float) + '%get-double-float) + (:unsigned-fullword '%get-unsigned-long) + (t '%%get-signed-longlong ) + ) ,result-ptr 0) ,result))))) + + Index: /branches/new-random/lib/ffi-darwinx8632.lisp =================================================================== --- /branches/new-random/lib/ffi-darwinx8632.lisp (revision 13309) +++ /branches/new-random/lib/ffi-darwinx8632.lisp (revision 13309) @@ -0,0 +1,38 @@ +;;; Copyright 2009 Clozure Associates +;;; This file is part of Clozure CL. +;;; +;;; Clozure CL is licensed under the terms of the Lisp Lesser GNU +;;; Public License , known as the LLGPL and distributed with Clozure +;;; CL as the file "LICENSE". The LLGPL consists of a preamble and +;;; the LGPL, which is distributed with Clozure CL as the file "LGPL". +;;; Where these conflict, the preamble takes precedence. +;;; +;;; Clozure CL is referenced in the preamble as the "LIBRARY." +;;; +;;; The LLGPL is also available online at +;;; http://opensource.franz.com/preamble.html + +(in-package "CCL") + +;;; Some small structures are returned in EAX and EDX. Otherwise, +;;; return values are placed at the address specified by the caller. +(defun x86-darwin32::record-type-returns-structure-as-first-arg (rtype) + (when (and rtype + (not (typep rtype 'unsigned-byte)) + (not (member rtype *foreign-representation-type-keywords* + :test #'eq))) + (let* ((ftype (if (typep rtype 'foreign-type) + rtype + (parse-foreign-type rtype))) + (nbits (ensure-foreign-type-bits ftype))) + (not (member nbits '(8 16 32 64)))))) + +;;; We don't support the __m64, __m128, __m128d, and __m128i types. +(defun x86-darwin32::expand-ff-call (callform args &key (arg-coerce #'null-coerce-foreign-arg) (result-coerce #'null-coerce-foreign-result)) + (x8632::expand-ff-call callform args :arg-coerce arg-coerce :result-coerce result-coerce)) + +(defun x86-darwin32::generate-callback-bindings (stack-ptr fp-args-ptr argvars argspecs result-spec struct-result-name) + (x8632::generate-callback-bindings stack-ptr fp-args-ptr argvars argspecs result-spec struct-result-name)) + +(defun x86-darwin32::generate-callback-return-value (stack-ptr fp-args-ptr result return-type struct-return-arg) + (x8632::generate-callback-return-value stack-ptr fp-args-ptr result return-type struct-return-arg)) Index: /branches/new-random/lib/ffi-darwinx8664.lisp =================================================================== --- /branches/new-random/lib/ffi-darwinx8664.lisp (revision 13309) +++ /branches/new-random/lib/ffi-darwinx8664.lisp (revision 13309) @@ -0,0 +1,34 @@ +;;;-*- Mode: Lisp; Package: CCL -*- +;;; +;;; Copyright (C) 2007-2009 Clozure Associates and contributors +;;; This file is part of Clozure CL. +;;; +;;; Clozure CL is licensed under the terms of the Lisp Lesser GNU Public +;;; License , known as the LLGPL and distributed with Clozure CL as the +;;; file "LICENSE". The LLGPL consists of a preamble and the LGPL, +;;; which is distributed with Clozure CL as the file "LGPL". Where these +;;; conflict, the preamble takes precedence. +;;; +;;; Clozure CL is referenced in the preamble as the "LIBRARY." +;;; +;;; The LLGPL is also available online at +;;; http://opensource.franz.com/preamble.html + +(in-package "CCL") + +;;; It looks like x86-64 Linux, FreeBSD, and Darwin all share the same +;;; ABI. + +(defun x86-darwin64::record-type-returns-structure-as-first-arg (rtype) + (x8664::record-type-returns-structure-as-first-arg rtype)) + + + +(defun x86-darwin64::expand-ff-call (callform args &key (arg-coerce #'null-coerce-foreign-arg) (result-coerce #'null-coerce-foreign-result)) + (x8664::expand-ff-call callform args :arg-coerce arg-coerce :result-coerce result-coerce)) + +(defun x86-darwin64::generate-callback-bindings (stack-ptr fp-args-ptr argvars argspecs result-spec struct-return-name) + (x8664::generate-callback-bindings stack-ptr fp-args-ptr argvars argspecs result-spec struct-return-name)) + +(defun x86-darwin64::generate-callback-return-value (stack-ptr fp-args-ptr result return-type struct-return-arg) + (x8664::generate-callback-return-value stack-ptr fp-args-ptr result return-type struct-return-arg)) Index: /branches/new-random/lib/ffi-freebsdx8632.lisp =================================================================== --- /branches/new-random/lib/ffi-freebsdx8632.lisp (revision 13309) +++ /branches/new-random/lib/ffi-freebsdx8632.lisp (revision 13309) @@ -0,0 +1,38 @@ +;;; Copyright 2009 Clozure Associates +;;; This file is part of Clozure CL. +;;; +;;; Clozure CL is licensed under the terms of the Lisp Lesser GNU +;;; Public License , known as the LLGPL and distributed with Clozure +;;; CL as the file "LICENSE". The LLGPL consists of a preamble and +;;; the LGPL, which is distributed with Clozure CL as the file "LGPL". +;;; Where these conflict, the preamble takes precedence. +;;; +;;; Clozure CL is referenced in the preamble as the "LIBRARY." +;;; +;;; The LLGPL is also available online at +;;; http://opensource.franz.com/preamble.html + +(in-package "CCL") + +;;; On FreeBSD, the C compiler returns small structures in registers +;;; (just like on Darwin, apparently). +(defun x86-freebsd32::record-type-returns-structure-as-first-arg (rtype) + (when (and rtype + (not (typep rtype 'unsigned-byte)) + (not (member rtype *foreign-representation-type-keywords* + :test #'eq))) + (let* ((ftype (if (typep rtype 'foreign-type) + rtype + (parse-foreign-type rtype))) + (nbits (ensure-foreign-type-bits ftype))) + (not (member nbits '(8 16 32 64)))))) + +(defun x86-freebsd32::expand-ff-call (callform args &key (arg-coerce #'null-coerce-foreign-arg) (result-coerce #'null-coerce-foreign-result)) + (x8632::expand-ff-call callform args :arg-coerce arg-coerce :result-coerce result-coerce)) + +(defun x86-freebsd32::generate-callback-bindings (stack-ptr fp-args-ptr argvars argspecs result-spec struct-result-name) + (x8632::generate-callback-bindings stack-ptr fp-args-ptr argvars argspecs result-spec struct-result-name)) + +(defun x86-freebsd32::generate-callback-return-value (stack-ptr fp-args-ptr result return-type struct-return-arg) + (x8632::generate-callback-return-value stack-ptr fp-args-ptr result return-type struct-return-arg)) + Index: /branches/new-random/lib/ffi-freebsdx8664.lisp =================================================================== --- /branches/new-random/lib/ffi-freebsdx8664.lisp (revision 13309) +++ /branches/new-random/lib/ffi-freebsdx8664.lisp (revision 13309) @@ -0,0 +1,34 @@ +;;;-*- Mode: Lisp; Package: CCL -*- +;;; +;;; Copyright (C) 2007-2009 Clozure Associates and contributors +;;; This file is part of Clozure CL. +;;; +;;; Clozure CL is licensed under the terms of the Lisp Lesser GNU Public +;;; License , known as the LLGPL and distributed with Clozure CL as the +;;; file "LICENSE". The LLGPL consists of a preamble and the LGPL, +;;; which is distributed with Clozure CL as the file "LGPL". Where these +;;; conflict, the preamble takes precedence. +;;; +;;; Clozure CL is referenced in the preamble as the "LIBRARY." +;;; +;;; The LLGPL is also available online at +;;; http://opensource.franz.com/preamble.html + +(in-package "CCL") + +;;; It looks like x86-64 Linux, FreeBSD, and Darwin all share the same +;;; ABI. + +(defun x86-freebsd64::record-type-returns-structure-as-first-arg (rtype) + (x8664::record-type-returns-structure-as-first-arg rtype)) + + + +(defun x86-freebsd64::expand-ff-call (callform args &key (arg-coerce #'null-coerce-foreign-arg) (result-coerce #'null-coerce-foreign-result)) + (x8664::expand-ff-call callform args :arg-coerce arg-coerce :result-coerce result-coerce)) + +(defun x86-freebsd64::generate-callback-bindings (stack-ptr fp-args-ptr argvars argspecs result-spec struct-return-name) + (x8664::generate-callback-bindings stack-ptr fp-args-ptr argvars argspecs result-spec struct-return-name)) + +(defun x86-freebsd64::generate-callback-return-value (stack-ptr fp-args-ptr result return-type struct-return-arg) + (x8664::generate-callback-return-value stack-ptr fp-args-ptr result return-type struct-return-arg)) Index: /branches/new-random/lib/ffi-linuxppc32.lisp =================================================================== --- /branches/new-random/lib/ffi-linuxppc32.lisp (revision 13309) +++ /branches/new-random/lib/ffi-linuxppc32.lisp (revision 13309) @@ -0,0 +1,218 @@ +;;;-*- Mode: Lisp; Package: CCL -*- +;;; +;;; Copyright (C) 2007-2009 Clozure Associates and contributors +;;; This file is part of Clozure CL. +;;; +;;; Clozure CL is licensed under the terms of the Lisp Lesser GNU Public +;;; License , known as the LLGPL and distributed with Clozure CL as the +;;; file "LICENSE". The LLGPL consists of a preamble and the LGPL, +;;; which is distributed with Clozure CL as the file "LGPL". Where these +;;; conflict, the preamble takes precedence. +;;; +;;; Clozure CL is referenced in the preamble as the "LIBRARY." +;;; +;;; The LLGPL is also available online at +;;; http://opensource.franz.com/preamble.html + +(in-package "CCL") + +;;; LinuxPPC32: +;;; Structures are never actually passed by value; the caller +;;; instead passes a pointer to the structure or a copy of it. +;;; In the EABI (which Linux uses, as opposed to the SVR4 ABI) +;;; structures are always "returned" by passing a pointer to +;;; a caller-allocated structure in the first argument. +(defun linux32::record-type-returns-structure-as-first-arg (rtype) + (when (and rtype + (not (typep rtype 'unsigned-byte)) + (not (member rtype *foreign-representation-type-keywords* + :test #'eq))) + (let* ((ftype (if (typep rtype 'foreign-type) + rtype + (parse-foreign-type rtype)))) + (typep ftype 'foreign-record-type)))) + + +(defun linux32::expand-ff-call (callform args &key (arg-coerce #'null-coerce-foreign-arg) (result-coerce #'null-coerce-foreign-result)) + (let* ((result-type-spec (or (car (last args)) :void)) + (enclosing-form nil) + (result-form nil)) + (multiple-value-bind (result-type error) + (ignore-errors (parse-foreign-type result-type-spec)) + (if error + (setq result-type-spec :void result-type *void-foreign-type*) + (setq args (butlast args))) + (collect ((argforms)) + (when (eq (car args) :monitor-exception-ports) + (argforms (pop args))) + (when (typep result-type 'foreign-record-type) + (setq result-form (pop args)) + (if (linux32::record-type-returns-structure-as-first-arg result-type) + (progn + (setq result-type *void-foreign-type* + result-type-spec :void) + (argforms :address) + (argforms result-form)) + ;; This only happens in the SVR4 ABI. + (progn + (setq result-type (parse-foreign-type :unsigned-doubleword) + result-type-spec :unsigned-doubleword + enclosing-form `(setf (%%get-unsigned-longlong ,result-form 0)))))) + (unless (evenp (length args)) + (error "~s should be an even-length list of alternating foreign types and values" args)) + (do* ((args args (cddr args))) + ((null args)) + (let* ((arg-type-spec (car args)) + (arg-value-form (cadr args))) + (if (or (member arg-type-spec *foreign-representation-type-keywords* + :test #'eq) + (typep arg-type-spec 'unsigned-byte)) + (progn + (argforms arg-type-spec) + (argforms arg-value-form)) + (let* ((ftype (parse-foreign-type arg-type-spec))) + (if (typep ftype 'foreign-record-type) + (progn + (argforms :address) + (argforms arg-value-form)) + (progn + (argforms (foreign-type-to-representation-type ftype)) + (argforms (funcall arg-coerce arg-type-spec arg-value-form)))))))) + (argforms (foreign-type-to-representation-type result-type)) + (let* ((call (funcall result-coerce result-type-spec `(,@callform ,@(argforms))))) + (if enclosing-form + `(,@enclosing-form ,call) + call)))))) + +;;; Return 7 values: +;;; A list of RLET bindings +;;; A list of LET* bindings +;;; A list of DYNAMIC-EXTENT declarations for the LET* bindings +;;; A list of initializaton forms for (some) structure args +;;; A FOREIGN-TYPE representing the "actual" return type. +;;; A form which can be used to initialize FP-ARGS-PTR, relative +;;; to STACK-PTR. (This is unused on linuxppc32.) +;;; The byte offset of the foreign return address, relative to STACK-PTR +(defun linux32::generate-callback-bindings (stack-ptr fp-args-ptr argvars argspecs result-spec struct-result-name) + (declare (ignore fp-args-ptr)) + (collect ((lets) + (rlets) + (dynamic-extent-names)) + (let* ((rtype (parse-foreign-type result-spec))) + (when (typep rtype 'foreign-record-type) + (let* ((bits (ensure-foreign-type-bits rtype))) + (if (<= bits 64) + (rlets (list struct-result-name (foreign-record-type-name rtype))) + (setq argvars (cons struct-result-name argvars) + argspecs (cons :address argspecs) + rtype *void-foreign-type*)))) + (let* ((offset 96) + (gpr 0) + (fpr 32)) + (do* ((argvars argvars (cdr argvars)) + (argspecs argspecs (cdr argspecs))) + ((null argvars) + (values (rlets) (lets) (dynamic-extent-names) nil rtype nil 0 #|wrong|#)) + (let* ((name (car argvars)) + (spec (car argspecs)) + (nextgpr gpr) + (nextfpr fpr) + (nextoffset offset) + (target gpr) + (bias 0) + (argtype (parse-foreign-type spec))) + (if (typep argtype 'foreign-record-type) + (setq argtype (parse-foreign-type :address))) + (let* ((access-form + `(,(cond + ((typep argtype 'foreign-single-float-type) + (incf nextfpr 8) + (if (< fpr 96) + (setq target fpr) + (setq target (+ offset (logand offset 4)) + nextoffset (+ target 8))) + '%get-single-float-from-double-ptr) + ((typep argtype 'foreign-double-float-type) + (incf nextfpr 8) + (if (< fpr 96) + (setq target fpr) + (setq target (+ offset (logand offset 4)) + nextoffset (+ target 8))) + '%get-double-float) + ((and (typep argtype 'foreign-integer-type) + (= (foreign-integer-type-bits argtype) 64) + (foreign-integer-type-signed argtype)) + (if (< gpr 56) + (setq target (+ gpr (logand gpr 4)) + nextgpr (+ 8 target)) + (setq target (+ offset (logand offset 4)) + nextoffset (+ 8 offset))) + '%%get-signed-longlong) + ((and (typep argtype 'foreign-integer-type) + (= (foreign-integer-type-bits argtype) 64) + (not (foreign-integer-type-signed argtype))) + (if (< gpr 56) + (setq target (+ gpr (logand gpr 4)) + nextgpr (+ 8 target)) + (setq target (+ offset (logand offset 4)) + nextoffset (+ 8 offset))) + '%%get-unsigned-longlong) + (t + (incf nextgpr 4) + (if (< gpr 64) + (setq target gpr) + (setq target offset nextoffset (+ offset 4))) + (cond ((typep argtype 'foreign-pointer-type) '%get-ptr) + ((typep argtype 'foreign-integer-type) + (let* ((bits (foreign-integer-type-bits argtype)) + (signed (foreign-integer-type-signed argtype))) + (cond ((<= bits 8) + (setq bias 3) + (if signed + '%get-signed-byte ' + '%get-unsigned-byte)) + ((<= bits 16) + (setq bias 2) + (if signed + '%get-signed-word + '%get-unsigned-word)) + ((<= bits 32) + (if signed + '%get-signed-long + '%get-unsigned-long)) + (t + (error "Don't know how to access foreign argument of type ~s" (unparse-foreign-type argtype)))))) + (t + (error "Don't know how to access foreign argument of type ~s" (unparse-foreign-type argtype)))))) + ,stack-ptr + ,(+ target bias)))) + (when name (lets (list name access-form))) + #+nil + (when (eq spec :address) + (dynamic-extent-names name)) + (setq gpr nextgpr fpr nextfpr offset nextoffset)))))))) + +(defun linux32::generate-callback-return-value (stack-ptr fp-args-ptr result return-type struct-return-arg) + (declare (ignore fp-args-ptr)) + (unless (eq return-type *void-foreign-type*) + (when (typep return-type 'foreign-single-float-type) + (setq result `(float ,result 0.0d0))) + (let* ((return-type-keyword + (if (typep return-type 'foreign-record-type) + (progn + (setq result `(%%get-unsigned-longlong ,struct-return-arg 0)) + :unsigned-doubleword) + (foreign-type-to-representation-type return-type))) + (offset (case return-type-keyword + ((:single-float :double-float) + 8) + (t 0)))) + `(setf (, + (case return-type-keyword + (:address '%get-ptr) + (:signed-doubleword '%%get-signed-longlong) + (:unsigned-doubleword '%%get-unsigned-longlong) + ((:double-float :single-float) '%get-double-float) + (t '%get-long)) ,stack-ptr ,offset) ,result)))) + + Index: /branches/new-random/lib/ffi-linuxppc64.lisp =================================================================== --- /branches/new-random/lib/ffi-linuxppc64.lisp (revision 13309) +++ /branches/new-random/lib/ffi-linuxppc64.lisp (revision 13309) @@ -0,0 +1,199 @@ +;;;-*- Mode: Lisp; Package: CCL -*- +;;; +;;; Copyright (C) 2007-2009 Clozure Associates and contributors +;;; This file is part of Clozure CL. +;;; +;;; Clozure CL is licensed under the terms of the Lisp Lesser GNU Public +;;; License , known as the LLGPL and distributed with Clozure CL as the +;;; file "LICENSE". The LLGPL consists of a preamble and the LGPL, +;;; which is distributed with Clozure CL as the file "LGPL". Where these +;;; conflict, the preamble takes precedence. +;;; +;;; Clozure CL is referenced in the preamble as the "LIBRARY." +;;; +;;; The LLGPL is also available online at +;;; http://opensource.franz.com/preamble.html + +(in-package "CCL") + +;;; LinuxPPC64 +;;; Structures whose size is less than 64 bits are passed "right-justified" +;;; in a GPR. +;;; Larger structures passed by value are passed in GPRs as N doublewords. +;;; If the structure would require > 64-bit alignment, this might result +;;; in some GPRs/parameter area words being skipped. (We don't handle this). +;;; All structures - of any size - are returned by passing a pointer +;;; in the first argument. + +(defun linux64::record-type-returns-structure-as-first-arg (rtype) + (when (and rtype + (not (typep rtype 'unsigned-byte)) + (not (member rtype *foreign-representation-type-keywords* + :test #'eq))) + (let* ((ftype (if (typep rtype 'foreign-type) + rtype + (parse-foreign-type rtype)))) + (typep ftype 'foreign-record-type)))) + +(defun linux64::expand-ff-call (callform args &key (arg-coerce #'null-coerce-foreign-arg) (result-coerce #'null-coerce-foreign-result)) + (let* ((result-type-spec (or (car (last args)) :void))) + (multiple-value-bind (result-type error) + (ignore-errors (parse-foreign-type result-type-spec)) + (if error + (setq result-type-spec :void result-type *void-foreign-type*) + (setq args (butlast args))) + (collect ((argforms)) + (when (eq (car args) :monitor-exception-ports) + (argforms (pop args))) + (when (typep result-type 'foreign-record-type) + (setq result-type *void-foreign-type* + result-type-spec :void) + (argforms :address) + (argforms (pop args))) + (unless (evenp (length args)) + (error "~s should be an even-length list of alternating foreign types and values" args)) + (do* ((args args (cddr args))) + ((null args)) + (let* ((arg-type-spec (car args)) + (arg-value-form (cadr args))) + (if (or (member arg-type-spec *foreign-representation-type-keywords* + :test #'eq) + (typep arg-type-spec 'unsigned-byte)) + (progn + (argforms arg-type-spec) + (argforms arg-value-form)) + (let* ((ftype (parse-foreign-type arg-type-spec))) + (if (typep ftype 'foreign-record-type) + (let* ((bits (ensure-foreign-type-bits ftype))) + (if (< bits 64) + (progn + (argforms :unsigned-doubleword) + (argforms `(ash (%%get-unsigned-longlong ,arg-value-form 0) ,(- bits 64)))) + (progn + (argforms (ceiling bits 64)) + (argforms arg-value-form)))) + (progn + (argforms (foreign-type-to-representation-type ftype)) + (argforms (funcall arg-coerce arg-type-spec arg-value-form)))))))) + (argforms (foreign-type-to-representation-type result-type)) + (funcall result-coerce result-type-spec `(,@callform ,@(argforms))))))) + +(defun linux64::generate-callback-bindings (stack-ptr fp-args-ptr argvars argspecs result-spec struct-result-name) + (collect ((lets) + (rlets) + (inits) + (dynamic-extent-names)) + (let* ((rtype (parse-foreign-type result-spec)) + (fp-regs-form nil)) + (flet ((set-fp-regs-form () + (unless fp-regs-form + (setq fp-regs-form `(%get-ptr ,stack-ptr ,(- ppc64::c-frame.unused-1 ppc64::c-frame.param0)))))) + (when (typep rtype 'foreign-record-type) + (setq argvars (cons struct-result-name argvars) + argspecs (cons :address argspecs) + rtype *void-foreign-type*)) + (when (typep rtype 'foreign-float-type) + (set-fp-regs-form)) + (do* ((argvars argvars (cdr argvars)) + (argspecs argspecs (cdr argspecs)) + (fp-arg-num 0) + (offset 0 (+ offset delta)) + (delta 8 8) + (bias 0 0) + (use-fp-args nil nil)) + ((null argvars) + (values (rlets) (lets) (dynamic-extent-names) (inits) rtype fp-regs-form (- ppc64::c-frame.savelr ppc64::c-frame.param0))) + (let* ((name (car argvars)) + (spec (car argspecs)) + (argtype (parse-foreign-type spec)) + (bits (ensure-foreign-type-bits argtype))) + (if (and (typep argtype 'foreign-record-type) + (< bits 64)) + (progn + (when name (rlets (list name (foreign-record-type-name argtype)))) + (when name (inits `(setf (%%get-unsigned-longlong ,name 0) + (ash (%%get-unsigned-longlong ,stack-ptr ,offset) + ,(- 64 bits)))))) + (let* ((access-form + `(,(cond + ((typep argtype 'foreign-single-float-type) + (if (< (incf fp-arg-num) 14) + (progn + (setq use-fp-args t) + '%get-single-float-from-double-ptr) + (progn + (setq bias 4) + '%get-single-float))) + ((typep argtype 'foreign-double-float-type) + (if (< (incf fp-arg-num) 14) + (setq use-fp-args t)) + '%get-double-float) + ((and (typep argtype 'foreign-integer-type) + (= (foreign-integer-type-bits argtype) 64) + (foreign-integer-type-signed argtype)) + '%%get-signed-longlong) + ((and (typep argtype 'foreign-integer-type) + (= (foreign-integer-type-bits argtype) 64) + (not (foreign-integer-type-signed argtype))) + '%%get-unsigned-longlong) + ((or (typep argtype 'foreign-pointer-type) + (typep argtype 'foreign-array-type)) + '%get-ptr) + ((typep argtype 'foreign-record-type) + (setq delta (* (ceiling bits 64) 8)) + '%inc-ptr) + (t + (cond ((typep argtype 'foreign-integer-type) + (let* ((bits (foreign-integer-type-bits argtype)) + (signed (foreign-integer-type-signed argtype))) + (cond ((<= bits 8) + (setq bias 7) + (if signed + '%get-signed-byte ' + '%get-unsigned-byte)) + ((<= bits 16) + (setq bias 6) + (if signed + '%get-signed-word + '%get-unsigned-word)) + ((<= bits 32) + (setq bias 4) + (if signed + '%get-signed-long + '%get-unsigned-long)) + (t + (error "Don't know how to access foreign argument of type ~s" (unparse-foreign-type argtype)))))) + (t + (error "Don't know how to access foreign argument of type ~s" (unparse-foreign-type argtype)))))) + ,(if use-fp-args fp-args-ptr stack-ptr) + ,(if use-fp-args (* 8 (1- fp-arg-num)) + `(+ ,offset ,bias))))) + (when name (lets (list name access-form))) + #+nil + (when (eq spec :address) + (dynamic-extent-names name)) + (when use-fp-args (set-fp-regs-form)))))))))) + + +;;; All structures are "returned" via the implicit first argument; we'll have +;;; already translated the return type to :void in that case. +(defun linux64::generate-callback-return-value (stack-ptr fp-args-ptr result return-type struct-return-arg) + (declare (ignore struct-return-arg)) + (unless (eq return-type *void-foreign-type*) + (when (typep return-type 'foreign-single-float-type) + (setq result `(float ,result 0.0d0))) + (let* ((return-type-keyword (foreign-type-to-representation-type return-type)) + (result-ptr (case return-type-keyword + ((:single-float :double-float) + fp-args-ptr) + (t stack-ptr)))) + `(setf (, + (case return-type-keyword + (:address '%get-ptr) + (:signed-doubleword '%%get-signed-longlong) + (:unsigned-doubleword '%%get-unsigned-longlong) + ((:double-float :single-float) + (setq stack-ptr `(%get-ptr ,stack-ptr ,(- ppc64::c-frame.unused-1 ppc64::c-frame.param0))) + '%get-double-float) + (t '%%get-signed-longlong ) + ) ,result-ptr 0) ,result)))) Index: /branches/new-random/lib/ffi-linuxx8632.lisp =================================================================== --- /branches/new-random/lib/ffi-linuxx8632.lisp (revision 13309) +++ /branches/new-random/lib/ffi-linuxx8632.lisp (revision 13309) @@ -0,0 +1,28 @@ +;;; Copyright 2009 Clozure Associates +;;; This file is part of Clozure CL. +;;; +;;; Clozure CL is licensed under the terms of the Lisp Lesser GNU +;;; Public License , known as the LLGPL and distributed with Clozure +;;; CL as the file "LICENSE". The LLGPL consists of a preamble and +;;; the LGPL, which is distributed with Clozure CL as the file "LGPL". +;;; Where these conflict, the preamble takes precedence. +;;; +;;; Clozure CL is referenced in the preamble as the "LIBRARY." +;;; +;;; The LLGPL is also available online at +;;; http://opensource.franz.com/preamble.html + +(in-package "CCL") + +(defun x86-linux32::record-type-returns-structure-as-first-arg (rtype) + (x8632::record-type-returns-structure-as-first-arg rtype)) + +(defun x86-linux32::expand-ff-call (callform args &key (arg-coerce #'null-coerce-foreign-arg) (result-coerce #'null-coerce-foreign-result)) + (x8632::expand-ff-call callform args :arg-coerce arg-coerce :result-coerce result-coerce)) + +(defun x86-linux32::generate-callback-bindings (stack-ptr fp-args-ptr argvars argspecs result-spec struct-result-name) + (x8632::generate-callback-bindings stack-ptr fp-args-ptr argvars argspecs result-spec struct-result-name)) + +(defun x86-linux32::generate-callback-return-value (stack-ptr fp-args-ptr result return-type struct-return-arg) + (x8632::generate-callback-return-value stack-ptr fp-args-ptr result return-type struct-return-arg)) + Index: /branches/new-random/lib/ffi-linuxx8664.lisp =================================================================== --- /branches/new-random/lib/ffi-linuxx8664.lisp (revision 13309) +++ /branches/new-random/lib/ffi-linuxx8664.lisp (revision 13309) @@ -0,0 +1,36 @@ +;;;-*- Mode: Lisp; Package: CCL -*- +;;; +;;; Copyright (C) 2007-2009 Clozure Associates and contributors +;;; This file is part of Clozure CL. +;;; +;;; Clozure CL is licensed under the terms of the Lisp Lesser GNU Public +;;; License , known as the LLGPL and distributed with Clozure CL as the +;;; file "LICENSE". The LLGPL consists of a preamble and the LGPL, +;;; which is distributed with Clozure CL as the file "LGPL". Where these +;;; conflict, the preamble takes precedence. +;;; +;;; Clozure CL is referenced in the preamble as the "LIBRARY." +;;; +;;; The LLGPL is also available online at +;;; http://opensource.franz.com/preamble.html + + +(in-package "CCL") + +;;; It looks like x86-64 Linux, FreeBSD, and Darwin all share the same +;;; ABI. + +(defun x86-linux64::record-type-returns-structure-as-first-arg (rtype) + (x8664::record-type-returns-structure-as-first-arg rtype)) + + + +(defun x86-linux64::expand-ff-call (callform args &key (arg-coerce #'null-coerce-foreign-arg) (result-coerce #'null-coerce-foreign-result)) + (x8664::expand-ff-call callform args :arg-coerce arg-coerce :result-coerce result-coerce)) + + +(defun x86-linux64::generate-callback-bindings (stack-ptr fp-args-ptr argvars argspecs result-spec struct-return-name) + (x8664::generate-callback-bindings stack-ptr fp-args-ptr argvars argspecs result-spec struct-return-name)) + +(defun x86-linux64::generate-callback-return-value (stack-ptr fp-args-ptr result return-type struct-return-arg) + (x8664::generate-callback-return-value stack-ptr fp-args-ptr result return-type struct-return-arg)) Index: /branches/new-random/lib/ffi-solarisx8632.lisp =================================================================== --- /branches/new-random/lib/ffi-solarisx8632.lisp (revision 13309) +++ /branches/new-random/lib/ffi-solarisx8632.lisp (revision 13309) @@ -0,0 +1,27 @@ +;;; Copyright 2009 Clozure Associates +;;; This file is part of Clozure CL. +;;; +;;; Clozure CL is licensed under the terms of the Lisp Lesser GNU +;;; Public License , known as the LLGPL and distributed with Clozure +;;; CL as the file "LICENSE". The LLGPL consists of a preamble and +;;; the LGPL, which is distributed with Clozure CL as the file "LGPL". +;;; Where these conflict, the preamble takes precedence. +;;; +;;; Clozure CL is referenced in the preamble as the "LIBRARY." +;;; +;;; The LLGPL is also available online at +;;; http://opensource.franz.com/preamble.html + +(in-package "CCL") + +(defun x86-solaris32::record-type-returns-structure-as-first-arg (rtype) + (x8632::record-type-returns-structure-as-first-arg rtype)) + +(defun x86-solaris32::expand-ff-call (callform args &key (arg-coerce #'null-coerce-foreign-arg) (result-coerce #'null-coerce-foreign-result)) + (x8632::expand-ff-call callform args :arg-coerce arg-coerce :result-coerce result-coerce)) + +(defun x86-solaris32::generate-callback-bindings (stack-ptr fp-args-ptr argvars argspecs result-spec struct-result-name) + (x8632::generate-callback-bindings stack-ptr fp-args-ptr argvars argspecs result-spec struct-result-name)) + +(defun x86-solaris32::generate-callback-return-value (stack-ptr fp-args-ptr result return-type struct-return-arg) + (x8632::generate-callback-return-value stack-ptr fp-args-ptr result return-type struct-return-arg)) Index: /branches/new-random/lib/ffi-solarisx8664.lisp =================================================================== --- /branches/new-random/lib/ffi-solarisx8664.lisp (revision 13309) +++ /branches/new-random/lib/ffi-solarisx8664.lisp (revision 13309) @@ -0,0 +1,36 @@ +;;;-*- Mode: Lisp; Package: CCL -*- +;;; +;;; Copyright (C) 2008-2009 Clozure Associates and contributors +;;; This file is part of Clozure CL. +;;; +;;; Clozure CL is licensed under the terms of the Lisp Lesser GNU Public +;;; License , known as the LLGPL and distributed with Clozure CL as the +;;; file "LICENSE". The LLGPL consists of a preamble and the LGPL, +;;; which is distributed with Clozure CL as the file "LGPL". Where these +;;; conflict, the preamble takes precedence. +;;; +;;; Clozure CL is referenced in the preamble as the "LIBRARY." +;;; +;;; The LLGPL is also available online at +;;; http://opensource.franz.com/preamble.html + + +(in-package "CCL") + +;;; It looks like x86-64 Linux, FreeBSD, Darwin, and Solaris all share +;;; the same ABI. + +(defun x86-solaris64::record-type-returns-structure-as-first-arg (rtype) + (x8664::record-type-returns-structure-as-first-arg rtype)) + + + +(defun x86-solaris64::expand-ff-call (callform args &key (arg-coerce #'null-coerce-foreign-arg) (result-coerce #'null-coerce-foreign-result)) + (x8664::expand-ff-call callform args :arg-coerce arg-coerce :result-coerce result-coerce)) + + +(defun x86-solaris64::generate-callback-bindings (stack-ptr fp-args-ptr argvars argspecs result-spec struct-return-name) + (x8664::generate-callback-bindings stack-ptr fp-args-ptr argvars argspecs result-spec struct-return-name)) + +(defun x86-solaris64::generate-callback-return-value (stack-ptr fp-args-ptr result return-type struct-return-arg) + (x8664::generate-callback-return-value stack-ptr fp-args-ptr result return-type struct-return-arg)) Index: /branches/new-random/lib/ffi-win32.lisp =================================================================== --- /branches/new-random/lib/ffi-win32.lisp (revision 13309) +++ /branches/new-random/lib/ffi-win32.lisp (revision 13309) @@ -0,0 +1,38 @@ +;;; Copyright 2009 Clozure Associates +;;; This file is part of Clozure CL. +;;; +;;; Clozure CL is licensed under the terms of the Lisp Lesser GNU +;;; Public License , known as the LLGPL and distributed with Clozure +;;; CL as the file "LICENSE". The LLGPL consists of a preamble and +;;; the LGPL, which is distributed with Clozure CL as the file "LGPL". +;;; Where these conflict, the preamble takes precedence. +;;; +;;; Clozure CL is referenced in the preamble as the "LIBRARY." +;;; +;;; The LLGPL is also available online at +;;; http://opensource.franz.com/preamble.html + +(in-package "CCL") + +;;; Cygwin compiler returns small structures in registers +;;; (just like on Darwin, apparently). +(defun win32::record-type-returns-structure-as-first-arg (rtype) + (when (and rtype + (not (typep rtype 'unsigned-byte)) + (not (member rtype *foreign-representation-type-keywords* + :test #'eq))) + (let* ((ftype (if (typep rtype 'foreign-type) + rtype + (parse-foreign-type rtype))) + (nbits (ensure-foreign-type-bits ftype))) + (not (member nbits '(8 16 32 64)))))) + +(defun win32::expand-ff-call (callform args &key (arg-coerce #'null-coerce-foreign-arg) (result-coerce #'null-coerce-foreign-result)) + (x8632::expand-ff-call callform args :arg-coerce arg-coerce :result-coerce result-coerce)) + +(defun win32::generate-callback-bindings (stack-ptr fp-args-ptr argvars argspecs result-spec struct-result-name) + (x8632::generate-callback-bindings stack-ptr fp-args-ptr argvars argspecs result-spec struct-result-name)) + +(defun win32::generate-callback-return-value (stack-ptr fp-args-ptr result return-type struct-return-arg) + (x8632::generate-callback-return-value stack-ptr fp-args-ptr result return-type struct-return-arg)) + Index: /branches/new-random/lib/ffi-win64.lisp =================================================================== --- /branches/new-random/lib/ffi-win64.lisp (revision 13309) +++ /branches/new-random/lib/ffi-win64.lisp (revision 13309) @@ -0,0 +1,183 @@ +;;;-*- Mode: Lisp; Package: CCL -*- +;;; +;;; Copyright (C) 2007-2009 Clozure Associates and contributors +;;; This file is part of Clozure CL. +;;; +;;; Clozure CL is licensed under the terms of the Lisp Lesser GNU Public +;;; License , known as the LLGPL and distributed with Clozure CL as the +;;; file "LICENSE". The LLGPL consists of a preamble and the LGPL, +;;; which is distributed with Clozure CL as the file "LGPL". Where these +;;; conflict, the preamble takes precedence. +;;; +;;; Clozure CL is referenced in the preamble as the "LIBRARY." +;;; +;;; The LLGPL is also available online at +;;; http://opensource.franz.com/preamble.html + +(in-package "CCL") + +;;; Win64: +;;; Structures are never actually passed by value; the caller +;;; instead passes a pointer to the structure or a copy of it. +;;; +(defun win64::record-type-returns-structure-as-first-arg (rtype) + (when (and rtype + (not (typep rtype 'unsigned-byte)) + (not (member rtype *foreign-representation-type-keywords* + :test #'eq))) + (let* ((ftype (if (typep rtype 'foreign-type) + rtype + (parse-foreign-type rtype)))) + (and (typep ftype 'foreign-record-type) + (> (ensure-foreign-type-bits ftype) 64))))) + + +(defun win64::expand-ff-call (callform args &key (arg-coerce #'null-coerce-foreign-arg) (result-coerce #'null-coerce-foreign-result)) + (let* ((result-type-spec (or (car (last args)) :void)) + (enclosing-form nil) + (result-form nil)) + (multiple-value-bind (result-type error) + (ignore-errors (parse-foreign-type result-type-spec)) + (if error + (setq result-type-spec :void result-type *void-foreign-type*) + (setq args (butlast args))) + (collect ((argforms)) + (when (eq (car args) :monitor-exception-ports) + (argforms (pop args))) + (when (typep result-type 'foreign-record-type) + (setq result-form (pop args)) + (if (win64::record-type-returns-structure-as-first-arg result-type) + (progn + (setq result-type *void-foreign-type* + result-type-spec :void) + (argforms :address) + (argforms result-form)) + ;; This only happens in the SVR4 ABI. + (progn + (setq result-type (parse-foreign-type :unsigned-doubleword) + result-type-spec :unsigned-doubleword + enclosing-form `(setf (%%get-unsigned-longlong ,result-form 0)))))) + (unless (evenp (length args)) + (error "~s should be an even-length list of alternating foreign types and values" args)) + (do* ((args args (cddr args))) + ((null args)) + (let* ((arg-type-spec (car args)) + (arg-value-form (cadr args))) + (if (or (member arg-type-spec *foreign-representation-type-keywords* + :test #'eq) + (typep arg-type-spec 'unsigned-byte)) + (progn + (argforms arg-type-spec) + (argforms arg-value-form)) + (let* ((ftype (parse-foreign-type arg-type-spec))) + (if (typep ftype 'foreign-record-type) + (progn + (argforms :address) + (argforms arg-value-form)) + (progn + (argforms (foreign-type-to-representation-type ftype)) + (argforms (funcall arg-coerce arg-type-spec arg-value-form)))))))) + (argforms (foreign-type-to-representation-type result-type)) + (let* ((call (funcall result-coerce result-type-spec `(,@callform ,@(argforms))))) + (if enclosing-form + `(,@enclosing-form ,call) + call)))))) + +;;; Return 7 values: +;;; A list of RLET bindings +;;; A list of LET* bindings +;;; A list of DYNAMIC-EXTENT declarations for the LET* bindings +;;; A list of initializaton forms for (some) structure args +;;; A FOREIGN-TYPE representing the "actual" return type. +;;; A form which can be used to initialize FP-ARGS-PTR, relative +;;; to STACK-PTR. +;;; The byte offset of the foreign return address, relative to STACK-PTR +(defun win64::generate-callback-bindings (stack-ptr fp-args-ptr argvars argspecs result-spec struct-result-name) + (declare (ignore fp-args-ptr)) + (collect ((lets) + (rlets) + (inits)) + (let* ((rtype (parse-foreign-type result-spec))) + (when (typep rtype 'foreign-record-type) + (if (win64::record-type-returns-structure-as-first-arg rtype) + (setq argvars (cons struct-result-name argvars) + argspecs (cons :address argspecs) + rtype :address) + (rlets (list struct-result-name (foreign-record-type-name rtype))))) + (do* ((argvars argvars (cdr argvars)) + (argspecs argspecs (cdr argspecs)) + (arg-num 0) + (gpr-arg-offset -8) + (fpr-arg-offset -40) + (memory-arg-offset 48) + (fp nil nil)) + ((null argvars) + (values (rlets) (lets) nil (inits) rtype nil 8)) + (flet ((next-gpr () + (if (<= (incf arg-num) 4) + (prog1 + gpr-arg-offset + (decf gpr-arg-offset 8) + (decf fpr-arg-offset 8)) + (prog1 + memory-arg-offset + (incf memory-arg-offset 8)))) + (next-fpr () + (if (<= (incf arg-num) 4) + (prog1 + fpr-arg-offset + (decf fpr-arg-offset 8) + (decf gpr-arg-offset 8)) + (prog1 + memory-arg-offset + (incf memory-arg-offset 8))))) + (let* ((name (car argvars)) + (spec (car argspecs)) + (argtype (parse-foreign-type spec))) + (if (typep argtype 'foreign-record-type) + (setq argtype :address)) + (let* ((access-form + `(, + (ecase (foreign-type-to-representation-type argtype) + (:single-float (setq fp t) '%get-single-float) + (:double-float (setq fp t) '%get-double-float) + (:signed-doubleword '%%get-signed-longlong) + (:signed-fullword '%get-signed-long) + (:signed-halfword '%get-signed-word) + (:signed-byte '%get-signed-byte) + (:unsigned-doubleword '%%get-unsigned-longlong) + (:unsigned-fullword '%get-unsigned-long) + (:unsigned-halfword '%get-unsigned-word) + (:unsigned-byte '%get-unsigned-byte) + (:address + #+nil + (dynamic-extent-names name) + '%get-ptr)) + ,stack-ptr + ,(if fp (next-fpr) (next-gpr))))) + (when name (lets (list name access-form)))))))))) + +(defun win64::generate-callback-return-value (stack-ptr fp-args-ptr result return-type struct-return-arg) + (declare (ignore fp-args-ptr)) + (unless (eq return-type *void-foreign-type*) + (when (typep return-type 'foreign-single-float-type) + (setq result `(float ,result 0.0d0))) + (let* ((return-type-keyword + (if (typep return-type 'foreign-record-type) + (progn + (setq result `(%%get-unsigned-longlong ,struct-return-arg 0)) + :unsigned-doubleword) + (foreign-type-to-representation-type return-type))) + (offset (case return-type-keyword + ((:single-float :double-float) + -24) + (t -8)))) + `(setf (, + (case return-type-keyword + (:address '%get-ptr) + (:signed-doubleword '%%get-signed-longlong) + (:unsigned-doubleword '%%get-unsigned-longlong) + ((:double-float :single-float) '%get-double-float) + (t '%get-long)) ,stack-ptr ,offset) ,result)))) + + Index: /branches/new-random/lib/foreign-types.lisp =================================================================== --- /branches/new-random/lib/foreign-types.lisp (revision 13309) +++ /branches/new-random/lib/foreign-types.lisp (revision 13309) @@ -0,0 +1,1956 @@ +;;;-*-Mode: LISP; Package: CCL -*- +;;; +;;; Copyright (C) 2001-2009 Clozure Associates +;;; This file is part of Clozure CL. +;;; +;;; Clozure CL is licensed under the terms of the Lisp Lesser GNU Public +;;; License , known as the LLGPL and distributed with Clozure CL as the +;;; file "LICENSE". The LLGPL consists of a preamble and the LGPL, +;;; which is distributed with Clozure CL as the file "LGPL". Where these +;;; conflict, the preamble takes precedence. +;;; +;;; Clozure CL is referenced in the preamble as the "LIBRARY." +;;; +;;; The LLGPL is also available online at +;;; http://opensource.franz.com/preamble.html + +;;; This is a slightly-watered-down version of CMUCL's ALIEN-TYPE system. + +(in-package "CCL") + +(defstruct (interface-dir + (:include dll-node) + ) + (name) + (subdir) + (constants-interface-db-file) + (functions-interface-db-file) + (records-interface-db-file) + (types-interface-db-file) + (vars-interface-db-file) + (objc-classes-interface-db-file) + (objc-methods-interface-db-file)) + +(defmethod print-object ((d interface-dir) stream) + (print-unreadable-object (d stream :type t :identity t) + (format stream "~s ~s" + (interface-dir-name d) + (interface-dir-subdir d)))) + +;;; We can't reference foreign types early in the cold load, +;;; but we want things like RLET to be able to set a pointer's +;;; type based on the foreign-type's "ordinal". We therefore +;;; seem to have to arrange that certain types have fixed, +;;; "canonical" ordinals. I doubt if we need more than a handful +;;; of these, but let's burn 100 + +(defconstant max-canonical-foreign-type-ordinal 100) + +;;; Some foreign types are "common" (POSIXy things that're available +;;; on most platforms; some are very platform-specific. It's getting +;;; to be a mess to keep those separate by reader conditionalization, +;;; so use the first 50 ordinals for "common" foreign types and the +;;; next 50 for platform-specific stuff. + +(defconstant max-common-foreign-type-ordinal 50) + +;;; This is intended to try to encapsulate foreign type stuff, to +;;; ease cross-compilation (among other things.) + +(defstruct (foreign-type-data (:conc-name ftd-) + (:constructor make-ftd)) + (translators (make-hash-table :test #'eq)) + (kind-info (make-hash-table :test #'eq)) + (definitions (make-hash-table :test #'eq)) + (struct-definitions (make-hash-table :test #'eq)) + (union-definitions (make-hash-table :test #'eq)) + ;; Do we even use this ? + (enum-definitions (make-hash-table :test #'eq)) + (interface-db-directory ()) + (interface-package-name ()) + (external-function-definitions (make-hash-table :test #'eq)) + (dirlist (make-dll-header)) + (attributes ()) + (ff-call-expand-function ()) + (ff-call-struct-return-by-implicit-arg-function ()) + (callback-bindings-function ()) + (callback-return-value-function ()) + (ordinal max-canonical-foreign-type-ordinal) + (ordinal-lock (make-lock)) + (ordinal-types (make-hash-table :test #'eq :weak :value)) + (pointer-types (make-hash-table :test #'eq)) + (array-types (make-hash-table :test #'equal)) + (platform-ordinal-types ())) + + + + +(defvar *host-ftd* (make-ftd + :interface-db-directory + #.(ecase (backend-name *target-backend*) + (:linuxppc32 "ccl:headers;") + (:darwinppc32 "ccl:darwin-headers;") + (:darwinppc64 "ccl:darwin-headers64;") + (:linuxppc64 "ccl:headers64;") + (:darwinx8632 "ccl:darwin-x86-headers;") + (:linuxx8664 "ccl:x86-headers64;") + (:darwinx8664 "ccl:darwin-x86-headers64;") + (:freebsdx8664 "ccl:freebsd-headers64;") + (:solarisx8664 "ccl:solarisx64-headers;") + (:win64 "ccl:win64-headers;") + (:linuxx8632 "ccl:x86-headers;") + (:win32 "ccl:win32-headers;") + (:solarisx8632 "ccl:solarisx86-headers;") + (:freebsdx8632 "ccl:freebsd-headers;")) + :interface-package-name + #.(ftd-interface-package-name *target-ftd*) + :attributes + '(:bits-per-word #+64-bit-target 64 #+32-bit-target 32 + #+win64-target :bits-per-long #+win64-target 32 + :signed-char #+darwinppc-target t #-darwinppc-target nil + :struct-by-value #+darwinppc-target t #-darwinppc-target nil + :struct-return-in-registers #+(or (and darwinppc-target 64-bit-target)) t #-(or (and darwinppc-target 64-bit-target)) nil + :struct-return-explicit #+(or (and darwinppc-target 64-bit-target)) t #-(or (and darwinppc-target 64-bit-target)) nil + :struct-by-value-by-field #+(or (and darwinppc-target 64-bit-target)) t #-(or (and darwinppc-target 64-bit-target)) nil + + :prepend-underscores #+darwinppc-target t #-darwinppc-target nil) + :ff-call-expand-function + 'os::expand-ff-call + :ff-call-struct-return-by-implicit-arg-function + 'os::record-type-returns-structure-as-first-arg + :callback-bindings-function + 'os::generate-callback-bindings + :callback-return-value-function + 'os::generate-callback-return-value + :platform-ordinal-types + (case (backend-name *target-backend*) + (:win64 '((:struct :_stat64))) + (:win32 '((:struct :__stat64))) + (t + (case (target-os-name *target-backend*) + (:darwin '((:struct :host_basic_info))) + (:solaris '((:struct :lifnum) + (:struct :lifconf))) + (t ())))))) + +(defvar *target-ftd* *host-ftd*) +(setf (backend-target-foreign-type-data *host-backend*) + *host-ftd*) + +(defun next-foreign-type-ordinal (&optional (ftd *target-ftd*)) + (with-lock-grabbed ((ftd-ordinal-lock ftd)) + (incf (ftd-ordinal ftd)))) + + +(defmacro do-interface-dirs ((dir &optional (ftd '*target-ftd*)) &body body) + `(do-dll-nodes (,dir (ftd-dirlist ,ftd)) + ,@body)) + +(defun find-interface-dir (name &optional (ftd *target-ftd*)) + (do-interface-dirs (d ftd) + (when (eq name (interface-dir-name d)) + (return d)))) + +(defun require-interface-dir (name &optional (ftd *target-ftd*)) + (or (find-interface-dir name ftd) + (error "Interface directory ~s not found" name))) + +(defun ensure-interface-dir (name &optional (ftd *target-ftd*)) + (or (find-interface-dir name ftd) + (let* ((d (make-interface-dir + :name name + :subdir (make-pathname + :directory + `(:relative ,(string-downcase name)))))) + (append-dll-node d (ftd-dirlist ftd))))) + +(defun use-interface-dir (name &optional (ftd *target-ftd*)) + "Tell Clozure CL to add the interface directory denoted by dir-id to the +list of interface directories which it consults for foreign type and +function information. Arrange that that directory is searched before any +others. + +Note that use-interface-dir merely adds an entry to a search list. If the +named directory doesn't exist in the file system or doesn't contain a set +of database files, a runtime error may occur when Clozure CL tries to open some +database file in that directory, and it will try to open such a database +file whenever it needs to find any foreign type or function information. +unuse-interface-dir may come in handy in that case." + (let* ((d (ensure-interface-dir name ftd))) + (move-dll-nodes d (ftd-dirlist ftd)) + d)) + +(defun unuse-interface-dir (name &optional (ftd *target-ftd*)) + "Tell Clozure CL to remove the interface directory denoted by dir-id from +the list of interface directories which are consulted for foreign type +and function information. Returns T if the directory was on the search +list, NIL otherwise." + (let* ((d (find-interface-dir name ftd))) + (when d + (remove-dll-node d) + t))) + + +(use-interface-dir :libc) + + + +;;;; Utility functions. + +(eval-when (:compile-toplevel :load-toplevel :execute) + (defun align-offset (offset alignment) + (let ((extra (rem offset alignment))) + (if (zerop extra) offset (+ offset (- alignment extra))))) + + (defun guess-alignment (bits) + (cond ((null bits) nil) + ((> bits 32) 64) + ((> bits 16) 32) + ((> bits 8) 16) + ((= bits 8) 8) + (t 1))) + + (defstruct foreign-type-class + (name nil #|:type symbol|#) + (include nil :type (or null foreign-type-class)) + (unparse nil :type (or null function)) + (type= nil :type (or null function)) + (lisp-rep nil :type (or null function)) + (foreign-rep nil :type (or null function)) + (extract-gen nil :type (or null function)) + (deposit-gen nil :type (or null function)) + (naturalize-gen nil :type (or null function)) + (deport-gen nil :type (or null function)) + ;; Cast? + (arg-tn nil :type (or null function)) + (result-tn nil :type (or null function)) + (subtypep nil :type (or null function))) + + (defvar *foreign-type-classes* (make-hash-table :test #'eq)) + + (defun info-foreign-type-translator (x &optional (ftd *target-ftd*)) + (gethash (make-keyword x) (ftd-translators ftd))) + (defun (setf info-foreign-type-translator) (val x &optional (ftd *target-ftd*)) + (setf (gethash (make-keyword x) (ftd-translators ftd)) val)) + + (defun note-foreign-type-ordinal (type ftd) + (let* ((ordinal (and type (foreign-type-ordinal type)))) + (when (and ordinal (not (eql 0 ordinal))) + (with-lock-grabbed ((ftd-ordinal-lock ftd)) + (setf (gethash ordinal (ftd-ordinal-types ftd)) type))))) + + (defun info-foreign-type-kind (x &optional (ftd *target-ftd*)) + (if (info-foreign-type-translator x ftd) + :primitive + (or (gethash (make-keyword x) (ftd-kind-info ftd)) :unknown))) + (defun (setf info-foreign-type-kind) (val x &optional (ftd *target-ftd*)) + (setf (gethash (make-keyword x) (ftd-kind-info ftd)) val)) + + (defun info-foreign-type-definition (x &optional (ftd *target-ftd*)) + (gethash (make-keyword x) (ftd-definitions ftd))) + (defun (setf info-foreign-type-definition) (val x &optional (ftd *target-ftd*)) + (note-foreign-type-ordinal val ftd) + (setf (gethash (make-keyword x) (ftd-definitions ftd)) val)) + (defun clear-info-foreign-type-definition (x &optional (ftd *target-ftd*)) + (remhash (make-keyword x) (ftd-definitions ftd))) + + (defun info-foreign-type-struct (x &optional (ftd *target-ftd*)) + (gethash (make-keyword x) (ftd-struct-definitions ftd))) + (defun (setf info-foreign-type-struct) (val x &optional (ftd *target-ftd*)) + (let* ((name (make-keyword x))) + (when (gethash name (ftd-union-definitions ftd)) + (cerror "Define ~s as a struct type" + "~s is already defined as a union type" + name) + (remhash name (ftd-union-definitions ftd))) + (note-foreign-type-ordinal val ftd) + (setf (gethash name (ftd-struct-definitions ftd)) val))) + + (defun info-foreign-type-union (x &optional (ftd *target-ftd*)) + (gethash (make-keyword x) (ftd-union-definitions ftd))) + (defun (setf info-foreign-type-union) (val x &optional (ftd *target-ftd*)) + (let* ((name (make-keyword x))) + (when (gethash name (ftd-struct-definitions ftd)) + (cerror "Define ~s as a union type" + "~s is already defined as a struct type" + name) + (remhash name (ftd-struct-definitions ftd))) + (note-foreign-type-ordinal val ftd) + (setf (gethash name (ftd-union-definitions ftd)) val))) + + (defun info-foreign-type-enum (x &optional (ftd *target-ftd*)) + (gethash (make-keyword x) (ftd-enum-definitions ftd))) + (defun (setf info-foreign-type-enum) (val x &optional (ftd *target-ftd*)) + (note-foreign-type-ordinal val ftd) + (setf (gethash (make-keyword x) (ftd-enum-definitions ftd)) val)) + + (defun require-foreign-type-class (name) + (or (gethash name *foreign-type-classes*) + (error "Unknown foreign type class ~s" name))) + + (defun find-or-create-foreign-type-class (name include) + (let* ((old (gethash name *foreign-type-classes*)) + (include-class (if include (require-foreign-type-class include)))) + (if old + (setf (foreign-type-class-name old) include-class) + (setf (gethash name *foreign-type-classes*) + (make-foreign-type-class :name name :include include-class))))) + + + (defconstant method-slot-alist + '((:unparse . foreign-type-class-unparse) + (:type= . foreign-type-class-type=) + (:subtypep . foreign-type-class-subtypep) + (:lisp-rep . foreign-type-class-lisp-rep) + (:foreign-rep . foreign-type-class-foreign-rep) + (:extract-gen . foreign-type-class-extract-gen) + (:deposit-gen . foreign-type-class-deposit-gen) + (:naturalize-gen . foreign-type-class-naturalize-gen) + (:deport-gen . foreign-type-class-deport-gen) + ;; Cast? + (:arg-tn . foreign-type-class-arg-tn) + (:result-tn . foreign-type-class-result-tn))) + + (defun method-slot (method) + (cdr (or (assoc method method-slot-alist) + (error "No method ~S" method)))) + ) + +(defmethod print-object ((f foreign-type-class) out) + (print-unreadable-object (f out :type t :identity t) + (prin1 (foreign-type-class-name f) out))) + + +;;; We define a keyword "BOA" constructor so that we can reference the slots +;;; names in init forms. +;;; +(defmacro def-foreign-type-class ((name &key include include-args) &rest slots) + (let ((defstruct-name + (intern (concatenate 'string "FOREIGN-" (symbol-name name) "-TYPE")))) + (multiple-value-bind + (include include-defstruct overrides) + (etypecase include + (null + (values nil 'foreign-type nil)) + (symbol + (values + include + (intern (concatenate 'string + "FOREIGN-" (symbol-name include) "-TYPE")) + nil)) + (list + (values + (car include) + (intern (concatenate 'string + "FOREIGN-" (symbol-name (car include)) "-TYPE")) + (cdr include)))) + `(progn + (eval-when (:compile-toplevel :load-toplevel :execute) + (find-or-create-foreign-type-class ',name ',(or include 'root))) + (defstruct (,defstruct-name + (:include ,include-defstruct + (class ',name) + ,@overrides) + (:constructor + ,(intern (concatenate 'string "MAKE-" + (string defstruct-name))) + (&key class bits alignment + ,@(mapcar #'(lambda (x) + (if (atom x) x (car x))) + slots) + ,@include-args))) + ,@slots))))) + +(defmacro def-foreign-type-method ((class method) lambda-list &rest body) + (let ((defun-name (intern (concatenate 'string + (symbol-name class) + "-" + (symbol-name method) + "-METHOD")))) + `(progn + (defun ,defun-name ,lambda-list + ,@body) + (setf (,(method-slot method) (require-foreign-type-class ',class)) + #',defun-name)))) + +(defmacro invoke-foreign-type-method (method type &rest args) + (let ((slot (method-slot method))) + (once-only ((type type)) + `(funcall (do ((class (require-foreign-type-class (foreign-type-class ,type)) + (foreign-type-class-include class))) + ((null class) + (error "Method ~S not defined for ~S" + ',method (foreign-type-class ,type))) + (let ((fn (,slot class))) + (when fn + (return fn)))) + ,type ,@args)))) + + + +;;;; Foreign-type defstruct. + +(eval-when (:compile-toplevel :load-toplevel :execute) + (find-or-create-foreign-type-class 'root nil)) + +(defstruct (foreign-type + (:constructor make-foreign-type (&key class bits alignment ordinal)) + (:print-object + (lambda (s out) + (print-unreadable-object (s out :type t :identity t) + (prin1 (unparse-foreign-type s) out))))) + (class 'root :type symbol) + (bits nil :type (or null unsigned-byte)) + (alignment (guess-alignment bits) :type (or null unsigned-byte)) + (ordinal (next-foreign-type-ordinal))) + + + +(defmethod make-load-form ((s foreign-type) &optional env) + (if (eq s *void-foreign-type*) + '*void-foreign-type* + (make-load-form-saving-slots s :environment env))) + + + + + +;;;; Type parsing and unparsing. + +(defvar *auxiliary-type-definitions* nil) +(defvar *new-auxiliary-types*) + +;;; WITH-AUXILIARY-FOREIGN-TYPES -- internal. +;;; +;;; Process stuff in a new scope. +;;; +(defmacro with-auxiliary-foreign-types (&body body) + `(let ((*auxiliary-type-definitions* + (if (boundp '*new-auxiliary-types*) + (append *new-auxiliary-types* *auxiliary-type-definitions*) + *auxiliary-type-definitions*)) + (*new-auxiliary-types* nil)) + ,@body)) + +;;; PARSE-FOREIGN-TYPE -- public +;;; +(defun parse-foreign-type (type &optional (ftd *target-ftd*)) + "Parse the list structure TYPE as a foreign type specifier and return + the resultant foreign-type structure." + (if (boundp '*new-auxiliary-types*) + (%parse-foreign-type type ftd) + (let ((*new-auxiliary-types* nil)) + (%parse-foreign-type type ftd)))) + +(defun %parse-foreign-type (type &optional (ftd *target-ftd*)) + (if (consp type) + (let ((translator (info-foreign-type-translator (car type) ftd))) + (unless translator + (error "Unknown foreign type: ~S" type)) + (funcall translator type nil)) + (case (info-foreign-type-kind type) + (:primitive + (let ((translator (info-foreign-type-translator type ftd))) + (unless translator + (error "No translator for primitive foreign type ~S?" type)) + (funcall translator (list type) nil))) + (:defined + (or (info-foreign-type-definition type ftd) + (error "Definition missing for foreign type ~S?" type))) + (:unknown + (let* ((loaded (load-foreign-type type ftd))) + (if loaded + (setq type loaded))) + (or (info-foreign-type-definition type ftd) + (error "Unknown foreign type: ~S" type)))))) + +(defun auxiliary-foreign-type (kind name &optional (ftd *target-ftd*)) + (declare (ignore ftd)) + (flet ((aux-defn-matches (x) + (and (eq (first x) kind) (eq (second x) name)))) + (let ((in-auxiliaries + (or (find-if #'aux-defn-matches *new-auxiliary-types*) + (find-if #'aux-defn-matches *auxiliary-type-definitions*)))) + (if in-auxiliaries + (values (third in-auxiliaries) t))))) + +(defun %set-auxiliary-foreign-type (kind name defn &optional (ftd *target-ftd*)) + (declare (ignore ftd)) + (flet ((aux-defn-matches (x) + (and (eq (first x) kind) (eq (second x) name)))) + (when (find-if #'aux-defn-matches *new-auxiliary-types*) + (error "Attempt to multiple define ~A ~S." kind name)) + (when (find-if #'aux-defn-matches *auxiliary-type-definitions*) + (error "Attempt to shadow definition of ~A ~S." kind name))) + (push (list kind name defn) *new-auxiliary-types*) + defn) + +(defsetf auxiliary-foreign-type %set-auxiliary-foreign-type) + + +(defun ensure-foreign-type (x) + (if (typep x 'foreign-type) + x + (parse-foreign-type x))) + +;;; *record-type-already-unparsed* -- internal +;;; +;;; Holds the list of record types that have already been unparsed. This is +;;; used to keep from outputing the slots again if the same structure shows +;;; up twice. +;;; +(defvar *record-types-already-unparsed*) + +;;; UNPARSE-FOREIGN-TYPE -- public. +;;; +(defun unparse-foreign-type (type) + "Convert the foreign-type structure TYPE back into a list specification of + the type." + (declare (type foreign-type type)) + (let ((*record-types-already-unparsed* nil)) + (%unparse-foreign-type type))) + +;;; %UNPARSE-FOREIGN-TYPE -- internal. +;;; +;;; Does all the work of UNPARSE-FOREIGN-TYPE. It's seperate because we need +;;; to recurse inside the binding of *record-types-already-unparsed*. +;;; +(defun %unparse-foreign-type (type) + (invoke-foreign-type-method :unparse type)) + + + + + +;;;; Foreign type defining stuff. + +(defmacro def-foreign-type-translator (name lambda-list &body body &environment env) + (expand-type-macro '%def-foreign-type-translator name lambda-list body env)) + + +(defun %def-foreign-type-translator (name translator docs) + (declare (ignore docs)) + (setf (info-foreign-type-translator name) translator) + (clear-info-foreign-type-definition name) + #+nil + (setf (documentation name 'foreign-type) docs) + name) + + +(defmacro def-foreign-type (name type) + "If name is non-NIL, define name to be an alias for the foreign type +specified by foreign-type-spec. If foreign-type-spec is a named structure +or union type, additionally defines that structure or union type. + +If name is NIL, foreign-type-spec must be a named foreign struct or union +definition, in which case the foreign structure or union definition is put +in effect. + +Note that there are two separate namespaces for foreign type names, one for +the names of ordinary types and one for the names of structs and unions. +Which one name refers to depends on foreign-type-spec in the obvious manner." + (with-auxiliary-foreign-types + (let ((foreign-type (parse-foreign-type type))) + `(eval-when (:compile-toplevel :load-toplevel :execute) + ,@(when *new-auxiliary-types* + `((%def-auxiliary-foreign-types ',*new-auxiliary-types*))) + ,@(when name + `((%def-foreign-type ',name ',foreign-type))))))) + +(defun %def-auxiliary-foreign-types (types) + (dolist (info types) + (destructuring-bind (kind name defn) info + (macrolet ((frob (accessor) + `(let ((old (,accessor name))) + (unless (or (null old) (foreign-type-= old defn)) + (warn "Redefining ~A ~S to be:~% ~S,~%was:~% ~S" + kind name defn old)) + (setf (,accessor name) defn)))) + (ecase kind + (:struct (frob info-foreign-type-struct)) + (:union (frob info-foreign-type-union)) + (:enum (frob info-foreign-type-enum))))))) + +(defun %def-foreign-type (name new &optional (ftd *target-ftd*)) + (ecase (info-foreign-type-kind name ftd) + (:primitive + (error "~S is a built-in foreign type." name)) + (:defined + (let ((old (info-foreign-type-definition name ftd))) + (unless (or (null old) (foreign-type-= new old)) + (warn "Redefining ~S to be:~% ~S,~%was~% ~S" name + (unparse-foreign-type new) (unparse-foreign-type old))))) + (:unknown)) + (setf (info-foreign-type-definition name ftd) new) + (setf (info-foreign-type-kind name ftd) :defined) + name) + + + + +;;;; Interfaces to the different methods + +(defun foreign-type-= (type1 type2) + "Return T iff TYPE1 and TYPE2 describe equivalent foreign types." + (or (eq type1 type2) + (and (eq (foreign-type-class type1) + (foreign-type-class type2)) + (invoke-foreign-type-method :type= type1 type2)))) + +(defun foreign-subtype-p (type1 type2) + "Return T iff the foreign type TYPE1 is a subtype of TYPE2. Currently, the + only supported subtype relationships are is that any pointer type is a + subtype of (* t), and any array type first dimension will match + (array nil ...). Otherwise, the two types have to be + FOREIGN-TYPE-=." + (or (eq type1 type2) + (invoke-foreign-type-method :subtypep type1 type2))) + +(defun foreign-typep (object type) + "Return T iff OBJECT is a foreign of type TYPE." + (let ((lisp-rep-type (compute-lisp-rep-type type))) + (if lisp-rep-type + (typep object lisp-rep-type)))) + + +(defun compute-naturalize-lambda (type) + `(lambda (foreign ignore) + (declare (ignore ignore)) + ,(invoke-foreign-type-method :naturalize-gen type 'foreign))) + +(defun compute-deport-lambda (type) + (declare (type foreign-type type)) + (multiple-value-bind + (form value-type) + (invoke-foreign-type-method :deport-gen type 'value) + `(lambda (value ignore) + (declare (type ,(or value-type + (compute-lisp-rep-type type) + `(foreign ,type)) + value) + (ignore ignore)) + ,form))) + +(defun compute-extract-lambda (type) + `(lambda (sap offset ignore) + (declare (type system-area-pointer sap) + (type unsigned-byte offset) + (ignore ignore)) + (naturalize ,(invoke-foreign-type-method :extract-gen type 'sap 'offset) + ',type))) + +(defun compute-deposit-lambda (type) + (declare (type foreign-type type)) + `(lambda (sap offset ignore value) + (declare (type system-area-pointer sap) + (type unsigned-byte offset) + (ignore ignore)) + (let ((value (deport value ',type))) + ,(invoke-foreign-type-method :deposit-gen type 'sap 'offset 'value) + ;; Note: the reason we don't just return the pre-deported value + ;; is because that would inhibit any (deport (naturalize ...)) + ;; optimizations that might have otherwise happen. Re-naturalizing + ;; the value might cause extra consing, but is flushable, so probably + ;; results in better code. + (naturalize value ',type)))) + +(defun compute-lisp-rep-type (type) + (invoke-foreign-type-method :lisp-rep type)) + +(defun compute-foreign-rep-type (type) + (invoke-foreign-type-method :foreign-rep type)) + + + + + + +;;;; Default methods. + +(defvar *void-foreign-type* (make-foreign-type :class 'root :bits 0 :alignment 0 :ordinal 0)) + +(def-foreign-type-method (root :unparse) (type) + (if (eq type *void-foreign-type*) + :void + `(!!unknown-foreign-type!! ,(type-of type)))) + +(def-foreign-type-method (root :type=) (type1 type2) + (declare (ignore type1 type2)) + t) + +(def-foreign-type-method (root :subtypep) (type1 type2) + (foreign-type-= type1 type2)) + +(def-foreign-type-method (root :lisp-rep) (type) + (declare (ignore type)) + nil) + +(def-foreign-type-method (root :foreign-rep) (type) + (declare (ignore type)) + '*) + +(def-foreign-type-method (root :naturalize-gen) (type foreign) + (declare (ignore foreign)) + (error "Cannot represent ~S typed foreigns." type)) + +(def-foreign-type-method (root :deport-gen) (type object) + (declare (ignore object)) + (error "Cannot represent ~S typed foreigns." type)) + +(def-foreign-type-method (root :extract-gen) (type sap offset) + (declare (ignore sap offset)) + (error "Cannot represent ~S typed foreigns." type)) + +(def-foreign-type-method (root :deposit-gen) (type sap offset value) + `(setf ,(invoke-foreign-type-method :extract-gen type sap offset) ,value)) + +(def-foreign-type-method (root :arg-tn) (type state) + (declare (ignore state)) + (error "Cannot pass foreigns of type ~S as arguments to call-out" + (unparse-foreign-type type))) + +(def-foreign-type-method (root :result-tn) (type state) + (declare (ignore state)) + (error "Cannot return foreigns of type ~S from call-out" + (unparse-foreign-type type))) + + + + +;;;; The INTEGER type. + +(def-foreign-type-class (integer) + (signed t :type (member t nil))) + +(defvar *unsigned-integer-types* + (let* ((a (make-array 65))) + (dotimes (i 65 a) + (setf (svref a i) (make-foreign-integer-type :signed nil + :bits i + :alignment + (if (= 1 (logcount i)) + i + 1)))))) + +(defvar *signed-integer-types* + (let* ((a (make-array 65))) + (dotimes (i 65 a) + (setf (svref a i) (make-foreign-integer-type :signed t + :bits i + :alignment + (if (= 1 (logcount i)) + i + 1)))))) + + +(defvar *bool-type* (make-foreign-integer-type :bits 8 :signed #+darwin-target t #-darwin-target nil)) + + + +(def-foreign-type-method (integer :unparse) (type) + (if (eq type *bool-type*) + : + (let* ((bits (foreign-integer-type-bits type)) + (signed (foreign-integer-type-signed type)) + (alignment (foreign-integer-type-alignment type))) + (if (eql alignment 1) + (if (eql bits 1) + :bit + `(:bitfield ,bits)) + (list (if signed :signed :unsigned) bits))))) + +(def-foreign-type-method (integer :type=) (type1 type2) + (and (eq (foreign-integer-type-signed type1) + (foreign-integer-type-signed type2)) + (= (foreign-integer-type-bits type1) + (foreign-integer-type-bits type2)))) + +(def-foreign-type-method (integer :lisp-rep) (type) + (list (if (foreign-integer-type-signed type) 'signed-byte 'unsigned-byte) + (foreign-integer-type-bits type))) + +(def-foreign-type-method (integer :foreign-rep) (type) + (list (if (foreign-integer-type-signed type) 'signed-byte 'unsigned-byte) + (foreign-integer-type-bits type))) + +(def-foreign-type-method (integer :naturalize-gen) (type foreign) + (declare (ignore type)) + foreign) + +(def-foreign-type-method (integer :deport-gen) (type value) + (declare (ignore type)) + value) + +(def-foreign-type-method (integer :extract-gen) (type sap offset) + (declare (type foreign-integer-type type)) + (let ((ref-form + (if (foreign-integer-type-signed type) + (case (foreign-integer-type-bits type) + (8 `(%get-signed-byte ,sap (/ ,offset 8))) + (16 `(%get-signed-word ,sap (/ ,offset 8))) + (32 `(%get-signed-long ,sap (/ ,offset 8))) + (64 `(%%get-signed-longlong ,sap (/ ,offset 8)))) + (case (foreign-integer-type-bits type) + (1 `(%get-bit ,sap ,offset)) + (8 `(%get-unsigned-byte ,sap (/ ,offset 8))) + (16 `(%get-unsigned-word ,sap (/ ,offset 8))) + (32 `(%get-unsigned-long ,sap (/ ,offset 8))) + (64 `(%%get-unsigned-longlong ,sap (/ ,offset 8))) + (t `(%get-bitfield ,sap ,offset ,(foreign-integer-type-bits type))))))) + (or ref-form + (error "Cannot extract ~D bit integers." + (foreign-integer-type-bits type))))) + + + + +;;;; The BOOLEAN type. + +(def-foreign-type-class (boolean :include integer :include-args (signed))) + + + +(def-foreign-type-method (boolean :lisp-rep) (type) + (declare (ignore type)) + `(member t nil)) + +(def-foreign-type-method (boolean :naturalize-gen) (type foreign) + (declare (ignore type)) + `(not (zerop ,foreign))) + +(def-foreign-type-method (boolean :deport-gen) (type value) + (declare (ignore type)) + `(if ,value 1 0)) + + +(def-foreign-type-method (boolean :unparse) (type) + `(boolean ,(foreign-boolean-type-bits type))) + + + +;;;; the FLOAT types. + +(def-foreign-type-class (float) + (type () :type symbol)) + +(def-foreign-type-method (float :unparse) (type) + (foreign-float-type-type type)) + +(def-foreign-type-method (float :lisp-rep) (type) + (foreign-float-type-type type)) + +(def-foreign-type-method (float :foreign-rep) (type) + (foreign-float-type-type type)) + +(def-foreign-type-method (float :naturalize-gen) (type foreign) + (declare (ignore type)) + foreign) + +(def-foreign-type-method (float :deport-gen) (type value) + (declare (ignore type)) + value) + + +(def-foreign-type-class (single-float :include (float (bits 32)) + :include-args (type))) + + +(def-foreign-type-method (single-float :extract-gen) (type sap offset) + (declare (ignore type)) + `(%get-single-float ,sap (/ ,offset 8))) + + +(def-foreign-type-class (double-float :include (float (bits 64)) + :include-args (type))) + + +(def-foreign-type-method (double-float :extract-gen) (type sap offset) + (declare (ignore type)) + `(%get-double-float ,sap (/ ,offset 8))) + + + + +;;;; The MACPTR type + +(def-foreign-type-class (macptr)) + + +(def-foreign-type-method (macptr :unparse) (type) + (declare (ignore type)) + 'macptr) + +(def-foreign-type-method (macptr :lisp-rep) (type) + (declare (ignore type)) + 'macptr) + +(def-foreign-type-method (macptr :foreign-rep) (type) + (declare (ignore type)) + 'macptr) + +(def-foreign-type-method (macptr :naturalize-gen) (type foreign) + (declare (ignore type)) + foreign) + +(def-foreign-type-method (macptr :deport-gen) (type object) + (declare (ignore type)) + object) + +(def-foreign-type-method (macptr :extract-gen) (type sap offset) + (declare (ignore type)) + `(%get-ptr ,sap (/ ,offset 8))) + + + +;;;; the FOREIGN-VALUE type. + +(def-foreign-type-class (foreign-value :include macptr)) + +(def-foreign-type-method (foreign-value :lisp-rep) (type) + (declare (ignore type)) + nil) + +(def-foreign-type-method (foreign-value :naturalize-gen) (type foreign) + `(%macptr-foreign ,foreign ',type)) + +(def-foreign-type-method (foreign-value :deport-gen) (type value) + (declare (ignore type)) + `(foreign-macptr ,value)) + + + + +;;;; The POINTER type. + +(def-foreign-type-class (pointer :include (foreign-value)) + (to *void-foreign-type* :type (or symbol foreign-type))) + + + +(def-foreign-type-method (pointer :unparse) (type) + (let ((to (foreign-pointer-type-to type))) + `(:* ,(if to + (%unparse-foreign-type to) + :void)))) + +(def-foreign-type-method (pointer :type=) (type1 type2) + (let ((to1 (foreign-pointer-type-to type1)) + (to2 (foreign-pointer-type-to type2))) + (if to1 + (if to2 + (foreign-type-= to1 to2) + nil) + (null to2)))) + +(def-foreign-type-method (pointer :subtypep) (type1 type2) + (and (foreign-pointer-type-p type2) + (let ((to1 (foreign-pointer-type-to type1)) + (to2 (foreign-pointer-type-to type2))) + (if to1 + (if to2 + (foreign-subtype-p to1 to2) + t) + (null to2))))) + +(def-foreign-type-method (pointer :deport-gen) (type value) + (values + `(etypecase ,value + (null + (%int-to-ptr 0)) + (macptr + ,value) + ((foreign ,type) + (foreign-sap ,value))) + `(or null macptr (foreign ,type)))) + + + +;;;; The MEM-BLOCK type. + + +(def-foreign-type-class (mem-block :include foreign-value)) + +(def-foreign-type-method (mem-block :extract-gen) (type sap offset) + (let* ((nbytes (%foreign-type-or-record-size type :bytes))) + `(%composite-pointer-ref ,nbytes ,sap (/ ,offset 8)))) + +(def-foreign-type-method (mem-block :deposit-gen) (type sap offset value) + (let ((bits (foreign-mem-block-type-bits type))) + (unless bits + (error "Cannot deposit foreigns of type ~S (unknown size)." type)) + `(%copy-macptr-to-macptr ,value 0 ,sap ,offset ',bits))) + + + + +;;;; The ARRAY type. + +(def-foreign-type-class (array :include mem-block) + (element-type () :type foreign-type) + (dimensions () :type list)) + + + +(def-foreign-type-method (array :unparse) (type) + `(array ,(%unparse-foreign-type (foreign-array-type-element-type type)) + ,@(foreign-array-type-dimensions type))) + +(def-foreign-type-method (array :type=) (type1 type2) + (and (equal (foreign-array-type-dimensions type1) + (foreign-array-type-dimensions type2)) + (foreign-type-= (foreign-array-type-element-type type1) + (foreign-array-type-element-type type2)))) + +(def-foreign-type-method (array :subtypep) (type1 type2) + (and (foreign-array-type-p type2) + (let ((dim1 (foreign-array-type-dimensions type1)) + (dim2 (foreign-array-type-dimensions type2))) + (and (= (length dim1) (length dim2)) + (or (and dim2 + (null (car dim2)) + (equal (cdr dim1) (cdr dim2))) + (equal dim1 dim2)) + (foreign-subtype-p (foreign-array-type-element-type type1) + (foreign-array-type-element-type type2)))))) + + + +;;;; The RECORD type. + +(defstruct (foreign-record-field + (:print-object + (lambda (field stream) + (print-unreadable-object (field stream :type t) + (funcall (formatter "~S ~S~@[ ~D@~D~]") + stream + (foreign-record-field-type field) + (foreign-record-field-name field) + (foreign-record-field-bits field) + (foreign-record-field-offset field)))))) + (name () :type symbol) + (type () :type foreign-type) + (bits nil :type (or unsigned-byte null)) + (offset 0 :type unsigned-byte)) + + + +(defmethod make-load-form ((f foreign-record-field) &optional env) + (make-load-form-saving-slots f :environment env)) + +(def-foreign-type-class (record :include mem-block) + (kind :struct :type (member :struct :union :transparent-union)) + (name nil :type (or symbol null)) + (fields nil :type list) + ;; For, e.g., records defined with #pragma options align=mac68k + ;; in effect. When non-nil, this specifies the maximum alignment + ;; of record fields and the overall alignment of the record. + (alt-align nil :type (or unsigned-byte null))) + +(defmethod make-load-form ((r foreign-record-type) &optional environment) + (declare (ignore environment)) + `(parse-foreign-type ',(unparse-foreign-type r))) + + +(defun parse-foreign-record-type (kind name fields &optional (ftd *target-ftd*)) + (let* ((result (if name + (or + (ecase kind + (:struct (info-foreign-type-struct name ftd)) + ((:union :transparent-union) (info-foreign-type-union name ftd))) + (case kind + (:struct (setf (info-foreign-type-struct name ftd) + (make-foreign-record-type :name name :kind :struct))) + ((:union :transparent-union) + (setf (info-foreign-type-union name ftd) + (make-foreign-record-type :name name :kind kind))))) + (make-foreign-record-type :kind kind)))) + (when fields + (multiple-value-bind (parsed-fields alignment bits) + (parse-field-list fields kind (foreign-record-type-alt-align result)) + (let* ((old-fields (foreign-record-type-fields result))) + (setf (foreign-record-type-fields result) parsed-fields + (foreign-record-type-alignment result) alignment + (foreign-record-type-bits result) bits) + (when old-fields + (unless (record-fields-match old-fields parsed-fields 5) + (warn "Redefining ~a ~s fields to be:~%~s~%were~%~s" + kind name parsed-fields old-fields)))))) + (if name + (unless (eq (auxiliary-foreign-type kind name) result) + (setf (auxiliary-foreign-type kind name) result))) + result)) + +;;; PARSE-FOREIGN-RECORD-FIELDS -- internal +;;; +;;; Used by parse-foreign-type to parse the fields of struct and union +;;; types. RESULT holds the record type we are paring the fields of, +;;; and FIELDS is the list of field specifications. +;;; +(defun parse-field-list (fields kind &optional alt-alignment) + (collect ((parsed-fields)) + (let* ((total-bits 0) + (overall-alignment 1) + (first-field-p t) + (attributes (ftd-attributes *target-ftd*)) + (poweropen-alignment (getf attributes :poweropen-alignment))) + + (dolist (field fields) + (destructuring-bind (var type &optional bits) field + (declare (ignore bits)) + (let* ((field-type (parse-foreign-type type)) + (bits (ensure-foreign-type-bits field-type)) + (natural-alignment (foreign-type-alignment field-type)) + (alignment (if alt-alignment + (min natural-alignment alt-alignment) + (if poweropen-alignment + (if first-field-p + (progn + (setq first-field-p nil) + natural-alignment) + (min 32 natural-alignment)) + natural-alignment))) + (parsed-field + (make-foreign-record-field :type field-type + :name var))) + (parsed-fields parsed-field) + (when (null bits) + (error "Unknown size: ~S" + (unparse-foreign-type field-type))) + (when (null alignment) + (error "Unknown alignment: ~S" + (unparse-foreign-type field-type))) + (setf overall-alignment (max overall-alignment (if (< alignment 8) 32 alignment))) + (ecase kind + (:struct + (let ((offset (align-offset total-bits alignment))) + (setf (foreign-record-field-offset parsed-field) offset) + (setf (foreign-record-field-bits parsed-field) bits) + (setf total-bits (+ offset bits)))) + ((:union :transparent-union) + (setf total-bits (max total-bits bits))))))) + (values (parsed-fields) + (or alt-alignment overall-alignment) + (align-offset total-bits (or alt-alignment overall-alignment)))))) + + + +(defun parse-foreign-record-fields (result fields) + (declare (type foreign-record-type result) + (type list fields)) + (multiple-value-bind (parsed-fields alignment bits) + (parse-field-list fields (foreign-record-type-kind result) (foreign-record-type-alt-align result)) + (setf (foreign-record-type-fields result) parsed-fields + (foreign-record-type-alignment result) alignment + (foreign-record-type-bits result) bits))) + + +(def-foreign-type-method (record :unparse) (type) + `(,(case (foreign-record-type-kind type) + (:struct :struct) + (:union :union) + (:transparent-union :transparent-union) + (t '???)) + ,(foreign-record-type-name type) + ,@(unless (member type *record-types-already-unparsed* :test #'eq) + (push type *record-types-already-unparsed*) + (mapcar #'(lambda (field) + `(,(foreign-record-field-name field) + ,(%unparse-foreign-type (foreign-record-field-type field)) + ,@(if (foreign-record-field-bits field) + (list (foreign-record-field-bits field))))) + (foreign-record-type-fields type))))) + +;;; Test the record fields. The depth is limiting in case of cyclic +;;; pointers. +(defun record-fields-match (fields1 fields2 depth) + (declare (type list fields1 fields2) + (type (mod 64) depth)) + (labels ((record-type-= (type1 type2 depth) + (and (eq (foreign-record-type-name type1) + (foreign-record-type-name type2)) + (eq (foreign-record-type-kind type1) + (foreign-record-type-kind type2)) + (= (length (foreign-record-type-fields type1)) + (length (foreign-record-type-fields type2))) + (record-fields-match (foreign-record-type-fields type1) + (foreign-record-type-fields type2) + (1+ depth)))) + (pointer-type-= (type1 type2 depth) + (let ((to1 (foreign-pointer-type-to type1)) + (to2 (foreign-pointer-type-to type2))) + (if to1 + (if to2 + (or (> depth 10) + (type-= to1 to2 (1+ depth))) + nil) + (null to2)))) + (type-= (type1 type2 depth) + (cond ((and (foreign-pointer-type-p type1) + (foreign-pointer-type-p type2)) + (or (> depth 10) + (pointer-type-= type1 type2 depth))) + ((and (foreign-record-type-p type1) + (foreign-record-type-p type2)) + (record-type-= type1 type2 depth)) + (t + (foreign-type-= type1 type2))))) + (do ((fields1-rem fields1 (rest fields1-rem)) + (fields2-rem fields2 (rest fields2-rem))) + ((or (eq fields1-rem fields2-rem) + (endp fields1-rem) + (endp fields2-rem)) + (eq fields1-rem fields2-rem)) + (let ((field1 (first fields1-rem)) + (field2 (first fields2-rem))) + (declare (type foreign-record-field field1 field2)) + (unless (and (eq (foreign-record-field-name field1) + (foreign-record-field-name field2)) + (eql (foreign-record-field-bits field1) + (foreign-record-field-bits field2)) + (eql (foreign-record-field-offset field1) + (foreign-record-field-offset field2)) + (let ((field1 (foreign-record-field-type field1)) + (field2 (foreign-record-field-type field2))) + (type-= field1 field2 (1+ depth)))) + (return nil)))))) + +(def-foreign-type-method (record :type=) (type1 type2) + (and (eq (foreign-record-type-name type1) + (foreign-record-type-name type2)) + (eq (foreign-record-type-kind type1) + (foreign-record-type-kind type2)) + (= (length (foreign-record-type-fields type1)) + (length (foreign-record-type-fields type2))) + (record-fields-match (foreign-record-type-fields type1) + (foreign-record-type-fields type2) 0))) + + + +;;;; The FUNCTION and VALUES types. + +(defvar *values-type-okay* nil) + +(def-foreign-type-class (function :include mem-block) + (result-type () :type foreign-type) + (arg-types () :type list) + (stub nil :type (or null function))) + + + +(def-foreign-type-method (function :unparse) (type) + `(function ,(%unparse-foreign-type (foreign-function-type-result-type type)) + ,@(mapcar #'%unparse-foreign-type + (foreign-function-type-arg-types type)))) + +(def-foreign-type-method (function :type=) (type1 type2) + (and (foreign-type-= (foreign-function-type-result-type type1) + (foreign-function-type-result-type type2)) + (= (length (foreign-function-type-arg-types type1)) + (length (foreign-function-type-arg-types type2))) + (every #'foreign-type-= + (foreign-function-type-arg-types type1) + (foreign-function-type-arg-types type2)))) + + +(def-foreign-type-class (values) + (values () :type list)) + + + +(def-foreign-type-method (values :unparse) (type) + `(values ,@(mapcar #'%unparse-foreign-type + (foreign-values-type-values type)))) + +(def-foreign-type-method (values :type=) (type1 type2) + (and (= (length (foreign-values-type-values type1)) + (length (foreign-values-type-values type2))) + (every #'foreign-type-= + (foreign-values-type-values type1) + (foreign-values-type-values type2)))) + + + + + +;;;; The FOREIGN-SIZE macro. + +(defmacro foreign-size (type &optional (units :bits)) + "Return the size of the foreign type TYPE. UNITS specifies the units to + use and can be either :BITS, :BYTES, or :WORDS." + (let* ((foreign-type (parse-foreign-type type)) + (bits (ensure-foreign-type-bits foreign-type))) + (if bits + (values (ceiling bits + (ecase units + (:bits 1) + (:bytes 8) + (:words 32)))) + (error "Unknown size for foreign type ~S." + (unparse-foreign-type foreign-type))))) + +(defun ensure-foreign-type-bits (type) + (or (foreign-type-bits type) + (and (typep type 'foreign-record-type) + (let* ((name (foreign-record-type-name type))) + (and name + (load-record name) + (foreign-type-bits type)))) + (and (typep type 'foreign-array-type) + (let* ((element-type (foreign-array-type-element-type type)) + (dims (foreign-array-type-dimensions type))) + (if (and (ensure-foreign-type-bits element-type) + (every #'integerp dims)) + (setf (foreign-array-type-alignment type) + (foreign-type-alignment element-type) + (foreign-array-type-bits type) + (* (align-offset (foreign-type-bits element-type) + (foreign-type-alignment element-type)) + (reduce #'* dims)))))))) + +(defun require-foreign-type-bits (type) + (or (ensure-foreign-type-bits type) + (error "Can't determine attributes of foreign type ~s" type))) + +(defun %find-foreign-record (name) + (or (info-foreign-type-struct name) + (info-foreign-type-union name) + (load-record name))) + + +(defun %foreign-type-or-record (type) + (if (typep type 'foreign-type) + type + (if (consp type) + (parse-foreign-type type) + (or (%find-foreign-record type) + (parse-foreign-type type))))) + +(defun %foreign-type-or-record-size (type &optional (units :bits)) + (let* ((info (%foreign-type-or-record type)) + (bits (ensure-foreign-type-bits info))) + (if bits + (values (ceiling bits + (ecase units + (:bits 1) + (:bytes 8) + (:words 32)))) + (error "Unknown size for foreign type ~S." + (unparse-foreign-type info))))) + +(defun %find-foreign-record-type-field (type field-name) + (ensure-foreign-type-bits type) ;load the record type if necessary. + (let* ((fields (foreign-record-type-fields type))) + (or (find field-name fields :key #'foreign-record-field-name :test #'string-equal) + (error "Record type ~a has no field named ~s.~&Valid field names are: ~&~a" + (foreign-record-type-name type) + field-name + (mapcar #'foreign-record-field-name fields))))) + +(defun %foreign-access-form (base-form type bit-offset accessors) + (if (null accessors) + (invoke-foreign-type-method :extract-gen type base-form bit-offset) + (etypecase type + (foreign-record-type + (let* ((field (%find-foreign-record-type-field type (car accessors)))) + (%foreign-access-form base-form + (foreign-record-field-type field) + (+ bit-offset (foreign-record-field-offset field)) + (cdr accessors)))) + (foreign-pointer-type + (%foreign-access-form + (invoke-foreign-type-method :extract-gen type base-form bit-offset) + (foreign-pointer-type-to type) + 0 + accessors))))) + +(defun %foreign-array-access-form (base-form type index-form) + (etypecase type + ((or foreign-pointer-type foreign-array-type) + (let* ((to (foreign-pointer-type-to type)) + (size (foreign-type-bits to)) + (bit-offset `(the fixnum (* ,size (the fixnum ,index-form))))) + (invoke-foreign-type-method :extract-gen to base-form bit-offset))))) + + + + + +;;;; Naturalize, deport, extract-foreign-value, deposit-foreign-value + +(defun naturalize (foreign type) + (declare (type foreign-type type)) + (funcall (coerce (compute-naturalize-lambda type) 'function) + foreign type)) + +(defun deport (value type) + (declare (type foreign-type type)) + (funcall (coerce (compute-deport-lambda type) 'function) + value type)) + +(defun extract-foreign-value (sap offset type) + (declare (type macptr sap) + (type unsigned-byte offset) + (type foreign-type type)) + (funcall (coerce (compute-extract-lambda type) 'function) + sap offset type)) + +(defun deposit-foreign-value (sap offset type value) + (declare (type macptr sap) + (type unsigned-byte offset) + (type foreign-type type)) + (funcall (coerce (compute-deposit-lambda type) 'function) + sap offset type value)) + + + +(defmacro external (name) + "If there is already an EXTERNAL-ENTRY-POINT for the symbol named by name, +find it and return it. If not, create one and return it. + +Try to resolve the entry point to a memory address, and identify the +containing library. + +Be aware that under Darwin, external functions which are callable from C +have underscores prepended to their names, as in '_fopen'." + `(load-eep ,name)) + +(defmacro external-call (name &rest args) + "Call the foreign function at the address obtained by resolving the +external-entry-point associated with name, passing the values of each arg +as a foreign argument of type indicated by the corresponding +arg-type-specifier. Returns the foreign function result (coerced to a +Lisp object of type indicated by result-type-specifier), or NIL if +result-type-specifer is :VOID or NIL" + `(ff-call (%reference-external-entry-point + (load-time-value (external ,name))) ,@args)) + +(defmacro ff-call (entry &rest args) + "Call the foreign function at address entrypoint passing the values of +each arg as a foreign argument of type indicated by the corresponding +arg-type-specifier. Returns the foreign function result (coerced to a +Lisp object of type indicated by result-type-specifier), or NIL if +result-type-specifer is :VOID or NIL" + (funcall (ftd-ff-call-expand-function *target-ftd*) + `(%ff-call ,entry) args)) + + + +(defmethod make-load-form ((eep external-entry-point) &optional env) + (declare (ignore env)) + `(load-eep ,(eep.name eep))) + + +(defmethod print-object ((eep external-entry-point) out) + (print-unreadable-object (eep out :type t :identity t) + (format out "~s" (eep.name eep)) + (let* ((addr (eep.address eep)) + (container (eep.container eep))) + (if addr + #+ppc-target + (progn + #+32-bit-target + (format out " (#x~8,'0x) " (logand #xffffffff (ash addr 2))) + #+64-bit-target + (format out " (#x~16,'0x) " (if (typep addr 'integer) + (logand #xffffffffffffffff (ash addr 2)) + (%ptr-to-int addr)))) + #+x8632-target + (format out " (#x~8,'0x) " addr) + #+x8664-target + (format out " (#x~16,'0x) " addr) + (format out " {unresolved} ")) + (when (and container (or (not (typep container 'macptr)) + (not (%null-ptr-p container)))) + (format out "~a" (shlib.soname container)))))) + + + +(defun %cons-foreign-variable (name type &optional container) + (%istruct 'foreign-variable nil name type container)) + +(defmethod make-load-form ((fv foreign-variable) &optional env) + (declare (ignore env)) + `(load-fv ,(fv.name fv) ',(fv.type fv))) + +(defmethod print-object ((fv foreign-variable) out) + (print-unreadable-object (fv out :type t :identity t) + (format out "~s" (fv.name fv)) + (let* ((addr (fv.addr fv)) + (container (fv.container fv))) + (if addr + #+32-bit-target + (format out " (#x~8,'0x) " (logand #xffffffff (%ptr-to-int addr))) + #+64-bit-target + (format out " (#x~16,'0x) " (logand #xfffffffffffffffff (%ptr-to-int addr))) + (format out " {unresolved} ")) + (when (and container (or (not (typep container 'macptr)) + (not (%null-ptr-p container)))) + (format out "~a" (shlib.soname container)))))) + + +(defmethod print-object ((s shlib) stream) + (print-unreadable-object (s stream :type t :identity t) + (format stream "~a" (or (shlib.soname s) (shlib.pathname s))))) + +#-(or darwin-target windows-target) +(defun dlerror () + (with-macptrs ((p)) + (%setf-macptr p (#_dlerror)) + (unless (%null-ptr-p p) (%get-cstring p)))) + +(defstruct (external-function-definition (:conc-name "EFD-") + (:constructor + make-external-function-definition + (&key entry-name arg-specs + result-spec + (min-args (length arg-specs)))) + ) + (entry-name "" :type string) + (arg-specs () :type list) + (result-spec nil :type (or symbol list)) + (min-args 0 :type fixnum)) + + +(defun %external-call-expander (whole env) + (declare (ignore env)) + (destructuring-bind (name &rest args) whole + (collect ((call)) + (let* ((info (or (gethash name (ftd-external-function-definitions + *target-ftd*)) + (error "Unknown external-function: ~s" name))) + (external-name (efd-entry-name info)) + (arg-specs (efd-arg-specs info)) + (result (efd-result-spec info)) + (monitor (eq (car args) :monitor-exception-ports))) + (when monitor + (setq args (cdr args)) + (call :monitor-exception-ports)) + (let* ((rtype (parse-foreign-type result))) + (if (typep rtype 'foreign-record-type) + (call (pop args)))) + (do* ((specs arg-specs (cdr specs)) + (args args (cdr args))) + ((null specs) + (call result) + (if args + (error "Extra arguments in ~s" whole) + `(external-call ,external-name ,@(call)))) + (let* ((spec (car specs))) + (cond ((eq spec :void) + ;; must be last arg-spec; remaining args should be + ;; keyword/value pairs + (unless (evenp (length args)) + (error "Remaining arguments should be keyword/value pairs: ~s" + args)) + (do* () + ((null args)) + (call (pop args)) + (call (pop args)))) + (t + (call spec) + (if args + (call (car args)) + (error "Missing arguments in ~s" whole)))))))))) + +(defun translate-foreign-arg-type (foreign-type-spec) + (let* ((foreign-type (parse-foreign-type foreign-type-spec))) + (etypecase foreign-type + (foreign-pointer-type :address) + (foreign-integer-type + (let* ((bits (foreign-integer-type-bits foreign-type)) + (signed (foreign-integer-type-signed foreign-type))) + (declare (fixnum bits)) + (cond ((<= bits 8) (if signed :signed-byte :unsigned-byte)) + ((<= bits 16) (if signed :signed-halfword :unsigned-halfword)) + ((<= bits 32) (if signed :signed-fullword :unsigned-fullword)) + ((<= bits 64) (if signed :signed-doubleword :unsigned-doubleword)) + (t `(:record ,bits))))) + (foreign-float-type + (ecase (foreign-float-type-bits foreign-type) + (32 :single-float) + (64 :double-float))) + (foreign-record-type + `(:record ,(foreign-record-type-bits foreign-type)))))) + + +(defmacro define-external-function (name (&rest arg-specs) result-spec + &key (min-args (length arg-specs))) + (let* ((entry-name nil) + (package (find-package (ftd-interface-package-name *target-ftd*))) + (arg-keywords (mapcar #'translate-foreign-arg-type arg-specs)) + (result-keyword (unless (and (symbolp result-spec) + (eq (make-keyword result-spec) :void)) + (translate-foreign-arg-type result-spec)))) + (when (and (consp result-keyword) (eq (car result-keyword) :record)) + (push :address arg-keywords) + (setq result-keyword nil)) + (if (consp name) + (setq entry-name (cadr name) name (intern (unescape-foreign-name + (car name)) + package)) + (progn + (setq entry-name (unescape-foreign-name name) + name (intern entry-name package)) + (if (getf (ftd-attributes *target-ftd*) + :prepend-underscore) + (setq entry-name (concatenate 'string "_" entry-name))))) + `(progn + (setf (gethash ',name (ftd-external-function-definitions *target-ftd*)) + (make-external-function-definition + :entry-name ',entry-name + :arg-specs ',arg-keywords + :result-spec ',result-keyword + :min-args ,min-args)) + (setf (macro-function ',name) #'%external-call-expander) + ',name))) + + +#+darwinppc-target +(defun open-dylib (name) + (with-cstrs ((name name)) + (#_NSAddImage name (logior #$NSADDIMAGE_OPTION_RETURN_ON_ERROR + #$NSADDIMAGE_OPTION_WITH_SEARCHING)))) + +(defparameter *foreign-representation-type-keywords* + `(:signed-doubleword :signed-fullword :signed-halfword :signed-byte + :unsigned-doubleword :unsigned-fullword :unsigned-halfword :unsigned-byte + :address + :single-float :double-float + :void)) + +(defun null-coerce-foreign-arg (arg-type-keyword argform) + (declare (ignore arg-type-keyword)) + argform) + +(defun null-coerce-foreign-result (result-type-keyword resultform) + (declare (ignore result-type-keyword)) + resultform) + +(defun foreign-type-to-representation-type (f) + (if (or (member f *foreign-representation-type-keywords*) + (typep f 'unsigned-byte)) + f + (let* ((ftype (if (typep f 'foreign-type) + f + (parse-foreign-type f)))) + (or + (and (eq (foreign-type-class ftype) 'root) :void) + (typecase ftype + ((or foreign-pointer-type foreign-array-type) :address) + (foreign-double-float-type :double-float) + (foreign-single-float-type :single-float) + (foreign-integer-type + (let* ((signed (foreign-integer-type-signed ftype)) + (bits (foreign-integer-type-bits ftype))) + (if signed + (if (<= bits 8) + :signed-byte + (if (<= bits 16) + :signed-halfword + (if (<= bits 32) + :signed-fullword + (if (<= bits 64) + :signed-doubleword)))) + (if (<= bits 8) + :unsigned-byte + (if (<= bits 16) + :unsigned-halfword + (if (<= bits 32) + :unsigned-fullword + (if (<= bits 64) + :unsigned-doubleword))))))) + (foreign-record-type + (if (getf (ftd-attributes *target-ftd*) + :struct-by-value) + (let* ((bits (ensure-foreign-type-bits ftype))) + (ceiling bits (target-word-size-case + (32 32) + (64 64)))) + :address))) + (error "can't determine representation keyword for ~s" f))))) + +(defun foreign-record-accessor-names (record-type &optional prefix) + (collect ((accessors)) + (dolist (field (foreign-record-type-fields record-type) (accessors)) + (let* ((field-name (append prefix (list (foreign-record-field-name field)))) + (field-type (foreign-record-field-type field))) + (if (typep field-type 'foreign-record-type) + (dolist (s (foreign-record-accessor-names field-type field-name)) + (accessors s)) + (accessors field-name)))))) + +;;; Are all (scalar) fields in the field-list FIELDS floats ?' +(defun all-floats-in-field-list (fields) + (dolist (field fields t) + (let* ((field-type (foreign-record-field-type field))) + (cond ((typep field-type 'foreign-record-type) + (unless (all-floats-in-field-list (foreign-record-type-fields field-type)) + (return nil))) + ((typep field-type 'foreign-array-type) + (unless (typep (foreign-array-type-element-type field-type) 'foreign-float-type) + (return nil))) + (t (unless (typep field-type 'foreign-float-type) + (return nil))))))) + +;;; Are any (scalar) fields in the field-list FIELDS floats ? +(defun some-floats-in-field-list (fields) + (dolist (field fields) + (let* ((field-type (foreign-record-field-type field))) + (cond ((typep field-type 'foreign-float-type) + (return t)) + ((typep field-type 'foreign-record-type) + (if (some-floats-in-field-list (foreign-record-type-fields field-type)) + (return t))) + ((typep field-type 'foreign-array-type) + (if (typep (foreign-array-type-element-type field-type) + 'foreign-float-type) + (return t))))))) + +;;; We don't use foreign type ordinals when cross-compiling, +;;; so the read-time conditionalization is OK here. + +#-windows-target +(defparameter *canonical-os-foreign-types* + '((:struct :timespec) + (:struct :stat) + (:struct :passwd) + #>Dl_info + (:array (:struct :pollfd) 1)) ) + +#+windows-target +(defparameter *canonical-os-foreign-types* + `(#>FILETIME + #>SYSTEM_INFO + #>HANDLE + #>PROCESS_INFORMATION + #>STARTUPINFO + (:array #>HANDLE 2) + #>DWORD + (:array #>wchar_t #.#$MAX_PATH) + #>fd_set + #>DWORD_PTR + #>SYSTEMTIME)) + + +(defun canonicalize-foreign-type-ordinals (ftd) + (let* ((canonical-ordinal 0)) ; used for :VOID + (flet ((canonicalize-foreign-type-ordinal (spec) + (let* ((new-ordinal (incf canonical-ordinal))) + (when spec + (let* ((type (parse-foreign-type spec)) + (old-ordinal (foreign-type-ordinal type))) + (unless (eql new-ordinal old-ordinal) + (remhash old-ordinal (ftd-ordinal-types ftd)) + (setf (foreign-type-ordinal type) new-ordinal) + (note-foreign-type-ordinal type ftd)))) + new-ordinal))) + (canonicalize-foreign-type-ordinal :signed) + (canonicalize-foreign-type-ordinal :unsigned) + (canonicalize-foreign-type-ordinal #+64-bit-target :long #-64-bit-target nil) + (canonicalize-foreign-type-ordinal :address) + (canonicalize-foreign-type-ordinal '(:struct :sockaddr_in)) + (canonicalize-foreign-type-ordinal '(:struct :sockaddr_un)) + (canonicalize-foreign-type-ordinal '(:struct :linger)) + (canonicalize-foreign-type-ordinal '(:struct :hostent)) + (canonicalize-foreign-type-ordinal '(:array :unsigned-long 3)) + (canonicalize-foreign-type-ordinal '(:* :char)) + (canonicalize-foreign-type-ordinal '(:struct :in_addr)) + (canonicalize-foreign-type-ordinal '(:struct :cdb-datum)) + (canonicalize-foreign-type-ordinal '(:struct :dbm-constant)) + (canonicalize-foreign-type-ordinal '(:* (:struct :hostent))) + (canonicalize-foreign-type-ordinal '(:array :int 2)) + (canonicalize-foreign-type-ordinal '(:array (:struct :pollfd) 1)) + (canonicalize-foreign-type-ordinal '(:struct :dirent)) + (canonicalize-foreign-type-ordinal '(:struct :timeval)) + (canonicalize-foreign-type-ordinal '(:struct :addrinfo)) + + (setq canonical-ordinal (1- max-common-foreign-type-ordinal)) + + (dolist (spec *canonical-os-foreign-types*) + (canonicalize-foreign-type-ordinal spec)) + (dolist (spec (ftd-platform-ordinal-types ftd)) + (canonicalize-foreign-type-ordinal spec))))) + +(defun install-standard-foreign-types (ftd) + (let* ((*target-ftd* ftd) + (natural-word-size (getf (ftd-attributes ftd) :bits-per-word)) + (long-word-size (or (getf (ftd-attributes ftd) :bits-per-long) + natural-word-size))) + + (def-foreign-type-translator signed (&optional (bits 32)) + (if (<= bits 64) + (svref *signed-integer-types* bits) + (make-foreign-integer-type :bits bits))) + + + (def-foreign-type-translator integer (&optional (bits 32)) + (if (<= bits 64) + (svref *signed-integer-types* bits) + (make-foreign-integer-type :bits bits))) + + (def-foreign-type-translator unsigned (&optional (bits 32)) + (if (<= bits 64) + (svref *unsigned-integer-types* bits) + (make-foreign-integer-type :bits bits :signed nil))) + + (def-foreign-type-translator bitfield (&optional (bits 1)) + (make-foreign-integer-type :bits bits :signed nil :alignment 1)) + + (def-foreign-type-translator root () + (make-foreign-type :class 'root :bits 0 :alignment 0)) + + (def-foreign-type-translator : () *bool-type*) + + (def-foreign-type-translator single-float () + (make-foreign-single-float-type :type 'single-float)) + + (def-foreign-type-translator double-float () + (make-foreign-double-float-type :type 'double-float)) + + (def-foreign-type-translator macptr () + (make-foreign-macptr-type :bits natural-word-size)) + + (def-foreign-type-translator values (&rest values) + (unless *values-type-okay* + (error "Cannot use values types here.")) + (let ((*values-type-okay* nil)) + (make-foreign-values-type + :values (mapcar #'parse-foreign-type values)))) + + (def-foreign-type-translator function (result-type &rest arg-types) + (make-foreign-function-type + :result-type (let ((*values-type-okay* t)) + (parse-foreign-type result-type)) + :arg-types (mapcar #'parse-foreign-type arg-types))) + + (def-foreign-type-translator struct (name &rest fields) + (parse-foreign-record-type :struct name fields)) + + (def-foreign-type-translator union (name &rest fields) + (parse-foreign-record-type :union name fields)) + + (def-foreign-type-translator transparent-union (name &rest fields) + (parse-foreign-record-type :transparent-union name fields)) + + (def-foreign-type-translator array (ele-type &rest dims) + (when dims + ;; cross-compiling kludge. replaces '(or index null) + (unless (typep (first dims) `(or + ,(target-word-size-case + (32 '(integer 0 #.(expt 2 24))) + (64 '(integer 0 #.(expt 2 56)))) + null)) + (error "First dimension is not a non-negative fixnum or NIL: ~S" + (first dims))) + (let ((loser (find-if-not #'(lambda (x) (typep x 'index)) + (rest dims)))) + (when loser + (error "Dimension is not a non-negative fixnum: ~S" loser)))) + + (let* ((type (parse-foreign-type ele-type)) + (pair (cons type dims))) + (declare (dynamic-extent pair)) + (ensure-foreign-type-bits type) + (or (gethash pair (ftd-array-types *target-ftd*)) + (setf (gethash (cons type dims) (ftd-array-types *target-ftd*)) + + (make-foreign-array-type + :element-type type + :dimensions dims + :alignment (foreign-type-alignment type) + :bits (if (and (ensure-foreign-type-bits type) + (every #'integerp dims)) + (* (align-offset (foreign-type-bits type) + (foreign-type-alignment type)) + (reduce #'* dims)))))))) + + (def-foreign-type-translator * (to) + (let* ((ftd *target-ftd*) + (to (if (eq to t) *void-foreign-type* (parse-foreign-type to ftd)))) + (or (gethash to (ftd-pointer-types ftd)) + (setf (gethash to (ftd-pointer-types *target-ftd*)) + (make-foreign-pointer-type + :to to + :bits natural-word-size))))) + + (def-foreign-type-translator boolean (&optional (bits 32)) + (make-foreign-boolean-type :bits bits :signed nil)) + + (def-foreign-type signed-char (signed 8)) + (def-foreign-type signed-byte (signed 8)) + (def-foreign-type short (signed 16)) + (def-foreign-type signed-halfword short) + (def-foreign-type int (signed 32)) + (def-foreign-type signed-fullword int) + (def-foreign-type signed-short (signed 16)) + (def-foreign-type signed-int (signed 32)) + (def-foreign-type signed-doubleword (signed 64)) + (def-foreign-type char #-darwin-target (unsigned 8) + #+darwin-target (signed 8)) + (def-foreign-type unsigned-char (unsigned 8)) + (def-foreign-type unsigned-byte (unsigned 8)) + (def-foreign-type unsigned-short (unsigned 16)) + (def-foreign-type unsigned-halfword unsigned-short) + (def-foreign-type unsigned-int (unsigned 32)) + (def-foreign-type unsigned-fullword unsigned-int) + (def-foreign-type unsigned-doubleword (unsigned 64)) + (def-foreign-type bit (bitfield 1)) + + (def-foreign-type float single-float) + (def-foreign-type double double-float) + + (%def-foreign-type :void *void-foreign-type*) + (def-foreign-type address (* :void)) + (let* ((signed-long-type (parse-foreign-type + `(:signed ,long-word-size))) + (unsigned-long-type (parse-foreign-type + `(:unsigned ,long-word-size)))) + (%def-foreign-type :long signed-long-type ftd) + (%def-foreign-type :signed-long signed-long-type ftd) + (%def-foreign-type :unsigned-long unsigned-long-type ftd)) + ;; + ;; Defining the handful of foreign structures that are used + ;; to build Clozure CL here ensures that all backends see appropriate + ;; definitions of them. + ;; + ;; Don't use DEF-FOREIGN-TYPE here; this often runs too + ;; early in the cold load for that to work. + ;; + (parse-foreign-type + '(:struct :cdb-datum + (:data (* t)) + (:size (:unsigned 32))) + ftd) + (parse-foreign-type + '(:struct :dbm-constant + (:class (:unsigned 32)) + (:pad (:unsigned 32)) + (:value + (:union nil + (:s32 (:signed 32)) + (:u32 (:unsigned 32)) + (:single-float :float) + (:double-float :double)))) + ftd) + ;; This matches the xframe-list struct definition in + ;; "ccl:lisp-kernel;constants.h" + (parse-foreign-type + '(:struct :xframe-list + (:this (:* t #|(struct :ucontext)|#)) + (:prev (:* (:struct :xframe-list)))) + ftd) + )) + +(defmethod make-load-form ((p macptr) &optional env) + (declare (ignore env)) + (let* ((value (%ptr-to-int p))) + (unless (or (< value 65536) + (>= value (- (ash 1 target::nbits-in-word) 65536))) + (error "~&~s can't be referenced as a constant because its address contains more than 16 significant bits." p)) + (if (zerop value) + '+null-ptr+ + `(%int-to-ptr ,value)))) + + + + Index: /branches/new-random/lib/format.lisp =================================================================== --- /branches/new-random/lib/format.lisp (revision 13309) +++ /branches/new-random/lib/format.lisp (revision 13309) @@ -0,0 +1,2627 @@ +;;; -*- Mode: Lisp; Package: CCL -*- +;;; +;;; Copyright (C) 2009 Clozure Associates +;;; Copyright (C) 1994-2001 Digitool, Inc +;;; This file is part of Clozure CL. +;;; +;;; Clozure CL is licensed under the terms of the Lisp Lesser GNU Public +;;; License , known as the LLGPL and distributed with Clozure CL as the +;;; file "LICENSE". The LLGPL consists of a preamble and the LGPL, +;;; which is distributed with Clozure CL as the file "LGPL". Where these +;;; conflict, the preamble takes precedence. +;;; +;;; Clozure CL is referenced in the preamble as the "LIBRARY." +;;; +;;; The LLGPL is also available online at +;;; http://opensource.franz.com/preamble.html + +;;; Functions to implement FORMAT. +;;; + +(in-package "CCL") + +;;; Special variables local to FORMAT +;;; why do these have top-level bindings ????? - seems wrong or at least unnecessary + +(defvar *format-control-string* "" + "The current FORMAT control string") + +(defvar *format-index* 0 + "The current index into *format-control-string*") + +(defvar *format-length* 0 + "The length of the current FORMAT control string") + +(defvar *format-arguments* () + "Arguments to the current call of FORMAT") + +(defvar *format-original-arguments* () + "Saved arglist from top-level FORMAT call for ~* and ~@*") + +(defvar *format-arguments-variance* nil + "Non-NIL only during compile-time scanning of a format string, in which case it is the +number of additional elements at the front of *format-arguments* that may be already used +up at runtime. I.e. the actual *format-arguments* may be anything between *format-arguments* +and (nthcdr *format-arguments-variance* *format-arguments*)") + +(def-standard-initial-binding *format-stream-stack* nil "A stack of string streams for collecting FORMAT output") + +(defvar *format-pprint* nil + "Has a pprint format directive (~W ~I ~_ ~:T) or logical-block directive been seen?") + +(defvar *format-justification-semi* nil + "Has a ~<...~:;...~> been seen?") + +(defvar *format-colon-rest* nil + ) + +;;; prevent circle checking rest args. Really EVIL when dynamic-extent +(def-standard-initial-binding *format-top-level* nil) + + +;;; ERRORS + +;;; Since errors may occur while an indirect control string is being +;;; processed, i.e. by ~? or ~{~:}, some sort of backtrace is necessary +;;; in order to indicate the location in the control string where the +;;; error was detected. To this end, errors detected by format are +;;; signalled by throwing a list of the form ((control-string args)) +;;; to the tag FORMAT-ERROR. This throw will be caught at each level +;;; of indirection, and the list of error messages re-thrown with an +;;; additional message indicating that indirection was present CONSed +;;; onto it. Ultimately, the last throw will be caught by the top level +;;; FORMAT function, which will then signal an error to the Slisp error +;;; system in such a way that all the errror messages will be displayed +;;; in reverse order. + +(defun format-error (complaint &rest args) + (throw 'format-error + (list (list "~1{~:}~%~S~%~V@T^" complaint args + *format-control-string* (1+ *format-index*))))) + + +;;; MACROS + +;;; This macro establishes the correct environment for processing +;;; an indirect control string. CONTROL-STRING is the string to +;;; process, and FORMS are the forms to do the processing. They +;;; invariably will involve a call to SUB-FORMAT. CONTROL-STRING +;;; is guaranteed to be evaluated exactly once. +(eval-when (compile eval #-bccl load) + +; does this need to exist????? +#|| ; put it out of its misery +(defmacro format-with-control-string (control-string &rest forms) + `(let ((string (if (simple-string-p ,control-string) + ,control-string + (coerce ,control-string 'simple-base-string)))) + (declare (simple-string string)) + (let ((error (catch 'format-error + (let ((*format-control-string* string) + (*format-length* (length string)) + (*format-index* 0)) + ,@forms + nil)))) + + (when error + (throw 'format-error + (cons (list "While processing indirect control string~%~S~%~V@T^" + *format-control-string* + (1+ *format-index*)) + error)))))) +||# +(defmacro format-indirect-error (error) + `(throw 'format-error + (cons (list "While processing indirect control string~%~S~%~V@T^" + *format-control-string* + (1+ *format-index*)) + ,error))) + + +(defmacro get-a-format-string-stream () + '(or (pop *format-stream-stack*) (make-string-output-stream :element-type 'base-char))) ; ?? + +;;; This macro rebinds collects output to the standard output stream +;;; in a string. For efficiency, we avoid consing a new stream on +;;; every call. A stack of string streams is maintained in order to +;;; guarantee re-entrancy. + +(defmacro with-format-string-output (stream-sym &rest forms) + `(let ((,stream-sym nil)) + (unwind-protect + (progn + (setq ,stream-sym (get-a-format-string-stream)) + ,@forms + (prog1 + (get-output-stream-string ,stream-sym) + (push ,stream-sym *format-stream-stack*))) + (when ,stream-sym (file-position ,stream-sym 0))))) + +;;; This macro decomposes the argument list returned by PARSE-FORMAT-OPERATION. +;;; PARMVAR is the list of parameters. PARMDEFS is a list of lists of the form +;;; (). The FORMS are evaluated in an environment where each +;;; is bound to either the value of the parameter supplied in the +;;; parameter list, or to its value if the parameter was omitted or +;;; explicitly defaulted. + +(defmacro with-format-parameters (parmvar parmdefs &body body &environment env) + (do ((parmdefs parmdefs (cdr parmdefs)) + (bindings () (cons `(,(caar parmdefs) (or (if ,parmvar (pop ,parmvar)) + ,(cadar parmdefs))) + bindings))) + ((null parmdefs) + (multiple-value-bind (forms decls) (parse-body body env) + `(let ,(nreverse bindings) + ,@decls + (when ,parmvar + (format-error "Too many parameters")) + ,@forms))))) + + + +;;; Returns the index of the first occurrence of the specified character +;;; between indices START (inclusive) and END (exclusive) in the control +;;; string. + + +(defmacro format-find-char (char start end) + `(%str-member ,char *format-control-string* + ,start ,end)) + + +) ;end of eval-when for macros + +;;; CONTROL STRING PARSING + +;;; The current control string is kept in *format-control-string*. +;;; The variable *format-index* is the position of the last character +;;; processed, indexing from zero. The variable *format-length* is the +;;; length of the control string, which is one greater than the maximum +;;; value of *format-index*. + + +;;; Gets the next character from the current control string. It is an +;;; error if there is none. Leave *format-index* pointing to the +;;; character returned. + +(defun format-nextchar () + (let ((index (%i+ 1 *format-index*))) + (if (%i< (setq *format-index* index) *format-length*) + (schar *format-control-string* index) + (format-error "Syntax error")))) + + + +;;; Returns the current character, i.e. the one pointed to by *format-index*. + +(defmacro format-peek () + `(schar *format-control-string* *format-index*)) + + + + +;;; Attempts to parse a parameter, starting at the current index. +;;; Returns the value of the parameter, or NIL if none is found. +;;; On exit, *format-index* points to the first character which is +;;; not a part of the recognized parameter. + +(defun format-get-parameter (ch) + (case ch + (#\# (format-nextchar) + (let ((n (or *format-arguments-variance* 0)) + (len (length *format-arguments*))) + (declare (fixnum n len)) + (if (eql n 0) + len + `(the (integer ,(- len n) ,len) (length *format-arguments*))))) + ((#\V #\v) + (prog1 (pop-format-arg) (format-nextchar))) + (#\' (prog1 (format-nextchar) (format-nextchar))) + (t (cond ((or (eq ch #\-) (eq ch #\+) (digit-char-p ch)) + (let ((neg-parm (eq ch #\-))) + (unless (setq ch (digit-char-p ch)) + (unless (setq ch (digit-char-p (format-nextchar))) + (format-error "Illegal parameter"))) + (do ((number ch (+ ch (* number 10)))) + ((not (setq ch (digit-char-p (format-nextchar)))) + (if neg-parm (- number) number))))) + (t nil))))) + +(defun format-skip-parameter (ch) ; only caller is parse-format-operation + "Might someday want to add proper format error checking for negative + parameters" + (let () + (case ch + ((#\V #\v #\#) + (format-nextchar)) + (#\' (format-nextchar) (format-nextchar)) + (#\,) + (t (when (or (eq ch #\-) (eq ch #\+)) (format-nextchar)) + (while (digit-char-p (format-nextchar))))))) + +(defun format-no-semi (char &optional colon atsign) + (when *format-justification-semi* + (format-error "~~~:[~;:~]~:[~;@~]~c illegal in this context" colon atsign char)) + (setq *format-pprint* t)) + +;;; Parses a format directive, including flags and parameters. On entry, +;;; *format-index* should point to the "~" preceding the command. On +;;; exit, *format-index* points to the command character itself. +;;; Returns the list of parameters, the ":" flag, the "@" flag, and the +;;; command character as multiple values. Explicitly defaulted parameters +;;; appear in the list of parameters as NIL. Omitted parameters are simply +;;; not included in the list at all. + +(defun parse-format-operation (&optional get-params) ; only caller is format-find-command + (let ((ch (format-nextchar)) parms colon atsign) + (when (or (digit-char-p ch) + ;(%str-member ch ",#Vv'")) + (memq ch '(#\- #\, #\# #\V #\v #\'))) + (cond (get-params + (setq parms (list (format-get-parameter ch))) + (until (neq (setq ch (format-peek)) #\,) + (setq ch (format-nextchar)) + (push (format-get-parameter ch) parms))) + (t (setq parms t) ; tell caller there were some so we get correct error msgs + (format-skip-parameter ch) + (until (neq (setq ch (format-peek)) #\,) + (setq ch (format-nextchar)) + (format-skip-parameter ch))))) + ; allow either order + (case ch + (#\: (setq colon t ch (format-nextchar)) + (when (eq ch #\@) + (setq atsign t ch (format-nextchar)))) + (#\@ (setq atsign t ch (format-nextchar)) + (when (eq ch #\:) + (setq colon t ch (format-nextchar))))) + (values (if (consp parms) (nreverse parms) parms) + colon + atsign + ch))) + + +;;; Starting at the current value of *format-index*, finds the first +;;; occurrence of one of the specified directives. Embedded constructs, +;;; i.e. those inside ~(~), ~[~], ~{~}, or ~<~>, are ignored. And error is +;;; signalled if no satisfactory command is found. Otherwise, the +;;; following are returned as multiple values: +;;; +;;; The value of *format-index* at the start of the search +;;; The index of the "~" character preceding the command +;;; The parameter list of the command +;;; The ":" flag +;;; The "@" flag +;;; The command character +;;; +;;; Implementation note: The present implementation is not particulary +;;; careful with storage allocation. It would be a good idea to have +;;; a separate function for skipping embedded constructs which did not +;;; bother to cons parameter lists and then throw them away. This issue has been addressed. (akh) +;;; +;;; We go to some trouble here to use POSITION for most of the searching. +;;; God only knows why!!!! + +;; and interesting note - the only caller who wants parameters is format-get-segments for +;; ~< .... ~n:; ...~> +(defun format-find-command (command-list &optional get-params evil-commands) + (let* ((start *format-index*) + (length *format-length*) + tilde) + (loop + (setq tilde (format-find-char #\~ *format-index* length)) + (if (not tilde) (format-error "Expecting one of ~S" command-list)) + (setq *format-index* tilde) + (multiple-value-bind (parms colon atsign command) + (parse-format-operation get-params) + (when (memq command command-list) + (return (values start tilde parms colon atsign command))) + (when (and evil-commands + (or (memq command '(#\w #\_ #\i #\W #\I)) + (and colon (memq command '(#\t #\T))))) + (format-error "Illegal in this context")) + (case command + (#\{ (format-nextchar) (format-find-command '(#\}))) + (#$ (format-nextchar) (format-find-command '(#$))) + (#\[ (format-nextchar) (format-find-command '(#\]))) + (#\< (format-nextchar) + (multiple-value-bind (prev tilde parms colon atsign cmd) + (format-find-command '(#\>)) + (declare (ignore prev tilde parms atsign cmd)) + (if (and evil-commands colon) + (format-error "Logical-block directive not allowed inside justification directive")))) + ((#\} #\> #\) #\]) + (format-error "No matching bracket"))))))) + +(defun format-find-command-no-params (command-list &key (colon t) (atsign t)) + (multiple-value-bind (prev tilde parms colon-flag atsign-flag command) + (format-find-command command-list) + (with-format-parameters parms () + (format-no-flags (and (not colon) colon-flag) (and (not atsign) atsign-flag))) + (values prev tilde command colon-flag atsign-flag))) + +;;; This is the FORMAT top-level function. + +(defun format (stream control-string &rest format-arguments) + (declare (dynamic-extent format-arguments)) + (if (null stream) + (with-output-to-string (s) + (apply #'format s control-string format-arguments)) + (if (stringp stream) + (with-output-to-string (s stream) + (apply #'format s control-string format-arguments)) + (let ((*format-top-level* t)) + (when (xp-structure-p stream)(setq stream (xp-stream-stream stream))) ; for xp tests only! They call format on a structure + (setq stream (if (eq stream t) + *standard-output* + (require-type stream 'stream))) + (if (functionp control-string) + (apply control-string stream format-arguments) + (let* ((control-string (ensure-simple-string control-string)) + (*format-control-string* control-string) + (*format-pprint* nil) + (*format-justification-semi* nil)) + (declare (type simple-string control-string)) + (cond + ;; Try to avoid pprint overhead in this case. + ((not (position #\~ control-string)) + (write-string control-string stream)) + ((and (or *print-pretty* *print-circle*) + (not (typep stream 'xp-stream))) + (maybe-initiate-xp-printing + #'(lambda (s o) + (do-sub-format-1 s o)) + stream format-arguments)) + (t + (let ((*format-original-arguments* format-arguments) + (*format-arguments* format-arguments) + (*format-colon-rest* 'error)) ; what should this be?? + (do-sub-format stream)))))) + nil)))) + +(defun format-to-string (string control-string &rest format-arguments) + (declare (dynamic-extent format-arguments)) + (if string + (with-output-to-string (stream string) + (apply #'format stream control-string format-arguments)) + (with-output-to-string (stream) + (apply #'format stream control-string format-arguments)))) + +(defun do-sub-format (stream) + (let (errorp) + (setq errorp + (catch 'format-error + (catch 'format-escape + (sub-format stream 0 (length *format-control-string*))) + nil)) + (when errorp + (error "~%~:{~@?~%~}" (nreverse errorp))))) + + + +;;; This function does the real work of format. The segment of the control +;;; string between indiced START (inclusive) and END (exclusive) is processed +;;; as follows: Text not part of a directive is output without further +;;; processing. Directives are parsed along with their parameters and flags, +;;; and the appropriate handlers invoked with the arguments COLON, ATSIGN, and +;;; PARMS. +;;; + +;;; POP-FORMAT-ARG also defined in l1-format + +; in l1-format +(def-standard-initial-binding *logical-block-xp* nil) + +(without-duplicate-definition-warnings + (defun pop-format-arg (&aux (args *format-arguments*) (xp *logical-block-xp*) (av *format-arguments-variance*)) + (when (and (null args) (null xp)) + (format-error "Missing argument")) + (when xp + (if (null av) + (when (pprint-pop-check+ args xp) ; gets us level and length stuff in logical block + (throw 'logical-block nil)) + ;; Could record that might exit here, but nobody cares. + #+no (note-format-scan-option *logical-block-options*))) + (if (or (null av) (eql av 0)) + (progn + (setq *format-arguments* (cdr args)) + (%car args)) + (let ((types (loop for x in args as i from 0 below av + collect (nx-form-type x)))) + (when (eql av (length args)) + (setq *format-arguments-variance* (1- av))) + (setq *format-arguments* (cdr args)) + `(the (or ,@types) (car *format-arguments*)))))) + +; SUB-FORMAT is now defined in L1-format.lisp +; DEFFORMAT is also defined there. + +;;;;;;;;;;;;;;;;;;;;;;;;;; +;;; pretty-printing stuff +;;; + +(defformat #\W format-write (stream colon atsign) + (format-no-semi #\W) + (let ((arg (pop-format-arg))) + (cond (atsign + (let ((*print-level* nil) + (*print-length* nil)) + (if colon + (let ((*print-pretty* t)) + (write-1 arg stream)) + (write-1 arg stream)))) + (t (if colon + (let ((*print-pretty* t)) + (write-1 arg stream)) + (write-1 arg stream)))))) + +(defformat #\I format-indent (stream colon atsign &rest parms) + (declare (dynamic-extent parms)) + (declare (ignore atsign)) + (format-no-semi #\I) + (with-format-parameters parms ((n 0)) + (pprint-indent (if colon :current :block) n stream))) + +(defformat #\_ format-conditional-newline (stream colon atsign) + (format-no-semi #\_) + (let ((option + (cond (atsign + (cond (colon :mandatory) + (t :miser))) + (colon :fill) + (t :linear)))) + (pprint-newline option stream))) + +;;; Tabulation ~T + +(defformat #\T format-tab (stream colon atsign &rest parms) + (declare (dynamic-extent parms)) + (when colon + (format-no-semi #\T t)) + (with-format-parameters parms ((colnum 1) (colinc 1)) + (cond ((or (typep stream 'xp-stream) (xp-structure-p stream)) + (let ((kind (if colon + (if atsign :section-relative :section) + (if atsign :line-relative :line)))) + (cond ((xp-structure-p stream) + (pprint-tab+ kind colnum colinc stream)) + ((typep stream 'xp-stream) + (pprint-tab+ kind colnum colinc + (slot-value stream 'xp-structure)))))) + ((not colon) + (pprint-tab-not-pretty stream colnum colinc atsign))))) + +(defun pprint-tab-not-pretty (stream colnum colinc &optional atsign) + (let* ((position (column stream)) + (count (if atsign + (if position + (if (zerop colinc) + colnum (+ colnum (mod (- (+ position colnum)) colinc))) + colnum) + (if position + (if (<= colnum position) + (if (zerop colinc) + 0 (- colinc (mod (- position colnum) colinc))) + (- colnum position)) + 2)))) + (while (> count 0) + (write-string " " + stream :start + 0 :end (min count 80)) + (setq count (- count 80))))) + + +;;; ~/ call function +(defformat #\/ format-call-function (stream colon atsign &rest parms) + (let* ((string *format-control-string*) + (ipos (1+ *format-index*)) + (epos (format-find-char #\/ ipos *format-length*))) + ; the spec is DUMB here - it requires that : and :: be treated the same + (when (not epos) (format-error "Unmatched ~~/")) + (let ((cpos (format-find-char #\: ipos epos)) + package) + (cond (cpos + (setq package (or (find-package (string-upcase (%substr string ipos cpos))) + (format-error "Unknown package"))) + (when (eql #\: (schar string (%i+ 1 cpos))) + (setq cpos (%i+ cpos 1))) + (setq ipos (%i+ cpos 1))) + (t (setq package (find-package "CL-USER")))) + (let ((thing (intern (string-upcase (%substr string ipos epos)) package))) + (setq *format-index* epos) ; or 1+ epos? + (apply thing stream (pop-format-arg) colon atsign parms))))) + +;;; Conditional case conversion ~( ... ~) + +#| coral's old version +(defformat #$ format-capitalization (stream colon atsign) + (format-nextchar) + (multiple-value-bind (prev tilde) (format-find-command-no-params '(#$)) + (let* (finished + (string (with-format-string-output stream + (setq finished (catch 'format-escape (sub-format stream prev tilde) t))))) + (write-string + (cond ((and atsign colon) + (nstring-upcase string)) + (colon + (nstring-capitalize string)) + (atsign + (let ((strlen (length string))) + ;; Capitalize the first word only + (nstring-downcase string) + (do ((i 0 (1+ i))) + ((or (<= strlen i) (alpha-char-p (char string i))) + (setf (char string i) (char-upcase (char string i))) + string)))) + (t (nstring-downcase string))) + stream :start + 0 :end (length string)) + (unless finished (throw 'format-escape nil))))) + +|# + +(defformat #$ format-capitalization (stream colon atsign) + (format-nextchar) + (multiple-value-bind (prev tilde) (format-find-command-no-params '(#$)) + (let (catchp) + (cond ((typep stream 'xp-stream) + (let ((xp (slot-value stream 'xp-structure))) + (push-char-mode xp (cond ((and colon atsign) :UP) + (colon :CAP1) + (atsign :CAP0) + (T :DOWN))) + (setq catchp + (catch 'format-escape + (sub-format stream prev tilde) + nil)) + (pop-char-mode xp))) + (t + (let* ((string (with-format-string-output stream + (setq catchp (catch 'format-escape + (sub-format stream prev tilde) + nil))))) + (write-string + (cond ((and atsign colon) + (nstring-upcase string)) + (colon + (nstring-capitalize string)) + (atsign + ;; Capitalize the first word only + (nstring-downcase string) + (dotimes (i (length string) string) + (let ((ch (char string i))) + (when (alpha-char-p ch) + (setf (char string i) (char-upcase ch)) + (return string))))) + (t (nstring-downcase string))) + stream :start + 0 :end (length string))))) + (when catchp + (throw 'format-escape catchp)) + ))) + +;;; Up and Out (Escape) ~^ + +(defformat #\^ format-escape (stream colon atsign &optional p1 p2 p3) + (declare (ignore stream)) + (when atsign + (format-error "FORMAT command ~~~:[~;:~]@^ is undefined" colon)) + (when (cond (p3 (etypecase p2 + (real + (<= p1 p2 p3)) + (character + (char< p1 p2 p3)))) + (p2 (equal p1 p2)) + (p1 (eql p1 0)) + (t (null (if colon *format-colon-rest* *format-arguments*)))) + (throw 'format-escape (if colon 'format-colon-escape t)))) + +;;; Conditional expression ~[ ... ] + + +;;; ~[ - Maybe these guys should deal with ~^ too - i.e. catch format-escape etc. +;;; but I cant think of a case where just throwing to the { catcher fails + +(defun format-untagged-condition (stream) + (let ((test (pop-format-arg))) + (unless (integerp test) + (format-error "Argument to ~~[ must be integer - ~S" test)) + (do ((count 0 (1+ count))) + ((= count test) + (multiple-value-bind (prev tilde cmd colon atsign) + (format-find-command-no-params '(#\; #\]) :atsign nil) + (declare (ignore colon atsign)) + (sub-format stream prev tilde) + (unless (eq cmd #\]) + (format-find-command '(#\]))))) + (multiple-value-bind (prev tilde cmd colon atsign) + (format-find-command-no-params '(#\; #\]) :atsign nil) + (declare (ignore prev tilde atsign)) + (when (eq cmd #\]) (return)) + (format-nextchar) + (when colon + (multiple-value-bind (prev tilde cmd colon atsign) + (format-find-command-no-params '(#\; #\])) + (declare (ignore colon atsign)) + (sub-format stream prev tilde) + (unless (eq cmd #\]) + (format-find-command-no-params '(#\])))) + (return)))))) + + +;;; ~@[ + +(defun format-funny-condition (stream) + (multiple-value-bind (prev tilde) (format-find-command-no-params '(#\])) + (if *format-arguments* + (if (car *format-arguments*) + (sub-format stream prev tilde) + (pop *format-arguments*)) + (format-error "Missing argument")))) + + +;;; ~:[ + +(defun format-boolean-condition (stream) + (multiple-value-bind (prev tilde command) (format-find-command-no-params '(#\; #\])) + (when (eq command #\]) + (format-error "Two clauses separated by ~~; are required for ~~:[")) + (format-nextchar) + (if (pop-format-arg) + (multiple-value-bind (prev tilde) + (format-find-command-no-params '(#\]) :colon nil :atsign nil) + (sub-format stream prev tilde)) + (progn + (sub-format stream prev tilde) + (format-find-command-no-params '(#\])))))) + + +(defformat #\[ format-condition (stream colon atsign &optional p) + (when p (push p *format-arguments*)) + (format-nextchar) + (cond (colon + (when atsign + (format-error "~~:@[ undefined")) + (format-boolean-condition stream)) + (atsign + (format-funny-condition stream)) + (t (format-untagged-condition stream)))) + + +;;; Iteration ~{ ... ~} + +(defformat #\{ format-iteration (stream colon atsign &rest parms) + (declare (dynamic-extent parms)) + (with-format-parameters parms ((max-iter -1)) + (format-nextchar) + (multiple-value-bind (prev tilde end-cmd end-colon end-atsign) + (format-find-command-no-params '(#\}) :atsign nil) + (declare (ignore end-cmd end-atsign)) + (if (= prev tilde) + ;; Use an argument as the control string if ~{~} is empty + (let ((string (pop-format-arg))) + (cond ((stringp string) + (when (not (simple-string-p string)) ; fix here too + (setq string (coerce string 'simple-string)))) + ((not (functionp string)) + (format-error "Control string is not a string or function"))) + (let ((error + (catch 'format-error + (cond + ((stringp string) + (let* ((length (length (the simple-string string))) + (*format-control-string* string) + (*format-length* length) + (*format-index* 0)) + (format-do-iteration stream 0 length + max-iter colon atsign end-colon))) + (t ;(functionp string) + (format-do-iteration stream string nil + max-iter colon atsign end-colon))) + nil))) + (when error (format-indirect-error error)))) + (format-do-iteration stream prev tilde + max-iter colon atsign end-colon))))) + + +;;; The two catch tags FORMAT-ESCAPE and FORMAT-COLON-ESCAPE are needed here +;;; to correctly implement ~^ and ~:^. The former aborts only the current +;;; iteration, but the latter aborts the entire iteration process. +;;; ~{ arg is a list ~:{ arg is list of sublists, ~@{ arg is spread ~:@{ spread lists +;;; We have nuked two catch tags. Instead throw two different values: +;;; T if ~^ and 'format-colon-escape if ~:^ + +(defun format-do-iteration (stream start end max-iter colon atsign at-least-once-p) + (flet ((do-iteration-1 (stream start end colon at-least-once-p) + (let (catchp) + (do* ((count 0 (1+ count))) + ((or (= count max-iter) + (and (null *format-arguments*) + (if (= count 0) (not at-least-once-p) t)))) + (setq catchp + (catch 'format-escape + (if colon + (let* ((args (unless (and at-least-once-p (null *format-arguments*)) + (pop-format-arg))) + (*format-top-level* nil) + (*format-colon-rest* *format-arguments*) + (*format-arguments* args) + (*format-original-arguments* args)) + (unless (listp *format-arguments*) + (report-bad-arg *format-arguments* 'list)) + (if (functionp start) + (apply start stream args) + (sub-format stream start end))) + (let ((*format-original-arguments* *format-arguments*)) + (if (functionp start) + (setq *format-arguments* (apply start stream *format-arguments*)) + (sub-format stream start end)))) + nil)) + (when (or (eq catchp 'format-colon-escape) + (and catchp (null colon))) + (return-from do-iteration-1 nil)))))) + (if atsign + (do-iteration-1 stream start end colon at-least-once-p) + ; no atsign - munch on first arg + (let* ((*format-arguments* (pop-format-arg)) + (*format-top-level* nil) + (*format-original-arguments* *format-arguments*)) + (unless (listp *format-arguments*) + (report-bad-arg *format-arguments* 'list)) + (do-iteration-1 stream start end colon at-least-once-p))))) + + +;;; Justification ~< ... ~> + +;;; Parses a list of clauses delimited by ~; and terminated by ~>. +;;; Recursively invoke SUB-FORMAT to process them, and return a list +;;; of the results, the length of this list, and the total number of +;;; characters in the strings composing the list. + + +(defun format-get-trailing-segments () + (format-nextchar) + (multiple-value-bind (prev tilde parms colon atsign cmd) + (format-find-command '(#\; #\>) nil T) + (with-format-parameters parms () + (when colon + (format-error "~~:; allowed only after first segment in ~~<")) + (format-no-flags nil atsign)) + (let ((str (catch 'format-escape + (with-format-string-output stream + (sub-format stream prev tilde))))) + (if (stringp str) + (if (eq cmd #\;) + (multiple-value-bind + (segments numsegs numchars) + (format-get-trailing-segments) + (values (cons str segments) + (1+ numsegs) + (+ numchars + (length str)))) + (values (list str) + 1 + (length str))) + (progn + (unless (eq cmd #\>) (format-find-command '(#\>) nil T)) + (values () 0 0)))))) + + +;;; Gets the first segment, which is treated specially. Call +;;; FORMAT-GET-TRAILING-SEGMENTS to get the rest. + +(defun format-get-segments () + (let (ignore) + (declare (ignore-if-unused ignore)) ; why?? + (multiple-value-bind (prev tilde parms colon atsign cmd) + (format-find-command '(#\; #\>) nil T) ; skipping + (when atsign + (format-error "Atsign flag not allowed")) + ;(setq *format-arguments* blech) + (let ((first-seg (catch 'format-escape + (with-format-string-output stream + (sub-format stream prev tilde))))) + (if (stringp first-seg) + (if (eq cmd #\;) + (progn + (when parms + (setq *format-index* tilde) + ; now get the parameters if any - do this way cause of the V thingies + ; maybe only necessary in the : case + (multiple-value-setq (ignore ignore parms) + (format-find-command '(#\; #\>) t T))) + (multiple-value-bind + (segments numsegs numchars) + (format-get-trailing-segments) + (if colon + (values first-seg parms segments numsegs numchars) + (values nil nil (cons first-seg segments) + (1+ numsegs) + (+ (length first-seg) numchars))))) + (values nil nil (list first-seg) 1 (length first-seg))) + (progn + (unless (eq cmd #\>) (format-find-command '(#\>) nil T)) + (values nil nil () 0 0))))))) + + +#| +;;; Given the total number of SPACES needed for padding, and the number +;;; of padding segments needed (PADDINGS), returns a list of such segments. +;;; We try to allocate the spaces equally to each segment. When this is +;;; not possible, we allocate the left-over spaces randomly, to improve the +;;; appearance of many successive lines of justified text. +;;; +;;; Query: Is this right? Perhaps consistency might be better for the kind +;;; of applications ~<~> is used for. + +(defun make-pad-segs (spaces paddings) + (do* ((extra-space () (and (plusp extra-spaces) + (< (random (float 1)) (/ segs extra-spaces)))) + (result () (cons (if extra-space (1+ min-space) min-space) result)) + (min-space (truncate spaces paddings)) + (extra-spaces (- spaces (* paddings min-space)) + (if extra-space (1- extra-spaces) extra-spaces)) + (segs paddings (1- segs))) + ((zerop segs) result))) +|# +(defun make-pad-segs (spaces segments) + (multiple-value-bind (min-space extra-spaces) (truncate spaces segments) + (declare (fixnum min-space extra-spaces)) + (let* ((result (make-list segments :initial-element min-space)) + (res result)) + (setq min-space (1+ min-space)) + (dotimes (i extra-spaces) + (rplaca res min-space) + (setq res (%cdr res))) + result))) + +;;; Determine the actual width to be used for a field requiring WIDTH +;;; characters according to the following rule: If WIDTH is less than or +;;; equal to MINCOL, use WIDTH as the actual width. Otherwise, round up +;;; to MINCOL + k * COLINC for the smallest possible positive integer k. + +(defun format-round-columns (width mincol colinc) + (if (< width mincol) + (+ width (* colinc (ceiling (- mincol width) colinc))) + width)) + +(defun format-justification-round-columns (width mincol colinc) + (if (< width mincol) + mincol + (+ mincol (* colinc (ceiling (- width mincol) colinc))))) + +(defformat #\< format-justification (stream colon atsign &rest parms) + (declare (dynamic-extent parms)) + (multiple-value-bind (start tilde ecmd ecolon eatsign) + (format-find-command-no-params '(#\>)) ; bumps format-index + (declare (ignore tilde ecmd)) + (cond + (ecolon + (format-logical-block stream colon atsign eatsign start *format-index* parms)) + (t (setq *format-index* start) + (with-format-parameters parms ((mincol 0) (colinc 1) (minpad 0) (padchar #\space)) + (unless (integerp mincol) + (format-error "Mincol must be an integer - ~S" mincol)) + (unless (and (integerp colinc) (plusp colinc)) + (format-error "Colinc must be a positive integer - ~S" colinc)) + (unless (integerp minpad) + (format-error "Minpad must be an integer - ~S" minpad)) + (unless (characterp padchar) + (if (typep padchar `(integer 0 #.char-code-limit)) + (setq padchar (code-char padchar)) + (format-error "Padchar must be a character or integer from 0 to ~a - ~S" + char-code-limit padchar))) + (format-nextchar) + (multiple-value-bind (special-arg special-parms segments numsegs numchars) + (format-get-segments) + (when (= numsegs 1) (setq minpad 0)) + (when segments + (let* ((padsegs (+ (if (or colon (= numsegs 1)) 1 0) + (1- numsegs) + (if atsign 1 0))) + (width (format-justification-round-columns (+ numchars (* minpad padsegs)) + mincol colinc)) + (spaces (if (and atsign (not colon) (= numsegs 1)) ;dirty but works + (list 0 (- width numchars)) + (append (if (or colon (= numsegs 1)) () '(0)) + (make-pad-segs (- width numchars) padsegs) + (if atsign () '(0)))))) + (when special-arg + (if *format-pprint* + (format-error "Justification illegal in this context")) + (setq *format-justification-semi* t) + (with-format-parameters special-parms ((spare 0) + (linel (stream-line-length stream))) + + (let ((pos (column stream))) + (when (> (+ pos width spare) linel) + (stream-write-entire-string stream special-arg))))) + (do ((segs segments (cdr segs)) + (spcs spaces (cdr spcs))) + ((null segs) (dotimes (i (car spcs)) (write-char padchar stream))) + (dotimes (i (car spcs)) (write-char padchar stream)) + (stream-write-entire-string stream (car segs))))))))))) + + +(defun format-logical-block (stream colon atsign end-atsign start end &rest parms) + (declare (ignore parms)) + (flet ((format-check-simple (str) + (when (and str (or (%str-member #\~ str) (%str-member #\newline str))) + (format-error "Suffix and prefix must be simple"))) + (first-block-p (start) + (let* ((*format-index* 0)) + (loop + (parse-format-operation) + (when (eq (format-peek) #\<) + (cond ((eq *format-index* start) + (return t)) + (t (return nil)))))))) + (format-no-semi #\<) + (let ((format-string *format-control-string*) + (prefix (if colon "(" "")) + (suffix (if colon ")" "")) + body-string start1 tilde ignore colon1 atsign1 per-line-p) + (declare (ignore-if-unused ignore colon1)) + (setq *format-index* start) + (multiple-value-setq (start1 tilde ignore colon1 atsign1) + (format-find-command '(#\; #\>))) + (setq body-string (%substr format-string (1+ start) tilde)) + (when (not (eql *format-index* end)) ; > 1 segment + (setq prefix body-string) + (if atsign1 (setq per-line-p t)) + (multiple-value-setq (start1 tilde) + (format-find-command '(#\; #\>))) + (setq body-string (%substr format-string (1+ start1) tilde)) + (when (neq *format-index* end) + (multiple-value-setq (start1 tilde)(format-find-command '(#\; #\>))) + (setq suffix (%substr format-string (1+ start1) tilde)) + (when (neq *format-index* end) + (format-error "Too many chunks")))) + (when end-atsign (setq body-string (format-fill-transform body-string))) + (format-check-simple prefix) + (format-check-simple suffix) + (let ((args (if (not atsign) + ; This piece of garbage is needed to avoid double length counting from (formatter ...) things + ; but also to allow (flet . t) not to barf. + ; Was formerly simply (if *format-arguments* (pop-format-arg)) + ; Actually wanna not count the arg iff the ~< is at the top level + ; in a format string i.e. "is this the first ~< in THIS string?" + (when *format-arguments* + (if (and (listp *format-arguments*) + (first-block-p start)) + (pop *format-arguments*) ; dont count + (pop-format-arg))) ; unless not listp or not first + (prog1 *format-arguments* + (setq *format-arguments* nil)))) + (*format-control-string* body-string) + (*format-top-level* (and atsign *format-top-level*))) + (let ((*logical-block-p* t) + (xp-struct (cond ((xp-structure-p stream) stream) + ((typep stream 'xp-stream) + (slot-value stream 'xp-structure))))) + ; lets avoid unnecessary closures + (cond (xp-struct (logical-block-sub xp-struct args prefix suffix per-line-p atsign)) + (t (maybe-initiate-xp-printing + #'(lambda (s o) + (logical-block-sub s o prefix suffix per-line-p atsign)) + stream args)))))))) + + + +; flet? +(defun logical-block-sub (stream args prefix suffix per-line-p atsign) + ;(push (list args body-string) barf) + (let ((circle-chk (not (or *format-top-level* (and atsign (eq *current-length* -1)))))) ; i.e. ~<~@< + (let ((*current-level* (1+ *current-level*)) ; these are for pprint + (*current-length* -1)) + (declare (special *current-level* *current-length*)) + (unless (check-block-abbreviation stream args circle-chk) ;(neq args *format-original-arguments*)) ;?? + (start-block stream prefix per-line-p suffix) + (let ((*logical-block-xp* stream) ; for pop-format-arg + (my-stream (if (xp-structure-p stream) (get-xp-stream stream) stream))) + (catch 'logical-block + (do-sub-format-1 my-stream args))) + (end-block stream suffix))))) + +; bash in fill conditional newline after white space (except blanks after ~) +; I think this is silly! +(defun format-fill-transform (string) + (let ((pos 0)(end (length (the string string)))(result "") ch) + (while (%i< pos end) + (let ((wsp-pos (min (or (%str-member #\space string pos) end) + (or (%str-member #\tab string pos) end))) + (yes nil)) + (when (%i< wsp-pos end) + (when (not (and (%i> wsp-pos 1) + (eq (schar string (%i- wsp-pos 1)) #\newline) + (or (eq (setq ch (schar string (%i- wsp-pos 2))) #\~) + (and (%i> wsp-pos 2) + (memq ch '(#\: #\@)) + (eq (schar string (%i- wsp-pos 3)) #\~))))) + (setq yes t)) + (loop + (while (%i< wsp-pos end) + (setq ch (schar string wsp-pos)) + (when (Not (%str-member ch wsp)) (return)) + (setq wsp-pos (%i+ 1 wsp-pos))) + (return))) + (setq result (%str-cat result (%substr string pos wsp-pos) (if yes "~:_" ""))) + (setq pos wsp-pos))) + result)) + + +;;;;some functions needed for dealing with floats + +;;;; Floating Point printing +;;; +;;; Written by Bill Maddox +;;; +;;; +;;; +;;; FLONUM-TO-STRING (and its subsidiary function FLOAT-STRING) does most of +;;; the work for all printing of floating point numbers in the printer and in +;;; FORMAT. It converts a floating point number to a string in a free or +;;; fixed format with no exponent. The interpretation of the arguments is as +;;; follows: +;;; +;;; X - The floating point number to convert, which must not be +;;; negative. +;;; WIDTH - The preferred field width, used to determine the number +;;; of fraction digits to produce if the FDIGITS parameter +;;; is unspecified or NIL. If the non-fraction digits and the +;;; decimal point alone exceed this width, no fraction digits +;;; will be produced unless a non-NIL value of FDIGITS has been +;;; specified. Field overflow is not considerd an error at this +;;; level. +;;; FDIGITS - The number of fractional digits to produce. Insignificant +;;; trailing zeroes may be introduced as needed. May be +;;; unspecified or NIL, in which case as many digits as possible +;;; are generated, subject to the constraint that there are no +;;; trailing zeroes. +;;; SCALE - If this parameter is specified or non-NIL, then the number +;;; printed is (* x (expt 10 scale)). This scaling is exact, +;;; and cannot lose precision. +;;; FMIN - This parameter, if specified or non-NIL, is the minimum +;;; number of fraction digits which will be produced, regardless +;;; of the value of WIDTH or FDIGITS. This feature is used by +;;; the ~E format directive to prevent complete loss of +;;; significance in the printed value due to a bogus choice of +;;; scale factor. +;;; +;;; Most of the optional arguments are for the benefit for FORMAT and are not +;;; used by the printer. +;;; +;;; Returns: +;;; (VALUES DIGIT-STRING DIGIT-LENGTH LEADING-POINT TRAILING-POINT DECPNT) +;;; where the results have the following interpretation: +;;; +;;; DIGIT-STRING - The decimal representation of X, with decimal point. +;;; DIGIT-LENGTH - The length of the string DIGIT-STRING. +;;; LEADING-POINT - True if the first character of DIGIT-STRING is the +;;; decimal point. +;;; TRAILING-POINT - True if the last character of DIGIT-STRING is the +;;; decimal point. +;;; POINT-POS - The position of the digit preceding the decimal +;;; point. Zero indicates point before first digit. +;;; NZEROS - number of zeros after point +;;; +;;; WARNING: For efficiency, there is a single string object *digit-string* +;;; which is modified destructively and returned as the value of +;;; FLONUM-TO-STRING. Thus the returned value is not valid across multiple +;;; calls. +;;; +;;; NOTE: FLONUM-TO-STRING goes to a lot of trouble to guarantee accuracy. +;;; Specifically, the decimal number printed is the closest possible +;;; approximation to the true value of the binary number to be printed from +;;; among all decimal representations with the same number of digits. In +;;; free-format output, i.e. with the number of digits unconstrained, it is +;;; guaranteed that all the information is preserved, so that a properly- +;;; rounding reader can reconstruct the original binary number, bit-for-bit, +;;; from its printed decimal representation. Furthermore, only as many digits +;;; as necessary to satisfy this condition will be printed. +;;; +;;; +;;; FLOAT-STRING actually generates the digits for positive numbers. The +;;; algorithm is essentially that of algorithm Dragon4 in "How to Print +;;; Floating-Point Numbers Accurately" by Steele and White. The current +;;; (draft) version of this paper may be found in [CMUC]tradix.press. +;;; DO NOT EVEN THINK OF ATTEMPTING TO UNDERSTAND THIS CODE WITHOUT READING +;;; THE PAPER! + + + + +(defun flonum-to-string (n &optional width fdigits scale) + (let ((*print-radix* nil)) + (cond ((zerop n)(values "" 0 0)) + ((and (not (or width fdigits scale)) + (double-float-p n) + ; cheat for the only (?) number that fails to be aesthetically pleasing + (= n 1e23)) + (values "1" 24 23)) + (t (let ((string (make-array 12 :element-type 'base-char + :fill-pointer 0 :adjustable t))) + (multiple-value-bind (sig exp)(integer-decode-float n) + (float-string string sig exp (integer-length sig) width fdigits scale))))))) + +;;; if width given and fdigits nil then if exponent is >= 0 returns at +;;; most width-1 digits if exponent is < 0 returns (- width (- exp) 1) +;;; digits if fdigits given width is ignored, returns fdigits after +;;; (implied) point The Steele/White algorithm can produce a leading +;;; zero for 1e23 which lies exactly between two double floats - +;;; rounding picks the float whose rational is +;;; 99999999999999991611392. This guy wants to print as +;;; 9.999999999999999E+22. The untweaked algorithm generates a leading +;;; zero in this case. (actually wants to print as 1e23!) If we +;;; choose s such that r < s - m/2, and r = s/10 - m/2 (which it does +;;; in this case) then r * 10 < s => first digit is zero and +;;; (remainder (* r 10) s) is r * 10 = new-r, 10 * m = new-m new-r = s +;;; - new-m/2 so high will be false and she won't round up we do r * +;;; (expt 2 (- e (- scale))) and s * (expt 5 (- scale)) i.e. both less +;;; by (expt 2 (- scale)) + +(defun float-string (string f e p &optional width fdigits scale) + (macrolet ((nth-digit (n) `(%code-char (%i+ ,n (%char-code #\0))))) + (let ((r f)(s 1)(m- 1)(m+ 1)(k 0) cutoff roundup (mm nil)) + (when (= f (if (eql p 53) #.(ash 1 52) (ash 1 (1- p)))) + (setq mm t)) + (when (or (null scale)(zerop scale)) + ; approximate k + (let ((fudge 0)) + (setq fudge (truncate (* (%i+ e p) .301))) + (when (neq fudge 0) + (setq k fudge) + (setq scale (- k))))) + (when (and scale (not (eql scale 0))) + (if (minusp scale) + (setq s (* s (5-to-e (- scale)))) + (let ((scale-factor (5-to-e scale))) + (setq r (* r scale-factor)) + (setq m+ scale-factor) + (when mm (setq m- scale-factor))))) + (let ((shift (- e (if scale (- scale) 0)))) + (declare (fixnum shift)) + ;(print (list e scale shift)) + (cond ((> shift 0) + (setq r (ash f shift)) + (setq m+ (ash m+ shift)) + (when mm (setq m- (ash m- shift)))) + ((< shift 0) + (setq s (ash s (- shift)))))) + (when mm + (setq m+ (+ m+ m+)) + (setq r (+ r r)) + (setq s (+ s s))) + (let ((ceil (ceiling s 10))(fudge 1)) + (while (< r ceil) + (setq k (1- k)) + (setq r (* r 10)) + (setq fudge (* fudge 10))) + (when (> fudge 1) + (setq m+ (* m+ fudge)) + (when mm (setq m- (* m- fudge))))) + (let ((2r (+ r r))) + (loop + (let ((2rm+ (+ 2r m+))) + (while + (if (not roundup) ; guarantee no leading zero + (> 2rm+ (+ s s)) + (>= 2rm+ (+ s s))) + (setq s (* s 10)) + (setq k (1+ k)))) + (when (not (or fdigits width))(return)) + (cond + (fdigits (setq cutoff (- fdigits))) + (width + (setq cutoff + (if (< k 0) (- 1 width)(1+ (- k width)))) + ;(if (and fmin (> cutoff (- fmin))) (setq cutoff (- fmin))) + )) + (let ((a (if cutoff (- cutoff k) 0)) + (y s)) + (DECLARE (FIXNUM A)) + (if (>= a 0) + (when (> a 0)(setq y (* y (10-to-e a)))) + (setq y (ceiling y (10-to-e (the fixnum (- a)))))) + (when mm (setq m- (max y m-))) + (setq m+ (max y m+)) + (when (= m+ y) (setq roundup t))) + (when (if (not roundup) ; tweak as above + (<= (+ 2r m+)(+ s s)) + (< (+ 2r m+)(+ s s))) + (return)))) + (let* ((h k) + (half-m+ (* m+ 5)) ; 10 * m+/2 + (half-m- (if mm (* m- 5))) + u high low + ) + ;(print (list r s m+ roundup)) + (unless (and fdigits (>= (- k) fdigits)) + (loop + (setq k (1- k)) + (multiple-value-setq (u r) (truncate (* r 10) s)) + (setq low (< r (if mm half-m- half-m+))) + (setq high + (if (not roundup) + (> r (- s half-m+)) + (>= r (- s half-m+)))) + (if (or low high) + (return) + (progn + (vector-push-extend (nth-digit u) string))) + (when mm (setq half-m- (* half-m- 10) )) + (setq half-m+ (* half-m+ 10))) + ;(print (list r s high low h k)) + (vector-push-extend + (nth-digit (cond + ((and low (not high)) u) + ((and high (not low))(+ u 1)) + + (t ;(and high low) + (if (<= (+ r r) s) u (1+ u))))) + string)) + ; second value is exponent, third is exponent - # digits generated + (values string h k))))) + + +(defparameter integer-powers-of-10 (make-array (+ 12 (floor 324 12)))) + +; e better be positive +(defun 10-to-e (e) + (declare (fixnum e)(optimize (speed 3)(safety 0))) + (if (> e 335) + (* (10-to-e 334) (10-to-e (%i- e 334))) + (if (< e 12) + (svref integer-powers-of-10 e) + (multiple-value-bind (q r) (truncate e 12) + (declare (fixnum q r)) + (if (eql r 0) + (svref integer-powers-of-10 (%i+ q 11)) + (* (svref integer-powers-of-10 r) + (svref integer-powers-of-10 (%i+ q 11)))))))) + + +(let ((array integer-powers-of-10)) + (dotimes (i 12) + (setf (svref array i) (expt 10 i))) + (dotimes (i (floor 324 12)) + (setf (svref array (+ i 12)) (expt 10 (* 12 (1+ i)))))) +#| +(defun 10-to-e (e) + (ash (5-to-e e) e)) +|# + + + + +;;; Given a non-negative floating point number, SCALE-EXPONENT returns a +;;; new floating point number Z in the range (0.1, 1.0] and and exponent +;;; E such that Z * 10^E is (approximately) equal to the original number. +;;; There may be some loss of precision due the floating point representation. +;;; JUST do the EXPONENT since thats all we use + + +(defconstant long-log10-of-2 0.30103d0) + +#| +(defun scale-exponent (x) + (if (floatp x ) + (scale-expt-aux (abs x) 0.0d0 1.0d0 1.0d1 1.0d-1 long-log10-of-2) + (report-bad-arg x 'float))) + +#|this is the slisp code that was in the place of the error call above. + before floatp was put in place of shortfloatp. + ;(scale-expt-aux x (%sp-l-float 0) (%sp-l-float 1) %long-float-ten + ; %long-float-one-tenth long-log10-of-2))) +|# + +; this dies with floating point overflow (?) if fed least-positive-double-float + +(defun scale-expt-aux (x zero one ten one-tenth log10-of-2) + (let ((exponent (nth-value 1 (decode-float x)))) + (if (= x zero) + (values zero 1) + (let* ((e (round (* exponent log10-of-2))) + (x (if (minusp e) ;For the end ranges. + (* x ten (expt ten (- -1 e))) + (/ x ten (expt ten (1- e)))))) + (do ((d ten (* d ten)) + (y x (/ x d)) + (e e (1+ e))) + ((< y one) + (do ((m ten (* m ten)) + (z y (* z m)) + (e e (1- e))) + ((>= z one-tenth) (values x e))))))))) +|# + +(defun scale-exponent (n) + (let ((exp (nth-value 1 (decode-float n)))) + (values (round (* exp long-log10-of-2))))) + + +;;; Page ~| + +(defformat #\| format-page (stream colon atsign &rest parms) + (declare (dynamic-extent parms)) + (format-no-flags colon atsign) + (with-format-parameters parms ((repeat-count 1)) + (declare (fixnum repeat-count)) + (dotimes (i repeat-count) (write-char #\page stream)))) + + +(defun format-eat-whitespace () + (do* ((i *format-index* (1+ i)) + (s *format-control-string*) + (n *format-length*)) + ((or (= i n) + (not (whitespacep (schar s i)))) + (setq *format-index* (1- i))))) + +(defun format-newline (stream colon atsign parms) + (with-format-parameters parms () + (cond (colon + (when atsign + (format-error "~:@ is undefined"))) + (atsign (terpri stream) (format-eat-whitespace)) + (t (format-eat-whitespace))))) + +(defformat #\newline format-newline (stream colon atsign &rest parms) + (declare (dynamic-extent parms)) + (format-newline stream colon atsign parms)) + +(defformat #\return format-newline (stream colon atsign &rest parms) + (declare (dynamic-extent parms)) + (format-newline stream colon atsign parms)) + +;;; Indirection ~? + +(defformat #\? format-indirection (stream colon atsign) + (format-no-flags colon nil) + (let ((string (pop-format-arg))) + (unless (or (stringp string)(functionp string)) + (format-error "Indirected control string is not a string or function")) + (when (and (stringp string) (not (simple-string-p string))) + (setq string (coerce string 'simple-string))) + (catch 'format-escape + (let ((error + (catch 'format-error + (cond + ((stringp string) + (let* ((length (length (the simple-string string))) + (*format-control-string* string) + (*format-length* length) + (*format-index* 0)) + (if atsign + (sub-format stream 0 length) + (let ((args (pop-format-arg))) + (let ((*format-top-level* nil) + (*format-arguments* args) + (*format-original-arguments* args)) + (sub-format stream 0 length)))))) + (T ;(functionp string) + (if (not atsign) + (apply string stream (pop-format-arg)) + ; account for the args it eats + (setq *format-arguments* (apply string stream *format-arguments*))))) + nil))) + (when error (format-indirect-error error)))))) + + + + +;;; Ascii ~A + +(defformat #\A format-princ (stream colon atsign &rest parms) + (declare (dynamic-extent parms)) + (let ((arg (pop-format-arg))) + (if (null parms) + (princ (or arg (if colon "()" nil)) stream) + (with-format-parameters parms ((mincol 0) (colinc 1) (minpad 0) (padchar #\space)) + (format-write-field + stream + (if (or arg (not colon)) + (princ-to-string arg) + "()") + mincol colinc minpad padchar atsign))))) + + + +;;; S-expression ~S + +(defformat #\S format-prin1 (stream colon atsign &rest parms) + (declare (dynamic-extent parms)) + (let ((arg (pop-format-arg))) + (if (null parms) + (if (or arg (not colon)) (prin1 arg stream) (princ "()" stream)) + (with-format-parameters parms ((mincol 0) (colinc 1) (minpad 0) (padchar #\space)) + (format-write-field + stream + (if (or arg (not colon)) + (prin1-to-string arg) + "()") + mincol colinc minpad padchar atsign))))) + + + +;;; Character ~C + +(defformat #\C format-print-character (stream colon atsign) + (let* ((char (character (pop-format-arg))) + (code (char-code char)) + (name (char-name char))) + (cond ((and atsign (not colon)) + (prin1 char stream)) + (colon + (if (or (eql char #\space) + (not (graphic-char-p char))) + (princ name stream) + (write-char char stream))) + ((not (or atsign colon)) + (write-char char stream)) + ((and (< code 32) atsign) + (setq char (code-char (logxor code 64))) + (if (or colon (%str-member char "@CGHIJKLM[\\]^_")) + (princ name stream) + (progn + (write-char #\^ stream) + (write-char char stream))) + (princ " (" stream) + (princ "Control " stream) + (write-char char stream) + (write-char #\) stream)) + (name (princ name stream)) + (t (write-char char stream))))) + + +;;; NUMERIC PRINTING + + + +;;; Output a string in a field at MINCOL wide, padding with PADCHAR. +;;; Pads on the left if PADLEFT is true, else on the right. If the +;;; length of the string plus the minimum permissible padding, MINPAD, +;;; is greater than MINCOL, the actual field size is rounded up to +;;; MINCOL + k * COLINC for the smallest possible positive integer k. + +(defun format-write-field (stream string mincol colinc minpad padchar padleft) + (unless (or (null mincol) + (integerp mincol)) + (format-error "Mincol must be an integer - ~S" mincol)) + (unless (and (integerp colinc) (plusp colinc)) + (format-error "Colinc must be a positive integer - ~S" colinc)) + (unless (integerp minpad) + (format-error "Minpad must be an integer - ~S" minpad)) + (unless (characterp padchar) + (if (typep padchar `(integer 0 #.char-code-limit)) + (setq padchar (code-char padchar)) + (format-error "Padchar must be a character or integer from 0 to ~a - ~S" + char-code-limit padchar))) + (let* ((strlen (length (the string string))) + (strwid (+ strlen minpad)) + (width (if mincol + (format-round-columns strwid mincol colinc) + strwid))) + (if padleft + (dotimes (i (the fixnum (- width strlen))) (write-char padchar stream))) + (write-string string stream :start 0 :end strlen) + (unless padleft + (dotimes (i (the fixnum (- width strlen))) (write-char padchar stream))))) + + +;;; This functions does most of the work for the numeric printing +;;; directives. The parameters are interpreted as defined for ~D. + +(defun format-print-number (stream number radix print-commas-p print-sign-p parms) + (declare (dynamic-extent parms)) + (declare (type t number) (type fixnum radix)) + #+wrong + (when (> (length parms) 2) (setq print-commas-p t)) ; print commas if char or interval provided + (if (not (integerp number)) + (let ((*print-base* radix) + (*print-escape* nil) + (*print-radix* nil)) + (declare (special *print-base* *print-radix*)) + (princ number stream)) + (with-format-parameters parms + ((mincol 0) (padchar #\space) (commachar #\,) (commainterval 3)) + ; look out for ",0D" - should be ",'0D" + (unless (characterp padchar) + (error "Use '~A instead of ~A for padchar in format directive" padchar padchar)) + (setq print-sign-p + (cond ((and print-sign-p (>= number 0)) #\+) + ((< number 0) #\-))) + (setq number (abs number)) + (block HAIRY + (block SIMPLE + (if (and (not print-commas-p) (eql 0 mincol)) + (return-from SIMPLE)) + (let ((lg 0) + (commas 0)) + (declare (type fixnum lg commas)) + (do ((n (abs number) (floor n radix))) + ((%i< n radix)) + (declare (type integer n)) + (setq lg (%i+ lg 1))) ; lg is 1- significant digits + (setq commas (if print-commas-p + (floor lg commainterval) + 0)) + (when print-sign-p + (setq lg (1+ lg))) + (when (and (eq commas 0) + (%i<= mincol lg)) + (return-from SIMPLE)) + ;; Cons-o-rama no more ! + (let* ((s (make-string-output-stream))) + (when (neq padchar #\space) + (dotimes (i (- mincol (+ lg commas) 1)) + (write-char padchar s))) + (when print-sign-p (write-char print-sign-p s)) + (%pr-integer number radix s) + (dotimes (i (the fixnum commas)) (write-char commachar s)) + (let ((text (get-output-stream-string s))) + (declare (type string text)) + ;; -1234567,, => -1,234,567 + (when (%i> commas 0) + (do* ((dest (%i- (length text) 1)) + (source (%i- dest commas))) + ((= source dest)) + (declare (type fixnum dest source)) + (dotimes (i (the fixnum commainterval)) + (setf (char text dest) (char text source) + dest (1- dest) + source (1- source))) + (setf (char text dest) commachar + dest (1- dest)))) + (format-write-field stream text mincol 1 0 padchar t) + (return-from HAIRY))))) + ;; SIMPLE case + (when print-sign-p (write-char print-sign-p stream)) + (%pr-integer number radix stream)))) + nil) + +;;; Print a cardinal number in English + +(eval-when (:compile-toplevel :execute) +(defmacro cardinal-ones () + "Table of cardinal ones-place digits in English" + '#(nil "one" "two" "three" "four" "five" "six" "seven" "eight" "nine")) +(defmacro cardinal-tens () + "Table of cardinal tens-place digits in English" + '#(nil nil "twenty" "thirty" "forty" + "fifty" "sixty" "seventy" "eighty" "ninety")) +(defmacro cardinal-teens () + '#("ten" "eleven" "twelve" "thirteen" "fourteen" ;;; RAD + "fifteen" "sixteen" "seventeen" "eighteen" "nineteen")) +) + + +(defun format-print-small-cardinal (stream n) + (multiple-value-bind (hundreds rem) (truncate n 100) + (when (plusp hundreds) + (write-string (svref (cardinal-ones) hundreds) stream) + (write-string " hundred" stream) + (when (plusp rem) (write-char #\space stream))) ; ; ; RAD + (when (plusp rem) + (multiple-value-bind (tens ones) (truncate rem 10) + (cond ((< 1 tens) + (write-string (svref (cardinal-tens) tens) stream) + (when (plusp ones) + (write-char #\- stream) + (write-string (svref (cardinal-ones) ones) stream))) + ((= tens 1) + (write-string (svref (cardinal-teens) ones) stream)) + ((plusp ones) + (write-string (svref (cardinal-ones) ones) stream))))))) + +(eval-when (:compile-toplevel :execute) + (defmacro cardinal-periods () + "Table of cardinal 'teens' digits in English" + '#("" " thousand" " million" " billion" " trillion" " quadrillion" + " quintillion" " sextillion" " septillion" " octillion" " nonillion" + " decillion")) +) + + +(defun format-print-cardinal (stream n) + (cond ((minusp n) + (stream-write-entire-string stream "negative ") + (format-print-cardinal-aux stream (- n) 0 n)) + ((zerop n) + (stream-write-entire-string stream "zero")) + (t (format-print-cardinal-aux stream n 0 n)))) + +(defun format-print-cardinal-aux (stream n period err) + (multiple-value-bind (beyond here) (truncate n 1000) + (unless (<= period 10) + (format-error "Number too large to print in English: ~:D" err)) + (unless (zerop beyond) + (format-print-cardinal-aux stream beyond (1+ period) err)) + (unless (zerop here) + (unless (zerop beyond) (write-char #\space stream)) + (format-print-small-cardinal stream here) + (stream-write-entire-string stream (svref (cardinal-periods) period))))) + + +;;; Print an ordinal number in English + + +(eval-when (:compile-toplevel :execute) +(defmacro ordinal-ones () + "Table of ordinal ones-place digits in English" + '#(nil "first" "second" "third" "fourth" + "fifth" "sixth" "seventh" "eighth" "ninth")) +(defmacro ordinal-tens () + "Table of ordinal tens-place digits in English" + '#(nil "tenth" "twentieth" "thirtieth" "fortieth" + "fiftieth" "sixtieth" "seventieth" "eightieth" "ninetieth")) +) + +(defun format-print-ordinal (stream n) + (when (minusp n) + (stream-write-entire-string stream "negative ")) + (let ((number (abs n))) + (multiple-value-bind (top bot) (truncate number 100) + (unless (zerop top) (format-print-cardinal stream (- number bot))) + (when (and (plusp top) (plusp bot)) (write-char #\space stream)) + (multiple-value-bind (tens ones) (truncate bot 10) + (cond ((= bot 12) (stream-write-entire-string stream "twelfth")) + ((= tens 1) + (stream-write-entire-string stream (svref (cardinal-teens) ones));;;RAD + (stream-write-entire-string stream "th")) + ((and (zerop tens) (plusp ones)) + (stream-write-entire-string stream (svref (ordinal-ones) ones))) + ((and (zerop ones)(plusp tens)) + (stream-write-entire-string stream (svref (ordinal-tens) tens))) + ((plusp bot) + (stream-write-entire-string stream (svref (cardinal-tens) tens)) + (write-char #\- stream) + (stream-write-entire-string stream (svref (ordinal-ones) ones))) + ((plusp number) (write-string "th" stream :start 0 :end 2)) + (t (stream-write-entire-string stream "zeroth"))))))) + + +;;; Print Roman numerals + +(defun format-print-old-roman (stream n) + (unless (< 0 n 5000) + (format-error "Number out of range for old Roman numerals: ~:D" n)) + (do ((char-list '(#\D #\C #\L #\X #\V #\I) (cdr char-list)) + (val-list '(500 100 50 10 5 1) (cdr val-list)) + (cur-char #\M (car char-list)) + (cur-val 1000 (car val-list)) + (start n (do ((i start (progn (write-char cur-char stream) (- i cur-val)))) + ((< i cur-val) i)))) + ((zerop start)))) + + +(defun format-print-roman (stream n) + (unless (< 0 n 4000) + (format-error "Number out of range for Roman numerals: ~:D" n)) + (do ((char-list '(#\D #\C #\L #\X #\V #\I) (cdr char-list)) + (val-list '(500 100 50 10 5 1) (cdr val-list)) + (sub-chars '(#\C #\X #\X #\I #\I) (cdr sub-chars)) + (sub-val '(100 10 10 1 1 0) (cdr sub-val)) + (cur-char #\M (car char-list)) + (cur-val 1000 (car val-list)) + (cur-sub-char #\C (car sub-chars)) + (cur-sub-val 100 (car sub-val)) + (start n (do ((i start (progn (write-char cur-char stream) (- i cur-val)))) + ((< i cur-val) + (cond ((<= (- cur-val cur-sub-val) i) + (write-char cur-sub-char stream) + (write-char cur-char stream) + (- i (- cur-val cur-sub-val))) + (t i)))))) + ((zerop start)))) + + +;;; Decimal ~D + +(defformat #\D format-print-decimal (stream colon atsign &rest parms) + (declare (dynamic-extent parms)) + (format-print-number stream (pop-format-arg) 10 colon atsign parms)) + + +;;; Binary ~B + +(defformat #\B format-print-binary (stream colon atsign &rest parms) + (declare (dynamic-extent parms)) + (format-print-number stream (pop-format-arg) 2 colon atsign parms)) + + +;;; Octal ~O + +(defformat #\O format-print-octal (stream colon atsign &rest parms) + (declare (dynamic-extent parms)) + (format-print-number stream (pop-format-arg) 8 colon atsign parms)) + + +;;; Hexadecimal ~X + +(defformat #\X format-print-hexadecimal (stream colon atsign &rest parms) + (declare (dynamic-extent parms)) + (format-print-number stream (pop-format-arg) 16 colon atsign parms)) + + +;;; Radix ~R + +(defformat #\R format-print-radix (stream colon atsign &rest parms) + (declare (dynamic-extent parms)) + (let ((number (pop-format-arg)) + (parm (if parms (pop parms) nil))) + (if parm + (format-print-number stream number parm colon atsign parms) + (if atsign + (if colon + (format-print-old-roman stream number) + (format-print-roman stream number)) + (if colon + (format-print-ordinal stream number) + (format-print-cardinal stream number)))))) + +;;; FLOATING-POINT NUMBERS + + +;;; Fixed-format floating point ~F + +(defformat #\F format-fixed (stream colon atsign &rest parms) + (declare (dynamic-extent parms)) + (when colon + (format-error "Colon flag not allowed")) + (with-format-parameters parms ((w nil) (d nil) (k nil) (ovf nil) (pad #\space)) + ;;Note that the scale factor k defaults to nil. This is interpreted as + ;;zero by flonum-to-string, but more efficiently. + (let ((number (pop-format-arg))(*print-escape* nil)) + (if (floatp number) + (format-fixed-aux stream number w d k ovf pad atsign) + (if (rationalp number) + (format-fixed-aux stream (coerce number 'float) w d k ovf pad atsign) + (let ((*print-base* 10)) + (format-write-field stream (princ-to-string number) w 1 0 #\space t))))))) + +; do something ad hoc if d > w - happens if (format nil "~15g" (- 2.3 .1)) +; called with w = 11 d = 16 - dont do it after all. + +(defun format-fixed-aux (stream number w d k ovf pad atsign) + (and w (<= w 0) (setq w nil)) ; if width is unreasonable, ignore it. + (if (not (or w d)) ; perhaps put this back when prin1 is better + (prin1 number stream) + (let ((spaceleft w) + (abs-number (abs number)) + strlen zsuppress flonum-to-string-width) + (when (and w (or atsign (minusp number))) + (decf spaceleft)) + (when (and d w (<= w (+ 1 d (if atsign 1 0)))) + (setq zsuppress t)) + (when (and d (minusp d)) + (format-error "Illegal value for d")) + (setq flonum-to-string-width + (and w + (if (and (< abs-number 1) (not zsuppress)) + (1- spaceleft) ; room for leading 0 + spaceleft))) + (when (and w (not (plusp flonum-to-string-width))) + (if ovf + (progn + (dotimes (i w) (write-char ovf stream)) + (return-from format-fixed-aux)) + (setq spaceleft nil w nil))) + (multiple-value-bind (str before-pt after-pt) + (flonum-to-string abs-number + flonum-to-string-width + d k) + (setq strlen (length str)) + (cond (w (decf spaceleft (+ (max before-pt 0) 1)) + (when (and (< before-pt 1) (not zsuppress)) + (decf spaceleft)) + (if d + (decf spaceleft d) + (setq d (max (min spaceleft (- after-pt)) + (if (> spaceleft 0) 1 0)) + spaceleft (- spaceleft d)))) + ((null d) (setq d (max (- after-pt) 1)))) + (cond ((and w (< spaceleft 0) ovf) + ;;field width overflow + (dotimes (i w) (declare (fixnum i)) (write-char ovf stream))) + (t (when w (dotimes (i spaceleft) (declare (fixnum i)) (write-char pad stream))) + (if (minusp (float-sign number)) ; 5/25 + (write-char #\- stream) + (if atsign (write-char #\+ stream))) + (cond + ((> before-pt 0) + (cond ((> strlen before-pt) + (write-string str stream :start 0 :end before-pt) + (write-char #\. stream) + (write-string str stream :start before-pt :end strlen) + (dotimes (i (- d (- strlen before-pt))) + (write-char #\0 stream))) + (t ; 0's after + (stream-write-entire-string stream str) + (dotimes (i (- before-pt strlen)) + (write-char #\0 stream)) + (write-char #\. stream) + (dotimes (i d) + (write-char #\0 stream))))) + (t (unless zsuppress (write-char #\0 stream)) + (write-char #\. stream) + (dotimes (i (- before-pt)) + (write-char #\0 stream)) + (stream-write-entire-string stream str) + (dotimes (i (+ d after-pt)) + (write-char #\0 stream)))))))))) +#| +; (format t "~7,3,-2f" 8.88) +; (format t "~10,5,2f" 8.88) +; (format t "~10,5,-2f" 8.88) +; (format t "~10,5,2f" 0.0) +; (format t "~10,5,2f" 9.999999999) +; (format t "~7,,,-2e" 8.88) s.b. .009e+3 ?? +; (format t "~10,,2f" 8.88) +; (format t "~10,,-2f" 8.88) +; (format t "~10,,2f" 0.0) +; (format t "~10,,2f" 0.123454) +; (format t "~10,,2f" 9.9999999) + (defun foo (x) + (format nil "~6,2f|~6,2,1,'*f|~6,2,,'?f|~6f|~,2f|~F" + x x x x x x)) + +|# + + + +;;; Exponential-format floating point ~E + + +(defformat #\E format-exponential (stream colon atsign &rest parms) + (declare (dynamic-extent parms)) + (when colon + (format-error "Colon flag not allowed")) + (with-format-parameters parms ((w nil) (d nil) (e nil) (k 1) (ovf nil) (pad #\space) (marker nil)) + (let ((number (pop-format-arg))) + (if (floatp number) + (format-exp-aux stream number w d e k ovf pad marker atsign) + (if (rationalp number) + (format-exp-aux stream (coerce number 'float) w d e k ovf pad marker atsign) + (let ((*print-base* 10)) + (format-write-field stream (princ-to-string number) w 1 0 #\space t))))))) +#| +(defun format-exponent-marker (number) + (if (typep number *read-default-float-format*) + #\E + (cond ((double-floatp) #\D) + ((short-floatp number) #\S) + ((single-floatp number) #\F) + ((long-floatp) #\L)))) +|# +(eval-when (eval compile #-bccl load) + (defmacro format-exponent-marker (number) + `(float-exponent-char ,number)) +) + +;;;Here we prevent the scale factor from shifting all significance out of +;;;a number to the right. We allow insignificant zeroes to be shifted in +;;;to the left right, athough it is an error to specify k and d such that this +;;;occurs. Perhaps we should detect both these condtions and flag them as +;;;errors. As for now, we let the user get away with it, and merely guarantee +;;;that at least one significant digit will appear. +;;; THE ABOVE COMMENT no longer applies + +(defun format-exp-aux (stream number w d e k ovf pad marker atsign &optional string exp) + (when (not k) (setq k 1)) + (if (not (or w d e marker (neq k 1))) + (print-a-float number stream t) + (prog () + (when d + (when (or (minusp d) + (and (plusp k)(>= k (+ d 2))) + (and (minusp k)(< k (- d)))) + (format-error "incompatible values for k and d"))) + (when (not exp) (setq exp (scale-exponent number))) + AGAIN + (let* ((expt (- exp k)) + (estr (let ((*print-base* 10)) + (princ-to-string (abs expt)))) + (elen (max (length estr) (or e 0))) + (spaceleft (if w (- w 2 elen) nil)) + (fwidth) scale) + (when (and w (or atsign (minusp (float-sign number)))) ; 5/25 + (setq spaceleft (1- spaceleft))) + (if w + (progn + (setq fwidth (if d + (if (> k 0)(+ d 2)(+ d k 1)) + (if (> k 0) spaceleft (+ spaceleft k)))) + (when (minusp exp) ; i don't claim to understand this + (setq fwidth (- fwidth exp)) + (when (< k 0) (setq fwidth (1- fwidth))))) + (when (and d (not (zerop number))) ; d and no w + (setq scale (- 2 k exp)))) ; 2 used to be 1 - 5/31 + (when (or (and w e ovf (> elen e))(and w fwidth (not (plusp fwidth)))) + ;;exponent overflow + (dotimes (i w) (declare (fixnum i)) (write-char ovf stream)) + (if (plusp fwidth) + (return-from format-exp-aux nil) + (setq fwidth nil))) + (when (not string) + (multiple-value-bind (new-string before-pt) (flonum-to-string number fwidth + (if (not fwidth) d) + (if (not fwidth) scale)) + (setq string new-string) + (when scale (setq before-pt (- (+ 1 before-pt) k scale))) ; sign right? + (when (neq exp before-pt) + ;(print (list 'agn exp before-pt)) + ;(setq string new-string) + (setq exp before-pt) + (go again)))) + (let ((strlen (length string))) + (when w + (if d + (setq spaceleft (- spaceleft (+ d 2))) + (if (< k 1) + (setq spaceleft (- spaceleft (+ 2 (- k)(max strlen 1)))) + (setq spaceleft (- spaceleft (+ 1 k (max 1 (- strlen k)))))))) + (when (and w (< spaceleft 0)) + (if (and ovf (or (plusp k)(< spaceleft -1))) + (progn (dotimes (i w) (declare (fixnum i)) (write-char ovf stream)) + (return-from format-exp-aux nil)))) + (when w + (dotimes (i spaceleft) + (declare (fixnum i)) + (write-char pad stream))) + (if (minusp (float-sign number)) ; 5/25 + (write-char #\- stream) + (if atsign (write-char #\+ stream))) + (cond + ((< k 1) + (when (not (minusp spaceleft))(write-char #\0 stream)) + (write-char #\. stream) + (dotimes (i (- k)) + (write-char #\0 stream)) + (if (and (eq strlen 0)(not d)) + (write-char #\0 stream) + (stream-write-entire-string stream string)) + (if d + (dotimes (i (- (+ d k) strlen)) + (write-char #\0 stream)))) + (t + (write-string string stream :start 0 :end (min k strlen)) + (dotimes (i (- k strlen)) + (write-char #\0 stream)) + (write-char #\. stream) + (when (> strlen k) + (write-string string stream :start k :end strlen)) + (if (not d) + (when (<= strlen k)(write-char #\0 stream)) + (dotimes (i (1+ (- d k (max 0 (- strlen k))))) + (write-char #\0 stream))))) + (write-char (if marker + marker + (format-exponent-marker number)) + stream) + (write-char (if (minusp expt) #\- #\+) stream) + (when e + ;;zero-fill before exponent if necessary + (dotimes (i (- e (length estr))) + (declare (fixnum i)) + (write-char #\0 stream))) + (stream-write-entire-string stream estr)))))) +#| +; (format t "~7,3,,-2e" 8.88) s.b. .009e+3 +; (format t "~10,5,,2e" 8.888888888) ; "88.8889E-1" +; (format t "~10,5,,-2e" 8.88) "0.00888E+3" +; (format t "~10,5,,-2e" .00123445) ; "0.00123E+0" +; (format t "~10,5,,-3e" .00123445) ; "0.00012E+1" +; (format t "~10,,,-2e" .123445) +; (format t "~10,5,,2e" .0012349999e-4) +; (format t "~10,5,,2e" 9.9999999) +; (format t "~10,5,,2e" 0.0) +; (format t "~10,5,,0e" 40000000.0) +; (format t "~10,5,,2e" 9.9999999) +; (format t "~7,,,-2e" 8.88) s.b. .009e+3 ?? +; (format t "~10,,,2e" 8.888888) +; (format t "~10,,,-2e" 8.88) +; (format t "~10,,,-2e" 0.0) +; (format t "~10,,,2e" 0.0) +; (format t "~10,,,2e" 9.9999999) +; (format t "~10,,,2e" 9.9999999e100) +; (format t "~10,5,3,2,'xe" 10e100) +; (format t "~9,3,2,-2e" 1100.0) +(defun foo (x) + (format nil + "~9,2,1,,'*e|~10,3,2,2,'?,,'$e|~9,3,2,-2,'%@e|~9,2e" + x x x x)) +|# + + +;;; General Floating Point - ~G + +(defformat #\G format-general-float (stream colon atsign &rest parms) + (declare (dynamic-extent parms)) + (when colon + (format-error "Colon flag not allowed")) + (with-format-parameters parms ((w nil) (d nil) (e nil) (k nil) (ovf nil) (pad #\space) (marker nil)) + (let ((number (pop-format-arg))) + ;;The Excelsior edition does not say what to do if + ;;the argument is not a float. Here, we adopt the + ;;conventions used by ~F and ~E. + (if (floatp number) + (format-general-aux stream number w d e k ovf pad marker atsign) + (if (rationalp number) + (format-general-aux stream (coerce number 'float) w d e k ovf pad marker atsign) + (let ((*print-base* 10)) + (format-write-field stream (princ-to-string number) w 1 0 #\space t))))))) + +#| +; completely broken +(defun foo (x) + (format nil + "~9,2,1,,'*g|~10,3,2,2,'?,,'$g|~9,3,2,-2,'%@g|~9,2g" + x x x x)) +|# + + +(defun format-general-aux (stream number w d e k ovf pad marker atsign) + (multiple-value-bind (str n #|after-pt|#)(flonum-to-string number) + ;;Default d if omitted. The procedure is taken directly + ;;from the definition given in the manual, and is not + ;;very efficient, since we generate the digits twice. + ;;Future maintainers are encouraged to improve on this. + (let* ((d2 (or d (max (length str) (min n 7)))) + (ee (if e (+ e 2) 4)) + (ww (if w (- w ee) nil)) + (dd (- d2 n))) + (cond ((<= 0 dd d2) + ; this causes us to print 1.0 as 1. - seems weird + (format-fixed-aux stream number ww dd nil ovf pad atsign) + (dotimes (i ee) (declare (fixnum i)) (write-char #\space stream))) + (t (format-exp-aux stream number w d e (or k 1) ovf pad marker atsign nil n)))))) + + +;;; Dollars floating-point format ~$ + +(defformat #\$ format-dollars (stream colon atsign &rest parms) + (declare (dynamic-extent parms)) + (with-format-parameters parms ((d 2) (n 1) (w 0) (pad #\space)) + (let* ((number (float (pop-format-arg))) + (signstr (if (minusp (float-sign number)) "-" (if atsign "+" ""))) + (spaceleft) + strlen) + (multiple-value-bind (str before-pt after-pt) (flonum-to-string number nil d) + (setq strlen (length str)) + (setq spaceleft (- w (+ (length signstr) (max before-pt n) 1 d))) + (when colon (stream-write-entire-string stream signstr)) + (dotimes (i spaceleft) (write-char pad stream)) + (unless colon (stream-write-entire-string stream signstr)) + (cond + ((> before-pt 0) + (cond ((> strlen before-pt) + (dotimes (i (- n before-pt)) + (write-char #\0 stream)) + (write-string str stream :start 0 :end before-pt) + (write-char #\. stream) + (write-string str stream :start before-pt :end strlen) + (dotimes (i (- d (- strlen before-pt))) + (write-char #\0 stream))) + (t ; 0's after + (stream-write-entire-string stream str) + (dotimes (i (- before-pt strlen)) + (write-char #\0 stream)) + (write-char #\. stream) + (dotimes (i d) + (write-char #\0 stream))))) + (t (dotimes (i n) + (write-char #\0 stream)) + (write-char #\. stream) + (dotimes (i (- before-pt)) + (write-char #\0 stream)) + (stream-write-entire-string stream str) + (dotimes (i (+ d after-pt)) + (write-char #\0 stream)))))))) + +(defun y-or-n-p (&optional format-string &rest arguments &aux response) + "Y-OR-N-P prints the message, if any, and reads characters from + *QUERY-IO* until the user enters y or Y as an affirmative, or either + n or N as a negative answer. It asks again if you enter any other + characters." + (declare (dynamic-extent arguments)) + (with-terminal-input + (clear-input *query-io*) + (loop + (when format-string + (fresh-line *query-io*) + (apply 'format *query-io* format-string arguments)) + (princ " (y or n) " *query-io*) + (setq response (read-char *query-io*)) + ;; Consume input up to trailing newline + (when (peek-char #\NewLine *query-io* nil) + ;; And consume the #\newline + (read-char *query-io*)) + (clear-input *query-io*) + (if (char-equal response #\y) (return t)) + (if (char-equal response #\n) (return nil)) + (format *query-io* "Please answer y or n.")))) + +(defun yes-or-no-p (&optional format-string &rest arguments &aux response) + "YES-OR-NO-P is similar to Y-OR-N-P, except that it clears the + input buffer, beeps, and uses READ-LINE to get the strings + YES or NO." + (declare (dynamic-extent arguments)) + (with-terminal-input + (loop + (when format-string + (fresh-line *query-io*) + (apply 'format *query-io* format-string arguments)) + (princ " (yes or no) " *query-io*) + (format *query-io* "~A" #\Bell) + (setq response (read-line *query-io*)) + (clear-input *query-io*) + (when response + (setq response (string-trim wsp response)) + (if (string-equal response "yes") (return t)) + (if (string-equal response "no") (return nil)) + (format *query-io* "Please answer yes or no."))))) + + + +;; Compile-time format-scanning support. +;; +;; All this assumes it's called from the compiler, but it has to be kept in sync with code +;; here more than with the code in the compiler, so keep it in here. + +(defun note-format-scan-option (cell) + (when cell + (if (null (cdr cell)) + (setf (car cell) *format-arguments* (cdr cell) *format-arguments-variance*) + (let* ((new-args *format-arguments*) + (new-var *format-arguments-variance*) + (new-max (length new-args)) + (old-args (car cell)) + (old-var (cdr cell)) + (old-max (length old-args)) + (min (min (- new-max new-var) (- old-max old-var)))) + (if (>= new-max old-max) + (setf (car cell) new-args (cdr cell) (- new-max min)) + (setf (cdr cell) (- old-max min)))))) + cell) + +(defmacro with-format-scan-options ((var) &body body) + (let ((cell (gensym))) + ;; CELL is used to record range of arg variations that should be deferred til the end + ;; of BODY because they represent possible non-local exits. + `(let* ((,cell (cons nil nil)) + (,var ,cell)) + (declare (dynamic-extent ,cell)) + (prog1 + (progn + ,@body) + (setq *format-arguments* (car ,cell) + *format-arguments-variance* (cdr ,cell)))))) + +(defvar *format-escape-options* nil) + +(defun nx1-check-format-call (control-string format-arguments &optional (env *nx-lexical-environment*)) + "Format-arguments are expressions that will evaluate to the actual arguments. + Pre-scan process the format string, nx1-whine if find errors" + (let* ((*nx-lexical-environment* env) + (*format-top-level* t) + (*logical-block-xp* nil) + (*format-pprint* nil) + (*format-justification-semi* nil)) + (let ((error (catch 'format-error + (format-scan control-string format-arguments 0) + nil))) + (when error + (setf (cadar error) (concatenate 'string (cadar error) " in format string:")) + (nx1-whine :format-error (nreverse error)) + t)))) + +(defun format-scan (string args var) + (let ((*format-original-arguments* args) + (*format-arguments* args) + (*format-arguments-variance* var) + (*format-colon-rest* 'error) + (*format-control-string* (ensure-simple-string string))) + (with-format-scan-options (*format-escape-options*) + (catch 'format-escape + (sub-format-scan 0 (length *format-control-string*)) + (note-format-scan-option *format-escape-options*))) + (when (> (length *format-arguments*) *format-arguments-variance*) + (format-error "Too many format arguments")))) + +(defun sub-format-scan (i end) + (let ((*format-index* i) + (*format-length* end) + (string *format-control-string*)) + (loop while (setq *format-index* (position #\~ string :start *format-index* :end end)) do + (multiple-value-bind (params colon atsign char) (parse-format-operation t) + (setq char (char-upcase char)) + (let ((code (%char-code char))) + (unless (and (< -1 code (length *format-char-table*)) + (svref *format-char-table* code)) + (format-error "Unknown directive ~c" char))) + (format-scan-directive char colon atsign params) + (incf *format-index*))))) + +(defun nx-could-be-type (form type &optional transformed &aux (env *nx-lexical-environment*)) + (unless transformed (setq form (nx-transform form env))) + (if (nx-form-constant-p form env) + (typep (nx-form-constant-value form env) type env) + (not (types-disjoint-p (nx-form-type form env) type env)))) + +(defun format-require-type (form type &optional description) + (unless (nx-could-be-type form type) + (format-error "~a must be of type ~s" (or description form) type))) + + +(defun format-scan-directive (char colon atsign parms) + (ecase char + ((#\% #\& #\~ #\|) + (with-format-parameters parms ((repeat-count 1)) + (format-no-flags colon atsign) + (format-require-type repeat-count '(integer 0)))) + ((#\newline #\return) + (with-format-parameters parms () + (when (and atsign colon) (format-error "~:@ is undefined")) + (unless colon + (format-eat-whitespace)))) + ((#\P) + (with-format-parameters parms () + (when colon + (loop with end = *format-arguments* + for list on *format-original-arguments* + when (eq (cdr list) end) return (setq *format-arguments* list) + finally (if (> (or *format-arguments-variance* 0) 0) + (decf *format-arguments-variance*) + (format-error "No previous argument")))) + (pop-format-arg))) + ((#\A #\S) + (with-format-parameters parms ((mincol 0) (colinc 1) (minpad 0) (padchar #\space)) + (format-require-type mincol 'integer "mincol (first parameter)") + (format-require-type colinc '(integer 1) "colinc (second parameter)") + (format-require-type minpad 'integer "minpad (third parameter)") + (format-require-type padchar '(or (integer 0 #.char-code-limit) character) "padchar (fourth parameter)")) + (pop-format-arg)) + ((#\I) + (with-format-parameters parms ((n 0)) + (format-no-flags nil atsign) + (format-no-semi char) + (format-require-type n 'real))) + ((#\_) + (with-format-parameters parms () + (format-no-semi char))) + ((#\T) + (with-format-parameters parms ((colnum 1) (colinc 1)) + (when colon + (format-no-semi char t)) + (format-require-type colnum 'integer "colnum (first parameter)") + (format-require-type colinc 'integer "colinc (second parameter)"))) + ((#\W) + (with-format-parameters parms () + (format-no-semi #\W)) + (pop-format-arg)) + ((#\C) + (with-format-parameters parms ()) + (format-require-type (pop-format-arg) '(or character fixnum (string 1)))) + ((#\D #\B #\O #\X #\R) + (when (eql char #\R) + (let ((radix (pop parms))) + (when radix + (format-require-type radix '(integer 2 36))))) + (with-format-parameters parms ((mincol 0) (padchar #\space) (commachar #\,) (commainterval 3)) + (format-require-type mincol 'integer "mincol (first parameter)") + (format-require-type padchar 'character "padchar (second parameter)") + (format-require-type commachar 'character "comma char (third parameter)") + (format-require-type commainterval 'integer "comma interval (fourth parameter)")) + (pop-format-arg)) + ((#\F) + (format-no-flags colon nil) + (with-format-parameters parms ((w nil) (d nil) (k nil) (ovf nil) (pad #\space)) + (format-require-type w '(or null (integer 0)) "w (first parameter)") + (format-require-type d '(or null (integer 0)) "d (second parameter)") + (format-require-type k '(or null integer) "k (third parameter)") + (format-require-type ovf '(or null character) "overflowchar (fourth parameter)") + (format-require-type pad '(or null character) "padchar (fifth parameter)")) + (pop-format-arg)) + ((#\E #\G) + (format-no-flags colon nil) + (with-format-parameters parms ((w nil) (d nil) (e nil) (k 1) (ovf nil) (pad #\space) (marker nil)) + (format-require-type w '(or null (integer 0)) "w (first parameter)") + (format-require-type d '(or null (integer 0)) "d (second parameter)") + (format-require-type e '(or null (integer 0)) "e (third parameter)") + (format-require-type k '(or null integer) "k (fourth parameter)") + (format-require-type ovf '(or null character) "overflowchar (fifth parameter)") + (format-require-type pad '(or null character) "padchar (sixth parameter)") + (format-require-type marker '(or null character) "exponentchar (seventh parameter)")) + (pop-format-arg)) + ((#\$) + (with-format-parameters parms ((d 2) (n 1) (w 0) (pad #\space)) + (format-require-type d '(or null (integer 0)) "d (first parameter)") + (format-require-type n '(or null (integer 0)) "n (second parameter)") + (format-require-type w '(or null (integer 0)) "w (third parameter)") + (format-require-type pad '(or null character) "pad (fourth parameter)")) + (format-require-type (pop-format-arg) 'real)) + ((#\*) + (with-format-parameters parms ((count nil)) + (when count + (format-require-type count 'integer "count parameter")) + (if (typep (setq count (nx-transform count)) '(or null integer)) + (format-scan-goto colon atsign count) + ;; Else can't tell how much going back or forth, could be anywhere. + (setq *format-arguments* *format-original-arguments* + *format-arguments-variance* (length *format-arguments*))))) + ((#\?) + (with-format-parameters parms () + (format-no-flags colon nil)) + (let ((string (pop-format-arg))) + (format-require-type string '(or string function)) + (if atsign + (setq *format-arguments-variance* (length *format-arguments*)) + (let ((arg (pop-format-arg))) + (format-require-type arg 'list))))) + ((#\/) + (let* ((string *format-control-string*) + (ipos (1+ *format-index*)) + (epos (format-find-char #\/ ipos *format-length*))) + (when (not epos) (format-error "Unmatched ~~/")) + (let* ((cpos (format-find-char #\: ipos epos)) + (name (if cpos + (prog1 + (string-upcase (%substr string ipos cpos)) + (when (eql #\: (schar string (%i+ 1 cpos))) + (setq cpos (%i+ cpos 1))) + (setq ipos (%i+ cpos 1))) + "CL-USER")) + (package (find-package name)) + (sym (and package (find-symbol (string-upcase (%substr string ipos epos)) package))) + (arg (pop-format-arg))) + (setq *format-index* epos) ; or 1+ epos? + ;; TODO: should we complain if the symbol doesn't exit? Perhaps it will be defined + ;; later, and to detect that would need to intern it. What if the package doesn't exist? + ;; Would need to extend :undefined-function warnings to handle previously-undefined package. + (when sym + (when (nx1-check-typed-call sym (list* '*standard-output* arg colon atsign parms)) + ;; Whined, just get out now. + (throw 'format-error nil)))))) + ((#\[) + (when (and colon atsign) (format-error "~~:@[ undefined")) + (format-nextchar) + (cond (colon + (format-scan-boolean-condition parms)) + (atsign + (format-scan-funny-condition parms)) + (t (format-scan-untagged-condition parms)))) + ((#$) + (with-format-parameters parms () + (format-nextchar) + (multiple-value-bind (prev tilde parms colon atsign) (format-find-command '(#$)) + (with-format-parameters parms () (format-no-flags colon atsign)) + (sub-format-scan prev tilde)))) + ((#\^) + (format-no-flags nil atsign) + (with-format-parameters parms ((p1 nil) (p2 nil) (p3 nil)) + (let ((val (nx-transform (cond (p3 + (if (every (lambda (p) (nx-could-be-type p 'real)) parms) + ;; If the params could also be chars, don't know enough to constant fold + ;; anyway, so this test will do. + `(< ,p1 ,p2 ,p3) + (if (every (lambda (p) (nx-could-be-type p 'character)) parms) + `(char< ,p1 ,p2 ,p3) + ;; At least one can't be real, at least one can't be char. + (format-error "Wrong type of parameters for three-way comparison")))) + (p2 `(equal ,p1 ,p2)) + (p1 `(eq ,p1 0)) + (t (null (if colon *format-colon-rest* *format-arguments*))))))) + (when val + (note-format-scan-option *format-escape-options*) + (unless (nx-could-be-type val 'null t) + (throw 'format-escape t)))))) + ((#\{) + (with-format-parameters parms ((max-iter -1)) + (format-require-type max-iter 'integer "max-iter parameter") + (format-nextchar) + (multiple-value-bind (prev tilde end-parms end-colon end-atsign) (format-find-command '(#\})) + (declare (ignore end-colon)) + (with-format-parameters end-parms () (format-no-flags nil end-atsign)) + (when (= prev tilde) + ;; Use an argument as the control string if ~{~} is empty + (let ((string (pop-format-arg))) + (unless (nx-could-be-type string '(or string function)) + (format-error "Control string is not a string or function")))) + ;; Could try to actually scan the iteration if string is a compile-time string, + ;; by that seems unlikely. + (if atsign + (setq *format-arguments-variance* (length *format-arguments*)) + (format-require-type (pop-format-arg) 'list))))) + ((#\<) + (multiple-value-bind (start tilde eparms ecolon eatsign) (format-find-command '(#\>)) + (declare (ignore tilde eparms eatsign)) + (setq *format-index* start) + (if ecolon + (format-logical-block-scan colon atsign parms) + (format-justification-scan colon atsign parms)))) + )) + +(defun format-justification-scan (colon atsign parms) + (declare (ignore colon atsign)) + (with-format-parameters parms ((mincol 0) (colinc 1) (minpad 0) (padchar #\space)) + (format-require-type mincol 'integer "mincol (first parameter)") + (format-require-type colinc '(integer 1) "colinc (second parameter)") + (format-require-type minpad 'integer "minpad (third parameter)") + (format-require-type padchar `(or character (integer 0 #.char-code-limit)) "padchar (fourth parameter)")) + (let ((first-parms nil) (first-colon nil) (count 0)) + (with-format-scan-options (*format-escape-options*) + (loop + (format-nextchar) + (multiple-value-bind (prev tilde parms colon atsign cmd) + (format-find-command '(#\; #\>) nil T) + (if (and (eql count 0) (eql cmd #\;) colon) + (progn + (format-no-flags nil atsign) + (setq first-colon t) + (setq *format-index* tilde) + (setq first-parms (nth-value 2 (format-find-command '(#\; #\>) t T)))) + (with-format-parameters parms () + (format-no-flags colon atsign))) + (when (catch 'format-escape + (sub-format-scan prev tilde) + nil) + (unless (eq cmd #\>) (format-find-command '(#\>) nil t)) + (return)) + (incf count) + (when (eq cmd #\>) + (return)))) + (note-format-scan-option *format-escape-options*)) + (when first-colon + (when *format-pprint* + (format-error "Justification illegal in this context")) + (setq *format-justification-semi* t) + (with-format-parameters first-parms ((spare 0) (linel 0)) + (format-require-type spare 'integer "spare (first parameter)") + (format-require-type linel 'integer "line length (second parameter)"))))) + + + +(defun format-logical-block-scan (colon atsign params) + (declare (ignore colon)) + (with-format-parameters params () + (format-no-semi #\<)) + ;; First section can be termined by ~@; + (let ((format-string *format-control-string*) + (prefix "") + (suffix "") + (body-string nil)) + (multiple-value-bind (start1 tilde parms1 colon1 atsign1 cmd) (format-find-command '(#\; #\>)) + (setq body-string (%substr format-string (1+ start1) tilde)) + (with-format-parameters parms1 ()) + (when (eq cmd #\;) + (format-no-flags colon1 nil) + (setq prefix body-string) + (multiple-value-setq (start1 tilde parms1 colon1 atsign1 cmd) (format-find-command '(#\; #\>))) + (with-format-parameters parms1 ()) + (setq body-string (%substr format-string (1+ start1) tilde)) + (when (eq cmd #\;) + (format-no-flags colon1 atsign1) + (multiple-value-setq (start1 tilde parms1 colon1 atsign1 cmd) (format-find-command '(#\; #\>))) + (with-format-parameters parms1 ()) + (setq suffix (%substr format-string (1+ start1) tilde)) + (when (eq cmd #\;) + (format-error "Too many sections"))))) + (flet ((format-check-simple (str where) + (when (and str (or (%str-member #\~ str) (%str-member #\newline str))) + (format-error "~A must be simple" where)))) + (format-check-simple prefix "Prefix") + (format-check-simple suffix "Suffix")) + (if atsign + (let ((*logical-block-p* t)) + (format-scan body-string *format-arguments* *format-arguments-variance*) + (setq *format-arguments* nil *format-arguments-variance* 0)) + ;; If no atsign, we just use up an arg. Don't bother trying to scan it, unlikely to be a constant. + (when *format-arguments* + (pop-format-arg))))) + + +(defun format-scan-untagged-condition (parms) + (with-format-parameters parms ((index nil)) + (unless index (setq index (pop-format-arg))) + (format-require-type index 'integer) + (with-format-scan-options (cond-options) + (loop with default = nil do + (multiple-value-bind (prev tilde parms colon atsign cmd) + (format-find-command '(#\; #\])) + (when (and default (eq cmd #\;)) + (format-error "~:; must be the last clause")) + (with-format-parameters parms () + (format-no-flags (if (eq cmd #\]) colon) atsign) + (when colon (setq default t))) + (format-scan-optional-clause prev tilde cond-options) + (when (eq cmd #\]) + (unless default ;; Could just skip the whole thing + (note-format-scan-option cond-options)) + (return)) + (format-nextchar)))))) + +(defun format-scan-funny-condition (parms) + (with-format-parameters parms ()) + (multiple-value-bind (prev tilde parms colon atsign) (format-find-command '(#\])) + (with-format-parameters parms () + (format-no-flags colon atsign)) + (when (null *format-arguments*) (pop-format-arg)) ;; invoke std error + (with-format-scan-options (cond-options) + (let ((arg (nx-transform (car *format-arguments*)))) + (when (nx-could-be-type arg 'null t) + (let ((*format-arguments* *format-arguments*) + (*format-arguments-variance* *format-arguments-variance*)) + (when (eql *format-arguments-variance* (length *format-arguments*)) + (decf *format-arguments-variance*)) + (pop *format-arguments*) + (note-format-scan-option cond-options))) + (when arg + (format-scan-optional-clause prev tilde cond-options)))))) + + +(defun format-scan-boolean-condition (parms) + (with-format-parameters parms ()) + (multiple-value-bind (prev tilde parms colon atsign cmd) (format-find-command '(#\; #\])) + (when (eq cmd #\]) + (format-error "Two clauses separated by ~~; are required for ~~:[")) + (with-format-parameters parms () (format-no-flags colon atsign)) + (format-nextchar) + (with-format-scan-options (cond-options) + (let ((arg (nx-transform (pop-format-arg)))) + (when (nx-could-be-type arg 'null t) + (format-scan-optional-clause prev tilde cond-options)) + (multiple-value-bind (prev tilde parms colon atsign) (format-find-command '(#\])) + (with-format-parameters parms () (format-no-flags colon atsign)) + (when arg + (format-scan-optional-clause prev tilde cond-options))))))) + + +(defun format-scan-optional-clause (start end cond-option) + (let ((*format-arguments* *format-arguments*) + (*format-arguments-variance* *format-arguments-variance*)) + ;; Let the branch points collect in outer *format-escape-options*, but don't + ;; throw there because need to consider the other clauses. + (catch 'format-escape + (sub-format-scan start end) + (note-format-scan-option cond-option) + nil))) + +(defun format-scan-goto (colon atsign count) + (if atsign + (let* ((orig *format-original-arguments*) + (orig-pos (- (length orig) (length *format-arguments*))) + (new-pos (or count 0))) + (format-no-flags colon nil) + ;; After backing up, we may not use up all the arguments we backed over, + ;; so even though real variance here is 0, increase variance so we don't + ;; complain. + (setq *format-arguments-variance* (max 0 (- orig-pos new-pos))) + (setq *format-arguments* (nthcdr-no-overflow new-pos orig))) + (progn + (when (null count)(setq count 1)) + (when colon (setq count (- count))) + (cond ((> count 0) + (when (> count (length *format-arguments*)) + (format-error "Target position for ~~* out of bounds")) + (setq *format-arguments* (nthcdr count *format-arguments*)) + (when *format-arguments-variance* + (setq *format-arguments-variance* + (min *format-arguments-variance* (length *format-arguments*))))) + ((< count 0) + (let* ((orig *format-original-arguments*) + (orig-pos (- (length orig) (length *format-arguments*))) + (pos (+ orig-pos count)) + (max-pos (+ pos (or *format-arguments-variance* 0)))) + (when (< max-pos 0) + (format-error "Target position for ~~* out of bounds")) + ;; After backing up, we may not use up all the arguments we backed over. + ;; Increase the variance allowed to cover those arguments, so we don't + ;; complain about not using them. E.g. (format t "~a ~a ~2:*~a" 1 2) should + ;; be ok, (format t "~a ~a ~2:*" 1 2) should warn. + (setq max-pos (1- (- max-pos count))) + (if (< pos 0) + (setq *format-arguments* orig + *format-arguments-variance* max-pos) + (setq *format-arguments* (nthcdr pos orig) + *format-arguments-variance* (- max-pos pos))))))))) Index: /branches/new-random/lib/hash.lisp =================================================================== --- /branches/new-random/lib/hash.lisp (revision 13309) +++ /branches/new-random/lib/hash.lisp (revision 13309) @@ -0,0 +1,456 @@ +;;;-*- Mode: Lisp; Package: CCL -*- +;;; +;;; Copyright (C) 2009 Clozure Associates +;;; Copyright (C) 1994-2001 Digitool, Inc +;;; This file is part of Clozure CL. +;;; +;;; Clozure CL is licensed under the terms of the Lisp Lesser GNU Public +;;; License , known as the LLGPL and distributed with Clozure CL as the +;;; file "LICENSE". The LLGPL consists of a preamble and the LGPL, +;;; which is distributed with Clozure CL as the file "LGPL". Where these +;;; conflict, the preamble takes precedence. +;;; +;;; Clozure CL is referenced in the preamble as the "LIBRARY." +;;; +;;; The LLGPL is also available online at +;;; http://opensource.franz.com/preamble.html + +;; This is just the stuff (make-load-form, print-object) that can't be fasloaded earlier. + + +;;;;;;;;;;;;; +;; +;; hash.lisp +;; New hash table implementation + +;;;;;;;;;;;;; +;; +;; Things I didn't do +;; +;; Save the 32-bit hash code along with the key so that growing the table can +;; avoid calling the hashing function (at least until a GC happens during growing). +;; +;; Maybe use Knuth's better method for hashing: +;; find two primes N-2, N. N is the table size. +;; First probe is at primary = (mod (funcall (nhash.keytransF h) key) N) +;; Secondary probes are spaced by (mod (funcall (nhash.keytransF h) key) N-2) +;; This does a bit better scrambling of the secondary probes, but costs another divide. +;; +;; Rethink how finalization is reported to the user. Maybe have a finalization function which +;; is called with the hash table and the deleted key & value. + + +;;;;;;;;;;;;; +;; +;; Documentation +;; +;; MAKE-HASH-TABLE is extended to accept a :HASH-FUNCTION keyword arg which +;; defaults for the 4 Common Lisp defined :TEST's. Also, any fbound symbol can +;; be used for the :TEST argument. The HASH-FUNCTION is a function of one +;; argument, the key, which returns one or two values: +;; +;; 1) HASH-CODE +;; 2) ADDRESSP +;; +;; The HASH-CODE can be any object. If it is a relocateable object (not a +;; fixnum, short float, or immediate) then ADDRESSP will default to :KEY +;; and it is an error if NIL is returned for ADDRESSP. +;; +;; If ADDRESSP is NIL, the hashing code assumes that no addresses were used +;; in computing the HASH-CODE. If ADDRESSP is :KEY (which is the default +;; if the hash function returns only one value and it is relocateable) then +;; the hashing code assumes that only the KEY's address was used to compute +;; the HASH-CODE. Otherwise, it is assumed that the address of a +;; component of the key was used to compute the HASH-CODE. +;; +;; +;; +;; Some (proposed) functions for using in user hashing functions: +;; +;; (HASH-CODE object) +;; +;; returns two values: +;; +;; 1) HASH-CODE +;; 2) ADDRESSP +;; +;; HASH-CODE is the object transformed into a fixnum by changing its tag +;; bits to a fixnum's tag. ADDRESSP is true if the object was +;; relocateable. ;; +;; +;; (FIXNUM-ADD o1 o2) +;; Combines two objects additively and returns a fixnum. +;; If the two objects are fixnums, will be the same as (+ o1 o2) except +;; that the result can not be a bignum. +;; +;; (FIXNUM-MULTIPLY o1 o2) +;; Combines two objects multiplicatively and returns a fixnum. +;; +;; (FIXNUM-FLOOR dividend &optional divisor) +;; Same as Common Lisp's FLOOR function, but converts the objects into +;; fixnums before doing the divide and returns two fixnums: quotient & +;; remainder. +;; +;;;;;;;;;;;;; +;; +;; Implementation details. +;; +;; Hash table vectors have a header that the garbage collector knows +;; about followed by alternating keys and values. Empty slots have a +;; key of (%UNBOUND-MARKER), deleted slots are denoted by a key of +;; (%SLOT-UNBOUND-MARKER), except in the case of "lock-free" hash +;; tables, which see below. +;; +;; Four bits in the nhash.vector.flags fixnum interact with the garbage +;; collector. This description uses the symbols that represent bit numbers +;; in a fixnum. $nhash_xxx_bit has a corresponding $nhash_lap_xxx_bit which +;; gives the byte offset of the bit for LAP code. The two bytes in +;; question are at offsets $nhash.vector-weak-byte and +;; $nhash.vector-track-keys-byte offsets from the tagged vector. +;; The raw 32 bits of the fixnum at nhash.vector.flags look like: +;; +;; TKEC0000 00000000 WVFZ0000 00000000 +;; +;; +;; $nhash_track_keys_bit "T" in the diagram above +;; Sign bit of the longword at $nhash.vector.flags +;; or the byte at $nhash.vector-track-keys-byte. +;; If set, GC tracks relocation of keys in the +;; vector. +;; $nhash_key_moved_bit "K" in the diagram above +;; Set by GC to indicate that a key moved. +;; If $nhash_track_keys_bit is clear, this bit is set to +;; indicate that any GC will require a rehash. +;; GC never clears this bit, but may set it if +;; $nhash_track_keys_bit is set. +;; $nhash_component_address_bit "C" in the diagram above. +;; Ignored by GC. Set to indicate that the +;; address of a component of a key was used. +;; Means that $nhash_track_keys_bit will +;; never be set until all such keys are +;; removed. +;; $nhash_weak_bit "W" in the diagram above +;; Sign bit of the byte at $nhash.vector-weak-byte +;; Set to indicate a weak hash table +;; $nhash_weak_value_bit "V" in the diagram above +;; If clear, the table is weak on key +;; If set, the table is weak on value +;; $nhash_finalizeable_bit "F" in the diagram above +;; If set the table is finalizeable: +;; If any key/value pairs are removed, they will be added to +;; the nhash.vector.finalization-alist using cons cells +;; from nhash.vector.free-alist +;; $nhash_keys_frozen_bit "Z" in diagram above. +;; If set, GC will remove weak entries by setting the +;; value to (%slot-unbound-marker), leaving key unchanged. + +(in-package "CCL") + + +(eval-when (:compile-toplevel :execute) + (require "HASHENV" "ccl:xdump;hashenv")) + +(defvar *hash-table-class* + (progn +; #+sparc-target (dbg) + (find-class 'hash-table))) + +(setf (type-predicate 'hash-table) 'hash-table-p) + + +(defmethod print-object ((table hash-table) stream) + (print-unreadable-object (table stream :type t :identity t) + (format stream "~S ~S size ~D/~D" + ':test (hash-table-test table) + (hash-table-count table) + (hash-table-size table)) + (when (readonly-hash-table-p table) + (format stream " (Readonly)")))) + + +#+vaporware +;;; Of course, the lisp version of this would be too slow ... +(defun hash-table-finalization-list (hash-table) + (unless (hash-table-p hash-table) + (report-bad-arg hash-table 'hash-table)) + (let* ((vector (nhash.vector hash-table)) + (flags (nhash.vector.flags vector))) + (declare (fixnum flags)) + (if (logbitp $nhash_finalizeable_bit flags) + (nhash.vector.finalization-alist vector) + (error "~S is not a finalizeable hash table" hash-table)))) + +#+vaporware +(defun (setf hash-table-finalization-list) (value hash-table) + (unless (hash-table-p hash-table) + (report-bad-arg hash-table 'hash-table)) + (let* ((vector (nhash.vector hash-table)) + (flags (nhash.vector.flags vector))) + (declare (fixnum flags)) + (if (logbitp $nhash_finalizeable_bit flags) + (setf (nhash.vector.finalization-alist vector) value) + (error "~S is not a finalizeable hash table" hash-table)))) + +(defsetf gethash puthash) + +; Returns nil, :key or :value +(defun hash-table-weak-p (hash) + (unless (hash-table-p hash) + (setq hash (require-type hash 'hash-table))) + (let* ((vector (nhash.vector hash)) + (flags (nhash.vector.flags vector))) + (when (logbitp $nhash_weak_bit flags) + (if (logbitp $nhash_weak_value_bit flags) + :value + :key)))) + +;;; It would be pretty complicated to offer a way of doing (SETF +;;; HASH-TABLE-WEAK-P) after the hash-table's been created, and +;;; it's not clear that that'd be incredibly useful. + + + +;;;;;;;;;;;;; +;; +;; Mapping functions +;; + + + +(defun next-hash-table-iteration-1 (state) + (do* ((index (nhti.index state) (1+ index)) + (keys (nhti.keys state)) + (values (nhti.values state)) + (nkeys (nhti.nkeys state))) + ((>= index nkeys) + (setf (nhti.index state) nkeys) + nil) + (declare (fixnum index nkeys) + (simple-vector keys)) + (let* ((key (svref keys index)) + (value (svref values index))) + (setf (nhti.index state) (1+ index)) + (return (values t key value))))) + + + +(defun maphash (function hash-table) + "For each entry in HASH-TABLE, call the designated two-argument function + on the key and value of the entry. Return NIL." + (with-hash-table-iterator (m hash-table) + (loop + (multiple-value-bind (found key value) (m) + (unless found (return)) + (funcall function key value))))) + + + +(defmethod make-load-form ((hash hash-table) &optional env) + (declare (ignore env)) + (%normalize-hash-table-count hash) + (let ((keytransF (nhash.keytransF hash)) + (compareF (nhash.compareF hash)) + (vector (nhash.vector hash)) + (private (if (nhash.owner hash) '*current-process*)) + (lock-free-p (logtest $nhash.lock-free (the fixnum (nhash.lock hash))))) + (flet ((convert (f) + (if (or (fixnump f) (symbolp f)) + `',f + `(symbol-function ',(function-name f))))) + (values + `(%cons-hash-table + nil nil nil ,(nhash.grow-threshold hash) ,(nhash.rehash-ratio hash) ,(nhash.rehash-size hash) + nil nil ,private ,lock-free-p) + `(%initialize-hash-table ,hash ,(convert keytransF) ,(convert compareF) ',vector))))) + +(defun needs-rehashing (hash) + (%set-needs-rehashing hash)) + +(defun %initialize-hash-table (hash keytransF compareF vector) + (setf (nhash.keytransF hash) keytransF + (nhash.compareF hash) compareF) + (setf (nhash.find hash) + (case comparef + (0 #'eq-hash-find) + (-1 #'eql-hash-find) + (t #'general-hash-find)) + (nhash.find-new hash) + (case comparef + (0 #'eq-hash-find-for-put) + (-1 #'eql-hash-find-for-put) + (t #'general-hash-find-for-put))) + (setf (nhash.vector hash) vector) + (%set-needs-rehashing hash)) + + +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; +;; +;; Support for locking hash tables while fasdumping +;; + + +(defun fasl-lock-hash-table (hash-table) + (setq hash-table (require-type hash-table 'hash-table)) + (without-interrupts + (let* ((lock (nhash.exclusion-lock hash-table))) + (if lock + (progn + (if (hash-lock-free-p hash-table) + ;; For lock-free hash tables, this only makes sure nobody is + ;; rehashing the table. It doesn't necessarily stop readers + ;; or writers (unless they need to rehash). + (grab-lock lock) + (write-lock-rwlock lock)) + (push hash-table *fcomp-locked-hash-tables*)) + (unless (eq (nhash.owner hash-table) *current-process*) + (error "Current process doesn't own hash-table ~s" hash-table)))))) + +(defun fasl-unlock-hash-tables () + (dolist (h *fcomp-locked-hash-tables*) + (let* ((lock (nhash.exclusion-lock h))) + (if (hash-lock-free-p h) + (release-lock lock) + (unlock-rwlock lock))))) + + + + + +#+not-yet +(progn +;;;;;;;;;;;;; +;; +;; Replacement for population +;; +(def-accessors (weak-table) %svref + nil ; 'weak-table + weak-table.vector ; a $v_nhash vector + weak-table.index ; index for next entry + weak-table.grow-threshold ; number of entries left in vector + ) + +(defun make-weak-table (&optional (size 20)) + (%istruct 'weak-table + (%cons-nhash-vector + size (+ (ash 1 $nhash_weak_bit))) + 0 + size)) + +(defun weak-table-p (weak-table) + (istruct-typep weak-table 'weak-table)) + +(setf (type-predicate 'weak-table) 'weak-table-p) + +(defun weak-table-count (weak-table) + (setq weak-table (require-type weak-table 'weak-table)) + (- (weak-table.index weak-table) + (nhash.vector.weak-deletions-count (weak-table.vector weak-table)))) + +(defun weak-table-push (key weak-table &optional value) + (setq weak-table (require-type weak-table 'weak-table)) + (let ((thresh (weak-table.grow-threshold weak-table)) + (vector (weak-table.vector weak-table)) + (index (weak-table.index weak-table))) + (declare (fixnum thresh index)) + (if (> thresh 0) + (progn + (lap-inline (index) + (:variable vector key value) + (move.l (varg vector) atemp0) + (lea (atemp0 arg_z.l $nhash_data) atemp0) + (move.l (varg key) atemp0@+) + (move.l (varg value) @atemp0)) + (setf (weak-table.index weak-table) (the fixnum (1+ index)) + (weak-table.grow-threshold weak-table) (the fixnum (1- thresh))) + value) + (let ((deletions (nhash.vector.weak-deletions-count vector))) + (declare (fixnum deletions)) + (if (> deletions 0) + ; GC deleted some entries, we can compact the table + (progn + (lap-inline (index) + (:variable vector) + (getint arg_z) ; length + (move.l (varg vector) atemp0) + (lea (atemp0 $nhash_data) atemp0) + (move.l atemp0 atemp1) + (move.l ($ $undefined) da) + ; Find the first deleted entry + (dbfloop.l arg_z + (if# (ne (cmp.l @atemp0 da)) + (add.l ($ 1) arg_z) + (bra @move)) + (add.w ($ 8) atemp0)) + ; copy the rest of the table up + @move + (dbfloop.l arg_z + (move.l atemp0@+ db) + (if# (eq (cmp.l db da)) + (add.w ($ 4) atemp0) + else# + (move.l db atemp1@+) + (move.l atemp0@+ atemp1@+))) + ; Write over the newly emptied part of the table + (while# (ne (cmp.l atemp0 atemp1)) + (move.l da @atemp1) + (add.l ($ 8) atemp1))) + (setf (nhash.vector.weak-deletions-count vector) 0 + (weak-table.index weak-table) (the fixnum (- index deletions)) + (weak-table.grow-threshold weak-table) (the fixnum (+ thresh deletions))) + (weak-table-push key weak-table value)) + ; table is full. Grow it by a factor of 1.5 + (let* ((new-size (+ index (the fixnum (ash (the fixnum (1+ index)) -1)))) + (new-vector (%cons-nhash-vector new-size (ash 1 $nhash_weak_bit)))) + (declare (fixnum new-size)) + (lap-inline (index) + (:variable vector new-vector count) + (move.l (varg vector) atemp0) + (move.l (varg new-vector) atemp1) + (lea (atemp0 $nhash_data) atemp0) + (lea (atemp1 $nhash_data) atemp1) + (getint arg_z) ; table length + (dbfloop.l arg_z + (move.l atemp0@+ atemp1@+) + (move.l atemp0@+ atemp1@+))) + (setf (weak-table.vector weak-table) new-vector + (weak-table.grow-threshold weak-table) (the fixnum (- new-size index))) + ; It's possible that GC deleted some entries while consing the new vector + (setf (nhash.vector.weak-deletions-count new-vector) + (nhash.vector.weak-deletions-count vector)) + (weak-table-push key weak-table value))))))) + +; function gets two args: key & value +(defun map-weak-table (function weak-table) + (setq weak-table (require-type weak-table 'weak-table)) + (let* ((vector (weak-table.vector weak-table)) + (index (weak-table.index weak-table)) + (flags (nhash.vector.flags vector))) + (unwind-protect + (progn + (setf (nhash.vector.flags vector) 0) ; disable deletion by GC + (lap-inline () + (:variable function vector index) + (while# (gt (move.l (varg index) da)) + (sub.l '1 da) + (move.l da (varg index)) + (move.l (varg vector) atemp0) + (move.l (atemp0 da.l $nhash_data) arg_y) + (if# (ne (cmp.w ($ $undefined) arg_y)) + (move.l (atemp0 da.l (+ $nhash_data 4)) arg_z) + (set_nargs 2) + (move.l (varg function) atemp0) + (jsr_subprim $sp-funcall)))) + nil) + (setf (nhash.vector.flags vector) flags)))) + +; function gets one arg, the key +(defun map-weak-table-keys (function weak-table) + (flet ((f (key value) + (declare (ignore value)) + (funcall function key))) + (declare (dynamic-extent #'f)) + (map-weak-table #'f weak-table))) + +) ; #+not-yet + +; end Index: /branches/new-random/lib/late-clos.lisp =================================================================== --- /branches/new-random/lib/late-clos.lisp (revision 13309) +++ /branches/new-random/lib/late-clos.lisp (revision 13309) @@ -0,0 +1,70 @@ +;;;-*-Mode: LISP; Package: CCL -*- +;;; +;;; Copyright (C) 2007-2009 Clozure Associates and contributors. +;;; This file is part of Clozure CL. +;;; +;;; Clozure CL is licensed under the terms of the Lisp Lesser GNU Public +;;; License , known as the LLGPL and distributed with Clozure CL as the +;;; file "LICENSE". The LLGPL consists of a preamble and the LGPL, +;;; which is distributed with Clozure CL as the file "LGPL". Where these +;;; conflict, the preamble takes precedence. +;;; +;;; Clozure CL is referenced in the preamble as the "LIBRARY." +;;; +;;; The LLGPL is also available online at +;;; http://opensource.franz.com/preamble.html + +;;; Maybe compile specialized discriminating code (dcode) for generic +;;; functions, if it seems likely that that might perform better than +;;; the general generic-function-dispatch mechanism. + + +;;; If the GF accepts a fixed number of arguments, return its +;;; lambda list. +(defun gf-fixed-arg-lambda-list (gf) + (let* ((lambda-list (generic-function-lambda-list gf))) + (dolist (arg lambda-list lambda-list) + (when (member arg lambda-list-keywords) + (return nil))))) + +(defun generate-conformance-test (arg-name specializer) + (cond ((typep specializer 'eql-specializer) + `(eql ,arg-name ',(eql-specializer-object specializer))) + ((eq specializer *t-class*)) + ((typep specializer 'standard-class) + (let* ((wrapper (gensym))) + `(let* ((,wrapper (if (= (the fixnum (typecode ,arg-name)) + target::subtag-instance) + (instance.class-wrapper ,arg-name)))) + (and ,wrapper + (memq ,specializer (or (%wrapper-cpl ,wrapper) + (%inited-class-cpl + (%wrapper-class ,wrapper)))))))) + (t `(typep ,arg-name ',(class-name specializer))))) + +(defun generate-conformance-clause (args method) + `((and ,@(mapcar #'generate-conformance-test args (method-specializers method))) + (funcall ,(method-function method) ,@args))) + +;;; Generate code to call the single fixed-arg primary method +;;; defined on GF if all args are conformant, or to call +;;; NO-APPLICABLE-METHOD otherwise. +;;; Note that we can often do better than this for accessor +;;; methods (especially reader methods) as a very late (delivery-time) +;;; optimization. +(defun dcode-for-fixed-arg-singleton-gf (gf) + (let* ((methods (generic-function-methods gf)) + (method (car methods)) + (args (gf-fixed-arg-lambda-list gf))) + (when (and method + args + (null (cdr methods)) + (null (method-qualifiers method)) + (dolist (spec (method-specializers method)) + (unless (eq spec *t-class*) (return t)))) + (compile nil + `(lambda ,args + (cond ,(generate-conformance-clause args method) + (t (no-applicable-method ,gf ,@args)))))))) + +(register-non-dt-dcode-function #'dcode-for-fixed-arg-singleton-gf) Index: /branches/new-random/lib/level-2.lisp =================================================================== --- /branches/new-random/lib/level-2.lisp (revision 13309) +++ /branches/new-random/lib/level-2.lisp (revision 13309) @@ -0,0 +1,483 @@ +;;;-*-Mode: LISP; Package: CCL -*- +;;; +;;; Copyright (C) 2009 Clozure Associates +;;; Copyright (C) 1994-2001 Digitool, Inc +;;; This file is part of Clozure CL. +;;; +;;; Clozure CL is licensed under the terms of the Lisp Lesser GNU Public +;;; License , known as the LLGPL and distributed with Clozure CL as the +;;; file "LICENSE". The LLGPL consists of a preamble and the LGPL, +;;; which is distributed with Clozure CL as the file "LGPL". Where these +;;; conflict, the preamble takes precedence. +;;; +;;; Clozure CL is referenced in the preamble as the "LIBRARY." +;;; +;;; The LLGPL is also available online at +;;; http://opensource.franz.com/preamble.html + +;; Level-2.lisp + +(in-package "CCL") + +(eval-when (eval compile) + (require "LEVEL-2") + (require "BACKQUOTE") + (require "DEFSTRUCT-MACROS")) + + + +(eval-when (eval compile) + (require "LISPEQU")) + + + + + + + + +; This incredibly essential thing is part of ANSI CL; put it in the +; right package someday. +; Like maybe when it says something about doc strings, or otherwise +; becomes useful. + +(defun parse-macro (name arglist body &optional env) + (values (parse-macro-1 name arglist body env))) + +; Return a list containing a special declaration for SYM +; if SYM is declared special in decls. +; This is so we can be pedantic about binding &WHOLE/&ENVIRONMENT args +; that have been scarfed out of a macro-like lambda list. +; The returned value is supposed to be suitable for splicing ... +(defun hoist-special-decls (sym decls) + (when sym + (dolist (decl decls) + (dolist (spec (cdr decl)) + (when (eq (car spec) 'special) + (dolist (s (%cdr spec)) + (when (eq s sym) + (return-from hoist-special-decls `((declare (special ,sym))))))))))) + +(defun parse-macro-1 (name arglist body &optional env) + (parse-macro-internal name arglist body env nil)) + +(defun parse-macro-internal (name arglist body env default-initial-value) + (unless (verify-lambda-list arglist t t t) + (error "Invalid lambda list ~s" arglist)) + (multiple-value-bind (lambda-list whole environment) + (normalize-lambda-list arglist t t) + (multiple-value-bind (body local-decs doc) + (parse-body body env t) + (let ((whole-var (gensym "WHOLE")) + (env-var (gensym "ENVIRONMENT"))) + (multiple-value-bind (bindings binding-decls) + (%destructure-lambda-list lambda-list whole-var nil nil + :cdr-p t + :whole-p nil + :use-whole-var t + :default-initial-value default-initial-value) + (when environment + (setq bindings (nconc bindings (list `(,environment ,env-var))))) + (when whole + (setq bindings (nconc bindings (list `(,whole ,whole-var))))) + (values + `(lambda (,whole-var ,env-var) + (declare (ignorable ,whole-var ,env-var)) + (block ,name + (let* ,(nreverse bindings) + ,@(when binding-decls `((declare ,@binding-decls))) + ,@local-decs + ,@body))) + doc)))))) + + +(defun %destructure-lambda-list (lambda-list wholeform lets decls + &key cdr-p (whole-p t) use-whole-var default-initial-value) + (unless (and (listp lambda-list) + (verify-lambda-list lambda-list t whole-p)) + (signal-simple-program-error "Invalid lambda list: ~s" lambda-list)) + (multiple-value-bind (normalized whole) (normalize-lambda-list + lambda-list whole-p) + (let* ((argstate :required) + (allow-other-keys nil) + (rest-arg-name nil) + (w (if use-whole-var wholeform (or whole (gensym "WHOLE")))) + (argptr (gensym "ARGS")) + (has-&key nil) + (most-recent-binding nil) + (keywords ()) + (first-keyword-init ()) + (restp nil)) + (labels ((simple-var (var &optional (initform `,default-initial-value)) + (let* ((binding `(,var ,initform))) + (unless (eq argstate :aux) + (setq most-recent-binding binding)) + (push binding lets) + binding)) + (structured-var (context sub-lambda-list initform) + (let* ((v (gensym (string context)))) + (simple-var v initform) + (multiple-value-setq (lets decls) + (%destructure-lambda-list + sub-lambda-list + v + lets + decls + :default-initial-value default-initial-value +)) + v))) + (unless use-whole-var + (if (atom w) + (simple-var w wholeform) + (progn + (setq w (structured-var "WHOLE" w (if cdr-p `(cdr ,wholeform) wholeform)) + cdr-p nil)))) + (simple-var argptr `(make-destructure-state ,@(if cdr-p `((cdr ,w)) `(,w)) ,w ',lambda-list)) + (setq most-recent-binding nil) + (push `(dynamic-extent ,argptr) decls) + (do* ((tail normalized (cdr tail))) + ((null tail) + (if has-&key + (let* ((key-check-form `(check-keywords + ',(nreverse keywords) + ,rest-arg-name ,allow-other-keys))) + (if first-keyword-init + (rplaca (cdr first-keyword-init) + `(progn + ,key-check-form + ,(cadr first-keyword-init))) + (let* ((check-var (gensym "CHECK"))) + (push `(ignorable ,check-var) decls) + (simple-var check-var key-check-form)))) + (unless restp + (let* ((checkform `(%check-extra-arguments ,argptr)) + (b most-recent-binding) + (b-init (cadr b))) + (if b + (rplaca (cdr b) `(prog1 ,b-init ,checkform)) + (let* ((junk (gensym "JUNK"))) + (simple-var junk checkform) + (push `(ignorable ,junk) decls)))))) + (values lets decls)) + (let* ((var (car tail))) + (cond ((or (eq var '&rest) (eq var '&body)) + (let* ((r (cadr tail)) + (init `(destructure-state.current ,argptr))) + (if (listp r) + (setq rest-arg-name + (structured-var "REST" r init)) + (progn + (setq rest-arg-name (gensym "REST")) + (simple-var rest-arg-name init) + (simple-var r rest-arg-name )))) + (setq restp t) + (setq tail (cdr tail))) + ((eq var '&optional) (setq argstate :optional)) + ((eq var '&key) + (setq argstate :key) + (setq has-&key t) + (unless restp + (setq restp t + rest-arg-name (gensym "KEYS")) + (push `(ignorable ,rest-arg-name) decls) + (simple-var rest-arg-name + `(destructure-state.current ,argptr)))) + ((eq var '&allow-other-keys) + (setq allow-other-keys t)) + ((eq var '&aux) + (setq argstate :aux)) + ((listp var) + (case argstate + (:required + (structured-var "REQ" var `(%pop-required-arg-ptr ,argptr))) + (:optional + (let* ((variable (car var)) + (initform (if (cdr var) + (cadr var) + `,default-initial-value)) + (spvar (if (cddr var) + (caddr var) + (gensym "OPT-SUPPLIED-P"))) + (varinit `(if ,spvar + (%default-optional-value ,argptr) + ,initform))) + (simple-var spvar + `(not (null (destructure-state.current ,argptr)))) + (if (listp variable) + (structured-var "OPT" variable varinit) + (simple-var variable varinit)))) + (:key + (let* ((explicit-key (consp (car var))) + (variable (if explicit-key + (cadar var) + (car var))) + (keyword (if explicit-key + (caar var) + (make-keyword variable))) + (initform (if (cdr var) + (cadr var) + `,default-initial-value)) + (spvar (if (cddr var) + (caddr var) + (gensym "KEY-SUPPLIED-P")))) + (push keyword keywords) + (let* ((sp-init (simple-var spvar + `(%keyword-present-p + ,rest-arg-name + ',keyword))) + (var-init `(if ,spvar + (getf ,rest-arg-name ',keyword) + ,initform))) + (unless first-keyword-init + (setq first-keyword-init sp-init)) + (if (listp variable) + (structured-var "KEY" variable var-init) + (simple-var variable var-init))))) + (:aux + (simple-var (car var) (cadr var))) + (t (error "NYI: ~s" argstate)))) + ((symbolp var) + (case argstate + (:required + (simple-var var `(%pop-required-arg-ptr ,argptr))) + (:optional + (simple-var var `(%default-optional-value ,argptr + ',default-initial-value))) + (:key + (let* ((keyword (make-keyword var))) + (push keyword keywords) + (let* ((init (simple-var + var + `(getf ,rest-arg-name + ',keyword + ,@(if default-initial-value + `(',default-initial-value)))))) + (unless first-keyword-init + (setq first-keyword-init init))))) + (:aux + (simple-var var))))))))))) + + + + + + +(defun apply-to-htab-syms (function pkg-vector) + (let* ((sym nil) + (foundp nil)) + (dotimes (i (uvsize pkg-vector)) + (declare (fixnum i)) + (multiple-value-setq (sym foundp) (%htab-symbol pkg-vector i)) + (when foundp (funcall function sym))))) + +(defun iterate-over-external-symbols (pkg-spec function) + (apply-to-htab-syms function (car (pkg.etab (pkg-arg (or pkg-spec *package*)))))) + +(defun iterate-over-present-symbols (pkg-spec function) + (let ((pkg (pkg-arg (or pkg-spec *package*)))) + (apply-to-htab-syms function (car (pkg.etab pkg))) + (apply-to-htab-syms function (car (pkg.itab pkg))))) + +(defun iterate-over-accessable-symbols (pkg-spec function) + (let* ((pkg (pkg-arg (or pkg-spec *package*))) + (used (pkg.used pkg)) + (shadowed (pkg.shadowed pkg))) + (iterate-over-present-symbols pkg function) + (when used + (if shadowed + (flet ((ignore-shadowed-conflicts (var) + (unless (%name-present-in-package-p (symbol-name var) pkg) + (funcall function var)))) + (declare (dynamic-extent #'ignore-shadowed-conflicts)) + (dolist (u used) (iterate-over-external-symbols u #'ignore-shadowed-conflicts))) + (dolist (u used) (iterate-over-external-symbols u function)))))) + +(defun iterate-over-all-symbols (function) + (dolist (pkg %all-packages%) + (iterate-over-present-symbols pkg function))) + + + +;;;Eval definitions for things open-coded by the compiler. +;;;Don't use DEFUN since it should be illegal to DEFUN compiler special forms... +;;;Of course, these aren't special forms. +(macrolet ((%eval-redef (name vars &rest body) + (when (null body) (setq body `((,name ,@vars)))) + `(setf (symbol-function ',name) + (qlfun ,name ,vars ,@body)))) + (declare (optimize (speed 1) (safety 1))) + (%eval-redef %ilsl (n x)) + (%eval-redef %ilsr (n x)) + (%eval-redef neq (x y)) + (%eval-redef not (x)) + (%eval-redef null (x)) + (%eval-redef rplaca (x y)) + (%eval-redef rplacd (x y)) + (%eval-redef set-car (x y)) + (%eval-redef set-cdr (x y)) + (%eval-redef int>0-p (x)) + (%eval-redef %get-byte (ptr &optional (offset 0)) (%get-byte ptr offset)) + (%eval-redef %get-word (ptr &optional (offset 0)) (%get-word ptr offset)) + (%eval-redef %get-signed-byte (ptr &optional (offset 0)) (%get-signed-byte ptr offset)) + (%eval-redef %get-signed-word (ptr &optional (offset 0)) (%get-signed-word ptr offset)) + (%eval-redef %get-long (ptr &optional (offset 0)) (%get-long ptr offset)) + (%eval-redef %get-fixnum (ptr &optional (offset 0)) (%get-fixnum ptr offset)) + (%eval-redef %get-signed-long (ptr &optional (offset 0)) (%get-signed-long ptr offset)) + (%eval-redef %get-unsigned-long (ptr &optional (offset 0)) (%get-unsigned-long ptr offset)) + (%eval-redef %get-ptr (ptr &optional (offset 0)) (%get-ptr ptr offset)) + (%eval-redef %get-full-long (ptr &optional (offset 0)) (%get-full-long ptr offset)) + (%eval-redef %int-to-ptr (int)) + (%eval-redef %ptr-to-int (ptr)) + (%eval-redef %ptr-eql (ptr1 ptr2)) + (%eval-redef %setf-macptr (ptr1 ptr2)) + (%eval-redef %null-ptr-p (ptr)) + + + (%eval-redef %iasr (x y)) + + + (%eval-redef %set-byte (p o &optional (new (prog1 o (setq o 0)))) + (%set-byte p o new)) + (%eval-redef %set-unsigned-byte (p o &optional (new (prog1 o (setq o 0)))) + (%set-unsigned-byte p o new)) + (%eval-redef %set-word (p o &optional (new (prog1 o (setq o 0)))) + (%set-word p o new)) + (%eval-redef %set-unsigned-word (p o &optional (new (prog1 o (setq o 0)))) + (%set-unsigned-word p o new)) + (%eval-redef %set-long (p o &optional (new (prog1 o (setq o 0)))) + (%set-long p o new)) + (%eval-redef %set-unsigned-long (p o &optional (new (prog1 o (setq o 0)))) + (%set-unsigned-long p o new)) + (%eval-redef %set-ptr (p o &optional (new (prog1 o (setq o 0)))) + (%set-ptr p o new)) + + + (%eval-redef %word-to-int (word)) + (%eval-redef %inc-ptr (ptr &optional (by 1)) (%inc-ptr ptr by)) + + (%eval-redef char-code (x)) + (%eval-redef code-char (x)) + (%eval-redef 1- (n)) + (%eval-redef 1+ (n)) + + (%eval-redef uvref (x y)) + (%eval-redef uvset (x y z)) + (%eval-redef uvsize (x)) + + (%eval-redef svref (x y)) + (%eval-redef svset (x y z)) + + + + (%eval-redef car (x)) + (%eval-redef cdr (x)) + (%eval-redef cons (x y)) + (%eval-redef endp (x)) + + (progn + (%eval-redef typecode (x)) + (%eval-redef lisptag (x)) + (%eval-redef fulltag (x)) + (%eval-redef %unbound-marker ()) + (%eval-redef %slot-unbound-marker ()) + (%eval-redef %slot-ref (v i)) + (%eval-redef %alloc-misc (count subtag &optional (initial nil initial-p)) + (if initial-p + (%alloc-misc count subtag initial) + (%alloc-misc count subtag))) + (%eval-redef %setf-double-float (x y)) + (%eval-redef %lisp-word-ref (x y)) + (%eval-redef %temp-cons (x y)) + (%eval-redef require-fixnum (x)) + (%eval-redef require-symbol (x)) + (%eval-redef require-list (x)) + (%eval-redef require-real (x)) + (%eval-redef require-simple-string (x)) + (%eval-redef require-simple-vector (x)) + (%eval-redef require-character (x)) + (%eval-redef require-number (x)) + (%eval-redef require-integer (x)) + (%eval-redef require-s8 (x)) + (%eval-redef require-u8 (x)) + (%eval-redef require-s16 (x)) + (%eval-redef require-u16 (x)) + (%eval-redef require-s32 (x)) + (%eval-redef require-u32 (x)) + (%eval-redef require-s64 (x)) + (%eval-redef require-u64 (x)) + (%eval-redef %reference-external-entry-point (x)) + ) + + (%eval-redef %get-bit (ptr offset)) + (%eval-redef %set-bit (ptr offset val)) + (%eval-redef %get-double-float (ptr &optional (offset 0)) + (%get-double-float ptr offset)) + (%eval-redef %get-single-float (ptr &optional (offset 0)) + (%get-single-float ptr offset)) + (%eval-redef %set-double-float (p o &optional (new (prog1 o (setq o 0)))) + (%set-double-float p o new)) + (%eval-redef %set-single-float (p o &optional (new (prog1 o (setq o 0)))) + (%set-single-float p o new)) + (%eval-redef assq (item list)) +) + +; In the spirit of eval-redef ... + + +;; pointer hacking stuff +; +; + + + +;;; I'd guess that the majority of bitfields in the world whose width is +;;; greater than 1 have a width of two. If that's true, this is probably +;;; faster than trying to be more clever about it would be. +(defun %get-bitfield (ptr start-bit width) + (declare (fixnum start-bit width)) + (do* ((bit #+big-endian-target start-bit + #+little-endian-target (the fixnum (1- (the fixnum (+ start-bit width)))) + #+big-endian-target (1+ bit) + #+little-endian-target (1- bit)) + (i 0 (1+ i)) + (val 0)) + ((= i width) val) + (declare (fixnum val i bit)) + (setq val (logior (ash val 1) (%get-bit ptr bit))))) + +(defun %set-bitfield (ptr start width val) + (declare (fixnum val start width)) + (do* ((v val (ash v -1)) + (bit #+big-endian-target (1- (+ start width)) + #+little-endian-target start + #+big-endian-target (1- bit) + #+little-endian-target (1+ bit)) + (i 0 (1+ i))) + ((= i width) val) + (declare (fixnum v bit i)) + (setf (%get-bit ptr bit) (logand v 1)))) + +; expands into compiler stuff + +(setf (symbol-function '%get-unsigned-byte) (symbol-function '%get-byte)) +(setf (symbol-function '%get-unsigned-word) (symbol-function '%get-word)) +(setf (symbol-function '%get-signed-long) (symbol-function '%get-long)) + +(defun decompose-record-accessor (accessor &aux ret) + (do* ((str (symbol-name accessor) (%substr str (+ i 1) len)) + (len (length str) (length str)) + (i (%str-member #\. str) (%str-member #\. str)) + (field (%substr str 0 (or i len)) (%substr str 0 (or i len)))) + ((not i) (nreverse (cons (make-keyword field) ret))) + (push (make-keyword field) ret))) + + + + +(provide 'level-2) + + + + +;; end of level-2.lisp + Index: /branches/new-random/lib/lists.lisp =================================================================== --- /branches/new-random/lib/lists.lisp (revision 13309) +++ /branches/new-random/lib/lists.lisp (revision 13309) @@ -0,0 +1,898 @@ +;;;-*-Mode: LISP; Package: CCL -*- +;;; +;;; Copyright (C) 2009 Clozure Associates +;;; Copyright (C) 1994-2001 Digitool, Inc +;;; This file is part of Clozure CL. +;;; +;;; Clozure CL is licensed under the terms of the Lisp Lesser GNU Public +;;; License , known as the LLGPL and distributed with Clozure CL as the +;;; file "LICENSE". The LLGPL consists of a preamble and the LGPL, +;;; which is distributed with Clozure CL as the file "LGPL". Where these +;;; conflict, the preamble takes precedence. +;;; +;;; Clozure CL is referenced in the preamble as the "LIBRARY." +;;; +;;; The LLGPL is also available online at +;;; http://opensource.franz.com/preamble.html + +(in-package "CCL") + +(eval-when (eval compile) + (require 'backquote) + (require 'level-2)) + + + +;;; These functions perform basic list operations: + +#| +(defun caar (list) (car (car list))) +(defun cadr (list) (car (cdr list))) +(defun cdar (list) (cdr (car list))) +(defun cddr (list) (cdr (cdr list))) + +(defun caaar (list) (car (caar list))) +(defun caadr (list) (car (cadr list))) +(defun cadar (list) (car (cdar list))) +(defun caddr (list) (car (cddr list))) +(defun cdaar (list) (cdr (caar list))) +(defun cdadr (list) (cdr (cadr list))) +(defun cddar (list) (cdr (cdar list))) +(defun cdddr (list) (cdr (cddr list))) +|# + + +(defun caaaar (list) + "Return the car of the caaar of a list." + (car (caaar list))) + +(defun caaadr (list) + "Return the car of the caadr of a list." + (car (caadr list))) + +(defun caadar (list) + "Return the car of the cadar of a list." + (car (cadar list))) + +(defun caaddr (list) + "Return the car of the caddr of a list." + (car (caddr list))) + +(defun cadaar (list) + "Return the car of the cdaar of a list." + (car (cdaar list))) + +(defun cadadr (list) + "Return the car of the cdadr of a list." + (car (cdadr list))) + +(defun caddar (list) + "Return the car of the cddar of a list." + (car (cddar list))) + +(defun cdaaar (list) + "Return the cdr of the caaar of a list." + (cdr (caaar list))) + +(defun cdaadr (list) + "Return the cdr of the caadr of a list." + (cdr (caadr list))) + +(defun cdadar (list) + "Return the cdr of the cadar of a list." + (cdr (cadar list))) + +(defun cdaddr (list) + "Return the cdr of the caddr of a list." + (cdr (caddr list))) + +(defun cddaar (list) + "Return the cdr of the cdaar of a list." + (cdr (cdaar list))) + +(defun cddadr (list) + "Return the cdr of the cdadr of a list." + (cdr (cdadr list))) + +(defun cdddar (list) + "Return the cdr of the cddar of a list." + (cdr (cddar list))) + +(defun cddddr (list) + "Return the cdr of the cdddr of a list." + (cdr (cdddr list))) + +(defun tree-equal (x y &key (test (function eql)) test-not) + "Returns T if X and Y are isomorphic trees with identical leaves." + (if test-not + (tree-equal-test-not x y test-not) + (tree-equal-test x y test))) + +(defun tree-equal-test-not (x y test-not) + (cond ((and (atom x) (atom y)) + (if (and (not x) (not y)) ;must special case end of both lists. + t + (if (not (funcall test-not x y)) t))) + ((consp x) + (and (consp y) + (tree-equal-test-not (car x) (car y) test-not) + (tree-equal-test-not (cdr x) (cdr y) test-not))) + (t ()))) + +(defun tree-equal-test (x y test) + (if (atom x) + (if (atom y) + (if (funcall test x y) t)) + (and (consp y) + (tree-equal-test (car x) (car y) test) + (tree-equal-test (cdr x) (cdr y) test)))) + +(defun first (list) + "Return the 1st object in a list or NIL if the list is empty." + (car list)) + +(defun second (list) + "Return the 2nd object in a list or NIL if there is no 2nd object." + (cadr list)) + +(defun third (list) + "Return the 3rd object in a list or NIL if there is no 3rd object." + (caddr list)) + +(defun fourth (list) + "Return the 4th object in a list or NIL if there is no 4th object." + (cadddr list)) + +(defun fifth (list) + "Return the 5th object in a list or NIL if there is no 5th object." + (car (cddddr list))) + +(defun sixth (list) + "Return the 6th object in a list or NIL if there is no 6th object." + (cadr (cddddr list))) + +(defun seventh (list) + "Return the 7th object in a list or NIL if there is no 7th object." + (caddr (cddddr list))) + +(defun eighth (list) + "Return the 8th object in a list or NIL if there is no 8th object." + (cadddr (cddddr list))) + +(defun ninth (list) + "Return the 9th object in a list or NIL if there is no 9th object." + (car (cddddr (cddddr list)))) + +(defun tenth (list) + "Return the 10th object in a list or NIL if there is no 10th object." + (cadr (cddddr (cddddr list)))) + +(defun rest (list) + "Means the same as the cdr of a list." + (cdr list)) +;;; List* is done the same as list, except that the last cons is made a +;;; dotted pair + + +;;; List Copying Functions + +;;; The list is copied correctly even if the list is not terminated by () +;;; The new list is built by cdr'ing splice which is always at the tail +;;; of the new list + + +(defun copy-alist (alist) + "Return a new association list which is EQUAL to ALIST." + (unless (endp alist) + (let ((result + (cons (if (endp (car alist)) + (car alist) + (cons (caar alist) (cdar alist)) ) + '() ))) + (do ((x (cdr alist) (cdr x)) + (splice result + (cdr (rplacd splice + (cons + (if (endp (car x)) + (car x) + (cons (caar x) (cdar x))) + '() ))) )) + ((endp x) result))))) + +;;; More Commonly-used List Functions + +(defun revappend (x y) + "Return (append (reverse x) y)." + (dolist (a x y) (push a y))) + + + + +(defun butlast (list &optional (n 1 n-p)) + "Returns a new list the same as List without the N last elements." + (setq list (require-type list 'list)) + (when (and n-p + (if (typep n 'fixnum) + (< (the fixnum n) 0) + (not (typep n 'unsigned-byte)))) + (report-bad-arg n 'unsigned-byte)) + (let* ((length (alt-list-length list))) + (declare (fixnum length)) ;guaranteed + (when (< n length) + (let* ((count (- length (the fixnum n))) + (head (cons nil nil)) + (tail head)) + (declare (fixnum count) (cons head tail) (dynamic-extent head)) + ;; Return a list of the first COUNT elements of list + (dotimes (i count (cdr head)) + (setq tail (cdr (rplacd tail (cons (pop list) nil))))))))) + + +(defun nbutlast (list &optional (n 1 n-p)) + "Modifies List to remove the last N elements." + (setq list (require-type list 'list)) + (when (and n-p + (if (typep n 'fixnum) + (< (the fixnum n) 0) + (not (typep n 'unsigned-byte)))) + (report-bad-arg n 'unsigned-byte)) + (let* ((length (alt-list-length list))) + (declare (fixnum length)) ;guaranteed + (when (< n length) + (let* ((count (1- (the fixnum (- length (the fixnum n))))) + (tail list)) + (declare (fixnum count) (list tail)) + (dotimes (i count (rplacd tail nil)) + (setq tail (cdr tail))) + list)))) + + +(defun ldiff (list object) + "Return a new list, whose elements are those of LIST that appear before + OBJECT. If OBJECT is not a tail of LIST, a copy of LIST is returned. + LIST must be a proper list or a dotted list." + (do* ((list (require-type list 'list) (cdr list)) + (result (cons nil nil)) + (splice result)) + ((atom list) + (if (eql list object) + (cdr result) + (progn (rplacd splice list) (cdr result)))) + (declare (dynamic-extent result) + (cons splice result)) + (if (eql list object) + (return (cdr result)) + (setq splice (cdr (rplacd splice (list (car list)))))))) + + +;;; Functions to alter list structure + +;;; The following are for use by SETF. + +(defun %setnth (n list newval) + "Sets the Nth element of List (zero based) to Newval." + (if (%i< n 0) + (error "~S is an illegal N for SETF of NTH." n) + (do ((count n (%i- count 1))) + ((%izerop count) (rplaca list newval) newval) + (if (endp (cdr list)) + (error "~S is too large an index for SETF of NTH." n) + (setq list (cdr list)))))) + +(defun test-not-error (test test-not) + (%err-disp $xkeyconflict :test test :test-not test-not)) + +;;; Use this with the following keyword args: +;;; (&key (key #'identity) (test #'eql testp) (test-not nil notp)) + +(eval-when (eval compile #-bccl load) + (defmacro with-set-keys (funcall) + `(cond (notp ,(append funcall '(:key key :test-not test-not))) + (t ,(append funcall '(:key key :test test))))) + +;;; Works with the above keylist. We do three clauses so that if only test-not +;;; is supplied, then we don't test eql. In each case, the args should be +;;; multiply evaluable. + +(defmacro elements-match-p (elt1 elt2) + `(or (and testp + (funcall test (funcall key ,elt1) (funcall key ,elt2))) + (and notp + (not (funcall test-not (funcall key ,elt1) (funcall key ,elt2)))) + (eql (funcall key ,elt1) (funcall key ,elt2)))) + + + +) +;;; Substitution of expressions + +;subst that doesn't call labels +(defun subst (new old tree &key key + (test #'eql testp) (test-not nil notp)) + "Substitutes new for subtrees matching old." + (if (and testp notp) + (test-not-error test test-not)) + (subst-aux new old tree key test test-not)) + +(defun subst-aux (new old subtree key test test-not) + (flet ((satisfies-the-test (item elt) + (let* ((val (if key (funcall key elt) elt))) + (if test-not + (not (funcall test-not item val)) + (funcall test item val))))) + (declare (inline satisfies-the-test)) + (cond ((satisfies-the-test old subtree) new) + ((atom subtree) subtree) + (t (let ((car (subst-aux new old (car subtree) + key test test-not )) + (cdr (subst-aux new old (cdr subtree) + key test test-not))) + (if (and (eq car (car subtree)) + (eq cdr (cdr subtree))) + subtree + (cons car cdr))))))) + +;;;subst-if without a call to labels +;;; I've always wondered how those calls to a special operator +;;; should best be avoided. Clearly, the answer involves +;;; lots of recursion. +(defun subst-if (new test tree &key key) + "Substitutes new for subtrees for which test is true." + (unless key (setq key #'identity)) + (cond ((funcall test (funcall key tree)) new) + ((atom tree) tree) + (t (let ((car (subst-if new test (car tree) :key key)) + (cdr (subst-if new test (cdr tree) :key key))) + (if (and (eq car (car tree)) + (eq cdr (cdr tree))) + tree + (cons car cdr)))))) + +;subst-if-not without a call to labels +(defun subst-if-not (new test tree &key key) + "Substitutes new for subtrees for which test is false." + (unless key (setq key #'identity)) + (cond ((not (funcall test (funcall key tree))) new) + ((atom tree) tree) + (t (let ((car (subst-if-not new test (car tree) :key key)) + (cdr (subst-if-not new test (cdr tree) :key key))) + (if (and (eq car (car tree)) + (eq cdr (cdr tree))) + tree + (cons car cdr)))))) + +(defun nsubst (new old tree &key key + (test #'eql testp) (test-not nil notp)) + "Substitute NEW for subtrees matching OLD." + (if (and testp notp) + (test-not-error test test-not)) + (nsubst-aux new old tree (or key #'identity) test test-not)) + +(defun nsubst-aux (new old subtree key test test-not) + (flet ((satisfies-the-test (item elt) + (let* ((val (if key (funcall key elt) elt))) + (if test-not + (not (funcall test-not item val)) + (funcall test item val))))) + (declare (inline satisfies-the-test)) + (cond ((satisfies-the-test old subtree) new) + ((atom subtree) subtree) + (t (do* ((last nil subtree) + (subtree subtree (cdr subtree))) + ((atom subtree) + (if (satisfies-the-test old subtree) + (set-cdr last new))) + (if (satisfies-the-test old subtree) + (return (set-cdr last new)) + (set-car subtree + (nsubst-aux new old (car subtree) + key test test-not)))) + subtree)))) + +(defun nsubst-if (new test tree &key key) + "Substitute NEW for subtrees of TREE for which TEST is true." + (unless key (setq key #'identity)) + (cond ((funcall test (funcall key tree)) new) + ((atom tree) tree) + (t (do* ((last nil tree) + (tree tree (cdr tree))) + ((atom tree) + (if (funcall test (funcall key tree)) + (set-cdr last new))) + (if (funcall test (funcall key tree)) + (return (set-cdr last new)) + (set-car tree + (nsubst-if new test (car tree) :key key)))) + tree))) + +(defun nsubst-if-not (new test tree &key key) + "Substitute NEW for subtrees of TREE for which TEST is false." + (unless key (setq key #'identity)) + (cond ((not (funcall test (funcall key tree))) new) + ((atom tree) tree) + (t (do* ((last nil tree) + (tree tree (cdr tree))) + ((atom tree) + (if (not (funcall test (funcall key tree))) + (set-cdr last new))) + (if (not (funcall test (funcall key tree))) + (return (set-cdr (cdr last) new)) + (set-car tree + (nsubst-if-not new test (car tree) :key key)))) + tree))) + +(defun sublis (alist tree &key key + (test #'eql testp) (test-not nil notp)) + "Substitute from ALIST into TREE nondestructively." + (if (and testp notp) + (test-not-error test test-not)) + (sublis-aux alist tree (or key #'identity) test test-not notp)) + +(defun sublis-aux (alist subtree key test test-not notp) + (let ((assoc (if notp + (assoc (funcall key subtree) alist :test-not test-not) + (assoc (funcall key subtree) alist :test test)))) + (cond (assoc (cdr assoc)) + ((atom subtree) subtree) + (t (let ((car (sublis-aux alist (car subtree) + key test test-not notp)) + (cdr (sublis-aux alist (cdr subtree) + key test test-not notp))) + (if (and (eq car (car subtree)) + (eq cdr (cdr subtree))) + subtree + (cons car cdr))))))) + +(eval-when (compile eval) + (defmacro nsublis-macro () + '(if notp + (assoc (funcall key subtree) alist :test-not test-not) + (assoc (funcall key subtree) alist :test test))) + ) + +(defun nsublis (alist tree &key key + (test #'eql testp) (test-not nil notp)) + "Substitute from ALIST into TRUE destructively." + (if (and testp notp) + (test-not-error test test-not)) + (nsublis-aux alist tree (or key #'identity) test test-not notp)) + +(defun nsublis-aux (alist subtree key test test-not notp &optional temp) + (cond ((setq temp (nsublis-macro)) + (cdr temp)) + ((atom subtree) subtree) + (t (do* ((last nil subtree) + (subtree subtree (cdr subtree))) + ((atom subtree) + (if (setq temp (nsublis-macro)) + (set-cdr last (cdr temp)))) + (if (setq temp (nsublis-macro)) + (return (set-cdr last (cdr temp))) + (set-car subtree + (nsublis-aux alist (car subtree) key test + test-not notp temp)))) + subtree))) + +;;; Functions for using lists as sets + + +(defun member-if (test list &key key ) + "Return tail of LIST beginning with first element satisfying TEST." + (unless key (setq key #'identity)) + (do ((list list (Cdr list))) + ((endp list) nil) + (if (funcall test (funcall key (car list))) + (return list)))) + +(defun member-if-not (test list &key key) + "Return tail of LIST beginning with first element not satisfying TEST." + (unless key (setq key #'identity)) + (do ((list list (cdr list))) + ((endp list) ()) + (if (not (funcall test (funcall key (car list)))) + (return list)))) + +(defun tailp (sublist list) ;Definition "B" + "Return true if OBJECT is the same as some tail of LIST, otherwise + returns false. LIST must be a proper list or a dotted list." + (do ((list list (%cdr list))) + ((atom list) (eql list sublist)) + (if (eq sublist list) + (return t)))) + + + +(defun union (list1 list2 &key + key + (test #'eql testp) + (test-not nil notp)) + "Returns the union of LIST1 and LIST2." + (if (and testp notp) + (test-not-error test test-not)) + (unless key (setq key #'identity)) + (let ((res list2)) + (dolist (elt list1) + (if (not (with-set-keys (member (funcall key elt) list2))) + (push elt res))) + res)) + + + + + + +(eval-when (eval compile #-bccl load) +;;; Destination and source are setf-able and many-evaluable. +;;; Sets the source to the cdr, and "conses" the 1st elt of +;;; source to destination. +(defmacro steve-splice (source destination) + `(let ((temp ,source)) + (setf ,source (cdr ,source) + (cdr temp) ,destination + ,destination temp))) +) + +(defun nunion (list1 list2 &key key + (test #'eql testp) (test-not nil notp)) + "Destructively return the union of LIST1 and LIST2." + (if (and testp notp) + (test-not-error test test-not)) + (unless key (setq key #'identity)) + (let ((res list2)) + (do () + ((endp list1)) + (if (not (with-set-keys (member (funcall key (car list1)) list2))) + (steve-splice list1 res) + (setq list1 (cdr list1)))) + res)) + + + + +(defun intersection (list1 list2 &key key + (test #'eql testp) (test-not nil notp)) + "Return the intersection of LIST1 and LIST2." + (if (and testp notp) + (test-not-error test test-not)) + (unless key (setq key #'identity)) + (let ((res nil)) + (dolist (elt list1) + (if (with-set-keys (member (funcall key elt) list2)) + (push elt res))) + res)) + +(defun nintersection (list1 list2 &key key + (test #'eql testp) (test-not nil notp)) + "Destructively return the intersection of LIST1 and LIST2." + (if (and testp notp) + (test-not-error test test-not)) + (unless key (setq key #'identity)) + (let ((res nil)) + (do () ((endp list1)) + (if (with-set-keys (member (funcall key (car list1)) list2)) + (steve-splice list1 res) + (setq list1 (Cdr list1)))) + res)) + +(defun set-difference (list1 list2 &key key + (test #'eql testp) (test-not nil notp)) + "Return the elements of LIST1 which are not in LIST2." + (if (and testp notp) + (test-not-error test test-not)) + (unless key (setq key #'identity)) + (let ((res nil)) + (dolist (elt list1) + (if (not (with-set-keys (member (funcall key elt) list2))) + (push elt res))) + res)) + +(defun nset-difference (list1 list2 &key key + (test #'eql testp) (test-not nil notp)) + "Destructively return the elements of LIST1 which are not in LIST2." + (if (and testp notp) + (test-not-error test test-not)) + (unless key (setq key #'identity)) + (let ((res nil)) + (do () ((endp list1)) + (if (not (with-set-keys (member (funcall key (car list1)) list2))) + (steve-splice list1 res) + (setq list1 (cdr list1)))) + res)) + +#| spice version +(defun set-exclusive-or (list1 list2 &key (key #'identity) + (test #'eql testp) (test-not nil notp)) + "Returns new list of elements appearing exactly once in List1 and List2. + If an element appears > once in a list and does not appear at all in the + other list, that element will appear >1 in the output list." + (let ((result nil)) + (dolist (elt list1) + (unless (with-set-keys (member (funcall key elt) list2)) + (setq result (cons elt result)))) + (dolist (elt list2) + (unless (with-set-keys (member (funcall key elt) list1)) + (setq result (cons elt result)))) + result)) +|# + +(defun set-exclusive-or (list1 list2 &key key + (test #'eql testp) (test-not nil notp) + &aux result elt1-compare elt2-compare) + "Return new list of elements appearing exactly once in LIST1 and LIST2." + (if (and testp notp) + (test-not-error test test-not)) + (unless key (setq key #'identity)) + (dolist (elt1 list1) + (setq elt1-compare (funcall key elt1)) + (if (if notp + (dolist (elt2 list2 t) + (if (not (funcall test-not elt1-compare (funcall key elt2))) + (return nil))) + (dolist (elt2 list2 t) + (if (funcall test elt1-compare (funcall key elt2)) + (return nil)))) + (push elt1 result))) + (dolist (elt2 list2) + (setq elt2-compare (funcall key elt2)) + (if (if notp + (dolist (elt1 list1 t) + (if (not (funcall test-not (funcall key elt1) elt2-compare)) + (return nil))) + (dolist (elt1 list1 t) + (if (funcall test (funcall key elt1) elt2-compare) + (return nil)))) + (push elt2 result))) + result) + +#| the description of the below SpiceLisp algorthm used for implementing + nset-exclusive-or sounds counter to CLtL. Furthermore, it fails +on the example (nset-exclusive-or (list 1 1) (list 1)) + [returns (1) but should return NIL.] ... fry + +;;; The outer loop examines list1 while the inner loop examines list2. If an +;;; element is found in list2 "equal" to the element in list1, both are +;;; spliced out. When the end of list1 is reached, what is left of list2 is +;;; tacked onto what is left of list1. The splicing operation ensures that +;;; the correct operation is performed depending on whether splice is at the +;;; top of the list or not + +(defun nset-exclusive-or (list1 list2 &key (test #'eql) (test-not nil notp) + (key #'identity)) + "Return a list with elements which appear but once in List1 and List2." + (do ((x list1 (cdr x)) + (splicex ())) + ((endp x) + (if (null splicex) + (setq list1 list2) + (rplacd splicex list2)) + list1) + (do ((y list2 (cdr y)) + (splicey ())) + ((endp y) (setq splicex x)) + (cond ((if notp + (not (funcall test-not (funcall key (car x)) + (funcall key (car y)))) + (funcall test (funcall key (car x)) + (funcall key (car y)))) + (if (null splicex) + (setq list1 (cdr x)) + (rplacd splicex (cdr x))) + (if (null splicey) + (setq list2 (cdr y)) + (rplacd splicey (cdr y))) + (return ())) ; assume lists are really sets + (t (setq splicey y)))))) +|# + +(defun nset-exclusive-or (list1 list2 &key key + (test #'eql testp) (test-not nil notp)) + "Destructively return a list with elements which appear but once in LIST1 + and LIST2." + (if (and testp notp) + (test-not-error test test-not)) + (unless key (setq key #'identity)) + (if notp + (set-exclusive-or list1 list2 :key key :test-not test-not) + (set-exclusive-or list1 list2 :key key :test test) + )) + +(defun subsetp (list1 list2 &key key + (test #'eql testp) (test-not nil notp)) + "Return T if every element in LIST1 is also in LIST2." + (if (and testp notp) + (test-not-error test test-not)) + (unless key (setq key #'identity)) + (dolist (elt list1) + (unless (with-set-keys (member (funcall key elt) list2)) + (return-from subsetp nil))) + T) + + +;;; Functions that operate on association lists + +(defun acons (key datum a-list) + "Construct a new alist by adding the pair (KEY . DATUM) to ALIST." + (cons (cons key datum) a-list)) + +(defun pairlis (keys data &optional (alist '())) + "Construct an association list from KEYS and DATA (adding to ALIST)." + (do ((x keys (cdr x)) + (y data (cdr y))) + ((and (endp x) (endp y)) alist) + (if (or (endp x) (endp y)) + (error "The lists of keys and data are of unequal length.")) + (setq alist (acons (car x) (car y) alist)))) + +(defun default-identity-key (key) + (and key (neq key 'identity) (neq key #'identity) (coerce-to-function key))) + +(defun assoc-if (predicate alist &key key) + "Return the first cons in ALIST whose CAR satisfies PREDICATE. If + KEY is supplied, apply it to the CAR of each cons before testing." + (setq key (default-identity-key key)) + (dolist (pair alist) + (when (and pair + (funcall predicate + (if key (funcall key (car pair)) + (car pair)))) + (return pair)))) + +(defun assoc-if-not (predicate alist &key key) + "Return the first cons in ALIST whose CAR does not satisfy PREDICATE. + If KEY is supplied, apply it to the CAR of each cons before testing." + (setq key (default-identity-key key)) + (dolist (pair alist) + (when (and pair + (not (funcall predicate + (if key (funcall key (car pair)) + (car pair))))) + (return pair)))) + +(defun rassoc-if (predicate alist &key key) + "Return the first cons in ALIST whose CDR satisfies PREDICATE. If KEY + is supplied, apply it to the CDR of each cons before testing." + (setq key (default-identity-key key)) + (dolist (pair alist) + (when (and pair + (funcall predicate + (if key (funcall key (cdr pair)) + (cdr pair)))) + (return pair)))) + +(defun rassoc-if-not (predicate alist &key key) + "Return the first cons in ALIST whose CDR does not satisfy PREDICATE. + If KEY is supplied, apply it to the CDR of each cons before testing." + (setq key (default-identity-key key)) + (dolist (pair alist) + (when (and pair + (not (funcall predicate + (if key (funcall key (cdr pair)) + (cdr pair))))) + (return pair)))) + + +(defun map1 (function original-arglists accumulate take-car) + "This function is called by mapc, mapcar, mapcan, mapl, maplist, and mapcon. + It Maps function over the arglists in the appropriate way. It is done when any + of the arglists runs out. Until then, it CDRs down the arglists calling the + function and accumulating results as desired." + (let* ((length (length original-arglists)) + (arglists (make-list length)) + (args (make-list length)) + (ret-list (list nil)) + (temp ret-list)) + (declare (dynamic-extent arglists args ret-list)) + (let ((argstail arglists)) + (dolist (arg original-arglists) + (setf (car (the cons argstail)) arg) + (pop argstail))) + (do ((res nil) + (argstail args args)) + ((memq nil arglists) + (if accumulate + (cdr ret-list) + (car original-arglists))) + (do ((l arglists (cdr l))) + ((not l)) + (setf (car (the cons argstail)) (if take-car (car (car l)) (car l))) + (rplaca l (cdr (car l))) + (pop argstail)) + (setq res (apply function args)) + (case accumulate + (:nconc + (setq temp (last (nconc temp res)))) + (:list (rplacd temp (list res)) + (setq temp (cdr temp))))))) + +(defun mapc (function list &rest more-lists) + "Apply FUNCTION to successive elements of lists. Return the second argument." + (declare (dynamic-extent more-lists)) + (let ((arglists (cons list more-lists))) + (declare (dynamic-extent arglists)) + (values (map1 function arglists nil t)))) + +(defun mapcar (function list &rest more-lists) + "Apply FUNCTION to successive elements of LIST. Return list of FUNCTION + return values." + (declare (dynamic-extent more-lists)) + (let ((arglists (cons list more-lists))) + (declare (dynamic-extent arglists)) + (values (map1 function arglists :list t)))) + +(defun mapcan (function list &rest more-lists) + "Apply FUNCTION to successive elements of LIST. Return NCONC of FUNCTION + results." + (declare (dynamic-extent more-lists)) + (let ((arglists (cons list more-lists))) + (declare (dynamic-extent arglists)) + (values (map1 function arglists :nconc t)))) + +(defun mapl (function list &rest more-lists) + "Apply FUNCTION to successive CDRs of list. Return NIL." + (declare (dynamic-extent more-lists)) + (let ((arglists (cons list more-lists))) + (declare (dynamic-extent arglists)) + (values (map1 function arglists nil nil)))) + +(defun maplist (function list &rest more-lists) + "Apply FUNCTION to successive CDRs of list. Return list of results." + (declare (dynamic-extent more-lists)) + (let ((arglists (cons list more-lists))) + (declare (dynamic-extent arglists)) + (values (map1 function arglists :list nil)))) + +(defun mapcon (function list &rest more-lists) + "Apply FUNCTION to successive CDRs of lists. Return NCONC of results." + (declare (dynamic-extent more-lists)) + (let ((arglists (cons list more-lists))) + (declare (dynamic-extent arglists)) + (values (map1 function arglists :nconc nil)))) + +;;; Functions for compatibility sake: + +(defun delq (item a-list &optional (n 0 np)) + "Returns list with all (up to n) elements with all elements EQ to ITEM + deleted" + ;(%print "a-list = " a-list) + (declare (type list a-list) (type integer n)) + ;(%print "a-list = " a-list) + (do ((x a-list (cdr x)) + (splice '())) + ((or (endp x) + (and np (zerop n))) + a-list) + ; (%print "a-list = " a-list) + (cond ((eq item (car x)) + (setq n (- n 1)) + (if (null splice) + (setq a-list (cdr x)) + (rplacd splice (cdr x)))) + (T (setq splice x))))) ; move splice along to include element + +(defun list-length-and-final-cdr (list) + "First value reutrned is length of regular list. + [for (a b . c), returns 2] + [for circular lists, returns NIL] + Second value is the final cdr. + [ for (a b), returns NIL + for (a b . c), returns c + for circular lists, returns NIL] + Third value only returned if we have a circular list. It is + the MAX possible length of the list until the repeat." + (do* ((n 0 (+ n 2)) + (fast list (cddr fast)) + (slow list (cdr slow))) + () + (declare (fixnum n)) + (cond ((null fast) + (return (values n nil))) + ((not (consp fast)) + (return (values n fast))) + ((null (cdr fast)) + (return (values (1+ n) nil))) + ((and (eq fast slow) (> n 0)) ;circular list + (return (values nil nil n))) + ((not (consp (cdr fast))) + (return (values (1+ n) (cdr fast))))))) + +(provide 'lists) Index: /branches/new-random/lib/macros.lisp =================================================================== --- /branches/new-random/lib/macros.lisp (revision 13309) +++ /branches/new-random/lib/macros.lisp (revision 13309) @@ -0,0 +1,3819 @@ +;;;-*-Mode: LISP; Package: CCL -*- +;;; +;;; Copyright (C) 2009 Clozure Associates +;;; Copyright (C) 1994-2001 Digitool, Inc +;;; This file is part of Clozure CL. +;;; +;;; Clozure CL is licensed under the terms of the Lisp Lesser GNU Public +;;; License , known as the LLGPL and distributed with Clozure CL as the +;;; file "LICENSE". The LLGPL consists of a preamble and the LGPL, +;;; which is distributed with Clozure CL as the file "LGPL". Where these +;;; conflict, the preamble takes precedence. +;;; +;;; Clozure CL is referenced in the preamble as the "LIBRARY." +;;; +;;; The LLGPL is also available online at +;;; http://opensource.franz.com/preamble.html + +;;; Macros (and functions/constants used at macroexpand-time) ONLY. + +(in-package "CCL") + +(eval-when (eval compile) + (require "LEVEL-2") + (require "BACKQUOTE") + (require "DEFSTRUCT-MACROS")) + +;; Constants + +(defmacro defconstant (sym val &optional (doc () doc-p) &environment env) + "Define a global constant, saying that the value is constant and may be + compiled into code. If the variable already has a value, and this is not + EQL to the new value, the code is not portable (undefined behavior). The + third argument is an optional documentation string for the variable." + (setq sym (require-type sym 'symbol) + doc (if doc-p (require-type doc 'string))) + `(progn + (eval-when (:compile-toplevel) + (define-compile-time-constant ',sym ',val ,env)) + (eval-when (:load-toplevel :execute) + (%defconstant ',sym ,val ,@(if doc-p (list doc)))))) + +;; Lists + +(defmacro %car (x) + `(car (the list ,x))) + +(defmacro set-%car (x y) + `(setf (car (the cons ,x)) ,y)) + +(defmacro %cdr (x) + `(cdr (the list ,x))) + +(defmacro set-%cdr (x y) + `(setf (cdr (the cons ,x)) ,y)) + +(defmacro %caar (x) + `(%car (%car ,x))) + +(defmacro %cadr (x) + `(%car (%cdr ,x))) + +(defmacro %cdar (x) + `(%cdr (%car ,x))) + +(defmacro %cddr (x) + `(%cdr (%cdr ,x))) + +(defmacro %caaar (x) + `(%car (%car (%car ,x)))) + +(defmacro %caadr (x) + `(%car (%car (%cdr ,x)))) + +(defmacro %cadar (x) + `(%car (%cdr (%car ,x)))) + +(defmacro %caddr (x) + `(%car (%cdr (%cdr ,x)))) + +(defmacro %cdaar (x) + `(%cdr (%car (%car ,x)))) + +(defmacro %cdadr (x) + `(%cdr (%car (%cdr ,x)))) + +(defmacro %cddar (x) + `(%cdr (%cdr (%car ,x)))) + +(defmacro %cdddr (x) + `(%cdr (%cdr (%cdr ,x)))) + +(defmacro %rplaca (x y) + `(rplaca (the cons ,x) ,y)) + +(defmacro %rplacd (x y) + `(rplacd (the cons ,x) ,y)) + +; These are open-coded by the compiler to isolate platform +; dependencies. + +(defmacro %unbound-marker-8 () + `(%unbound-marker)) + +(defmacro %slot-missing-marker () + `(%illegal-marker)) + + + + +(defmacro %null-ptr () '(%int-to-ptr 0)) + +;;;Assorted useful macro definitions + +(defmacro def-accessors (ref &rest names) + (define-accessors ref names)) + +(defmacro def-accessor-macros (ref &rest names) + (define-accessors ref names t)) + +(defun define-accessors (ref names &optional no-constants + &aux (arg (gensym)) (index 0) progn types) + (when (listp ref) + (setq types ref + ref (pop names))) + (dolist (name names) + (when name + (unless (listp name) (setq name (list name))) + (dolist (sym name) + (when sym + (push `(defmacro ,sym (,arg) (list ',ref ,arg ,index)) progn) + (unless no-constants + (push `(defconstant ,sym ,index) progn))))) + (setq index (1+ index))) + `(progn + ,.(nreverse progn) + ,@(if types `((add-accessor-types ',types ',names))) + ,index)) + +(defmacro specialv (var) + `(locally (declare (special ,var)) ,var)) + + +(defmacro prog1 (valform &rest otherforms) + (let ((val (gensym))) + `(let ((,val ,valform)) + ,@otherforms + ,val))) + +(defmacro prog2 (first second &rest others) + `(progn ,first (prog1 ,second ,@others))) + +(defmacro prog (inits &body body &environment env) + (multiple-value-bind (forms decls) (parse-body body env nil) + `(block nil + (let ,inits + ,@decls + (tagbody ,@forms))))) + +(defmacro prog* (inits &body body &environment env) + (multiple-value-bind (forms decls) (parse-body body env nil) + `(block nil + (let* ,inits + ,@decls + (tagbody ,@forms))))) + + +(defmacro %stack-block ((&rest specs) &body forms &aux vars lets) + (dolist (spec specs) + (destructuring-bind (var ptr &key clear) spec + (push var vars) + (push `(,var (%new-ptr ,ptr ,clear)) lets))) + `(let* ,(nreverse lets) + (declare (dynamic-extent ,@vars)) + (declare (type macptr ,@vars)) + (declare (unsettable ,@vars)) + ,@forms)) + +(defmacro %vstack-block (spec &body forms) + `(%stack-block (,spec) ,@forms)) + +(eval-when (:compile-toplevel :load-toplevel :execute) +(defun extract-bound-decls-for-dolist-var (var decls env) + (if (null decls) + (values nil nil) + (collect ((var-decls) + (other-decls)) + (dolist (declform decls + (let* ((vdecls (var-decls)) + (others (other-decls))) + (values (if vdecls `((declare ,@vdecls))) + (if others `((declare ,@others)))))) + ;; (assert (eq (car declform) 'declare)) + (dolist (decl (cdr declform)) + (if (atom decl) + (other-decls decl) + (let* ((spec (car decl))) + (if (specifier-type-if-known spec env) + (setq spec 'type + decl `(type ,@decl))) + (case spec + (type + (destructuring-bind (typespec &rest vars) (cdr decl) + (cond ((member var vars :test #'eq) + (setq vars (delete var vars)) + (var-decls `(type ,typespec ,var)) + (when vars + (other-decls `(type ,typespec ,@vars)))) + (t (other-decls decl))))) + ((special ingore ignorable ccl::ignore-if-unused) + (let* ((vars (cdr decl))) + (cond ((member var vars :test #'eq) + (setq vars (delete var vars)) + (var-decls `(,spec ,var)) + (when vars + (other-decls `(,spec ,@vars)))) + (t (other-decls decl))))) + (t (other-decls decl)))))))))) +) + + + +(defmacro dolist ((varsym list &optional ret) &body body &environment env) + (if (not (symbolp varsym)) (signal-program-error $XNotSym varsym)) + (multiple-value-bind (forms decls) (parse-body body env nil) + (multiple-value-bind (var-decls other-decls) + (extract-bound-decls-for-dolist-var varsym decls env) + (let* ((lstsym (gensym))) + `(do* ((,lstsym ,list (cdr (the list ,lstsym)))) + ((null ,lstsym) + ,@(if ret `((let* ((,varsym ())) + (declare (ignorable ,varsym)) + ,ret)))) + ,@other-decls + (let* ((,varsym (car ,lstsym))) + ,@var-decls + (tagbody ,@forms))))))) + +(defmacro dovector ((varsym vector &optional ret) &body body &environment env) + (if (not (symbolp varsym))(signal-program-error $XNotSym varsym)) + (let* ((toplab (gensym)) + (tstlab (gensym)) + (lengthsym (gensym)) + (indexsym (gensym)) + (vecsym (gensym))) + (multiple-value-bind (forms decls) (parse-body body env nil) + `(let* ((,vecsym ,vector) + (,lengthsym (length ,vecsym)) + (,indexsym 0) + ,varsym) + ,@decls + ,@(let ((type (nx-form-type vector env))) + (unless (eq type t) + `((declare (type ,type ,vecsym))))) + (block nil + (tagbody + (go ,tstlab) + ,toplab + (setq ,varsym (locally (declare (optimize (speed 3) (safety 0))) + (aref ,vecsym ,indexsym)) + ,indexsym (%i+ ,indexsym 1)) + ,@forms + ,tstlab + (if (%i< ,indexsym ,lengthsym) (go ,toplab))) + ,@(if ret `((progn (setq ,varsym nil) ,ret)))))))) + +(defmacro report-bad-arg (&rest args) + `(values (%badarg ,@args))) + +(defmacro %cons-restart (name action report interactive test) + `(%istruct 'restart ,name ,action ,report ,interactive ,test)) + +(defmacro restart-bind (clauses &body body) + "Executes forms in a dynamic context where the given restart bindings are + in effect. Users probably want to use RESTART-CASE. When clauses contain + the same restart name, FIND-RESTART will find the first such clause." + (let* ((restarts (mapcar #'(lambda (clause) + (list (make-symbol (symbol-name (require-type (car clause) 'symbol))) + `(%cons-restart nil nil nil nil nil))) + clauses)) + (bindings (mapcar #'(lambda (clause name) + `(make-restart ,(car name) ',(car clause) + ,@(cdr clause))) + clauses restarts)) + (cluster (gensym))) + `(let* (,@restarts) + (declare (dynamic-extent ,@(mapcar #'car restarts))) + (let* ((,cluster (list ,@bindings)) + (%restarts% (cons ,cluster %restarts%))) + (declare (dynamic-extent ,cluster %restarts%)) + (progn + ,@body))))) + +(defmacro handler-bind (clauses &body body) + "(HANDLER-BIND ( {(type handler)}* ) body) + Executes body in a dynamic context where the given handler bindings are + in effect. Each handler must take the condition being signalled as an + argument. The bindings are searched first to last in the event of a + signalled condition." + (let* ((fns) + (decls) + (bindings (mapcan #'(lambda (clause) + (destructuring-bind (condition handler) clause + (if (and (consp handler)(eq (car handler) 'function) + (consp (cadr handler))(eq (car (cadr handler)) 'lambda)) + (let ((fn (gensym))) + (push `(,fn ,handler) fns) + (push `(declare (dynamic-extent ,fn)) decls) + `(',condition ,fn)) + (list `',condition + `,handler)))) + clauses)) + (cluster (gensym))) + (if (null bindings) + `(progn ,@body) + `(let* (,@fns + (,cluster (list ,@bindings)) + (%handlers% (cons ,cluster %handlers%))) + (declare (dynamic-extent ,cluster %handlers%)) + ,@decls + ,@body)))) + +(defmacro restart-case (&environment env form &rest clauses) + "(RESTART-CASE form + {(case-name arg-list {keyword value}* body)}*) + The form is evaluated in a dynamic context where the clauses have special + meanings as points to which control may be transferred (see INVOKE-RESTART). + When clauses contain the same case-name, FIND-RESTART will find the first + such clause. If Expression is a call to SIGNAL, ERROR, CERROR or WARN (or + macroexpands into such) then the signalled condition will be associated with + the new restarts." + (let ((cluster nil)) + (when clauses (setq cluster (gensym) form (restart-case-form form env cluster))) + (flet ((restart-case-1 (name arglist &rest forms) + (let (interactive report test) + (loop + (case (car forms) + (:interactive (setq interactive (cadr forms))) + (:report (setq report (cadr forms))) + (:test (setq test (cadr forms))) + (t (return nil))) + (setq forms (cddr forms))) + (when (and report (not (stringp report))) + (setq report `#',report)) + (when interactive + (setq interactive `#',interactive)) + (when test + (setq test `#',test)) + (values (require-type name 'symbol) arglist report interactive test forms)))) + (cond ((null clauses) form) + ((and (null (cdr clauses)) (null (cadr (car clauses)))) + (let ((block (gensym)) + (restart-name (gensym))) + (multiple-value-bind (name arglist report interactive test body) + (apply #'restart-case-1 (car clauses)) + (declare (ignore arglist)) + `(block ,block + (let* ((,restart-name (%cons-restart ',name () ,report ,interactive ,test)) + (,cluster (list ,restart-name))) + (declare (dynamic-extent ,restart-name ,cluster)) + (catch ,cluster + (let ((%restarts% (cons ,cluster %restarts%))) + (declare (dynamic-extent %restarts%)) + (return-from ,block ,form)))) + ,@body)))) + (t + (let ((block (gensym)) (val (gensym)) + (index -1) restarts restart-names restart-name cases) + (while clauses + (setq index (1+ index)) + (multiple-value-bind (name arglist report interactive test body) + (apply #'restart-case-1 (pop clauses)) + (push (setq restart-name (make-symbol (symbol-name name))) restart-names) + (push (list restart-name `(%cons-restart ',name ,index ,report ,interactive ,test)) + restarts) + (when (null clauses) (setq index t)) + (push `(,index (apply #'(lambda ,arglist ,@body) ,val)) + cases))) + `(block ,block + (let ((,val (let* (,@restarts + (,cluster (list ,@(reverse restart-names)))) + (declare (dynamic-extent ,@restart-names ,cluster)) + (catch ,cluster + (let ((%restarts% (cons ,cluster %restarts%))) + (declare (dynamic-extent %restarts%)) + (return-from ,block ,form)))))) + (case (pop ,val) + ,@(nreverse cases)))))))))) + + +; Anything this hairy should die a slow and painful death. +; Unless, of course, I grossly misunderstand... +(defun restart-case-form (form env clustername) + (let ((expansion (macroexpand form env)) + (head nil)) + (if (and (listp expansion) ; already an ugly hack, made uglier by %error case ... + (memq (setq head (pop expansion)) '(signal error cerror warn %error))) + (let ((condform nil) + (signalform nil) + (cname (gensym))) + (case head + (cerror + (destructuring-bind + (continue cond &rest args) expansion + (setq condform `(condition-arg ,cond (list ,@args) 'simple-error) + signalform `(cerror ,continue ,cname)))) + ((signal error warn) + (destructuring-bind + (cond &rest args) expansion + (setq condform `(condition-arg ,cond (list ,@args) ,(if (eq head 'warning) + ''simple-warning + (if (eq head 'error) + ''simple-error + ''simple-condition))) + signalform `(,head ,cname)))) + (t ;%error + (destructuring-bind (cond args fp) expansion + (setq condform `(condition-arg ,cond ,args 'simple-error) + signalform `(%error ,cname nil ,fp))))) + `(let ((,cname ,condform)) + (with-condition-restarts ,cname ,clustername + ,signalform))) + form))) + + +(defmacro handler-case (form &rest clauses) + "(HANDLER-CASE form + { (type ([var]) body) }* ) + Execute FORM in a context with handlers established for the condition + types. A peculiar property allows type to be :NO-ERROR. If such a clause + occurs, and form returns normally, all its values are passed to this clause + as if by MULTIPLE-VALUE-CALL. The :NO-ERROR clause accepts more than one + var specification." + (let* ((no-error-clause (assoc :no-error clauses))) + (if no-error-clause + (let* ((normal-return (gensym)) + (error-return (gensym))) + `(block ,error-return + (multiple-value-call #'(lambda ,@(cdr no-error-clause)) + (block ,normal-return + (return-from ,error-return + (handler-case (return-from ,normal-return ,form) + ,@(remove no-error-clause clauses))))))) + (flet ((handler-case (type var &rest body) + (when (eq type :no-error) + (signal-program-error "Duplicate :no-error clause. ")) + (values type var body))) + (cond ((null clauses) form) + ((null (cdr clauses)) + (let ((block (gensym)) + (cluster (gensym))) + (multiple-value-bind (type var body) + (apply #'handler-case (car clauses)) + (if var + `(block ,block + ((lambda ,var ,@body) + (let* ((,cluster (list ',type))) + (declare (dynamic-extent ,cluster)) + (catch ,cluster + (let ((%handlers% (cons ,cluster %handlers%))) + (declare (dynamic-extent %handlers%)) + (return-from ,block ,form)))))) + `(block ,block + (let* ((,cluster (list ',type))) + (declare (dynamic-extent ,cluster)) + (catch ,cluster + (let ((%handlers% (cons ,cluster %handlers%))) + (declare (dynamic-extent %handlers%)) + (return-from ,block ,form))) + (locally ,@body))))))) + (t (let ((block (gensym)) (cluster (gensym)) (val (gensym)) + (index -1) handlers cases) + (while clauses + (setq index (1+ index)) + (multiple-value-bind (type var body) + (apply #'handler-case (pop clauses)) + (push `',type handlers) + (push index handlers) + (when (null clauses) (setq index t)) + (push (if var + `(,index ((lambda ,var ,@body) ,val)) + `(,index (locally ,@body))) cases))) + `(block ,block + (let ((,val (let* ((,cluster (list ,@(nreverse handlers)))) + (declare (dynamic-extent ,cluster)) + (catch ,cluster + (let ((%handlers% (cons ,cluster %handlers%))) + (declare (dynamic-extent %handlers%)) + (return-from ,block ,form)))))) + (case (pop ,val) + ,@(nreverse cases))))))))))) + +(defmacro with-simple-restart ((restart-name format-string &rest format-args) + &body body + &aux (cluster (gensym)) (temp (make-symbol (symbol-name restart-name)))) + "(WITH-SIMPLE-RESTART (restart-name format-string format-arguments) + body) + If restart-name is not invoked, then all values returned by forms are + returned. If control is transferred to this restart, it immediately + returns the values NIL and T." + (unless (and (stringp format-string) + (null format-args) + (not (%str-member #\~ (ensure-simple-string format-string)))) + (let ((stream (gensym))) + (setq format-string `#'(lambda (,stream) (format ,stream ,format-string ,@format-args))))) + `(let* ((,temp (%cons-restart ',restart-name + 'simple-restart + ,format-string + nil + nil)) + (,cluster (list ,temp))) + (declare (dynamic-extent ,temp ,cluster)) + (catch ,cluster + (let ((%restarts% (cons ,cluster %restarts%))) + (declare (dynamic-extent %restarts%)) + ,@body)))) + +;Like with-simple-restart but takes a pre-consed restart. Not CL. +(defmacro with-restart (restart &body body &aux (cluster (gensym))) + `(let* ((,cluster (list ,restart))) + (declare (dynamic-extent ,cluster)) + (catch ,cluster + (let ((%restarts% (cons ,cluster %restarts%))) + (declare (dynamic-extent %restarts%)) + ,@body)))) + +(defmacro ignore-errors (&rest forms) + "Execute FORMS handling ERROR conditions, returning the result of the last + form, or (VALUES NIL the-ERROR-that-was-caught) if an ERROR was handled." + `(handler-case (progn ,@forms) + (error (condition) (values nil condition)))) + +(defmacro def-kernel-restart (&environment env errno name arglist &body body) + (multiple-value-bind (body decls) + (parse-body body env) + `(let* ((fn (nfunction ,name (lambda ,arglist ,@decls (block ,name ,@body)))) + (pair (assq ,errno ccl::*kernel-restarts*))) + (if pair + (rplacd pair fn) + (push (cons ,errno fn) ccl::*kernel-restarts*)) + fn))) + + +;;; Setf. + +; If you change anything here, be sure to make the corresponding change +; in get-setf-method. +(defmacro setf (&rest args &environment env) + "Takes pairs of arguments like SETQ. The first is a place and the second + is the value that is supposed to go into that place. Returns the last + value. The place argument may be any of the access forms for which SETF + knows a corresponding setting form." + (let ((temp (length args)) + (accessor nil)) + (cond ((eq temp 2) + (let* ((form (car args)) + (value (cadr args))) + ;This must match get-setf-method . + (cond ((atom form) + (progn + (unless (symbolp form)(signal-program-error $XNotSym form)) + `(setq ,form ,value))) + ((eq (car form) 'the) + (unless (eql (length form) 3) + (error "Bad THE place form in (SETF ~S ~S)" form value)) + (destructuring-bind (type place) (cdr form) + `(setf ,place (the ,type ,value)))) + (t + (multiple-value-bind (ftype local-p) + (function-information (setq accessor (car form)) ENV) + (if local-p + (if (eq ftype :function) + ;Local function, so don't use global setf definitions. + (default-setf form value env) + `(setf ,(macroexpand-1 form env) ,value)) + (cond + ((setq temp (%setf-method accessor)) + (if (symbolp temp) + `(,temp ,@(cdar args) ,value) + (multiple-value-bind (dummies vals storevars setter #|getter|#) + (funcall temp form env) + (do* ((d dummies (cdr d)) + (v vals (cdr v)) + (let-list nil)) + ((null d) + (setq let-list (nreverse let-list)) + `(let* ,let-list + (declare (ignorable ,@dummies)) + (multiple-value-bind ,storevars ,value + #|,getter|# + ,setter))) + (push (list (car d) (car v)) let-list))))) + ((and (type-and-refinfo-p (setq temp (or (environment-structref-info accessor env) + (and #-bccl (boundp '%structure-refs%) + (gethash accessor %structure-refs%))))) + (not (refinfo-r/o (if (consp temp) (%cdr temp) temp)))) + (if (consp temp) + ;; strip off type, but add in a require-type + (let ((type (%car temp))) + `(the ,type (setf ,(defstruct-ref-transform (%cdr temp) (%cdar args) env) + (require-type ,value ',type)))) + `(setf ,(defstruct-ref-transform temp (%cdar args) env) + ,value))) + (t + (multiple-value-bind (res win) + (macroexpand-1 form env) + (if win + `(setf ,res ,value) + (default-setf form value env))))))))))) + ((oddp temp) + (signal-program-error "Odd number of args to SETF : ~s." args)) + (t (do* ((a args (cddr a)) (l nil)) + ((null a) `(progn ,@(nreverse l))) + (push `(setf ,(car a) ,(cadr a)) l)))))) + + +(defun default-setf (setter value &optional env) + (let* ((reader (car setter)) + (args (cdr setter)) + (gensyms (mapcar #'(lambda (sym) (declare (ignore sym)) (gensym)) args)) + types declares) + (flet ((form-type (form) + (nx-form-type form env))) + (declare (dynamic-extent #'form-type)) + (setq types (mapcar #'form-type args))) + (dolist (sym gensyms) + (let ((sym-type (pop types))) + (unless (eq sym-type t) + (push `(type ,sym-type ,sym) declares)))) + `(let ,(mapcar #'list gensyms args) + ,@(and declares (list `(declare ,@(nreverse declares)))) + (funcall #'(setf ,reader) ,value ,@gensyms)))) + +;; Establishing these setf-inverses is something that should +;; happen at compile-time +(defsetf elt set-elt) +(defsetf car set-car) +(defsetf %car set-%car) +(defsetf first set-car) +(defsetf cdr set-cdr) +(defsetf %cdr set-%cdr) +(defsetf rest set-cdr) +(defsetf uvref uvset) +(defsetf aref aset) +(defsetf svref svset) +(defsetf %svref %svset) +(defsetf char set-char) +(defsetf schar set-schar) +(defsetf %scharcode %set-scharcode) +(defsetf symbol-value set) +(defsetf symbol-plist set-symbol-plist) +(defsetf fill-pointer set-fill-pointer) + +; This sux; it calls the compiler twice (once to shove the macro in the +; environment, once to dump it into the file.) +(defmacro defmacro (name arglist &body body &environment env) + (unless (symbolp name)(signal-program-error $XNotSym name)) + (unless (listp arglist) (signal-program-error "~S is not a list." arglist)) + (multiple-value-bind (lambda-form doc) + (parse-macro-1 name arglist body env) + (let* ((normalized (normalize-lambda-list arglist t t)) + (body-pos (position '&body normalized)) + (argstring (let ((temp nil)) + (dolist (arg normalized) + (if (eq arg '&aux) + (return) + (push arg temp))) + (format nil "~:a" (nreverse temp))))) + (if (and body-pos (memq '&optional normalized)) (decf body-pos)) + `(progn + (eval-when (:compile-toplevel) + (define-compile-time-macro ',name ',lambda-form ',env)) + (eval-when (:load-toplevel :execute) + (%macro + (nfunction ,name ,lambda-form) + '(,doc ,body-pos . ,argstring)) + ',name))))) + +(defmacro define-symbol-macro (name expansion &environment env) + (unless (symbolp name)(signal-program-error $XNotSym name)) + `(progn + (eval-when (:compile-toplevel) + (define-compile-time-symbol-macro ',name ',expansion ',env)) + (eval-when (:load-toplevel :execute) + (%define-symbol-macro ',name ',expansion)))) + +;; ---- allow inlining setf functions +(defmacro defun (spec args &body body &environment env &aux global-name inline-spec) + "Define a function at top level." + (validate-function-name spec) + (setq args (require-type args 'list)) + (setq body (require-type body 'list)) + (multiple-value-bind (forms decls doc) (parse-body body env t) + (cond ((symbolp spec) + (setq global-name spec) + (setq inline-spec spec) + (setq body `(block ,spec ,@forms))) + ((setf-function-name-p spec) + (setq inline-spec spec) + (setq body `(block ,(cadr spec) ,@forms))) + (t (setq body `(progn ,@forms)))) + (let* ((lambda-expression `(lambda ,args + ,@(if global-name + `((declare (global-function-name ,global-name)))) + ,@decls ,body)) + (info (if (and inline-spec + (or (null env) + (definition-environment env t)) + (nx-declared-inline-p inline-spec env) + (not (and (symbolp inline-spec) + (gethash inline-spec *NX1-ALPHATIZERS*)))) + (cons doc lambda-expression) + doc))) + `(progn + (%defun (nfunction ,spec ,lambda-expression) ',info) + ',spec)))) + +(defmacro %defvar-init (var initform doc) + `(unless (%defvar ',var ,doc) + (set ',var ,initform))) + +(defmacro defvar (&environment env var &optional (value () value-p) doc) + "Define a global variable at top level. Declare the variable + SPECIAL and, optionally, initialize it. If the variable already has a + value, the old value is not clobbered. The third argument is an optional + documentation string for the variable." + (if (and doc (not (stringp doc))) (report-bad-arg doc 'string)) + (if (and (compile-file-environment-p env) (not *fasl-save-doc-strings*)) + (setq doc nil)) + `(progn + (eval-when (:compile-toplevel) + (note-variable-info ',var ,value-p ,env)) + ,(if value-p + `(%defvar-init ,var ,value ,doc) + `(%defvar ',var)) + ',var)) + +(defmacro def-standard-initial-binding (name &optional (form name) (doc nil doc-p) &environment env) + `(progn + (eval-when (:compile-toplevel) + (note-variable-info ',name t ,env)) + (define-standard-initial-binding ',name #'(lambda () ,form)) + ,@(when doc-p + `((set-documentation ',name 'variable ,doc))) + ',name)) + +(defmacro defparameter (&environment env var value &optional doc) + "Define a parameter that is not normally changed by the program, + but that may be changed without causing an error. Declare the + variable special and sets its value to VAL, overwriting any + previous value. The third argument is an optional documentation + string for the parameter." + (if (and doc (not (stringp doc))) (signal-program-error "~S is not a string." doc)) + (if (and (compile-file-environment-p env) (not *fasl-save-doc-strings*)) + (setq doc nil)) + `(progn + (eval-when (:compile-toplevel) + (note-variable-info ',var t ,env)) + (%defparameter ',var ,value ,doc))) + + +(defmacro defstatic (&environment env var value &optional doc) + "Syntax is like DEFPARAMETER. Proclaims the symbol to be special, +but also asserts that it will never be given a per-thread dynamic +binding. The value of the variable can be changed (via SETQ, etc.), +but since all threads access the same static binding of the variable, +such changes should be made with care." + (if (and doc (not (stringp doc))) (signal-program-error "~S is not a string." doc)) + (if (and (compile-file-environment-p env) (not *fasl-save-doc-strings*)) + (setq doc nil)) + `(progn + (eval-when (:compile-toplevel) + (note-variable-info ',var :global ,env)) + (%defglobal ',var ,value ,doc))) + +(defmacro defstaticvar (&environment env var value &optional doc) + "Syntax is like DEFVAR. Proclaims the symbol to be special, +but also asserts that it will never be given a per-thread dynamic +binding. The value of the variable can be changed (via SETQ, etc.), +but since all threads access the same static binding of the variable, +such changes should be made with care. Like DEFVAR, the initial value +form is not evaluated if the variable is already BOUNDP." + (if (and doc (not (stringp doc))) (signal-program-error "~S is not a string." doc)) + (if (and (compile-file-environment-p env) (not *fasl-save-doc-strings*)) + (setq doc nil)) + `(progn + (eval-when (:compile-toplevel) + (note-variable-info ',var :global ,env)) + (%symbol-bits ',var (logior (ash 1 $sym_vbit_global) (the fixnum (%symbol-bits ',var)))) + (%defvar-init ,var ,value ,doc))) + + +(defmacro defglobal (&rest args) + "Synonym for DEFSTATIC." + `(defstatic ,@args)) + + +(defmacro defloadvar (var value &optional doc) + `(progn + (defstaticvar ,var ,nil ,@(if doc `(,doc))) + (def-ccl-pointers ,var () + (setq ,var ,value)) + ',var)) + + + + +(defmacro qlfun (name args &body body) + `(nfunction ,name (lambda ,args ,@body))) + +(defmacro lfun-bits-known-function (f) + (let* ((temp (gensym))) + `(let* ((,temp (function-to-function-vector ,f))) + (%svref ,temp (the fixnum (1- (the fixnum (uvsize ,temp)))))))) + +(defmacro lfunloop (for var in function &body loop-body) + "Loop over immediates in function" + (assert (and (or (equal (symbol-name for) "FOR") (equal (symbol-name for) "AS")) + (equal (symbol-name in) "IN"))) + (let ((fn (gensym)) + (lfv (gensym)) + (i (gensym))) + `(loop with ,fn = ,function + with ,lfv = (function-to-function-vector ,fn) + for ,i from #+ppc-target 1 #+x86-target (%function-code-words ,fn) below (%i- (uvsize ,lfv) 1) + as ,var = (%svref ,lfv ,i) + ,@loop-body))) + +(defmacro cond (&rest args &aux clause) + (when args + (setq clause (car args)) + (if (cdr clause) + `(if ,(car clause) (progn ,@(cdr clause)) (cond ,@(cdr args))) + (if (cdr args) `(or ,(car clause) (cond ,@(cdr args))) + `(values ,(car clause)))))) + +(defmacro and (&rest args) + "And Form* +AND evaluates each form in sequence, from left to right. If any form +returns NIL, AND returns NIL; otherwise, AND returns the values(s) returned +by the last form. If there are no forms, AND returns T." + (if (null args) t + (if (null (cdr args)) (car args) + `(if ,(car args) (and ,@(cdr args)))))) + +(defmacro or (&rest args) + "Or Form* +OR evaluates each Form, in sequence, from left to right. +If any Form but the last returns a non-NIL value, OR returns that +single value (without evaluating any subsequent Forms.) If OR evaluates +the last Form, it returns all values returned by that Form. If there +are no Forms, OR returns NIL." + (if args + (if (cdr args) + (do* ((temp (gensym)) + (handle (list nil)) + (forms `(let ((,temp ,(pop args))) + (if ,temp ,temp ,@handle)))) + ((null (cdr args)) + (%rplaca handle (%car args)) + forms) + (%rplaca handle `(if (setq ,temp ,(%car args)) + ,temp + ,@(setq handle (list nil)))) + (setq args (%cdr args))) + (%car args)))) + +(defmacro case (key &body forms) + "CASE Keyform {({(Key*) | Key} Form*)}* + Evaluates the Forms in the first clause with a Key EQL to the value of + Keyform. If a singleton key is T then the clause is a default clause." + (let ((key-var (gensym))) + `(let ((,key-var ,key)) + (declare (ignorable ,key-var)) + (cond ,@(case-aux forms key-var nil nil))))) + +(defmacro ccase (keyplace &body forms) + "CCASE Keyform {({(Key*) | Key} Form*)}* + Evaluates the Forms in the first clause with a Key EQL to the value of + Keyform. If none of the keys matches then a correctable error is + signalled." + (let* ((key-var (gensym)) + (tag (gensym))) + `(prog (,key-var) + ,tag + (setq ,key-var ,keyplace) + (return (cond ,@(case-aux forms key-var tag keyplace)))))) + +(defmacro ecase (key &body forms) + "ECASE Keyform {({(Key*) | Key} Form*)}* + Evaluates the Forms in the first clause with a Key EQL to the value of + Keyform. If none of the keys matches then an error is signalled." + (let* ((key-var (gensym))) + `(let ((,key-var ,key)) + (declare (ignorable ,key-var)) + (cond ,@(case-aux forms key-var 'ecase nil))))) + +(defun case-aux (clauses key-var e-c-p placename &optional (used-keys (list (list '%case-core)))) + (if clauses + (let* ((key-list (caar clauses)) + (stype (if e-c-p (if (eq e-c-p 'ecase) e-c-p 'ccase) 'case)) + (test (cond ((and (not e-c-p) + (or (eq key-list 't) + (eq key-list 'otherwise))) + t) + (key-list + (cons 'or + (case-key-testers key-var used-keys key-list stype))))) + (consequent-list (or (%cdar clauses) '(nil)))) + (if (eq test t) + (progn + (when (%cdr clauses) (warn "~s or ~s clause in the middle of a ~s statement. Subsequent clauses ignored." + 't 'otherwise 'case)) + (cons (cons t consequent-list) nil)) + (cons (cons test consequent-list) + (case-aux (%cdr clauses) key-var e-c-p placename used-keys)))) + (when e-c-p + (setq used-keys `(member ,@(mapcar #'car (cdr used-keys)))) + (if (eq e-c-p 'ecase) + `((t (values (%err-disp #.$XWRONGTYPE ,key-var ',used-keys)))) + `((t (setf ,placename (ensure-value-of-type ,key-var ',used-keys ',placename)) + (go ,e-c-p))))))) + + +;;; We don't want to descend list structure more than once (like this has +;;; been doing for the last 18 years or so.) +(defun case-key-testers (symbol used-keys atom-or-list statement-type &optional recursive) + (if (or recursive (atom atom-or-list)) + (progn + (if (assoc atom-or-list used-keys) + (warn "Duplicate keyform ~s in ~s statement." atom-or-list statement-type) + (setq used-keys (nconc used-keys (list (cons atom-or-list t))))) + `((,(if (typep atom-or-list '(and number (not fixnum))) + 'eql + 'eq) + ,symbol ',atom-or-list))) + (nconc (case-key-testers symbol used-keys (car atom-or-list) statement-type t) + (when (cdr atom-or-list) + (case-key-testers symbol used-keys (%cdr atom-or-list) statement-type nil))))) + + +; generate the COND body of a {C,E}TYPECASE form +(defun typecase-aux (key-var clauses &optional e-c-p keyform) + (let* ((construct (if e-c-p (if (eq e-c-p 'etypecase) e-c-p 'ctypecase) 'typecase)) + (types ()) + (body ()) + otherwise-seen-p) + (flet ((bad-clause (c) + (signal-program-error "Invalid clause ~S in ~S form." c construct))) + (dolist (clause clauses) + (if (atom clause) + (bad-clause clause)) + (if otherwise-seen-p + (signal-program-error "OTHERWISE must be final clause in ~S form." construct)) + (destructuring-bind (typespec &body consequents) clause + (when (eq construct 'typecase) + (if (eq typespec 'otherwise) + (progn (setq typespec t) + (setq otherwise-seen-p t)))) + (unless + (dolist (already types nil) + (when (subtypep typespec already) + (warn "Clause ~S ignored in ~S form - shadowed by ~S ." clause construct (assq already clauses)) + (return t))) + (push typespec types) + (setq typespec `(typep ,key-var ',typespec)) + (push `(,typespec nil ,@consequents) body)))) + (when e-c-p + (setq types `(or ,@(nreverse types))) + (if (eq construct 'etypecase) + (push `(t (values (%err-disp #.$XWRONGTYPE ,key-var ',types))) body) + (push `(t (setf ,keyform (ensure-value-of-type ,key-var ',types ',keyform)) + (go ,e-c-p)) body)))) + `(cond ,@(nreverse body)))) + +(defmacro typecase (keyform &body clauses) + "TYPECASE Keyform {(Type Form*)}* + Evaluates the Forms in the first clause for which TYPEP of Keyform and Type + is true." + (let ((key-var (gensym))) + `(let ((,key-var ,keyform)) + (declare (ignorable ,key-var)) + ,(typecase-aux key-var clauses)))) + +(defmacro etypecase (keyform &body clauses) + "ETYPECASE Keyform {(Type Form*)}* + Evaluates the Forms in the first clause for which TYPEP of Keyform and Type + is true. If no form is satisfied then an error is signalled." + (let ((key-var (gensym))) + `(let ((,key-var ,keyform)) + (declare (ignorable ,key-var)) + ,(typecase-aux key-var clauses 'etypecase)))) + +(defmacro ctypecase (keyplace &body clauses) + "CTYPECASE Key {(Type Form*)}* + Evaluates the Forms in the first clause for which TYPEP of Keyform and Type + is true. If no form is satisfied then a correctable error is signalled." + (let ((key-var (gensym)) + (tag (gensym))) + `(prog (,key-var) + ,tag + (setq ,key-var ,keyplace) + (return ,(typecase-aux key-var clauses tag keyplace))))) + +(defmacro destructuring-bind (lambda-list expression &body body) + "Bind the variables in LAMBDA-LIST to the contents of ARG-LIST." + (multiple-value-bind (bindings decls) + (%destructure-lambda-list lambda-list expression nil nil) + `(let* ,(nreverse bindings) + ,@(when decls `((declare ,@decls))) + ,@body))) + +(defmacro make-destructure-state (tail whole lambda) + `(%istruct 'destructure-state ,tail ,whole ,lambda)) + + +; This is supposedly ANSI CL. +(defmacro lambda (&whole lambda-expression (&rest paramlist) &body body) + (declare (ignore paramlist body)) + (unless (lambda-expression-p lambda-expression) + (warn "Invalid lambda expression: ~s" lambda-expression)) + `(function ,lambda-expression)) + +; This isn't +(defmacro nlambda (name (&rest arglist) &body body) + `(nfunction ,name (lambda ,arglist ,@body))) + +(defmacro when (test &body body) + "If the first argument is true, the rest of the forms are + evaluated as a PROGN." + `(if ,test + (progn ,@body))) + +(defmacro unless (test &body body) + "If the first argument is not true, the rest of the forms are + evaluated as a PROGN." + `(if (not ,test) + (progn ,@body))) + +(defmacro return (&optional (form nil form-p)) + `(return-from nil ,@(if form-p `(,form)))) + +; since they use tagbody, while & until BOTH return NIL +(defmacro while (test &body body) + (let ((testlab (gensym)) + (toplab (gensym))) + `(tagbody + (go ,testlab) + ,toplab + (progn ,@body) + ,testlab + (when ,test (go ,toplab))))) + +(defmacro until (test &body body) + (let ((testlab (gensym)) + (toplab (gensym))) + `(tagbody + (go ,testlab) + ,toplab + (progn ,@body) + ,testlab + (if (not ,test) + (go ,toplab))))) + +(defmacro psetq (&whole call &body pairs &environment env) + "PSETQ {var value}* + Set the variables to the values, like SETQ, except that assignments + happen in parallel, i.e. no assignments take place until all the + forms have been evaluated." + (when pairs + (if (evenp (length pairs)) + (do* ((l pairs (%cddr l)) + (sym (%car l) (%car l))) + ((null l) (%pset pairs)) + (unless (symbolp sym) (report-bad-arg sym 'symbol)) + (when (nth-value 1 (macroexpand-1 sym env)) + (return `(psetf ,@pairs)))) + (signal-program-error "Uneven number of args in the call ~S" call)))) + +; generates body for psetq. +; "pairs" is a proper list whose length is not odd. +(defun %pset (pairs) + (when pairs + (let (vars vals gensyms let-list var val sets) + (loop + (setq var (pop pairs) + val (pop pairs)) + (if (null pairs) (return)) + (push var vars) + (push val vals) + (push (gensym) gensyms)) + (dolist (g gensyms) + (push g sets) + (push (pop vars) sets) + (push (list g (pop vals)) let-list)) + (push val sets) + (push var sets) + `(progn + (let ,let-list + (setq ,@sets)) + nil)))) + + +(eval-when (:compile-toplevel :load-toplevel :execute) +(defun do-loop (binder setter env var-init-steps end-test result body) + (let ((toptag (gensym)) + (testtag (gensym))) + (multiple-value-bind (forms decls) (parse-body body env nil) + `(block nil + (,binder ,(do-let-vars var-init-steps) + ,@decls + (tagbody ; crocks-r-us. + (go ,testtag) + ,toptag + (tagbody + ,@forms) + (,setter ,@(do-step-vars var-init-steps)) + ,testtag + (unless ,end-test + (go ,toptag))) + ,@result))))) +) + +(defmacro do (&environment env var-init-steps (&optional end-test &rest result) &body body) + "DO ({(Var [Init] [Step])}*) (Test Exit-Form*) Declaration* Form* + Iteration construct. Each Var is initialized in parallel to the value of the + specified Init form. On subsequent iterations, the Vars are assigned the + value of the Step form (if any) in parallel. The Test is evaluated before + each evaluation of the body Forms. When the Test is true, the Exit-Forms + are evaluated as a PROGN, with the result being the value of the DO. A block + named NIL is established around the entire expansion, allowing RETURN to be + used as an alternate exit mechanism." + (do-loop 'let 'psetq env var-init-steps end-test result body)) + +(defmacro do* (&environment env var-init-steps (&optional end-test &rest result) &body body) + "DO* ({(Var [Init] [Step])}*) (Test Exit-Form*) Declaration* Form* + Iteration construct. Each Var is initialized sequentially (like LET*) to the + value of the specified Init form. On subsequent iterations, the Vars are + sequentially assigned the value of the Step form (if any). The Test is + evaluated before each evaluation of the body Forms. When the Test is true, + the Exit-Forms are evaluated as a PROGN, with the result being the value + of the DO. A block named NIL is established around the entire expansion, + allowing RETURN to be used as an laternate exit mechanism." + (do-loop 'let* 'setq env var-init-steps end-test result body)) + + +(defun do-let-vars (var-init-steps) + (if var-init-steps + (cons (list (do-let-vars-var (car var-init-steps)) + (do-let-vars-init (car var-init-steps))) + (do-let-vars (cdr var-init-steps))))) + +(defun do-let-vars-var (var-init-step) + (if (consp var-init-step) + (car var-init-step) + var-init-step)) + +(defun do-let-vars-init (var-init-step) + (if (consp var-init-step) + (cadr var-init-step) + nil)) + +(defun do-step-vars (var-init-steps) + (if var-init-steps + (if (do-step-vars-step? (car var-init-steps)) + (append (list (do-let-vars-var (car var-init-steps)) + (do-step-vars-step (car var-init-steps))) + (do-step-vars (cdr var-init-steps))) + (do-step-vars (cdr var-init-steps))))) + +(defun do-step-vars-step? (var-init-step) + (if (consp var-init-step) + (cddr var-init-step))) + +(defun do-step-vars-step (var-init-step) + (if (consp var-init-step) + (caddr var-init-step))) + + +(defmacro dotimes ((i n &optional result) &body body &environment env) + (multiple-value-bind (forms decls) + (parse-body body env) + (if (not (symbolp i))(signal-program-error $Xnotsym i)) + (let* ((toptag (gensym)) + (limit (gensym))) + `(block nil + (let ((,limit ,n) (,i 0)) + ,@decls + (declare (unsettable ,i)) + (if (int>0-p ,limit) + (tagbody + ,toptag + ,@forms + (locally + (declare (settable ,i)) + (setq ,i (1+ ,i))) + (unless (eql ,i ,limit) (go ,toptag)))) + ,result))))) + +(defun do-syms-result (var resultform) + (unless (eq var resultform) + (if (and (consp resultform) (not (quoted-form-p resultform))) + `(progn (setq ,var nil) ,resultform) + resultform))) + +(defun expand-package-iteration-macro (iteration-function var pkg-spec resultform body env) + (multiple-value-bind (body decls) (parse-body body env nil) + (let* ((ftemp (gensym)) + (vtemp (gensym)) + (ptemp (gensym)) + (result (do-syms-result var resultform))) + `(block nil + (let* ((,var nil) + (,ptemp ,pkg-spec)) + ,@decls + (flet ((,ftemp (,vtemp) (declare (debugging-function-name nil)) (setq ,var ,vtemp) (tagbody ,@body))) + (declare (dynamic-extent #',ftemp)) + (,iteration-function ,ptemp #',ftemp)) + ,@(when result `(,result))))))) + +(defmacro do-symbols ((var &optional pkg result) &body body &environment env) + "DO-SYMBOLS (VAR [PACKAGE [RESULT-FORM]]) {DECLARATION}* {TAG | FORM}* + Executes the FORMs at least once for each symbol accessible in the given + PACKAGE with VAR bound to the current symbol." + (expand-package-iteration-macro 'iterate-over-accessable-symbols var pkg result body env)) + +(defmacro do-present-symbols ((var &optional pkg result) &body body &environment env) + (expand-package-iteration-macro 'iterate-over-present-symbols var pkg result body env)) + +(defmacro do-external-symbols ((var &optional pkg result) &body body &environment env) + "DO-EXTERNAL-SYMBOLS (VAR [PACKAGE [RESULT-FORM]]) {DECL}* {TAG | FORM}* + Executes the FORMs once for each external symbol in the given PACKAGE with + VAR bound to the current symbol." + (expand-package-iteration-macro 'iterate-over-external-symbols var pkg result body env)) + +(defmacro do-all-symbols ((var &optional resultform) + &body body &environment env) + "DO-ALL-SYMBOLS (VAR [RESULT-FORM]) {DECLARATION}* {TAG | FORM}* + Executes the FORMs once for each symbol in every package with VAR bound + to the current symbol." + (multiple-value-bind (body decls) (parse-body body env nil) + (let* ((ftemp (gensym)) + (vtemp (gensym)) + (result (do-syms-result var resultform))) + `(block nil + (let* ((,var nil)) + ,@decls + (flet ((,ftemp (,vtemp) (declare (debugging-function-name nil)) (setq ,var ,vtemp) (tagbody ,@body))) + (declare (dynamic-extent #',ftemp)) + (iterate-over-all-symbols #',ftemp)) + ,@(when result `(,result))))))) + +(defmacro multiple-value-list (form) + `(multiple-value-call #'list ,form)) + + + + +(defmacro %i> (x y) + `(> (the fixnum ,x) (the fixnum ,y))) + +(defmacro %i< (x y) + `(< (the fixnum ,x) (the fixnum ,y))) + +(defmacro %i<= (x y) + `(not (%i> ,x ,y))) + +(defmacro %i>= (x y) + `(not (%i< ,x ,y))) + +(defmacro bitset (bit number) + `(logior (ash 1 ,bit) ,number)) + +(defmacro bitclr (bit number) + `(logand (lognot (ash 1 ,bit)) ,number)) + +(defmacro bitopf ((op bit place) &environment env) + (multiple-value-bind (vars vals stores store-form access-form) + (get-setf-method place env) + (let* ((constant-bit-p (constantp bit)) + (bitvar (if constant-bit-p bit (gensym)))) + `(let ,(unless constant-bit-p `((,bitvar ,bit))) ; compiler isn't smart enough + (let* ,(mapcar #'list `(,@vars ,@stores) `(,@vals (,op ,bitvar ,access-form))) + ,store-form))))) + +(defmacro bitsetf (bit place) + `(bitopf (bitset ,bit ,place))) + +(defmacro bitclrf (bit place) + `(bitopf (bitclr ,bit ,place))) + +(defmacro %svref (v i) + (let* ((vtemp (make-symbol "VECTOR")) + (itemp (make-symbol "INDEX"))) + `(let* ((,vtemp ,v) + (,itemp ,i)) + (locally (declare (optimize (speed 3) (safety 0))) + (svref ,vtemp ,itemp))))) + +(defmacro %svset (v i new) + (let* ((vtemp (make-symbol "VECTOR")) + (itemp (make-symbol "INDEX")) + (ntemp (make-symbol "NEW"))) + `(let* ((,vtemp ,v) + (,itemp ,i) + (,ntemp ,new)) + (locally (declare (optimize (speed 3) (safety 0))) + (setf (svref ,vtemp ,itemp) ,ntemp))))) + + +(defmacro %schar (v i) + (let* ((vtemp (make-symbol "STRING")) + (itemp (make-symbol "INDEX"))) + `(let* ((,vtemp ,v) + (,itemp ,i)) + (locally (declare (optimize (speed 3) (safety 0))) + (schar ,vtemp ,itemp))))) + +(defmacro %set-schar (v i new) + (let* ((vtemp (make-symbol "STRING")) + (itemp (make-symbol "INDEX")) + (ntemp (make-symbol "NEW"))) + `(let* ((,vtemp ,v) + (,itemp ,i) + (,ntemp ,new)) + (locally (declare (optimize (speed 3) (safety 0))) + (setf (schar ,vtemp ,itemp) ,ntemp))))) + + + +(defmacro %char-code (c) `(char-code (the character ,c))) +(defmacro %code-char (i) `(code-char (the (mod 256) ,i))) + +(defmacro %izerop (x) `(eq ,x 0)) +(defmacro %iminusp (x) `(< (the fixnum ,x) 0)) +(defmacro %i+ (&rest (&optional (n0 0) &rest others)) + (if others + `(the fixnum (+ (the fixnum ,n0) (%i+ ,@others))) + `(the fixnum ,n0))) +(defmacro %i- (x y &rest others) + (if (not others) + `(the fixnum (- (the fixnum ,x) (the fixnum ,y))) + `(the fixnum (- (the fixnum ,x) (the fixnum (%i+ ,y ,@others)))))) + + +(defmacro %i* (x y) `(the fixnum (* (the fixnum ,x) (the fixnum ,y)))) + +(defmacro %ilogbitp (b i) + (target-word-size-case + (32 + `(logbitp (the (integer 0 29) ,b) (the fixnum ,i))) + (64 + `(logbitp (the (integer 0 60) ,b) (the fixnum ,i))))) + +;;; Seq-Dispatch does an efficient type-dispatch on the given Sequence. + +(defmacro seq-dispatch (sequence list-form array-form) + `(if (sequence-type ,sequence) + ,list-form + ,array-form)) + + +(defsetf %get-byte %set-byte) +(defsetf %get-unsigned-byte %set-unsigned-byte) +(defsetf %get-signed-byte %set-byte) +(defsetf %get-word %set-word) +(defsetf %get-signed-word %set-word) +(defsetf %get-unsigned-word %set-unsigned-word) +(defsetf %get-long %set-long) +(defsetf %get-signed-long %set-long) +(defsetf %get-unsigned-long %set-unsigned-long) +(defsetf %get-full-long %set-long) +(defsetf %get-point %set-long) +(defsetf %get-ptr %set-ptr) +(defsetf %get-double-float %set-double-float) +(defsetf %get-single-float %set-single-float) +(defsetf %get-bit %set-bit) +(defsetf %get-unsigned-long-long %set-unsigned-long-long) +(defsetf %%get-unsigned-longlong %%set-unsigned-longlong) +(defsetf %get-signed-long-long %set-signed-long-long) +(defsetf %%get-signed-longlong %%set-signed-longlong) +(defsetf %get-bitfield %set-bitfield) + +(defmacro %ilognot (int) `(%i- -1 ,int)) + +(defmacro %ilogior2 (x y) + `(logior (the fixnum ,x) (the fixnum ,y))) + +(defmacro %ilogior (body &rest args) + (while args + (setq body (list '%ilogior2 body (pop args)))) + body) + +(defmacro %ilogand2 (x y) + `(logand (the fixnum ,x) (the fixnum ,y))) + +(defmacro %ilogand (body &body args) + (while args + (setq body (list '%ilogand2 body (pop args)))) + body) + +(defmacro %ilogxor2 (x y) + `(logxor (the fixnum ,x) (the fixnum ,y))) + +(defmacro %ilogxor (body &body args) + (while args + (setq body (list '%ilogxor2 body (pop args)))) + body) + +(defmacro with-macptrs (varlist &rest body &environment env) + (multiple-value-bind (body other-decls) (parse-body body env) + (collect ((temp-bindings) + (temp-decls) + (bindings) + (our-decls) + (inits)) + (dolist (var varlist) + (let* ((temp (gensym))) + (temp-decls temp) + (if (consp var) + (progn + (our-decls (car var)) + (temp-bindings `(,temp (%null-ptr))) + (bindings `(,(car var) ,temp)) + (if (cdr var) + (inits `(%setf-macptr ,temp ,@(cdr var))))) + (progn + (our-decls var) + (temp-bindings `(,temp (%null-ptr))) + (bindings `(,var ,temp)))))) + `(let* ,(temp-bindings) + (declare (dynamic-extent ,@(temp-decls))) + (declare (type macptr ,@(temp-decls))) + ,@(inits) + (let* ,(bindings) + (declare (type macptr ,@(our-decls))) + ,@other-decls + ,@body))))) + + +(defmacro with-loading-file (filename &rest body) + `(let ((*loading-files* (cons ,filename (locally (declare (special *loading-files*)) + *loading-files*)))) + (declare (special *loading-files*)) + ,@body)) + +(defmacro with-input-from-string ((var string &key index start end) &body forms &environment env) + "Create an input string stream, provide an opportunity to perform +operations on the stream (returning zero or more values), and then close +the string stream. + +STRING is evaluated first, and VAR is bound to a character input string +stream that supplies characters from the subsequence of the resulting +string bounded by start and end. BODY is executed as an implicit progn." + (multiple-value-bind (forms decls) (parse-body forms env nil) + `(let ((,var + ,(cond ((null end) + `(make-string-input-stream ,string ,(or start 0))) + ((symbolp end) + `(if ,end + (make-string-input-stream ,string ,(or start 0) ,end) + (make-string-input-stream ,string ,(or start 0)))) + (t + `(make-string-input-stream ,string ,(or start 0) ,end))))) + ,@decls + (unwind-protect + (multiple-value-prog1 + (progn ,@forms) + ,@(if index `((setf ,index (string-input-stream-index ,var))))) + (close ,var))))) + +(defmacro with-output-to-string ((var &optional string &key (element-type 'base-char element-type-p)) + &body body + &environment env) + "Create a character output stream, perform a series of operations that +may send results to this stream, and then close the stream. BODY is +executed as an implicit progn with VAR bound to an output string stream. +All output to that string stream is saved in a string." + (let ((string-var (gensym "string"))) + (multiple-value-bind (forms decls) (parse-body body env nil) + `(let* ((,string-var ,string) + (,var (if ,string-var + ,@(if element-type-p + `((progn + ,element-type + (%make-string-output-stream ,string-var))) + `((%make-string-output-stream ,string-var))) + ,@(if element-type-p + `((make-string-output-stream :element-type ,element-type)) + `((make-string-output-stream)))))) + ,@decls + (unwind-protect + (progn + ,@forms + ,@(if string () `((get-output-stream-string ,var)))) + (close ,var)))))) + +(defmacro with-output-to-truncating-string-stream ((var len) &body body + &environment env) + (multiple-value-bind (forms decls) (parse-body body env nil) + `(let* ((,var (make-truncating-string-stream ,len))) + ,@decls + (unwind-protect + (progn + ,@forms + (values (get-output-stream-string ,var) + (slot-value ,var 'truncated))) + (close ,var))))) + +(defmacro with-open-file ((var filename . args) &body body &aux (stream (gensym))(done (gensym))) + "Use open to create a file stream to file named by filename. Filename is +the name of the file to be opened. Options are used as keyword arguments +to open." + `(let (,stream ,done) + (unwind-protect + (multiple-value-prog1 + (let ((,var (setq ,stream (open ,filename ,@args)))) + ,@body) + (setq ,done t)) + (when ,stream (close ,stream :abort (null ,done)))))) + +(defmacro with-compilation-unit ((&key override) &body body) + "WITH-COMPILATION-UNIT ({Key Value}*) Form* + This form affects compilations that take place within its dynamic extent. It + is intended to be wrapped around the compilation of all files in the same + system. These keywords are defined: + :OVERRIDE Boolean-Form + One of the effects of this form is to delay undefined warnings + until the end of the form, instead of giving them at the end of each + compilation. If OVERRIDE is NIL (the default), then the outermost + WITH-COMPILATION-UNIT form grabs the undefined warnings. Specifying + OVERRIDE true causes that form to grab any enclosed warnings, even if + it is enclosed by another WITH-COMPILATION-UNIT." + `(flet ((with-compilation-unit-body () + ,@body)) + (declare (dynamic-extent #'with-compilation-unit-body)) + (call-with-compilation-unit #'with-compilation-unit-body :override ,override))) + +; Yow! Another Done Fun. +(defmacro with-standard-io-syntax (&body body &environment env) + "Bind the reader and printer control variables to values that enable READ + to reliably read the results of PRINT. These values are: + *PACKAGE* the COMMON-LISP-USER package + *PRINT-ARRAY* T + *PRINT-BASE* 10 + *PRINT-CASE* :UPCASE + *PRINT-CIRCLE* NIL + *PRINT-ESCAPE* T + *PRINT-GENSYM* T + *PRINT-LENGTH* NIL + *PRINT-LEVEL* NIL + *PRINT-LINES* NIL + *PRINT-MISER-WIDTH* NIL + *PRINT-PRETTY* NIL + *PRINT-RADIX* NIL + *PRINT-READABLY* T + *PRINT-RIGHT-MARGIN* NIL + *READ-BASE* 10 + *READ-DEFAULT-FLOAT-FORMAT* SINGLE-FLOAT + *READ-EVAL* T + *READ-SUPPRESS* NIL + *READTABLE* the standard readtable" + (multiple-value-bind (decls body) (parse-body body env) + `(let ((*package* (pkg-arg "COMMON-LISP-USER")) + (*print-array* t) + (*print-base* 10.) + (*print-case* :upcase) + (*print-circle* nil) + (*print-escape* t) + (*print-gensym* t) + (*print-length* nil) + (*print-level* nil) + (*print-lines* nil) ; This doesn't exist as of 5/15/90 - does now + (*print-miser-width* nil) + (*print-pprint-dispatch* nil) + (*print-pretty* nil) + (*print-radix* nil) + (*print-readably* t) + (*print-right-margin* nil) + (*read-base* 10.) + (*read-default-float-format* 'single-float) + (*read-eval* t) ; Also MIA as of 5/15/90 + (*read-suppress* nil) + (*readtable* %standard-readtable%) + ; ccl extensions (see l1-io.lisp) + (*print-abbreviate-quote* t) + (*print-structure* t) + (*print-simple-vector* nil) + (*print-simple-bit-vector* nil) + (*print-string-length* nil)) + ,@decls + ,@body))) + +(defmacro with-self-bound-io-control-vars (&body body) + `(let ( + (*print-array* *print-array*) + (*print-base* *print-base*) + (*print-case* *print-case*) + (*print-circle* *print-circle*) + (*print-escape* *print-escape*) + (*print-gensym* *print-gensym*) + (*print-length* *print-length*) + (*print-level* *print-level*) + (*print-lines* *print-lines*) + (*print-miser-width* *print-miser-width*) + (*print-pprint-dispatch* *print-pprint-dispatch*) + (*print-pretty* *print-pretty*) + (*print-radix* *print-radix*) + (*print-readably* *print-readably*) + (*print-right-margin* *print-right-margin*) + (*read-base* *read-base*) + (*read-default-float-format* *read-default-float-format*) + (*read-eval* *read-eval*) + (*read-suppress* *read-suppress*) + (*readtable* *readtable*)) + ,@body)) + +(defmacro print-unreadable-object (&environment env (object stream &key type identity) &body forms) + "Output OBJECT to STREAM with \"#<\" prefix, \">\" suffix, optionally + with object-type prefix and object-identity suffix, and executing the + code in BODY to provide possible further output." + (multiple-value-bind (body decls) (parse-body forms env) + (if body + (let ((thunk (gensym))) + `(let ((,thunk #'(lambda () ,@decls ,@body))) + (declare (dynamic-extent ,thunk)) + (%print-unreadable-object ,object ,stream ,type ,identity ,thunk))) + `(%print-unreadable-object ,object ,stream ,type ,identity nil)))) +;; Pointers and Handles + +;;Add function to lisp system pointer functions, and run it if it's not already +;; there. +(defmacro def-ccl-pointers (name arglist &body body &aux (old (gensym))) + `(flet ((,name ,arglist ,@body)) + (let ((,old (member ',name *lisp-system-pointer-functions* :key #'function-name))) + (if ,old + (rplaca ,old #',name) + (progn + (push #',name *lisp-system-pointer-functions*) + (,name)))))) + +(defmacro def-load-pointers (name arglist &body body &aux (old (gensym))) + `(flet ((,name ,arglist ,@body)) + (let ((,old (member ',name *lisp-user-pointer-functions* :key #'function-name))) + (if ,old + (rplaca ,old #',name) + (progn + (push #',name *lisp-user-pointer-functions*) + (,name)))))) + +;Queue up some code to run after ccl all loaded up, or, if ccl is already +;loaded up, just run it right now. +(defmacro queue-fixup (&rest body &aux (fn (gensym))) + `(let ((,fn #'(lambda () ,@body))) + (if (eq %lisp-system-fixups% T) + (funcall ,fn) + (push (cons ,fn (or *loading-toplevel-location* *loading-file-source-file*)) %lisp-system-fixups%)))) + +(defmacro %incf-ptr (p &optional (by 1)) + (if (symbolp p) ;once-only + `(%setf-macptr (the macptr ,p) (%inc-ptr ,p ,by)) + (let ((var (gensym))) + `(let ((,var ,p)) (%setf-macptr (the macptr ,var) (%inc-ptr ,var ,by)))))) + +(defmacro with-string-from-cstring ((s ptr) &body body) + (let* ((len (gensym)) + (p (gensym))) + `(let* ((,p ,ptr) + (,len (%cstrlen ,p)) + (,s (make-string ,len))) + (declare (fixnum ,len)) + (%copy-ptr-to-ivector ,p 0 ,s 0 ,len) + (locally + ,@body)))) + + +(defmacro with-cstr ((sym str &optional start end) &rest body &environment env) + (multiple-value-bind (body decls) (parse-body body env nil) + (if (and (base-string-p str) (null start) (null end)) + (let ((strlen (%i+ (length str) 1))) + `(%stack-block ((,sym ,strlen)) + ,@decls + (%cstr-pointer ,str ,sym) + ,@body)) + (let ((strname (gensym)) + (start-name (gensym)) + (end-name (gensym))) + `(let ((,strname ,str) + ,@(if (or start end) + `((,start-name ,(or start 0)) + (,end-name ,(or end `(length ,strname)))))) + (%vstack-block (,sym + (the fixnum + (1+ + (the fixnum + ,(if (or start end) + `(byte-length + ,strname ,start-name ,end-name) + `(length ,strname)))))) + ,@decls + ,(if (or start end) + `(%cstr-segment-pointer ,strname ,sym ,start-name ,end-name) + `(%cstr-pointer ,strname ,sym)) + ,@body)))))) + +(defmacro with-utf-8-cstr ((sym str) &body body) + (let* ((data (gensym)) + (offset (gensym)) + (string (gensym)) + (len (gensym)) + (noctets (gensym)) + (end (gensym))) + `(let* ((,string ,str) + (,len (length ,string))) + (multiple-value-bind (,data ,offset) (array-data-and-offset ,string) + (let* ((,end (+ ,offset ,len)) + (,noctets (utf-8-octets-in-string ,data ,offset ,end))) + (%stack-block ((,sym (1+ ,noctets))) + (utf-8-memory-encode ,data ,sym 0 ,offset ,end) + (setf (%get-unsigned-byte ,sym ,noctets) 0) + ,@body)))))) + + + +(defmacro with-native-utf-16-cstr ((sym str) &body body) + (let* ((data (gensym)) + (offset (gensym)) + (string (gensym)) + (len (gensym)) + (noctets (gensym)) + (end (gensym))) + `(let* ((,string ,str) + (,len (length ,string))) + (multiple-value-bind (,data ,offset) (array-data-and-offset ,string) + (let* ((,end (+ ,offset ,len)) + (,noctets (utf-16-octets-in-string ,data ,offset ,end))) + (%stack-block ((,sym (1+ ,noctets))) + (native-utf-16-memory-encode ,data ,sym 0 ,offset ,end) + (setf (%get-unsigned-word ,sym ,noctets) 0) + ,@body)))))) + +(defmacro with-pointers (speclist &body body) + (with-specs-aux 'with-pointer speclist body)) + + + +(defmacro with-cstrs (speclist &body body) + (with-specs-aux 'with-cstr speclist body)) + +(defmacro with-utf-8-cstrs (speclist &body body) + (with-specs-aux 'with-utf-8-cstr speclist body)) + +(defmacro with-native-utf-16-cstrs (speclist &body body) + (with-specs-aux 'with-native-utf-16-cstr speclist body)) + +(defmacro with-encoded-cstr ((encoding-name (sym string &optional start end)) + &rest body &environment env) + (let* ((encoding (gensym)) + (str (gensym))) + (multiple-value-bind (body decls) (parse-body body env nil) + `(let* ((,str ,string) + (,encoding (get-character-encoding ,encoding-name))) + (%stack-block ((,sym (cstring-encoded-length-in-bytes ,encoding ,str ,start ,end) :clear t)) + ,@decls + (encode-string-to-memory ,encoding ,sym 0 ,str ,start ,end) + ,@body))))) + +(defmacro with-encoded-cstrs (encoding-name bindings &body body) + (with-specs-aux 'with-encoded-cstr (mapcar #'(lambda (b) + `(,encoding-name ,b)) + bindings) body)) + +(defmacro with-filename-cstrs (&rest rest) + (case (target-os-name) + (:darwin `(with-utf-8-cstrs ,@rest)) + (:windows `(with-native-utf-16-cstrs ,@rest)) + (t `(with-encoded-cstrs (pathname-encoding-name) ,@rest)))) + + +(defun with-specs-aux (name spec-list original-body) + (multiple-value-bind (body decls) (parse-body original-body nil) + (when decls (signal-program-error "declarations not allowed in ~s" original-body)) + (setq body (cons 'progn body)) + (dolist (spec (reverse spec-list)) + (setq body (list name spec body))) + body)) + + +(defmacro type-predicate (type) + `(get-type-predicate ,type)) + +(defsetf type-predicate set-type-predicate) + +(defun adjust-defmethod-lambda-list (ll) + ;; If the lambda list contains &key, ensure that it also contains + ;; &allow-other-keys + (if (or (not (memq '&key ll)) + (memq '&allow-other-keys ll)) + ll + (if (memq '&aux ll) + (let* ((ll (copy-list ll)) + (aux (memq '&aux ll))) + (setf (car aux) '&allow-other-keys + (cdr aux) (cons '&aux (cdr aux))) + ll) + (append ll '(&allow-other-keys))))) + +(defmacro defmethod (name &rest args &environment env) + (multiple-value-bind (function-form specializers-form qualifiers lambda-list documentation specializers) + (parse-defmethod name args env) + `(progn + (eval-when (:compile-toplevel) + (record-function-info ',(maybe-setf-function-name name) + ',(multiple-value-bind (bits keyvect) (encode-lambda-list lambda-list t) + (unless bits ;; verify failed + (signal-program-error "Invalid lambda list ~s" + (find-if #'listp args))) + (%cons-def-info 'defmethod bits keyvect nil specializers qualifiers)) + ,env)) + (compiler-let ((*nx-method-warning-name* '(,name ,@qualifiers ,specializers))) + (ensure-method ',name ,specializers-form + :function ,function-form + :qualifiers ',qualifiers + :lambda-list ',lambda-list + ,@(if documentation `(:documentation ,documentation))))))) + + +(defun seperate-defmethod-decls (decls) + (let (outer inner) + (dolist (decl decls) + (if (neq (car decl) 'declare) + (push decl outer) + (let (outer-list inner-list) + (dolist (d (cdr decl)) + (if (and (listp d) (eq (car d) 'dynamic-extent)) + (let (in out) + (dolist (fspec (cdr d)) + (if (and (listp fspec) + (eq (car fspec) 'function) + (listp (cdr fspec)) + (null (cddr fspec)) + (memq (cadr fspec) '(call-next-method next-method-p))) + (push fspec in) + (push fspec out))) + (when out + (push `(dynamic-extent ,@(nreverse out)) outer-list)) + (when in + (push `(dynamic-extent ,@(nreverse in)) inner-list))) + (push d outer-list))) + (when outer-list + (push `(declare ,@(nreverse outer-list)) outer)) + (when inner-list + (push `(declare ,@(nreverse inner-list)) inner))))) + (values (nreverse outer) (nreverse inner)))) + + +(defvar *warn-about-unreferenced-required-args-in-methods* #+ccl-0711 nil #-ccl-0711 T) + +(defun parse-defmethod (name args env) + (validate-function-name name) + (let (qualifiers lambda-list parameters specializers specializers-form refs types temp) + (until (listp (car args)) + (push (pop args) qualifiers)) + (setq lambda-list (pop args)) + (while (and lambda-list (not (memq (car lambda-list) lambda-list-keywords))) + (let ((p (pop lambda-list))) + (cond ((consp p) + (unless (and (consp (%cdr p)) (null (%cddr p))) + (signal-program-error "Illegal arg ~S" p)) + (push (%car p) parameters) + (push (%car p) refs) + (setq p (%cadr p)) + (cond ((and (consp p) (eq (%car p) 'eql) + (consp (%cdr p)) (null (%cddr p))) + (push `(list 'eql ,(%cadr p)) specializers-form) + (push p specializers)) + ((or (setq temp (non-nil-symbol-p p)) + (specializer-p p)) + (push `',p specializers-form) + (push p specializers) + (unless (or (eq p t) (not temp)) + ;Should be `(guaranteed-type ...). + (push `(type ,p ,(%car parameters)) types))) + (t (signal-program-error "Illegal arg ~S" p)))) + (t + (push p parameters) + (unless *warn-about-unreferenced-required-args-in-methods* + (push p refs)) + (push t specializers-form) + (push t specializers))))) + (setq lambda-list (nreconc parameters lambda-list)) + (multiple-value-bind (body decls doc) (parse-body args env t) + (multiple-value-bind (outer-decls inner-decls) + (seperate-defmethod-decls decls) + (let* ((methvar (make-symbol "NEXT-METHOD-CONTEXT")) + (cnm-args (gensym)) + (lambda-form `(lambda ,(list* '&method methvar lambda-list) + (declare ;,@types + (ignorable ,@refs)) + ,@outer-decls + (block ,(if (consp name) (cadr name) name) + (flet ((call-next-method (&rest ,cnm-args) + (declare (dynamic-extent ,cnm-args)) + (if ,cnm-args + (apply #'%call-next-method-with-args ,methvar ,cnm-args) + (%call-next-method ,methvar))) + (next-method-p () (%next-method-p ,methvar))) + (declare (inline call-next-method next-method-p)) + ,@inner-decls + ,@body))))) + (values + (if name `(nfunction ,name ,lambda-form) `(function ,lambda-form)) + `(list ,@(nreverse specializers-form)) + (nreverse qualifiers) + lambda-list + doc + (nreverse specializers))))))) + +(defmacro anonymous-method (name &rest args &environment env) + (multiple-value-bind (function-form specializers-form qualifiers method-class documentation) + (parse-defmethod name args env) + + `(%anonymous-method + ,function-form + ,specializers-form + ',qualifiers + ,@(if (or method-class documentation) `(',method-class)) + ,@(if documentation `(,documentation))))) + + + +(defmacro defclass (class-name superclasses slots &rest class-options &environment env) + (flet ((duplicate-options (where) (signal-program-error "Duplicate options in ~S" where)) + (illegal-option (option) (signal-program-error "Illegal option ~s" option)) + (make-initfunction (form) + (cond ((or (eq form 't) + (equal form ''t)) + '(function true)) + ((or (eq form 'nil) + (equal form ''nil)) + '(function false)) + (t + `(function (lambda () ,form)))))) + (setq class-name (require-type class-name '(and symbol (not null)))) + (setq superclasses (mapcar #'(lambda (s) (require-type s 'symbol)) superclasses)) + (let* ((options-seen ()) + (signatures ()) + (slot-names ()) + (slot-initargs ())) + (flet ((canonicalize-defclass-option (option) + (let* ((option-name (car option))) + (if (member option-name options-seen :test #'eq) + (duplicate-options class-options) + (push option-name options-seen)) + (case option-name + (:default-initargs + (let ((canonical ()) + (initargs-seen ())) + (let (key val (tail (cdr option))) + (loop (when (null tail) (return nil)) + (setq key (pop tail) + val (pop tail)) + (when (memq key initargs-seen) + (SIGNAL-PROGRAM-error "Duplicate initialization argument name ~S in :DEFAULT-INITARGS of DEFCLASS ~S" key class-name)) + (push key initargs-seen) + (push ``(,',key ,',val ,,(make-initfunction val)) canonical)) + `(':direct-default-initargs (list ,@(nreverse canonical)))))) + (:metaclass + (unless (and (cadr option) + (typep (cadr option) 'symbol)) + (illegal-option option)) + `(:metaclass ',(cadr option))) + (:documentation + `(:documentation ',(cadr option))) + (t + (list `',option-name `',(cdr option)))))) + (canonicalize-slot-spec (slot) + (if (null slot) (signal-program-error "Illegal slot NIL")) + (if (not (listp slot)) (setq slot (list slot))) + (let* ((slot-name (require-type (car slot) 'symbol)) + (initargs nil) + (other-options ()) + (initform nil) + (initform-p nil) + (initfunction nil) + (type nil) + (type-p nil) + (allocation nil) + (allocation-p nil) + (documentation nil) + (documentation-p nil) + (readers nil) + (writers nil) + (reader-info (%cons-def-info 'defmethod (dpb 1 $lfbits-numreq 0) nil nil (list class-name))) + (writer-info (%cons-def-info 'defmethod (dpb 2 $lfbits-numreq 0) nil nil (list t class-name)))) + (when (memq slot-name slot-names) + (signal-program-error "Multiple slots named ~S in DEFCLASS ~S" slot-name class-name)) + (push slot-name slot-names) + (do ((options (cdr slot) (cddr options)) + name) + ((null options)) + (when (null (cdr options)) (signal-program-error "Illegal slot spec ~S" slot)) + (case (car options) + (:reader + (setq name (cadr options)) + (unless (memq name readers) + (push (cons name reader-info) signatures) + (push name readers))) + (:writer + (setq name (cadr options)) + (unless (member name writers :test 'equal) + (push (cons name writer-info) signatures) + (push name writers))) + (:accessor + (setq name (cadr options)) + (unless (memq name readers) + (push (cons name reader-info) signatures) + (push name readers)) + (let ((setf-name `(setf ,name))) + (unless (member setf-name writers :test 'equal) + (push (cons (setf-function-name name) writer-info) signatures) + (push setf-name writers)))) + (:initarg + (let* ((initarg (require-type (cadr options) 'symbol)) + (other (position initarg slot-initargs :test #'memq))) + (when other + (warn "Initarg ~s occurs in both ~s and ~s slots" + initarg (nth (1+ other) slot-names) slot-name)) + (push initarg initargs))) + (:type + (if type-p + (duplicate-options slot) + (setq type-p t)) + (setq type (cadr options)) + ;; complain about illegal typespecs and continue + (handler-case (specifier-type type env) + (program-error () + (warn "Invalid type ~s in ~s slot definition ~s" type class-name slot)))) + (:initform + (if initform-p + (duplicate-options slot) + (setq initform-p t)) + (let ((option (cadr options))) + (setq initform `',option + initfunction + (if (constantp option) + `(constantly ,option) + `#'(lambda () ,option))))) + (:allocation + (if allocation-p + (duplicate-options slot) + (setq allocation-p t)) + (setq allocation (cadr options))) + (:documentation + (if documentation-p + (duplicate-options slot) + (setq documentation-p t)) + (setq documentation (cadr options))) + (t + (let* ((pair (or (assq (car options) other-options) + (car (push (list (car options)) other-options))))) + (push (cadr options) (cdr pair)))))) + (push initargs slot-initargs) + `(list :name ',slot-name + ,@(when allocation `(:allocation ',allocation)) + ,@(when initform-p `(:initform ,initform + :initfunction ,initfunction)) + ,@(when initargs `(:initargs ',initargs)) + ,@(when readers `(:readers ',readers)) + ,@(when writers `(:writers ',writers)) + ,@(when type-p `(:type ',type)) + ,@(when documentation-p `(:documentation ,documentation)) + ,@(mapcan #'(lambda (opt) + `(',(car opt) ',(if (null (cddr opt)) + (cadr opt) + (cdr opt)))) other-options))))) + (let* ((direct-superclasses superclasses) + (direct-slot-specs (mapcar #'canonicalize-slot-spec slots)) + (other-options (apply #'append (mapcar #'canonicalize-defclass-option class-options ))) + (keyvect (class-keyvect class-name other-options))) + (when (vectorp keyvect) + (let ((illegal (loop for arg in other-options by #'cddr + as key = (if (quoted-form-p arg) (%cadr arg) arg) + unless (or (eq key :metaclass) (find key keyvect)) collect key))) + (when illegal + (signal-program-error "Class option~p~{ ~s~} is not one of ~s" + (length illegal) illegal keyvect)))) + `(progn + (when (memq ',class-name *nx-known-declarations*) + (check-declaration-redefinition ',class-name 'defclass)) + (eval-when (:compile-toplevel) + (%compile-time-defclass ',class-name ,env) + (progn + ,@(mapcar #'(lambda (sig) `(record-function-info ',(car sig) ',(cdr sig) ,env)) + signatures))) + (ensure-class-for-defclass ',class-name + :direct-superclasses ',direct-superclasses + :direct-slots ,`(list ,@direct-slot-specs) + ,@other-options))))))) + +(defmacro define-method-combination (name &rest rest &environment env) + (setq name (require-type name 'symbol)) + (cond ((or (null rest) (and (car rest) (symbolp (car rest)))) + `(short-form-define-method-combination ',name ',rest)) + ((listp (car rest)) + (destructuring-bind (lambda-list method-group-specifiers . forms) rest + (long-form-define-method-combination + name lambda-list method-group-specifiers forms env))) + (t (%badarg (car rest) '(or (and null symbol) list))))) + +(defmacro defgeneric (function-name lambda-list &rest options-and-methods &environment env) + (fboundp function-name) ; type-check + (multiple-value-bind (method-combination generic-function-class options methods) + (parse-defgeneric function-name t lambda-list options-and-methods) + (let ((gf (gensym))) + `(progn + (eval-when (:compile-toplevel) + (record-function-info ',(maybe-setf-function-name function-name) + ',(multiple-value-bind (bits keyvect) (encode-lambda-list lambda-list t) + (%cons-def-info 'defgeneric bits keyvect)) + ,env)) + (let ((,gf (%defgeneric + ',function-name ',lambda-list ',method-combination ',generic-function-class + ',(apply #'append options)))) + (%set-defgeneric-methods ,gf ,@methods) + ,gf))))) + + + +(defun parse-defgeneric (function-name global-p lambda-list options-and-methods) + (check-generic-function-lambda-list lambda-list) + (let ((method-combination '(standard)) + (generic-function-class 'standard-generic-function) + options declarations methods option-keywords method-class) + (flet ((bad-option (o) + (signal-program-error "Bad option: ~s to ~s." o 'defgeneric))) + (dolist (o options-and-methods) + (let ((keyword (car o)) + (defmethod (if global-p 'defmethod 'anonymous-method))) + (if (eq keyword :method) + (let ((defn `(,defmethod ,function-name ,@(%cdr o)))) + (note-source-transformation o defn) + (push defn methods)) + (cond ((and (not (eq keyword 'declare)) + (memq keyword (prog1 option-keywords (push keyword option-keywords)))) + (signal-program-error "Duplicate option: ~s to ~s" keyword 'defgeneric)) + ((eq keyword :method-combination) + (unless (symbolp (cadr o)) + (bad-option o)) + (setq method-combination (cdr o))) + ((eq keyword :generic-function-class) + (unless (and (cdr o) (symbolp (cadr o)) (null (%cddr o))) + (bad-option o)) + (setq generic-function-class (%cadr o))) + ((eq keyword 'declare) + (push (cadr o) declarations)) + ((eq keyword :argument-precedence-order) + (dolist (arg (cdr o)) + (unless (and (symbolp arg) (memq arg lambda-list)) + (bad-option o))) + (push (list keyword (cdr o)) options)) + ((eq keyword :method-class) + (push o options) + (when (or (cddr o) (not (symbolp (setq method-class (%cadr o))))) + (bad-option o))) + ((eq keyword :documentation) + (push o options) + (when (or (cddr o) (not (stringp (%cadr o)))) + (bad-option o))) + (t (bad-option o))))))) + (when method-class + (dolist (m methods) + (push `(:method-class ,method-class) (cddr m)))) + (when declarations + (setq options `((:declarations ,declarations) ,@options))) + (values method-combination generic-function-class options methods))) + + +(defmacro def-aux-init-functions (class &rest functions) + `(set-aux-init-functions ',class (list ,@functions))) + + + + + + +;;; A powerful way of defining REPORT-CONDITION... +;;; Do they really expect that each condition type has a unique method on PRINT-OBJECT +;;; which tests *print-escape* ? Scary if so ... + +(defmacro define-condition (name (&rest supers) (&rest slots) &body options) + "DEFINE-CONDITION Name (Parent-Type*) (Slot-Spec*) Option* + Define NAME as a condition type. This new type inherits slots and its + report function from the specified PARENT-TYPEs. A slot spec is a list of: + (slot-name :reader :initarg {Option Value}* + + The DEFINE-CLASS slot options :ALLOCATION, :INITFORM, [slot] :DOCUMENTATION + and :TYPE and the overall options :DEFAULT-INITARGS and + [type] :DOCUMENTATION are also allowed. + + The :REPORT option is peculiar to DEFINE-CONDITION. Its argument is either + a string or a two-argument lambda or function name. If a function, the + function is called with the condition and stream to report the condition. + If a string, the string is printed. + + Condition types are classes, but (as allowed by ANSI and not as described in + CLtL2) are neither STANDARD-OBJECTs nor STRUCTURE-OBJECTs. WITH-SLOTS and + SLOT-VALUE may not be used on condition objects." + ; If we could tell what environment we're being expanded in, we'd + ; probably want to check to ensure that all supers name conditions + ; in that environment. + (let ((classopts nil) + (duplicate nil) + (docp nil) + (default-initargs-p nil) + (reporter nil)) + (dolist (option options) + (unless (and (consp option) + (consp (%cdr option))) + (signal-program-error "Invalid option ~s ." option)) + (ecase (%car option) + (:default-initargs + (unless (plistp (cdr option)) + (signal-program-error "~S is not a plist." (%cdr option))) + (if default-initargs-p + (setq duplicate t) + (push (setq default-initargs-p option) classopts))) + (:documentation + (unless (null (%cddr option)) + (signal-program-error "Invalid option ~s ." option)) + (if docp + (setq duplicate t) + (push (setq docp option) classopts))) + (:report + (unless (null (%cddr option)) + (signal-program-error "Invalid option ~s ." option)) + (if reporter + (setq duplicate t) + (progn + (if (or (lambda-expression-p (setq reporter (%cadr option))) + (symbolp reporter)) + (setq reporter `(function ,reporter)) + (if (stringp reporter) + (setq reporter `(function (lambda (c s) (declare (ignore c)) (write-string ,reporter s)))) + (signal-program-error "~a expression is not a string, symbol, or lambda expression ." (%car option)))) + (setq reporter `((defmethod report-condition ((c ,name) s) + (funcall ,reporter c s)))))))) + (if duplicate (signal-program-error "Duplicate option ~s ." option))) + `(progn + (defclass ,name ,(or supers '(condition)) ,slots ,@classopts) + ,@reporter + ',name))) + +(defmacro with-condition-restarts (&environment env condition restarts &body body) + "Evaluates the BODY in a dynamic environment where the restarts in the list + RESTARTS-FORM are associated with the condition returned by CONDITION-FORM. + This allows FIND-RESTART, etc., to recognize restarts that are not related + to the error currently being debugged. See also RESTART-CASE." + (multiple-value-bind (body decls) + (parse-body body env) + (let ((cond (gensym)) + (r (gensym))) + `(let* ((*condition-restarts* *condition-restarts*)) + ,@decls + (let ((,cond ,condition)) + (dolist (,r ,restarts) (push (cons ,r ,cond) *condition-restarts*)) + ,@body))))) + +(defmacro setf-find-class (name arg1 &optional (arg2 () 2-p) (arg3 () 3-p)) + (cond (3-p ;might want to pass env (arg2) to find-class someday? + `(set-find-class ,name (progn ,arg1 ,arg2 ,arg3))) + (2-p + `(set-find-class ,name (progn ,arg1 ,arg2))) + (t `(set-find-class ,name ,arg1)))) + +(defsetf find-class setf-find-class) + +(defmacro restoring-interrupt-level (var &body body) + `(unwind-protect + (progn ,@body) + (restore-interrupt-level ,var) + (%interrupt-poll))) + +(defmacro without-interrupts (&body body) + "Evaluate its body in an environment in which process-interrupt +requests are deferred." + `(let* ((*interrupt-level* -1)) + ,@body)) + +(defmacro with-interrupts-enabled (&body body) + "Evaluate its body in an environment in which process-interrupt +has immediate effect." + `(let* ((*interrupt-level* 0)) + ,@body)) + +;;; undoes the effect of one enclosing without-interrupts during execution of body. +(defmacro ignoring-without-interrupts (&body body) + `(let* ((*interrupt-level* 0)) + ,@body)) + + + +(defmacro error-ignoring-without-interrupts (format-string &rest format-args) + `(ignoring-without-interrupts + (error ,format-string ,@format-args))) + + +;init-list-default: if there is no init pair for , +; add a pair to init-list +(defmacro init-list-default (the-init-list &rest args) + (let ((result) + (init-list-sym (gensym))) + (do ((args args (cddr args))) + ((not args)) + (setq result + (cons `(if (eq '%novalue (getf ,init-list-sym ,(car args) + '%novalue)) + (setq ,init-list-sym (cons ,(car args) + (cons ,(cadr args) + ,init-list-sym)))) + result))) + `(let ((,init-list-sym ,the-init-list)) + (progn ,@result) + ,init-list-sym) + )) + +; This can only be partially backward-compatible: even if only +; the "name" arg is supplied, the old function would create the +; package if it didn't exist. +; Should see how well this works & maybe flush the whole idea. + +(defmacro in-package (name) + (let ((form nil)) + (when (quoted-form-p name) + (warn "Unquoting argument ~S to ~S." name 'in-package ) + (setq name (cadr name))) + (setq form `(set-package ,(string name))) + `(eval-when (:execute :load-toplevel :compile-toplevel) + ,form))) + +(defmacro defpackage (name &rest options) + "Defines a new package called PACKAGE. Each of OPTIONS should be one of the + following: + (NICKNAMES {package-name}*) + + (SIZE ) + (SHADOW {symbol-name}*) + (SHADOWING-IMPORT-FROM {symbol-name}*) + (USE {package-name}*) + (IMPORT-FROM {symbol-name}*) + (INTERN {symbol-name}*) + (EXPORT {symbol-name}*) + (IMPLEMENT {package-name}*) + (LOCK boolean) + (DOCUMENTATION doc-string) + All options except SIZE, LOCK, and :DOCUMENTATION can be used multiple + times." + (let* ((size nil) + (all-names-size 0) + (intern-export-size 0) + (shadow-etc-size 0) + (documentation nil) + (all-names-hash (let ((all-options-alist nil)) + (dolist (option options) + (let ((option-name (car option))) + (when (memq option-name + '(:nicknames :shadow :shadowing-import-from + :use :import-from :intern :export)) + (let ((option-size (length (cdr option))) + (cell (assq option-name all-options-alist))) + (declare (fixnum option-size)) + (if cell + (incf (cdr cell) option-size) + (push (cons option-name option-size) all-options-alist)) + (when (memq option-name '(:shadow :shadowing-import-from :import-from :intern)) + (incf shadow-etc-size option-size)) + (when (memq option-name '(:export :intern)) + (incf intern-export-size option-size)))))) + (dolist (cell all-options-alist) + (let ((option-size (cdr cell))) + (when (> option-size all-names-size) + (setq all-names-size option-size)))) + (when (> all-names-size 0) + (make-hash-table :test 'equal :size all-names-size)))) + (intern-export-hash (when (> intern-export-size 0) + (make-hash-table :test 'equal :size intern-export-size))) + (shadow-etc-hash (when (> shadow-etc-size 0) + (make-hash-table :test 'equal :size shadow-etc-size))) + (external-size nil) + (nicknames nil) + (shadow nil) + (shadowing-import-from-specs nil) + (use :default) + (import-from-specs nil) + (intern nil) + (export nil)) + (declare (fixnum all-names-size intern-export-size shadow-etc-size)) + (labels ((string-or-name (s) (string s)) + (duplicate-option (o) + (signal-program-error "Duplicate ~S option in ~S ." o options)) + (duplicate-name (name option-name) + (signal-program-error "Name ~s, used in ~s option, is already used in a conflicting option ." name option-name)) + (all-names (option-name tail already) + (when (eq already :default) (setq already nil)) + (when all-names-hash + (clrhash all-names-hash)) + (dolist (name already) + (setf (gethash (string-or-name name) all-names-hash) t)) + (dolist (name tail already) + (setq name (string-or-name name)) + (unless (gethash name all-names-hash) ; Ok to repeat name in same option. + (when (memq option-name '(:shadow :shadowing-import-from :import-from :intern)) + (if (gethash name shadow-etc-hash) + (duplicate-name name option-name)) + (setf (gethash name shadow-etc-hash) t)) + (when (memq option-name '(:export :intern)) + (if (gethash name intern-export-hash) + (duplicate-name name option-name)) + (setf (gethash name intern-export-hash) t)) + (setf (gethash name all-names-hash) t) + (push name already))))) + (dolist (option options) + (let ((args (cdr option))) + (ecase (%car option) + (:size + (if size + (duplicate-option :size) + (setq size (car args)))) + (:external-size + (if external-size + (duplicate-option :external-size) + (setq external-size (car args)))) + (:nicknames (setq nicknames (all-names nil args nicknames))) + (:shadow (setq shadow (all-names :shadow args shadow))) + (:shadowing-import-from + (destructuring-bind (from &rest shadowing-imports) args + (push (cons (string-or-name from) + (all-names :shadowing-import-from shadowing-imports nil)) + shadowing-import-from-specs))) + (:use (setq use (all-names nil args use))) + (:import-from + (destructuring-bind (from &rest imports) args + (push (cons (string-or-name from) + (all-names :import-from imports nil)) + import-from-specs))) + (:intern (setq intern (all-names :intern args intern))) + (:export (setq export (all-names :export args export))) + (:documentation + (if documentation + (duplicate-option :documentation) + (setq documentation (cadr option))))))) + `(eval-when (:execute :compile-toplevel :load-toplevel) + (%define-package ',(string-or-name name) + ',size + ',external-size + ',nicknames + ',shadow + ',shadowing-import-from-specs + ',use + ',import-from-specs + ',intern + ',export + ',documentation))))) + + + +(defmacro with-package-iterator ((mname package-list first-type &rest other-types) + &body body) + "Within the lexical scope of the body forms, MNAME is defined via macrolet + such that successive invocations of (MNAME) will return the symbols, + one by one, from the packages in PACKAGE-LIST. SYMBOL-TYPES may be + any of :INHERITED :EXTERNAL :INTERNAL." + (setq mname (require-type mname 'symbol)) + (let ((state (make-symbol "WITH-PACKAGE-ITERATOR_STATE"))) + (dolist (type (push first-type other-types)) + (ecase type + ((:external :internal :inherited)))) + `(let ((,state (%setup-pkg-iter-state ,package-list ',other-types))) + (macrolet ((,mname () `(%pkg-iter-next ,',state))) + ,@body)))) + +; Does NOT evaluate the constructor, but DOES evaluate the destructor & initializer +(defmacro defresource (name &key constructor destructor initializer) + `(defparameter ,name (make-resource #'(lambda () ,constructor) + ,@(when destructor + `(:destructor ,destructor)) + ,@(when initializer + `(:initializer ,initializer))))) + +(defmacro using-resource ((var resource) &body body) + (let ((resource-var (gensym))) + `(let ((,resource-var ,resource) + ,var) + (unwind-protect + (progn + (setq ,var (allocate-resource ,resource-var)) + ,@body) + (when ,var + (free-resource ,resource-var ,var)))))) + +;;; Bind per-thread specials which help with lock accounting. +(defmacro with-lock-context (&body body) + `(progn ,@body)) + +(defmacro with-lock-grabbed ((lock &optional + (whostate "Lock")) + &body body) + "Wait until a given lock can be obtained, then evaluate its body with +the lock held." + (declare (ignore whostate)) + (let* ((locked (gensym)) + (l (gensym))) + ` (with-lock-context + (let ((,locked (make-lock-acquisition)) + (,l ,lock)) + (declare (dynamic-extent ,locked)) + (unwind-protect + (progn + (%lock-recursive-lock-object ,l ,locked ) + ,@body) + (when (lock-acquisition.status ,locked) (%unlock-recursive-lock-object ,l))))))) + +(defmacro with-lock-grabbed-maybe ((lock &optional + (whostate "Lock")) + &body body) + (declare (ignore whostate)) + (let* ((l (gensym))) + `(with-lock-context + (let* ((,l ,lock)) + (when (%try-recursive-lock-object ,l) + (unwind-protect + (progn ,@body) + (%unlock-recursive-lock-object ,l))))))) + +(defmacro with-standard-abort-handling (abort-message &body body) + (let ((stream (gensym))) + `(restart-case + (catch :abort + (catch-cancel + ,@body)) + (abort () ,@(when abort-message + `(:report (lambda (,stream) + (write-string ,abort-message ,stream))))) + (abort-break ())))) + + + + +(defmacro %lexpr-count (l) + `(%lisp-word-ref ,l 0)) + +(defmacro %lexpr-ref (lexpr count i) + `(%lisp-word-ref ,lexpr (%i- ,count ,i))) + +;;; args will be list if old style clos +(defmacro apply-with-method-context (magic function args) + (let ((m (gensym)) + (f (gensym)) + (as (gensym))) + `((lambda (,m ,f ,as) + (if (listp ,as) + (%apply-with-method-context ,m ,f ,as) + (%apply-lexpr-with-method-context ,m ,f ,as))) ,magic ,function ,args))) + +(defmacro defcallback (name arglist &body body &environment env) + "Proclaim name to be a special variable; sets its value to a MACPTR which, +when called by foreign code, calls a lisp function which expects foreign +arguments of the specified types and which returns a foreign value of the +specified result type. Any argument variables which correspond to foreign +arguments of type :ADDRESS are bound to stack-allocated MACPTRs. + +If name is already a callback function pointer, its value is not changed; +instead, it's arranged that an updated version of the lisp callback function +will be called. This feature allows for callback functions to be redefined +incrementally, just like Lisp functions are. + +defcallback returns the callback pointer, e.g., the value of name." + (define-callback name arglist body env)) + +(declare-arch-specific-macro %get-single-float-from-double-ptr) + +(declare-arch-specific-macro lfun-vector) +(declare-arch-specific-macro lfun-vector-lfun) + +(declare-arch-specific-macro symptr->symvector) +(declare-arch-specific-macro symvector->symptr) + +(declare-arch-specific-macro function-to-function-vector) +(declare-arch-specific-macro function-vector-to-function) + +(declare-arch-specific-macro with-ffcall-results) + +(defvar *trace-print-functions* nil) +(defun %trace-print-arg (stream arg val type) + (format stream " ") + (let ((fn (assoc type *trace-print-functions*))) + (if fn + (funcall (cdr fn) stream arg val) + (progn + (when arg + (format stream "~A = " arg)) + (if (and type (not (eq type :void))) + (format stream "[:~A] ~A~%" type val) + (format stream ":VOID~%")))))) + +(defun def-trace-print-function (type fn) + (push (cons type fn) *trace-print-functions*)) + +(defun define-callback (name args body env) + (let* ((stack-word (gensym)) + (stack-ptr (gensym)) + (fp-args-ptr (gensym)) + (result-type-spec :void) + (args args) + (discard-stack-args nil) ;only meaningful on win32 + (discard-hidden-arg nil) ;only meaningful on x8632 + (info nil) + (woi nil) + (need-struct-arg) + (struct-return-arg-name) + (error-return nil)) + (collect ((arg-names) + (arg-specs)) + (let* ((spec (car (last args))) + (rtype (ignore-errors (parse-foreign-type spec)))) + (setq need-struct-arg (typep rtype 'foreign-record-type)) + (when need-struct-arg + (setq discard-hidden-arg + (funcall (ftd-ff-call-struct-return-by-implicit-arg-function + *target-ftd*) rtype))) + (if rtype + (setq result-type-spec spec args (butlast args)))) + (loop + (when (null args) (return)) + (if (eq (car args) :without-interrupts) + (setq woi (cadr args) args (cddr args)) + (if (eq (car args) :discard-stack-args) + (setq discard-stack-args (eq (backend-target-os *target-backend*) :win32) args (cdr args)) + (if (eq (car args) :error-return) + (setq error-return + (cadr args) + args (cddr args)) + (if need-struct-arg + (setq struct-return-arg-name (pop args) need-struct-arg nil) + (progn + (arg-specs (pop args)) + (arg-names (pop args)))))))) + (multiple-value-bind (rlets lets dynamic-extent-names inits foreign-return-type fp-args-form error-return-offset num-arg-bytes) + (funcall (ftd-callback-bindings-function *target-ftd*) + stack-ptr fp-args-ptr (arg-names) (arg-specs) result-type-spec struct-return-arg-name) + ;; x8632 hair + (when discard-hidden-arg + (if discard-stack-args + ;; We already have to discard some number of args, so just + ;; discard the extra hidden arg while we're at it. + (incf num-arg-bytes 4) + ;; Otherwise, indicate that we'll need to discard the + ;; hidden arg. + (setq info (ash 1 23)))) + (when discard-stack-args + (setq info 0) + ;; put number of words to discard in high-order byte + (setf (ldb (byte 8 24) info) + (ash num-arg-bytes (- target::word-shift)))) + (multiple-value-bind (body decls doc) (parse-body body env t) + `(progn + (declaim (special ,name)) + (define-callback-function + (nfunction ,name + (lambda (,stack-word) + (declare (ignorable ,stack-word)) + (block ,name + (with-macptrs ((,stack-ptr)) + (%setf-macptr-to-object ,stack-ptr ,stack-word) + (with-macptrs (,@(when fp-args-form + `((,fp-args-ptr ,fp-args-form)))) + ,(defcallback-body stack-ptr + fp-args-ptr + lets + rlets + inits + `(declare (dynamic-extent ,@dynamic-extent-names)) + decls + body + foreign-return-type + struct-return-arg-name + error-return + error-return-offset + )))))) + ,doc + ,woi + ,info))))))) + + +(defun defcallback-body (&rest args) + (declare (dynamic-extent args)) + (destructuring-bind (stack-ptr fp-args-ptr lets rlets inits dynamic-extent-decls other-decls body return-type struct-return-arg error-return error-delta) args + (declare (ignorable dynamic-extent-decls)) + (let* ((condition-name (if (atom error-return) 'error (car error-return))) + (error-return-function (if (atom error-return) error-return (cadr error-return))) + (result (if struct-return-arg (gensym))) + (body + `(rlet ,rlets + (let ,lets + ,dynamic-extent-decls + ,@other-decls + ,@inits + ,(if result + `(let* ((,result ,@body)) + (declare (dynamic-extent ,result) + (ignorable ,result)) + ,(funcall (ftd-callback-return-value-function *target-ftd*) + stack-ptr + fp-args-ptr + result + return-type + struct-return-arg)) + (if (eq return-type *void-foreign-type*) + `(progn ,@body) + (funcall (ftd-callback-return-value-function *target-ftd*) + stack-ptr + fp-args-ptr + `(progn ,@body) + return-type + struct-return-arg))) + nil)))) + (if error-return + (let* ((cond (gensym)) + (block (gensym)) + (handler (gensym))) + `(block ,block + (let* ((,handler (lambda (,cond) + (,error-return-function ,cond ,stack-ptr (%inc-ptr ,stack-ptr ,error-delta)) + (return-from ,block + nil)))) + (declare (dynamic-extent ,handler)) + (handler-bind ((,condition-name ,handler)) + (values ,body))))) + body)))) + + +(defmacro define-toplevel-command (group-name name arglist &body body &environment env) + (let* ((key (make-keyword name))) + (multiple-value-bind (body decls doc) (parse-body body env) + `(%define-toplevel-command ',group-name ,key ',name + (nfunction ,name (lambda ,arglist + ,@decls + (block ,name + ,@body))) + ,doc + ',(mapcar #'symbol-name arglist))))) + +(defmacro with-toplevel-commands (group-name &body body) + `(let* ((*active-toplevel-commands* *active-toplevel-commands*)) + (progn + (%use-toplevel-commands ',group-name) + ,@body))) + +(defmacro assert (test-form &optional (places ()) string &rest args) + "ASSERT Test-Form [(Place*) [String Arg*]] + If the Test-Form is not true, then signal a correctable error. If Places + are specified, then new values are prompted for when the error is proceeded. + String and Args are the format string and args to the error call." + (let* ((TOP (gensym)) + (setf-places-p (not (null places)))) + `(without-compiling-code-coverage + (tagbody + ,TOP + (unless ,test-form + (%assertion-failure ,setf-places-p ',test-form ,string ,@args) + ,@(if places + `((write-line "Type expressions to set places to, or nothing to leave them alone." + *query-io*) + ,@(mapcar #'(lambda (place &aux (new-val (gensym)) + (set-p (gensym))) + `(multiple-value-bind + (,new-val ,set-p) + (assertion-value-prompt ',place) + (when ,set-p (setf ,place (values-list ,new-val))))) + places))) + (go ,TOP)))))) + + +(defmacro check-type (place typespec &optional string) + "CHECK-TYPE Place Typespec [String] + Signal a restartable error of type TYPE-ERROR if the value of PLACE is + not of the specified type. If an error is signalled and the restart is + used to return, this can only return if the STORE-VALUE restart is + invoked. In that case it will store into PLACE and start over." + (let* ((val (gensym))) + `(without-compiling-code-coverage + (do* ((,val ,place ,place)) + ((typep ,val ',typespec)) + (setf ,place (%check-type ,val ',typespec ',place ,string)))))) + + + + +(defmacro with-hash-table-iterator ((mname hash-table) &body body) + "WITH-HASH-TABLE-ITERATOR ((function hash-table) &body body) + provides a method of manually looping over the elements of a hash-table. + FUNCTION is bound to a generator-macro that, within the scope of the + invocation, returns one or three values. The first value tells whether + any objects remain in the hash table. When the first value is non-NIL, + the second and third values are the key and the value of the next object." + (let* ((hash (gensym)) + (keys (gensym)) + (values (gensym)) + (count (gensym)) + (state (gensym))) + `(let* ((,hash ,hash-table) + (,count (hash-table-count ,hash)) + (,keys (make-array ,count)) + (,values (make-array ,count)) + (,state (vector ,hash 0 ,keys ,values (enumerate-hash-keys-and-values ,hash ,keys ,values)))) + (declare (dynamic-extent ,keys ,state) + (fixnum ,count)) + (macrolet ((,mname () `(next-hash-table-iteration-1 ,',state))) + ,@body)))) + + +(eval-when (compile load eval) +(defmacro pprint-logical-block ((stream-symbol list + &key (prefix "" prefixp) + (per-line-prefix "" per-line-prefix-p) + (suffix "" suffixp)) + &body body) + (cond ((eq stream-symbol nil) (setq stream-symbol '*standard-output*)) + ((eq stream-symbol T) (setq stream-symbol '*terminal-io*))) + (when (not (symbolp stream-symbol)) + (warn "STREAM-SYMBOL arg ~S to PPRINT-LOGICAL-BLOCK is not a bindable symbol" + stream-symbol) + (setq stream-symbol '*standard-output*)) + (when (and prefixp per-line-prefix-p) + (warn "prefix ~S and per-line-prefix ~S cannot both be specified ~ + in PPRINT-LOGICAL-BLOCK" prefix per-line-prefix) + (setq per-line-prefix nil)) + `(let ((*logical-block-p* t)) + (maybe-initiate-xp-printing + #'(lambda (,stream-symbol) + (let ((+l ,list) + (+p (or (and ,prefixp + (require-type ,prefix 'string)) + (and ,per-line-prefix-p + (require-type ,per-line-prefix 'string)))) + (+s (require-type ,suffix 'string))) + (pprint-logical-block+ + (,stream-symbol +l +p +s ,per-line-prefix-p T nil) + ,@ body nil))) + (decode-stream-arg ,stream-symbol)))) + + +;Assumes var and args must be variables. Other arguments must be literals or variables. + +(defmacro pprint-logical-block+ ((var args prefix suffix per-line? circle-check? atsign?) + &body body) + "Group some output into a logical block. STREAM-SYMBOL should be either a + stream, T (for *TERMINAL-IO*), or NIL (for *STANDARD-OUTPUT*). The printer + control variable *PRINT-LEVEL* is automatically handled." + (when (and circle-check? atsign?) + (setq circle-check? 'not-first-p)) + `(let ((*current-level* (1+ *current-level*)) + (*current-length* -1) + ;(*parents* *parents*) + ,@(if (and circle-check? atsign?) `((not-first-p (plusp *current-length*))))) + (unless (check-block-abbreviation ,var ,args ,circle-check?) + (start-block ,var ,prefix ,per-line? ,suffix) + (when + (catch 'line-limit-abbreviation-exit + (block logical-block + (macrolet ((pprint-pop () `(pprint-pop+ ,',args ,',var)) + (pprint-exit-if-list-exhausted () + `(if (null ,',args) (return-from logical-block nil)))) + ,@ body)) + (end-block ,var ,suffix) + nil) + (end-block ,var ,suffix) + (throw 'line-limit-abbreviation-exit T))))) +) ; eval-when + +(defmacro %old-class-local-shared-slotds (class &optional default) + (if default ; so setf works + `(%class-get ,class '%old-class-local-shared-slotds ,default) + `(%class-get ,class '%old-class-local-shared-slotds))) + +(defmacro with-slot-values (slot-entries instance-form &body body) +; Simplified form of with-slots. Expands into a let instead of a symbol-macrolet +; Thus, you can access the slot values, but you can't setq them. + (let ((instance (gensym)) var slot-name bindings) + (dolist (slot-entry slot-entries) + (cond ((symbolp slot-entry) + (setq var slot-entry slot-name slot-entry)) + ((and (listp slot-entry) (cdr slot-entry) (null (cddr slot-entry)) + (symbolp (car slot-entry)) (symbolp (cadr slot-entry))) + (setq var (car slot-entry) slot-name (cadr slot-entry))) + (t (signal-program-error "Malformed slot-entry: ~a to with-slot-values.~@ + Should be a symbol or a list of two symbols." + slot-entry))) + (push `(,var (slot-value ,instance ',slot-name)) bindings)) + `(let ((,instance ,instance-form)) + (let ,(nreverse bindings) + ,@body)))) + +(defmacro with-slots (slot-entries instance-form &body body) + "Establish a lexical environment for referring to the slots in the +instance named by the given slot-names as though they were variables. +Within such a context the value of the slot can be specified by using +its slot name, as if it were a lexically bound variable. Both setf and +setq can be used to set the value of the slot." + (let ((instance (gensym)) var slot-name bindings) + (dolist (slot-entry slot-entries) + (cond ((symbolp slot-entry) + (setq var slot-entry slot-name slot-entry)) + ((and (listp slot-entry) (cdr slot-entry) (null (cddr slot-entry)) + (symbolp (car slot-entry)) (symbolp (cadr slot-entry))) + (setq var (car slot-entry) slot-name (cadr slot-entry))) + (t (signal-program-error "Malformed slot-entry: ~a to with-slots.~@ + Should be a symbol or a list of two symbols." + slot-entry))) + (push `(,var (slot-value ,instance ',slot-name)) bindings)) + `(let ((,instance ,instance-form)) + ,@(if bindings + (list `(declare (ignorable ,instance))) + (list `(declare (ignore ,instance)))) + (symbol-macrolet ,(nreverse bindings) + ,@body)))) + +(defmacro with-accessors (slot-entries instance-form &body body) + "Create a lexical environment in which the slots specified by slot-entry +are lexically available through their accessors as if they were variables. +The appropriate accessors are invoked to access the slots specified by +slot-entry. Both setf and setq can be used to set the value of the slot." + (let ((instance (gensym)) var reader bindings) + (dolist (slot-entry slot-entries) + (cond ((and (listp slot-entry) (cdr slot-entry) (null (cddr slot-entry)) + (symbolp (car slot-entry)) (symbolp (cadr slot-entry))) + (setq var (car slot-entry) reader (cadr slot-entry))) + (t (signal-program-error "Malformed slot-entry: ~a to with-accessors.~@ + Should be a list of two symbols." + slot-entry))) + (push `(,var (,reader ,instance)) bindings)) + `(let ((,instance ,instance-form)) + ,@(if bindings + (list `(declare (ignorable ,instance))) + (list `(declare (ignore ,instance)))) + (symbol-macrolet ,(nreverse bindings) + ,@body)))) + +; I wanted to call this ":method" +(defmacro reference-method (gf &rest qualifiers-and-specializers) + (let ((qualifiers (butlast qualifiers-and-specializers)) + (specializers (car (last qualifiers-and-specializers)))) + (if (null specializers) (report-bad-arg qualifiers-and-specializers '(not null))) + `(find-method #',gf ',qualifiers (mapcar #'find-specializer ',specializers)))) + +(defmacro time (form) + "Execute FORM and print timing information on *TRACE-OUTPUT*." + `(report-time ',form #'(lambda () (progn ,form)))) + +(defmacro with-error-reentry-detection (&body body) + (let ((thunk (gensym))) + `(let ((,thunk #'(lambda () ,@body))) + (declare (dynamic-extent ,thunk)) + (funcall-with-error-reentry-detection ,thunk)))) + +(defmacro without-duplicate-definition-warnings (&body body) + `(compiler-let ((*compiler-warn-on-duplicate-definitions* nil)) + ,@body)) + + +#+ppc-target +(defmacro scan-for-instr (mask opcode fn pc-index &optional (tries *trap-lookup-tries*)) + `(%scan-for-instr ,mask ,opcode ,fn ,pc-index ,tries)) + + +(declare-arch-specific-macro codevec-header-p) + +#+ppc-target +(defmacro match-instr (instr mask bits-to-match) + `(eql (logand ,instr ,mask) ,bits-to-match)) + +(defmacro with-xp-stack-frames ((xp trap-function &optional stack-frame) &body body) + (let ((thunk (gensym)) + (sf (or stack-frame (gensym)))) + `(let ((,thunk #'(lambda (&optional ,sf) + ,@(unless stack-frame `((declare (ignore ,sf)))) + ,@body))) + (declare (dynamic-extent ,thunk)) + (funcall-with-xp-stack-frames ,xp ,trap-function ,thunk)))) + +(defmacro signal-eof-error (stream) + `(error 'end-of-file :stream ,stream)) + +(defmacro check-eof (valform stream eof-error-p eof-value) + (let* ((val (gensym))) + `(let ((,val ,valform)) + (if (eq ,val :eof) + (if ,eof-error-p + (signal-eof-error ,stream) + ,eof-value) + ,val)))) + +(defmacro designated-input-stream (input-stream) + `(if ,input-stream + (if (eq t ,input-stream) + *terminal-io* + ,input-stream) + *standard-input*)) + +(defmacro pref (pointer accessor) + "Reference an instance of a foreign type (or a component of a foreign +type) accessible via ptr. + +Expand into code which references the indicated scalar type or component, +or returns a pointer to a composite type." + (let* ((*target-ftd* (backend-target-foreign-type-data *target-backend*))) + (destructuring-bind (type-name &rest accessors) (decompose-record-accessor accessor) + (%foreign-access-form pointer (%foreign-type-or-record type-name) 0 accessors)))) + +(defmacro paref (pointer type-name index) + (let* ((*target-ftd* (backend-target-foreign-type-data *target-backend*))) + (%foreign-array-access-form pointer (%foreign-type-or-record type-name) index))) + +(defmacro rref (pointer accessor &key (storage :pointer storage-p)) + (when storage-p + (warn "Use of :storage option ignored: ~a" storage)) + `(pref ,pointer ,accessor)) + +(defmacro rlet (spec &body body) + "Execute body in an environment in which each var is bound to a MACPTR +encapsulating the address of a stack-allocated foreign memory block, +allocated and initialized from typespec and initforms as per make-record. +Return whatever value(s) body returns." + (let* ((*target-ftd* (backend-target-foreign-type-data *target-backend*))) + `(%stack-block ,(rlet-sizes spec) + ,@(rlet-inits spec) + ,@body))) + +(defmacro rletz (spec &body body) + "Execute body in an environment in which each var is bound to a MACPTR +encapuslating the address of a stack-allocated foreign memory block, +allocated and initialized from typespec and initforms as per make-record. +Return whatever value(s) body returns. + +Unlike rlet, record fields that aren't explicitly initialized are set +to binary 0." + (let* ((*target-ftd* (backend-target-foreign-type-data *target-backend*))) + `(%stack-block ,(rlet-sizes spec t) + ,@(rlet-inits spec) + ,@body))) + +(defun rlet-sizes (inits &optional clear-p &aux result) + (dolist (item inits (nreverse result)) + (push `(,(car item) + ,(%foreign-type-or-record-size (cadr item) :bytes) + ,@(if clear-p '(:clear t))) + result))) + +(defun rlet-inits (inits &aux result) + (dolist (item inits result) + (let* ((name (car item)) + (record-name (cadr item)) + (inits (cddr item)) + (ftype (%foreign-type-or-record record-name)) + (ordinal (foreign-type-ordinal ftype)) + (ordinal-form (if (< ordinal max-canonical-foreign-type-ordinal) + ordinal + `(foreign-type-ordinal (load-time-value (%foreign-type-or-record ',record-name)))))) + (when (eq *host-backend* *target-backend*) + (setq result (nconc result `((%set-macptr-type ,name ,ordinal-form))))) + (if (typep ftype 'foreign-record-type) + (setq result + (nconc result (%foreign-record-field-forms name ftype record-name inits))) + (progn + (when inits + (if (and ftype (null (cdr inits))) + (setq result + (nconc result + `((setf ,(%foreign-access-form name ftype 0 nil) + ,(car inits))))) + (signal-program-error "Unexpected or malformed initialization forms: ~s in field type: ~s" + inits record-name)))))))) + +(defun %foreign-record-field-forms (ptr record-type record-name inits) + (unless (evenp (length inits)) + (signal-program-error "Unexpected or malformed initialization forms: ~s in field type: ~s" + inits record-name)) + (let* ((result ())) + (do* () + ((null inits) + `((progn + ;(%assert-macptr-ftype ,ptr ,record-type) + ,@(nreverse result)))) + (let* ((accessor (decompose-record-accessor (pop inits))) + (valform (pop inits))) + (push `(setf ,(%foreign-access-form ptr record-type 0 accessor) ,valform) + result))))) + +(defmacro get-field-offset (accessor) + (destructuring-bind (type-name field-name) (decompose-record-accessor accessor) + (let* ((record-type (require-type (%foreign-type-or-record type-name) 'foreign-record-type)) + (field (%find-foreign-record-type-field record-type field-name)) + (bit-offset (foreign-record-field-offset field))) + `(values ,(floor bit-offset 8) ,(foreign-record-field-type field) ,bit-offset)))) + +(defmacro record-length (recname) + (%foreign-type-or-record-size recname :bytes)) + +(defun make-record-form (record-name allocator &rest initforms) + (let* ((ftype (%foreign-type-or-record record-name)) + (ordinal (foreign-type-ordinal ftype)) + (ordinal-form (if (< ordinal max-canonical-foreign-type-ordinal) + ordinal + `(foreign-type-ordinal (load-time-value (%foreign-type-or-record ',record-name))))) + (bits (ensure-foreign-type-bits ftype)) + (bytes (if bits + (ceiling bits 8) + (signal-program-error "Unknown size for foreign type ~S." + (unparse-foreign-type ftype)))) + (p (gensym)) + (memset (read-from-string "#_memset"))) + `(let* ((,p (,allocator ,bytes))) + ,@(when (eq *host-backend* *target-backend*) + `((%set-macptr-type ,p ,ordinal-form))) + (,memset ,p 0 ,bytes) + ,@(%foreign-record-field-forms p ftype record-name initforms) + ,p))) + +(defmacro make-record (record-name &rest initforms) + "Expand into code which allocates and initalizes an instance of the type +denoted by typespec, on the foreign heap. The record is allocated using the +C function malloc, and the user of make-record must explicitly call the C +function free to deallocate the record, when it is no longer needed." + (apply 'make-record-form record-name 'malloc initforms)) + +(defmacro make-gcable-record (record-name &rest initforms) + "Like MAKE-RECORD, only advises the GC that the foreign memory can + be deallocated if the returned pointer becomes garbage." + (apply 'make-record-form record-name '%new-gcable-ptr initforms)) + +(defmacro copy-record (type source dest) + (let* ((size (* (%foreign-type-or-record-size type :words) #+64-bit-target 1 #+32-bit-target 2)) + (src (gensym "SRC")) + (dst (gensym "DST")) + (accessor #+64-bit-target '%get-unsigned-long #+32-bit-target '%get-unsigned-word) + (i (gensym "I")) + (j (gensym "J"))) + `(with-macptrs ((,src ,source) + (,dst ,dest)) + (do* ((,i 0 (+ ,i #+64-bit-target 4 #+32-bit-target 2)) + (,j 0 (+ ,j 1))) + ((= ,j ,size)) + (declare (fixnum ,i)) + (setf (,accessor ,dst ,i) (,accessor ,src ,i)))))) + +(defmacro assert-pointer-type (pointer type) + "Assert that the pointer points to an instance of the specified foreign type. +Return the pointer." + (let* ((ptr (gensym))) + `(let* ((,ptr ,pointer)) + (%set-macptr-type ,ptr (foreign-type-ordinal (load-time-value (parse-foreign-type ',type)))) + ,ptr))) + + + +(defmacro with-terminal-input (&body body) + "Execute body in an environment with exclusive read access to the terminal." + (let* ((got-it (gensym))) + `(let* ((,got-it (%request-terminal-input))) + (unwind-protect + (progn ,@body) + (%restore-terminal-input ,got-it))))) + + +(defmacro with-process-whostate ((whostate) &body body) + `(let* ((*whostate* ,whostate)) + ,@body)) + + + + + +(defmacro with-read-lock ((lock) &body body) + "Wait until a given lock is available for read-only access, then evaluate +its body with the lock held." + (let* ((p (gensym))) + `(with-lock-context + (let* ((,p ,lock)) + (unwind-protect + (progn + (read-lock-rwlock ,p) + ,@body) + (unlock-rwlock ,p)))))) + + +(defmacro with-write-lock ((lock) &body body) + "Wait until the given lock is available for write access, then execute +its body with the lock held." + (let* ((p (gensym))) + `(with-lock-context + (let* ((,p ,lock)) + (unwind-protect + (progn + (write-lock-rwlock ,p) + ,@body) + (unlock-rwlock ,p)))))) + + + +(defmacro without-gcing (&body body) + `(unwind-protect + (progn + (%lock-gc-lock) + ,@body) + (%unlock-gc-lock))) + +(defmacro with-deferred-gc (&body body) + "Execute BODY without responding to the signal used to suspend +threads for GC. BODY must be very careful not to do anything which +could cause an exception (note that attempting to allocate lisp memory +may cause an exception.)" + `(let* ((*interrupt-level* -2)) + ,@body)) + +(defmacro allowing-deferred-gc (&body body) + "Within the extent of a surrounding WITH-DEFERRED-GC, allow GC." + `(let* ((*interrupt-level* -1)) + (%check-deferred-gc) + ,@body)) + +(defmacro defer-gc () + `(setq *interrupt-level* -2)) + + +(defmacro with-pointer-to-ivector ((ptr ivector) &body body) + "Executes BODY with PTR bound to a pointer to the first byte of data +in IVECTOR. The GC is disabled during execution of BODY; PTR has +has dynamic-extent (and the address it references may become invalid +after the BODY exits.) IVECTOR should be a (SIMPLE-ARRAY (*)) whose +element-type is numeric." + (let* ((v (gensym))) + `(let* ((,v ,ivector)) + (unless (typep ,v 'ivector) (report-bad-arg ,v 'ivector)) + (without-gcing + (with-macptrs ((,ptr)) + (%vect-data-to-macptr ,v ,ptr) + ,@body))))) + + + +(defmacro with-other-threads-suspended (&body body) + `(unwind-protect + (progn + (%suspend-other-threads) + ,@body) + (%resume-other-threads))) + +(defmacro with-package-read-lock ((p) &body body) + `(with-read-lock ((pkg.lock ,p)) ,@body)) + +(defmacro with-package-write-lock ((p) &body body) + `(with-write-lock ((pkg.lock ,p)) ,@body)) + +(defmacro with-package-lock ((p) &body body) + `(with-package-write-lock (,p) ,@body)) + +;;; Lock %all-packages-lock%, for shared read access to %all-packages% + +(defmacro with-package-list-read-lock (&body body) + `(with-read-lock (%all-packages-lock%) ,@body)) + +;;; Lock %all-packages-lock%, to allow modification to %all-packages% +(defmacro with-package-list-write-lock (&body body) + `(with-write-lock (%all-packages-lock%) ,@body)) + +(defmacro atomic-incf-decf (place delta &environment env) + (setq place (macroexpand place env)) + (if (consp place) + (let* ((sym (car place)) + (struct-transform (or (environment-structref-info sym env) + (gethash sym %structure-refs%)))) + (if struct-transform + (setq place (defstruct-ref-transform struct-transform (cdr place) env) + sym (car place))) + (ecase sym + (the `(the ,(cadr place) (atomic-incf-decf ,(caddr place) ,delta))) + ;; Needed so can handle %svref (which macroexpands into a LET*) + ((let let*) (multiple-value-bind (body decls) (parse-body (cddr place) env t) + (unless (eql (length body) 1) + (error "~S is not a valid atomic-incf/decf place" place)) + `(,sym ,(cadr place) ,@decls (atomic-incf-decf ,@body ,delta)))) + ;; Ditto + (locally (multiple-value-bind (body decls) (parse-body (cdr place) env t) + (unless (eql (length body) 1) + (error "~S is not a valid atomic-incf/decf place" place)) + `(,sym ,@decls (atomic-incf-decf ,@body ,delta)))) + (car `(%atomic-incf-car ,(cadr place) ,delta)) + (cdr `(%atomic-incf-cdr ,(cadr place) ,delta)) + (svref `(%atomic-incf-gvector ,@(cdr place) ,delta)))) + (if (and (symbolp place) (eq :special (variable-information place env))) + (let* ((base (gensym)) + (offset (gensym))) + `(multiple-value-bind (,base ,offset) + (%symbol-binding-address ',place) + (%atomic-incf-node ,delta ,base ,offset))) + (signal-program-error "~S is not a special variable" place)))) + +(defmacro atomic-incf (place) + `(atomic-incf-decf ,place 1)) + +(defmacro atomic-decf (place) + `(atomic-incf-decf ,place -1)) + +; Some of these macros were stolen from CMUCL. Sort of ... + +(defmacro iterate (name binds &body body) + "Iterate Name ({(Var Initial-Value)}*) Declaration* Form* + This is syntactic sugar for Labels. It creates a local function Name with + the specified Vars as its arguments and the Declarations and Forms as its + body. This function is then called with the Initial-Values, and the result + of the call is return from the macro." + (dolist (x binds) + (unless (and (listp x) + (= (length x) 2)) + (signal-program-error "Malformed iterate variable spec: ~S." x))) + + `(labels ((,name ,(mapcar #'first binds) ,@body)) + (,name ,@(mapcar #'second binds)))) + +;;;; The Collect macro: + +;;; Collect-Normal-Expander -- Internal +;;; +;;; This function does the real work of macroexpansion for normal collection +;;; macros. N-Value is the name of the variable which holds the current +;;; value. Fun is the function which does collection. Forms is the list of +;;; forms whose values we are supposed to collect. +;;; +(eval-when (:compile-toplevel :load-toplevel :execute) + + +(defun collect-normal-expander (n-value fun forms) + `(progn + ,@(mapcar #'(lambda (form) `(setq ,n-value (,fun ,form ,n-value))) forms) + ,n-value)) + + +) + +(defmacro once-only (specs &body body) + "Once-Only ({(Var Value-Expression)}*) Form* + Create a Let* which evaluates each Value-Expression, binding a temporary + variable to the result, and wrapping the Let* around the result of the + evaluation of Body. Within the body, each Var is bound to the corresponding + temporary variable." + (iterate frob + ((specs specs) + (body body)) + (if (null specs) + `(progn ,@body) + (let ((spec (first specs))) + (when (/= (length spec) 2) + (signal-program-error "Malformed ~s binding spec: ~S." 'once-only spec)) + (let ((name (first spec)) + (exp-temp (gensym))) + `(let ((,exp-temp ,(second spec)) + (,name (gensym))) + `(let ((,,name ,,exp-temp)) + ,,(frob (rest specs) body)))))))) + +(eval-when (:compile-toplevel :load-toplevel :execute) +(defun form-symbol (first &rest others) + (intern (apply #'concatenate 'simple-base-string (string first) (mapcar #'string others)))) +) + + +;;; Collect-List-Expander -- Internal +;;; +;;; This function deals with the list collection case. N-Tail is the pointer +;;; to the current tail of the list, which is NIL if the list is empty. +;;; +(defun collect-list-expander (n-value n-tail forms) + (let ((n-res (gensym))) + `(progn + ,@(mapcar #'(lambda (form) + `(let ((,n-res (cons ,form nil))) + (cond (,n-tail + (setf (cdr ,n-tail) ,n-res) + (setq ,n-tail ,n-res)) + (t + (setq ,n-tail ,n-res ,n-value ,n-res))))) + forms) + ,n-value))) + +;;; +;;; The ultimate collection macro... +;;; + +(defmacro collect (collections &body body) + "Collect ({(Name [Initial-Value] [Function])}*) {Form}* + Collect some values somehow. Each of the collections specifies a bunch of + things which collected during the evaluation of the body of the form. The + name of the collection is used to define a local macro, a la MACROLET. + Within the body, this macro will evaluate each of its arguments and collect + the result, returning the current value after the collection is done. The + body is evaluated as a PROGN; to get the final values when you are done, just + call the collection macro with no arguments. + + Initial-Value is the value that the collection starts out with, which + defaults to NIL. Function is the function which does the collection. It is + a function which will accept two arguments: the value to be collected and the + current collection. The result of the function is made the new value for the + collection. As a totally magical special-case, the Function may be Collect, + which tells us to build a list in forward order; this is the default. If an + Initial-Value is supplied for Collect, the stuff will be rplacd'd onto the + end. Note that Function may be anything that can appear in the functional + position, including macros and lambdas." + + + (let ((macros ()) + (binds ())) + (dolist (spec collections) + (unless (<= 1 (length spec) 3) + (signal-program-error "Malformed collection specifier: ~S." spec)) + (let ((n-value (gensym)) + (name (first spec)) + (default (second spec)) + (kind (or (third spec) 'collect))) + + (push `(,n-value ,default) binds) + (if (eq kind 'collect) + (let ((n-tail (gensym))) + (if default + (push `(,n-tail (last ,n-value)) binds) + (push n-tail binds)) + (push `(,name (&rest args) + (collect-list-expander ',n-value ',n-tail args)) + macros)) + (push `(,name (&rest args) + (collect-normal-expander ',n-value ',kind args)) + macros)))) + `(macrolet ,macros (let* ,(nreverse binds) (declare (ignorable ,@binds)) ,@body)))) + + +;;; DEFENUM -- Internal Interface. +;;; +(defmacro defenum ((&key (prefix "") (suffix "") (start 0) (step 1)) + &rest identifiers) + (let ((results nil) + (index 0) + (start (eval start)) + (step (eval step))) + (dolist (id identifiers) + (multiple-value-bind + (root docs) + (if (consp id) + (values (car id) (cdr id)) + (values id nil)) + (push `(defconstant ,(intern (concatenate 'simple-base-string + (string prefix) + (string root) + (string suffix))) + ,(+ start (* step index)) + ,@docs) + results)) + (incf index)) + `(eval-when (:compile-toplevel :load-toplevel :execute) + ,@(nreverse results)))) + + +;;; This does something like special binding, but the "bindings" established +;;; aren't thread-specific. + +(defmacro let-globally ((&rest vars) &body body &environment env) + (multiple-value-bind (body decls) (parse-body body env) + (let* ((initforms nil) + (psetform nil) + (specvars nil) + (restoreform nil)) + (flet ((pair-name-value (p) + (if (atom p) + (values (require-global-symbol p env) nil) + (if (and (consp (%cdr p)) (null (%cddr p))) + (values (require-global-symbol (%car p) env) (%cadr p)) + (signal-program-error "Invalid variable initialization form : ~s"))))) + (declare (inline pair-name-value)) + (dolist (v vars) + (let* ((oldval (gensym)) + (newval (gensym))) + (multiple-value-bind (var valueform) (pair-name-value v) + (push var specvars) + (push var restoreform) + (push oldval restoreform) + (push `(,oldval (uvref (symptr->symvector ',var) #.target::symbol.vcell-cell)) initforms) + (push `(,newval ,valueform) initforms) + (push var psetform) + (push newval psetform)))) + `(let ,(nreverse initforms) + ,@decls + (locally (declare (special ,@(nreverse specvars))) + (unwind-protect + (progn (psetq ,@(nreverse psetform)) ,@body) + (psetq ,@(nreverse restoreform))))))))) +;;; From CLX. + +;;; The good news is that this uses an interlocked load/store sequence +;;; and is fairly efficient. +;;; The bad news is that it only handles a few types of "place" forms. +;;; The good news is that CLX only uses a few types of "place" forms. + +(defmacro conditional-store (place old-value new-value &environment env) + (setq place (macroexpand place env)) + (if (atom place) + ;; CLX uses special variables' value cells as place forms. + (if (and (symbolp place) + (eq :special (ccl::variable-information place env))) + (let* ((base (gensym)) + (offset (gensym))) + `(multiple-value-bind (,base ,offset) + (ccl::%symbol-binding-address ',place) + (ccl::%store-node-conditional ,offset ,base ,old-value ,new-value))) + (signal-program-error "~s is not a special variable ." place)) + (let* ((sym (car place)) + (struct-transform (or (ccl::environment-structref-info sym env) + (gethash sym ccl::%structure-refs%)))) + (if struct-transform + (setq place (defstruct-ref-transform struct-transform (cdr place) env) + sym (car place))) + (if (member sym '(svref ccl::%svref ccl::struct-ref)) + (let* ((v (gensym))) + `(let* ((,v ,(cadr place))) + (ccl::store-gvector-conditional ,(caddr place) + ,v ,old-value ,new-value))) + (signal-program-error "Don't know how to do conditional store to ~s" place))))) + +(defmacro step (form) + "The form is evaluated with single stepping enabled. Function calls +outside the lexical scope of the form can be stepped into only if the +functions in question have been compiled with sufficient DEBUG policy +to be at least partially steppable." + form) + +(defmacro target-arch-case (&rest clauses) + `(case (backend-target-arch-name *target-backend*) + ,@clauses)) + +(defmacro target-os-case (&rest clauses) + `(ecase (backend-target-os *target-backend*) + ,@clauses)) + +(defmacro target-word-size-case (&rest clauses) + `(ecase (arch::target-nbits-in-word (backend-target-arch *target-backend*)) + ,@clauses)) + +(defmacro %get-natural (&body body) + "A free copy of the next OpenMCL release to anyone who remembers Flakey Foont" + (target-word-size-case + (32 `(%get-unsigned-long ,@body)) + (64 `(%%get-unsigned-longlong ,@body)))) + +(defmacro %get-signed-natural (&body body) + "And that's my final offer." + (target-word-size-case + (32 `(%get-signed-long ,@body)) + (64 `(%%get-signed-longlong ,@body)))) + +(declare-arch-specific-macro %target-kernel-global) + +;;; This behaves like a function, but looks up the kernel global +;;; at compile time if possible. Probably should be done as a function +;;; and a compiler macro, but we can't define compiler macros yet, +;;; and I don't want to add it to "ccl:compiler;optimizers.lisp" +(declare-arch-specific-macro %get-kernel-global) + +(declare-arch-specific-macro %get-kernel-global-ptr) + +(declare-arch-specific-macro area-code) + +(declare-arch-specific-macro nth-immediate) + +(declare-arch-specific-macro set-nth-immediate) + +(defsetf nth-immediate set-nth-immediate) + +(defmacro do-consing-areas ((area) &body body) + (let ((code (gensym))) + `(do-gc-areas (,area) + (let ((,code (%fixnum-ref ,area (area-code)))) + (when (or (eql ,code area-readonly) + (eql ,code area-watched) + (eql ,code area-managed-static) + (eql ,code area-static) + (eql ,code area-dynamic)) + ,@body))))) + +(declare-arch-specific-macro area-succ) + + +(defmacro do-gc-areas ((area) &body body) + (let ((initial-area (gensym))) + `(let* ((,initial-area (%get-kernel-global 'all-areas)) + (,area ,initial-area)) + (declare (fixnum ,initial-area ,area)) + (loop + (setq ,area (%fixnum-ref ,area (area-succ))) + (when (eql ,area ,initial-area) + (return)) + ,@body)))) + +(defmacro with-ioblock-input-lock-grabbed ((ioblock) &body body) + (let* ((i (gensym))) + `(let* ((,i ,ioblock)) + (with-lock-grabbed ((ioblock-inbuf-lock ,i)) + (cond ((ioblock-device ,i) + ,@body) + (t (stream-is-closed (ioblock-stream ,i)))))))) + +(defmacro with-ioblock-output-lock-grabbed ((ioblock) &body body) + (let* ((i (gensym))) + `(let* ((,i ,ioblock)) + (with-lock-grabbed ((ioblock-outbuf-lock ,i)) + (cond ((ioblock-device ,i) + ,@body) + (t (stream-is-closed (ioblock-stream ,i)))))))) + + +(defmacro with-stream-ioblock-input ((ioblock stream &key + speedy) + &body body) + `(let ((,ioblock (stream-ioblock ,stream t))) + ,@(when speedy `((declare (optimize (speed 3) (safety 0))))) + (with-ioblock-input-locked (,ioblock) ,@body))) + +(defmacro with-stream-ioblock-output ((ioblock stream &key + speedy) + &body body) + `(let ((,ioblock (stream-ioblock ,stream t))) + ,@(when speedy `((declare (optimize (speed 3) (safety 0))))) + (with-ioblock-output-locked (,ioblock) ,@body))) + +(defmacro with-stream-ioblock-output-maybe ((ioblock stream &key + speedy) + &body body) + `(let ((,ioblock (stream-ioblock ,stream t))) + ,@(when speedy `((declare (optimize (speed 3) (safety 0))))) + (with-ioblock-output-locked-maybe (,ioblock) ,@body))) + +(defmacro with-ioblock-input-locked ((ioblock) &body body) + (let* ((lock (gensym))) + `(let* ((,lock (locally (declare (optimize (speed 3) (safety 0))) + (ioblock-inbuf-lock ,ioblock)))) + (if ,lock + (with-lock-grabbed (,lock) + (cond ((ioblock-device ,ioblock) + ,@body) + (t (stream-is-closed (ioblock-stream ,ioblock))))) + (progn + (check-ioblock-owner ,ioblock) + ,@body))))) + +(defmacro with-ioblock-output-locked ((ioblock) &body body) + (let* ((lock (gensym))) + `(let* ((,lock (locally (declare (optimize (speed 3) (safety 0))) + (ioblock-outbuf-lock ,ioblock)))) + (if ,lock + (with-lock-grabbed (,lock) + (cond ((ioblock-device ,ioblock) + ,@body) + (t (stream-is-closed (ioblock-stream ,ioblock))))) + (progn + (check-ioblock-owner ,ioblock) + ,@body))))) + + + +(defmacro with-ioblock-output-locked-maybe ((ioblock) &body body) + (let* ((lock (gensym))) + `(let* ((,lock (locally (declare (optimize (speed 3) (safety 0))) + (ioblock-outbuf-lock ,ioblock)))) + (if ,lock + (with-lock-grabbed (,lock) + (cond ((ioblock-device ,ioblock) + ,@body) + (t (stream-is-closed (ioblock-stream ,ioblock))))) + (progn + (check-ioblock-owner ,ioblock) + ,@body))))) + +;;; Use this when it's possible that the fd might be in +;;; a non-blocking state. Body must return a negative of +;;; the os error number on failure. +;;; The use of READ-FROM-STRING below is certainly ugly, but macros +;;; that expand into reader-macros don't generally trigger the reader-macro's +;;; side-effects. (Besides, the reader-macro might return a different +;;; value when the macro function is expanded than it did when the macro +;;; function was defined; this can happen during cross-compilation.) +(defmacro with-eagain (fd direction &body body) + (let* ((res (gensym)) + (eagain (symbol-value (read-from-string "#$EAGAIN")))) + `(loop + (let ((,res (progn ,@body))) + (if (eql ,res (- ,eagain)) + (progn + (setq ,res + (,(ecase direction + (:input 'process-input-would-block) + (:output 'process-output-would-block)) + ,fd)) + (unless (eq ,res t) (return ,res))) + (return ,res)))))) + +(defmacro ignoring-eintr (&body body) + (let* ((res (gensym)) + (eintr (symbol-value (read-from-string "#$EINTR")))) + `(loop + (let* ((,res (progn ,@body))) + (unless (eql ,res (- ,eintr)) + (return ,res)))))) + +(defmacro ff-call-ignoring-eintr (&body body) + (let* ((res (gensym)) + (eintr (symbol-value (read-from-string "#$EINTR")))) + `(loop + (let* ((,res (progn ,@body))) + (declare (fixnum ,res)) + (when (< ,res 0) + (setq ,res (%get-errno))) + (unless (eql ,res (- ,eintr)) + (return ,res)))))) + +(defmacro basic-stream-ioblock (s) + `(or (basic-stream.state ,s) + (stream-is-closed ,s))) + +(defsetf interrupt-level set-interrupt-level) + +(defmacro %swap-u16 (val) + (let* ((arg (gensym))) + `(let* ((,arg ,val)) + (declare (type (unsigned-byte 16) ,arg)) + (logand #xffff (the fixnum (logior (the fixnum (ash ,arg -8)) + (the fixnum (ash ,arg 8)))))))) + +(defmacro %swap-u32 (val) + (let* ((arg (gensym))) + `(let ((,arg ,val)) + (declare (type (unsigned-byte 32) ,arg)) + (the (unsigned-byte 32) (logior (the (unsigned-byte 32) + (ash (logand #xff ,arg) 24)) + (the (unsigned-byte 24) + (logior + (the (unsigned-byte 24) (ash (logand #xff00 ,arg) 8)) + (the (unsigned-byte 16) + (logior + (the (unsigned-byte 16) (ash (logand #xff0000 ,arg) -8)) + (the (unsigned-byte 8) (ash ,arg -24))))))))))) + + +(defmacro multiple-value-bind (varlist values-form &body body &environment env) + (multiple-value-bind (body decls) + (parse-body body env) + (let ((ignore (make-symbol "IGNORE"))) + `(multiple-value-call #'(lambda (&optional ,@varlist &rest ,ignore) + (declare (ignore ,ignore)) + ,@decls + ,@body) + ,values-form)))) + +(defmacro multiple-value-setq (vars val) + (if vars + `(values (setf (values ,@(mapcar #'(lambda (s) (require-type s 'symbol)) vars)) ,val)) + `(prog1 ,val))) + +(defmacro nth-value (n form) + "Evaluate FORM and return the Nth value (zero based). This involves no + consing when N is a trivial constant integer." + `(car (nthcdr ,n (multiple-value-list ,form)))) + + + +(defmacro with-input-timeout (((stream-var &optional (stream-form stream-var)) timeout) &body body) + "Execute body with STREAM-VAR bound to STREAM-FORM and with that stream's +stream-input-timeout set to TIMEOUT." + (let* ((old-input-timeout (gensym)) + (stream (gensym))) + `(let* ((,stream ,stream-form) + (,stream-var ,stream) + (,old-input-timeout (stream-input-timeout ,stream))) + (unwind-protect + (progn + (setf (stream-input-timeout ,stream) ,timeout) + ,@body) + (setf (stream-input-timeout ,stream) ,old-input-timeout))))) + +(defmacro with-output-timeout (((stream-var &optional (stream-form stream-var)) timeout) &body body) + "Execute body with STREAM-VAR bound to STREAM-FORM and with that stream's +stream-output-timeout set to TIMEOUT." + (let* ((old-output-timeout (gensym)) + (stream (gensym))) + `(let* ((,stream ,stream-form) + (,stream-var ,stream) + (,old-output-timeout (stream-output-timeout ,stream))) + (unwind-protect + (progn + (setf (stream-output-timeout ,stream) ,timeout) + ,@body) + (setf (stream-output-timeout ,stream) ,old-output-timeout))))) + +;;; FORM returns a signed integer. If it's non-negative, return that +;;; value, otherwise, return the (negative) errnor value returned by +;;; %GET-ERRNO +(defmacro int-errno-call (form) + (let* ((value (gensym))) + `(let* ((,value ,form)) + (if (< ,value 0) + (%get-errno) + ,value)))) + +(defmacro int-errno-ffcall (entry &rest args) + `(int-errno-call (ff-call ,entry ,@args))) Index: /branches/new-random/lib/mcl-compat.lisp =================================================================== --- /branches/new-random/lib/mcl-compat.lisp (revision 13309) +++ /branches/new-random/lib/mcl-compat.lisp (revision 13309) @@ -0,0 +1,48 @@ +;;;-*-Mode: LISP; Package: CCL -*- +;;; +;;; Copyright (C) 2009 Clozure Associates +;;; Copyright (C) 1994-2001 Digitool, Inc +;;; This file is part of Clozure CL. +;;; +;;; Clozure CL is licensed under the terms of the Lisp Lesser GNU Public +;;; License , known as the LLGPL and distributed with Clozure CL as the +;;; file "LICENSE". The LLGPL consists of a preamble and the LGPL, +;;; which is distributed with Clozure CL as the file "LGPL". Where these +;;; conflict, the preamble takes precedence. +;;; +;;; Clozure CL is referenced in the preamble as the "LIBRARY." +;;; +;;; The LLGPL is also available online at +;;; http://opensource.franz.com/preamble.html + +(in-package "CCL") + +;;; mcl-compat.lisp - (some) backwards-compatibility with traditional MCL +;;; (CLtL2/ANSI, etc.) + +;;; Gratuitous name changes, for the most part: + +(deftype base-character () 'base-char) +(deftype extended-character () 'extended-char) + +(defmacro define-setf-method (access-fn lambda-list &body body) + `(define-setf-expander ,access-fn ,lambda-list ,@body)) + +(defun get-setf-method (form &optional environment) + (get-setf-expansion-aux form environment nil)) + +(defun get-setf-method-multiple-value (form &optional environment) + "Like Get-Setf-Method, but may return multiple new-value variables." + (get-setf-expansion-aux form environment t)) + +;;; Traditional MCL I/O primitives: + +(defun tyi (stream) + (let* ((ch (stream-read-char stream))) + (unless (eq ch :eof) ch))) + +(defun untyi (ch &optional stream) + (stream-unread-char (designated-input-stream stream) ch)) + +(defun tyo (ch &optional stream) + (stream-write-char (real-print-stream stream) ch)) Index: /branches/new-random/lib/method-combination.lisp =================================================================== --- /branches/new-random/lib/method-combination.lisp (revision 13309) +++ /branches/new-random/lib/method-combination.lisp (revision 13309) @@ -0,0 +1,784 @@ +; -*- Mode:Lisp; Package:CCL; -*- +;;; +;;; Copyright (C) 2009 Clozure Associates +;;; Copyright (C) 1994-2001 Digitool, Inc +;;; This file is part of Clozure CL. +;;; +;;; Clozure CL is licensed under the terms of the Lisp Lesser GNU Public +;;; License , known as the LLGPL and distributed with Clozure CL as the +;;; file "LICENSE". The LLGPL consists of a preamble and the LGPL, +;;; which is distributed with Clozure CL as the file "LGPL". Where these +;;; conflict, the preamble takes precedence. +;;; +;;; Clozure CL is referenced in the preamble as the "LIBRARY." +;;; +;;; The LLGPL is also available online at +;;; http://opensource.franz.com/preamble.html + + +;;;;;;;;;;;;;;; +;; +;; define-method-combination.lisp +;; Copyright 1990-1994, Apple Computer, Inc. +;; Copyright 1995-1996 Digitool, Inc. + +;; + +;;;;;;;;;;;;;;; +; +; Change History +; +; 05/31/96 bill list method combination is not :identity-with-one-argument +; ------------- MCL-PPC 3.9 +; 12/01/93 bill specifier-match-p uses EQUAL instead of EQ +; ------------- 3.0d13 +; 04/30/93 bill no-applicable-primary-method -> make-no-applicable-method-function +; ------------ 2.0 +; 11/05/91 gb experiment with INLINE. +; 09/26/91 bill %badarg had the wrong number of args in with-call-method-context. +; Mix in Flavors Technology's optimization. +; 07/21/91 gb Use DYNAMIC-EXTENT vice DOWNWARD-FUNCTION. +; 06/26/91 bill method-combination's direct-superclass is metaobject +;-------------- 2.0b2 +; 02/13/91 bill New File. +;------------ 2.0b1 +; + +; MOP functions pertaining to method-combination: +; +; COMPUTE-DISCRIMINATING-FUNCTION generic-function (not implemented) +; COMPUTE-EFFECTIVE-METHOD generic-function method-combination methods +; FIND-METHOD-COMBINATION generic-function method-combination-type method-combination-options +; Readers for method-combination objects +; METHOD-COMBINATION-NAME +; METHOD-COMBINATION-OPTIONS +; METHOD-COMBINATION-ORDER +; METHOD-COMBINATION-OPERATOR +; METHOD-COMBINATION-IDENTITY-WITH-ONE-ARGUMENT + +(in-package "CCL") + +(defclass method-combination (metaobject) + ((name :reader method-combination-name :initarg :name) + (options :reader method-combination-options :initarg :options :initform nil))) + +(defclass short-method-combination (method-combination) + ((operator :reader method-combination-operator :initarg :operator :initform nil) + (identity-with-one-argument :reader method-combination-identity-with-one-argument + :initarg :identity-with-one-argument + :initform nil)) + (:documentation "Generated by the simple form of define-method-combination")) + +(defclass long-method-combination (method-combination) + ((expander :reader method-combination-expander :initarg :expander + :documentation "The expander is called by compute-effective-method with args: gf mc options methods args") + ) + (:documentation "Generated by the long form of define-method-combination")) + +(defmethod print-object ((object method-combination) stream) + (print-unreadable-object (object stream :type t) + (let* ((name (method-combination-name object)) + (options (method-combination-options object))) + (declare (dynamic-extent options)) + (prin1 name stream) + (dolist (option options) + (pp-space stream) + (prin1 option stream))))) + +; Hash a method-combination name to a method-combination-info vector +(defvar *method-combination-info* (make-hash-table :test 'eq)) + +(defmacro method-combination-info (method-combination-type) + `(gethash ,method-combination-type *method-combination-info*)) + +;;; Need to special case (find-method-combination #'find-method-combination ...) +(without-duplicate-definition-warnings ;; override version in l1-clos-boot.lisp + (defmethod find-method-combination ((generic-function standard-generic-function) + method-combination-type + method-combination-options) + (%find-method-combination + generic-function method-combination-type method-combination-options))) + +(defun %find-method-combination (gf type options) + (declare (ignore gf)) + (if (eq type 'standard) + (progn + (unless (null options) + (error "STANDARD method-combination accepts no options.")) + *standard-method-combination*) + (let ((mci (method-combination-info type))) + (unless mci + (error "~s is not a method-combination type" type)) + (labels ((same-options-p (o1 o2) + (cond ((null o1) (null o2)) + ((null o2) nil) + ((or (atom o1) (atom o2)) nil) + ((eq (car o1) (car o2)) + (same-options-p (cdr o1) (cdr o2))) + (t nil)))) + (dolist (mc (population-data (mci.instances mci))) + (when (same-options-p options (method-combination-options mc)) + (return-from %find-method-combination mc)))) + (let ((new-mc + (case (mci.class mci) + (short-method-combination + (unless (or (null options) + (and (listp options) + (null (cdr options)) + (memq (car options) + '(:most-specific-first :most-specific-last)))) + (error "Illegal method-combination options: ~s" options)) + (destructuring-bind (&key identity-with-one-argument + (operator type) + &allow-other-keys) + (mci.options mci) + (make-instance 'short-method-combination + :name type + :identity-with-one-argument identity-with-one-argument + :operator operator + :options options))) + (long-method-combination + (make-instance 'long-method-combination + :name type + :options options + :expander (mci.options mci))) + (t (error "Don't understand ~s method-combination" type))))) + (push new-mc (population-data (mci.instances mci))) + new-mc)))) + +; Push GF on the MCI.GFS population of its method-combination type. +(defun register-gf-method-combination (gf &optional (mc (%gf-method-combination gf))) + (unless (eq mc *standard-method-combination*) + (let* ((name (method-combination-name mc)) + (mci (or (method-combination-info name) + (error "~s not a known method-combination type" name))) + (gfs (mci.gfs mci))) + (pushnew gf (population-data gfs))) + mc)) + +(defun unregister-gf-method-combination (gf &optional (mc (%gf-method-combination gf))) + (unless (eq mc *standard-method-combination*) + (let* ((name (method-combination-name mc)) + (mci (or (method-combination-info name) + (error "~s not a known method-combination type" name))) + (gfs (mci.gfs mci))) + (setf (population-data gfs) (delq gf (population-data gfs)))) + mc)) + + +;;; Need to special case (compute-effective-method #'compute-effective-method ...) +(defmethod compute-effective-method ((generic-function standard-generic-function) + (method-combination standard-method-combination) + methods) + (%compute-standard-effective-method generic-function method-combination methods)) + +(defun %compute-standard-effective-method (generic-function method-combination methods) + (declare (ignore method-combination)) + (make-standard-combined-method methods nil generic-function t)) + +(defvar *method-combination-evaluators* (make-hash-table :test 'eq)) + +(defmacro get-method-combination-evaluator (key) + `(gethash ,key *method-combination-evaluators*)) + +(defmacro define-method-combination-evaluator (name arglist &body body) + (setq name (require-type name 'symbol)) + (unless (and arglist (listp arglist) (eq (length arglist) 2)) + (error "A method-combination-evaluator must take two args.")) + `(%define-method-combination-evaluator ',name #'(lambda ,arglist ,@body))) + +(defun %define-method-combination-evaluator (operator function) + (setq operator (require-type operator 'symbol)) + (setq function (require-type function 'function)) + (record-source-file operator 'method-combination-evaluator) + (setf (get-method-combination-evaluator operator) function) + (maphash #'(lambda (name mci) + (when (eq operator (or (and (eq (mci.class mci) 'short-method-combination) (getf (mci.options mci) :operator)) name))) + (clear-method-combination-caches name mci)) + *method-combination-info*) + function) + +(defmethod compute-effective-method ((generic-function standard-generic-function) + (method-combination short-method-combination) + methods) + (or (get-combined-method methods generic-function) + (put-combined-method + methods + (let* ((arounds nil) + (primaries nil) + (iwoa (method-combination-identity-with-one-argument method-combination)) + (reverse-p (eq (car (method-combination-options method-combination)) + :most-specific-last)) + (operator (method-combination-operator method-combination)) + (name (method-combination-name method-combination)) + qualifiers + q) + (dolist (m methods) + (setq qualifiers (method-qualifiers m)) + (unless (and qualifiers (null (cdr qualifiers)) + (cond ((eq (setq q (car qualifiers)) name) + (push m primaries)) + ((eq q :around) + (push m arounds)) + (t nil))) + (%invalid-method-error m "invalid method qualifiers: ~s" qualifiers))) + (when (null primaries) + (return-from compute-effective-method + (make-no-applicable-method-function generic-function))) + (setq arounds (nreverse arounds)) + (unless reverse-p (setq primaries (nreverse primaries))) + (or (optimized-short-effective-method generic-function operator iwoa arounds primaries) + (let ((code (if (and iwoa (null (cdr primaries))) + `(call-method ,(car primaries) nil) + `(,operator ,@(mapcar #'(lambda (m) `(call-method ,m nil)) primaries))))) + (make-effective-method + generic-function + (if arounds + `(call-method ,(car arounds) + (,@(cdr arounds) (make-method ,code))) + code))))) + generic-function))) + +(defun optimized-short-effective-method (gf operator iwoa arounds primaries) + (let* ((functionp (functionp (fboundp operator))) + (evaluator (unless functionp (get-method-combination-evaluator operator)))) + (when (or functionp evaluator) + (let ((code (if (and iwoa (null (cdr primaries))) + (let ((method (car primaries))) + (if (call-next-method-p method) + #'(lambda (&rest args) + (declare (dynamic-extent args)) + (%%call-method* method nil args)) + (method-function method))) + (if functionp + (let ((length (length primaries)) + (primaries primaries)) + #'(lambda (&rest args) + (declare (dynamic-extent args)) + (let* ((results (make-list length)) + (results-tail results)) + (declare (cons results-tail)) + (declare (dynamic-extent results)) + (dolist (method primaries) + (setf (car results-tail) + (%%call-method* method nil args)) + (pop results-tail)) + (apply operator results)))) + (let ((primaries primaries)) + #'(lambda (&rest args) + (declare (dynamic-extent args)) + (funcall evaluator primaries args))))))) + (if arounds + (let* ((code-method (make-instance 'standard-method + :function code + :generic-function gf + :name (function-name gf))) + (first-around (car arounds)) + (rest-arounds (nconc (cdr arounds) (list code-method)))) + #'(lambda (&rest args) + (declare (dynamic-extent args)) + (%%call-method* first-around rest-arounds args))) + code))))) + +(defmethod compute-effective-method ((generic-function standard-generic-function) + (method-combination long-method-combination) + methods) + (or (get-combined-method methods generic-function) + (destructuring-bind ((args-var . gf-name) . expander) + (method-combination-expander method-combination) + (let* ((user-form (funcall expander + generic-function + methods + (method-combination-options method-combination))) + (effective-method + (if (functionp user-form) + user-form + (make-effective-method generic-function user-form args-var gf-name)))) + (put-combined-method methods effective-method generic-function))))) + +(defmacro with-call-method-context (args-var &body body) + (labels ((bad-call-method-method (method) + (error "~s is neither a method nor a ~s form." method 'make-method)) + (call-method-aux (method next-methods args-var) + (unless (typep method 'standard-method) + (if (and (listp method) (eq (car method) 'make-method)) + (setq method (%make-method method)) + (bad-call-method-method method))) + (let ((real-next-methods nil)) + (dolist (m next-methods) + (cond ((typep m 'standard-method) + (push m real-next-methods)) + ((and (listp m) (eq (car m) 'make-method)) + (push (%make-method m) real-next-methods)) + (t (bad-call-method-method m)))) + `(%%call-method* ,method + ',(nreverse real-next-methods) + ,args-var)))) + `(macrolet ((call-method (method &optional next-methods) + (funcall ',#'call-method-aux method next-methods ',args-var))) + ,@body))) + +(defun %make-method (make-method-form &optional + args-var + generic-function + (method-class 'standard-method)) + (setq args-var (require-type args-var 'symbol)) + (unless (and (cdr make-method-form) (null (cddr make-method-form))) + (%method-combination-error "MAKE-METHOD requires exactly one argument.")) + (let ((form (cadr make-method-form))) + (make-instance + method-class + :generic-function generic-function + :name (and (functionp generic-function) (function-name generic-function)) + :function (%make-function + nil + `(lambda (&rest ,(setq args-var (or args-var (make-symbol "ARGS")))) + (declare (ignore-if-unused ,args-var) + (dynamic-extent ,args-var)) + (with-call-method-context ,args-var + ,form)) + nil)))) + +(defmethod call-next-method-p ((method standard-method)) + (call-next-method-p (%method-function method))) + +(defmethod call-next-method-p ((function function)) + (let (lfbits) + (and (logbitp $lfbits-method-bit + (setq lfbits (lfun-bits function))) + (logbitp $lfbits-nextmeth-bit lfbits)))) + +(defun make-effective-method (gf form &optional (args-sym (make-symbol "ARGS")) (gf-name (make-symbol "GF"))) + (setq args-sym (require-type args-sym 'symbol)) + (let (m mf) + (if (and (listp form) + (eq (car form) 'call-method) + (listp (cdr form)) + (typep (setq m (cadr form)) 'standard-method) + (listp (cddr form)) + (null (cdddr form)) + (not (call-next-method-p (setq mf (%method-function m))))) + mf + (%make-function + nil + `(lambda (&rest ,args-sym) + (declare (dynamic-extent ,args-sym)) + (let* ((,gf-name ,gf)) + (declare (ignorable ,gf-name)) + (with-call-method-context ,args-sym + ,form))) + nil)))) + +;;;;;;; +;; +;; Expansions of the DEFINE-METHOD-COMBINATION macro +;; + +;; +;; Short form +;; +(defun short-form-define-method-combination (name options) + (destructuring-bind (&key documentation identity-with-one-argument + (operator name)) options + (setq name (require-type name 'symbol) + operator (require-type operator 'symbol) + documentation (unless (null documentation) + (require-type documentation 'string))) + (let* ((mci (method-combination-info name)) + (was-short? (and mci (eq (mci.class mci) 'short-method-combination)))) + (when (and mci (not was-short?)) + (check-long-to-short-method-combination name mci)) + (if mci + (let ((old-options (mci.options mci))) + (setf (mci.class mci) 'short-method-combination + (mci.options mci) options) + (unless (and was-short? + (destructuring-bind (&key ((:identity-with-one-argument id)) + ((:operator op) name) + &allow-other-keys) + old-options + (and (eq id identity-with-one-argument) + (eq op operator)))) + (update-redefined-short-method-combinations name mci))) + (setf (method-combination-info name) + (setq mci (%cons-mci 'short-method-combination options))))) + (set-documentation name 'method-combination documentation)) + (record-source-file name 'method-combination) + name) + +(defun check-long-to-short-method-combination (name mci) + (dolist (gf (population-data (mci.gfs mci))) + (let ((options (method-combination-options (%gf-method-combination gf)))) + (unless (or (null options) + (and (listp options) + (null (cdr options)) + (memq (car options) '(:most-specific-first :most-specific-last)))) + (error "Redefining ~s method-combination disagrees with the~ + method-combination arguments to ~s" name gf))))) + +(defun update-redefined-short-method-combinations (name mci) + (destructuring-bind (&key identity-with-one-argument (operator name) documentation) + (mci.options mci) + (declare (ignore documentation)) + (dolist (mc (population-data (mci.instances mci))) + (when (typep mc 'long-method-combination) + (change-class mc 'short-method-combination)) + (if (typep mc 'short-method-combination) + (setf (slot-value mc 'identity-with-one-argument) identity-with-one-argument + (slot-value mc 'operator) operator) + (error "Bad method-combination-type: ~s" mc)))) + (clear-method-combination-caches name mci)) + +(defun clear-method-combination-caches (name mci) + (dolist (gf (population-data (mci.gfs mci))) + (clear-gf-cache gf)) + (when *effective-method-gfs* ; startup glitch + (let ((temp #'(lambda (mc gf) + (when (eq name (method-combination-name (%gf-method-combination gf))) + (remhash mc *effective-method-gfs*) + (remhash mc *combined-methods*))))) + (declare (dynamic-extent temp)) + (maphash temp *effective-method-gfs*)))) + +;;; Support el-bizarro arglist partitioning for the long form of +;;; DEFINE-METHOD-COMBINATION. +(defun nth-required-gf-arg (gf argvals i) + (declare (fixnum i)) + (let* ((bits (lfun-bits gf)) + (numreq (ldb $lfbits-numreq bits))) + (declare (fixnum bits numreq)) + (if (< i numreq) + (nth i argvals)))) + +(defun nth-opt-gf-arg-present-p (gf argvals i) + (declare (fixnum i)) + (let* ((bits (lfun-bits gf)) + (numreq (ldb $lfbits-numreq bits)) + (numopt (ldb $lfbits-numopt bits))) + (declare (fixnum bits numreq numopt)) + (and (< i numopt) + (< (the fixnum (+ i numreq)) (length argvals))))) + +;;; This assumes that we've checked for argument presence. +(defun nth-opt-gf-arg (gf argvals i) + (declare (fixnum i)) + (let* ((bits (lfun-bits gf)) + (numreq (ldb $lfbits-numreq bits))) + (declare (fixnum bits numreq )) + (nth (the fixnum (+ i numreq)) argvals))) + +(defun gf-arguments-tail (gf argvals) + (let* ((bits (lfun-bits gf)) + (numreq (ldb $lfbits-numreq bits)) + (numopt (ldb $lfbits-numopt bits))) + (declare (fixnum bits numreq numopt)) + (nthcdr (the fixnum (+ numreq numopt)) argvals))) + +(defun gf-key-present-p (gf argvals key) + (let* ((tail (gf-arguments-tail gf argvals)) + (missing (cons nil nil))) + (declare (dynamic-extent missing)) + (not (eq missing (getf tail key missing))))) + +;; Again, this should only be called if GF-KEY-PRESENT-P returns true. +(defun gf-key-value (gf argvals key) + (let* ((tail (gf-arguments-tail gf argvals))) + (getf tail key))) + + +(defun lfmc-bindings (gf-form args-form lambda-list) + (let* ((req-idx 0) + (opt-idx 0) + (state :required)) + (collect ((names) + (vals)) + (dolist (arg lambda-list) + (case arg + ((&whole &optional &rest &key &allow-other-keys &aux) + (setq state arg)) + (t + (case state + (:required + (names arg) + (vals (list 'quote `(nth-required-gf-arg ,gf-form ,args-form ,req-idx))) + (incf req-idx)) + (&whole + (names arg) + (vals `,args-form) + (setq state :required)) + (&optional + (let* ((var arg) + (val nil) + (spvar nil)) + (when (listp arg) + (setq var (pop arg) + val (pop arg) + spvar (car arg))) + (names var) + (vals (list 'quote + `(if (nth-opt-gf-arg-present-p ,gf-form ,args-form ,opt-idx) + (nth-opt-gf-arg ,gf-form ,args-form ,opt-idx) + ,val))) + (when spvar + (names spvar) + (vals (list 'quote + `(nth-opt-gf-arg-present-p ,gf-form ,args-form ,opt-idx)))) + (incf opt-idx))) + (&rest + (names arg) + (vals (list 'quote + `(gf-arguments-tail ,gf-form ,args-form)))) + (&key + (let* ((var arg) + (keyword nil) + (val nil) + (spvar nil)) + (if (atom arg) + (setq keyword (make-symbol (symbol-name arg))) + (progn + (setq var (car arg)) + (if (atom var) + (setq keyword (make-symbol (symbol-name var))) + (setq keyword (car var) var (cadr var))) + (setq val (cadr arg) spvar (caddr arg)))) + (names var) + (vals (list 'quote `(if (gf-key-present-p ,gf-form ,args-form ',keyword) + (gf-key-value ,gf-form ,args-form ',keyword) + ,val))) + (when spvar + (names spvar) + (vals (list 'quote `(gf-key-present-p ,gf-form ,args-form ',keyword)))))) + (&allow-other-keys) + (&aux + (cond ((atom arg) + (names arg) + (vals nil)) + (t + (names (car arg)) + (vals (list 'quote (cadr arg)))))))))) + (values (names) (vals))))) +;; +;; Long form +;; +(defun long-form-define-method-combination (name lambda-list method-group-specifiers + forms env) + (let (arguments args-specified? generic-fn-symbol gf-symbol-specified?) + (unless (verify-lambda-list lambda-list) + (error "~s is not a proper lambda-list" lambda-list)) + (loop + (unless (and forms (consp (car forms))) (return)) + (case (caar forms) + (:arguments + (when args-specified? (error ":ARGUMENTS specified twice")) + (setq arguments (cdr (pop forms)) + args-specified? t) + (do ((args arguments (cdr args))) + ((null args)) + (setf (car args) (require-type (car args) 'symbol)))) + (:generic-function + (when gf-symbol-specified? (error ":GENERIC-FUNCTION specified twice")) + (setq generic-fn-symbol + (require-type (cadr (pop forms)) '(and symbol (not null))) + gf-symbol-specified? t)) + (t (return)))) + (multiple-value-bind (body decls doc) (parse-body forms env) + (unless generic-fn-symbol (setq generic-fn-symbol (make-symbol "GF"))) + (multiple-value-bind (specs order-forms required-flags descriptions) + (parse-method-group-specifiers method-group-specifiers) + (let* ((methods-sym (make-symbol "METHODS")) + (args-sym (make-symbol "ARGS")) + (options-sym (make-symbol "OPTIONS")) + (arg-vars ()) + (arg-vals ()) + (code `(lambda (,generic-fn-symbol ,methods-sym ,options-sym) + ,@(unless gf-symbol-specified? + `((declare (ignore-if-unused ,generic-fn-symbol)))) + (let* (,@(progn + (multiple-value-setq (arg-vars arg-vals) + (lfmc-bindings generic-fn-symbol + args-sym + arguments)) + (mapcar #'list arg-vars arg-vals))) + (declare (ignorable ,@arg-vars)) + ,@decls + (destructuring-bind ,lambda-list ,options-sym + (destructuring-bind + ,(mapcar #'car method-group-specifiers) + (seperate-method-groups + ,methods-sym ',specs + (list ,@order-forms) + ',required-flags + ',descriptions) + ,@body)))))) + `(%long-form-define-method-combination + ',name (cons (cons ',args-sym ',generic-fn-symbol) #',code) ',doc)))))) + +(defun %long-form-define-method-combination (name args-var.expander documentation) + (setq name (require-type name 'symbol)) + (let* ((mci (method-combination-info name))) + (if mci + (progn + (setf (mci.class mci) 'long-method-combination + (mci.options mci) args-var.expander) + (update-redefined-long-method-combinations name mci)) + (setf (method-combination-info name) + (setq mci (%cons-mci 'long-method-combination args-var.expander))))) + (set-documentation name 'method-combination documentation) + (record-source-file name 'method-combination) + name) + +(defun update-redefined-long-method-combinations (name mci) + (let ((args-var.expander (mci.options mci))) + (dolist (mc (population-data (mci.instances mci))) + (when (typep mc 'short-method-combination) + (change-class mc 'long-method-combination)) + (if (typep mc 'long-method-combination) + (setf (slot-value mc 'expander) args-var.expander) + (error "Bad method-combination-type: ~s" mc)))) + (clear-method-combination-caches name mci)) + +; Returns four values: +; method-group specifiers with :order, :required, & :description parsed out +; Values for the :order args +; Values for the :required args +; values for the :description args +(defun parse-method-group-specifiers (mgs) + (let (specs orders requireds descriptions) + (dolist (mg mgs) + (push nil specs) + (push :most-specific-first orders) + (push nil requireds) + (push nil descriptions) + (push (pop mg) (car specs)) ; name + (loop + (when (null mg) (return)) + (when (memq (car mg) '(:order :required :description)) + (destructuring-bind (&key (order :most-specific-first) required description) + mg + (setf (car orders) order) + (setf (car requireds) required) + (setf (car descriptions) description)) + (return)) + (push (pop mg) (car specs))) + (setf (car specs) (nreverse (car specs)))) + (values (nreverse specs) + (nreverse orders) + (nreverse requireds) + (nreverse descriptions)))) + +(defun seperate-method-groups (methods specs orders requireds descriptions) + (declare (ignore descriptions)) + (let ((res (make-list (length specs)))) + (dolist (m methods) + (let ((res-tail res)) + (dolist (s specs (%invalid-method-error + m "Does not match any of the method group specifiers")) + (when (specifier-match-p (method-qualifiers m) s) + (push m (car res-tail)) + (return)) + (pop res-tail)))) + (do ((res-tail res (cdr res-tail)) + (o-tail orders (cdr o-tail)) + (r-tail requireds (cdr r-tail))) + ((null res-tail)) + (case (car o-tail) + (:most-specific-last) + (:most-specific-first (setf (car res-tail) (nreverse (car res-tail)))) + (t (error "~s is neither ~s nor ~s" (car o-tail) :most-specific-first :most-specific-last))) + (when (car r-tail) + (unless (car res-tail) + ; should use DESCRIPTIONS here + (error "A required method-group matched no method group specifiers")))) + res)) + +(defun specifier-match-p (qualifiers spec) + (flet ((match (qs s) + (cond ((or (listp s) (eq s '*)) + (do ((qs-tail qs (cdr qs-tail)) + (s-tail s (cdr s-tail))) + ((or (null qs-tail) (atom s-tail)) + (or (eq s-tail '*) + (and (null qs-tail) (null s-tail)))) + (unless (or (eq (car s-tail) '*) + (equal (car qs-tail) (car s-tail))) + (return nil)))) + ((atom s) (funcall s qs)) + (t (error "Malformed method group specifier: ~s" spec))))) + (declare (inline match)) + (dolist (s (cdr spec)) + (when (match qualifiers s) + (return t))))) + +;;;;;;; +; +; The user visible error functions +; We don't add any contextual information yet. +; Maybe we never will. +(setf (symbol-function 'method-combination-error) #'%method-combination-error) +(setf (symbol-function 'invalid-method-error) #'%invalid-method-error) + +;;;;;;; +; +; The predefined method-combination types +; +(define-method-combination + :identity-with-one-argument t) +(define-method-combination and :identity-with-one-argument t) +(define-method-combination append :identity-with-one-argument t) +(define-method-combination list :identity-with-one-argument nil) +(define-method-combination max :identity-with-one-argument t) +(define-method-combination min :identity-with-one-argument t) +(define-method-combination nconc :identity-with-one-argument t) +(define-method-combination or :identity-with-one-argument t) +(define-method-combination progn :identity-with-one-argument t) + +; And evaluators for the non-functions +(define-method-combination-evaluator and (methods args) + (when methods + (loop + (if (null (cdr methods)) + (return (%%call-method* (car methods) nil args))) + (unless (%%call-method* (pop methods) nil args) + (return nil))))) + +(define-method-combination-evaluator or (methods args) + (when methods + (loop + (if (null (cdr methods)) + (return (%%call-method* (car methods) nil args))) + (let ((res (%%call-method* (pop methods) nil args))) + (when res (return res)))))) + +(define-method-combination-evaluator progn (methods args) + (when methods + (loop + (if (null (cdr methods)) + (return (%%call-method* (car methods) nil args))) + (%%call-method* (pop methods) nil args)))) + +#| + +;(define-method-combination and :identity-with-one-argument t) +(defgeneric func (x) (:method-combination and)) +(defmethod func and ((x window)) (print 3)) +(defmethod func and ((x fred-window)) (print 2)) +(func (front-window)) + +(define-method-combination example ()((methods positive-integer-qualifier-p)) + `(progn ,@(mapcar #'(lambda (method) + `(call-method ,method ())) + (sort methods #'< :key #'(lambda (method) + (first (method-qualifiers method))))))) + +(defun positive-integer-qualifier-p (method-qualifiers) + (and (= (length method-qualifiers) 1) + (typep (first method-qualifiers)'(integer 0 *)))) + +(defgeneric zork (x)(:method-combination example)) + +(defmethod zork 1 ((x window)) (print 1)) +(defmethod zork 2 ((x fred-window)) (print 2)) +(zork (front-window)) + + +|# + Index: /branches/new-random/lib/misc.lisp =================================================================== --- /branches/new-random/lib/misc.lisp (revision 13309) +++ /branches/new-random/lib/misc.lisp (revision 13309) @@ -0,0 +1,1241 @@ +;;;-*-Mode: LISP; Package: CCL -*- +;;; +;;; Copyright (C) 2009 Clozure Associates +;;; Copyright (C) 1994-2001 Digitool, Inc +;;; This file is part of Clozure CL. +;;; +;;; Clozure CL is licensed under the terms of the Lisp Lesser GNU Public +;;; License , known as the LLGPL and distributed with Clozure CL as the +;;; file "LICENSE". The LLGPL consists of a preamble and the LGPL, +;;; which is distributed with Clozure CL as the file "LGPL". Where these +;;; conflict, the preamble takes precedence. +;;; +;;; Clozure CL is referenced in the preamble as the "LIBRARY." +;;; +;;; The LLGPL is also available online at +;;; http://opensource.franz.com/preamble.html + +(in-package "CCL") + +(eval-when (eval compile) + (require 'defstruct-macros)) + +(defun short-site-name () + "Return a string with the abbreviated site name, or NIL if not known." + (or *short-site-name* "unspecified")) + +(defun long-site-name () + "Return a string with the long form of the site name, or NIL if not known." + (or *long-site-name* "unspecified")) + +(defun machine-instance () + "Return a string giving the name of the local machine." + #-windows-target (%uname 1) + #+windows-target + (rlet ((nsize #>DWORD 0)) + (if (eql 0 (#_GetComputerNameExW #$ComputerNameDnsFullyQualified + (%null-ptr) + nsize)) + (%stack-block ((buf (* 2 (pref nsize #>DWORD)))) + (#_GetComputerNameExW #$ComputerNameDnsFullyQualified + buf + nsize) + (%get-native-utf-16-cstring buf)) + "localhost")) + ) + + +(defun machine-type () + "Returns a string describing the type of the local machine." + #-windows-target (%uname 4) + #+windows-target + (rlet ((info #>SYSTEM_INFO)) + (#_GetSystemInfo info) + (case (pref info #>SYSTEM_INFO.nil.nil.wProcessorArchitecture) + (#.#$PROCESSOR_ARCHITECTURE_AMD64 "x64") + (#.#$PROCESSOR_ARCHITECTURE_INTEL "x86") + (t "unknown"))) + ) + + + +(defloadvar *machine-version* nil) + +(defun machine-version () + "Return a string describing the version of the computer hardware we +are running on, or NIL if we can't find any useful information." + (or *machine-version* + (setq *machine-version* + #+darwin-target + (block darwin-machine-version + (%stack-block ((mib 8)) + (setf (%get-long mib 0) #$CTL_HW + (%get-long mib 4) #$HW_MODEL) + (%stack-block ((res 256) + (reslen target::node-size)) + (setf (%get-byte res 0) 0 + (%get-natural reslen 0) 256) + (if (zerop (#_sysctl mib 2 res reslen (%null-ptr) 0)) + (return-from darwin-machine-version (%get-cstring res)))))) + #+linux-target + (with-open-file (f "/proc/cpuinfo" :if-does-not-exist nil) + (when f + (flet ((cpu-info-match (target line) + (let* ((targetlen (length target)) + (linelen (length line))) + (if (and (> linelen targetlen) + (string= target line + :end2 targetlen)) + (let* ((colonpos (position #\: line))) + (when colonpos + (string-trim " " + (subseq line (1+ colonpos))))))))) + (do* ((line (read-line f nil nil) + (read-line f nil nil)) + (target #+ppc-target "machine" + #+x86-target "model name")) + ((null line)) + (let* ((matched (cpu-info-match target line))) + (when matched (return matched))))))) + #+freebsd-target + (%stack-block ((ret 512) + (mib (* (record-length :uint)))) + (setf (%get-unsigned-long mib 0) + #$CTL_HW + (%get-unsigned-long mib (record-length :uint)) + #$HW_MODEL) + (rlet ((oldsize :uint 512)) + (if (eql 0 (#_sysctl mib 2 ret oldsize (%null-ptr) 0)) + (%get-cstring ret) + 1))) + #+solaris-target + (rlet ((info :processor_info_t)) + (do* ((i 0 (1+ i))) + ((and (= 0 (#_processor_info i info)) + (= (pref info :processor_info_t.pi_state) + #$P_ONLINE)) + (%get-cstring (pref info :processor_info_t.pi_processor_type))))) + #+windows-target + (getenv "PROCESSOR_IDENTIFIER") + ))) + + +(defun software-type () + "Return a string describing the supporting software." + #-windows-target (%uname 0) + #+windows-target "Microsoft Windows") + + +(defun software-version () + "Return a string describing version of the supporting software, or NIL + if not available." + #-windows-target (%uname 2) + #+windows-target + (rletZ ((info #>OSVERSIONINFOEX)) + (setf (pref info #>OSVERSIONINFOEX.dwOSVersionInfoSize) + (record-length #>OSVERSIONINFOEX)) + (#_GetVersionExA info) + (format nil "~d.~d Build ~d (~a)" + (pref info #>OSVERSIONINFOEX.dwMajorVersion) + (pref info #>OSVERSIONINFOEX.dwMinorVersion) + (pref info #>OSVERSIONINFOEX.dwBuildNumber) + (if (eql (pref info #>OSVERSIONINFOEX.wProductType) + #$VER_NT_WORKSTATION) + "Workstation" + "Server"))) + ) + + + + + + + +;;; Yawn. + + + +(defmethod documentation (thing doc-id) + (%get-documentation thing doc-id)) + +(defmethod (setf documentation) (new thing doc-id) + (%put-documentation thing doc-id new)) + + +(defmethod documentation ((symbol symbol) (doc-type (eql 'function))) + (let* ((def (fboundp symbol))) ; FBOUNDP returns info about definition + (when def + (%get-documentation def t)))) + +(defmethod (setf documentation) ((new t) + (symbol symbol) + (doc-type (eql 'function))) + (let* ((def (fboundp symbol))) ; FBOUNDP returns info about definition + (when def + (%put-documentation def + t + new)) + new)) + +(defmethod documentation ((symbol symbol) (doc-type (eql 'setf))) + (call-next-method)) + +(defmethod (setf documentation) ((new t) + (symbol symbol) + (doc-type (eql 'setf))) + (call-next-method)) + + +(defmethod documentation ((symbol symbol) (doc-type (eql 'variable))) + (call-next-method)) + +(defmethod (setf documentation) ((new t) + (symbol symbol) + (doc-type (eql 'variable))) + (call-next-method)) + +(defmethod documentation ((symbol symbol) (doc-type (eql 'compiler-macro))) + (call-next-method)) + +(defmethod (setf documentation) ((new t) + (symbol symbol) + (doc-type (eql 'compiler-macro))) + (call-next-method)) + +(defmethod documentation ((symbol symbol) (doc-type (eql 'type))) + (let* ((class (find-class symbol nil))) + (if class + (documentation class doc-type) + (call-next-method)))) + +(defmethod (setf documentation) (new (symbol symbol) (doc-type (eql 'type))) + (let* ((class (find-class symbol nil))) + (if class + (setf (documentation class doc-type) new) + (call-next-method)))) + +(defmethod documentation ((symbol symbol) (doc-type (eql 'method-combination))) + (let* ((mci (method-combination-info symbol))) + (if mci + (documentation mci doc-type)))) + +(defmethod (setf documentation) ((new t) + (symbol symbol) + (doc-type (eql 'method-combination))) + (let* ((mci (method-combination-info symbol))) + (if mci + (setf (documentation mci doc-type) new)))) + + +(defmethod documentation ((symbol symbol) (doc-type (eql 'structure))) + (let* ((class (find-class symbol nil))) + (if (typep class 'structure-class) + (documentation class 'type) + (call-next-method)))) + +(defmethod (setf documentation) ((new t) + (symbol symbol) + (doc-type (eql 'structure))) + (let* ((class (find-class symbol nil))) + (if (typep class 'structure-class) + (setf (documentation class 'type) new) + (call-next-method)))) + +(defmethod documentation ((p package) (doc-type (eql 't))) + (call-next-method)) + +(defmethod (setf documentation) ((new t) (p package) (doc-type (eql 't))) + (call-next-method)) + +(defmethod documentation ((f function) (doc-type (eql 't))) + (call-next-method)) + +(defmethod (setf documentation) ((new t) (f function) (doc-type (eql 't))) + (call-next-method)) + +(defmethod documentation ((f function) (doc-type (eql 'function))) + (documentation f t)) + +(defmethod (setf documentation) ((new t) + (f function) + (doc-type (eql 'function))) + (setf (documentation f t) new)) + +(defmethod documentation ((l cons) (doc-type (eql 'function))) + (let* ((name (setf-function-spec-name l))) + (if name + (documentation name doc-type) + (%get-documentation l doc-type)))) + +(defmethod (setf documentation) ((new t) (l cons) (doc-type (eql 'function))) + (let* ((name (setf-function-spec-name l))) + (if name + (setf (documentation name doc-type) new) + (%put-documentation l doc-type new)))) + + +(defmethod documentation ((l cons) (doc-type (eql 'compiler-macro))) + (let* ((name (setf-function-spec-name l))) + (if name + (documentation name doc-type) + (%get-documentation l doc-type)))) + +(defmethod (setf documentation) ((new t) (l cons) (doc-type (eql 'compiler-macr0))) + (let* ((name (setf-function-spec-name l))) + (if name + (setf (documentation name doc-type) new) + (%put-documentation l doc-type new)))) + + +(defmethod documentation ((m method-combination) + (doc-type (eql 'method-combination))) + (call-next-method)) + +(defmethod (setf documentation) ((new t) + (m method-combination) + (doc-type (eql 'method-combination))) + (call-next-method)) + +(defmethod documentation ((m method-combination) + (doc-type (eql t))) + (documentation m 'method-combination)) + +(defmethod (setf documentation) ((new t) + (m method-combination) + (doc-type (eql t))) + (setf (documentation m 'method-combination) new)) + +(defmethod documentation ((m standard-method) + (doc-type (eql t))) + (call-next-method)) + +(defmethod (setf documentation) ((new t) + (m standard-method) + (doc-type (eql t))) + (call-next-method)) + +(defmethod documentation ((c standard-class) (doc-type (eql 'type))) + (call-next-method)) + +(defmethod (setf documentation) ((new t) + (c standard-class) + (doc-type (eql 'type))) + (call-next-method)) + +(defmethod documentation ((c standard-class) (doc-type (eql 't))) + (documentation c 'type)) + +(defmethod (setf documentation) ((new t) + (c standard-class) + (doc-type (eql 't))) + (setf (documentation c 'type) new)) + +(defmethod documentation ((c structure-class) (doc-type (eql 'type))) + (call-next-method)) + +(defmethod (setf documentation) ((new t) + (c structure-class) + (doc-type (eql 'type))) + (call-next-method)) + +(defmethod documentation ((c structure-class) (doc-type (eql 't))) + (documentation c 'type)) + +(defmethod (setf documentation) ((new t) + (c structure-class) + (doc-type (eql 't))) + (setf (documentation c 'type) new)) + +;;; This is now deprecated; things which call it should stop doing so. +(defun set-documentation (symbol doc-type string) + (setf (documentation symbol doc-type) string)) + +(defun set-function-info (symbol info) + (let* ((doc-string (if (consp info) (car info) info))) + (if (and *save-doc-strings* (stringp doc-string)) + (set-documentation symbol 'function doc-string))) + (let* ((cons (assq symbol *nx-globally-inline*)) + (lambda-expression (if (consp info) (cdr info)))) + (if (and (proclaimed-inline-p symbol) + (not (compiler-special-form-p symbol)) + (lambda-expression-p lambda-expression) + (let* ((lambda-list (cadr lambda-expression))) + (and (not (memq '&lap lambda-list)) + (not (memq '&method lambda-list)) + (not (memq '&lexpr lambda-list))))) + (if cons + (%rplacd cons lambda-expression) + (push (cons symbol lambda-expression) *nx-globally-inline*)) + (if cons (setq *nx-globally-inline* (delete cons *nx-globally-inline*))))) + symbol) + + +(setf (documentation 'if 'function) + "If Predicate Then [Else] + If Predicate evaluates to non-null, evaluate Then and returns its values, + otherwise evaluate Else and return its values. Else defaults to NIL.") + +(setf (documentation 'progn 'function) + "progn form* + Evaluates each FORM and returns the value(s) of the last FORM.") + +(defmethod documentation ((thing character-encoding) (doc-type (eql t))) + (character-encoding-documentation thing)) + +(defmethod (setf documentation) (new (thing character-encoding) (doc-type (eql t))) + (check-type new (or null string)) + (setf (character-encoding-documentation thing) new)) + +(defmethod documentation ((thing symbol) (doc-type (eql 'character-encoding))) + (let* ((encoding (lookup-character-encoding (intern (string thing) :keyword)))) + (when encoding + (documentation encoding t)))) + + + + +#| +(setf (documentation 'car 'variable) "Preferred brand of automobile") +(documentation 'car 'variable) +(setf (documentation 'foo 'structure) "the structure is grand.") +(documentation 'foo 'structure) +(setf (documentation 'foo 'variable) "the metasyntactic remarker") +(documentation 'foo 'variable) +(setf (documentation 'foo 'obscure) "no one really knows what it means") +(documentation 'foo 'obscure) +(setf (documentation 'foo 'structure) "the structure is solid") +(documentation 'foo 'function) +||# + +;; + + +(defun %page-fault-info () + #-(or darwin-target windows-target) + (rlet ((usage :rusage)) + (%%rusage usage) + (values (pref usage :rusage.ru_minflt) + (pref usage :rusage.ru_majflt) + (pref usage :rusage.ru_nswap))) + #+darwin-target + (rlet ((count #>mach_msg_type_number_t #$TASK_EVENTS_INFO_COUNT) + (info #>task_events_info)) + (#_task_info (#_mach_task_self) #$TASK_EVENTS_INFO info count) + (values (pref info #>task_events_info.cow_faults) + (pref info #>task_events_info.faults) + (pref info #>task_events_info.pageins))) + #+windows-target + ;; Um, don't know how to determine this, or anything like it. + (values 0 0 0)) + + + +(defparameter *report-time-function* nil + "If non-NULL, should be a function which accepts the following + keyword arguments: + :FORM the form that was executed + :RESULTS a list of all values returned by the execution of FORM + :ELAPSED-TIME total elapsed (real) time, in internal-time-units-per-second + :USER-TIME elapsed user time, in internal-time-units-per-second + :SYSTEM-TIME elapsed system time, in internal-time-units-per-second + :GC-TIME total real time spent in the GC, in internal-time-units-per-second + :BYTES-ALLOCATED total bytes allocated + :MINOR-PAGE-FAULTS minor page faults + :MAJOR-PAGE-FAULTS major page faults + :SWAPS swaps") + + +(defun standard-report-time (&key form results elapsed-time user-time + system-time gc-time bytes-allocated + minor-page-faults major-page-faults + swaps) + (let* ((s *trace-output*) + (units + (ecase internal-time-units-per-second + (1000000 "microseconds") + (1000 "milliseconds"))) + (width + (ecase internal-time-units-per-second + (1000000 6) + (1000 3))) + (cpu-count (cpu-count))) + (format s "~&~S took ~:D ~a (~,vF seconds) to run ~%~20twith ~D available CPU core~P." + form elapsed-time units width (/ elapsed-time internal-time-units-per-second) cpu-count cpu-count) + (format s "~&During that period, ~:D ~a (~,vF seconds) were spent in user mode" user-time units width (/ user-time internal-time-units-per-second)) + (format s "~& ~:D ~a (~,vF seconds) were spent in system mode" system-time units width(/ system-time internal-time-units-per-second)) + (unless (eql gc-time 0) + (format s + "~%~:D ~a (~,vF seconds) was spent in GC." + gc-time units width (/ gc-time internal-time-units-per-second))) + (unless (eql 0 bytes-allocated) + (format s "~% ~:D bytes of memory allocated." bytes-allocated)) + (when (or (> minor-page-faults 0) + (> major-page-faults 0) + (> swaps 0)) + (format s + "~% ~:D minor page faults, ~:D major page faults, ~:D swaps." + minor-page-faults major-page-faults swaps)) + (format s "~&") + (values-list results))) + +(defun report-time (form thunk) + (flet ((integer-size-in-bytes (i) + (if (typep i 'fixnum) + 0 + (* (logand (+ 2 (uvsize i)) (lognot 1)) 4)))) + (multiple-value-bind (user-start system-start) + (%internal-run-time) + (multiple-value-bind (minor-start major-start swaps-start) + (%page-fault-info) + (let* ((initial-real-time (get-internal-real-time)) + (initial-gc-time (gctime)) + (initial-consed (total-bytes-allocated)) + (initial-overhead (integer-size-in-bytes initial-consed))) + (let* ((results (multiple-value-list (funcall thunk)))) + (declare (dynamic-extent results)) + (multiple-value-bind (user-end system-end) + (%internal-run-time) + (multiple-value-bind (minor-end major-end swaps-end) + (%page-fault-info) + (let* ((new-consed (total-bytes-allocated)) + (bytes-consed + (- new-consed (+ initial-overhead initial-consed))) + (elapsed-real-time + (- (get-internal-real-time) initial-real-time)) + (elapsed-gc-time (- (gctime) initial-gc-time)) + (elapsed-user-time + (- user-end user-start)) + (elapsed-system-time + (- system-end system-start)) + (elapsed-minor (- minor-end minor-start)) + (elapsed-major (- major-end major-start)) + (elapsed-swaps (- swaps-end swaps-start))) + (funcall (or *report-time-function* + #'standard-report-time) + :form form + :results results + :elapsed-time elapsed-real-time + :user-time elapsed-user-time + :system-time elapsed-system-time + :gc-time elapsed-gc-time + :bytes-allocated bytes-consed + :minor-page-faults elapsed-minor + :major-page-faults elapsed-major + :swaps elapsed-swaps)))))))))) + + + + +;;; site names and machine-instance is in the init file. + +(defun add-feature (symbol) + "Not CL but should be." + (if (symbolp symbol) + (if (not (memq symbol *features*)) + (setq *features* (cons symbol *features*))))) + +;;; (dotimes (i 5000) (declare (fixnum i)) (add-feature 'junk)) + + + + +;;; Misc string functions + + +(defun string-left-trim (char-bag string &aux end) + "Given a set of characters (a list or string) and a string, returns + a copy of the string with the characters in the set removed from the + left end." + (setq string (string string)) + (setq end (length string)) + (do ((index 0 (%i+ index 1))) + ((or (eq index end) (not (find (aref string index) char-bag))) + (subseq string index end)))) + +(defun string-right-trim (char-bag string &aux end) + "Given a set of characters (a list or string) and a string, returns + a copy of the string with the characters in the set removed from the + right end." + (setq string (string string)) + (setq end (length string)) + (do ((index (%i- end 1) (%i- index 1))) + ((or (%i< index 0) (not (find (aref string index) char-bag))) + (subseq string 0 (%i+ index 1))))) + +(defun string-trim (char-bag string &aux end) + "Given a set of characters (a list or string) and a string, returns a + copy of the string with the characters in the set removed from both + ends." + (setq string (string string)) + (setq end (length string)) + (let ((left-end) (right-end)) + (do ((index 0 (%i+ index 1))) + ((or (eq index end) (not (find (aref string index) char-bag))) + (setq left-end index))) + (do ((index (%i- end 1) (%i- index 1))) + ((or (%i< index left-end) (not (find (aref string index) char-bag))) + (setq right-end index))) + (subseq string left-end (%i+ right-end 1)))) + + + +(defun copy-symbol (symbol &optional (copy-props nil) &aux new-symbol def) + "Make and return a new uninterned symbol with the same print name + as SYMBOL. If COPY-PROPS is false, the new symbol is neither bound + nor fbound and has no properties, else it has a copy of SYMBOL's + function, value and property list." + (setq new-symbol (make-symbol (symbol-name symbol))) + (when copy-props + (when (boundp symbol) + (set new-symbol (symbol-value symbol))) + (when (setq def (fboundp symbol)) + ;;;Shouldn't err out on macros/special forms. + (%fhave new-symbol def)) + (set-symbol-plist new-symbol (copy-list (symbol-plist symbol)))) + new-symbol) + + +(defvar %gentemp-counter 0 + "Counter for generating unique GENTEMP symbols.") + +(defun gentemp (&optional (prefix "T") (package *package*)) + "Creates a new symbol interned in package PACKAGE with the given PREFIX." + (loop + (let* ((new-pname (%str-cat (ensure-simple-string prefix) + (%integer-to-string %gentemp-counter))) + (sym (find-symbol new-pname package))) + (if sym + (setq %gentemp-counter (%i+ %gentemp-counter 1)) + (return (values (intern new-pname package))))))) ; 1 value. + + + + +(defun add-gc-hook (hook-function &optional (which-hook :pre-gc)) + (ecase which-hook + (:pre-gc + (pushnew hook-function *pre-gc-hook-list*) + (setq *pre-gc-hook* #'(lambda () + (dolist (hook *pre-gc-hook-list*) + (funcall hook))))) + (:post-gc + (pushnew hook-function *post-gc-hook-list*) + (setq *post-gc-hook* #'(lambda () + (dolist (hook *post-gc-hook-list*) + (funcall hook)))))) + hook-function) + +(defun remove-gc-hook (hook-function &optional (which-hook :pre-gc)) + (ecase which-hook + (:pre-gc + (unless (setq *pre-gc-hook-list* (delq hook-function *pre-gc-hook-list*)) + (setq *pre-gc-hook* nil))) + (:post-gc + (unless (setq *post-gc-hook-list* (delq hook-function *post-gc-hook-list*)) + (setq *post-gc-hook* nil))))) + + + + + + +(defun find-method-by-names (name qualifiers specializers) + (let ((gf (fboundp name))) + (when gf + (if (not (standard-generic-function-p gf)) + (error "~S is not a generic-function." gf) + (let ((methods (%gf-methods gf))) + (when methods + (let* ((spec-len (length (%method-specializers (car methods)))) + (new-specs (make-list spec-len :initial-element (find-class t)))) + (declare (dynamic-extent new-specs)) + (do ((specs specializers (cdr specs)) + (nspecs new-specs (cdr nspecs))) + ((or (null specs) (null nspecs))) + (let ((s (car specs))) + (rplaca nspecs (if (consp s) s (find-class s nil))))) + (find-method gf qualifiers new-specs nil)))))))) + + + + +(defun make-population (&key (type :list) initial-contents) + (let* ((ntype (ecase type + (:list $population_weak-list) + (:alist $population_weak-alist))) + (list (if (eq type :alist) + (map 'list (lambda (c) (cons (car c) (%cdr c))) initial-contents) + (if (listp initial-contents) + (copy-list initial-contents) + (coerce initial-contents 'list))))) + (%cons-population list ntype))) + +(defun population-type (population) + (let ((ntype (population.type (require-type population 'population)))) + (cond ((eq ntype $population_weak-alist) :alist) + ((eq ntype $population_weak-list) :list) + (t nil)))) + +(declaim (inline population-contents (setf population-contents))) + +(defun population-contents (population) + (population.data (require-type population 'population))) + +(defun (setf population-contents) (list population) + (setf (population.data (require-type population 'population)) (require-type list 'list))) + + + + +(defun get-string-from-user (prompt) + (with-terminal-input + (format *query-io* "~&~a " prompt) + (force-output *query-io*) + (clear-input *query-io*) + (values (read-line *query-io*)))) + + +(defun select-item-from-list (list &key (window-title "Select one of the following") + (table-print-function #'prin1) + &allow-other-keys) + (block get-answer + (with-terminal-input + (format *query-io* "~a:~%" window-title) + (loop + (catch :redisplay + (do* ((l list (cdr l)) + (i 0 (1+ i)) + (item (car l) (car l))) + ((null l)) + (declare (fixnum i)) + (format *query-io* "~& ~d: " i) + (funcall table-print-function item *query-io*)) + (loop + (fresh-line *query-io*) + (let* ((string (get-string-from-user "Selection [number,q,r,?]:")) + (value (ignore-errors + (let* ((*package* *keyword-package*)) + (read-from-string string nil))))) + (cond ((eq value :q) (throw :cancel t)) + ((eq value :r) (throw :redisplay t)) + ((eq value :?) + (format *query-io* "~%Enter the number of the selection, ~% r to redisplay, ~% q to cancel or ~% ? to show this message again.")) + ((and (typep value 'unsigned-byte) + (< value (length list))) + (return-from get-answer (list (nth value list)))))))))))) + +(defvar *choose-file-dialog-hook* nil "for GUIs") + +;;; There should ideally be some way to override the UI (such as +;;; it is ...) here. +;;; More generally, this either +;;; a) shouldn't exist, or +;;; b) should do more sanity-checking +(defun choose-file-dialog (&key file-types (prompt "File name:")) + (let* ((hook *choose-file-dialog-hook*)) + (if hook + (funcall hook t prompt file-types) + (%choose-file-dialog t prompt file-types)))) + +(defun choose-new-file-dialog (&key prompt) + (let* ((hook *choose-file-dialog-hook*)) + (if hook + (funcall hook nil prompt nil) + (%choose-file-dialog nil prompt nil)))) + +(defun %choose-file-dialog (must-exist prompt file-types) + (loop + (let* ((namestring (get-string-from-user prompt)) + (pathname (ignore-errors (pathname namestring))) + (exists (and pathname (probe-file pathname)))) + (when (and (if must-exist exists) + (or (null file-types) + (member (pathname-type pathname) + file-types :test #'equal))) + (return pathname)) + (if (not exists) + (format *query-io* "~&~s does not exist." namestring) + (format *query-io* "~&Type of ~s is not one of ~{~a~}" + namestring file-types))))) + +(defparameter *overwrite-dialog-hook* nil) +(defun overwrite-dialog (filename prompt) + (if *overwrite-dialog-hook* + (funcall *overwrite-dialog-hook* filename prompt) + t)) + +;;; Might want to have some other entry for, e.g., the inspector +;;; and to let it get its hands on the list header returned by +;;; disassemble-ppc-function. Maybe disassemble-ppc-function +;;; should take care of "normalizing" the code-vector ? +(defun disassemble (thing) + "Disassemble the compiled code associated with OBJECT, which can be a + function, a lambda expression, or a symbol with a function definition. If + it is not already compiled, the compiler is called to produce something to + disassemble." + (#+ppc-target ppc-xdisassemble + #+x86-target x86-xdisassemble + (require-type (function-for-disassembly thing) 'compiled-function))) + +(defun function-for-disassembly (thing) + (let* ((fun thing)) + ;; CLHS says that DISASSEMBLE should signal a type error if its + ;; argument isn't a function designator. Hard to imagine any + ;; code depending on that ... + ;;(when (typep fun 'standard-method) (setq fun (%method-function fun))) + (when (or (symbolp fun) + (and (consp fun) (neq (%car fun) 'lambda))) + (setq fun (fboundp thing)) + (when (and (symbolp thing) (not (functionp fun))) + (setq fun (macro-function thing)))) + (if (typep fun 'compiled-lexical-closure) + (setq fun (closure-function fun))) + (when (lambda-expression-p fun) + (setq fun (compile-named-function fun))) + fun)) + +(%fhave 'df #'disassemble) + +(defun string-sans-most-whitespace (string &optional (max-length (length string))) + (with-output-to-string (sans-whitespace) + (loop + for count below max-length + for char across string + with just-saw-space = nil + if (member char '(#\Space #\Tab #\Newline #\Return #\Formfeed)) + do (if just-saw-space + (decf count) + (write-char #\Space sans-whitespace)) + and do (setf just-saw-space t) + else + do (setf just-saw-space nil) + and do (write-char char sans-whitespace)))) + + +(defparameter *svn-program* "svn") + +(defloadvar *use-cygwin-svn* + #+windows-target (not (null (getenv "CYGWIN"))) + #-windows-target nil) + +(defun svn-info-component (component) + (let* ((component-length (length component))) + (let* ((s (make-string-output-stream))) + (multiple-value-bind (status exit-code) + (external-process-status + (run-program *svn-program* (list "info" (native-translated-namestring "ccl:")) :output s :error :output)) + (when (and (eq :exited status) (zerop exit-code)) + (with-input-from-string (output (get-output-stream-string s)) + (do* ((line (read-line output nil nil) (read-line output nil nil))) + ((null line)) + (when (and (>= (length line) component-length) + (string= component line :end2 component-length)) + (return-from svn-info-component + (string-trim " " (subseq line component-length))))))))) + nil)) + +(defun svn-url () (svn-info-component "URL:")) +(defun svn-repository () (svn-info-component "Repository Root:")) + +;;; Try to say something about what tree (trunk, a branch, a release) +;;; we were built from. If the URL (relative to the repository) +;;; starts with "branches", return the second component of the +;;; relative URL, otherwise return the first component. +(defun svn-tree () + (let* ((repo (svn-repository)) + (url (svn-url))) + (or + (if (and repo url) + (let* ((repo-len (length repo))) + (when (and (> (length url) repo-len) + (string= repo url :end2 repo-len)) + ;; Cheat: do pathname parsing here. + (let* ((path (pathname (ensure-directory-namestring (subseq url repo-len)))) + (dir (cdr (pathname-directory path)))) + (when (string= "ccl" (car (last dir))) + (let* ((base (car dir))) + (unless (or (string= base "release") + (string= base "releases")) + (if (string= base "branches") + (cadr dir) + (car dir)))))))))))) + + +(defun svnversion-program () + (or (ignore-errors + (native-translated-namestring + (merge-pathnames "svnversion" *svn-program*))) + "svnversion")) + + + + +(defun local-svn-revision () + (let* ((s (make-string-output-stream)) + (root (native-translated-namestring "ccl:"))) + (when *use-cygwin-svn* + (setq root (cygpath root))) + (multiple-value-bind (status exit-code) + (external-process-status + (run-program (svnversion-program) (list (native-translated-namestring "ccl:") (or (svn-url) "")) :output s :error :output)) + (when (and (eq :exited status) (zerop exit-code)) + (with-input-from-string (output (get-output-stream-string s)) + (let* ((line (read-line output nil nil))) + (when (and line (parse-integer line :junk-allowed t) ) + (return-from local-svn-revision line)))))) + nil)) + + +;;; Scan the heap, collecting infomation on the primitive object types +;;; found. Report that information. + +(defun heap-utilization (&key (stream *debug-io*) + (gc-first t) + (area nil) + (unit nil) + (sort :size) + (classes nil) + (start nil)) + "Show statistic about types of objects in the heap. + If :GC-FIRST is true (the default), do a full gc before scanning the heap. + If :START is non-nil, it should be an object returned by GET-ALLOCATION-SENTINEL, only + objects at higher address are scanned (i.e. roughly, only objects allocated after it). + :SORT can be one of :COUNT, :LOGICAL-SIZE, or :PHYSICAL-SIZE to sort by count or size. + :UNIT can be one of :KB :MB or :GB to show sizes in units other than bytes. + :AREA can be used to restrict the walk to one area or a list of areas. Some possible + values are :DYNAMIC, :STATIC, :MANAGED-STATIC, :READONLY. By default, all areas + (including stacks) are examined. + If :CLASSES is true, classifies by class rather than just typecode" + (let ((data (collect-heap-utilization :gc-first gc-first :start start :area area :classes classes))) + (report-heap-utilization data :stream stream :unit unit :sort sort))) + +(defun collect-heap-utilization (&key (gc-first t) start area classes) + ;; returns list of (type-name count logical-sizes-total physical-sizes-total) + (when start + (unless (or (null area) + (eq (heap-area-code area) area-dynamic) + (and (consp area) (every (lambda (a) (eq (heap-area-code a) area-dynamic)) area))) + (error "~s ~s and ~s ~s are incompatible" :start start :area area)) + (setq area area-dynamic)) + (if classes + (collect-heap-utilization-by-class gc-first area start) + (collect-heap-utilization-by-typecode gc-first area start))) + +(defun collect-heap-utilization-by-typecode (gc-first area start) + (let* ((nconses 0) + (counts (make-array 257)) + (sizes (make-array 257)) + (physical-sizes (make-array 257)) + (array-size-function (arch::target-array-data-size-function + (backend-target-arch *host-backend*)))) + (declare (type (simple-vector 257) counts sizes physical-sizes) + (fixnum nconses) + (dynamic-extent counts sizes physical-sizes)) + (flet ((collect (thing) + (when (or (null start) + (locally (declare (optimize (speed 3) (safety 0))) ;; lie + (%i< start thing))) + (if (listp thing) + (incf nconses) + (let* ((typecode (typecode thing)) + (logsize (funcall array-size-function typecode (uvsize thing))) + (physize (logandc2 (+ logsize + #+64-bit-target (+ 8 15) + #+32-bit-target (+ 4 7)) + #+64-bit-target 15 + #+32-bit-target 7))) + (incf (aref counts typecode)) + (incf (aref sizes typecode) logsize) + (incf (aref physical-sizes typecode) physize)))))) + (declare (dynamic-extent #'collect)) + (when gc-first (gc)) + (%map-areas #'collect area)) + (setf (aref counts 256) nconses) + (setf (aref sizes 256) (* nconses target::cons.size)) + (setf (aref physical-sizes 256) (aref sizes 256)) + (loop for i from 0 upto 256 + when (plusp (aref counts i)) + collect (list (if (eql i 256) 'cons (aref *heap-utilization-vector-type-names* i)) + (aref counts i) + (aref sizes i) + (aref physical-sizes i))))) + +(defun collect-heap-utilization-by-class (gc-first area start) + (let* ((nconses 0) + (max-classes (+ 100 (hash-table-count %find-classes%))) + (map (make-hash-table :shared nil + :test 'eq + :size max-classes)) + (inst-counts (make-array max-classes :initial-element 0)) + (slotv-counts (make-array max-classes :initial-element 0)) + (inst-sizes (make-array max-classes :initial-element 0)) + (slotv-sizes (make-array max-classes :initial-element 0)) + (inst-psizes (make-array max-classes :initial-element 0)) + (slotv-psizes (make-array max-classes :initial-element 0)) + (overflow nil) + (array-size-function (arch::target-array-data-size-function + (backend-target-arch *host-backend*)))) + (declare (type simple-vector inst-counts slotv-counts inst-sizes slotv-sizes inst-psizes slotv-psizes)) + (flet ((collect (thing) + (when (or (null start) + (locally (declare (optimize (speed 3) (safety 0))) ;; lie + (%i< start thing))) + (if (listp thing) + (incf nconses) + (unless (or (eq thing map) + (eq thing (nhash.vector map)) + (eq thing inst-counts) + (eq thing slotv-counts) + (eq thing inst-sizes) + (eq thing slotv-sizes) + (eq thing inst-psizes) + (eq thing slotv-psizes)) + (let* ((typecode (typecode thing)) + (logsize (funcall array-size-function typecode (uvsize thing))) + (physize (logandc2 (+ logsize + #+64-bit-target (+ 8 15) + #+32-bit-target (+ 4 7)) + #+64-bit-target 15 + #+32-bit-target 7)) + (class (class-of (if (eql typecode target::subtag-slot-vector) + (uvref thing slot-vector.instance) + thing))) + (index (or (gethash class map) + (let ((count (hash-table-count map))) + (if (eql count max-classes) + (setq overflow t count (1- max-classes)) + (setf (gethash class map) count)))))) + + (if (eql typecode target::subtag-slot-vector) + (progn + (incf (aref slotv-counts index)) + (incf (aref slotv-sizes index) logsize) + (incf (aref slotv-psizes index) physize)) + (progn + (incf (aref inst-counts index)) + (incf (aref inst-sizes index) logsize) + (incf (aref inst-psizes index) physize))))))))) + (declare (dynamic-extent #'collect)) + (when gc-first (gc)) + (%map-areas #'collect area)) + (let ((data ())) + (when (plusp nconses) + (push (list 'cons nconses (* nconses target::cons.size) (* nconses target::cons.size)) data)) + (maphash (lambda (class index) + (let* ((icount (aref inst-counts index)) + (scount (aref slotv-counts index)) + (name (if (and overflow (eql index (1- max-classes))) + "All others" + (or (%class-proper-name class) class)))) + (declare (fixnum icount) (fixnum scount)) + ;; When printing class names, the package matters. report-heap-utilization + ;; uses ~a, so print here. + (when (plusp icount) + (push (list (prin1-to-string name) + icount (aref inst-sizes index) (aref inst-psizes index)) data)) + (when (plusp scount) + (push (list (format nil "(SLOT-VECTOR ~s)" name) + scount (aref slotv-sizes index) (aref slotv-psizes index)) data)))) + map) + data))) + +(defvar *heap-utilization-vector-type-names* + (let* ((a (make-array 256))) + #+x8664-target + (dotimes (i 256) + (let* ((fulltag (logand i x8664::fulltagmask)) + (names-vector + (cond ((= fulltag x8664::fulltag-nodeheader-0) + *nodeheader-0-types*) + ((= fulltag x8664::fulltag-nodeheader-1) + *nodeheader-1-types*) + ((= fulltag x8664::fulltag-immheader-0) + *immheader-0-types*) + ((= fulltag x8664::fulltag-immheader-1) + *immheader-1-types*) + ((= fulltag x8664::fulltag-immheader-2) + *immheader-2-types*))) + (name (if names-vector + (aref names-vector (ash i -4))))) + ;; Special-case a few things ... + (if (eq name 'symbol-vector) + (setq name 'symbol) + (if (eq name 'function-vector) + (setq name 'function))) + (setf (aref a i) name))) + #+ppc64-target + (dotimes (i 256) + (let* ((lowtag (logand i ppc64::lowtagmask))) + (setf (%svref a i) + (cond ((= lowtag ppc64::lowtag-immheader) + (%svref *immheader-types* (ash i -2))) + ((= lowtag ppc64::lowtag-nodeheader) + (%svref *nodeheader-types* (ash i -2))))))) + #+(or ppc32-target x8632-target) + (dotimes (i 256) + (let* ((fulltag (logand i target::fulltagmask))) + (setf (%svref a i) + (cond ((= fulltag target::fulltag-immheader) + (%svref *immheader-types* (ash i -3))) + ((= fulltag target::fulltag-nodeheader) + (%svref *nodeheader-types* (ash i -3))))))) + a)) + + +(defun report-heap-utilization (data &key stream unit sort) + (let* ((div (ecase unit + ((nil) 1) + (:kb 1024.0d0) + (:mb (* 1024.0d0 1024.0d0)) + (:gb (* 1024.0d0 1024.0d0 1024.0d0)))) + (sort-key (ecase sort + (:count #'cadr) + (:logical-size #'caddr) + ((:physical-size :size) #'cadddr) + ((:name nil) nil))) + (total-count 0) + (total-lsize 0) + (total-psize 0) + (max-name 0)) + (loop for (name count lsize psize) in data + do (incf total-count count) + do (incf total-lsize lsize) + do (incf total-psize psize) + do (setq max-name (max max-name + (length (if (stringp name) + name + (if (symbolp name) + (symbol-name name) + (princ-to-string name))))))) + (setq data + (if sort-key + (sort data #'> :key sort-key) + (sort data #'string-lessp :key #'(lambda (name) + (if (stringp name) + name + (if (symbolp name) + (symbol-name name) + (princ-to-string name))))))) + + (format stream "~&Object type~vtCount Logical size Physical size % of Heap~%~vt ~a~vt ~2:*~a" + (+ max-name 7) + (+ max-name 15) + (ecase unit + ((nil) " (in bytes)") + (:kb "(in kilobytes)") + (:mb "(in megabytes)") + (:gb "(in gigabytes)")) + (+ max-name 31)) + (loop for (type count logsize physsize) in data + do (if unit + (format stream "~&~a~vt~11d~16,2f~16,2f~11,2f%" + type + (1+ max-name) + count + (/ logsize div) + (/ physsize div) + (* 100.0 (/ physsize total-psize))) + (format stream "~&~a~vt~11d~16d~16d~11,2f%" + type + (1+ max-name) + count + logsize + physsize + (* 100.0 (/ physsize total-psize))))) + (if unit + (format stream "~&~a~vt~11d~16,2f~16,2f~11,2f%" + "Total" + (1+ max-name) + total-count + (/ total-lsize div) + (/ total-psize div) + 100.0d0) + (format stream "~&~a~vt~11d~16d~16d~11,2f%" + "Total" + (1+ max-name) + total-count + total-lsize + total-psize + 100.0d0))) + (values)) + + + +(defun static-cons (car-value cdr-value) + "Allocates a cons cell that doesn't move on garbage collection, + and thus doesn't trigger re-hashing when used as a key in a hash + table. Usage is equivalent to regular CONS." + (loop + (let ((cell (%atomic-pop-static-cons))) + (if cell + (progn + (setf (car cell) car-value) + (setf (cdr cell) cdr-value) + (return cell)) + (progn + (%ensure-static-conses)))))) + +(defun free-static-conses () + (%get-kernel-global free-static-conses)) + +(defun reserved-static-conses () + (%fixnum-ref-natural (%get-kernel-global static-cons-area) target::area.ndnodes)) + + +(defparameter *weak-gc-method-names* + '((:traditional . 0) + (:non-circular . 1))) + + +(defun weak-gc-method () + (or (car (rassoc (%get-kernel-global 'weak-gc-method) + *weak-gc-method-names*)) + :traditional)) + + +(defun (setf weak-gc-method) (name) + (setf (%get-kernel-global 'weak-gc-method) + (or (cdr (assoc name *weak-gc-method-names*)) + 0)) + name) + +(defun %lock-whostate-string (string lock) + (with-standard-io-syntax + (format nil "~a for ~a ~@[~a ~]@ #x~x" + string + (%svref lock target::lock.kind-cell) + (lock-name lock) + (%ptr-to-int (%svref lock target::lock._value-cell))))) + +(defun all-watched-objects () + (let (result) + (with-other-threads-suspended + (%map-areas #'(lambda (x) (push x result)) area-watched)) + result)) + +(defun primitive-watch (thing) + (require-type thing '(or cons (satisfies uvectorp))) + (%watch thing)) + +(defun watch (&optional thing) + (cond ((null thing) + (all-watched-objects)) + ((arrayp thing) + (primitive-watch (array-data-and-offset thing))) + ((hash-table-p thing) + (primitive-watch (nhash.vector thing))) + ((standard-instance-p thing) + (primitive-watch (instance-slots thing))) + (t + (primitive-watch thing)))) + +(defun unwatch (thing) + (with-other-threads-suspended + (%map-areas #'(lambda (x) + (when (eq x thing) + (let ((new (if (uvectorp thing) + (%alloc-misc (uvsize thing) + (typecode thing)) + (cons nil nil)))) + (return-from unwatch (%unwatch thing new))))) + area-watched))) Index: /branches/new-random/lib/nfcomp.lisp =================================================================== --- /branches/new-random/lib/nfcomp.lisp (revision 13309) +++ /branches/new-random/lib/nfcomp.lisp (revision 13309) @@ -0,0 +1,2119 @@ +;;-*-Mode: LISP; Package: CCL -*- +;;; +;;; Copyright (C) 2009 Clozure Associates +;;; Copyright (C) 1994-2001 Digitool, Inc +;;; This file is part of Clozure CL. +;;; +;;; Clozure CL is licensed under the terms of the Lisp Lesser GNU Public +;;; License , known as the LLGPL and distributed with Clozure CL as the +;;; file "LICENSE". The LLGPL consists of a preamble and the LGPL, +;;; which is distributed with Clozure CL as the file "LGPL". Where these +;;; conflict, the preamble takes precedence. +;;; +;;; Clozure CL is referenced in the preamble as the "LIBRARY." +;;; +;;; The LLGPL is also available online at +;;; http://opensource.franz.com/preamble.html + +(in-package "CCL") + +;; :lib:nfcomp.lisp - New fasl compiler. + +(eval-when (:compile-toplevel :load-toplevel :execute) + (require 'level-2)) + +(require 'optimizers) +(require 'hash) + +(eval-when (:compile-toplevel :execute) + +(require 'backquote) +(require 'defstruct-macros) + +(defmacro short-fixnum-p (fixnum) + `(and (fixnump ,fixnum) (< (integer-length ,fixnum) 16))) + +(require "FASLENV" "ccl:xdump;faslenv") + +#+ppc32-target +(require "PPC32-ARCH") +#+ppc64-target +(require "PPC64-ARCH") +#+x8632-target +(require "X8632-ARCH") +#+x8664-target +(require "X8664-ARCH") +) ;eval-when (:compile-toplevel :execute) + + +;File compiler options. Not all of these need to be exported/documented, but +;they should be in the product just in case we need them for patches.... +(defvar *fasl-save-local-symbols* t) +(defvar *fasl-save-doc-strings* t) +(defvar *fasl-save-definitions* nil) + +(defvar *fasl-deferred-warnings* nil) +(defvar *fasl-non-style-warnings-signalled-p* nil) +(defvar *fasl-warnings-signalled-p* nil) + +(defvar *compile-verbose* nil ; Might wind up getting called *compile-FILE-verbose* + "The default for the :VERBOSE argument to COMPILE-FILE.") +(defvar *compile-file-pathname* nil + "The defaulted pathname of the file currently being compiled, or NIL if not + compiling.") ; pathname of src arg to COMPILE-FILE +(defvar *compile-file-truename* nil + "The TRUENAME of the file currently being compiled, or NIL if not + compiling.") ; truename ... +(defvar *fasl-target* (backend-name *host-backend*)) +(defvar *fasl-backend* *host-backend*) +(defvar *fasl-host-big-endian* + (arch::target-big-endian (backend-target-arch *host-backend*))) +(defvar *fasl-target-big-endian* *fasl-host-big-endian*) +(defvar *fcomp-external-format* :default) + +(defvar *fasl-break-on-program-errors* #+ccl-0711 nil #-ccl-0711 :defer + "Controls what happens when the compiler detects PROGRAM-ERROR's during file compilation. + + If T, the compiler signals an error immediately when it detects the program-error. + + If :DEFER, program errors are reported as compiler warnings, and in addition, an error + is signalled at the end of file compilation. This allows all warnings for the file + to be reported, but prevents the creation of a fasl file. + + If NIL, program errors are treated the same as any other error condition detected by + the compiler, i.e. they are reported as compiler warnings and do not cause any + error to be signalled at compile time.") + + +(defvar *compile-print* nil ; Might wind up getting called *compile-FILE-print* + "The default for the :PRINT argument to COMPILE-FILE.") + +;Note: errors need to rebind this to NIL if they do any reading without +; unwinding the stack! +(declaim (special *compiling-file*)) ; defined in l1-init. + +(defvar *fasl-source-file* nil "Name of file currently being read from. +Will differ from *compiling-file* during an INCLUDE") + +(defparameter *fasl-package-qualified-symbols* '(*loading-file-source-file* set-package %define-package) + "These symbols are always fasdumped with full package qualification.") + +(defun setup-target-features (backend features) + (if (eq backend *host-backend*) + features + (let* ((new nil) + (nope (backend-target-specific-features *host-backend*))) + (dolist (f features) + (unless (memq f nope) (pushnew f new))) + (dolist (f (backend-target-specific-features backend) + (progn (pushnew :cross-compiling new) new)) + (pushnew f new))))) + +(defun compile-file-pathname (pathname &rest ignore &key output-file &allow-other-keys) + "Return a pathname describing what file COMPILE-FILE would write to given + these arguments." + (declare (ignore ignore)) + (setq pathname (merge-pathnames pathname)) + (merge-pathnames (if output-file + (merge-pathnames output-file *.fasl-pathname*) + *.fasl-pathname*) + pathname)) + +(defun compile-file (src &key output-file + (verbose *compile-verbose*) + (print *compile-print*) + load + features + (target *fasl-target* target-p) + (save-local-symbols *fasl-save-local-symbols*) + (save-doc-strings *fasl-save-doc-strings*) + (save-definitions *fasl-save-definitions*) + (save-source-locations *save-source-locations*) + (external-format :default) + force + ;; src may be a temp file with a section of the real source, + ;; then this is the real source file name. + compile-file-original-truename + (compile-file-original-buffer-offset 0) + (break-on-program-errors (if compile-file-original-truename + t ;; really SLIME being interactive... + *fasl-break-on-program-errors*))) + "Compile SRC, producing a corresponding fasl file and returning its filename." + (let* ((backend *target-backend*)) + (when (and target-p (not (setq backend (find-backend target)))) + (warn "Unknown :TARGET : ~S. Reverting to ~s ..." target *fasl-target*) + (setq target *fasl-target* backend *target-backend*)) + (multiple-value-bind (output-file truename warnings-p serious-p) + (loop + (restart-case + (return (%compile-file src output-file verbose print features + save-local-symbols save-doc-strings save-definitions + save-source-locations break-on-program-errors + force backend external-format + compile-file-original-truename compile-file-original-buffer-offset)) + (retry-compile-file () + :report (lambda (stream) (format stream "Retry compiling ~s" src)) + nil) + (skip-compile-file () + :report (lambda (stream) + (if load + (format stream "Skip compiling and loading ~s" src) + (format stream "Skip compiling ~s" src))) + (return-from compile-file)))) + (when load (load output-file :verbose (or verbose *load-verbose*))) + (values truename warnings-p serious-p)))) + + +(defvar *fasl-compile-time-env* nil) + +(defun %compile-file (src output-file verbose print features + save-local-symbols save-doc-strings save-definitions + save-source-locations break-on-program-errors + force target-backend external-format + compile-file-original-truename compile-file-original-buffer-offset) + (let* ((orig-src (merge-pathnames src)) + (output-default-type (backend-target-fasl-pathname target-backend)) + (*fasl-non-style-warnings-signalled-p* nil) + (*fasl-warnings-signalled-p* nil)) + (setq src (fcomp-find-file orig-src)) + (let* ((newtype (pathname-type src))) + (when (and newtype (not (pathname-type orig-src))) + (setq orig-src (merge-pathnames orig-src (make-pathname :type newtype :defaults nil))))) + (setq output-file (merge-pathnames + (if output-file ; full-pathname in case output-file is relative + (full-pathname (merge-pathnames output-file output-default-type) :no-error nil) + output-default-type) + orig-src)) + ;; This should not be necessary, but it is. + (setq output-file (namestring output-file)) + (when (physical-pathname-p orig-src) ; only back-translate to things likely to exist at load time + (setq orig-src (back-translate-pathname orig-src '("home" "ccl")))) + (when (and (not force) + (probe-file output-file) + (not (fasl-file-p output-file))) + (cerror "overwrite it anyway" + "Compile destination ~S is not a ~A file!" + output-file (pathname-type + (backend-target-fasl-pathname + *target-backend*)))) + (let* ((*features* (append (if (listp features) features (list features)) (setup-target-features target-backend *features*))) + (*fasl-deferred-warnings* nil) ; !!! WITH-COMPILATION-UNIT ... + (*fasl-save-local-symbols* save-local-symbols) + (*save-source-locations* save-source-locations) + (*fasl-save-doc-strings* save-doc-strings) + (*fasl-save-definitions* save-definitions) + (*fasl-break-on-program-errors* break-on-program-errors) + (*fcomp-warnings-header* nil) + (*compile-file-pathname* orig-src) + (*compile-file-truename* (truename src)) + (*package* *package*) + (*readtable* *readtable*) + (*compile-print* print) + (*compile-verbose* verbose) + (*fasl-target* (backend-name target-backend)) + (*fasl-backend* target-backend) + (*fasl-target-big-endian* (arch::target-big-endian + (backend-target-arch target-backend))) + (*target-ftd* (backend-target-foreign-type-data target-backend)) + (defenv (new-definition-environment)) + (lexenv (new-lexical-environment defenv)) + (*fasl-compile-time-env* (new-lexical-environment (new-definition-environment))) + (*fcomp-external-format* external-format) + (forms nil)) + (let ((current *outstanding-deferred-warnings*) last) + (when (and current + (setq last (deferred-warnings.last-file current)) + (equalp *compile-file-pathname* (cdr last))) + ;; Discard previous deferred warnings when recompiling exactly the same file again, + ;; since most likely this is due to an interactive "retry compilation" request and + ;; we want to avoid duplicate warnings. + (setf (deferred-warnings.last-file current) nil))) + + (let* ((*outstanding-deferred-warnings* (%defer-warnings nil))) + (rplacd (defenv.type defenv) *outstanding-deferred-warnings*) + (setf (defenv.defined defenv) (deferred-warnings.defs *outstanding-deferred-warnings*)) + + (setq forms (fcomp-file src + (or compile-file-original-truename (namestring orig-src)) + compile-file-original-buffer-offset + lexenv)) + + (setf (deferred-warnings.warnings *outstanding-deferred-warnings*) + (append *fasl-deferred-warnings* (deferred-warnings.warnings *outstanding-deferred-warnings*))) + (when *compile-verbose* (fresh-line)) + (multiple-value-bind (any harsh) (report-deferred-warnings *compile-file-pathname*) + (setq *fasl-warnings-signalled-p* (or *fasl-warnings-signalled-p* any) + *fasl-non-style-warnings-signalled-p* (if (eq harsh :very) :very + (or *fasl-non-style-warnings-signalled-p* harsh))))) + (when (and *fasl-break-on-program-errors* (eq *fasl-non-style-warnings-signalled-p* :very)) + (cerror "create the output file despite the errors" + "Serious errors encountered during compilation of ~s" + src)) + (fasl-scan-forms-and-dump-file forms output-file lexenv) + (values output-file + (truename (pathname output-file)) + *fasl-warnings-signalled-p* + (and *fasl-non-style-warnings-signalled-p* t))))) + +(defvar *fcomp-locked-hash-tables*) +(defvar *fcomp-load-forms-environment* nil) + +; This is separated out so that dump-forms-to-file can use it +(defun fasl-scan-forms-and-dump-file (forms output-file &optional env) + (let ((*fcomp-locked-hash-tables* nil) + (*fcomp-load-forms-environment* env)) + (unwind-protect + (multiple-value-bind (hash gnames goffsets) (fasl-scan forms) + (fasl-dump-file gnames goffsets forms hash output-file)) + (fasl-unlock-hash-tables)))) + +#-bccl +(defun nfcomp (src &optional dest &rest keys) + (when (keywordp dest) (setq keys (cons dest keys) dest nil)) + (apply #'compile-file src :output-file dest keys)) + +#-bccl +(%fhave 'fcomp #'nfcomp) + +(defparameter *default-file-compilation-policy* (new-compiler-policy)) + +(defun current-file-compiler-policy () + *default-file-compilation-policy*) + +(defun set-current-file-compiler-policy (&optional new-policy) + (setq *default-file-compilation-policy* + (if new-policy (require-type new-policy 'compiler-policy) (new-compiler-policy)))) + +(defparameter *compile-time-evaluation-policy* + (new-compiler-policy :force-boundp-checks t)) + +(defun %compile-time-eval (form env) + (declare (ignore env)) + (let* ((*target-backend* *host-backend*) + (*loading-toplevel-location* (or (fcomp-source-note form) + *loading-toplevel-location*)) + (lambda `(lambda () ,form))) + (fcomp-note-source-transformation form lambda) + ;; The HANDLER-BIND here is supposed to note WARNINGs that're + ;; signaled during (eval-when (:compile-toplevel) processing; this + ;; in turn is supposed to satisfy a pedantic interpretation of the + ;; spec's requirement that COMPILE-FILE's second and third return + ;; values reflect (all) conditions "detected by the compiler." + ;; (It's kind of sad that CL language design is influenced so + ;; strongly by the views of pedants these days.) + (handler-bind ((warning (lambda (c) + (setq *fasl-warnings-signalled-p* t) + (unless (typep c 'style-warning) + (setq *fasl-non-style-warnings-signalled-p* t)) + (signal c)))) + (funcall (compile-named-function + lambda + :source-notes *fcomp-source-note-map* + :env *fasl-compile-time-env* + :policy *compile-time-evaluation-policy*))))) + + +;;; No methods by default, not even for structures. This really sux. +(defgeneric make-load-form (object &optional environment)) + +;;; Well, no usable methods by default. How this is better than +;;; getting a NO-APPLICABLE-METHOD error frankly escapes me, +(defun no-make-load-form-for (object) + (error "No ~S method is defined for ~s" 'make-load-form object)) + +(defmethod make-load-form ((s standard-object) &optional environment) + (declare (ignore environment)) + (no-make-load-form-for s)) + +(defmethod make-load-form ((s structure-object) &optional environment) + (declare (ignore environment)) + (no-make-load-form-for s)) + +(defmethod make-load-form ((c condition) &optional environment) + (declare (ignore environment)) + (no-make-load-form-for c)) + +(defmethod make-load-form ((c class) &optional environment) + (let* ((name (class-name c)) + (found (if name (find-class name nil environment)))) + (if (eq found c) + `(find-class ',name) + (error "Class ~s does not have a proper name." c)))) + + +;;;; FCOMP-FILE - read & compile file +;;;; Produces a list of (opcode . args) to run on loading, intermixed +;;;; with read packages. + +(defparameter *fasl-eof-forms* nil) + +(defparameter cfasl-load-time-eval-sym (make-symbol "LOAD-TIME-EVAL")) +(%macro-have cfasl-load-time-eval-sym + #'(lambda (call env) (declare (ignore env)) (list 'eval (list 'quote call)))) +;Make it a constant so compiler will barf if try to bind it, e.g. (LET #,foo ...) +(define-constant cfasl-load-time-eval-sym cfasl-load-time-eval-sym) + + +(defparameter *reading-for-cfasl* nil "Used by the reader for #,") + + + +(declaim (special *nx-compile-time-types* +;The following are the global proclaimed values. Since compile-file binds +;them, this means you can't ever globally proclaim these things from within a +;file compile (e.g. from within eval-when compile, or loading a file) - the +;proclamations get lost when compile-file exits. This is sort of intentional +;(or at least the set of things which fall in this category as opposed to +;having a separate compile-time variable is sort of intentional). + *nx-proclaimed-inline* ; inline and notinline + *nx-proclaimed-ignore* ; ignore and unignore + *nx-known-declarations* ; declaration + *nx-speed* ; optimize speed + *nx-space* ; optimize space + *nx-safety* ; optimize safety + *nx-cspeed*)) ; optimize compiler-speed + +(defvar *fcomp-load-time*) +(defvar *fcomp-inside-eval-always* nil) +(defvar *fcomp-eval-always-functions* nil) ; used by the LISP package +(defvar *fcomp-output-list*) +(defvar *fcomp-toplevel-forms*) +(defvar *fcomp-source-note-map* nil) +(defvar *fcomp-loading-toplevel-location*) +(defvar *fcomp-warnings-header*) +(defvar *fcomp-stream-position* nil) +(defvar *fcomp-previous-position* nil) +(defvar *fcomp-indentation*) +(defvar *fcomp-print-handler-plist* nil) +(defvar *fcomp-last-compile-print* + '(INCLUDE (NIL . T) + DEFSTRUCT ("Defstruct" . T) + DEFCONSTANT "Defconstant" + DEFSETF "Defsetf" + DEFTYPE "Deftype" + DEFCLASS "Defclass" + DEFGENERIC "Defgeneric" + DEFMETHOD "Defmethod" + DEFMACRO "Defmacro" + DEFPARAMETER "Defparameter" + DEFVAR "Defvar" + DEFUN "")) + +(setf (getf *fcomp-print-handler-plist* 'defun) "" + (getf *fcomp-print-handler-plist* 'defvar) "Defvar" + (getf *fcomp-print-handler-plist* 'defparameter) "Defparameter" + (getf *fcomp-print-handler-plist* 'defmacro) "Defmacro" + (getf *fcomp-print-handler-plist* 'defmethod) "Defmethod" ; really want more than name (use the function option) + (getf *fcomp-print-handler-plist* 'defgeneric) "Defgeneric" + (getf *fcomp-print-handler-plist* 'defclass) "Defclass" + (getf *fcomp-print-handler-plist* 'deftype) "Deftype" + (getf *fcomp-print-handler-plist* 'defsetf) "Defsetf" + (getf *fcomp-print-handler-plist* 'defconstant) "Defconstant" + (getf *fcomp-print-handler-plist* 'defstruct) '("Defstruct" . t) + (getf *fcomp-print-handler-plist* 'include) '(nil . t)) + + +(defun fcomp-file (filename orig-file orig-offset env) ; orig-file is back-translated + (let* ((*package* *package*) + (*compiling-file* filename) + (*nx-compile-time-types* *nx-compile-time-types*) + (*nx-proclaimed-inline* *nx-proclaimed-inline*) + (*nx-known-declarations* *nx-known-declarations*) + (*nx-proclaimed-ignore* *nx-proclaimed-ignore*) + (*nx-speed* *nx-speed*) + (*nx-space* *nx-space*) + (*nx-debug* *nx-debug*) + (*nx-safety* *nx-safety*) + (*nx-cspeed* *nx-cspeed*) + (*fcomp-load-time* t) + (*fcomp-output-list* nil) + (*fcomp-indentation* 0) + (*fcomp-last-compile-print* (cons nil (cons nil nil)))) + (push (list $fasl-platform (backend-target-platform *fasl-backend*)) *fcomp-output-list*) + (fcomp-read-loop filename orig-file orig-offset env :not-compile-time) + (nreverse *fcomp-output-list*))) + +(defun fcomp-find-file (file &aux path) + (unless (or (setq path (probe-file file)) + (setq path (probe-file (merge-pathnames file *.lisp-pathname*)))) + (error 'file-error :pathname file :error-type "File ~S not found")) + (namestring path)) + +;;; orig-file is back-translated when from fcomp-file +;;; when from fcomp-include it's included filename merged with *compiling-file* +;;; which is not back translated +(defun fcomp-read-loop (filename orig-file orig-offset env processing-mode) + (when *compile-verbose* + (format t "~&;~A ~S..." + (if (eq filename *compiling-file*) "Compiling" " Including") + filename)) + (with-open-file (stream filename + :element-type 'base-char + :external-format *fcomp-external-format*) + (let* ((old-file (and (neq filename *compiling-file*) *fasl-source-file*)) + (*fasl-source-file* (or orig-file filename)) + (*fcomp-toplevel-forms* nil) + (*fasl-eof-forms* nil) + (*loading-file-source-file* orig-file) + (*fcomp-source-note-map* (and (or *save-source-locations* *compile-code-coverage*) + (make-hash-table :test #'eq :shared nil))) + (*loading-toplevel-location* nil) + (*fcomp-loading-toplevel-location* nil) + (eofval (cons nil nil)) + (read-package nil) + form) + + (fcomp-output-form $fasl-src env *loading-file-source-file*) + (let* ((*fcomp-previous-position* nil)) + (loop + (let* ((*fcomp-stream-position* (file-position stream)) + (*nx-warnings* nil)) ;; catch any warnings from :compile-toplevel forms + (when (and *fcomp-stream-position* orig-offset) + (incf *fcomp-stream-position* orig-offset)) + (unless (eq read-package *package*) + (fcomp-compile-toplevel-forms env) + (setq read-package *package*)) + (let ((*reading-for-cfasl* + (and *fcomp-load-time* cfasl-load-time-eval-sym))) + (declare (special *reading-for-cfasl*)) + (let ((pos (file-position stream))) + (handler-bind + ((error #'(lambda (c) ; we should distinguish read errors from others? + (format *error-output* "~&Read error between positions ~a and ~a in ~a." pos (file-position stream) filename) + (signal c)))) + (multiple-value-setq (form *loading-toplevel-location*) + (read-recording-source stream + :eofval eofval + :file-name *loading-file-source-file* + :start-offset orig-offset + :map *fcomp-source-note-map* + :save-source-text (neq *save-source-locations* :no-text)))))) + (when (eq eofval form) + (require-type *loading-toplevel-location* 'null) + (return)) + (fcomp-form form env processing-mode) + (fcomp-signal-or-defer-warnings *nx-warnings* env) + (setq *fcomp-previous-position* *fcomp-stream-position*)))) + (when *compile-code-coverage* + (fcomp-compile-toplevel-forms env) + (let* ((fns (fcomp-code-covered-functions)) + (v (nreverse (coerce fns 'vector)))) + (map nil #'fcomp-digest-code-notes v) + (fcomp-random-toplevel-form `(register-code-covered-functions ',v) env))) + (while (setq form *fasl-eof-forms*) + (setq *fasl-eof-forms* nil) + (fcomp-form-list form env processing-mode)) + (when old-file + (fcomp-output-form $fasl-src env (namestring *compile-file-pathname*))) + (fcomp-compile-toplevel-forms env)))) + +(defun fcomp-code-covered-functions () + (loop for op in *fcomp-output-list* + when (consp op) + nconc (if (eq (car op) $fasl-lfuncall) + ;; Don't collect the toplevel lfun itself, it leads to spurious markings. + ;; Instead, descend one level and collect any referenced fns. + (destructuring-bind (fn) (cdr op) + (lfunloop for imm in fn when (functionp imm) collect imm)) + (loop for arg in (cdr op) when (functionp arg) collect arg)))) + + +(defun fcomp-form (form env processing-mode + &aux print-stuff + (load-time (and processing-mode (neq processing-mode :compile-time))) + (compile-time-too (or (eq processing-mode :compile-time) + (eq processing-mode :compile-time-too)))) + (let* ((*fcomp-indentation* *fcomp-indentation*) + (*compile-print* *compile-print*)) + (when *compile-print* + (cond ((and (consp form) (setq print-stuff (getf *fcomp-print-handler-plist* (car form)))) + (rplaca (rplacd (cdr *fcomp-last-compile-print*) nil) nil) + (rplaca *fcomp-last-compile-print* nil) + (let ((print-recurse nil)) + (when (consp print-stuff) + (setq print-recurse (cdr print-stuff) print-stuff (car print-stuff))) + (cond ((stringp print-stuff) + (if (equal print-stuff "") + (format t "~&~vT~S~%" *fcomp-indentation* (second form)) + (format t "~&~vT~S [~A]~%" *fcomp-indentation* (second form) print-stuff))) + ((not (null print-stuff)) + (format t "~&~vT" *fcomp-indentation*) + (funcall print-stuff form *standard-output*) + (terpri *standard-output*))) + (if print-recurse + (setq *fcomp-indentation* (+ *fcomp-indentation* 4)) + (setq *compile-print* nil)))) + (t (unless (and (eq load-time (car *fcomp-last-compile-print*)) + (eq compile-time-too (cadr *fcomp-last-compile-print*)) + (eq *fcomp-indentation* (cddr *fcomp-last-compile-print*))) + (rplaca *fcomp-last-compile-print* load-time) + (rplaca (rplacd (cdr *fcomp-last-compile-print*) compile-time-too) *fcomp-indentation*) + (format t "~&~vTToplevel Forms...~A~%" + *fcomp-indentation* + (if load-time + (if compile-time-too + " (Compiletime, Loadtime)" + "") + (if compile-time-too + " (Compiletime)" + ""))))))) + (fcomp-form-1 form env processing-mode))) + +(defun fcomp-form-1 (form env processing-mode &aux sym body) + (if (consp form) (setq sym (%car form) body (%cdr form))) + (case sym + (progn (fcomp-form-list body env processing-mode)) + (eval-when (fcomp-eval-when form env processing-mode)) + (compiler-let (fcomp-compiler-let form env processing-mode)) + (locally (fcomp-locally form env processing-mode)) + (macrolet (fcomp-macrolet form env processing-mode)) + (symbol-macrolet (fcomp-symbol-macrolet form env processing-mode)) + ((%include include) (fcomp-include form env processing-mode)) + (t + ;;Need to macroexpand to see if get more progn's/eval-when's and so should + ;;stay at toplevel. But don't expand if either the evaluator or the + ;;compiler might not - better safe than sorry... + ;; Good advice, but the hard part is knowing which is which. + (cond + ((and (non-nil-symbol-p sym) + (macro-function sym env) + (not (compiler-macro-function sym env)) + (not (eq sym '%defvar-init)) ; a macro that we want to special-case + (multiple-value-bind (new win) (fcomp-macroexpand-1 form env) + (if win (setq form new)) + win)) + (fcomp-form form env processing-mode)) + ((and (not *fcomp-inside-eval-always*) + (memq sym *fcomp-eval-always-functions*)) + (let* ((*fcomp-inside-eval-always* t) + (new `(eval-when (:execute :compile-toplevel :load-toplevel) ,form))) + (fcomp-form-1 new env processing-mode))) + (t + (when (or (eq processing-mode :compile-time) (eq processing-mode :compile-time-too)) + (%compile-time-eval form env)) + (when (and processing-mode (neq processing-mode :compile-time)) + (case sym + ((%defconstant) (fcomp-load-%defconstant form env)) + ((%defparameter) (fcomp-load-%defparameter form env)) + ((%defvar %defvar-init) (fcomp-load-defvar form env)) + ((%defun) (fcomp-load-%defun form env)) + ((set-package %define-package) + (fcomp-random-toplevel-form form env) + (fcomp-compile-toplevel-forms env)) + ((%macro) (fcomp-load-%macro form env)) + ;; ((%deftype) (fcomp-load-%deftype form)) + ;; ((define-setf-method) (fcomp-load-define-setf-method form)) + (t (fcomp-random-toplevel-form form env))))))))) + +(defun fcomp-form-list (forms env processing-mode) + (let* ((outer *loading-toplevel-location*)) + (dolist (form forms) + (setq *loading-toplevel-location* (or (fcomp-source-note form) outer)) + (fcomp-form form env processing-mode)) + (setq *loading-toplevel-location* outer))) + +(defun fcomp-compiler-let (form env processing-mode &aux vars varinits (body (%cdr form))) + (fcomp-compile-toplevel-forms env) + (dolist (pair (car body)) + (push (nx-pair-name pair) vars) + (push (%compile-time-eval (nx-pair-initform pair) env) varinits)) + (progv (nreverse vars) (nreverse varinits) + (fcomp-form-list (cdr body) env processing-mode) + (fcomp-compile-toplevel-forms env))) + +(defun fcomp-locally (form env processing-mode &aux (body (%cdr form))) + (fcomp-compile-toplevel-forms env) + (multiple-value-bind (body decls) (parse-body body env) + (let* ((decl-specs (decl-specs-from-declarations decls)) + (env (augment-environment env :declare decl-specs)) + (*fasl-compile-time-env* (augment-environment *fasl-compile-time-env* + :declare decl-specs))) + (fcomp-form-list body env processing-mode) + (fcomp-compile-toplevel-forms env)))) + +(defun fcomp-macrolet (form env processing-mode &aux (body (%cdr form))) + (fcomp-compile-toplevel-forms env) + (flet ((augment-with-macros (e defs) + (augment-environment e + :macro + (mapcar #'(lambda (m) + (destructuring-bind (name arglist &body body) m + (list name (enclose (parse-macro name arglist body env) + e)))) + defs)))) + + (let* ((macros (car body)) + (outer-env (augment-with-macros env macros))) + (multiple-value-bind (body decls) (parse-body (cdr body) outer-env) + (let* ((decl-specs (decl-specs-from-declarations decls)) + (env (augment-environment + outer-env + :declare decl-specs)) + (*fasl-compile-time-env* (augment-environment + (augment-with-macros + *fasl-compile-time-env* + macros) + :declare decl-specs))) + (fcomp-form-list body env processing-mode) + (fcomp-compile-toplevel-forms env)))))) + +(defun fcomp-symbol-macrolet (form env processing-mode &aux (body (%cdr form))) + (fcomp-compile-toplevel-forms env) + (let* ((defs (car body)) + (outer-env (augment-environment env :symbol-macro defs))) + (multiple-value-bind (body decls) (parse-body (cdr body) env) + (let* ((decl-specs (decl-specs-from-declarations decls)) + (env (augment-environment outer-env + :declare decl-specs)) + (*fasl-compile-time-env* (augment-environment *fasl-compile-time-env* + :symbol-macro defs + :declare decl-specs))) + (fcomp-form-list body env processing-mode) + (fcomp-compile-toplevel-forms env))))) + +(defun fcomp-eval-when (form env processing-mode &aux (body (%cdr form)) (eval-times (pop body))) + (let* ((compile-time-too (eq processing-mode :compile-time-too)) + (compile-time-only (eq processing-mode :compile-time)) + (at-compile-time nil) + (at-load-time nil) + (at-eval-time nil)) + (dolist (when eval-times) + (if (or (eq when 'compile) (eq when :compile-toplevel)) + (setq at-compile-time t) + (if (or (eq when 'eval) (eq when :execute)) + (setq at-eval-time t) + (if (or (eq when 'load) (eq when :load-toplevel)) + (setq at-load-time t) + (warn "Unknown EVAL-WHEN time ~s in ~S while compiling ~S." + when eval-times *fasl-source-file*))))) + (fcomp-compile-toplevel-forms env) ; always flush the suckers + (cond (compile-time-only + (if at-eval-time (fcomp-form-list body env :compile-time))) + (at-load-time + (fcomp-form-list body env (if (or at-compile-time (and at-eval-time compile-time-too)) + :compile-time-too + :not-compile-time))) + ((or at-compile-time (and at-eval-time compile-time-too)) + (fcomp-form-list body env :compile-time)))) + (fcomp-compile-toplevel-forms env)) + +(defun fcomp-include (form env processing-mode &aux file) + (fcomp-compile-toplevel-forms env) + (verify-arg-count form 1 1) + (setq file (nx-transform (%cadr form) env)) + (unless (constantp file) (report-bad-arg file '(or string pathname))) + (let ((actual (merge-pathnames (eval-constant file) + (directory-namestring *compiling-file*)))) + (when *compile-print* (format t "~&~vTIncluding file ~A~%" *fcomp-indentation* actual)) + (let ((*fcomp-indentation* (+ 4 *fcomp-indentation*)) + (*package* *package*)) + (fcomp-read-loop (fcomp-find-file actual) actual 0 env processing-mode) + (fcomp-output-form $fasl-src env *loading-file-source-file*)) + (when *compile-print* (format t "~&~vTFinished included file ~A~%" *fcomp-indentation* actual)))) + +(defun define-compile-time-constant (symbol initform env) + (note-variable-info symbol t env) + (let ((compile-time-defenv (definition-environment *fasl-compile-time-env*)) + (definition-env (definition-environment env))) + (when (or compile-time-defenv definition-env) + (multiple-value-bind (value error) + (ignore-errors (values (%compile-time-eval initform env) nil)) + (when error + (warn "Compile-time evaluation of DEFCONSTANT initial value form for ~S while ~ + compiling ~S signalled the error: ~&~A" symbol *fasl-source-file* error)) + (let ((cell (cons symbol (if error (%unbound-marker-8) value)))) + (when definition-env + (push cell (defenv.constants definition-env))) + (when compile-time-defenv + (push cell (defenv.constants compile-time-defenv)))))) + symbol)) + +(defun fcomp-load-%defconstant (form env) + (destructuring-bind (sym valform &optional doc) (cdr form) + (unless *fasl-save-doc-strings* + (setq doc nil)) + (if (quoted-form-p sym) + (setq sym (%cadr sym))) + (if (and (typep sym 'symbol) (or (quoted-form-p valform) (self-evaluating-p valform))) + (fcomp-output-form $fasl-defconstant env sym (eval-constant valform) (eval-constant doc)) + (fcomp-random-toplevel-form form env)))) + +(defun fcomp-load-%defparameter (form env) + (destructuring-bind (sym valform &optional doc) (cdr form) + (unless *fasl-save-doc-strings* + (setq doc nil)) + (if (quoted-form-p sym) + (setq sym (%cadr sym))) + (let* ((sym-p (typep sym 'symbol)) + (fn (and sym-p (fcomp-function-arg valform env)))) + (if (and sym-p (or fn (constantp valform))) + (fcomp-output-form $fasl-defparameter env sym (or fn (eval-constant valform)) (eval-constant doc)) + (fcomp-random-toplevel-form form env))))) + +; Both the simple %DEFVAR and the initial-value case (%DEFVAR-INIT) come here. +; Only try to dump this as a special fasl operator if the initform is missing +; or is "harmless" to evaluate whether needed or not (constant or function.) +; Hairier initforms could be handled by another fasl operator that takes a thunk +; and conditionally calls it. +(defun fcomp-load-defvar (form env) + (destructuring-bind (sym &optional (valform nil val-p) doc) (cdr form) + (unless *fasl-save-doc-strings* + (setq doc nil)) + (if (quoted-form-p sym) ; %defvar quotes its arg, %defvar-init doesn't. + (setq sym (%cadr sym))) + (let* ((sym-p (typep sym 'symbol))) + (if (and sym-p (not val-p)) + (fcomp-output-form $fasl-defvar env sym) + (let* ((fn (if sym-p (fcomp-function-arg valform env)))) + (if (and sym-p (or fn (constantp valform))) + (fcomp-output-form $fasl-defvar-init env sym (or fn (eval-constant valform)) (eval-constant doc)) + (fcomp-random-toplevel-form form env))))))) + +(defun define-compile-time-macro (name lambda-expression env) + (let ((compile-time-defenv (definition-environment *fasl-compile-time-env*)) + (definition-env (definition-environment env))) + (when (or definition-env compile-time-defenv) + (let ((cell (list* name + 'macro + (compile-named-function lambda-expression :name name :env env)))) + (when compile-time-defenv + (push cell (defenv.functions compile-time-defenv))) + (when definition-env + (push cell (defenv.functions definition-env)))) + (record-function-info name (%cons-def-info 'defmacro) env)) + name)) + +(defun define-compile-time-symbol-macro (name expansion env) + (let ((compile-time-defenv (definition-environment *fasl-compile-time-env*)) + (definition-env (definition-environment env))) + (let* ((info (variable-information name env))) + (when (or (eq info :special) + (eq info :constant)) + (signal-program-error "Can't define ~s as a symbol-macro; already defined as a ~a." name (string-downcase info)))) + (when (or definition-env compile-time-defenv) + (let ((cell (cons name expansion))) + (when compile-time-defenv + (push cell (defenv.symbol-macros compile-time-defenv))) + (when definition-env + (push cell (defenv.symbol-macros definition-env))))) + name)) + + +(defun fcomp-proclaim-type (type syms env) + (if (every #'symbolp syms) + (progn + (specifier-type-if-known type env :whine t) + (dolist (sym syms) + (push (cons sym type) *nx-compile-time-types*))) + (nx-bad-decls `(,type ,@syms)))) + +(defun compile-time-proclamation (specs env &aux sym (defenv (definition-environment env))) + (when defenv + (dolist (spec specs) + (setq sym (pop spec)) + (case sym + (type + (fcomp-proclaim-type (car spec) (cdr spec) env)) + (special + (if (every #'symbolp spec) + (dolist (sym spec) + (push (cons sym nil) (defenv.specials defenv))) + (nx-bad-decls `(,sym ,@spec)))) + (notspecial + (if (every #'symbolp spec) + (let ((specials (defenv.specials defenv))) + (dolist (sym spec (setf (defenv.specials defenv) specials)) + (let ((pair (assq sym specials))) + (when pair (setq specials (nremove pair specials)))))) + (nx-bad-decls `(,sym ,@spec)))) + (optimize + (handler-case (%proclaim-optimize spec) + (program-error () (nx-bad-decls `(,sym ,@spec))))) + (inline + (if (every (lambda (v) (or (symbolp v) (setf-function-name-p v))) spec) + (dolist (sym spec) + (push (cons (maybe-setf-function-name sym) (cons 'inline 'inline)) (lexenv.fdecls defenv))) + (nx-bad-decls `(,sym ,@spec)))) + (notinline + (if (every (lambda (v) (or (symbolp v) (setf-function-name-p v))) spec) + (dolist (sym spec) + (unless (compiler-special-form-p sym) + (push (cons (maybe-setf-function-name sym) (cons 'inline 'notinline)) (lexenv.fdecls defenv)))) + (nx-bad-decls `(,sym ,@spec)))) + (declaration + (if (every #'symbolp spec) + (dolist (sym spec) + (pushnew sym *nx-known-declarations*)) + (nx-bad-decls `(,sym ,@spec)))) + (ignore + (if (every #'symbolp spec) + (dolist (sym spec) + (push (cons sym t) *nx-proclaimed-ignore*)) + (nx-bad-decls `(,sym ,@spec)))) + (unignore + (if (every #'symbolp spec) + (dolist (sym spec) + (push (cons sym nil) *nx-proclaimed-ignore*)) + (nx-bad-decls `(,sym ,@spec)))) + (ftype + (let ((ftype (car spec)) + (fnames (cdr spec))) + (if (every (lambda (v) (or (symbolp v) (setf-function-name-p v))) fnames) + (when (specifier-type-if-known ftype env :whine t) + ;; ----- this part may be redundant, now that the lexenv.fdecls part is being done + (if (and (consp ftype) + (consp fnames) + (eq (%car ftype) 'function)) + (dolist (fname fnames) + (note-function-info fname nil env))) + (dolist (fname fnames) + (push (list* (maybe-setf-function-name fname) sym ftype) (lexenv.fdecls defenv)))) + (nx-bad-decls `(ftype ,@spec))))) + (otherwise + (unless (memq sym *nx-known-declarations*) + ;; Any type name is now (ANSI CL) a valid declaration. + (if (specifier-type-if-known sym env) + (fcomp-proclaim-type sym spec env) + (nx-bad-decls `(,sym ,@spec))))))))) + +(defun fcomp-load-%defun (form env) + (destructuring-bind (fn &optional doc) (cdr form) + (unless *fasl-save-doc-strings* + (if (consp doc) + (if (and (eq (car doc) 'quote) (consp (cadr doc))) + (setf (car (cadr doc)) nil)) + (setq doc nil))) + (when (and (consp fn) (eq (%car fn) 'nfunction)) + (note-function-info (cadr fn) (caddr fn) env)) + (if (and (constantp doc) + (setq fn (fcomp-function-arg fn env))) + (progn + (setq doc (eval-constant doc)) + (fcomp-output-form $fasl-defun env fn doc)) + (fcomp-random-toplevel-form form env)))) + +(defun fcomp-load-%macro (form env &aux fn doc) + (verify-arg-count form 1 2) + (if (and (constantp (setq doc (caddr form))) + (setq fn (fcomp-function-arg (cadr form) env))) + (progn + (setq doc (eval-constant doc)) + (fcomp-output-form $fasl-macro env fn doc)) + (fcomp-random-toplevel-form form env))) + +(defun define-compile-time-structure (sd refnames predicate env) + (let ((defenv (definition-environment env))) + (when defenv + (when (non-nil-symbolp (sd-name sd)) + (note-type-info (sd-name sd) 'class env) + (push (make-instance 'compile-time-class :name (sd-name sd)) + (defenv.classes defenv))) + (setf (defenv.structures defenv) (alist-adjoin (sd-name sd) sd (defenv.structures defenv))) + (let* ((structrefs (defenv.structrefs defenv))) + (when (and (null (sd-type sd)) + predicate) + (setq structrefs (alist-adjoin predicate (sd-name sd) structrefs))) + (dolist (slot (sd-slots sd)) + (unless (fixnump (ssd-name slot)) + (setq structrefs + (alist-adjoin (if refnames (pop refnames) (ssd-name slot)) + (ssd-type-and-refinfo slot) + structrefs)))) + (setf (defenv.structrefs defenv) structrefs))))) + +(defun fcomp-source-note (form &aux (notes *fcomp-source-note-map*)) + (and notes (gethash form notes))) + +(defun fcomp-note-source-transformation (original new) + (let* ((*nx-source-note-map* *fcomp-source-note-map*)) + (nx-note-source-transformation original new))) + +(defun fcomp-macroexpand-1 (form env) + (handler-bind ((warning (lambda (c) + (nx1-whine :program-error c) + (muffle-warning c))) + (program-error (lambda (c) + (if *fasl-break-on-program-errors* + (cerror "continue compilation ignoring this form" c) + (progn + (when (typep c 'compile-time-program-error) + (setq c (make-condition 'simple-program-error + :format-control (simple-condition-format-control c) + :format-arguments (simple-condition-format-arguments c)))) + (nx1-whine :program-error c))) + (return-from fcomp-macroexpand-1 (values nil t))))) + (let* ((*nx-source-note-map* *fcomp-source-note-map*)) + (multiple-value-bind (new win) + (macroexpand-1 form env) + (when win + (nx-note-source-transformation form new)) + (values new win))))) + +(defun fcomp-transform (form env) + (let* ((*nx-source-note-map* *fcomp-source-note-map*)) + (nx-transform form env))) + + +(defun fcomp-random-toplevel-form (form env) + (unless (constantp form) + (unless (or (atom form) + (compiler-special-form-p (%car form))) + ;;Pre-compile any lfun args. This is an efficiency hack, since compiler + ;;reentering itself for inner lambdas tends to be more expensive than + ;;top-level compiles. + ;;This assumes the form has been macroexpanded, or at least none of the + ;;non-evaluated macro arguments could look like functions. + (let ((new-form (make-list (length form)))) + (declare (dynamic-extent new-form)) + (loop for arg in (%cdr form) for newptr on (%cdr new-form) + do (setf (%car newptr) + (multiple-value-bind (new win) (fcomp-transform arg env) + (let ((lfun (fcomp-function-arg new env))) + (when lfun + (setq new `',lfun win t) + (fcomp-note-source-transformation arg new))) + (if win new arg)))) + (unless (every #'eq (%cdr form) (%cdr new-form)) + (setf (%car new-form) (%car form)) + (fcomp-note-source-transformation form (setq form (copy-list new-form)))))) + ;; At some point we will dump the toplevel forms, make sure that when that happens, + ;;; the loading location for this form is stored in *fcomp-loading-toplevel-location*, + ;; because *loading-toplevel-location* will be long gone by then. + (fcomp-ensure-source env) + (push form *fcomp-toplevel-forms*))) + +(defun fcomp-function-arg (expr env) + (when (consp expr) + (multiple-value-bind (lambda-expr name win) + (cond ((and (eq (%car expr) 'nfunction) + (lambda-expression-p (cadr (%cdr expr)))) + (values (%caddr expr) (%cadr expr) t)) + ((and (eq (%car expr) 'function) + (lambda-expression-p (car (%cdr expr)))) + (values (%cadr expr) nil t))) + (when win + (fcomp-named-function lambda-expr name env + (or (fcomp-source-note expr) + (fcomp-source-note lambda-expr) + *loading-toplevel-location*)))))) + +(defun fcomp-compile-toplevel-forms (env) + (when *fcomp-toplevel-forms* + (let* ((forms (nreverse *fcomp-toplevel-forms*)) + (*fcomp-stream-position* *fcomp-previous-position*) + (*loading-toplevel-location* *fcomp-loading-toplevel-location*) + (lambda (if T ;; (null (cdr forms)) + `(lambda () ,@forms) + `(lambda () + (macrolet ((load-time-value (value) + (declare (ignore value)) + (compiler-function-overflow))) + ,@forms))))) + (setq *fcomp-toplevel-forms* nil) + ;(format t "~& Random toplevel form: ~s" lambda) + (handler-case (fcomp-output-form + $fasl-lfuncall + env + (fcomp-named-function lambda nil env *loading-toplevel-location*)) + (compiler-function-overflow () + (if (null (cdr forms)) + (error "Form ~s cannot be compiled - size exceeds compiler limitation" + (%car forms)) + ; else compile each half : + (progn + (dotimes (i (floor (length forms) 2)) + (declare (fixnum i)) + (push (pop forms) *fcomp-toplevel-forms*)) + (fcomp-compile-toplevel-forms env) + (setq *fcomp-toplevel-forms* (nreverse forms)) + (fcomp-compile-toplevel-forms env)))))))) + +(defun fcomp-ensure-source (env) + ;; if source location saving is off, both values are NIL, so this will do nothing, + ;; don't need to check explicitly. + (unless (eq *fcomp-loading-toplevel-location* *loading-toplevel-location*) + (setq *fcomp-loading-toplevel-location* *loading-toplevel-location*) + (fcomp-output-form $fasl-toplevel-location env *loading-toplevel-location*))) + +(defun fcomp-output-form (opcode env &rest args) + (fcomp-ensure-source env) + (when *fcomp-toplevel-forms* (fcomp-compile-toplevel-forms env)) + (push (cons opcode args) *fcomp-output-list*)) + + +;;; Compile a lambda expression for the sole purpose of putting it in a fasl +;;; file. The result will not be funcalled. This really shouldn't bother +;;; making an lfun, but it's simpler this way... +(defun fcomp-named-function (def name env &optional source-note) + (let* ((env (new-lexical-environment env)) + (*nx-break-on-program-errors* (not (memq *fasl-break-on-program-errors* '(nil :defer))))) + (multiple-value-bind (lfun warnings) + (compile-named-function def + :name name + :env env + :function-note source-note + :keep-lambda *fasl-save-definitions* + :keep-symbols *fasl-save-local-symbols* + :policy *default-file-compilation-policy* + :source-notes *fcomp-source-note-map* + :load-time-eval-token cfasl-load-time-eval-sym + :target *fasl-target*) + (fcomp-signal-or-defer-warnings warnings env) + lfun))) + + +;; Convert parent-notes to immediate indices. The reason this is necessary is to avoid hitting +;; the fasdumper's 64K limit on multiply-referenced objects. This removes the reference +;; from parent slots, making notes less likely to be multiply-referenced. +(defun fcomp-digest-code-notes (lfun &optional refs) + (unless (memq lfun refs) + (let* ((lfv (function-to-function-vector lfun)) + (start #+ppc-target 0 #+x86-target (%function-code-words lfun)) + (refs (cons lfun refs))) + (declare (dynamic-extent refs)) + (loop for i from start below (uvsize lfv) as imm = (uvref lfv i) + do (typecase imm + (code-note + (let* ((parent (code-note-parent-note imm)) + (pos (when (code-note-p parent) + (loop for j from start below i + do (when (eq parent (uvref lfv j)) (return j)))))) + (when pos + (setf (code-note-parent-note imm) pos)))) + (function + (fcomp-digest-code-notes imm refs))))))) + +; For now, defer only UNDEFINED-REFERENCEs, signal all others via WARN. +; Well, maybe not WARN, exactly. +(defun fcomp-signal-or-defer-warnings (warnings env) + (let ((init (null *fcomp-warnings-header*)) + (some *fasl-warnings-signalled-p*) + (harsh *fasl-non-style-warnings-signalled-p*)) + (dolist (w warnings) + (unless (compiler-warning-source-note w) + (setf (compiler-warning-source-note w) + (make-source-note :source nil + :filename *fasl-source-file* + :start-pos *fcomp-stream-position* + :end-pos *fcomp-stream-position*))) + (if (and (typep w 'undefined-reference) + (eq w (setq w (macro-too-late-p w env)))) + (push w *fasl-deferred-warnings*) + (progn + (multiple-value-setq (harsh some *fcomp-warnings-header*) + (signal-compiler-warning w init *fcomp-warnings-header* harsh some)) + (setq init nil)))) + (setq *fasl-warnings-signalled-p* some + *fasl-non-style-warnings-signalled-p* harsh))) + +; If W is an UNDEFINED-FUNCTION-REFERENCE which refers to a macro (either at compile-time in ENV +; or globally), cons up a MACRO-USED-BEFORE-DEFINITION warning and return it; else return W. + +(defun macro-too-late-p (w env) + (let* ((args (compiler-warning-args w)) + (name (car args))) + (if (typep w 'undefined-function-reference) + (if (or (macro-function name) + (let* ((defenv (definition-environment env)) + (info (if defenv (assq name (defenv.functions defenv))))) + (and (consp (cdr info)) + (eq 'macro (cadr info))))) + (make-instance 'macro-used-before-definition + :source-note (compiler-warning-source-note w) + :function-name (compiler-warning-function-name w) + :warning-type ':macro-used-before-definition + :args args) + w) + w))) + + + +;;;; fasl-scan - dumping reference counting +;;;; +;;;; +;These should be constants, but it's too much trouble when need to change 'em. +(defparameter FASL-FILE-ID #xFF00) ;Overall file format, shouldn't change much +(defparameter FASL-VERSION #xFF5e) ;Fasl block format. ($fasl-vers) + +(defvar *fasdump-hash*) +(defvar *fasdump-read-package*) +(defvar *fasdump-global-offsets*) +(defvar *make-load-form-hash*) + +;;;Return a hash table containing subexp's which are referenced more than once. +(defun fasl-scan (forms) + (let* ((*fasdump-hash* (make-hash-table :size (length forms) ; Crude estimate + :rehash-threshold 0.9 + :test 'eq + :shared nil)) + (*make-load-form-hash* (make-hash-table :test 'eq :shared nil)) + (*fasdump-read-package* nil) + (*fasdump-global-offsets* nil) + (gsymbols nil)) + (dolist (op forms) + (if (packagep op) ; old magic treatment of *package* + (setq *fasdump-read-package* op) + (dolist (arg (cdr op)) (fasl-scan-form arg)))) + + #-bccl (when (eq *compile-verbose* :debug) + (format t "~&~S forms, ~S entries -> " + (length forms) + (hash-table-count *fasdump-hash*))) + (maphash #'(lambda (key val) + (when (%izerop val) (remhash key *fasdump-hash*))) + *fasdump-hash*) + #-bccl (when (eq *compile-verbose* :debug) + (format t "~S." (hash-table-count *fasdump-hash*))) + (values *fasdump-hash* + gsymbols + *fasdump-global-offsets*))) + +;;; During scanning, *fasdump-hash* values are one of the following: +;;; nil - form hasn't been referenced yet. +;;; 0 - form has been referenced exactly once +;;; T - form has been referenced more than once +;;; (load-form scanning-p referenced-p initform) +;;; form should be replaced by load-form +;;; scanning-p is true while we're scanning load-form +;;; referenced-p is nil if unreferenced, +;;; T if referenced but not dumped yet, +;;; 0 if dumped already (fasl-dump-form uses this) +;;; initform is a compiled version of the user's initform +(defun fasl-scan-form (form) + (when form + (let ((info (gethash form *fasdump-hash*))) + (cond ((null info) + (fasl-scan-dispatch form)) + ((eql info 0) + (puthash form *fasdump-hash* t)) + ((listp info) ; a make-load-form form + (when (cadr info) + (error "Circularity in ~S for ~S" 'make-load-form form)) + (let ((referenced-cell (cddr info))) + (setf (car referenced-cell) t) ; referenced-p + (setf (gethash (car info) *fasdump-hash*) t))))))) + + + + +(defun fasl-scan-dispatch (exp) + (when exp + (let ((type-code (typecode exp))) + (declare (fixnum type-code)) + (case type-code + (#.target::tag-fixnum + (fasl-scan-fixnum exp)) + (#.target::fulltag-cons (fasl-scan-list exp)) + #+ppc32-target + (#.ppc32::tag-imm) + #+ppc64-target + ((#.ppc64::fulltag-imm-0 + #.ppc64::fulltag-imm-1 + #.ppc64::fulltag-imm-2 + #.ppc64::fulltag-imm-3)) + #+x8632-target + (#.x8632::tag-imm) + #+x8664-target + ((#.x8664::fulltag-imm-0 + #.x8664::fulltag-imm-1)) + (t + (if + #+ppc32-target + (= (the fixnum (logand type-code ppc32::full-tag-mask)) ppc32::fulltag-immheader) + #+ppc64-target + (= (the fixnum (logand type-code ppc64::lowtagmask)) ppc64::lowtag-immheader) + #+x8632-target + (= (the fixnum (logand type-code x8632::fulltagmask)) x8632::fulltag-immheader) + #+x8664-target + (and (= (the fixnum (lisptag exp)) x8664::tag-misc) + (logbitp (the (unsigned-byte 16) (logand type-code x8664::fulltagmask)) + (logior (ash 1 x8664::fulltag-immheader-0) + (ash 1 x8664::fulltag-immheader-1) + (ash 1 x8664::fulltag-immheader-2)))) + (case type-code + (#.target::subtag-dead-macptr (fasl-unknown exp)) + (#.target::subtag-macptr + ;; Treat untyped pointers to the high/low 64K of the address + ;; space as constants. Refuse to dump other pointers. + (unless (and (zerop (%macptr-type exp)) + (<= (%macptr-domain exp) 1)) + (error "Can't dump typed pointer ~s" exp)) + (let* ((addr (%ptr-to-int exp))) + (unless (or (< addr #x10000) + (>= addr (- (ash 1 target::nbits-in-word) + #x10000))) + (error "Can't dump pointer ~s : address is not in the low or high 64K of the address space." exp)))) + (t (fasl-scan-ref exp))) + (case type-code + ((#.target::subtag-pool #.target::subtag-weak #.target::subtag-lock) (fasl-unknown exp)) + (#+ppc-target #.target::subtag-symbol + #+x8632-target #.target::subtag-symbol + #+x8664-target #.target::tag-symbol (fasl-scan-symbol exp)) + ((#.target::subtag-instance #.target::subtag-struct) + (fasl-scan-user-form exp)) + (#.target::subtag-package (fasl-scan-ref exp)) + (#.target::subtag-istruct + (if (memq (istruct-type-name exp) *istruct-make-load-form-types*) + (progn + (if (hash-table-p exp) + (fasl-lock-hash-table exp)) + (fasl-scan-user-form exp)) + (fasl-scan-gvector exp))) + #+x8632-target + (#.target::subtag-function (fasl-scan-clfun exp)) + #+x8664-target + (#.target::tag-function (fasl-scan-clfun exp)) + (t (fasl-scan-gvector exp))))))))) + + +(defun fasl-scan-ref (form) + (puthash form *fasdump-hash* 0)) + +(defun fasl-scan-fixnum (fixnum) + (unless (short-fixnum-p fixnum) (fasl-scan-ref fixnum))) + +(defparameter *istruct-make-load-form-types* + '(lexical-environment shared-library-descriptor shared-library-entry-point + external-entry-point foreign-variable + ctype unknown-ctype class-ctype foreign-ctype union-ctype member-ctype + array-ctype numeric-ctype hairy-ctype named-ctype constant-ctype args-ctype + hash-table package-ref type-cell class-cell slot-id)) + + + + +(defun fasl-scan-gvector (vec) + (fasl-scan-ref vec) + (dotimes (i (uvsize vec)) + (declare (fixnum i)) + (fasl-scan-form (%svref vec i)))) + +#+x86-target +(defun fasl-scan-clfun (f) + (let* ((fv (function-to-function-vector f)) + (size (uvsize fv)) + (ncode-words (%function-code-words f))) + (fasl-scan-ref f) + (do* ((k ncode-words (1+ k))) + ((= k size)) + (fasl-scan-form (uvref fv k))))) + +(defun funcall-lfun-p (form) + (and (listp form) + (eq (%car form) 'funcall) + (listp (%cdr form)) + (or (functionp (%cadr form)) + (eql (typecode (%cadr form)) target::subtag-xfunction)) + (null (%cddr form)))) + +;;; We currently represent istruct-cells as conses. That's not +;;; incredibly efficient (among other things, we have to do this +;;; check when scanning/dumping any list), but it's probably not +;;; worth burning a tag on them. There are currently about 50 +;;; entries on the *istruct-cells* list. +(defun istruct-cell-p (x) + (and (consp x) + (typep (%car x) 'symbol) + (atom (%cdr x)) + (not (null (memq x *istruct-cells*))))) + +(defun fasl-scan-list (list) + (cond ((eq (%car list) cfasl-load-time-eval-sym) + (let ((form (car (%cdr list)))) + (fasl-scan-form (if (funcall-lfun-p form) + (%cadr form) + form)))) + ((istruct-cell-p list) + (fasl-scan-form (%car list))) + (t (when list + (fasl-scan-ref list) + (fasl-scan-form (%car list)) + (fasl-scan-form (%cdr list)))))) + +(defun fasl-scan-user-form (form) + (when (or (source-note-p form) + (code-note-p form)) + (return-from fasl-scan-user-form (fasl-scan-gvector form))) + (multiple-value-bind (load-form init-form) (make-load-form form *fcomp-load-forms-environment*) + (labels ((simple-load-form (form) + (or (atom form) + (let ((function (car form))) + (or (eq function 'quote) + (and (symbolp function) + ;; using fboundp instead of symbol-function + ;; see comments in symbol-function + (or (functionp (fboundp function)) + (eq function 'progn)) + ;; (every #'simple-load-form (cdr form)) + (dolist (arg (cdr form) t) + (unless (simple-load-form arg) + (return nil)))))))) + (load-time-eval-form (load-form form type) + (cond ((quoted-form-p load-form) + (%cadr load-form)) + ((self-evaluating-p load-form) + load-form) + ((simple-load-form load-form) + `(,cfasl-load-time-eval-sym ,load-form)) + (t (multiple-value-bind (lfun warnings) + (or + (gethash load-form *make-load-form-hash*) + (fcomp-named-function `(lambda () ,load-form) nil nil)) + (when warnings + (cerror "Ignore the warnings" + "Compiling the ~s ~a form for~%~s~%produced warnings." + 'make-load-form type form)) + (setf (gethash load-form *make-load-form-hash*) lfun) + `(,cfasl-load-time-eval-sym (funcall ,lfun))))))) + (declare (dynamic-extent #'simple-load-form #'load-time-eval-form)) + (let* ((compiled-initform + (and init-form (load-time-eval-form init-form form "initialization"))) + (info (list (load-time-eval-form load-form form "creation") + T ; scanning-p + nil ; referenced-p + compiled-initform ;initform-info + ))) + (puthash form *fasdump-hash* info) + (fasl-scan-form (%car info)) + (setf (cadr info) nil) ; no longer scanning load-form + (when init-form + (fasl-scan-form compiled-initform)))))) + +(defun fasl-scan-symbol (form) + (fasl-scan-ref form) + (fasl-scan-form (symbol-package form))) + + + +;;;; Pass 3 - dumping +;;;; +;;;; +(defvar *fasdump-epush*) +(defvar *fasdump-stream*) +(defvar *fasdump-eref*) + +(defun fasl-dump-file (gnames goffsets forms hash filename) + (let ((opened? nil) + (finished? nil)) + (unwind-protect + (with-open-file (*fasdump-stream* filename :direction :output + :element-type '(unsigned-byte 8) + :if-exists :supersede + :if-does-not-exist :create) + (setq opened? t) + (fasl-set-filepos 0) + (fasl-out-word 0) ;Will become the ID word + (fasl-out-word 1) ;One block in the file + (fasl-out-long 12) ;Block starts at file pos 12 + (fasl-out-long 0) ;Length will go here + (fasl-dump-block gnames goffsets forms hash) ;Write the block + (let ((pos (fasl-filepos))) + (fasl-set-filepos 8) ;Back to length longword + (fasl-out-long (- pos 12))) ;Write length + (fasl-set-filepos 0) ;Seem to have won, make us legal + (fasl-out-word FASL-FILE-ID) + (setq finished? t) + filename) + (when (and opened? (not finished?)) + (delete-file filename))))) + +(defun fasl-dump-block (gnames goffsets forms hash) + (let ((etab-size (hash-table-count hash))) + (when (> etab-size 65535) + (error "Too many multiply-referenced objects in fasl file.~%Limit is ~d. Were ~d." 65535 etab-size)) + (fasl-out-word FASL-VERSION) ; Word 0 + (fasl-out-long 0) + (fasl-out-byte $fasl-vetab-alloc) + (fasl-out-count etab-size) + (fasl-dump gnames goffsets forms hash) + (fasl-out-byte $fasl-end))) + +(defun fasl-dump (gnames goffsets forms hash) + (let* ((*fasdump-hash* hash) + (*fasdump-read-package* nil) + (*fasdump-epush* nil) + (*fasdump-eref* -1) + (*fasdump-global-offsets* goffsets)) + (when gnames + (fasl-out-byte $fasl-globals) + (fasl-dump-form gnames)) + (dolist (op forms) + (if (packagep op) + (setq *fasdump-read-package* op) + (progn + (fasl-out-byte (car op)) + (dolist (arg (cdr op)) (fasl-dump-form arg))))))) + +;;;During dumping, *fasdump-hash* values are one of the following: +;;; nil - form has no load form, is referenced at most once. +;;; fixnum - form has already been dumped, fixnum is the etab index. +;;; T - form hasn't been dumped yet, is referenced more than once. +;;; (load-form . nil) - form should be replaced by load-form. +(defun fasl-dump-form (form) + (let ((info (gethash form *fasdump-hash*))) + (cond ((fixnump info) + (fasl-out-byte $fasl-veref) + (fasl-out-count info)) + ((consp info) + (fasl-dump-user-form form info)) + (t + (setq *fasdump-epush* info) + (fasl-dump-dispatch form))))) + +(defun fasl-dump-user-form (form info) + (let* ((load-form (car info)) + (referenced-p (caddr info)) + (initform (cadddr info))) + (when referenced-p + (unless (gethash load-form *fasdump-hash*) + (error "~s was not in ~s. This shouldn't happen." 'load-form '*fasdump-hash*))) + (when initform + (fasl-out-byte $fasl-prog1)) ; ignore the initform + (fasl-dump-form load-form) + (when referenced-p + (setf (gethash form *fasdump-hash*) (gethash load-form *fasdump-hash*))) + (when initform + (fasl-dump-form initform)))) + +(defun fasl-out-opcode (opcode form) + (if *fasdump-epush* + (progn + (setq *fasdump-epush* nil) + (fasl-out-byte (fasl-epush-op opcode)) + (fasl-dump-epush form)) + (fasl-out-byte opcode))) + +(defun fasl-dump-epush (form) + #-bccl (when (fixnump (gethash form *fasdump-hash*)) + (error "Bug! Duplicate epush for ~S" form)) + (puthash form *fasdump-hash* (setq *fasdump-eref* (1+ *fasdump-eref*)))) + + +(defun fasl-dump-dispatch (exp) + (etypecase exp + ((signed-byte 16) (fasl-dump-s16 exp)) + ((signed-byte 32) (fasl-dump-s32 exp)) + ((signed-byte 64) (fasl-dump-s64 exp)) + (bignum (fasl-dump-32-bit-ivector exp $fasl-bignum32)) + (character (fasl-dump-char exp)) + (list (fasl-dump-list exp)) + (immediate (fasl-dump-t_imm exp)) + (double-float (fasl-dump-dfloat exp)) + (single-float (fasl-dump-sfloat exp)) + (simple-string + (let* ((nextra (utf-8-extra-bytes exp))) + (cond ((= 0 nextra) + (fasl-out-opcode $fasl-nvstr exp) + (fasl-out-nvstring exp)) + (t (fasl-out-opcode $fasl-vstr exp) + (fasl-out-vstring exp nextra))))) + (simple-bit-vector (fasl-dump-bit-vector exp)) + ((simple-array (unsigned-byte 8) (*)) + (fasl-dump-8-bit-ivector exp $fasl-u8-vector)) + ((simple-array (signed-byte 8) (*)) + (fasl-dump-8-bit-ivector exp $fasl-s8-vector)) + ((simple-array (unsigned-byte 16) (*)) + (fasl-dump-16-bit-ivector exp $fasl-u16-vector)) + ((simple-array (signed-byte 16) (*)) + (fasl-dump-16-bit-ivector exp $fasl-s16-vector)) + ((simple-array (unsigned-byte 32) (*)) + (fasl-dump-32-bit-ivector exp $fasl-u32-vector)) + ((simple-array (signed-byte 32) (*)) + (fasl-dump-32-bit-ivector exp $fasl-s32-vector)) + ((simple-array single-float (*)) + (fasl-dump-32-bit-ivector exp $fasl-single-float-vector)) + ((simple-array double-float (*)) + (fasl-dump-double-float-vector exp)) + (symbol (fasl-dump-symbol exp)) + (package (fasl-dump-package exp)) + (function (fasl-dump-function exp)) + (xfunction (fasl-dump-function exp)) + (code-vector (fasl-dump-codevector exp)) + (xcode-vector (fasl-dump-codevector exp)) + (simple-vector (fasl-dump-gvector exp $fasl-t-vector)) + (ratio (fasl-dump-ratio exp)) + (complex (fasl-dump-complex exp)) + #+(and 64-bit-target (not cross-compiling)) + ((simple-array (unsigned-byte 64) (*)) + (fasl-dump-64-bit-ivector exp $fasl-u64-vector)) + #+(and 64-bit-target (not cross-compiling)) + ((simple-array (signed-byte 64) (*)) + (fasl-dump-64-bit-ivector exp $fasl-s64-vector)) + (ivector + (unless (eq (backend-target-arch-name *target-backend*) + (backend-target-arch-name *host-backend*)) + (error "can't cross-compile constant reference to ~s" exp)) + (let* ((typecode (typecode exp)) + (n (uvsize exp)) + (nb (subtag-bytes typecode n))) + (declare (fixnum n nb typecode)) + (fasl-out-opcode $fasl-vivec exp) + (fasl-out-byte typecode) + (fasl-out-count n) + (fasl-out-ivect exp 0 nb))) + (vector (fasl-dump-gvector exp $fasl-vector-header)) + (array (fasl-dump-gvector exp $fasl-array-header)) + + (gvector + (if (= (typecode exp) target::subtag-istruct) + (fasl-dump-gvector exp $fasl-istruct) + (progn + (unless (eq (backend-target-arch-name *target-backend*) + (backend-target-arch-name *host-backend*)) + (error "can't cross-compile constant reference to ~s" exp)) + (let* ((typecode (typecode exp)) + (n (uvsize exp))) + (declare (fixnum n typecode)) + (fasl-out-opcode $fasl-vgvec exp) + (fasl-out-byte typecode) + (fasl-out-count n) + (dotimes (i n) + (fasl-dump-form (%svref exp i))))))))) + +(defun fasl-dump-gvector (v op) + (let* ((n (uvsize v))) + (fasl-out-opcode op v) + (fasl-out-count n) + (dotimes (i n) + (fasl-dump-form (%svref v i))))) + +(defun fasl-dump-ratio (v) + (fasl-out-opcode $fasl-ratio v) + (fasl-dump-form (%svref v target::ratio.numer-cell)) + (fasl-dump-form (%svref v target::ratio.denom-cell))) + +(defun fasl-dump-complex (v) + (fasl-out-opcode $fasl-complex v) + (fasl-dump-form (%svref v target::complex.realpart-cell)) + (fasl-dump-form (%svref v target::complex.imagpart-cell))) + +(defun fasl-dump-bit-vector (v) + (let* ((n (uvsize v))) + (fasl-out-opcode $fasl-bit-vector v) + (fasl-out-count n) + (if (eq *fasl-host-big-endian* *fasl-target-big-endian*) + (let* ((nb (ash (+ n 7) -3))) + (fasl-out-ivect v 0 nb)) + (compiler-bug "need to byte-swap ~a" v)))) + +(defun fasl-dump-8-bit-ivector (v op) + (let* ((n (uvsize v))) + (fasl-out-opcode op v) + (fasl-out-count n) + (let* ((nb n)) + (fasl-out-ivect v 0 nb)))) + +(defun fasl-dump-16-bit-ivector (v op) + (let* ((n (uvsize v))) + (fasl-out-opcode op v) + (fasl-out-count n) + (if (eq *fasl-host-big-endian* *fasl-target-big-endian*) + (let* ((nb (ash n 1))) + (fasl-out-ivect v 0 nb)) + (dotimes (i n) + (let* ((k (uvref v i))) + (fasl-out-byte (ldb (byte 8 0) k)) + (fasl-out-byte (ldb (byte 8 8) k))))))) + +(defun fasl-dump-32-bit-ivector (v op) + (let* ((n (uvsize v))) + (fasl-out-opcode op v) + (fasl-out-count n) + (if (eq *fasl-host-big-endian* *fasl-target-big-endian*) + (let* ((nb (ash n 2))) + (fasl-out-ivect v 0 nb)) + (dotimes (i n) + (let* ((k (uvref v i))) + (fasl-out-byte (ldb (byte 8 0) k)) + (fasl-out-byte (ldb (byte 8 8) k)) + (fasl-out-byte (ldb (byte 8 16) k)) + (fasl-out-byte (ldb (byte 8 24) k))))))) + + +(defun fasl-dump-64-bit-ivector (v op) + (let* ((n (uvsize v))) + (fasl-out-opcode op v) + (fasl-out-count n) + (if (eq *fasl-host-big-endian* *fasl-target-big-endian*) + (let* ((nb (ash n 3))) + (fasl-out-ivect v 0 nb)) + (compiler-bug "need to byte-swap ~a" v)))) + +(defun fasl-dump-double-float-vector (v) + (let* ((n (uvsize v))) + (fasl-out-opcode $fasl-double-float-vector v) + (fasl-out-count n) + (if (eq *fasl-host-big-endian* *fasl-target-big-endian*) + (let* ((nb (ash n 3))) + (fasl-out-ivect v (- target::misc-dfloat-offset + target::misc-data-offset) nb)) + (compiler-bug "need to byte-swap ~a" v)))) + +;;; This is used to dump functions and "xfunctions". +;;; If we're cross-compiling, we shouldn't reference any +;;; (host) functions as constants; try to detect that +;;; case. +#-x86-target +(defun fasl-dump-function (f) + (if (and (not (eq *fasl-backend* *host-backend*)) + (typep f 'function)) + (compiler-bug "Dumping a native function constant ~s during cross-compilation." f)) + (if (and (= (typecode f) target::subtag-xfunction) + (= (typecode (uvref f 0)) target::subtag-u8-vector)) + (fasl-xdump-clfun f) + (let* ((n (uvsize f))) + (fasl-out-opcode $fasl-function f) + (fasl-out-count n) + (dotimes (i n) + (fasl-dump-form (%svref f i)))))) + +#+x86-target +(defun fasl-dump-function (f) + (if (and (not (eq *fasl-backend* *host-backend*)) + (typep f 'function)) + (compiler-bug "Dumping a native function constant ~s during cross-compilation." f)) + (if (and (= (typecode f) target::subtag-xfunction) + (= (typecode (uvref f 0)) target::subtag-u8-vector)) + (fasl-xdump-clfun f) + (let* ((code-size (%function-code-words f)) + (function-vector (function-to-function-vector f)) + (function-size (uvsize function-vector))) + (fasl-out-opcode $fasl-clfun f) + (fasl-out-count function-size) + (fasl-out-count code-size) + (fasl-out-ivect function-vector 0 (ash code-size target::word-shift)) + (do* ((k code-size (1+ k))) + ((= k function-size)) + (declare (fixnum k)) + (fasl-dump-form (uvref function-vector k)))))) + + + + +;;; Write a "concatenated function". +(defun fasl-xdump-clfun (f) + (target-arch-case + (:x8632 + (let* ((code (uvref f 0)) + (function-size (ash (uvsize code) -2)) + (imm-words (dpb (uvref code 1) (byte 8 8) (uvref code 0))) + (imm-bytes (ash imm-words 2)) + (other-words (- function-size imm-words))) + (assert (= other-words (1- (uvsize f)))) + (fasl-out-opcode $fasl-clfun f) + (fasl-out-count function-size) + (fasl-out-count imm-words) + (fasl-out-ivect code 0 imm-bytes) + (do ((i 1 (1+ i)) + (n (uvsize f))) + ((= i n)) + (declare (fixnum i n)) + (fasl-dump-form (%svref f i))))) + (:x8664 + (let* ((code (uvref f 0)) + (code-size (dpb (uvref code 3) + (byte 8 24) + (dpb (uvref code 2) + (byte 8 16) + (dpb (uvref code 1) + (byte 8 8) + (uvref code 0))))) + (function-size (ash (uvsize code) -3))) + (assert (= (- function-size code-size) (1- (uvsize f)))) + (fasl-out-opcode $fasl-clfun f) + (fasl-out-count function-size) + (fasl-out-count code-size) + (fasl-out-ivect code 0 (ash code-size 3)) + (do* ((i 1 (1+ i)) + (n (uvsize f))) + ((= i n)) + (declare (fixnum i n)) + (fasl-dump-form (%svref f i))))))) + +(defun fasl-dump-codevector (c) + (if (and (not (eq *fasl-backend* *host-backend*)) + (typep c 'code-vector)) + (compiler-bug "Dumping a native code-vector constant ~s during cross-compilation." c)) + (let* ((n (uvsize c))) + (fasl-out-opcode $fasl-code-vector c) + (fasl-out-count n) + (fasl-out-ivect c))) + +(defun fasl-dump-t_imm (imm) + (fasl-out-opcode $fasl-timm imm) + (fasl-out-long (%address-of imm))) + +(defun fasl-dump-char (char) ; << maybe not + (let ((code (%char-code char))) + (fasl-out-opcode $fasl-char char) + (fasl-out-count code))) + +;;; Always write big-endian. +(defun fasl-dump-s16 (s16) + (fasl-out-opcode $fasl-word-fixnum s16) + (fasl-out-word s16)) + +;;; Always write big-endian +(defun fasl-dump-s32 (s32) + (fasl-out-opcode $fasl-s32 s32) + (fasl-out-word (ldb (byte 16 16) s32)) + (fasl-out-word (ldb (byte 16 0) s32))) + +;;; Always write big-endian +(defun fasl-dump-s64 (s64) + (fasl-out-opcode $fasl-s64 s64) + (fasl-out-word (ldb (byte 16 48) s64)) + (fasl-out-word (ldb (byte 16 32) s64)) + (fasl-out-word (ldb (byte 16 16) s64)) + (fasl-out-word (ldb (byte 16 0) s64))) + + + +(defun fasl-dump-dfloat (float) + (fasl-out-opcode $fasl-dfloat float) + (multiple-value-bind (high low) (double-float-bits float) + (fasl-out-long high) + (fasl-out-long low))) + +(defun fasl-dump-sfloat (float) + (fasl-out-opcode $fasl-sfloat float) + (fasl-out-long (single-float-bits float))) + + +(defun fasl-dump-package (pkg) + (let* ((name (package-name pkg)) + (nextra (utf-8-extra-bytes name))) + (cond ((eql nextra 0) + (fasl-out-opcode $fasl-nvpkg pkg) + (fasl-out-nvstring name)) + (t + (fasl-out-opcode $fasl-vpkg pkg) + (fasl-out-vstring name nextra))))) + + + +(defun fasl-dump-list (list) + (cond ((null list) (fasl-out-opcode $fasl-nil list)) + ((eq (%car list) cfasl-load-time-eval-sym) + (let* ((form (car (%cdr list))) + (opcode $fasl-eval)) + (when (funcall-lfun-p form) + (setq opcode $fasl-lfuncall + form (%cadr form))) + (if *fasdump-epush* + (progn + (fasl-out-byte (fasl-epush-op opcode)) + (fasl-dump-form form) + (fasl-dump-epush list)) + (progn + (fasl-out-byte opcode) + (fasl-dump-form form))))) + ((istruct-cell-p list) + (fasl-out-opcode $fasl-istruct-cell (car list)) + (fasl-dump-symbol (car list))) + (t (fasl-dump-cons list)))) + +(defun fasl-dump-cons (cons &aux (end cons) (cdr-len 0)) + (declare (fixnum cdr-len)) + (while (and (consp (setq end (%cdr end))) + (null (gethash end *fasdump-hash*))) + (incf cdr-len)) + (if (eql 0 cdr-len) + (fasl-out-opcode $fasl-cons cons) + (progn + (fasl-out-opcode (if end $fasl-vlist* $fasl-vlist) cons) + (fasl-out-count cdr-len))) + (dotimes (i (the fixnum (1+ cdr-len))) + (fasl-dump-form (%car cons)) + (setq cons (%cdr cons))) + (when (or (eql 0 cdr-len) end) ;cons or list* + (fasl-dump-form end))) + + + +(defun fasl-dump-symbol (sym) + (let* ((pkg (symbol-package sym)) + (name (symbol-name sym)) + (nextra (utf-8-extra-bytes name)) + (ascii (eql nextra 0)) + (idx (let* ((i (%svref (symptr->symvector (%symbol->symptr sym)) target::symbol.binding-index-cell))) + (declare (fixnum i)) + (unless (zerop i) i)))) + (cond ((null pkg) + (progn + (fasl-out-opcode (if idx + (if ascii $fasl-nvmksym-special $fasl-vmksym-special) + (if ascii $fasl-nvmksym $fasl-vmksym)) + sym) + (if ascii + (fasl-out-nvstring name) + (fasl-out-vstring name nextra)))) + (*fasdump-epush* + (progn + (fasl-out-byte (fasl-epush-op (if idx + (if ascii $fasl-nvpkg-intern-special $fasl-vpkg-intern-special) + (if ascii $fasl-nvpkg-intern $fasl-vpkg-intern)))) + (fasl-dump-form pkg) + (fasl-dump-epush sym) + (if ascii + (fasl-out-nvstring name) + (fasl-out-vstring name nextra)))) + (t + (progn + (fasl-out-byte (if idx + (if ascii $fasl-nvpkg-intern-special $fasl-vpkg-intern-special) + (if ascii $fasl-nvpkg-intern-special $fasl-vpkg-intern))) + (fasl-dump-form pkg) + (if ascii + (fasl-out-nvstring name) + (fasl-out-vstring name nextra))))))) + + +(defun fasl-unknown (exp) + (error "Can't dump ~S - unknown type" exp)) + +(defun fasl-out-simple-string (str start end) + (declare (simple-string str) (fixnum start end)) + (do* ((k start (1+ k))) + ((= k end)) + (declare (fixnum k)) + (fasl-out-byte (char-code (schar str k))))) + +(defun fasl-out-nvstring (str) + (fasl-out-count (length str)) + (fasl-out-simple-string str 0 (length str))) + +(defun utf-8-extra-bytes (string) + (declare (simple-string string)) + (let* ((extra 0)) + (declare (fixnum extra)) + (dotimes (i (length string) extra) + (let* ((code (%scharcode string i))) + (declare ((mod #x110000) code)) + (cond ((>= code #x10000) (incf extra 3)) + ((>= code #x800) (incf extra 2)) + ((>= code #x80) (incf extra 1))))))) + +(defun fasl-out-vstring (str nextra) + (declare (fixnum nextra)) + (let* ((len (length str))) + (declare (fixnum len)) + (fasl-out-count len) + (fasl-out-count nextra) + (dotimes (i len) + (let* ((code (%scharcode str i))) + (declare ((mod #x110000) code)) + (cond ((< code #x80) (fasl-out-byte code)) + ((< code #x800) + (let* ((y (ldb (byte 5 6) code)) + (z (ldb (byte 6 0) code))) + (declare (fixnum y z)) + (fasl-out-byte (logior #xc0 y)) + (fasl-out-byte (logior #x80 z)))) + ((< code #x10000) + (let* ((x (ldb (byte 4 12) code)) + (y (ldb (byte 6 6) code)) + (z (ldb (byte 6 0) code))) + (declare (fixnum x y z)) + (fasl-out-byte (logior #xe0 x)) + (fasl-out-byte (logior #x80 y)) + (fasl-out-byte (logior #x80 z)))) + (t + (let* ((w (ldb (byte 3 18) code)) + (x (ldb (byte 6 12) code)) + (y (ldb (byte 6 6) code)) + (z (ldb (byte 6 0) code))) + (declare (fixnum w x y z)) + (fasl-out-byte (logior #xf0 w)) + (fasl-out-byte (logior #x80 x)) + (fasl-out-byte (logior #x80 y)) + (fasl-out-byte (logior #x80 z))))))))) + + +(defun fasl-out-ivect (iv &optional + (start 0) + (nb + (subtag-bytes (typecode iv) (uvsize iv)))) + (stream-write-ivector *fasdump-stream* iv start nb)) + + +(defun fasl-out-long (long) + (fasl-out-word (ash long -16)) + (fasl-out-word (logand long #xFFFF))) + +(defun fasl-out-word (word) + (fasl-out-byte (ash word -8)) + (fasl-out-byte word)) + +(defun fasl-out-byte (byte) + (write-byte (%ilogand2 byte #xFF) *fasdump-stream*)) + +;;; Write an unsigned integer in 7-bit chunks. +(defun fasl-out-count (val) + (do* ((b (ldb (byte 7 0) val) (ldb (byte 7 0) val)) + (done nil)) + (done) + (when (zerop (setq val (ash val -7))) + (setq b (logior #x80 b) done t)) + (fasl-out-byte b))) + +(defun fasl-filepos () + (file-position *fasdump-stream*)) + +(defun fasl-set-filepos (pos) + (file-position *fasdump-stream* pos) + #-bccl (unless (eq (file-position *fasdump-stream*) pos) + (error "Unable to set file position to ~S" pos))) + +;;; Concatenate fasl files. + +;;; Format of a fasl file as expected by the fasloader. +;;; +;;; #xFF00 2 bytes - File version +;;; Block Count 2 bytes - Number of blocks in the file +;;; addr[0] 4 bytes - address of 0th block +;;; length[0] 4 bytes - length of 0th block +;;; addr[1] 4 bytes - address of 1st block +;;; length[1] 4 bytes - length of 1st block +;;; ... +;;; addr[n-1] 4 bytes +;;; length[n-1] 4 bytes +;;; length[0] + length[1] + ... + length [n-1] bytes of data + +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; +;; +;; (fasl-concatenate out-file fasl-files &key :if-exists) +;; +;; out-file name of file in which to store the concatenation +;; fasl-files list of names of fasl files to concatenate +;; if-exists as for OPEN, defaults to :error +;; +;; function result: pathname to the output file. +;; It works to use the output of one invocation of fasl-concatenate +;; as an input of another invocation. +;; +(defun fasl-concatenate (out-file fasl-files &key (if-exists :error)) + (%fasl-concatenate out-file fasl-files if-exists (pathname-type *.fasl-pathname*))) + +(defun %fasl-concatenate (out-file fasl-files if-exists file-ext) + (let ((count 0) + (created? nil) + (finished? nil) + (ext-pathname (make-pathname :type file-ext))) + (declare (fixnum count)) + (flet ((fasl-read-halfword (f) + (dpb (read-byte f) (byte 8 8) (read-byte f))) + (fasl-write-halfword (h f) + (write-byte (ldb (byte 8 8) h) f) + (write-byte (ldb (byte 8 0) h) f) + h)) + (flet ((fasl-read-fullword (f) + (dpb (fasl-read-halfword f) (byte 16 16) (fasl-read-halfword f))) + (fasl-write-fullword (w f) + (fasl-write-halfword (ldb (byte 16 16) w) f) + (fasl-write-halfword (ldb (byte 16 0) w) f) + w)) + (dolist (file fasl-files) + (setq file (merge-pathnames file ext-pathname)) + (unless (equal (pathname-type file) file-ext) + (error "Not a ~A file: ~s" file-ext file)) + (with-open-file (instream file :element-type '(unsigned-byte 8)) + (unless (eql fasl-file-id (fasl-read-halfword instream)) + (error "Bad ~A file ID in ~s" file-ext file)) + (incf count (fasl-read-halfword instream)))) + (unwind-protect + (with-open-file (outstream + (setq out-file (merge-pathnames out-file ext-pathname)) + :element-type '(unsigned-byte 8) + :direction :output + :if-does-not-exist :create + :if-exists if-exists) + (setq created? t) + (let ((addr-address 4) + (data-address (+ 4 (* count 8)))) + (fasl-write-halfword 0 outstream) ; will be $fasl-id + (fasl-write-halfword count outstream) + (dotimes (i (* 2 count)) + (fasl-write-fullword 0 outstream)) ; for addresses/lengths + (dolist (file fasl-files) + (with-open-file (instream (merge-pathnames file ext-pathname) + :element-type '(unsigned-byte 8)) + (fasl-read-halfword instream) ; skip ID + (let* ((fasl-count (fasl-read-halfword instream)) + (addrs (make-array fasl-count)) + (sizes (make-array fasl-count)) + addr0) + (declare (fixnum fasl-count) + (dynamic-extent addrs sizes)) + (dotimes (i fasl-count) + (setf (svref addrs i) (fasl-read-fullword instream) + (svref sizes i) (fasl-read-fullword instream))) + (setq addr0 (svref addrs 0)) + (file-position outstream addr-address) + (dotimes (i fasl-count) + (fasl-write-fullword + (+ data-address (- (svref addrs i) addr0)) + outstream) + (fasl-write-fullword (svref sizes i) outstream) + (incf addr-address 8)) + (file-position outstream data-address) + (dotimes (i fasl-count) + (file-position instream (svref addrs i)) + (let ((fasl-length (svref sizes i))) + (dotimes (j fasl-length) + (write-byte (read-byte instream) outstream)) + (incf data-address fasl-length)))))) + (stream-length outstream data-address) + (file-position outstream 0) + (fasl-write-halfword fasl-file-id outstream) + (setq finished? t))) + (when (and created? (not finished?)) + (delete-file out-file)))) + out-file))) + +;;; Cross-compilation environment stuff. Some of this involves +;;; setting up the TARGET and OS packages. +(defun ensure-package-nickname (name package) + (let* ((old (find-package name))) + (unless (eq old package) + (rename-package old (package-name old) (delete name (package-nicknames old) :test #'string=)) + (rename-package package (package-name package) (cons name (package-nicknames package))) + old))) + +(defmacro with-cross-compilation-package ((name target) &body body) + (let* ((old-package (gensym)) + (name-var (gensym)) + (target-var (gensym))) + `(let* ((,name-var ,name) + (,target-var ,target) + (,old-package (ensure-package-nickname ,name-var ,target-var))) + (unwind-protect + (progn ,@body) + (when ,old-package (ensure-package-nickname ,name-var + ,old-package)))))) + +(defun %with-cross-compilation-target (target thunk) + (let* ((backend (find-backend target))) + (if (null backend) + (error "No known compilation target named ~s." target) + (let* ((arch (backend-target-arch backend)) + (arch-package-name (arch::target-package-name arch)) + (ftd (backend-target-foreign-type-data backend)) + (ftd-package-name (ftd-interface-package-name ftd))) + (or (find-package arch-package-name) + (make-package arch-package-name)) + (or (find-package ftd-package-name) + (make-package ftd-package-name :use "COMMON-LISP")) + (with-cross-compilation-package ("OS" ftd-package-name) + (with-cross-compilation-package ("TARGET" arch-package-name) + (let* ((*target-ftd* ftd)) + (funcall thunk)))))))) + +(defmacro with-cross-compilation-target ((target) &body body) + `(%with-cross-compilation-target ,target #'(lambda () ,@body))) + + + + +(provide 'nfcomp) + Index: /branches/new-random/lib/number-case-macro.lisp =================================================================== --- /branches/new-random/lib/number-case-macro.lisp (revision 13309) +++ /branches/new-random/lib/number-case-macro.lisp (revision 13309) @@ -0,0 +1,109 @@ +;;-*- Mode: Lisp; Package: CCL -*- +;;; +;;; Copyright (C) 2009 Clozure Associates +;;; Copyright (C) 1994-2001 Digitool, Inc +;;; This file is part of Clozure CL. +;;; +;;; Clozure CL is licensed under the terms of the Lisp Lesser GNU Public +;;; License , known as the LLGPL and distributed with Clozure CL as the +;;; file "LICENSE". The LLGPL consists of a preamble and the LGPL, +;;; which is distributed with Clozure CL as the file "LGPL". Where these +;;; conflict, the preamble takes precedence. +;;; +;;; Clozure CL is referenced in the preamble as the "LIBRARY." +;;; +;;; The LLGPL is also available online at +;;; http://opensource.franz.com/preamble.html + +(in-package "CCL") + +;;;;;;;;; +;; support fns and vars for number-case + +(defun type-name-to-code (name) + (funcall (arch::target-numeric-type-name-to-typecode-function + (backend-target-arch *target-backend*)) + name)) + +(defvar nd-onions `((integer fixnum bignum) (rational fixnum bignum ratio) + (float double-float short-float) + (real fixnum bignum ratio double-float short-float) + (number fixnum bignum ratio double-float short-float complex))) + +(defun nd-diff (x y) ; things in x that are not in y + (let ((res)) + (dolist (e x) + (when (not (memq e y))(push e res))) + res)) + +(defun nd-type-compose (selectors) + ;; this could do better but probably not worth the trouble - only + ;; for require-type error + (or (dolist (union nd-onions) + (if (when (eq (length selectors)(length (cdr union))) + (dolist (e selectors t)(if (not (memq e (cdr union)))(return)))) + (return (car union)))) + (cons 'or selectors))) + + + +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; +;; +;; Simpler number dispatch. Syntax is just like case. +;; +;; (number-case x => (case (typecode x) +;; (fixnum (print 4)) (target::tag-fixnum (print 4)) ; actually tag value +;; ((bignum ratio)(print 5))) ((target::tag-bignum target::tag-ratio)(print 5)) +;; (t (require-type x 'rational)))) +;; + +(defmacro number-case (var &rest cases) + (let ((selectors-so-far) + (t-case nil) + (tag (gensym)) + (block (gensym))) + (flet ((maybe-compound (selector) + (let ((compound (cdr (assq selector nd-onions)))) + (when compound + (setq compound (nd-diff compound selectors-so-far)) + (when (not compound)(error "Unreachable case ~s" selector)) + (setq selectors-so-far + (append compound selectors-so-far)) + compound)))) + (declare (dynamic-extent #'maybe-compound)) + `(block ,block + (tagbody + ,tag + (return-from ,block + (case (typecode ,var) + ,@(mapcar + #'(lambda (case) + (let ((selector (car case))) + (if (atom selector) + (cond ((eq selector t)(setq t-case t)) + ((memq selector selectors-so-far)(error "Unreachable case ~s" selector)) + ((let ((compound (maybe-compound selector))) + (when compound + (setq selector compound)))) + (t (push selector selectors-so-far))) + (progn + (setq selector + (mapcan #'(lambda (item) + (cond ((memq item selectors-so-far)) + ((let ((compound (maybe-compound item))) + (when compound + (setq item compound)))) + (t (push item selectors-so-far))) + (if (listp item) item (list item))) + selector)))) + (setq selector (if (listp selector) + (mapcar #'type-name-to-code selector) + (if (eq selector t) t + (type-name-to-code selector)))) + `(,selector ,@(cdr case)))) + cases) + ,@(if (not t-case) + `((t (setq ,var (%kernel-restart $xwrongtype ,var ',(nd-type-compose selectors-so-far))) + (go ,tag))))))))))) + +(provide "NUMBER-CASE-MACRO") Index: /branches/new-random/lib/number-macros.lisp =================================================================== --- /branches/new-random/lib/number-macros.lisp (revision 13309) +++ /branches/new-random/lib/number-macros.lisp (revision 13309) @@ -0,0 +1,141 @@ +;;;-*- Mode: Lisp; Package: CCL -*- +;;; +;;; Copyright (C) 2009 Clozure Associates +;;; Copyright (C) 1994-2001 Digitool, Inc +;;; This file is part of Clozure CL. +;;; +;;; Clozure CL is licensed under the terms of the Lisp Lesser GNU Public +;;; License , known as the LLGPL and distributed with Clozure CL as the +;;; file "LICENSE". The LLGPL consists of a preamble and the LGPL, +;;; which is distributed with Clozure CL as the file "LGPL". Where these +;;; conflict, the preamble takes precedence. +;;; +;;; Clozure CL is referenced in the preamble as the "LIBRARY." +;;; +;;; The LLGPL is also available online at +;;; http://opensource.franz.com/preamble.html + +(in-package "CCL") + +(eval-when (:compile-toplevel :execute) + (require "LISPEQU") + ) + +(declare-arch-specific-macro %make-sfloat) + +(declare-arch-specific-macro %make-dfloat) + +(defmacro require-null-or-double-float-sym (sym) + (setq sym (require-type sym 'symbol)) + `(when (and ,sym (not (double-float-p ,sym))) + (setq ,sym (require-type ,sym 'double-float)))) + + +(declare-arch-specific-macro %numerator) + +(declare-arch-specific-macro %denominator) + +(declare-arch-specific-macro %realpart) + +(declare-arch-specific-macro %imagpart) + + +(defmacro with-stack-double-floats (specs &body body) + (collect ((binds) + (inits) + (names)) + (dolist (spec specs) + (let ((name (first spec))) + (binds `(,name (%make-dfloat))) + (names name) + (let ((init (second spec))) + (when init + (inits `(%double-float ,init ,name)))))) + `(let* ,(binds) + (declare (dynamic-extent ,@(names)) + (double-float ,@(names))) + ,@(inits) + ,@body))) + + + + + + + ;;; WITH-BIGNUM-BUFFERS -- Internal. + ;;; + ;;; Could do freelisting someday. NAH + ;;; +(defmacro with-bignum-buffers (specs &body body) ; << + "WITH-BIGNUM-BUFFERS ({(var size [init])}*) Form*" + (collect ((binds) + (inits) + (names)) + (dolist (spec specs) + (let ((name (first spec)) + (size (second spec))) + (binds `(,name (allocate-typed-vector :bignum ,size))) + (names name) + (let ((init (third spec))) + (when init + (inits `(bignum-replace ,name ,init)))))) + `(let* ,(binds) + (declare (dynamic-extent ,@(names))) + ,@(inits) + ,@body))) + +;;; call fn on possibly stack allocated negative of a and/or b +;;; args better be vars - we dont bother with once-only +(defmacro with-negated-bignum-buffers (a b fn) + `(let* ((len-a (%bignum-length ,a)) + (len-b (%bignum-length ,b)) + (a-plusp (bignum-plusp ,a)) + (b-plusp (bignum-plusp ,b))) + (declare (type bignum-index len-a len-b)) + (if (and a-plusp b-plusp) + (,fn ,a ,b ) + (if (not a-plusp) + (with-bignum-buffers ((a1 (1+ len-a))) + (negate-bignum ,a nil a1) + (if b-plusp + (,fn a1 ,b) + (with-bignum-buffers ((b1 (1+ len-b))) + (negate-bignum ,b nil b1) + (,fn a1 b1)))) + (with-bignum-buffers ((b1 (1+ len-b))) + (negate-bignum ,b nil b1) + (,fn ,a b1)))))) + +(defmacro with-one-negated-bignum-buffer (a fn) + `(if (bignum-plusp ,a) + (,fn ,a) + (with-bignum-buffers ((a1 (1+ (%bignum-length ,a)))) + (negate-bignum ,a nil a1) + (,fn a1)))) + + +(defmacro fixnum-to-bignum-set (big fix) + `(%fixnum-to-bignum-set ,big ,fix)) + +(defmacro with-small-bignum-buffers (specs &body body) + (collect ((binds) + (inits) + (names)) + (dolist (spec specs) + (let ((name (first spec))) + (binds `(,name (allocate-typed-vector :bignum + ,(target-word-size-case (32 1) + (64 2))))) + + (names name) + (let ((init (second spec))) + (when init + (inits `(fixnum-to-bignum-set ,name ,init)))))) + `(let* ,(binds) + (declare (dynamic-extent ,@(names))) + ,@(inits) + ,@body))) + +(provide "NUMBER-MACROS") + +;;; end of number-macros.lisp Index: /branches/new-random/lib/numbers.lisp =================================================================== --- /branches/new-random/lib/numbers.lisp (revision 13309) +++ /branches/new-random/lib/numbers.lisp (revision 13309) @@ -0,0 +1,814 @@ +;;;-*-Mode: LISP; Package: CCL -*- +;;; +;;; Copyright (C) 2009 Clozure Associates +;;; Copyright (C) 1994-2001 Digitool, Inc +;;; This file is part of Clozure CL. +;;; +;;; Clozure CL is licensed under the terms of the Lisp Lesser GNU Public +;;; License , known as the LLGPL and distributed with Clozure CL as the +;;; file "LICENSE". The LLGPL consists of a preamble and the LGPL, +;;; which is distributed with Clozure CL as the file "LGPL". Where these +;;; conflict, the preamble takes precedence. +;;; +;;; Clozure CL is referenced in the preamble as the "LIBRARY." +;;; +;;; The LLGPL is also available online at +;;; http://opensource.franz.com/preamble.html + +;; Lib;numbers.lisp - Lisp arithmetic code. + +(in-package "CCL") + +(eval-when (:compile-toplevel :execute) + (require :number-macros) + (require :number-case-macro) + #+(and cross-compiling 64-bit-target) + (declaim (ftype function %single-float-atanh %single-float-acosh + %single-float-asinh %single-float-tanh + %single-float-cosh %single-float-sinh))) + + + +(defconstant double-float-positive-infinity + #.(let* ((division-by-zero (get-fpu-mode :division-by-zero))) + (declare (notinline /)) + (unwind-protect + (progn + (ccl:set-fpu-mode :division-by-zero nil) + (/ 0d0)) + (ccl:set-fpu-mode :division-by-zero division-by-zero)))) + +(defconstant double-float-negative-infinity + #.(let* ((division-by-zero (get-fpu-mode :division-by-zero))) + (declare (notinline /)) + (unwind-protect + (progn + (ccl:set-fpu-mode :division-by-zero nil) + (/ -0d0)) + (ccl:set-fpu-mode :division-by-zero division-by-zero)))) + +(defconstant double-float-nan + #.(let ((invalid (get-fpu-mode :invalid))) + (unwind-protect + (progn + (set-fpu-mode :invalid nil) + (+ double-float-positive-infinity double-float-negative-infinity)) + (set-fpu-mode :invalid invalid)))) + +(defun parse-float (str len off) + ; we cant assume this really is a float but dont call with eg s1 or e1 + (let ((integer 0)(expt 0)(sign 0)(done 0)(digits 0) point-pos type) + (setq integer + (do ((n off (1+ n)) + (first t nil) + (maxn (+ off len))) + ((>= n maxn) integer) + (declare (fixnum n maxn)) + (let ((c (%schar str n))) + (cond ((eq c #\.) + (setq point-pos digits)) + ((and first (eq c #\+))) + ((and first (eq c #\-)) + (setq sign -1)) + ((memq c '(#\s #\f #\S #\F)) + (setq type 'short-float) + (return integer)) + ((memq c '(#\d #\l #\D #\L)) + (setq type 'double-float) + (return integer)) + ((memq c '(#\e #\E)) + (return integer)) + ((setq c (digit-char-p c)) + (setq digits (1+ digits)) + (setq integer (+ c (* 10 integer)))) + (t (return-from parse-float nil))) + (setq done (1+ done))))) + (when point-pos + (setq expt (%i- point-pos digits))) + (when (null type) + (setq type *read-default-float-format*)) + (when (> len done) + (let ((eexp nil) (inf nil) (nan nil) (esign 1) c (xsign-n -1)) + (do ((n (%i+ off done 1) (1+ n)) + (first t nil)) + ((>= n (+ off len))) + (declare (fixnum n)) + (setq c (%schar str n)) + (cond ((and first (or (eq c #\+)(eq c #\-))) + (when (eq c #\-)(setq esign -1)) + (setq xsign-n (1+ n))) + ((and (= n xsign-n) + (or (eq c #\+)(eq c #\-))) + (if (eq c #\-) + (setq nan t) + (setq inf t))) + ((setq c (digit-char-p c)) + (setq eexp (+ c (* (or eexp 0) 10)))) + (t (return-from parse-float nil)))) + (when (not eexp)(return-from parse-float nil)) + (cond + (inf + (return-from parse-float + (coerce (if (minusp sign) + double-float-negative-infinity + double-float-positive-infinity) + type))) + (nan + (return-from parse-float + (coerce double-float-nan type))) + (expt (setq expt (%i+ expt (* esign eexp)))) + (t (return-from parse-float nil))))) + (fide sign integer expt (subtypep type 'short-float)))) + + +;; an interesting test case: 1.448997445238699 +;; The correct result is 6525704354437805 x 2^-52 +;; Incorrect is 6525704354437806 x 2^-52 +;; (from Will Clinger, "How to Read Floating Point Numbers Accurately", +;; ACM SIGPLAN'90 Conference on Programming Language Design and Implementation") +;; Doug Curries numbers 214748.3646, 1073741823/5000 + + +;; Sane read losers +;; 15871904747836473438871.0e-8 +;; 3123927307537977993905.0-13 +;; 17209940865514936528.0e-6 +;; "13.60447536e132" => adds some gratuitous drech +;; "94824331561426550.889e182" +;; "1166694.64175277e-150" => 1.1666946417527701E-144 +;; "3109973217844.55680988601e-173" +;; "817332.e-184" => 8.173320000000001E-179 +;; "2695.13e-180" => 2.6951300000000002E-177 +;; "89.85345789e-183" => 8.985345789000001E-182 +;; "0864813880.29e140" => 8.648138802899999E+148 +;; "5221.e-193" => 5.2209999999999995E-190 +;; "7.15628e-175" => 7.156280000000001E-175 + +(defparameter float-powers-of-5 nil) +(defparameter integer-powers-of-5 nil) + +(defun 5-to-e (e) + (declare (fixnum e)(optimize (speed 3)(safety 0))) + (if (> e 335) + (* (5-to-e 335)(5-to-e (- e 335))) ; for the dude who types 200 digits and e-500 + (if (< e 12) + (svref integer-powers-of-5 e) + (multiple-value-bind (q r) (truncate e 12) ; was floor + (declare (fixnum q r)) + (if (eql r 0) + (svref integer-powers-of-5 (%i+ q 11)) + (* (svref integer-powers-of-5 r) + (svref integer-powers-of-5 (%i+ q 11)))))))) + +(defun float-5-to-e (e) + (if (> e 22) ; shouldnt happen + (expt 5.0d0 e) + (svref float-powers-of-5 e))) + +(defparameter a-short-float nil) + +(eval-when (:compile-toplevel :execute) + ; number of bits for mantissa before rounding + (defconstant *short-float-extended-precision* 28) + (defconstant *double-float-extended-precision* 60) + ; number of mantissa bits including hidden bit + (defconstant *double-float-precision* (1+ IEEE-double-float-mantissa-width)) + (defconstant *short-float-precision* (1+ IEEE-single-float-mantissa-width)) + (defconstant *double-float-bias* IEEE-double-float-bias) + (defconstant *double-float-max-exponent* (1+ IEEE-double-float-normal-exponent-max)) + (defconstant *double-float-max-exact-power-of-5* 23) + ;(defconstant *short-float-max-exact-integer-length* 24) + (defconstant *double-float-max-exact-integer-length* 53) +) + + + + +(eval-when (:compile-toplevel :execute) + (defconstant *short-float-max-exact-power-of-5* 10) + (defconstant *short-float-bias* IEEE-single-float-bias) + (defconstant *short-float-max-exact-integer-length* 24) + (defconstant *short-float-max-exponent* (1+ IEEE-single-float-normal-exponent-max)) +) + + +;; this stuff could be in a shared file + +(defun fide #|float-integer-with-decimal-exponent|# (sign integer power-of-10 &optional short) + ;; take care of the zero case + (when (zerop integer) + (return-from fide ;float-integer-with-decimal-exponent + (if short + (if (minusp sign) -0.0s0 0.0s0) + (if (minusp sign) -0.0d0 0.0d0)))) + (let ((abs-power (abs power-of-10)) + (integer-length (integer-length integer))) + ;; this doesn't work for the above example, so arithmetic must be done wrong + ;; This does work if set FPCR precision to double + ;; now see if the conversion can be done simply: + ;; if both the integer and the power of 10 can be floated exactly, then + ;; correct rounding can be done by the multiply or divide + (when (or;short + (and (<= integer-length + ;; was (if short 17 53) why 17? see above + (if short *short-float-max-exact-integer-length* *double-float-max-exact-integer-length*)) + ;; (integer-length (expt 5 23)) => 54 + ;; was (if short 5 23) + (< abs-power (if short + *short-float-max-exact-power-of-5* + *double-float-max-exact-power-of-5*)))) ; we mean < 23 not <= + ;; if you care about consing, this could be done in assembly language or whatever, + ;; since all integers fit in 53 bits + (return-from fide ;float-integer-with-decimal-exponent + (let* ((signed-integer (prog1 (if (minusp sign) (- integer) integer))) + (float (float signed-integer (if short 0.0s0 0.0d0))) + (10-to-power (scale-float (float-5-to-e abs-power) abs-power))) + ;; coerce to short-float does not whine about undeflow, but does re overflow + (when short (setq 10-to-power (coerce 10-to-power 'short-float))) + (if (zerop abs-power) + float + (if (minusp power-of-10) + (/ float 10-to-power) + (* float 10-to-power)))))) + (try-harder sign integer power-of-10 short))) + + +(defun try-harder (sign integer power-of-10 short) + (flet ((ovf (&optional under) + (if under + (if (get-fpu-mode :underflow) + (error 'floating-point-underflow + :operation 'scale + :operands (list sign integer power-of-10))) + (if (get-fpu-mode :overflow) + (error 'floating-point-overflow + :operation 'scale + :operands (list sign integer power-of-10)))) + (return-from try-harder + (if under + (if short + (if (minusp sign) -0.0s0 0.0s0) + (if (minusp sign) 0.0d0 0.0d0)) + (if short + (if (minusp sign) most-negative-short-float most-positive-short-float) + (if (minusp sign) most-negative-double-float most-positive-double-float)))))) + (let* ((integer-length (integer-length integer)) new-int power-of-2) + (if (minusp power-of-10) + (progn + ;; avoid creating enormous integers with 5-to-e only to error later + (when (< power-of-10 -335) + (let ((poo (+ (round integer-length 3.2) power-of-10))) + ;; overestimate digits in integer + (when (< poo -335) (ovf t)) + ;; this case occurs if 600+ digits + (when (> poo 335) (ovf)))) + (let* ((divisor (5-to-e (- power-of-10))) + ;; make sure we will have enough bits in the quotient + ;; (and a couple extra for rounding) + (shift-factor (+ (- (integer-length divisor) integer-length) + (if short *short-float-extended-precision* *double-float-extended-precision*))) + (scaled-integer integer)) + (if (plusp shift-factor) + (setq scaled-integer (ash integer shift-factor)) + (setq divisor (ash divisor (- shift-factor)))) + (multiple-value-bind (quotient remainder)(floor scaled-integer divisor) + (unless (zerop remainder) ; whats this - tells us there's junk below + (setq quotient (logior quotient 1))) + (setq new-int quotient) + (setq power-of-2 (- power-of-10 shift-factor))))) + (progn + (when (> power-of-10 335)(ovf)) + (setq new-int (* integer (5-to-e power-of-10))) + (setq power-of-2 power-of-10))) + (float-and-scale-and-round sign new-int power-of-2 short)))) + + +(defun float-and-scale-and-round (sign integer power-of-2 short &optional result) + (let* ((length (integer-length integer)) + (lowbits 0) + (prec (if short *short-float-precision* *double-float-precision*)) + (ep (if short *short-float-extended-precision* *double-float-extended-precision*))) + (when (<= length prec) + ;; float can be done exactly, so do it the easy way + (return-from float-and-scale-and-round + (scale-float (float (if (minusp sign) (- integer) integer) (if short a-short-float)) + power-of-2))) + (let* ((exponent (+ length power-of-2)) + (biased-exponent (+ exponent (if short *short-float-bias* *double-float-bias*))) + (sticky-residue nil)) + (cond + ((<= biased-exponent 0) + ;; denormalize the number + (setf sticky-residue (not (zerop (ldb integer (byte (- 1 biased-exponent) 0))))) + (setf integer (ash integer (- biased-exponent 1))) + (setf biased-exponent 0))) + (let ((lowest (min ep length))) + (when (and (> length ep)(not (zerop (ldb (byte (- length ep) 0) integer)))) + (setq integer (logior integer (ash 1 (- length ep))))) + ; somewhere between 1 and (- ep prec) bits + (setq lowbits (ash (ldb (byte (- lowest prec) (- length lowest)) integer) (- ep lowest)))) + (let* ((significand (ldb (byte (1- prec) (- length prec)) integer))) + (when (and (not (zerop (ldb (byte 1 (- length (1+ prec))) integer))) ; round bit + (or sticky-residue (oddp significand) + (not (zerop (ldb (byte (- ep prec 1) 0) lowbits))))) + ;; round up + (setf significand (ldb (byte (1- prec) 0) (+ significand 1))) + (when (zerop significand) + (incf biased-exponent))) + (cond ((and (zerop biased-exponent) + (zerop significand) + (get-fpu-mode :underflow)) + (error 'floating-point-underflow + :operation 'scale + :operands (list sign integer power-of-2))) + ((>= biased-exponent (if short *short-float-max-exponent* *double-float-max-exponent*)) + (cond + (t + (if (get-fpu-mode :overflow) + (error 'floating-point-overflow + :operation 'scale + :operands (list sign integer power-of-2))) + (setf significand 0) + (setq biased-exponent (if short *short-float-max-exponent* *double-float-max-exponent*)))))) + (values + (if short + (make-short-float-from-fixnums (ldb (byte 23 0) significand) + biased-exponent + sign #-64-bit-target result) + (make-float-from-fixnums (ldb (byte 24 28) significand) + (ldb (byte 28 0) significand) + biased-exponent + sign result)) + lowbits))))) + + + + +(defparameter a-short-float 1.0s0) + +#+32-bit-target +(defmethod print-object ((rs random-state) stream) + (format stream "#.(~S ~S ~S)" ;>> #.GAG!!! + 'ccl::initialize-random-state + (random.seed-1 rs) + (random.seed-2 rs))) + +#+64-bit-target +(defmethod print-object ((rs random-state) stream) + (let* ((s1 (random.seed-1 rs))) + (format stream "#.(~S ~S ~S)" ;>> #.GAG!!! + 'ccl::initialize-random-state + (ldb (byte 16 16) s1) + (ldb (byte 16 0) s1)))) + + + +(defun float-radix (float) + "Return (as an integer) the radix b of its floating-point argument." + (require-type float 'float) + 2) + +(defun float-digits (float) + (if (typep (require-type float 'float) 'short-float) + IEEE-single-float-digits + IEEE-double-float-digits)) + +(defun number-arg (arg) + (if (numberp arg) arg (%badarg arg 'number))) + + + + + +;==> Needs a transform... +(defun logandc2 (integer1 integer2) + "Bitwise AND INTEGER1 with (LOGNOT INTEGER2)." + (logandc1 integer2 integer1)) + +(defun logorc2 (integer1 integer2) + "Bitwise OR INTEGER1 with (LOGNOT INTEGER2)." + (logorc1 integer2 integer1)) + + + +; Figure that the common (2-arg) case is caught by a compiler transform anyway. +(defun gcd (&lexpr numbers) + "Return the greatest common divisor of the arguments, which must be + integers. Gcd with no arguments is defined to be 0." + (let* ((count (%lexpr-count numbers))) + (declare (fixnum count)) + (if (zerop count) + 0 + (let* ((n0 (%lexpr-ref numbers count 0))) + (if (= count 1) + (%integer-abs n0) + (do* ((i 1 (1+ i))) + ((= i count) n0) + (declare (fixnum i)) + (setq n0 (gcd-2 n0 (%lexpr-ref numbers count i))))))))) + +(defun lcm-2 (n0 n1) + (or (typep n0 'integer) (report-bad-arg n0 'integer)) + (or (typep n1 'integer) (report-bad-arg n1 'integer)) + (locally (declare (integer n0 n1)) + (if (zerop n0) + 0 + (if (zerop n1) + 0 + (let* ((small (if (< n0 n1) n0 n1)) + (large (if (eq small n0) n1 n0))) + (values (truncate (abs (* n0 n1)) (gcd large small)))))))) + +(defun lcm (&lexpr numbers) + "Return the least common multiple of one or more integers. LCM of no + arguments is defined to be 1." + (let* ((count (%lexpr-count numbers))) + (declare (fixnum count)) + (if (zerop count) + 1 + (let* ((n0 (%lexpr-ref numbers count 0))) + (if (= count 1) + (%integer-abs n0) + (if (= count 2) + (lcm-2 n0 (%lexpr-ref numbers count 1)) + (do* ((i 1 (1+ i))) + ((= i count) n0) + (declare (fixnum i)) + (setq n0 (lcm-2 n0 (%lexpr-ref numbers count i)))))))))) + + +#| +(defun rationalize (x) + (etypecase x + (rational x) + (real + (cond ((minusp x) (- (rationalize (- x)))) + ((zerop x) 0) + (t + (let ((eps (etypecase x + (single-float single-float-epsilon) + (double-float double-float-epsilon))) + (y ()) + (a ())) + (do ((xx x (setq y (/ (float 1.0 x) (- xx (float a x))))) + (num (setq a (truncate x)) + (+ (* (setq a (truncate y)) num) onum)) + (den 1 (+ (* a den) oden)) + (onum 1 num) + (oden 0 den)) + ((and (not (zerop den)) + (not (> (abs (/ (- x (/ (float num x) + (float den x))) + x)) + eps))) + (integer-/-integer num den))))))))) +|# + +(defun rationalize (number) + "Converts any REAL to a RATIONAL. Floats are converted to a simple rational + representation exploiting the assumption that floats are only accurate to + their precision. RATIONALIZE (and also RATIONAL) preserve the invariant: + (= x (float (rationalize x) x))" + (if (floatp number) + (labels ((simpler-rational (less-predicate lonum loden hinum hiden + &aux (trunc (if (eql less-predicate #'<=) + #'ceiling + #'(lambda (n d) (1+ (floor n d))))) + (term (funcall trunc lonum loden))) + ;(pprint (list lonum loden hinum hiden)) + (if (funcall less-predicate (* term hiden) hinum) + (values term 1) + (multiple-value-bind + (num den) + (simpler-rational less-predicate hiden (- hinum (* (1- term) hiden)) + loden (- lonum (* (1- term) loden))) + (values (+ den (* (1- term) num)) num))))) + (multiple-value-bind (fraction exponent sign) (integer-decode-float number) + ;; the first 2 tests may be unnecessary - I think the check + ;; for denormalized is compensating for a bug in 3.0 re + ;; floating a rational (in order to pass tests in + ;; ppc-test-arith). + (if (or (and (typep number 'double-float) ; is it denormalized + (eq exponent #.(nth-value 1 (integer-decode-float least-positive-double-float)))) ; aka -1074)) + (eq exponent #.(nth-value 1 (integer-decode-float least-positive-short-float))) ; aka -149)) + (zerop (logand fraction (1- fraction)))) ; or a power of two + (rational number) + (if (minusp exponent) + ;;less than 1 + (let ((num (ash fraction 2)) + (den (ash 1 (- 2 exponent)))) + (multiple-value-bind + (n d) + (simpler-rational (if (evenp fraction) #'<= #'<) + (- num 2) ;(if (zerop (logand fraction (1- fraction))) 1 2)) + den (+ num 2) den) + (when (minusp sign) + (setq n (- n))) + (/ n d))) + ;;greater than 1 + (ash (if (minusp number) (- fraction) fraction) exponent))))) + (rational number))) +#| +(defun testrat (&optional (n 1000)) + (dotimes (i n) + (let* (( numerator (random (ash 1 63))) + (denominator (random (ash 1 63))) + (sign (if (zerop (random 2)) 1 -1)) + (trial (float (/ (* sign numerator) denominator))) + (rat (rationalize trial))) + (when (not (= (float rat) trial)) + (error "Rationalize failed. Input ~s Rational ~s Float ~s" trial rat (float rat)))))) + +; smallest fails in 3.0 - powers of 2 - works here but we cheat a bit +(defun testrat2 () + (let ((f least-positive-double-float)) + (dotimes (i 100) + (when (not (= (float (rationalize f)) f)) + (cerror "a" "rat failed ~s ~s" f i)) + (setq f (* f 2))))) + +; fails a lot in 3.0 - not powers of 2 - works here +(defun testrat3 () + (let ((f least-positive-double-float)) + (dotimes (i 1000) + (let ((f2 (* (+ i i 1) f))) + (when (not (= (float (rationalize f2)) f2)) + (cerror "a" "rat failed ~s ~s" f2 i))))) + (let ((f least-negative-double-float)) + (dotimes (i 1000) + (let ((f2 (* (+ i i 1) f))) + (when (not (= (float (rationalize f2)) f2)) + (cerror "a" "rat failed ~s ~s" f2 i)))))) + +(defun testrat31 () + (let ((f least-positive-short-float)) + (dotimes (i 1000) + (let ((f2 (* (+ i i 1) f))) + (when (not (= (float (rationalize f2)) f2)) + (cerror "a" "rat failed ~s ~s" f2 i))))) + (let ((f least-negative-short-float)) + (dotimes (i 1000) + (let ((f2 (* (+ i i 1) f))) + (when (not (= (float (rationalize f2)) f2)) + (cerror "a" "rat failed ~s ~s" f2 i)))))) + +; works in 3.0 - and here +(defun testrat4 () + (let ((f least-positive-normalized-double-float)) + (dotimes (i 1000) + (let ((f2 (* (+ i i 1) f))) + (when (not (= (float (rationalize f2)) f2)) + (cerror "a" "rat failed ~s ~s" f2 i))))) + (let ((f least-negative-normalized-double-float)) + (dotimes (i 100) + (let ((f2 (* (+ i i 1) f))) + (when (not (= (float (rationalize f2)) f2)) + (cerror "a" "rat failed ~s ~s" f2 i)))))) + + +|# + +#| now in l1-numbers.lisp +(defun logeqv (&lexpr numbers) + (let* ((count (%lexpr-count numbers))) + (declare (fixnum count)) + (if (zerop count) + -1 + (let* ((n0 (%lisp-word-ref numbers count))) + (if (= count 1) + (require-type n0 'integer) + (do* ((i 1 (1+ i))) + ((= i count) n0) + (declare (fixnum i)) + (declare (optimize (speed 3) (safety 0))) + (setq n0 (logeqv-2 (%lexpr-ref numbers count i) n0)))))))) +|# + + +(defparameter *boole-ops* + (vector + #'(lambda (i1 i2) (declare (ignore i1 i2)) 0) + #'(lambda (i1 i2) (declare (ignore i1 i2)) -1) + #'(lambda (i1 i2) (declare (ignore i2)) i1) + #'(lambda (i1 i2) (declare (ignore i1)) i2) + #'(lambda (i1 i2) (declare (ignore i2)) (lognot i1)) + #'(lambda (i1 i2) (declare (ignore i1)) (lognot i2)) + #'(lambda (i1 i2) (logand i1 i2)) + #'(lambda (i1 i2) (logior i1 i2)) + #'(lambda (i1 i2) (logxor i1 i2)) + #'(lambda (i1 i2) (logeqv i1 i2)) + #'(lambda (i1 i2) (lognand i1 i2)) + #'(lambda (i1 i2) (lognor i1 i2)) + #'(lambda (i1 i2) (logandc1 i1 i2)) + #'(lambda (i1 i2) (logandc2 i1 i2)) + #'(lambda (i1 i2) (logorc1 i1 i2)) + #'(lambda (i1 i2) (logorc2 i1 i2)))) + + + +;===> Change these constants to match maclisp!! +(defun boole (op integer1 integer2) + "Bit-wise boolean function on two integers. Function chosen by OP: + 0 BOOLE-CLR + 1 BOOLE-SET + 2 BOOLE-1 + 3 BOOLE-2 + 4 BOOLE-C1 + 5 BOOLE-C2 + 6 BOOLE-AND + 7 BOOLE-IOR + 8 BOOLE-XOR + 9 BOOLE-EQV + 10 BOOLE-NAND + 11 BOOLE-NOR + 12 BOOLE-ANDC1 + 13 BOOLE-ANDC2 + 14 BOOLE-ORC1 + 15 BOOLE-ORC2" + (unless (and (typep op 'fixnum) + (locally (declare (fixnum op)) + (and (>= op 0) + (<= op 15)))) + (report-bad-arg op '(integer 0 15))) + (funcall (%svref *boole-ops* op) + (require-type integer1 'integer) + (require-type integer2 'integer))) + + +(defun %integer-power (b e) + (declare (type unsigned-byte e)) + (if (zerop e) + (+ 1 (* b 0)) + (if (eql b 2) + (ash 1 e) + (do* ((next (ash e -1) (ash e -1)) + (oddexp (oddp e) (oddp e)) + (total (if oddexp b 1) (if oddexp (* b total) total))) + ((zerop next) total) + (declare (type unsigned-byte next)) + (setq b (* b b) e next))))) + +(defun signum (x) + "If NUMBER is zero, return NUMBER, else return (/ NUMBER (ABS NUMBER))." + (cond ((complexp x) (if (zerop x) x (/ x (abs x)))) + ((rationalp x) (if (plusp x) 1 (if (zerop x) 0 -1))) + ((zerop x) (float 0.0 x)) + (t (float-sign x)))) + + + +; Thanks to d34676@tansei.cc.u-tokyo.ac.jp (Akira KURIHARA) +(defun isqrt (n &aux n-len-quarter n-half n-half-isqrt + init-value iterated-value) + "Return the root of the nearest integer less than n which is a perfect + square. Argument n must be a non-negative integer" + (cond + ((eql n 0) 0) + ; this fails sometimes - do we care? 70851992595801818865024053174 or #x80000000 + ; maybe we do - its used by dotimes + ;((not (int>0-p n)) (report-bad-arg n '(integer 0))) ;'unsigned-byte)) ; Huh? + ((or (not (integerp n))(minusp n))(report-bad-arg n '(integer 0))) + ((> n 24) ; theoretically (> n 7) ,i.e., n-len-quarter > 0 + (setq n-len-quarter (ash (integer-length n) -2)) + (setq n-half (ash n (- (ash n-len-quarter 1)))) + (setq n-half-isqrt (isqrt n-half)) + (setq init-value (ash (1+ n-half-isqrt) n-len-quarter)) + (loop + (setq iterated-value (ash (+ init-value (floor n init-value)) -1)) + (if (not (< iterated-value init-value)) + (return init-value) + (setq init-value iterated-value)))) + ((> n 15) 4) + ((> n 8) 3) + ((> n 3) 2) + (t 1))) + + +(defun sinh (x) + "Return the hyperbolic sine of NUMBER." + (if (complexp x) + (/ (- (exp x) (exp (- x))) 2) + (if (typep x 'double-float) + (%double-float-sinh! x (%make-dfloat)) + #+32-bit-target + (target::with-stack-short-floats ((sx x)) + (%single-float-sinh! sx (%make-sfloat))) + #+64-bit-target + (%single-float-sinh (%short-float x))))) + + +(defun cosh (x) + "Return the hyperbolic cosine of NUMBER." + (if (complexp x) + (/ (+ (exp x) (exp (- x))) 2) + (if (typep x 'double-float) + (%double-float-cosh! x (%make-dfloat)) + #+32-bit-target + (target::with-stack-short-floats ((sx x)) + (%single-float-cosh! sx (%make-sfloat))) + #+64-bit-target + (%single-float-cosh (%short-float x))))) + +(defun tanh (x) + "Return the hyperbolic tangent of NUMBER." + (if (complexp x) + (/ (sinh x) (cosh x)) + (if (typep x 'double-float) + (%double-float-tanh! x (%make-dfloat)) + #+32-bit-target + (target::with-stack-short-floats ((sx x)) + (%single-float-tanh! sx (%make-sfloat))) + #+64-bit-target + (%single-float-tanh (%short-float x))))) + +(defun asinh (x) + "Return the hyperbolic arc sine of NUMBER." + (if (complexp x) + (log (+ x (sqrt (+ 1 (* x x))))) + (if (typep x 'double-float) + (%double-float-asinh! x (%make-dfloat)) + #+32-bit-target + (target::with-stack-short-floats ((sx x)) + (%single-float-asinh! sx (%make-sfloat))) + #+64-bit-target + (%single-float-asinh (%short-float x))))) + +(defun acosh (x) + "Return the hyperbolic arc cosine of NUMBER." + (if (and (realp x) (<= 1.0 x)) + (if (typep x 'double-float) + (%double-float-acosh! x (%make-dfloat)) + #+32-bit-target + (target::with-stack-short-floats ((sx x)) + (%single-float-acosh! sx (%make-sfloat))) + #+64-bit-target + (%single-float-acosh (%short-float x))) + (* 2 (log (+ (sqrt (/ (1+ x) 2)) (sqrt (/ (1- x) 2))))))) + +(defun atanh (x) + "Return the hyperbolic arc tangent of NUMBER." + (if (and (realp x) (<= -1.0 (setq x (float x)) 1.0)) + (if (typep x 'double-float) + (%double-float-atanh! x (%make-dfloat)) + #+32-bit-target + (%single-float-atanh! x (%make-sfloat)) + #+64-bit-target + (%single-float-atanh x)) + (/ (log (/ (+ 1 x) (- 1 x))) 2))) + + +(defun ffloor (number &optional divisor) + "Same as FLOOR, but returns first value as a float." + (multiple-value-bind (q r) (floor number divisor) + (values (float q (if (floatp r) r 0.0)) r))) + +(defun fceiling (number &optional divisor) + "Same as CEILING, but returns first value as a float." + (multiple-value-bind (q r) (ceiling number divisor) + (values (float q (if (floatp r) r 0.0)) r))) + +(defun ftruncate (number &optional divisor) + "Same as TRUNCATE, but returns first value as a float." + (multiple-value-bind (q r) (truncate number divisor) + (values (float q (if (floatp r) r 0.0)) r))) + +(defun fround (number &optional divisor) + "Same as ROUND, but returns first value as a float." + (multiple-value-bind (q r) (round number divisor) + (values (float q (if (floatp r) r 0.0)) r))) + +(defun rational (number) + "RATIONAL produces a rational number for any real numeric argument. This is + more efficient than RATIONALIZE, but it assumes that floating-point is + completely accurate, giving a result that isn't as pretty." + (if (floatp number) + (multiple-value-bind (s e sign) + (number-case number + (short-float + (integer-decode-short-float number)) + (double-float + (integer-decode-double-float number))) + (if (eq sign -1) (setq s (- s))) + (if (%iminusp e) + (/ s (ash 1 (%i- 0 e))) + (ash s e))) + (if (rationalp number) + number + (report-bad-arg number 'real)))) + +; make power tables for floating point reader +(progn + (setq float-powers-of-5 (make-array 23)) + (let ((array float-powers-of-5)) + (dotimes (i 23) + (setf (svref array i) (float (expt 5 i) 0.0d0)))) + (setq integer-powers-of-5 (make-array (+ 12 (floor 324 12)))) + (let ((array integer-powers-of-5)) + (dotimes (i 12) + (setf (svref array i) (expt 5 i))) + (dotimes (i (floor 324 12)) + (setf (svref array (+ i 12)) (expt 5 (* 12 (1+ i))))))) + + +(provide 'numbers) + Index: /branches/new-random/lib/pathnames.lisp =================================================================== --- /branches/new-random/lib/pathnames.lisp (revision 13309) +++ /branches/new-random/lib/pathnames.lisp (revision 13309) @@ -0,0 +1,525 @@ +;;;-*-Mode: LISP; Package: CCL -*- +;;; +;;; Copyright (C) 1994-2001 Digitool, Inc +;;; Portions copyright (C) 2001-2009 Clozure Associates +;;; This file is part of Clozure CL. +;;; +;;; Clozure CL is licensed under the terms of the Lisp Lesser GNU Public +;;; License , known as the LLGPL and distributed with Clozure CL as the +;;; file "LICENSE". The LLGPL consists of a preamble and the LGPL, +;;; which is distributed with Clozure CL as the file "LGPL". Where these +;;; conflict, the preamble takes precedence. +;;; +;;; Clozure CL is referenced in the preamble as the "LIBRARY." +;;; +;;; The LLGPL is also available online at +;;; http://opensource.franz.com/preamble.html + +;;pathnames.lisp Pathnames for Coral Common LISP +(in-package "CCL") + +(eval-when (eval compile) + (require 'level-2) + (require 'backquote) +) +;(defconstant $accessDenied -5000) ; put this with other errnos +(defconstant $afpAccessDenied -5000) ; which name to use? + + + +;-_-_-_-_-_-_-_-_-_-_-_-_-_-_-_-_-_-_-_-_-_-_-_-_-_-_-_-_-_-_-_-_-_-_-_-_-_-_-_-_-_-_ +;ANSI CL logical pathnames + + +(defvar *pathname-translations-pathname* + (make-pathname :host "ccl" :type "pathname-translations")) + +(defun load-logical-pathname-translations (host) + ;(setq host (verify-logical-host-name host)) + (when (not (%str-assoc host %logical-host-translations%)) + (setf (logical-pathname-translations host) + (with-open-file (file (merge-pathnames (make-pathname :name host :defaults nil) + *pathname-translations-pathname*) + :element-type 'base-char) + (read file))) + T)) + +(defun back-translate-pathname (path &optional hosts) + (let ((newpath (back-translate-pathname-1 path hosts))) + (cond ((equalp path newpath) + ;; (fcomp-standard-source path) + (namestring (pathname path))) + (t newpath)))) + + +(defun back-translate-pathname-1 (path &optional hosts) + (dolist (host %logical-host-translations%) + (when (or (null hosts) (member (car host) hosts :test 'string-equal)) + (dolist (trans (cdr host)) + (when (pathname-match-p path (cadr trans)) + (let* (newpath) + (setq newpath (translate-pathname path (cadr trans) (car trans) :reversible t)) + (return-from back-translate-pathname-1 + (if (equalp path newpath) path (back-translate-pathname-1 newpath hosts)))))))) + path) + + + +; must be after back-translate-pathname +(defun physical-pathname-p (path) + (let* ((path (pathname path)) + (dir (pathname-directory path))) + (and dir + (or (not (logical-pathname-p path)) + (not (null (memq (pathname-host path) '(nil :unspecific)))))))) + + + +;-_-_-_-_-_-_-_-_-_-_-_-_-_-_-_-_-_-_-_-_-_-_-_-_-_-_-_-_-_-_-_-_-_-_-_-_-_-_-_-_-_-_ +;File or directory Manipulations + +(defun unix-rename (old-name new-name) + (with-cstrs ((old old-name) + (new new-name)) + #+windows-target + (#__unlink new) + (let* ((res (#_rename old new))) + (declare (fixnum res)) + (if (zerop res) + (values t nil) + (values nil (%get-errno)))))) + +(defun rename-file (file new-name &key (if-exists :error)) + "Rename FILE to have the specified NEW-NAME. If FILE is a stream open to a + file, then the associated file is renamed." + (let* ((original (truename file)) + (original-namestring (native-translated-namestring original)) + (new-name (merge-pathnames new-name original)) + (new-namestring (native-translated-namestring new-name))) + (unless new-namestring + (error "~S can't be created." new-name)) + (unless (and (probe-file new-name) + (not (if-exists if-exists new-name))) + (multiple-value-bind (res error) + (unix-rename original-namestring + new-namestring) + (unless res + (error "Failed to rename ~A to ~A: ~A" + original new-name error)) + (when (streamp file) + (setf (stream-filename file) + (namestring (native-to-pathname new-namestring)))) + (values new-name original (truename new-name)))))) + +(defun copy-file (source-path dest-path &key (if-exists :error) (if-does-not-exist :create) + (preserve-attributes nil)) + (let* ((original (truename source-path)) + (new-name (merge-pathnames dest-path original)) + (buffer (make-array 4096 :element-type '(unsigned-byte 8)))) + (with-open-file (in original :direction :input + :element-type '(unsigned-byte 8)) + (with-open-file (out new-name :direction :output + :if-exists if-exists + :if-does-not-exist if-does-not-exist + :element-type '(unsigned-byte 8)) + (loop + as n = (stream-read-vector in buffer 0 4096) until (eql n 0) + do (stream-write-vector out buffer 0 n)))) + (when preserve-attributes + (copy-file-attributes original new-name)) + (values new-name original (truename new-name)))) + +(defun recursive-copy-directory (source-path dest-path &key test (if-exists :error)) + ;; TODO: Support :if-exists :supersede to blow away any files not in source dir + (assert (directoryp source-path)(source-path) + "source-path is not a directory in RECURSIVE-COPY-DIRECTORY") + (setq if-exists (require-type if-exists '(member :overwrite :error))) + (setq dest-path (ensure-directory-pathname dest-path)) + (when (eq if-exists :error) + (when (probe-file dest-path) + (if-exists if-exists dest-path)) + ;; Skip the probe-file in recursive calls, we already know it's ok. + (setq if-exists :overwrite)) + (let* ((source-dir (ensure-directory-pathname source-path)) + (pattern (make-pathname :name :wild :type :wild :defaults source-dir)) + (source-files (directory pattern :test test :directories t :files t))) + (ensure-directories-exist dest-path) + (dolist (f source-files) + (when (or (null test) (funcall test f)) + (if (directory-pathname-p f) + (let ((dest-file (make-pathname :name (first (last (pathname-directory f))) + :defaults dest-path))) + (recursive-copy-directory f dest-file :test test :if-exists if-exists)) + (let* ((dest-file (make-pathname :name (pathname-name f) + :type (pathname-type f) + :defaults dest-path))) + (copy-file f dest-file :if-exists :supersede :preserve-attributes t))))))) + +;;; use with caution! +;;; blows away a directory and all its contents +(defun recursive-delete-directory (path &key (if-does-not-exist :error)) + (setq path (ensure-directory-pathname path)) + (setq if-does-not-exist (require-type if-does-not-exist '(member :error nil))) + (when (eq if-does-not-exist :error) + (unless (probe-file path) + (if-does-not-exist if-does-not-exist path))) + (when (probe-file path) + (if (directoryp path) + ;; it's a directory: blow it away + (let* ((pattern (make-pathname :name :wild :type :wild :defaults path)) + (files (directory pattern :directories nil :files t)) + (subdirs (directory pattern :directories t :files nil)) + (target-pathname (native-translated-namestring path))) + (dolist (f files) + (delete-file f)) + (dolist (d subdirs) + (recursive-delete-directory d :if-does-not-exist if-does-not-exist)) + (%rmdir target-pathname)) + ;; it's not a directory: for safety's sake, signal an error + (error "Pathname '~A' is not a directory" path)))) + +;;; It's not clear that we can support anything stronger than +;;; "advisory" ("you pretend the file's locked & I will too") file +;;; locking under Darwin. + + + + +(defun create-directory (path &key (mode #o777)) + (let* ((pathname (translate-logical-pathname (merge-pathnames path))) + (created-p nil) + (parent-dirs (let* ((pd (pathname-directory pathname))) + (if (eq (car pd) :relative) + (pathname-directory (merge-pathnames + pathname + (mac-default-directory))) + pd))) + (nparents (length parent-dirs))) + (when (wild-pathname-p pathname) + (error 'file-error :error-type "Inappropriate use of wild pathname ~s" + :pathname pathname)) + (do* ((i 1 (1+ i))) + ((> i nparents) (values pathname created-p)) + (declare (fixnum i)) + (let* ((parent (make-pathname + :name :unspecific + :type :unspecific + :host (pathname-host pathname) + :device (pathname-device pathname) + :directory (subseq parent-dirs 0 i))) + (parent-name (native-translated-namestring parent)) + (parent-kind (%unix-file-kind parent-name))) + + (if parent-kind + (unless (eq parent-kind :directory) + (error 'simple-file-error + :error-type "Can't create directory ~s, since file ~a exists and is not a directory" + :pathname pathname + :format-arguments (list parent-name))) + (let* ((result (%mkdir parent-name mode))) + (declare (fixnum result)) + (if (< result 0) + (signal-file-error result parent-name) + (setq created-p t)))))))) + + +(defun ensure-directories-exist (pathspec &key verbose (mode #o777)) + "Test whether the directories containing the specified file + actually exist, and attempt to create them if they do not. + The MODE argument is an extension to control the Unix permission + bits. Portable programs should avoid using the :MODE keyword + argument." + (let ((pathname (let ((pathspec (translate-logical-pathname (merge-pathnames pathspec)))) + (make-directory-pathname :device (pathname-device pathspec) + :directory (pathname-directory pathspec)))) + (created-p nil)) + (when (wild-pathname-p pathname) + (error 'file-error + :error-type "Inappropriate use of wild pathname ~s" + :pathname pathname)) + (let ((dir (pathname-directory pathname))) + (if (eq (car dir) :relative) + (setq dir (pathname-directory (merge-pathnames + pathname + (mac-default-directory))))) + (loop for i from 1 upto (length dir) + do (let ((newpath (make-pathname + :name :unspecific + :type :unspecific + :host (pathname-host pathname) + :device (pathname-device pathname) + :directory (subseq dir 0 i)))) + (unless (probe-file newpath) + (let ((namestring (native-translated-namestring newpath))) + (when verbose + (format *standard-output* "~&Creating directory: ~A~%" + namestring)) + (%mkdir namestring mode) + (unless (probe-file newpath) + (error 'file-error + :pathname namestring + :error-type "Can't create directory ~S.")) + (setf created-p t))))) + (values pathspec created-p)))) + +(defun dirpath-to-filepath (path) + (setq path (translate-logical-pathname (merge-pathnames path))) + (let* ((dir (pathname-directory path)) + (super (butlast dir)) + (name (car (last dir)))) + (when (eq name :up) + (setq dir (remove-up (copy-list dir))) + (setq super (butlast dir)) + (setq name (car (last dir)))) + (when (null super) + (signal-file-error $xnocreate path)) + (setq path (make-pathname :directory super :name name :defaults nil)))) + +(defun filepath-to-dirpath (path) + (let* ((dir (pathname-directory path)) + (rest (file-namestring path))) + (make-pathname :directory (append dir (list rest)) :defaults nil))) + + + +;Takes a pathname, returns the truename of the directory if the pathname +;names a directory, NIL if it names an ordinary file, error otherwise. +;E.g. (directoryp "ccl;:foo:baz") might return #P"hd:mumble:foo:baz:" if baz +;is a dir. - should we doc this - its exported? +(defun directoryp (path) + (let* ((native (native-translated-namestring path)) + (realpath (%realpath native))) + (if realpath (eq (%unix-file-kind realpath) :directory)))) + + +;-_-_-_-_-_-_-_-_-_-_-_-_-_-_-_-_-_-_-_-_-_-_-_-_-_-_-_-_-_-_-_-_-_-_-_-_-_-_-_-_-_-_ +;Wildcards + + + + +;-_-_-_-_-_-_-_-_-_-_-_-_-_-_-_-_-_-_-_-_-_-_-_-_-_-_-_-_-_-_-_-_-_-_-_-_-_-_-_-_-_-_ +;Directory Traversing + +(defun %path-cat (device dir subdir) + (if device + (%str-cat device ":" dir subdir) + (%str-cat dir subdir))) + +(defmacro with-open-dir ((dirent device dir) &body body) + `(let ((,dirent (%open-dir (native-translated-namestring (make-pathname :device ,device :directory ,dir :defaults nil))))) + (when ,dirent + (unwind-protect + (progn ,@body) + (close-dir ,dirent))))) + +(defun directory (path &key (directories nil) ;; include subdirectories + (files t) ;; include files + (all t) ;; include Unix dot files (other than dot and dot dot) + (directory-pathnames t) ;; return directories as directory-pathname-p's. + (include-emacs-lockfiles nil) ;; inculde .#foo + test ;; Only return pathnames matching test + (follow-links t)) ;; return truename's of matching files. + "Return a list of PATHNAMEs, each the TRUENAME of a file that matched the + given pathname. Note that the interaction between this ANSI-specified + TRUENAMEing and the semantics of the Unix filesystem (symbolic links..) + means this function can sometimes return files which don't have the same + directory as PATHNAME." + (let* ((keys (list :directories directories ;list defaulted key values + :files files + :all all + :directory-pathnames directory-pathnames + :test test + :include-emacs-lockfiles include-emacs-lockfiles + :follow-links follow-links)) + (path (full-pathname (merge-pathnames path) :no-error nil)) + (dir (directory-namestring path))) + (declare (dynamic-extent keys)) + (if (null (pathname-directory path)) + (setq dir (directory-namestring (setq path + (merge-pathnames path + (mac-default-directory)))))) + (assert (eq (car (pathname-directory path)) :absolute) () + "full-pathname returned relative path ~s??" path) + ;; return sorted in alphabetical order, target-Xload-level-0 depends + ;; on this. + (nreverse + (delete-duplicates (%directory "/" dir path '(:absolute) keys) :test #'equal)))) + +(defun %directory (dir rest path so-far keys) + (multiple-value-bind (sub-dir wild rest) (%split-dir rest) + (%some-specific dir sub-dir wild rest path so-far keys))) + +(defun %some-specific (dir sub-dir wild rest path so-far keys) + (let* ((start 1) + (end (length sub-dir)) + (full-dir (if (eq start end) dir (%str-cat dir (%substr sub-dir start end))))) + (while (neq start end) + (let ((pos (position #\/ sub-dir :start start :end end))) + (push (%path-std-quotes (%substr sub-dir start pos) nil "/:;*") so-far) + (setq start (%i+ 1 pos)))) + (cond ((null wild) + (%files-in-directory full-dir path so-far keys)) + ((string= wild "**") + (%all-directories full-dir rest path so-far keys)) + (t (%one-wild full-dir wild rest path so-far keys))))) + +; for a * or *x*y +(defun %one-wild (dir wild rest path so-far keys) + (let ((result ()) + (device (pathname-device path)) + (all (getf keys :all)) + name) + (with-open-dir (dirent device dir) + (while (setq name (%read-dir dirent)) + (when (and (or all (neq (%schar name 0) #\.)) + (not (string= name ".")) + (not (string= name "..")) + (%path-pstr*= wild name) + (eq (%unix-file-kind (%path-cat device dir name) t) :directory)) + (let ((subdir (%path-cat nil dir name)) + (so-far (cons (%path-std-quotes name nil "/;:*") so-far))) + (declare (dynamic-extent so-far)) + (setq result + (nconc (%directory (%str-cat subdir "/") rest path so-far keys) result)))))) + result)) + +(defun %files-in-directory (dir path so-far keys) + (let ((device (pathname-device path)) + (name (pathname-name path)) + (type (pathname-type path)) + (directories (getf keys :directories)) + (files (getf keys :files)) + (directory-pathnames (getf keys :directory-pathnames)) + (test (getf keys :test)) + (follow-links (getf keys :follow-links)) + (all (getf keys :all)) + (include-emacs-lockfiles (getf keys :include-emacs-lockfiles)) + (result ()) + sub dir-list ans) + (if (not (or name type)) + (let (full-path) + (when (and directories + (eq (%unix-file-kind (namestring (setq full-path (%cons-pathname (reverse so-far) nil nil nil device))) + t) + :directory)) + (setq ans (if directory-pathnames full-path + (%cons-pathname (reverse (cdr so-far)) (car so-far) nil nil device))) + (when (and ans (or (null test) (funcall test ans))) + (setq result (list ans))))) + (with-open-dir (dirent (pathname-device path) dir) + (while (setq sub (%read-dir dirent)) + (when (and (or all (neq (%schar sub 0) #\.)) + (or include-emacs-lockfiles + (< (length sub) 2) + (not (string= sub ".#" :end1 2))) + (not (string= sub ".")) + (not (string= sub "..")) + (%file*= name type sub)) + (setq ans + (if (eq (%unix-file-kind (%path-cat device dir sub) t) :directory) + (when directories + (let* ((std-sub (%path-std-quotes sub nil "/;:*"))) + (if directory-pathnames + (%cons-pathname (reverse (cons std-sub so-far)) nil nil nil device) + (%cons-pathname (or dir-list (setq dir-list (reverse so-far))) std-sub nil nil device)))) + (when files + (multiple-value-bind (name type) (%std-name-and-type sub) + (%cons-pathname (or dir-list (setq dir-list (reverse so-far))) name type nil device))))) + (when (and ans (or (null test) (funcall test ans))) + (push (if follow-links (or (probe-file ans) ans) ans) result)))))) + result)) + +(defun %all-directories (dir rest path so-far keys) + (let ((do-files nil) + (do-dirs nil) + (result nil) + (device (pathname-device path)) + (name (pathname-name path)) + (type (pathname-type path)) + (all (getf keys :all)) + (test (getf keys :test)) + (directory-pathnames (getf keys :directory-pathnames)) + (follow-links (getf keys :follow-links)) + sub dir-list ans) + ;; First process the case that the ** stands for 0 components + (multiple-value-bind (next-dir next-wild next-rest) (%split-dir rest) + (while (and next-wild ; Check for **/**/ which is the same as **/ + (string= next-dir "/") + (string= next-wild "**")) + (setq rest next-rest) + (multiple-value-setq (next-dir next-wild next-rest) (%split-dir rest))) + (cond ((not (string= next-dir "/")) + (setq result + (%some-specific dir next-dir next-wild next-rest path so-far keys))) + (next-wild + (setq result + (%one-wild dir next-wild next-rest path so-far keys))) + ((or name type) + (when (getf keys :files) (setq do-files t)) + (when (getf keys :directories) (setq do-dirs t))) + (t (when (getf keys :directories) + (setq sub (if directory-pathnames + (%cons-pathname (setq dir-list (reverse so-far)) nil nil nil device) + (%cons-pathname (reverse (cdr so-far)) (car so-far) nil nil device))) + (when (or (null test) (funcall test sub)) + (setq result (list (if follow-links (truename sub) sub)))))))) + ; now descend doing %all-dirs on dirs and collecting files & dirs if do-x is t + (with-open-dir (dirent device dir) + (while (setq sub (%read-dir dirent)) + (when (and (or all (neq (%schar sub 0) #\.)) + (not (string= sub ".")) + (not (string= sub ".."))) + (if (eq (%unix-file-kind (%path-cat device dir sub) t) :directory) + (let* ((subfile (%path-cat nil dir sub)) + (std-sub (%path-std-quotes sub nil "/;:*")) + (so-far (cons std-sub so-far)) + (subdir (%str-cat subfile "/"))) + (declare (dynamic-extent so-far)) + (when (and do-dirs (%file*= name type sub)) + (setq ans (if directory-pathnames + (%cons-pathname (reverse so-far) nil nil nil device) + (%cons-pathname (or dir-list (setq dir-list (reverse (cdr so-far)))) + std-sub nil nil device))) + (when (or (null test) (funcall test ans)) + (push (if follow-links (truename ans) ans) result))) + (setq result (nconc (%all-directories subdir rest path so-far keys) result))) + (when (and do-files (%file*= name type sub)) + (multiple-value-bind (name type) (%std-name-and-type sub) + (setq ans (%cons-pathname (or dir-list (setq dir-list (reverse so-far))) name type nil device)) + (when (or (null test) (funcall test ans)) + (push (if follow-links (truename ans) ans) result)))))))) + result)) + +(defun %split-dir (dir &aux pos) ; dir ends in a "/". + ;"/foo/bar/../x*y/baz/../z*t/" -> "/foo/bar/../" "x*y" "/baz/../z*t/" + (if (null (setq pos (%path-mem "*" dir))) + (values dir nil nil) + (let (epos (len (length dir))) + (setq pos (if (setq pos (%path-mem-last "/" dir 0 pos)) (%i+ pos 1) 0) + epos (%path-mem "/" dir pos len)) + (when (%path-mem-last-quoted "/" dir 0 pos) + (signal-file-error $xbadfilenamechar dir #\/)) + (values (unless (%izerop pos) (namestring-unquote (%substr dir 0 pos))) + (%substr dir pos epos) + (%substr dir epos len))))) + +(defun %path-pstr*= (pattern pstr &optional (p-start 0)) + (assert (eq p-start 0)) + (%path-str*= pstr pattern)) + +(defun %file*= (name-pat type-pat pstr) + (if (eq name-pat :wild) (setq name-pat "*")) + (if (eq type-pat :wild) (setq type-pat "*")) + (when (and (null name-pat) (null type-pat)) + (return-from %file*= T)) + (let* ((end (length pstr)) + (pos (position #\. pstr :from-end t)) + (type (and pos (%substr pstr (%i+ pos 1) end))) + (name (unless (eq (or pos end) 0) (if pos (%substr pstr 0 pos) pstr)))) + (and (cond ((or (eq name-pat :unspecific) (null name-pat)) (null name)) + (t (%path-pstr*= name-pat (or name "")))) + (cond ((or (null type-pat) (eq type-pat :unspecific)) (null type)) + (t (%path-pstr*= type-pat (or type ""))))))) + +(provide "PATHNAMES") Index: /branches/new-random/lib/ppc-backtrace.lisp =================================================================== --- /branches/new-random/lib/ppc-backtrace.lisp (revision 13309) +++ /branches/new-random/lib/ppc-backtrace.lisp (revision 13309) @@ -0,0 +1,883 @@ +;;;-*-Mode: LISP; Package: CCL -*- +;;; +;;; Copyright (C) 2009 Clozure Associates +;;; Copyright (C) 1994-2001 Digitool, Inc +;;; This file is part of Clozure CL. +;;; +;;; Clozure CL is licensed under the terms of the Lisp Lesser GNU Public +;;; License , known as the LLGPL and distributed with Clozure CL as the +;;; file "LICENSE". The LLGPL consists of a preamble and the LGPL, +;;; which is distributed with Clozure CL as the file "LGPL". Where these +;;; conflict, the preamble takes precedence. +;;; +;;; Clozure CL is referenced in the preamble as the "LIBRARY." +;;; +;;; The LLGPL is also available online at +;;; http://opensource.franz.com/preamble.html + + +(in-package "CCL") + +(def-accessors (fake-stack-frame) %svref + nil ; 'fake-stack-frame + %fake-stack-frame.sp ; fixnum. The stack pointer where this frame "should" be + %fake-stack-frame.next-sp ; Either sp or another fake-stack-frame + %fake-stack-frame.fn ; The current function + %fake-stack-frame.lr ; fixnum offset from fn (nil if fn is not functionp) + %fake-stack-frame.vsp ; The value stack pointer + %fake-stack-frame.xp ; Exception frame. + %fake-stack-frame.link ; next in *fake-stack-frames* list + ) + +;;; Linked list of fake stack frames. +;;; %frame-backlink looks here +(def-standard-initial-binding *fake-stack-frames* nil) + + +(defun fake-stack-frame-p (x) + (istruct-typep x 'fake-stack-frame)) + +(defun cfp-lfun (p) + (if (fake-stack-frame-p p) + (let* ((fn (%fake-stack-frame.fn p)) + (lr (%fake-stack-frame.lr p))) + (if (and (typep fn 'function) + (typep lr 'fixnum)) + (values fn lr) + (values nil nil))) + (%cfp-lfun p))) + + +(defun %stack< (index1 index2 &optional context) + (cond ((fake-stack-frame-p index1) + (let ((sp1 (%fake-stack-frame.sp index1))) + (declare (fixnum sp1)) + (if (fake-stack-frame-p index2) + (or (%stack< sp1 (%fake-stack-frame.sp index2) context) + (eq index2 (%fake-stack-frame.next-sp index1))) + (%stack< sp1 (%i+ index2 1) context)))) + ((fake-stack-frame-p index2) + (%stack< index1 (%fake-stack-frame.sp index2) context)) + (t (let* ((tcr (if context (bt.tcr context) (%current-tcr))) + (cs-area (%fixnum-ref tcr target::tcr.cs-area))) + (and (%ptr-in-area-p index1 cs-area) + (%ptr-in-area-p index2 cs-area) + (< (the fixnum index1) (the fixnum index2))))))) + +;;; Returns two values: +;;; [nil, nil] if it can be reliably determined that function uses no registers at PC +;;; [mask, savevsp] if it can be reliably determined that the registers specified by "mask" +;;; were saved at "savevsp" in the function's stack frame +;;; [mask, nil] if registers in "mask" MAY have been saved, but we don't know how to restore them +;;; (perhaps because the "at-pc" argument wasn't specified. + + +;;; If the last instruction in a code vector is an +;;; LWZ instruction (of the form "(LWZ rx s16 ry)"), +;;; then +;;; this function uses registers RX-R31. Note that this leaves +;;; us 2 extra bits, since we're only encoding 3 bits worth of +;;; register info. +;;; RX is saved nearest the top of the vstack +;;; s16 is the offset from the saved-vsp to the address at which +;;; RX was saved; this is a negative value whose low two bits +;;; are ignored +;;; (logior (ash (logand s16 3) 5) rY) is the pc at which +;;; the registers were saved (a fullword code-vector index). +;;; This scheme lets us encode any "simple" register usage, where +;;; the registers were saved once, saved somewhere within the first +;;; 128 instructions in the code vector, and nothing interesting (to +;;; backtrace) happens after the registers have been restored. +;;; If the compiler ever gets cleverer about this, we'll have to use +;;; some other scheme (perhaps a STW instruction, preceded by branches). +;;; +;;; Note that the "last instruction" really means "last instruction +;;; before any traceback table"; we should be able to truncate the code +;;; vector (probably by copying it) to strip off the traceback table +;;; without losing this information. +;;; Note also that the disassembler would probably ordinarily want to +;;; hide this last instruction ... +;;; + +#+ppc32-target +(defun registers-used-by (lfun &optional at-pc) + (let* ((regs-used nil) + (where-saved nil)) + (multiple-value-bind (op-high op-low) (%code-vector-last-instruction (uvref lfun 0)) + (declare (fixnum op-high op-low)) + (if (eql (ldb (byte 6 (- 26 16)) op-high) 32) ; LWZ + (let* ((nregs (- 32 (ldb (byte 5 (- 21 16)) op-high))) + (pc (dpb (ldb (byte 2 0) op-low) (byte 2 5) (ldb (byte 5 (- 16 16)) op-high))) + (offset (%word-to-int (logand op-low (lognot 3))))) + (declare (fixnum nregs pc offset)) + (setq regs-used (1- (ash 1 nregs))) + (if at-pc + (if (>= at-pc pc) + (setq where-saved (- (ash (- offset) -2) nregs)) + (setq regs-used nil)))))) + (values (and regs-used (bit-reverse-8 regs-used)) where-saved))) + +#+ppc64-target +(defun registers-used-by (lfun &optional at-pc) + (let* ((regs-used nil) + (where-saved nil) + (instr (%code-vector-last-instruction (uvref lfun 0)))) + (if (eql (ldb (byte 6 26) instr) 32) ; LWZ + (let* ((nregs (- 32 (ldb (byte 5 21) instr))) + (pc (dpb (ldb (byte 2 0) instr) (byte 2 5) (ldb (byte 5 16) instr))) + (offset (%word-to-int (logand instr (lognot 7))))) + (declare (fixnum nregs pc offset)) + (setq regs-used (1- (ash 1 nregs))) + (if at-pc + (if (>= at-pc pc) + (setq where-saved (- (ash (- offset) -3) nregs)) + (setq regs-used nil))))) + (values (and regs-used (bit-reverse-8 regs-used)) where-saved))) + + +(defparameter *bit-reverse-8-table* + #.(let ((table (make-array 256 :element-type '(unsigned-byte 8)))) + (dotimes (i 256) + (let ((j 0) + (out-mask (ash 1 7))) + (declare (fixnum j out-mask)) + (dotimes (bit 8) + (when (logbitp bit i) + (setq j (logior j out-mask))) + (setq out-mask (ash out-mask -1))) + (setf (aref table i) j))) + table)) + +(defun bit-reverse-8 (x) + (aref *bit-reverse-8-table* x)) + +(defun %frame-savefn (p) + (if (fake-stack-frame-p p) + (%fake-stack-frame.fn p) + (%%frame-savefn p))) + +(defun %frame-savevsp (p) + (if (fake-stack-frame-p p) + (%fake-stack-frame.vsp p) + (%%frame-savevsp p))) + +(defun frame-vsp (frame) + (%frame-savevsp frame)) + +;;; Return two values: the vsp of p and the vsp of p's "parent" frame. +;;; The "parent" frame vsp might actually be the end of p's segment, +;;; if the real "parent" frame vsp is in another segment. +(defun vsp-limits (p context) + (let* ((vsp (%frame-savevsp p)) + parent) + (when (eql vsp 0) + ; This frame is where the code continues after an unwind-protect cleanup form + (setq vsp (%frame-savevsp (child-frame p context)))) + (flet ((grand-parent (frame) + (let ((parent (parent-frame frame context))) + (when (and parent (eq parent (%frame-backlink frame context))) + (let ((grand-parent (parent-frame parent context))) + (when (and grand-parent (eq grand-parent (%frame-backlink parent context))) + grand-parent)))))) + (declare (dynamic-extent #'grand-parent)) + (let* ((frame p) + grand-parent) + (loop + (setq grand-parent (grand-parent frame)) + (when (or (null grand-parent) (not (eql 0 (%frame-savevsp grand-parent)))) + (return)) + (setq frame grand-parent)) + (setq parent (parent-frame frame context))) + (let* ((parent-vsp (if parent (%frame-savevsp parent) vsp)) + (tcr (if context (bt.tcr context) (%current-tcr))) + (vsp-area (%fixnum-ref tcr target::tcr.vs-area))) + (if (eql 0 parent-vsp) + (values vsp vsp) ; p is the kernel frame pushed by an unwind-protect cleanup form + (progn + (unless vsp-area + (error "~s is not a stack frame pointer for context ~s" p tcr)) + (unless (%ptr-in-area-p parent-vsp vsp-area) + (setq parent-vsp (%fixnum-ref vsp-area target::area.high))) + (values vsp parent-vsp))))))) + + +(defun catch-csp-p (p context) + (let ((catch (if context + (bt.top-catch context) + (%catch-top (%current-tcr))))) + (loop + (when (null catch) (return nil)) + (let ((sp (catch-frame-sp catch))) + (when (eql sp p) + (return t))) + (setq catch (next-catch catch))))) + +(defun last-catch-since (sp context) + (let* ((tcr (if context (bt.tcr context) (%current-tcr))) + (catch (%catch-top tcr)) + (last-catch nil)) + (loop + (unless catch (return last-catch)) + (let ((csp (uvref catch target::catch-frame.csp-cell))) + (when (%stack< sp csp context) (return last-catch)) + (setq last-catch catch + catch (next-catch catch)))))) + +(defun register-number->saved-register-index (regno) + (- regno ppc::save7)) + +(defun %find-register-argument-value (context cfp regval bad) + (let* ((last-catch (last-catch-since cfp context)) + (index (register-number->saved-register-index regval))) + (do* ((frame cfp + (child-frame frame context)) + (first t)) + ((null frame)) + (if (fake-stack-frame-p frame) + (return-from %find-register-argument-value + (xp-gpr-lisp (%fake-stack-frame.xp frame) regval)) + (if first + (setq first nil) + (multiple-value-bind (lfun pc) + (cfp-lfun frame) + (when lfun + (multiple-value-bind (mask where) + (registers-used-by lfun pc) + (when (if mask (logbitp index mask)) + (incf where (logcount (logandc2 mask (1- (ash 1 (1+ index)))))) + (return-from + %find-register-argument-value + (raw-frame-ref frame context where bad))))))))) + (get-register-value nil last-catch index))) + +(defun %set-register-argument-value (context cfp regval new) + (let* ((last-catch (last-catch-since cfp context)) + (index (register-number->saved-register-index regval))) + (do* ((frame cfp + (child-frame frame context)) + (first t)) + ((null frame)) + (if (fake-stack-frame-p frame) + (return-from %set-register-argument-value + (setf (xp-gpr-lisp (%fake-stack-frame.xp frame) regval) new)) + (if first + (setq first nil) + (multiple-value-bind (lfun pc) + (cfp-lfun frame) + (when lfun + (multiple-value-bind (mask where) + (registers-used-by lfun pc) + (when (if mask (logbitp index mask)) + (incf where (logcount (logandc2 mask (1- (ash 1 (1+ index)))))) + (return-from + %set-register-argument-value + (raw-frame-set frame context where new))))))))) + (set-register-value new nil last-catch index))) + +(defun %raw-frame-ref (cfp context idx bad) + (declare (fixnum idx)) + (multiple-value-bind (frame base) + (vsp-limits cfp context) + (let* ((raw-size (- base frame))) + (declare (fixnum frame base raw-size)) + (if (and (>= idx 0) + (< idx raw-size)) + (let* ((addr (- (the fixnum (1- base)) + idx))) + (multiple-value-bind (db-count first-db last-db) + (count-db-links-in-frame frame base context) + (let* ((is-db-link + (unless (zerop db-count) + (do* ((last last-db (previous-db-link last first-db))) + ((null last)) + (when (= addr last) + (return t)))))) + (if is-db-link + (oldest-binding-frame-value context addr) + (%fixnum-ref addr))))) + bad)))) + +(defun %raw-frame-set (cfp context idx new) + (declare (fixnum idx)) + (multiple-value-bind (frame base) + (vsp-limits cfp context) + (let* ((raw-size (- base frame))) + (declare (fixnum frame base raw-size)) + (if (and (>= idx 0) + (< idx raw-size)) + (let* ((addr (- (the fixnum (1- base)) + idx))) + (multiple-value-bind (db-count first-db last-db) + (count-db-links-in-frame frame base context) + (let* ((is-db-link + (unless (zerop db-count) + (do* ((last last-db (previous-db-link last first-db))) + ((null last)) + (when (= addr last) + (return t)))))) + (if is-db-link + (setf (oldest-binding-frame-value context addr) new) + (setf (%fixnum-ref addr) new)))) + t))))) + +;;; Used for printing only. +(defun index->address (p) + (when (fake-stack-frame-p p) + (setq p (%fake-stack-frame.sp p))) + (ldb (byte #+32-bit-target 32 #+64-bit-target 64 0) (ash p target::fixnumshift))) + + +(defun match-local-name (cellno info pc) + (when info + (let* ((syms (%car info)) + (ptrs (%cdr info))) + (dotimes (i (length syms)) + (let ((j (%i+ i (%i+ i i )))) + (and (eq (uvref ptrs j) (%ilogior (%ilsl (+ 6 target::word-shift) cellno) #o77)) + (%i>= pc (uvref ptrs (%i+ j 1))) + (%i< pc (uvref ptrs (%i+ j 2))) + (return (aref syms i)))))))) + +(defun get-register-value (address last-catch index) + (if address + (%fixnum-ref address) + (uvref last-catch (+ index target::catch-frame.save-save7-cell)))) + +;;; Inverse of get-register-value + +(defun set-register-value (value address last-catch index) + (if address + (%fixnum-set address value) + (setf (uvref last-catch (+ index target::catch-frame.save-save7-cell)) + value))) + +;;; I'm skeptical about a lot of this stuff on the PPC, but if anything it's +;;; pretty PPC-specific + +;;; Act as if VSTACK-INDEX points somewhere where DATA could go & put it there. +(defun set-lisp-data (vstack-index data) + (let* ((old (%access-lisp-data vstack-index))) + (if (closed-over-value-p old) + (set-closed-over-value old data) + (%store-lisp-data vstack-index data)))) + + +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; +;; +;;extensions to let user access and modify values + + + + + +;;; nth-frame-info, set-nth-frame-info, & frame-lfun are in "inspector;new-backtrace" + + + + + + +(defparameter *saved-register-count+1* + (1+ *saved-register-count*)) + + + +(defparameter *saved-register-numbers* + #+x8664-target #(wrong) + #+ppc-target #(31 30 29 28 27 26 25 24)) + +;;; Don't do unbound checks in compiled code +(declaim (type t *saved-register-count* *saved-register-count+1* + *saved-register-names* *saved-register-numbers*)) + +(defmacro %cons-saved-register-vector () + `(make-array (the fixnum *saved-register-count+1*) :initial-element nil)) + +(defun copy-srv (from-srv &optional to-srv) + (if to-srv + (if (eq from-srv to-srv) + to-srv + (dotimes (i (uvsize from-srv) to-srv) + (setf (uvref to-srv i) (uvref from-srv i)))) + (copy-uvector from-srv))) + +(defmacro srv.unresolved (saved-register-vector) + `(svref ,saved-register-vector 0)) + +(defmacro srv.register-n (saved-register-vector n) + `(svref ,saved-register-vector (1+ ,n))) + +;;; This isn't quite right - has to look at all functions on stack, +;;; not just those that saved VSPs. + + +(defun frame-restartable-p (target &optional context) + (multiple-value-bind (frame last-catch srv) (last-catch-since-saved-vars target context) + (when frame + (loop + (when (null frame) + (return-from frame-restartable-p nil)) + (when (eq frame target) (return)) + (multiple-value-setq (frame last-catch srv) + (ccl::parent-frame-saved-vars context frame last-catch srv srv))) + (when (and srv (eql 0 (srv.unresolved srv))) + (setf (srv.unresolved srv) last-catch) + srv)))) + + +;;; get the saved register addresses for this frame +;;; still need to worry about this unresolved business +;;; could share some code with parent-frame-saved-vars +(defun my-saved-vars (frame &optional (srv-out (%cons-saved-register-vector))) + (let ((unresolved 0)) + (multiple-value-bind (lfun pc) (cfp-lfun frame) + (if lfun + (multiple-value-bind (mask where) (registers-used-by lfun pc) + (when mask + (if (not where) + (setq unresolved (%ilogior unresolved mask)) + (let ((vsp (- (frame-vsp frame) where (1- (logcount mask)))) + (j *saved-register-count*)) + (declare (fixnum j)) + (dotimes (i j) + (declare (fixnum i)) + (when (%ilogbitp (decf j) mask) + (setf (srv.register-n srv-out i) vsp + vsp (1+ vsp) + unresolved (%ilogand unresolved (%ilognot (%ilsl j 1)))))))))) + (setq unresolved (1- (ash 1 *saved-register-count*))))) + (setf (srv.unresolved srv-out) unresolved) + srv-out)) + +(defun parent-frame-saved-vars + (context frame last-catch srv &optional (srv-out (%cons-saved-register-vector))) + (copy-srv srv srv-out) + (let* ((parent (and frame (parent-frame frame context))) + (grand-parent (and parent (parent-frame parent context)))) + (when grand-parent + (loop (let ((next-catch (and last-catch (next-catch last-catch)))) + ;(declare (ignore next-catch)) + (if (and next-catch (%stack< (catch-frame-sp next-catch) grand-parent context)) + (progn + (setf last-catch next-catch + (srv.unresolved srv-out) 0) + (dotimes (i *saved-register-count*) + (setf (srv.register-n srv i) nil))) + (return)))) + (lookup-registers parent context grand-parent srv-out) + (values parent last-catch srv-out)))) + +(defun lookup-registers (parent context grand-parent srv-out) + (unless (or (eql (frame-vsp grand-parent) 0) + (let ((gg-parent (parent-frame grand-parent context))) + (eql (frame-vsp gg-parent) 0))) + (multiple-value-bind (lfun pc) (cfp-lfun parent) + (when lfun + (multiple-value-bind (mask where) (registers-used-by lfun pc) + (when mask + (locally (declare (fixnum mask)) + (if (not where) + (setf (srv.unresolved srv-out) (%ilogior (srv.unresolved srv-out) mask)) + (let* ((grand-parent-vsp (frame-vsp grand-parent))) + + (let ((vsp (- grand-parent-vsp where 1)) + (j *saved-register-count*)) + (declare (fixnum j)) + (dotimes (i j) + (declare (fixnum i)) + (when (%ilogbitp (decf j) mask) + (setf (srv.register-n srv-out i) vsp + vsp (1- vsp) + (srv.unresolved srv-out) + (%ilogand (srv.unresolved srv-out) (%ilognot (%ilsl j 1)))))))))))))))) + +;;; initialization for looping on parent-frame-saved-vars +(defun last-catch-since-saved-vars (frame context) + (let* ((parent (parent-frame frame context)) + (last-catch (and parent (last-catch-since parent context)))) + (when last-catch + (let ((frame (catch-frame-sp last-catch)) + (srv (%cons-saved-register-vector))) + (setf (srv.unresolved srv) 0) + (let* ((parent (parent-frame frame context)) + (child (and parent (child-frame parent context)))) + (when child + (lookup-registers child context parent srv)) + (values child last-catch srv)))))) + +;;; Returns 2 values: +;;; mask srv +;;; The mask says which registers are used at PC in LFUN. srv is a +;;; saved-register-vector whose register contents are the register +;;; values registers whose bits are not set in MASK or set in +;;; UNRESOLVED will be returned as NIL. + +(defun saved-register-values + (lfun pc child last-catch srv &optional (srv-out (%cons-saved-register-vector))) + (declare (ignore child)) + (cond ((null srv-out) (setq srv-out (copy-uvector srv))) + ((eq srv-out srv)) + (t (dotimes (i (the fixnum (uvsize srv))) + (setf (uvref srv-out i) (uvref srv i))))) + (let ((mask (or (registers-used-by lfun pc) 0)) + (unresolved (srv.unresolved srv)) + (j *saved-register-count*)) + (declare (fixnum j)) + (dotimes (i j) + (declare (fixnum i)) + (setf (srv.register-n srv-out i) + (and (%ilogbitp (setq j (%i- j 1)) mask) + (not (%ilogbitp j unresolved)) + (safe-cell-value (get-register-value (srv.register-n srv i) last-catch j))))) + (setf (srv.unresolved srv-out) mask) + (values mask srv-out))) + +; Set the nth saved register to value. +(defun set-saved-register (value n lfun pc child last-catch srv) + (declare (ignore lfun pc child) (dynamic-extent)) + (let ((j (- target::node-size n)) + (unresolved (srv.unresolved srv)) + (addr (srv.register-n srv n))) + (when (logbitp j unresolved) + (error "Can't set register ~S to ~S" n value)) + (set-register-value value addr last-catch j)) + value) + + + + + +(defun return-from-nth-frame (n &rest values) + (apply-in-nth-frame n #'values values)) + +(defun apply-in-nth-frame (n fn arglist) + (let* ((bt-info (car *backtrace-contexts*))) + (and bt-info + (let* ((frame (nth-frame nil (bt.youngest bt-info) n bt-info))) + (and frame (apply-in-frame frame fn arglist))))) + (format t "Can't return to frame ~d ." n)) + +;;; This method is shadowed by one for the backtrace window. +(defmethod nth-frame (w target n context) + (declare (ignore w)) + (and target (dotimes (i n target) + (declare (fixnum i)) + (unless (setq target (parent-frame target context)) (return nil))))) + +; If this returns at all, it's because the frame wasn't restartable. +(defun apply-in-frame (frame fn arglist &optional context) + (let* ((srv (frame-restartable-p frame context)) + (target-sp (and srv (srv.unresolved srv)))) + (if target-sp + (apply-in-frame-internal context frame fn arglist srv)))) + +(defun apply-in-frame-internal (context frame fn arglist srv) + (let* ((tcr (if context (bt.tcr context) (%current-tcr)))) + (if (eq tcr (%current-tcr)) + (%apply-in-frame frame fn arglist srv) + (let ((process (tcr->process tcr))) + (if process + (process-interrupt + process + #'%apply-in-frame + frame fn arglist srv) + (error "Can't find active process for ~s" tcr)))))) + + +(defun return-from-frame (frame &rest values) + (apply-in-frame frame #'values values nil)) + + +;;; (srv.unresolved srv) is the last catch frame, left there by +;;; frame-restartable-p The registers in srv are locations of +;;; variables saved between frame and that catch frame. +(defun %apply-in-frame (frame fn arglist srv) + (declare (fixnum frame)) + (let* ((catch (srv.unresolved srv)) + (tsp-count 0) + (tcr (%current-tcr)) + (parent (parent-frame frame tcr)) + (vsp (frame-vsp parent)) + (catch-top (%catch-top tcr)) + (db-link (%svref catch target::catch-frame.db-link-cell)) + (catch-count 0)) + (declare (fixnum parent vsp db-link catch-count)) + ;; Figure out how many catch frames to throw through + (loop + (unless catch-top + (error "Didn't find catch frame")) + (incf catch-count) + (when (eq catch-top catch) + (return)) + (setq catch-top (next-catch catch-top))) + ;; Figure out where the db-link should be + (loop + (when (or (eql db-link 0) (>= db-link vsp)) + (return)) + (setq db-link (%fixnum-ref db-link))) + ;; Figure out how many TSP frames to pop after throwing. + (let ((sp (catch-frame-sp catch))) + (loop + (multiple-value-bind (f pc) (cfp-lfun sp) + (when f (incf tsp-count (active-tsp-count f pc)))) + (setq sp (parent-frame sp tcr)) + (when (eql sp parent) (return)) + (unless sp (error "Didn't find frame: ~s" frame)))) + #+debug + (cerror "Continue" "(apply-in-frame ~s ~s ~s ~s ~s ~s ~s)" + catch-count srv tsp-count db-link parent fn arglist) + (%%apply-in-frame catch-count srv tsp-count db-link parent fn arglist))) + + + + +;;;;;;;;;;;;;;;;;;;;;;; +;;; +;;; Code to determine how many tsp frames to pop. +;;; This is done by parsing the code. +;;; active-tsp-count is the entry point below. +;;; + +(defstruct (branch-tree (:print-function print-branch-tree)) + first-instruction + last-instruction + branch-target ; a branch-tree or nil + fall-through) ; a branch-tree or nil + +(defun print-branch-tree (tree stream print-level) + (declare (ignore print-level)) + (print-unreadable-object (tree stream :type t :identity t) + (format stream "~s-~s" + (branch-tree-first-pc tree) + (branch-tree-last-pc tree)))) + +(defun branch-tree-first-pc (branch-tree) + (let ((first (branch-tree-first-instruction branch-tree))) + (and first (instruction-element-address first)))) + +(defun branch-tree-last-pc (branch-tree) + (let ((last (branch-tree-last-instruction branch-tree))) + (if last + (instruction-element-address last) + (branch-tree-first-pc branch-tree)))) + +(defun branch-tree-contains-pc-p (branch-tree pc) + (<= (branch-tree-first-pc branch-tree) + pc + (branch-tree-last-pc branch-tree))) + +(defvar *branch-tree-hash* + (make-hash-table :test 'eq :weak :value)) + +(defun get-branch-tree (function) + (or (gethash function *branch-tree-hash*) + (let* ((dll (function-to-dll-header function)) + (tree (dll-to-branch-tree dll))) + (setf (gethash function *branch-tree-hash*) tree)))) + +; Return the number of TSP frames that will be active after throwing out +; of all the active catch frames in function at pc. +; PC is a byte address, a multiple of 4. +(defun active-tsp-count (function pc) + (setq function + (require-type + (if (symbolp function) + (symbol-function function) + function) + 'compiled-function)) + (let* ((tree (get-branch-tree function)) + (visited nil)) + (labels ((find-pc (branch path) + (unless (memq branch visited) + (push branch path) + (if (branch-tree-contains-pc-p branch pc) + path + (let ((target (branch-tree-branch-target branch)) + (fall-through (branch-tree-fall-through branch))) + (push branch visited) + (if fall-through + (or (and target (find-pc target path)) + (find-pc fall-through path)) + (and target (find-pc target path)))))))) + (let* ((path (nreverse (find-pc tree nil))) + (last-tree (car (last path))) + (catch-count 0) + (tsp-count 0)) + (unless path + (error "Can't find path to pc: ~s in ~s" pc function)) + (dolist (tree path) + (let ((next (branch-tree-first-instruction tree)) + (last (branch-tree-last-instruction tree))) + (loop + (when (and (eq tree last-tree) + (eql pc (instruction-element-address next))) + ; If the instruction before the current one is an ff-call, + ; then callback pushed a TSP frame. + #| ; Not any more + (when (ff-call-instruction-p (dll-node-pred next)) + (incf tsp-count)) + |# + (return)) + (multiple-value-bind (type target fall-through count) (categorize-instruction next) + (declare (ignore target fall-through)) + (case type + (:tsp-push + (when (eql catch-count 0) + (incf tsp-count count))) + (:tsp-pop + (when (eql catch-count 0) + (decf tsp-count count))) + ((:catch :unwind-protect) + (incf catch-count)) + (:throw + (decf catch-count count)))) + (when (eq next last) + (return)) + (setq next (dll-node-succ next))))) + tsp-count)))) + + +(defun dll-to-branch-tree (dll) + (let* ((hash (make-hash-table :test 'eql)) ; start-pc -> branch-tree + (res (collect-branch-tree (dll-header-first dll) dll hash)) + (did-something nil)) + (loop + (setq did-something nil) + (let ((mapper #'(lambda (key value) + (declare (ignore key)) + (flet ((maybe-collect (pc) + (when (integerp pc) + (let ((target-tree (gethash pc hash))) + (if target-tree + target-tree + (progn + (collect-branch-tree (dll-pc->instr dll pc) dll hash) + (setq did-something t) + nil)))))) + (declare (dynamic-extent #'maybe-collect)) + (let ((target-tree (maybe-collect (branch-tree-branch-target value)))) + (when target-tree (setf (branch-tree-branch-target value) target-tree))) + (let ((target-tree (maybe-collect (branch-tree-fall-through value)))) + (when target-tree (setf (branch-tree-fall-through value) target-tree))))))) + (declare (dynamic-extent mapper)) + (maphash mapper hash)) + (unless did-something (return))) + ; To be totally correct, we should fix up the trees containing + ; the BLR instruction for unwind-protect cleanups, but none + ; of the users of this code yet care that it appears that the code + ; stops there. + res)) + +(defun collect-branch-tree (instr dll hash) + (unless (eq instr dll) + (let ((tree (make-branch-tree :first-instruction instr)) + (pred nil) + (next instr)) + (setf (gethash (instruction-element-address instr) hash) + tree) + (loop + (when (eq next dll) + (setf (branch-tree-last-instruction tree) pred) + (return)) + (multiple-value-bind (type target fall-through) (categorize-instruction next) + (case type + (:label + (when pred + (setf (branch-tree-last-instruction tree) pred + (branch-tree-fall-through tree) (instruction-element-address next)) + (return))) + ((:branch :catch :unwind-protect) + (setf (branch-tree-last-instruction tree) next + (branch-tree-branch-target tree) target + (branch-tree-fall-through tree) fall-through) + (return)))) + (setq pred next + next (dll-node-succ next))) + tree))) + +;;; Returns 4 values: +;;; 1) type: one of :regular, :label, :branch, :catch, :unwind-protect, :throw, :tsp-push, :tsp-pop +;;; 2) branch target (or catch or unwind-protect cleanup) +;;; 3) branch-fallthrough (or catch or unwind-protect body) +;;; 4) Count for throw, tsp-push, tsp-pop +(defun categorize-instruction (instr) + (etypecase instr + (lap-label :label) + (lap-instruction + (let* ((opcode (lap-instruction-opcode instr)) + (opcode-p (typep opcode 'opcode)) + (name (if opcode-p (opcode-name opcode) opcode)) + (pc (lap-instruction-address instr)) + (operands (lap-instruction-parsed-operands instr))) + (cond ((equalp name "bla") + (let ((subprim (car operands))) + (case subprim + (.SPmkunwind + (values :unwind-protect (+ pc 4) (+ pc 8))) + ((.SPmkcatch1v .SPmkcatchmv) + (values :catch (+ pc 4) (+ pc 8))) + (.SPthrow + (values :branch nil nil)) + ((.SPnthrowvalues .SPnthrow1value) + (let* ((prev-instr (require-type (lap-instruction-pred instr) + 'lap-instruction)) + (prev-name (opcode-name (lap-instruction-opcode prev-instr))) + (prev-operands (lap-instruction-parsed-operands prev-instr))) + ; Maybe we should recognize the other possible outputs of ppc2-lwi, but I + ; can't imagine we'll ever see them + (unless (and (equalp prev-name "li") + (equalp (car prev-operands) "imm0")) + (error "Can't determine throw count for ~s" instr)) + (values :throw nil (+ pc 4) (ash (cadr prev-operands) (- target::fixnum-shift))))) + ((.SPprogvsave + .SPstack-rest-arg .SPreq-stack-rest-arg .SPstack-cons-rest-arg + .SPmakestackblock .SPmakestackblock0 .SPmakestacklist .SPstkgvector + .SPstkconslist .SPstkconslist-star + .SPmkstackv .SPstack-misc-alloc .SPstack-misc-alloc-init + .SPstkvcell0 .SPstkvcellvsp + .SPsave-values) + (values :tsp-push nil nil 1)) + (.SPrecover-values + (values :tsp-pop nil nil 1)) + (t :regular)))) + ((or (equalp name "lwz") (equalp name "addi")) + (if (equalp (car operands) "tsp") + (values :tsp-pop nil nil 1) + :regular)) + ((equalp name "stwu") + (if (equalp (car operands) "tsp") + (values :tsp-push nil nil 1) + :regular)) + ((member name '("ba" "blr" "bctr") :test 'equalp) + (values :branch nil nil)) + ; It would probably be faster to determine the branch address by adding the PC and the offset. + ((equalp name "b") + (values :branch (branch-label-address instr (car (last operands))) nil)) + ((and opcode-p (eql (opcode-majorop opcode) 16)) + (values :branch (branch-label-address instr (car (last operands))) (+ pc 4))) + (t :regular)))))) + +(defun branch-label-address (instr label-name &aux (next instr)) + (loop + (setq next (dll-node-succ next)) + (when (eq next instr) + (error "Couldn't find label ~s" label-name)) + (when (and (typep next 'lap-label) + (eq (lap-label-name next) label-name)) + (return (instruction-element-address next))))) + +(defun dll-pc->instr (dll pc) + (let ((next (dll-node-succ dll))) + (loop + (when (eq next dll) + (error "Couldn't find pc: ~s in ~s" pc dll)) + (when (eql (instruction-element-address next) pc) + (return next)) + (setq next (dll-node-succ next))))) + +(defun exception-frame-p (frame) + (fake-stack-frame-p frame)) + +(defun arg-check-call-arguments (frame function) + (declare (ignore function)) + (xp-argument-list (%fake-stack-frame.xp frame))) Index: /branches/new-random/lib/ppc-init-ccl.lisp =================================================================== --- /branches/new-random/lib/ppc-init-ccl.lisp (revision 13309) +++ /branches/new-random/lib/ppc-init-ccl.lisp (revision 13309) @@ -0,0 +1,64 @@ +;;;-*-Mode: LISP; Package: CCL -*- +;;; +;;; Copyright (C) 2009 Clozure Associates +;;; Copyright (C) 1994-2001 Digitool, Inc +;;; This file is part of Clozure CL. +;;; +;;; Clozure CL is licensed under the terms of the Lisp Lesser GNU Public +;;; License , known as the LLGPL and distributed with Clozure CL as the +;;; file "LICENSE". The LLGPL consists of a preamble and the LGPL, +;;; which is distributed with Clozure CL as the file "LGPL". Where these +;;; conflict, the preamble takes precedence. +;;; +a;;; Opensourced MCL 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 LLGPL is also available online at +;;; http://opensource.franz.com/preamble.html + +(in-package "CCL") + +;(setq *save-local-symbols* t) + +#+ppc-target +(progn +(breaker) +(format t "~&Initializing Macintosh Common Lisp ...") +(setq *load-verbose* t) +(setq *warn-if-redefine* nil) +(setq *.fasl-pathname* (pathname ".pfsl")) ; leave it? +(setq *.pfsl-pathname* (pathname ".pfsl")) +(setq *fasl-target* :ppc) +(setq *save-exit-functions* nil) + +(require 'compile-ccl) +(ppc-load-ccl) + +(setq *warn-if-redefine* t) +(setq *load-verbose* nil) +(format t "~&Macintosh Common Lisp Loaded") + +(defun save-mcl-libraries (&optional (suffix "")) + (save-library (concatenate 'string "ccl:ccl;pmcl-compiler" suffix) + "pmcl-compiler" *nx-start* *nx-end*) + ; More here ? + ; Pick up the leftovers ... + (save-library (concatenate 'string "ccl:ccl;pmcl-library" suffix) + "pmcl-library" nil nil)) + +(defun save-it (&optional (suffix "")) + (save-mcl-libraries (and suffix (concatenate 'string "-" suffix))) + (let ((prefix "ccl:ccl;PPCCL")) + (save-application (if suffix + (concatenate 'string prefix " " suffix) + prefix)))) + +;(save-application "ccl;CCL") +) +; End of init-ccl.lisp Index: /branches/new-random/lib/ppcenv.lisp =================================================================== --- /branches/new-random/lib/ppcenv.lisp (revision 13309) +++ /branches/new-random/lib/ppcenv.lisp (revision 13309) @@ -0,0 +1,93 @@ +; -*- Mode:Lisp; Package:CCL; -*- +;;; +;;; Copyright (C) 2009 Clozure Associates +;;; Copyright (C) 1994-2001 Digitool, Inc +;;; This file is part of Clozure CL. +;;; +;;; Clozure CL is licensed under the terms of the Lisp Lesser GNU Public +;;; License , known as the LLGPL and distributed with Clozure CL as the +;;; file "LICENSE". The LLGPL consists of a preamble and the LGPL, +;;; which is distributed with Clozure CL as the file "LGPL". Where these +;;; conflict, the preamble takes precedence. +;;; +;;; Clozure CL is referenced in the preamble as the "LIBRARY." +;;; +;;; The LLGPL is also available online at +;;; http://opensource.franz.com/preamble.html + +(in-package "CCL") + +(defconstant $numppcsaveregs 8) +(defconstant $numppcargregs 3) + + +(defconstant ppc-nonvolatile-registers-mask + (logior (ash 1 ppc::save0) + (ash 1 ppc::save1) + (ash 1 ppc::save2) + (ash 1 ppc::save3) + (ash 1 ppc::save4) + (ash 1 ppc::save5) + (ash 1 ppc::save6) + (ash 1 ppc::save7))) + +(defconstant ppc-arg-registers-mask + (logior (ash 1 ppc::arg_z) + (ash 1 ppc::arg_y) + (ash 1 ppc::arg_x))) + +(defconstant ppc-temp-registers-mask + (logior (ash 1 ppc::temp0) + (ash 1 ppc::temp1) + (ash 1 ppc::temp2) + (ash 1 ppc::temp3))) + + +(defconstant ppc-tagged-registers-mask + (logior ppc-temp-registers-mask + ppc-arg-registers-mask + ppc-nonvolatile-registers-mask)) + + + +(defconstant ppc-temp-node-regs + (make-mask ppc::temp0 + ppc::temp1 + ppc::temp2 + ppc::temp3 + ppc::arg_x + ppc::arg_y + ppc::arg_z)) + +(defconstant ppc-nonvolatile-node-regs + (make-mask ppc::save0 + ppc::save1 + ppc::save2 + ppc::save3 + ppc::save4 + ppc::save5 + ppc::save6 + ppc::save7)) + + +(defconstant ppc-node-regs (logior ppc-temp-node-regs ppc-nonvolatile-node-regs)) + +(defconstant ppc-imm-regs (make-mask + ppc::imm0 + ppc::imm1 + ppc::imm2 + ppc::imm3 + ppc::imm4 + ppc::imm5)) + +(defconstant ppc-temp-fp-regs (1- (ash 1 ppc::fp14))) + +(defconstant ppc-cr-fields + (make-mask 0 (ash 4 -2) (ash 8 -2) (ash 12 -2) (ash 16 -2) (ash 20 -2) (ash 24 -2) (ash 28 -2))) + + + +(defconstant $undo-ppc-c-frame 16) + + +(ccl::provide "PPCENV") Index: /branches/new-random/lib/pprint.lisp =================================================================== --- /branches/new-random/lib/pprint.lisp (revision 13309) +++ /branches/new-random/lib/pprint.lisp (revision 13309) @@ -0,0 +1,2035 @@ +;-*-syntax:COMMON-LISP;Package:"CCL"-*- + +;; Change History (most recent first): +;; 2 4/8/97 akh pretty-loop dont loop +;; 3 12/13/95 Alice Hartley no call compiler at load time +;; 3 3/2/95 akh will promote strings to fat strings if needed +;; (do not edit before this line!!) + + +;------------------------------------------------------------------------ + +;Copyright 1989,1990 by the Massachusetts Institute of Technology, Cambridge, +;Massachusetts. + +;Permission to use, copy, modify, and distribute this software and its +;documentation for any purpose and without fee is hereby granted, +;provided that this copyright and permission notice appear in all +;copies and supporting documentation, and that the name of M.I.T. not +;be used in advertising or publicity pertaining to distribution of the +;software without specific, written prior permission. M.I.T. makes no +;representations about the suitability of this software for any +;purpose. It is provided "as is" without express or implied warranty. + +; M.I.T. DISCLAIMS ALL WARRANTIES WITH REGARD TO THIS SOFTWARE, INCLUDING +; ALL IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS, IN NO EVENT SHALL +; M.I.T. BE LIABLE FOR ANY SPECIAL, INDIRECT OR CONSEQUENTIAL DAMAGES OR +; ANY DAMAGES WHATSOEVER RESULTING FROM LOSS OF USE, DATA OR PROFITS, +; WHETHER IN AN ACTION OF CONTRACT, NEGLIGENCE OR OTHER TORTIOUS ACTION, +; ARISING OUT OF OR IN CONNECTION WITH THE USE OR PERFORMANCE OF THIS +; SOFTWARE. + +;------------------------------------------------------------------------ + +;This file "XP.LISP" implements an efficient pretty printer for Common +;Lisp. The functions in this file are documented fully in MIT/AIM-1102a, July +;1989. This report can be obtained by sending $3.25 to + +; Publications +; MIT AI Laboratory +; 545 Tech. Sq. +; Cambridge MA 02139 + +;This file attempts to be as compatible with pure Common Lisp as possible. +;It has been tested on the following Common Lisps to date (7/31/89). +; Symbolics CL version 7 (does not work in version 6), +; LUCID CL version 3.0.2 on a sun. +; Allegro CL version 1.2.1 on a Macintosh. +; CMU CL. + +;The companion file "XPTEST.LISP" contains a set of 600+ tests. You should +;run these tests after the first time you compile this file on a new system. + +;The companion file "XPDOC.TXT" contains brief documentation +; 04/05/97 akh pretty-loop fix for *print-level* exceeded +; 10/26/95 slh %gvector -> %istruct +; 08/26/93 bill indentation +; -------- 3.0d12 +; 06/26/93 alice stream-fresh-line (xp-stream) was producing premature newlines +; 05/24/93 alice *free-xps* and *free-circularity-hash-tables* are global +; 03/04/93 alice set *error-print-circle* to T +; 02/23/93 alice get-printer - look in others table before def.., with.. hack +; 02/15/93 alice don't unwind-protect in pprint-logical-block+ +; 12/21/92 alice lets not print loop as #' +; 06/23/92 alice change set-pprint-dispatch+ and priority-> so '(0) is less than 0 +;--------------- 2.0 +; 02/22/92 (alice from "post 2.0f2c5:pprint-defmethod-patch") fix DEFMETHOD-LIKE. +; -------- 2.0f2c5 +; 01/29/92 gb pretty-structure calls structure-print-function. +; -------- 2.0f2 +; 10/11/91 alice dont print generic-function as #' +; 10/09/91 alice write+ don't deal with structures and arrays - prior fix was brain dead +; p.s. technically we shouldn't special case strings, fixnums and symbols either +; 10/03/91 alice write+ - if print-object method for structure use it. +; 09/25/91 alice fix circularity-process so we can rebind *print-circle* in mid stream +; 09/25/91 alice pretty-structure - no dangling space if no slots +; 09/24/91 alice fix pretty-structure bogus keyword printing +; 09/11/91 alice keep first pass output until first circularity in case no circularities +; 09/09/91 alice fix print circle in case circularity detected after first line (geez) +; dont die if *print-pprint-dispatch* is nil +;--------------- 2.0b3 +; 08/21/91 gb xp-stream-stream +; 07/21/91 gb def-accessors vice defstruct. +; 07/09/91 alice allow write+ to tail call +; 07/01/91 bind level and length as (f *print-readably*) +; 07/01/91 generic-function & reinstate some MLY hacks for "def.." "with-.." etc. +; 06/24/91 added pretty-structure +; 05/22/91 Modified for MCL 2.0b +;;;;;;;;;;;;;; +;;; lisp: => cl: +;;; string-char => character (or base-character?) +;;; #-ccl-2 compiled format and format and much else +;;; put the xp-stream in the xp-structure +;;; write-char => write-char+ in pretty-loop +;;; nuke *last-abbreviated-printing* +;;; Teach it about fred-special-indent-alist +;;; in fred-alist 2 means defun-like, 0 is progn-like +;;; 3 is defsetf-print , 1 is block-like +;;; Put circularity table & number in the structure? - didn't do it +;;; Nuke the xp package +;;; Added progn-print +;;; MAYBELAB take xp-stream or xp-structure +;;; Gave up on #+/#-ccl-2 +;;; Could save a few hundred bytes by (funcall (formatter ...)) to (format ... )) - maybe not +;;; The dispatch table could use some compacting: done! +;;; an entry contains test: 0 - must be some predicate if not of the other form +;;; fn: ok +;;; full-spec: '((0)(cons (member defvar))) +;;; Nuke *print-shared* and *parents* +;;; This version has a new special *xp-current-object* but doesnt gratuitously cons. +;;; Fixed circle doing it twice when it needn't (what does this break?) +;;; member => memq +;;; Apply optimizations as Mly did in prior conversion, i.e. liberal doses +;;; of %i+, (declare (fixnum ...)), dont fetch a stucture field 15 times +;;; when once will suffice, no char=, fewer position & find +;;; Now about same speed as old one. (actually 10% slower) & it conses less +;;; In pprint-dispatch just store the function if (cons (member blah)) & (0) or 0. +;;; nuke some entries in pprint-dispatch where same info is in fred-special-indent-alist +;;; Size is down from 23K larger to 18K larger. +;;; maybe-print-fast iff readtable-case is :upcase +;;; add defmethod-like for guess what +;;; nuke *abbreviation-happened* + + + +(in-package "CCL") + +(defvar *ipd* nil ;see initialization at end of file. + "initial print dispatch table.") + +(eval-when (:compile-toplevel :execute) + (declaim (inline xp-structure-p))) + +(defun xp-structure-p (x) + (istruct-typep x 'xp-structure)) + + +(defun entry-p (x) + (istruct-typep x 'entry)) + + + +;default (bad) definitions for the non-portable functions + +(eval-when (:execute :load-toplevel :compile-toplevel) +(defun structure-type-p (x) (structurep x)) +(defun output-width (&optional (s *standard-output*)) + (when (streamp s)(line-length s))) +(defun output-position (&optional (s *standard-output*)) + (when (streamp s)(column s))) +) + +(defvar *logical-block-p* nil + "True if currently inside a logical block.") + +(defvar *locating-circularities* nil + "Integer if making a first pass over things to identify circularities. + Integer used as counter for #n= syntax.") + +(def-standard-initial-binding *free-circularity-hash-tables* nil) + +(defun get-circularity-hash-table () + (let ((table (pop *free-circularity-hash-tables*))) + (if table table (make-hash-table :test 'eq)))) + +;If you call this, then the table gets efficiently recycled. +(defun free-circularity-hash-table (table) + (clrhash table) + (pushnew table *free-circularity-hash-tables*)) + + + +; ---- DISPATCHING ---- + +(cl:defstruct (pprint-dispatch-table (:conc-name nil) (:copier nil)) + (conses-with-cars (make-hash-table :test #'eq) :type hash-table) + (structures (make-hash-table :test #'eq) :type (or null hash-table)) + (others nil :type list)) + +;The list and the hash-tables contain entries of the +;following form. When stored in the hash tables, the test entry is +;the number of entries in the OTHERS list that have a higher priority. + +(defun make-entry (&key test fn full-spec) + (%istruct 'entry test fn full-spec)) + +(defun copy-pprint-dispatch (&optional (table *print-pprint-dispatch*)) + (let* ((table (if (null table) + *IPD* + (require-type table '(or nil pprint-dispatch-table)))) + (new-conses-with-cars + (make-hash-table :test #'eq + :size (max (hash-table-count (conses-with-cars table)) 32))) + (new-structures NIL)) + (maphash #'(lambda (key value) + (setf (gethash key new-conses-with-cars) + (if (istruct-typep value 'entry)(copy-uvector value) value))) + (conses-with-cars table)) + (make-pprint-dispatch-table + :conses-with-cars new-conses-with-cars + :structures new-structures + :others (copy-list (others table))))) + + +(defun set-pprint-dispatch (type-specifier function + &optional (priority 0) (table *print-pprint-dispatch*)) + (when (or (not (numberp priority)) (complexp priority)) + (error "invalid PRIORITY argument ~A to SET-PPRINT-DISPATCH" priority)) + (set-pprint-dispatch+ type-specifier function priority table)) + +(defun set-pprint-dispatch+ (type-specifier function priority table) + (let* ((category (specifier-category type-specifier)) + (pred + (if (not (eq category 'other)) nil + (let ((pred (specifier-fn type-specifier))) + (if (symbolp pred) + (symbol-function pred) + ; checking for (lambda (x) (foo x)) => #'foo + (if (and (consp (caddr pred)) + (symbolp (caaddr pred)) + (equal (cdaddr pred) '(x))) + (symbol-function (caaddr pred)) + ; calling the compiler at load time is an indictable offense + (compile nil pred)))))) + (entry (if function (make-entry :test pred + :fn function + :full-spec (list priority type-specifier))))) + (case category + (cons-with-car + (let ((key (cadadr type-specifier)) ;(cons (member FOO)) + (cons-tbl (conses-with-cars table))) + (cond ((null function) (remhash key cons-tbl)) + (T (let ((num + (count-if #'(lambda (e) + (priority-> e priority)) + (others table)))) + (cond ((and (or ;(eq priority 0) + (and (consp priority)(eq (%car priority) 0))) + (eq num 0)) + (setq entry function)) + (t (setf (entry-test entry) num))) + (setf (gethash key cons-tbl) entry)))))) + (T ;other + (let ((old (car (member type-specifier (others table) :test #'equal + :key #'(lambda (e) (cadr (entry-full-spec e))))))) + (when old + (setf (others table) (delete old (others table))) + (adjust-counts table (car (entry-full-spec old)) -1))) + (when entry + (let ((others (cons nil (others table)))) + (do ((l others (cdr l))) + ((null (cdr l)) (rplacd l (list entry))) + (when (priority-> priority (car (entry-full-spec (cadr l)))) + (rplacd l (cons entry (cdr l))) + (return nil))) + (setf (others table) (cdr others))) + (adjust-counts table priority 1))))) + nil) + +(defun priority-> (entry-x entry-y) + (flet ((foo (e) + (cond ((istruct-typep e 'entry)(car (entry-full-spec e))) + ((or (numberp e)(consp e)) e) + (t '(0))))) + (let ((x (foo entry-x)) + (y (foo entry-y))) + (if (consp x) + (if (consp y) (> (car x) (car y)) nil) + (if (consp y) T (> x y)))))) + + + +(defun adjust-counts (table priority delta) + (maphash #'(lambda (key value) + (when (priority-> priority value) + (when (not (istruct-typep value 'entry)) + (setf (gethash key (conses-with-cars table)) + (setq value (make-entry :fn value :test 0 :full-spec '(0))))) + (incf (entry-test value) delta))) + (conses-with-cars table))) + +(defun pprint-dispatch (object &optional (table *print-pprint-dispatch*)) + (flet ((non-pretty-print (s object) + (write-not-pretty s object + (if (get-*print-frob* '*print-level*) + (- *print-level* *current-level*)) + nil nil))) + (when (null table) (setq table *IPD*)) + (let ((fn (get-printer object table))) + (values (or fn #'non-pretty-print) (not (null fn)))))) + +(defun get-printer (object table) + (when (null table)(setq table *IPD*)) + (let* (entry) + (cond ((consp object) + (setq entry (gethash (%car object) (conses-with-cars table))) + (when (not entry) + (setq entry (find object (others table) :test #'fits)) + (if entry + (setq entry (entry-fn entry))))) + (nil (setq entry (gethash (type-of object) (structures table))))) + (if (not entry) + (setq entry (find object (others table) :test #'fits)) + (if (istruct-typep entry 'entry) + (let ((test (entry-test entry))) + (when (numberp test) + (do ((i test (1- i)) + (l (others table) (cdr l))) + ((zerop i)) + (when (fits object (car l)) (setq entry (car l)) (return nil))))))) + (when entry + (if (istruct-typep entry 'entry)(entry-fn entry) entry)))) + +(defun fits (obj entry) + (funcall (entry-test entry) obj)) + +(defun specifier-category (spec) + (cond ((and (consp spec) + (eq (car spec) 'cons) + (consp (cdr spec)) + (null (cddr spec)) + (consp (cadr spec)) + (eq (caadr spec) 'member) + (consp (cdadr spec)) + (null (cddadr spec))) + 'cons-with-car) + (T 'other))) + + +; lets make fewer things fns that compile at load time, esp anything +; we do - really none should +(defun specifier-fn (spec) + (if (and (consp spec)(eq (car spec) 'satisfies)(symbolp (cadr spec))) + (cadr spec) + (if (and (symbolp spec)(type-predicate spec)) ; ccl specific + (type-predicate spec) + `(lambda (x) ,(convert-body spec))))) + +(defun convert-body (spec) + (cond ((atom spec) `(typep x ',spec)) + ((member (car spec) '(and or not)) + (cons (car spec) (mapcar #'convert-body (cdr spec)))) + ((eq (car spec) 'member) + `(member x ',(copy-list (cdr spec)))) + ((eq (car spec) 'cons) + `(and (consp x) + ,@(if (cdr spec) `((let ((x (car x))) + ,(convert-body (cadr spec))))) + ,@(if (cddr spec) `((let ((x (cdr x))) + ,(convert-body (caddr spec))))))) + ((eq (car spec) 'satisfies) + `(funcall (function ,(cadr spec)) x)) + (T `(typep x ',spec)))) + + +; ---- XP STRUCTURES, AND THE INTERNAL ALGORITHM ---- + +(eval-when (:execute :compile-toplevel) ;not used at run time. + (defvar block-stack-entry-size 1) + (defvar prefix-stack-entry-size 5) + (defvar queue-entry-size 7) + (defvar buffer-entry-size 1) + (defvar prefix-entry-size 1) + (defvar suffix-entry-size 1)) + +(eval-when (:execute :load-toplevel :compile-toplevel) ;used at run time + (defvar block-stack-min-size #.(* 35. block-stack-entry-size)) + (defvar prefix-stack-min-size #.(* 30. prefix-stack-entry-size)) + (defvar queue-min-size #.(* 75. queue-entry-size)) + (defvar buffer-min-size 256.) + (defvar prefix-min-size 256.) + (defvar suffix-min-size 256.)) + +(progn + (setf (symbol-function 'xp-stream-stream) #'(lambda (s) (xp-stream s))) + + (defmethod streamp ((x xp-structure)) t) + (defmethod streamp ((x xp-stream)) t) + + (defmethod output-stream-p ((x xp-structure)) t) + (defmethod output-stream-p ((x xp-stream)) t) + + (defun make-xp-structure () + (%istruct + 'xp-structure + nil ; xp-base-stream + nil ; xp-linel + nil ; xp-line-limit + nil ; xp-line-no + nil ; xp-char-mode + nil ; xp-char-mode-counter + nil ; xp-depth-in-blocks + (make-array #.block-stack-min-size) ; xp-block-stack + nil ; xp-block-stack-ptr + (make-array #.buffer-min-size :element-type 'base-char) + ; use make-string and let it default? + ; xp-buffer + nil ; xp-charpos + nil ; xp-buffer-ptr + nil ; xp-buffer-offset + (make-array #.queue-min-size) ; xp-queue + 0 ; xp-qleft + 0 ; xp-qright + (make-array #.buffer-min-size :element-type 'base-char) + ; xp-prefix + (make-array #.prefix-stack-min-size) ; xp-prefix-stack + nil ; xp-prefix-stack-ptr + (make-array #.buffer-min-size :element-type 'base-char) + ; xp-suffix + nil ; xp-stream + nil ; xp-string-stream + )) ; XP-STRUCTURE is a built-in class. + + (defmethod write-internal-1 ((xp-struc xp-structure) object level list-kludge) + (write-internal-1 (xp-stream xp-struc) object level list-kludge)) + + + + (defun get-xp-stream (pp) + (xp-stream pp)) + ) + + + +(eval-when (:compile-toplevel :execute) +(defmacro LP<-BP (xp &optional (ptr nil)) + (if (null ptr) (setq ptr `(xp-buffer-ptr ,xp))) + `(the fixnum (%i+ ,ptr (xp-charpos ,xp)))) +(defmacro TP<-BP (xp) + `(the fixnum (%i+ (xp-buffer-ptr ,xp) (xp-buffer-offset ,xp)))) +(defmacro BP<-LP (xp ptr) + `(the fixnum (%i- ,ptr (xp-charpos ,xp)))) +(defmacro BP<-TP (xp ptr) + `(the fixnum (%i- ,ptr (xp-buffer-offset ,xp)))) +;This does not tell you the line position you were at when the TP +;was set, unless there have been no newlines or indentation output +;between ptr and the current output point. +(defmacro LP<-TP (xp ptr) + `(LP<-BP ,xp (BP<-TP ,xp ,ptr))) + +;We don't use adjustable vectors or any of that, because we seldom have +;to actually extend and non-adjustable vectors are a lot faster in +;many Common Lisps. + +(defmacro xp-check-size (FORM ptr min-size entry-size + &optional (type '(simple-array * (*)))) + `(let ((.old. ,form) + (.ptr. ,ptr)) + (declare (type ,type .old.) (type fixnum .ptr.)) + (if (and (ccl::%i> .ptr. ,(- min-size entry-size)) ;seldom haxpens + (ccl::%i> .ptr. (- (length (the ,type .old.)) ,entry-size))) + (let ((.new. ,(let ((l `(ccl::%i+ .ptr. ,(if (= entry-size 1) + 50 + (* 10 entry-size))))) + `(make-array ,l :element-type (array-element-type .old.))))) + ;;>> + (replace .new. .old.) + (setf ,form .new.)) + .old.))) + +(defmacro section-start (xp) `(svref (xp-block-stack ,xp) (xp-block-stack-ptr ,xp))) +) ; eval-when + +; ---- CCL specific METHODS -------- +(progn +(defmethod stream-write-char ((stream xp-stream) char) + (write-char+ char (slot-value stream 'xp-structure)) + char) + +(defmethod stream-write-char ((stream xp-structure) char) + (write-char+ char stream) + char) + +(defmethod stream-write-string ((stream xp-stream) string &optional (start 0) end) + (setq end (check-sequence-bounds string start end)) + (write-string+ string (slot-value stream 'xp-structure) start end) + string) + +(defmethod stream-write-string ((stream xp-structure) string &optional (start 0) end) + (setq end (check-sequence-bounds string start end)) + (write-string+ string stream start end) + string) + +; If we really don't care about the value returned then just +; plain (pprint-newline+ :fresh xp) is fine. +(defmethod stream-fresh-line ((stream xp-stream)) + (let ((xp (slot-value stream 'xp-structure))) + (attempt-to-output xp nil nil) ; was (attempt-to-output xp T T) + (prog1 (not (zerop (LP<-BP xp))) + (pprint-newline+ :fresh xp)))) + + +(defmethod stream-finish-output ((stream xp-stream)) + (attempt-to-output (slot-value stream 'xp-structure) t t)) + +(defmethod stream-force-output ((stream xp-stream)) + (attempt-to-output (slot-value stream 'xp-structure) t t) + nil) + +(defmethod stream-clear-output ((stream xp-stream)) + (let ((*locating-circularities* 1)) ;hack to prevent visible output + (attempt-to-output (slot-value stream 'xp-structure) T T)) + nil) + +(defmethod stream-line-column ((stream xp-stream)) + (LP<-BP (slot-value stream 'xp-structure))) + +(defmethod stream-line-length ((stream xp-stream)) + (xp-linel (slot-value stream 'xp-structure))) + +) + + +(defun push-block-stack (xp) + (let ((ptr (%i+ (xp-block-stack-ptr xp) #.block-stack-entry-size))) + (setf (xp-block-stack-ptr xp) ptr) + (xp-check-size (xp-block-stack xp) ptr + #.block-stack-min-size #.block-stack-entry-size))) + +(eval-when (:compile-toplevel :execute) +(defmacro prefix-ptr (xp) + `(svref (xp-prefix-stack ,xp) (xp-prefix-stack-ptr ,xp))) +(defmacro suffix-ptr (xp) + `(svref (xp-prefix-stack ,xp) (%i+ (xp-prefix-stack-ptr ,xp) 1))) +(defmacro non-blank-prefix-ptr (xp) + `(svref (xp-prefix-stack ,xp) (%i+ (xp-prefix-stack-ptr ,xp) 2))) +(defmacro initial-prefix-ptr (xp) + `(svref (xp-prefix-stack ,xp) (%i+ (xp-prefix-stack-ptr ,xp) 3))) +(defmacro section-start-line (xp) + `(svref (xp-prefix-stack ,xp) (%i+ (xp-prefix-stack-ptr ,xp) 4))) + +(defmacro stk-prefix-ptr (stk ptr) + `(svref ,stk ,ptr)) +(defmacro stk-suffix-ptr (stk ptr) + `(svref ,stk (%i+ ,ptr 1))) +(defmacro stk-non-blank-prefix-ptr (stk ptr) + `(svref ,stk (%i+ ,ptr 2))) +) ; EVAL-when + + + +; saves 100 bytes and a microsecond or 2 +(defun push-prefix-stack (xp) + (let ((old-prefix 0) + (old-suffix 0) + (old-non-blank 0) + (stack (xp-prefix-stack xp)) + (ptr (xp-prefix-stack-ptr xp))) + (declare (fixnum ptr)) + (when (>= ptr 0) + (setq old-prefix (stk-prefix-ptr stack ptr) + old-suffix (stk-suffix-ptr stack ptr) + old-non-blank (stk-non-blank-prefix-ptr stack ptr))) + (setq ptr (%i+ ptr #.prefix-stack-entry-size)) + (setf (xp-prefix-stack-ptr xp) ptr) + (setq stack + (xp-check-size (xp-prefix-stack xp) ptr + #.prefix-stack-min-size #.prefix-stack-entry-size)) + (setf (stk-prefix-ptr stack ptr) old-prefix) + (setf (stk-suffix-ptr stack ptr) old-suffix) + (setf (stk-non-blank-prefix-ptr stack ptr) old-non-blank))) + + + +(eval-when (:compile-toplevel :execute) +(defmacro Qtype (xp index) `(svref (xp-queue ,xp) ,index)) +(defmacro Qkind (xp index) `(svref (xp-queue ,xp) (1+ ,index))) +(defmacro Qpos (xp index) `(svref (xp-queue ,xp) (+ ,index 2))) +(defmacro Qdepth (xp index) `(svref (xp-queue ,xp) (+ ,index 3))) +(defmacro Qend (xp index) `(svref (xp-queue ,xp) (+ ,index 4))) +(defmacro Qoffset (xp index) `(svref (xp-queue ,xp) (+ ,index 5))) +(defmacro Qarg (xp index) `(svref (xp-queue ,xp) (+ ,index 6))) +(defmacro xpq-type (queue index) + `(svref ,queue ,index)) +(defmacro xpq-kind (queue index) + `(svref ,queue (ccl::%i+ ,index 1))) +(defmacro xpq-pos (queue index) + `(svref ,queue (ccl::%i+ ,index 2))) +(defmacro xpq-depth (queue index) + `(svref ,queue (ccl::%i+ ,index 3))) +(defmacro xpq-end (queue index) + `(svref ,queue (ccl::%i+ ,index 4))) +(defmacro xpq-offset (queue index) + `(svref ,queue (ccl::%i+ ,index 5))) +(defmacro xpq-arg (queue index) + `(svref ,queue (ccl::%i+ ,index 6))) +) ; eval-when + +;we shift the queue over rather than using a circular queue because +;that works out to be a lot faster in practice. Note, short printout +;does not ever cause a shift, and even in long printout, the queue is +;shifted left for free every time it happens to empty out. + +(defun enqueue (xp type kind &optional arg) + (let ((queue (xp-queue xp)) + (qright (ccl::%i+ (xp-qright xp) #.queue-entry-size)) + (qleft (xp-qleft xp))) + (declare (type fixnum qright qleft) (type simple-vector queue)) + (when (ccl::%i> qright #.(- queue-min-size queue-entry-size)) + ;;>> generic + (replace queue queue :start2 qleft :end2 qright) + (setf (xp-qleft xp) 0 + qright (ccl::%i- qright qleft))) + (setq queue (xp-check-size (xp-queue xp) qright + #.queue-min-size #.queue-entry-size)) + (setf (xp-qright xp) qright + (xpq-type queue qright) type + (xpq-kind queue qright) kind + (xpq-pos queue qright) (TP<-BP xp) + (xpq-depth queue qright) (xp-depth-in-blocks xp) + (xpq-end queue qright) nil + (xpq-offset queue qright) nil + (xpq-arg queue qright) arg))) + +(defmacro Qnext (index) `(%i+ ,index #.queue-entry-size)) + + + +;This maintains a list of XP structures. We save them +;so that we don't have to create new ones all of the time. +;We have separate objects so that many can be in use at once. + +;(Note should really be doing some locking here, but CL does not have the +;primitives for it. There is a tiny probability here that two different +;processes could end up trying to use the same xp-stream) + +(def-standard-initial-binding *free-xps* nil) ;free list of XP stream objects + +(defun get-pretty-print-stream (stream) + (let ((xp (without-interrupts (pop *free-xps*)))) + (when (not xp)(setq xp (make-xp-structure))) + (initialize-xp xp stream) + (let ((the-xp-stream (make-instance 'xp-stream))) + (setf (slot-value the-xp-stream 'xp-structure) xp) + (setf (xp-stream xp) the-xp-stream) ; lets be circular + the-xp-stream))) + +;If you call this, the xp-stream gets efficiently recycled. + +(defun free-pretty-print-stream (xp) + (setf (xp-base-stream xp) nil) + (pushnew xp *free-xps*)) + +;This is called to initialize things when you start pretty printing. + +(defun initialize-xp (xp stream) + (setf (xp-base-stream xp) stream) + (setf (xp-linel xp) (max 0 (cond (*print-right-margin*) + ((output-width stream)) + (T *default-right-margin*)))) + (setf (xp-line-limit xp) *print-lines*) + (setf (xp-line-no xp) 1) + (setf (xp-char-mode xp) nil) + (setf (xp-char-mode-counter xp) 0) + (setf (xp-depth-in-blocks xp) 0) + (setf (xp-block-stack-ptr xp) 0) + (setf (xp-charpos xp) (cond ((output-position stream)) (T 0))) + (setf (section-start xp) 0) + (setf (xp-buffer-ptr xp) 0) + (setf (xp-buffer-offset xp) (xp-charpos xp)) + (setf (xp-qleft xp) 0) + (setf (xp-qright xp) #.(- queue-entry-size)) + (setf (xp-prefix-stack-ptr xp) #.(- prefix-stack-entry-size)) + (let ((s (xp-string-stream xp))) + (when s (stream-position s 0))) + xp) + + +;The char-mode stuff is a bit tricky. +;one can be in one of the following modes: +;NIL no changes to characters output. +;:UP CHAR-UPCASE used. +;:DOWN CHAR-DOWNCASE used. +;:CAP0 capitalize next alphanumeric letter then switch to :DOWN. +;:CAP1 capitalize next alphanumeric letter then switch to :CAPW +;:CAPW downcase letters. When a word break letter found, switch to :CAP1. +;It is possible for ~(~) to be nested in a format string, but note that +;each mode specifies what should happen to every letter. Therefore, inner +;nested modes never have any effect. You can just ignore them. + +(defun push-char-mode (xp new-mode) + (if (zerop (xp-char-mode-counter xp)) + (setf (xp-char-mode xp) new-mode)) + (incf (xp-char-mode-counter xp))) + +(defun pop-char-mode (xp) + (decf (xp-char-mode-counter xp)) + (if (zerop (xp-char-mode-counter xp)) + (setf (xp-char-mode xp) nil))) + +;Assumes is only called when char-mode is non-nil +(defun handle-char-mode (xp char) + (case (xp-char-mode xp) + (:CAP0 (cond ((not (alphanumericp char)) char) + (T (setf (xp-char-mode xp) :DOWN) (char-upcase char)))) + (:CAP1 (cond ((not (alphanumericp char)) char) + (T (setf (xp-char-mode xp) :CAPW) (char-upcase char)))) + (:CAPW (cond ((alphanumericp char) (char-downcase char)) + (T (setf (xp-char-mode xp) :CAP1) char))) + (:UP (char-upcase char)) + (T (char-downcase char)))) ;:DOWN + +;All characters output are passed through the handler above. However, it must +;be noted that on-each-line prefixes are only processed in the context of the +;first place they appear. They stay the same later no matter what. Also +;non-literal newlines do not count as word breaks. + + +;This handles the basic outputting of characters. note + suffix means that +;the stream is known to be an XP stream, all inputs are mandatory, and no +;error checking has to be done. Suffix ++ additionally means that the +;output is guaranteed not to contain a newline char. + +(defun write-char+ (char xp) + (if (eql char #\newline) (pprint-newline+ :unconditional xp) + (write-char++ char xp))) + +(defun write-string+ (string xp start end) + (let ((sub-end nil) next-newline) + (loop (setq next-newline + (if (typep string 'simple-string) + (%str-member #\newline string start end) + (position #\newline string :start start :end end :test #'eq ))) + (setq sub-end (if next-newline next-newline end)) + (write-string++ string xp start sub-end) + (when (null next-newline) (return nil)) + (pprint-newline+ :unconditional xp) + (setq start (%i+ 1 sub-end))))) + + + + +;note this checks (> BUFFER-PTR LINEL) instead of (> (LP<-BP) LINEL) +;this is important so that when things are longer than a line they +;end up getting printed in chunks of size LINEL. + +(defun write-char++ (char xp) + (when (> (xp-buffer-ptr xp) (xp-linel xp)) + (force-some-output xp)) + (let ((new-buffer-end (%i+ 1 (xp-buffer-ptr xp)))) + (xp-check-size (xp-buffer xp) new-buffer-end #.buffer-min-size #.buffer-entry-size) + (if (xp-char-mode xp) (setq char (handle-char-mode xp char))) + (setf (schar (xp-buffer xp) (xp-buffer-ptr xp)) char) + (setf (xp-buffer-ptr xp) new-buffer-end))) + + +(defun force-some-output (xp) + (attempt-to-output xp nil nil) + (when (> (xp-buffer-ptr xp) (xp-linel xp)) ;only if printing off end of line + (attempt-to-output xp T T))) + +(defun write-string++ (string xp start end) + (when (> (xp-buffer-ptr xp) (xp-linel xp)) + (force-some-output xp)) + (write-string+++ string xp start end)) + +;never forces output; therefore safe to call from within output-line. + +(defun write-string+++ (string xp start end) + (declare (fixnum start end)) + (let ((new-buffer-end (%i+ (xp-buffer-ptr xp) (- end start)))) + (xp-check-size (xp-buffer xp) new-buffer-end #.buffer-min-size #.buffer-entry-size) + (do ((buffer (xp-buffer xp)) + (i (xp-buffer-ptr xp) (1+ i)) + (j start (1+ j))) + ((= j end)) + (declare (fixnum i j)) + (let ((char (char string j))) + (if (xp-char-mode xp) (setq char (handle-char-mode xp char))) + (setf (schar buffer i) char))) + (setf (xp-buffer-ptr xp) new-buffer-end))) + +(defun pprint-tab+ (kind colnum colinc xp) + (let ((indented? nil) (relative? nil)) + (declare (fixnum colnum colinc)) + (case kind + (:section (setq indented? T)) + (:line-relative (setq relative? T)) + (:section-relative (setq indented? T relative? T))) + (when (or (not indented?) + (and *print-pretty* *logical-block-p*)) + (let* ((current + (if (not indented?) (LP<-BP xp) + (%i- (TP<-BP xp) (section-start xp)))) + (new + (if (zerop colinc) + (if relative? (+ current colnum) (max colnum current)) + (cond (relative? + (* colinc (floor (+ current colnum colinc -1) colinc))) + ((> colnum current) colnum) + (T (+ colnum + (* colinc + (floor (+ current (- colnum) colinc) colinc))))))) + (length (- new current))) + (declare (fixnum current new length)) + (when (plusp length) + (if (xp-char-mode xp) (handle-char-mode xp #\space)) + (let ((end (%i+ (xp-buffer-ptr xp) length))) + (xp-check-size (xp-buffer xp) end #.buffer-min-size #.buffer-entry-size) + (fill (xp-buffer xp) #\space :start (xp-buffer-ptr xp) :end end) + (setf (xp-buffer-ptr xp) end))))))) + +;note following is smallest number >= x that is a multiple of colinc +; (* colinc (floor (+ x (1- colinc)) colinc)) + + +(defun pprint-newline+ (kind xp) + (enqueue xp :newline kind) + (let ((queue (xp-queue xp)) + (qright (xp-qright xp))) + (declare (fixnum qright)) + (do ((ptr (xp-qleft xp) (Qnext ptr))) ;find sections we are ending + ((not (< ptr qright))) ;all but last + (declare (fixnum ptr)) + (when (and (null (xpq-end queue ptr)) + (not (%i> (xp-depth-in-blocks xp) (xpq-depth queue ptr))) + (memq (xpq-type queue ptr) '(:newline :start-block))) + (setf (xpq-end queue ptr) (- qright ptr)))) + (setf (section-start xp) (TP<-BP xp)) + (when (and (memq kind '(:fresh :unconditional)) (xp-char-mode xp)) + (handle-char-mode xp #\newline)) + (when (memq kind '(:fresh :unconditional :mandatory)) + (attempt-to-output xp T nil)))) + +(defun start-block (xp prefix-string on-each-line? suffix-string) + (macrolet ((push-block-stack (xp) + `(let ((ptr (%i+ (xp-block-stack-ptr ,xp) #.block-stack-entry-size))) + (setf (xp-block-stack-ptr ,xp) ptr) + (xp-check-size (xp-block-stack ,xp) ptr + #.block-stack-min-size #.block-stack-entry-size)))) + (let ((length (if prefix-string (length (the string prefix-string)) 0))) + (declare (fixnum length)) + (when prefix-string (write-string++ prefix-string xp 0 length)) + (if (and (xp-char-mode xp) on-each-line?) + (let ((ptr (xp-buffer-ptr xp))) + (declare (fixnum ptr)) + (setq prefix-string + (%substr (xp-buffer xp) (- ptr length) ptr)))) + (push-block-stack xp) + (enqueue xp :start-block nil + (if on-each-line? (cons suffix-string prefix-string) suffix-string)) + (setf (xp-depth-in-blocks xp)(%i+ 1 (xp-depth-in-blocks xp))) ;must be after enqueue + (setf (section-start xp) (TP<-BP xp))))) + +(defun end-block (xp suffix) + (macrolet ((pop-block-stack (xp) + `(decf (the fixnum (xp-block-stack-ptr ,xp)) #.block-stack-entry-size))) + ;(unless (eq *abbreviation-happened* '*print-lines*) + (when suffix (write-string+ suffix xp 0 (length suffix))) + (decf (xp-depth-in-blocks xp)) + (enqueue xp :end-block nil suffix) + (let ((queue (xp-queue xp)) + (qright (xp-qright xp))) + (declare (fixnum qright)) + (do ((ptr (xp-qleft xp) (Qnext ptr))) ;looking for start of block we are ending + ((not (< ptr qright))) ;all but last + (declare (fixnum ptr)) + (when (and (= (the fixnum (xp-depth-in-blocks xp)) (the fixnum (xpq-depth queue ptr))) + (eq (xpq-type queue ptr) :start-block) + (null (xpq-offset queue ptr))) + (setf (xpq-offset queue ptr) (- qright ptr)) + (return nil))) ;can only be 1 + (pop-block-stack xp)))) ;) + +(defun pprint-indent+ (kind n xp) + (when (and *print-pretty* *logical-block-p*) + (enqueue xp :ind kind n))) + + +; The next function scans the queue looking for things it can do. +;it keeps outputting things until the queue is empty, or it finds +;a place where it cannot make a decision yet. + +(eval-when (:compile-toplevel :execute) +(defmacro maybe-too-large (xp Qentry queue linel) + `(let ((.limit. ,linel) + (.qend. (xpq-end ,queue ,qentry))) + (declare (fixnum .limit.)) + (when (eql (xp-line-limit ,xp) (xp-line-no ,xp)) ;prevents suffix overflow + (decf .limit. 2) ;3 for " .." minus 1 for space (heuristic) + (when (not (minusp (xp-prefix-stack-ptr ,xp))) + (decf .limit. (suffix-ptr ,xp)))) + (cond (.qend. + (%i> (LP<-TP ,xp (xpq-pos ,queue (%i+ ,Qentry .qend.))) .limit.)) + ((or force-newlines? (%i> (LP<-BP ,xp) .limit.)) T) + (T (return nil))))) ;wait until later to decide. + +(defmacro misering? (xp left) + `(<= ,left + (the fixnum (initial-prefix-ptr ,xp)))) +) ; eval-when + +;If flush-out? is T and force-newlines? is NIL then the buffer, +;prefix-stack, and queue will be in an inconsistent state after the call. +;You better not call it this way except as the last act of outputting. + + +(defun attempt-to-output (xp force-newlines? flush-out?) + (macrolet ((pop-prefix-stack (xp) + `(decf (the fixnum (xp-prefix-stack-ptr ,xp)) + #.prefix-stack-entry-size))) + (let* ((width *print-miser-width*) + (linel (xp-linel xp)) + (left (if width (- linel width) most-positive-fixnum))) + (declare (fixnum linel left)) + (do ((qleft (xp-qleft xp)) + (queue (xp-queue xp)(xp-queue xp))) + ((%i> qleft (xp-qright xp)) + (setf (xp-qleft xp) 0) + (setf (xp-qright xp) #.(- queue-entry-size))) ;saves shifting + ; initial-prefix-ptr cant be referenced initially - prefix-stack-ptr is negative + (case (xpq-type queue qleft) + (:ind + (unless (misering? xp left) + (set-indentation-prefix xp + (case (xpq-kind queue qleft) + (:block (%i+ (initial-prefix-ptr xp) (xpq-arg queue qleft))) + (T ; :current + (%i+ (LP<-TP xp (xpq-pos queue qleft)) + (xpq-arg queue qleft)))))) ) + (:start-block + (cond ((maybe-too-large xp qleft queue linel) + (push-prefix-stack xp) + (setf (initial-prefix-ptr xp) (prefix-ptr xp)) + (set-indentation-prefix xp (LP<-TP xp (xpq-pos queue qleft))) + (let ((arg (xpq-arg queue qleft))) + (when (consp arg) (set-prefix xp (cdr arg))) + (setf (initial-prefix-ptr xp) (prefix-ptr xp)) + (cond ((not (listp arg)) (set-suffix xp arg)) + ((car arg) (set-suffix xp (car arg))))) + (setf (section-start-line xp) (xp-line-no xp))) + (T (setq qleft (%i+ qleft (xpq-offset queue qleft))))) ) + (:end-block (pop-prefix-stack xp)) + (T ; :newline + (when (case (xpq-kind queue qleft) + (:fresh (not (%izerop (LP<-BP xp)))) + (:miser (misering? xp left)) + (:fill (or (misering? xp left) + (%i> (xp-line-no xp) (section-start-line xp)) + (maybe-too-large xp qleft queue linel))) + (T T)) ;(:linear :unconditional :mandatory) + (output-line xp qleft) + (setup-for-next-line xp qleft)))) + (setf (xp-qleft xp) (setq qleft (qnext qleft)))) + (when flush-out? (flush xp))))) + + + +(defun flush (xp) + (let ((ostream (xp-out-stream xp))) + (when ostream + (write-string (xp-buffer xp) ostream :start 0 :end (xp-buffer-ptr xp))) + (incf (xp-buffer-offset xp) (xp-buffer-ptr xp)) + (incf (xp-charpos xp) (xp-buffer-ptr xp)) + (setf (xp-buffer-ptr xp) 0))) + + +(defun xp-out-stream (xp) + (let ((lc *locating-circularities*)) + (cond + ((null lc) + (xp-base-stream xp)) + ((= lc 0) + (if (null (xp-string-stream xp)) + (setf (xp-string-stream xp) (make-string-output-stream)) + (xp-string-stream xp)))))) + + +;This prints out a line of stuff. + +(defun output-line (xp Qentry) + (flet ((find-not-char-reverse (buffer out-point) + (declare (type simple-base-string buffer) (type fixnum out-point)) + (do ((i (%i- out-point 1) (%i- i 1))) + ((%i< i 0) nil) + (when (or (neq (schar buffer i) #\Space) + ;; Don't match possibly-quoted space ("possibly" because the #\\ itself might be + ;; quoted; don't bother checking for that, no big harm leaving the space even if + ;; not totally necessary). + (and (%i< 0 i) (eq (schar buffer (%i- i 1)) #\\))) + (return i))))) + (let* ((queue (xp-queue xp)) + (out-point (BP<-TP xp (xpq-pos queue Qentry))) + (last-non-blank (find-not-char-reverse (xp-buffer xp) out-point)) + (end (cond ((memq (xpq-kind queue Qentry) '(:fresh :unconditional)) out-point) + (last-non-blank (%i+ 1 last-non-blank)) + (T 0))) + (line-limit-exit (and (xp-line-limit xp) (not (%i> (xp-line-limit xp) (xp-line-no xp)))))) + (when line-limit-exit + (setf (xp-buffer-ptr xp) end) ;truncate pending output. + (write-string+++ " .." xp 0 3) + (reverse-string-in-place (xp-suffix xp) 0 (suffix-ptr xp)) + (write-string+++ (xp-suffix xp) xp 0 (suffix-ptr xp)) + (setf (xp-qleft xp) (qnext (xp-qright xp))) + ;(setq *abbreviation-happened* '*print-lines*) + (throw 'line-limit-abbreviation-exit T)) + (setf (xp-line-no xp)(%i+ 1 (xp-line-no xp))) + (let ((bstream (xp-out-stream xp))) + (when bstream + (write-string (xp-buffer xp) bstream :start 0 :end end) + (stream-write-char bstream #\newline)))))) + +(defun setup-for-next-line (xp Qentry) + (let* ((queue (xp-queue xp)) + (out-point (BP<-TP xp (xpq-pos queue Qentry))) + (prefix-end + (cond ((memq (xpq-kind queue Qentry) '(:unconditional :fresh)) + (non-blank-prefix-ptr xp)) + (T (prefix-ptr xp)))) + (change (- prefix-end out-point))) + (declare (fixnum out-point prefix-end change)) + (setf (xp-charpos xp) 0) + (when (plusp change) ;almost never happens + (xp-check-size (xp-buffer xp) (%i+ (xp-buffer-ptr xp) change) + #.buffer-min-size #.buffer-entry-size)) + (let ((buffer (xp-buffer xp))) + (replace buffer buffer :start1 prefix-end + :start2 out-point :end2 (xp-buffer-ptr xp)) + (replace buffer (xp-prefix xp) :end2 prefix-end) + (setf (xp-buffer-ptr xp) (%i+ (xp-buffer-ptr xp) change)) + (setf (xp-buffer-offset xp) (%i- (xp-buffer-offset xp) change)) + (when (not (memq (xpq-kind queue Qentry) '(:unconditional :fresh))) + (setf (section-start-line xp) (xp-line-no xp)))))) + +(defun set-indentation-prefix (xp new-position) + (let ((new-ind (max (non-blank-prefix-ptr xp) new-position))) + (declare (fixnum new-ind)) + (setf (prefix-ptr xp) (initial-prefix-ptr xp)) + (xp-check-size (xp-prefix xp) new-ind #.prefix-min-size #.prefix-entry-size) + (when (%i> new-ind (prefix-ptr xp)) + (fill (xp-prefix xp) #\space :start (prefix-ptr xp) :end new-ind)) + (setf (prefix-ptr xp) new-ind))) + +(defun set-prefix (xp prefix-string) + (declare (string prefix-string)) + (replace (xp-prefix xp) prefix-string + :start1 (%i- (prefix-ptr xp) (length prefix-string))) + (setf (non-blank-prefix-ptr xp) (prefix-ptr xp))) + +(defun set-suffix (xp suffix-string) + (declare (string suffix-string)) + (let* ((end (length suffix-string)) + (new-end (%i+ (suffix-ptr xp) end))) + (declare (fixnum end new-end)) + (xp-check-size (xp-suffix xp) new-end #.suffix-min-size #.suffix-entry-size) + (do ((i (1- new-end) (1- i)) (j 0 (1+ j))) ((= j end)) + (declare (fixnum i j)) + (setf (char (xp-suffix xp) i) (char suffix-string j))) + (setf (suffix-ptr xp) new-end))) + +(defun reverse-string-in-place (string start end) + (declare (fixnum start end)) + (do ((i start (1+ i)) (j (1- end) (1- j))) ((not (< i j)) string) + (declare (fixnum i j)) + (let ((c (schar string i))) + (setf (schar string i) (schar string j)) + (setf (schar string j) c)))) + + +; ---- BASIC INTERFACE FUNCTIONS ---- + +;The internal functions in this file, and the (formatter "...") expansions +;use the '+' forms of these functions directly (which is faster) because, +;they do not need error checking of fancy stream coercion. The '++' forms +;additionally assume the thing being output does not contain a newline. + +(defun maybe-initiate-xp-printing (fn stream &rest args) + (if (xp-structure-p stream) (apply fn stream args) + (if (typep stream 'xp-stream) + (apply fn (slot-value stream 'xp-structure) args) + (let ((*locating-circularities* (if *print-circle* 0 nil)) + (*circularity-hash-table* + (if *print-circle* (get-circularity-hash-table) nil))) + (prog1 (xp-print fn (decode-stream-arg stream) args) + (if *circularity-hash-table* + (free-circularity-hash-table *circularity-hash-table*))))))) + +(defun xp-print (fn stream args) + (flet ((do-it (fn stream args) + (prog1 (do-xp-printing fn stream args) + (when *locating-circularities* + (setq *locating-circularities* nil) + (do-xp-printing fn stream args))))) + (cond (*print-readably* + (let* ((*print-level* nil) + (*print-length* nil) + (*print-lines* nil) + (*print-escape* t) + (*print-gensym* t) + (*print-array* nil)) + (do-it fn stream args))) + (t (do-it fn stream args))))) + + +(defun decode-stream-arg (stream) + (cond ((eq stream T) *terminal-io*) + ((null stream) *standard-output*) + (T stream))) + +(defun do-xp-printing (fn stream args) + (let ((xp (slot-value (get-pretty-print-stream stream) 'xp-structure)) + (*current-level* 0) + (*xp-current-object* nil) + (result nil)) + (declare (special *foo-string*)) + (catch 'line-limit-abbreviation-exit + (start-block xp nil nil nil) + (setq result (apply fn xp args)) + (end-block xp nil)) + (when (and *locating-circularities* + (zerop *locating-circularities*) ;No circularities. + ;(= (xp-line-no xp) 1) ;Didn't suppress line. + ;(zerop (xp-buffer-offset xp)) + ) ;Didn't suppress partial line. + (setq *locating-circularities* nil) + (let ((s (xp-string-stream xp))) + (when s + (stream-write-entire-string (xp-base-stream xp) + (get-output-stream-string s))))) + (when (catch 'line-limit-abbreviation-exit + (attempt-to-output xp nil T) + nil) + (attempt-to-output xp T T)) + (free-pretty-print-stream xp) + result)) + + + +(defun write+ (object xp &optional interior-cdr circle) + (let ((pretty *print-pretty*)) ;((*parents* *parents*)) + (when (or circle + (not (and *circularity-hash-table* + (eq (setq circle (circularity-process xp object interior-cdr)) :subsequent)))) + (when *circularity-hash-table* + (setq *xp-current-object* object)) + (let ((printer (if pretty (get-printer object *print-pprint-dispatch*) nil)) + #|type|#) + (cond (printer + (funcall printer xp object)) + ((and pretty (maybe-print-fast xp object))) + (t (write-not-pretty xp object + (if *print-level* + (- *print-level* *current-level*) + most-positive-fixnum) + interior-cdr circle))))))) + +;It is vital that this function be called EXACTLY once for each occurrence of +; each thing in something being printed. +;Returns nil if printing should just continue on. +; Either it is not a duplicate, or we are in the first pass and do not know. +;returns :FIRST if object is first occurrence of a DUPLICATE. +; (This can only be returned on a second pass.) +; After an initial code (printed by this routine on the second pass) +; printing should continue on for the object. +;returns :SUBSEQUENT if second or later occurrence. +; Printing is all taken care of by this routine. + +;Note many (maybe most) lisp implementations have characters and small numbers +;represented in a single word so that the are always eq when they are equal and the +;reader takes care of properly sharing them (just as it does with symbols). +;Therefore, we do not want circularity processing applied to them. However, +;some kinds of numbers (e.g., bignums) undoubtedly are complex structures that +;the reader does not share. However, they cannot have circular pointers in them +;and it is therefore probably a waste to do circularity checking on them. In +;any case, it is not clear that it easy to tell exactly what kinds of numbers a +;given implementation of CL is going to have the reader automatically share. + +; if not pretty print a space before dot + +(defun circularity-process (xp object interior-cdr? &aux (not-pretty (not *print-pretty*))) + (unless (or (numberp object) + (characterp object) + (and (symbolp object) ;Reader takes care of sharing. + (or (null *print-gensym*) (symbol-package object)))) + (let ((id (gethash object *circularity-hash-table*))) + (if (and *locating-circularities* *print-circle*) ; << was *locating-circularities* + (progn ;(push (list object id info-p) barf) + (cond ((null id) ;never seen before + ;(when *parents* (push object *parents*)) + (setf (gethash object *circularity-hash-table*) 0) + nil) + ((zerop id) ;possible second occurrence + (setf (gethash object *circularity-hash-table*) + (incf *locating-circularities*)) + :subsequent) + (T :subsequent)));third or later occurrence + (progn ;(push (list object id info-p interior-cdr?) barf2) + (cond + ((or (null id) ;never seen before (note ~@* etc. conses) + (zerop id));no duplicates + nil) + (t (when interior-cdr? + (write-string++ (if not-pretty " . #" ". #") + xp 0 + (if not-pretty 4 3))) + (cond ((plusp id) + (cond (interior-cdr? + (decf *current-level*)) + (T (write-char++ #\# xp))) + (print-fixnum xp id) + (write-char++ #\= xp) + (setf (gethash object *circularity-hash-table*) (- id)) + :first) + (T (when (not interior-cdr?) (write-char++ #\# xp)) + (print-fixnum xp (- id)) + (write-char++ #\# xp) + :subsequent))))))))) + + +;This prints a few very common, simple atoms very fast. +;Pragmatically, this turns out to be an enormous savings over going to the +;standard printer all the time. There would be diminishing returns from making +;this work with more things, but might be worth it. +; does this really win? + +(defun maybe-print-fast (xp object) + (cond ((stringp object) + (cond ((null *print-escape*) (write-string+ object xp 0 (length object)) T) + ((every #'(lambda (c) (not (or (eq c #\") (eq c #\\)))) + object) + (write-char++ #\" xp) + (write-string+ object xp 0 (length object)) + (write-char++ #\" xp) T))) + ((typep object 'fixnum) + (when (and (null *print-radix*) (= *print-base* 10.)) + (when (minusp object) + (write-char++ #\- xp) + (setq object (- object))) + (print-fixnum xp object) T)) + ((symbolp object) + (if (> *print-base* 10) ; may need to escape potential numbers + (write-a-symbol object (xp-stream xp)) + (let ((s (symbol-name object)) + (p (symbol-package object)) + (is-key (keywordp object)) + (mode (case *print-case* + (:downcase :down) + (:capitalize :cap1) + (T nil)))) ; note no-escapes-needed requires all caps + (declare (string s)) + (cond ((and (or is-key (eq p *package*) + (and ;*package* ;can be NIL on symbolics + (multiple-value-bind (symbol type) (find-symbol s) + (and type (eq object symbol))))) + (eq (readtable-case *readtable*) :upcase) + (neq *print-case* :studly) + (no-escapes-needed s)) + (when (and is-key *print-escape*) + (write-char++ #\: xp)) + (if mode (push-char-mode xp mode)) + (write-string++ s xp 0 (length s)) + (if mode (pop-char-mode xp)) T))))))) + +(defun print-fixnum (xp fixnum) + (multiple-value-bind (digits d) + (truncate fixnum 10) + (unless (zerop digits) + (print-fixnum xp digits)) + (write-char++ (code-char (+ #.(char-code #\0) d)) xp))) + +;just wants to succeed fast in a lot of common cases. +;assumes no funny readtable junk for the characters shown. + +(defun no-escapes-needed (s) + (declare (string s)) + (let ((n (length s))) + (declare (fixnum n)) + (and (not (zerop n)) + (let ((c (schar s 0))) + (or (and (alpha-char-p c) (upper-case-p c)) (%str-member c "*<>"))) + (do ((i 1 (1+ i))) ((= i n) T) + (declare (fixnum i)) + (let ((c (schar s i))) + (if (not (or (digit-char-p c) + (and (alpha-char-p c) (upper-case-p c)) + (%str-member c "*+<>-"))) + (return nil))))))) + + + +(without-duplicate-definition-warnings ;; override l1-io version. + (defun pprint (object &optional (stream *standard-output*)) + "Prettily output OBJECT preceded by a newline." + (setq stream (decode-stream-arg stream)) + (terpri stream) + (let ((*print-escape* T) (*print-pretty* T)) + (write-1 object stream)) + (values))) + + + +;Any format string that is converted to a function is always printed +;via an XP stream (See formatter). + +(defvar *format-string-cache* nil) + +(defun process-format-string (string-or-fn force-fn?) + (declare (ignore force-fn?)) + string-or-fn) + + + +;Each of these causes the stream to be pessimistic and insert +;newlines wherever it might have to, when forcing the partial output +;out. This is so that things will be in a consistent state if +;output continues to the stream later. + +(defmethod stream-force-output ((xp xp-structure)) + (attempt-to-output xp t t)) + +(defmethod stream-finish-output ((xp xp-structure)) + (attempt-to-output xp t t)) + + + +; ---- FUNCTIONAL INTERFACE TO DYNAMIC FORMATTING ---- + +;The internal functions in this file, and the (formatter "...") expansions +;use the '+' forms of these functions directly (which is faster) because, +;they do not need error checking or fancy stream coercion. The '++' forms +;additionally assume the thing being output does not contain a newline. + + + +(defun pprint-newline (kind &optional (stream *standard-output*)) + "Output a conditional newline to STREAM (which defaults to + *STANDARD-OUTPUT*) if it is a pretty-printing stream, and do + nothing if not. KIND can be one of: + :LINEAR - A line break is inserted if and only if the immediatly + containing section cannot be printed on one line. + :MISER - Same as LINEAR, but only if ``miser-style'' is in effect. + (See *PRINT-MISER-WIDTH*.) + :FILL - A line break is inserted if and only if either: + (a) the following section cannot be printed on the end of the + current line, + (b) the preceding section was not printed on a single line, or + (c) the immediately containing section cannot be printed on one + line and miser-style is in effect. + :MANDATORY - A line break is always inserted. + When a line break is inserted by any type of conditional newline, any + blanks that immediately precede the conditional newline are ommitted + from the output and indentation is introduced at the beginning of the + next line. (See PPRINT-INDENT.)" + (when (not (memq kind '(:linear :miser :fill :mandatory))) + (signal-type-error kind '(member :linear :miser :fill :mandatory) + "Invalid KIND argument ~A to PPRINT-NEWLINE")) + (when (and *print-pretty* *logical-block-p*) + (setq stream (decode-stream-arg stream)) + (cond ((xp-structure-p stream) + (pprint-newline+ kind stream)) + ((typep stream 'xp-stream) + (pprint-newline+ kind (slot-value stream 'xp-structure))) + (t (pp-newline stream kind)))) + nil) + +(defun pprint-indent (relative-to n &optional (stream *standard-output*)) + "Specify the indentation to use in the current logical block if STREAM + (which defaults to *STANDARD-OUTPUT*) is it is a pretty-printing stream + and do nothing if not. (See PPRINT-LOGICAL-BLOCK.) N is the indentation + to use (in ems, the width of an ``m'') and RELATIVE-TO can be either: + :BLOCK - Indent relative to the column the current logical block + started on. + :CURRENT - Indent relative to the current column. + The new indentation value does not take effect until the following line + break." + (setq stream (decode-stream-arg stream)) + (when (not (memq relative-to '(:block :current))) + (error "Invalid KIND argument ~A to PPRINT-INDENT" relative-to)) + (cond ((xp-structure-p stream) + (pprint-indent+ relative-to (truncate n) stream)) + ((typep stream 'xp-stream) + (pprint-indent+ relative-to (truncate n) (slot-value stream 'xp-structure))) + (t nil)) ; ???(break))) + nil) + +(defun pprint-tab (kind colnum colinc &optional (stream *standard-output*)) + "If STREAM (which defaults to *STANDARD-OUTPUT*) is a pretty-printing + stream, perform tabbing based on KIND, otherwise do nothing. KIND can + be one of: + :LINE - Tab to column COLNUM. If already past COLNUM tab to the next + multiple of COLINC. + :SECTION - Same as :LINE, but count from the start of the current + section, not the start of the line. + :LINE-RELATIVE - Output COLNUM spaces, then tab to the next multiple of + COLINC. + :SECTION-RELATIVE - Same as :LINE-RELATIVE, but count from the start + of the current section, not the start of the line." + (setq stream (decode-stream-arg stream)) + (when (not (memq kind '(:line :section :line-relative :section-relative))) + (error "Invalid KIND argument ~A to PPRINT-TAB" kind)) + + (when (and *print-pretty* *logical-block-p*) + (cond ((xp-structure-p stream) + (pprint-tab+ kind colnum colinc stream)) + ((typep stream 'xp-stream) + (pprint-tab+ kind colnum colinc (slot-value stream 'xp-structure))))) + nil) + + +; ---- COMPILED FORMAT ---- + +;Note that compiled format strings always print through xp streams even if +;they don't have any xp directives in them. As a result, the compiled code +;can depend on the fact that the stream being operated on is an xp +;stream not an ordinary one. + + +(eval-when (:compile-toplevel :load-toplevel :execute) +; called by formatter frobs +(defun do-sub-format-0 (s control-string args) + (setq s (if (xp-structure-p s)(xp-stream s) + (if (output-stream-p s) + s + (require-type s '(satisfies output-stream-p))))) + + (let ((*format-control-string* control-string) + (*format-top-level* t)) + (cond ((and (or *print-pretty* *print-circle*) + (not (typep s 'xp-stream))) + (maybe-initiate-xp-printing + #'do-sub-format-1 s args)) + (t (do-sub-format-1 s args))))) + +; called from above, format, and logical-block-sub +(defun do-sub-format-1 (stream args) + (let ((*format-original-arguments* args) + (*format-arguments* args) + (*format-colon-rest* 'error)) + (declare (special *format-colon-rest*)) + (if (xp-structure-p stream)(setq stream (xp-stream stream))) + (do-sub-format stream) + ; copylist cause args is dynamic extent in format & formatter + ; n.b. when printing lisp code its nearly always nil + (setq args *format-arguments*) + (if (and (consp args) *format-top-level*)(copy-list args) args))) + +(defmacro formatter (control-string) ; maybe-initiate-xp-printing? + (setq control-string (require-type control-string 'string)) + `(function + (lambda (s &rest args) + ; IFFY because things can end up in the same place on the stack + ; appearing EQ giving bogus circularity detection + ; But now we have fixed things so we don't circle check rest args (ha!) + (do-sub-format-0 s ,control-string args)))) + +(defmacro pprint-pop+ (args xp) + `(if (pprint-pop-check+ ,args ,xp) + (return-from logical-block nil) + (pop ,args))) + +(defun pprint-pop-check+ (args xp) + (let ((current-length *current-length*)) + (declare (fixnum current-length)) + (setq current-length (setq *current-length* (1+ *current-length*))) + (cond ((not (listp args)) ;must be first so supersedes length abbrev + (write-string++ ". " xp 0 2) + (write+ args xp) + T) + ((and *print-length* ;must supersede circle check + (not (< current-length *print-length*))) + (write-string++ "..." xp 0 3) + ;(setq *abbreviation-happened* T) + T) + ((and *circularity-hash-table* (not *format-top-level*) + (not (zerop current-length))) + (let ((circle (circularity-process xp args T))) + (case circle + (:first ;; note must inhibit rechecking of circularity for args. + (write+ args xp T circle) + T) + (:subsequent T) + (T nil))))))) + +(defun check-block-abbreviation (xp args circle-check?) + (cond ((not (listp args)) (write+ args xp) T) + ((and *print-level* (> *current-level* *print-level*)) + (write-char++ #\# XP) + ;(setq *abbreviation-happened* T) + T) + ((and *circularity-hash-table* circle-check? (neq args *xp-current-object*) + (eq (circularity-process xp args nil) :subsequent)) + T) + (T nil))) + + +) + + + +; ---- PRETTY PRINTING FORMATS ---- + +(defun pretty-array (xp array) + (when (typep xp 'xp-stream)(setq xp (slot-value xp 'xp-structure))) + (cond ((vectorp array) (pretty-vector xp array)) + ((zerop (array-rank array)) + (write-string++ "#0A" xp 0 3) + (write+ (aref array) xp)) + (T (pretty-non-vector xp array)))) + +(defun pretty-vector (xp v) + (pprint-logical-block (xp nil :prefix "#(" :suffix ")") + (let ((end (length v)) (i 0)) + (declare (fixnum end i)) + (when (plusp end) + (loop (pprint-pop) ;HUH + (write+ (aref v i) xp) + (if (= (incf i) end) (return nil)) + (write-char++ #\space xp) + (pprint-newline+ :fill xp)))))) + +(defun pretty-non-vector (xp array) + (let* ((bottom (1- (array-rank array))) + (indices (make-list (1+ bottom) :initial-element 0)) + (dims (array-dimensions array))) + (funcall (formatter "#~DA") xp (1+ bottom)) + (labels ((pretty-slice (slice) + (pprint-logical-block (xp nil :prefix "(" :suffix ")") + (let ((end (nth slice dims)) + (spot (nthcdr slice indices)) + (i 0)) + (when (plusp end) + (loop (pprint-pop) + (setf (car spot) i) + (if (= slice bottom) + (write+ (apply #'aref array indices) xp) + (pretty-slice (1+ slice))) + (if (= (incf i) end) (return nil)) + (write-char++ #\space xp) + (pprint-newline+ (if (= slice bottom) :fill :linear) xp))))))) + (pretty-slice 0)))) + +(defun pretty-structure (xp struc &aux (class (struct-def struc)) (slots (sd-slots class))) + (when (typep xp 'xp-stream)(setq xp (slot-value xp 'xp-structure))) + (let* ((class (ccl::struct-def struc)) ;;guaranteed non-NIL if this function is called + (pf (structure-print-function class))) + (cond + (pf + (if (consp pf) + (funcall (car pf) struc (xp-stream xp)) + (funcall pf struc (xp-stream xp) *current-level*))) + (t + (pprint-logical-block (xp nil :prefix "#S(" :suffix ")") + (pprint-pop) + (write+ (sd-name class) xp) + (start-block xp (if (cdr slots) " " "") nil "") + (when slots + (let ((pcase *print-case*)) + (loop + (let* ((slot (pop slots))(name (ssd-name slot))) + (cond + ((symbolp name) + (pprint-pop) + (write-char++ #\: xp) + (write-pname (symbol-name name) pcase xp) + (write-char++ #\space xp) + (pprint-pop) + (write+ (uvref struc (ssd-offset slot)) xp) + (when (null slots)(return nil)) + (write-char++ #\space xp) + (pprint-newline+ :fill xp)) + ((null slots)(return nil))))))) + (end-block xp "")))))) + + + + +;Must use pprint-logical-block (no +) in the following three, because they are +;exported functions. + +(defun pprint-linear (s list &optional (colon? T) atsign?) + "Output LIST to STREAM putting :LINEAR conditional newlines between each + element. If COLON? is NIL (defaults to T), then no parens are printed + around the output. ATSIGN? is ignored (but allowed so that PPRINT-LINEAR + can be used with the ~/.../ format directive." + (declare (ignore atsign?)) + (pprint-logical-block (s list :prefix (if colon? "(" "") + :suffix (if colon? ")" "")) + (pprint-exit-if-list-exhausted) + (loop (write+ (pprint-pop) s) + (pprint-exit-if-list-exhausted) + (write-char++ #\space s) + (pprint-newline+ :linear s)))) + +(defun pprint-fill (s list &optional (colon? T) atsign?) + "Output LIST to STREAM putting :FILL conditional newlines between each + element. If COLON? is NIL (defaults to T), then no parens are printed + around the output. ATSIGN? is ignored (but allowed so that PPRINT-FILL + can be used with the ~/.../ format directive." + (declare (ignore atsign?)) + (pprint-logical-block (s list :prefix (if colon? "(" "") + :suffix (if colon? ")" "")) + (pprint-exit-if-list-exhausted) + (loop (write+ (pprint-pop) s) + (pprint-exit-if-list-exhausted) + (write-char++ #\space s) + (pprint-newline+ :fill s)))) + +(defun pprint-tabular (s list &optional (colon? T) atsign? (tabsize nil)) + "Output LIST to STREAM tabbing to the next column that is an even multiple + of TABSIZE (which defaults to 16) between each element. :FILL style + conditional newlines are also output between each element. If COLON? is + NIL (defaults to T), then no parens are printed around the output. + ATSIGN? is ignored (but allowed so that PPRINT-TABULAR can be used with + the ~/.../ format directive." + (declare (ignore atsign?)) + (when (null tabsize) (setq tabsize 16)) + (pprint-logical-block (s list :prefix (if colon? "(" "") + :suffix (if colon? ")" "")) + (pprint-exit-if-list-exhausted) + (loop (write+ (pprint-pop) s) + (pprint-exit-if-list-exhausted) + (write-char++ #\space s) + (pprint-tab+ :section-relative 0 tabsize s) + (pprint-newline+ :fill s)))) + +; perhaps should use alternate-fn-call instead +(defun fn-call (xp list) + (funcall (formatter "~:<~W~^ ~:I~@_~@{~W~^ ~_~}~:>") xp list)) + +;Although idiosyncratic, I have found this very useful to avoid large +;indentations when printing out code. + +(defun alternative-fn-call (xp list) + (if (> (length (symbol-name (car list))) 12) + (funcall (formatter "~:<~1I~@{~W~^ ~_~}~:>") xp list) + (funcall (formatter "~:<~W~^ ~:I~@_~@{~W~^ ~_~}~:>") xp list))) + + +(defun bind-list (xp list &rest args) + (declare (ignore args)) + (if (do ((i 50 (1- i)) + (ls list (cdr ls))) ((null ls) t) + (when (or (not (consp ls)) (not (symbolp (car ls))) (minusp i)) + (return nil))) + (pprint-fill xp list) + (funcall (formatter "~:<~@{~:/pprint-fill/~^ ~_~}~:>") xp list))) + +(defun block-like (xp list &rest args) + (declare (ignore args)) + (funcall (formatter "~:<~1I~^~W~^ ~@_~W~^~@{ ~_~W~^~}~:>") xp list)) + +(defun defun-like (xp list &rest args) + (declare (ignore args)) + (funcall (formatter "~:<~1I~W~^ ~@_~W~^ ~@_~:/pprint-fill/~^~@{ ~_~W~^~}~:>") + xp list)) + +(defun print-fancy-fn-call (xp list template) + (let ((i 0) (in-first-section T)) + (declare (fixnum i)) + (pprint-logical-block+ (xp list "(" ")" nil T nil) + (write+ (pprint-pop) xp) + (pprint-indent+ :current 1 xp) + (loop + (pprint-exit-if-list-exhausted) + (write-char++ #\space xp) + (when (eq i (car template)) + (pprint-indent+ :block (cadr template) xp) + (setq template (cddr template)) + (setq in-first-section nil)) + (pprint-newline (cond ((and (zerop i) in-first-section) :miser) + (in-first-section :fill) + (T :linear)) + xp) + (write+ (pprint-pop) xp) + (incf i))))) + +(defun defmethod-like (xp list &rest args) + (declare (ignore args)) + (cond ((and (consp (cdr list))(consp (cddr list))(listp (caddr list))) + (defun-like xp list)) + (t (defsetf-print xp list)))) + + +(defun maybelab (xp item &rest args) + (declare (ignore args) (special need-newline indentation)) + (when (typep xp 'xp-stream)(setq xp (slot-value xp 'xp-structure))) + (when need-newline (pprint-newline+ :mandatory xp)) + (cond ((and item (symbolp item)) + (write+ item xp) + (setq need-newline nil)) + (T (pprint-tab+ :section indentation 0 xp) + (write+ item xp) + (setq need-newline T)))) + +(defun function-call-p (x) + (and (consp x) (symbolp (car x)) (fboundp (car x)))) + + + + +;THE FOLLOWING STUFF SETS UP THE DEFAULT *PRINT-PPRINT-DISPATCH* + +;This is an attempt to specify a correct format for every form in the CL book +;that does not just get printed out like an ordinary function call +;(i.e., most special forms and many macros). This of course does not +;cover anything new you define. + +(defun let-print (xp obj) + (funcall (formatter "~:<~1I~W~^ ~@_~/ccl::bind-list/~^~@{ ~_~W~^~}~:>") xp obj)) + +(defun cond-print (xp obj) + (funcall (formatter "~:<~W~^ ~:I~@_~@{~:/pprint-linear/~^ ~_~}~:>") xp obj)) + +(defun dmm-print (xp list) + (print-fancy-fn-call xp list '(3 1))) + +(defun defsetf-print (xp list) + (print-fancy-fn-call xp list '(3 1))) + +(defun do-print (xp obj) + (funcall + (formatter "~:<~W~^ ~:I~@_~/ccl::bind-list/~^ ~_~:/pprint-linear/ ~1I~^~@{ ~_~W~^~}~:>") + xp obj)) + + +(defun flet-print (xp obj) + (funcall (formatter "~:<~1I~W~^ ~@_~:<~@{~/ccl::block-like/~^ ~_~}~:>~^~@{ ~_~W~^~}~:>") + xp obj)) + +(defun function-print (xp list) + (if (and *print-abbreviate-quote* (consp (cdr list)) (null (cddr list))) + (format (xp-stream xp) "#'~W" (cadr list)) + (fn-call xp list))) + +(defun mvb-print (xp list) + (print-fancy-fn-call xp list '(1 3 2 1))) + +(defun prog-print (xp list) + (let ((need-newline T) (indentation (1+ (length (symbol-name (car list)))))) ; less? + (declare (special need-newline indentation)) + (funcall (formatter "~:<~W~^ ~:/pprint-fill/~^ ~@{~/ccl::maybelab/~^ ~}~:>") + xp list))) + + +(defun progn-print (xp list) + (funcall (formatter "~:<~1I~@{~W~^ ~_~}~:>") xp list)) + +(defun setq-print (xp obj) + (funcall (formatter "~:<~W~^ ~:I~@_~@{~W~^ ~:_~W~^ ~_~}~:>") xp obj)) + +(defun quote-print (xp list) + (if (and (consp (cdr list)) (null (cddr list))) + (format (xp-stream xp) "'~W" (cadr list)) + (pprint-fill xp list))) + +(defun tagbody-print (xp list) + (let ((need-newline (and (consp (cdr list)) + (symbolp (cadr list)) (cadr list))) + (indentation (1+ (length (symbol-name (car list)))))) + (declare (special need-newline indentation)) + (funcall (formatter "~:<~W~^ ~@{~/ccl::maybelab/~^ ~}~:>") xp list))) + +(defun up-print (xp list) + (print-fancy-fn-call xp list '(0 3 1 1))) + + +;here is some simple stuff for printing LOOP + +;The challange here is that we have to effectively parse the clauses of the +;loop in order to know how to print things. Also you want to do this in a +;purely incremental way so that all of the abbreviation things work, and +;you wont blow up on circular lists or the like. (More aesthic output could +;be produced by really parsing the clauses into nested lists before printing them.) + +;The following program assumes the following simplified grammar of the loop +;clauses that explains how to print them. Note that it does not bare much +;resemblence to the right parsing grammar, however, it produces half decent +;output. The way to make the output better is to make the grammar more +;detailed. +; +;loop == (LOOP {clause}*) ;one clause on each line. +;clause == block | linear | cond | finally +;block == block-head {expr}* ;as many exprs as possible on each line. +;linear == linear-head {expr}* ;one expr on each line. +;finally == FINALLY [DO | DOING | RETURN] {expr}* ;one expr on each line. +;cond == cond-head [expr] +; clause +; {AND clause}* ;one AND on each line. +; [ELSE +; clause +; {AND clause}*] ;one AND on each line. +; [END] +;block-head == FOR | AS | WITH | AND +; | REPEAT | NAMED | WHILE | UNTIL | ALWAYS | NEVER | THEREIS | RETURN +; | COLLECT | COLLECTING | APPEND | APPENDING | NCONC | NCONCING | COUNT +; | COUNTING | SUM | SUMMING | MAXIMIZE | MAXIMIZING | MINIMIZE | MINIMIZING +;linear-head == DO | DOING | INITIALLY +;var-head == FOR | AS | WITH +;cond-head == IF | WHEN | UNLESS +;expr == + +;Note all the string comparisons below are required to support some +;existing implementations of LOOP. +(defun token-type (token &aux string) + (cond ((not (symbolp token)) :expr) + ((string= (setq string (string token)) "FINALLY") :finally) + ((member string '("IF" "WHEN" "UNLESS") :test #'string=) :cond-head) + ((member string '("DO" "DOING" "INITIALLY") :test #'string=) :linear-head) + ((member string '("FOR" "AS" "WITH" "AND" "END" "ELSE" + "REPEAT" "NAMED" "WHILE" "UNTIL" "ALWAYS" "NEVER" + "THEREIS" "RETURN" "COLLECT" "COLLECTING" "APPEND" + "APPENDING" "NCONC" "NCONCING" "COUNT" "COUNTING" + "SUM" "SUMMING" "MAXIMIZE" "MAXIMIZING" + "MINIMIZE" "MINIMIZING") + :test #'string=) + :block-head) + (T :expr))) + + +; maybe put in a separate file (replace write-char by write-char+) +(defun pretty-loop (xp loop) + (if (not (and (consp (cdr loop)) (symbolp (cadr loop)))) ; old-style loop + (tagbody-print xp loop) + (pprint-logical-block (xp loop :prefix "(" :suffix ")") + (let (token type) + (labels ((next-token () + (pprint-exit-if-list-exhausted) + (setq token (pprint-pop)) + (setq type (token-type token))) + (print-clause (xp) + (case type + (:linear-head (print-exprs xp nil :mandatory)) + (:cond-head (print-cond xp)) + (:finally (print-exprs xp T :mandatory)) + (otherwise (print-exprs xp nil :fill)))) + (print-exprs (xp skip-first-non-expr newline-type) + (pprint-logical-block (xp nil) + (write+ token xp) + (next-token) + (when (and skip-first-non-expr (not (eq type :expr))) + (write-char+ #\space xp) + (write+ token xp) + (next-token)) + (when (eq type :expr) + (write-char+ #\space xp) + (pprint-indent :current 0 xp) + (loop (write+ token xp) + (next-token) + (when (not (eq type :expr)) (return nil)) + (write-char+ #\space xp) + (pprint-newline newline-type xp))))) + (print-cond (xp) + (pprint-logical-block (xp nil) + (write+ token xp) + (next-token) + (when (eq type :expr) + (write-char+ #\space xp) + (write+ token xp) + (next-token)) + (write-char+ #\space xp) + (pprint-indent :block 2 xp) + (pprint-newline :linear xp) + (print-clause xp) + (print-and-list xp) + (when (string= (string token) "ELSE") + (print-else-or-end xp) + (write-char+ #\space xp) + (pprint-newline :linear xp) + (print-clause xp) + (print-and-list xp)) + (when (string= (string token) "END") + (print-else-or-end xp)))) + (print-and-list (xp) + (loop (when (not (string= (string token) "AND")) (return nil)) + (write-char+ #\space xp) + (pprint-newline :mandatory xp) + (write+ token xp) + (next-token) + (write-char+ #\space xp) + (print-clause xp))) + (print-else-or-end (xp) + (write-char+ #\space xp) + (pprint-indent :block 0 xp) + (pprint-newline :linear xp) + (write+ token xp) + (next-token) + (pprint-indent :block 2 xp))) + (pprint-exit-if-list-exhausted) + (write+ (pprint-pop) xp) + (next-token) + (write-char+ #\space xp) + (pprint-indent :current 0 xp) + (loop (print-clause xp) + (write-char+ #\space xp) + (pprint-newline :linear xp) + ; without this we can loop forever + (if (and *print-level* + (>= *current-level* *print-level*)) + (return)))))))) + + +;Backquote is a big problem we MUST do all this reconsing of structure in +;order to get a list that will trigger the right formatting functions to +;operate on it. On the other side of the coin, we must use a non-list structure +;for the little backquote printing markers to ensure that they will always +;print out the way we want no matter what the code printers say. +; Note that since it is sometimes possible to write the same +;backquote form in several ways, this might not necessarily print out a +;form in exactly the way you wrote it. For example '`(a .,b) and '`(a ,@b) +;both print out as `'(a .,b), because the backquote reader produces the +;same code in both cases. + + + +(setq *IPD* (make-pprint-dispatch-table)) + +(set-pprint-dispatch+ '(satisfies function-call-p) #'alternative-fn-call '(-5) *IPD*) +(set-pprint-dispatch+ 'cons #'pprint-fill '(-10) *IPD*) + +(set-pprint-dispatch+ '(cons (member defstruct)) #'block-like '(0) *IPD*) +(set-pprint-dispatch+ '(cons (member block)) #'block-like '(0) *IPD*) +(set-pprint-dispatch+ '(cons (member case)) #'block-like '(0) *IPD*) +(set-pprint-dispatch+ '(cons (member catch)) #'block-like '(0) *IPD*) +(set-pprint-dispatch+ '(cons (member ccase)) #'block-like '(0) *IPD*) +(set-pprint-dispatch+ '(cons (member compiler-let)) #'let-print '(0) *IPD*) +(set-pprint-dispatch+ '(cons (member cond)) #'cond-print '(0) *IPD*) +(set-pprint-dispatch+ '(cons (member ctypecase)) #'block-like '(0) *IPD*) +(set-pprint-dispatch+ '(cons (member defclass)) #'defun-like '(0) *IPD*) +(set-pprint-dispatch+ '(cons (member ctypecase)) #'block-like '(0) *IPD*) +(set-pprint-dispatch+ '(cons (member defconstant)) #'defun-like '(0) *IPD*) +(set-pprint-dispatch+ '(cons (member define-setf-expander)) #'defun-like '(0) *IPD*) +(set-pprint-dispatch+ '(cons (member defmacro)) #'defun-like '(0) *IPD*) +(set-pprint-dispatch+ '(cons (member define-modify-macro)) #'dmm-print '(0) *IPD*) +(set-pprint-dispatch+ '(cons (member defparameter)) #'defun-like '(0) *IPD*) +(set-pprint-dispatch+ '(cons (member defsetf)) #'defsetf-print '(0) *IPD*) +(set-pprint-dispatch+ '(cons (member define-setf-expander)) #'defun-like '(0) *IPD*) +(set-pprint-dispatch+ '(cons (member cl:defstruct)) #'block-like '(0) *IPD*) +(set-pprint-dispatch+ '(cons (member deftype)) #'defun-like '(0) *IPD*) +(set-pprint-dispatch+ '(cons (member defun)) #'defun-like '(0) *IPD*) +(set-pprint-dispatch+ '(cons (member defmethod)) #'defmethod-like '(0) *IPD*) +(set-pprint-dispatch+ '(cons (member defvar)) #'defun-like '(0) *IPD*) +(set-pprint-dispatch+ '(cons (member do)) #'do-print '(0) *IPD*) +(set-pprint-dispatch+ '(cons (member do*)) #'do-print '(0) *IPD*) +(set-pprint-dispatch+ '(cons (member do-all-symbols)) #'block-like '(0) *IPD*) +(set-pprint-dispatch+ '(cons (member do-external-symbols)) #'block-like '(0) *IPD*) +(set-pprint-dispatch+ '(cons (member do-symbols)) #'block-like '(0) *IPD*) +(set-pprint-dispatch+ '(cons (member dolist)) #'block-like '(0) *IPD*) +(set-pprint-dispatch+ '(cons (member dotimes)) #'block-like '(0) *IPD*) +(set-pprint-dispatch+ '(cons (member ecase)) #'block-like '(0) *IPD*) +(set-pprint-dispatch+ '(cons (member etypecase)) #'block-like '(0) *IPD*) +(set-pprint-dispatch+ '(cons (member eval-when)) #'block-like '(0) *IPD*) +(set-pprint-dispatch+ '(cons (member flet)) #'flet-print '(0) *IPD*) +(set-pprint-dispatch+ '(cons (member function)) #'function-print '(0) *IPD*) +(set-pprint-dispatch+ '(cons (member generic-function)) #'fn-call '(0) *IPD*) +(set-pprint-dispatch+ '(cons (member labels)) #'flet-print '(0) *IPD*) +(set-pprint-dispatch+ '(cons (member lambda)) #'block-like '(0) *IPD*) +(set-pprint-dispatch+ '(cons (member let)) #'let-print '(0) *IPD*) +(set-pprint-dispatch+ '(cons (member let*)) #'let-print '(0) *IPD*) +(set-pprint-dispatch+ '(cons (member locally)) #'block-like '(0) *IPD*) + +(set-pprint-dispatch+ '(cons (member loop)) #'pretty-loop '(0) *IPD*) +(set-pprint-dispatch+ '(cons (member macrolet)) #'flet-print '(0) *IPD*) +(set-pprint-dispatch+ '(cons (member multiple-value-bind)) #'mvb-print '(0) *IPD*) +(set-pprint-dispatch+ '(cons (member multiple-value-setq)) #'block-like '(0) *IPD*) +(set-pprint-dispatch+ '(cons (member prog)) #'prog-print '(0) *IPD*) +(set-pprint-dispatch+ '(cons (member prog*)) #'prog-print '(0) *IPD*) +(set-pprint-dispatch+ '(cons (member progv)) #'defun-like '(0) *IPD*) +(set-pprint-dispatch+ '(cons (member psetf)) #'setq-print '(0) *IPD*) +(set-pprint-dispatch+ '(cons (member psetq)) #'setq-print '(0) *IPD*) +(set-pprint-dispatch+ '(cons (member quote)) #'quote-print '(0) *IPD*) +(set-pprint-dispatch+ '(cons (member return-from)) #'block-like '(0) *IPD*) +(set-pprint-dispatch+ '(cons (member setf)) #'setq-print '(0) *IPD*) +(set-pprint-dispatch+ '(cons (member setq)) #'setq-print '(0) *IPD*) +(set-pprint-dispatch+ '(cons (member tagbody)) #'tagbody-print '(0) *IPD*) +(set-pprint-dispatch+ '(cons (member throw)) #'block-like '(0) *IPD*) +(set-pprint-dispatch+ '(cons (member typecase)) #'block-like '(0) *IPD*) +(set-pprint-dispatch+ '(cons (member unless)) #'block-like '(0) *IPD*) +(set-pprint-dispatch+ '(cons (member unwind-protect)) #'up-print '(0) *IPD*) +(set-pprint-dispatch+ '(cons (member when)) #'block-like '(0) *IPD*) +(set-pprint-dispatch+ '(cons (member with-input-from-string)) #'block-like '(0) *IPD*) +(set-pprint-dispatch+ '(cons (member with-open-file)) #'block-like '(0) *IPD*) +(set-pprint-dispatch+ '(cons (member with-open-stream)) #'block-like '(0) *IPD*) +(set-pprint-dispatch+ '(cons (member with-output-to-string)) #'block-like '(0) *IPD*) + + + +;so only happens first time is loaded. - why doesn't this work right? +; cause we have *print-pprin... bound to NIL +(when t ;(eq *print-pprint-dispatch* T) + (setq *print-pprint-dispatch* (copy-pprint-dispatch nil))) + +(setq *error-print-circle* t) ; now we can circle-print + +; 82 bytes shorter but uglier +(defun write-not-pretty (stream object level list-kludge circle) + (declare (type fixnum level) (type (or null fixnum) list-kludge)) + (when (xp-structure-p stream)(setq stream (xp-stream stream))) + (cond ((eq circle :subsequent) + (if list-kludge (stream-write-char stream #\))) + (return-from write-not-pretty nil)) + ((not list-kludge)) + ((null object)(return-from write-not-pretty nil)) + ((not (consp object)) + (stream-write-entire-string stream " . ")) + ((eq circle :first) + (stream-write-char stream #$) + (write-a-frob object stream level list-kludge) + (stream-write-char stream #$) + (return-from write-not-pretty nil)) + (t (stream-write-char stream #\space))) + (write-a-frob object stream level list-kludge)) + +(eval-when (:load-toplevel :execute) + (setq *error-print-circle* t)) + +;changes since last documentation. +;~/fn/ only refers to global function values, not lexical. + +;------------------------------------------------------------------------ + +;Copyright 1989,1990 by the Massachusetts Institute of Technology, Cambridge, +;Massachusetts. + +;Permission to use, copy, modify, and distribute this software and its +;documentation for any purpose and without fee is hereby granted, +;provided that this copyright and permission notice appear in all +;copies and supporting documentation, and that the name of M.I.T. not +;be used in advertising or publicity pertaining to distribution of the +;software without specific, written prior permission. M.I.T. makes no +;representations about the suitability of this software for any +;purpose. It is provided "as is" without express or implied warranty. + +; M.I.T. DISCLAIMS ALL WARRANTIES WITH REGARD TO THIS SOFTWARE, INCLUDING +; ALL IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS, IN NO EVENT SHALL +; M.I.T. BE LIABLE FOR ANY SPECIAL, INDIRECT OR CONSEQUENTIAL DAMAGES OR +; ANY DAMAGES WHATSOEVER RESULTING FROM LOSS OF USE, DATA OR PROFITS, +; WHETHER IN AN ACTION OF CONTRACT, NEGLIGENCE OR OTHER TORTIOUS ACTION, +; ARISING OUT OF OR IN CONNECTION WITH THE USE OR PERFORMANCE OF THIS +; SOFTWARE. + +;------------------------------------------------------------------------ + +#| + Change History (most recent last): + 2 12/29/94 akh merge with d13 +|# ;(do not edit past this line!!) Index: /branches/new-random/lib/prepare-mcl-environment.lisp =================================================================== --- /branches/new-random/lib/prepare-mcl-environment.lisp (revision 13309) +++ /branches/new-random/lib/prepare-mcl-environment.lisp (revision 13309) @@ -0,0 +1,91 @@ +;-*-Mode: LISP; Package: CCL -*- +;;; +;;; Copyright (C) 2009 Clozure Associates +;;; Copyright (C) 1994-2001 Digitool, Inc +;;; This file is part of Clozure CL. +;;; +;;; Clozure CL is licensed under the terms of the Lisp Lesser GNU Public +;;; License , known as the LLGPL and distributed with Clozure CL as the +;;; file "LICENSE". The LLGPL consists of a preamble and the LGPL, +;;; which is distributed with Clozure CL as the file "LGPL". Where these +;;; conflict, the preamble takes precedence. +;;; +;;; Clozure CL is referenced in the preamble as the "LIBRARY." +;;; +;;; The LLGPL is also available online at +;;; http://opensource.franz.com/preamble.html + +;; prepare-mcl-environment.lisp +;; Load this into a PPCCL to make it into an MCL-PPC for shipping +;; Sort of. + +(in-package "CCL") + +(defun %reset-outermost-binding (symbol value) + (let* ((symvector (symptr->symvector symbol)) + (idx (%svref symvector target::symbol.binding-index-cell)) + (marker (%no-thread-local-binding-marker))) + (if (> idx 0) + (do-db-links (db var) + (when (eq var idx) + (let* ((oldval (%fixnum-ref db (* 2 target::node-size)))) + (unless (eq oldval marker) + (setf (%fixnum-ref db (* 2 target::node-size)) value)))))) + (setf (uvref symvector target::symbol.vcell-cell) value))) + +(defun freeze-current-definitions () + ;; Set the frozen bits so that redefine-kernel-function + ;; will error if a builtin function is redefined. + (do-all-symbols (s) + (when (fboundp s) + (%symbol-bits s (bitset $sym_fbit_frozen (%symbol-bits s))))) + ;; Force an error if a kernel method is redefined. + (make-all-methods-kernel)) + +(defun thaw-current-definitions () + ;; Clear the frozen bits on all fboundp symbols + (do-all-symbols (s) + (when (fboundp s) + (%symbol-bits s (bitclr $sym_fbit_frozen (%symbol-bits s))))) + ;; Allow redefinition of kernel methods. + (make-all-methods-non-kernel)) + +(defun set-user-environment (&optional (freeze-definitions nil)) + "Arrange that the outermost special bindings of *PACKAGE* and +*WARN-IF-REDEFINE-KERNEL* restore values of the CL-USER package and T +respectively, and set *CCL-SAVE-SOURCE-LOCATIONS* to :NO-TEXT. +If the optional argument is true, marks all globally defined +functions and methods as being predefined (this is a fairly +expensive operation.)" + (when freeze-definitions + (freeze-current-definitions)) + ;; enable redefine-kernel-function's error checking + (%reset-outermost-binding '*warn-if-redefine-kernel* t) + ;; Set the top-level *package* to the CL-USER package + (%reset-outermost-binding '*package* (find-package "CL-USER")) + (setq *ccl-save-source-locations* :NO-TEXT)) + +(defun set-development-environment (&optional (thaw-definitions nil)) + "Arrange that the outermost special bindings of *PACKAGE* and +*WARN-IF-REDEFINE-KERNEL* restore values of the CCL package and NIL +respectively, and set *ccl-save-source-locations* to T. If the +optional argument is true, mark all globally defined functions and +methods as being not predefined (this is a fairly expensive operation.)" + (when thaw-definitions + (thaw-current-definitions)) + ;; enable redefine-kernel-function's error checking + (%reset-outermost-binding '*warn-if-redefine-kernel* nil) + ;; Set the top-level *package* to the CCL package + (%reset-outermost-binding '*package* (find-package "CCL")) + (setq *ccl-save-source-locations* T)) + + + +(defmacro in-development-mode (&body body) + `(let* ((*package* (find-package "CCL")) + (*warn-if-redefine-kernel* nil)) + ,@body)) + + + + Index: /branches/new-random/lib/print-db.lisp =================================================================== --- /branches/new-random/lib/print-db.lisp (revision 13309) +++ /branches/new-random/lib/print-db.lisp (revision 13309) @@ -0,0 +1,39 @@ +; -*- Mode:Lisp; Package:CCL; -*- +;;; +;;; Copyright (C) 2009 Clozure Associates +;;; Copyright (C) 1994-2001 Digitool, Inc +;;; This file is part of Clozure CL. +;;; +;;; Clozure CL is licensed under the terms of the Lisp Lesser GNU Public +;;; License , known as the LLGPL and distributed with Clozure CL as the +;;; file "LICENSE". The LLGPL consists of a preamble and the LGPL, +;;; which is distributed with Clozure CL as the file "LGPL". Where these +;;; conflict, the preamble takes precedence. +;;; +;;; Clozure CL is referenced in the preamble as the "LIBRARY." +;;; +;;; The LLGPL is also available online at +;;; http://opensource.franz.com/preamble.html + +(in-package "CCL") + +(defmacro print-db (&rest forms &aux) + `(multiple-value-prog1 + (progn ,@(print-db-aux forms)) + (terpri *trace-output*))) + +(defun print-db-aux (forms) + (when forms + (cond ((stringp (car forms)) + `((print ',(car forms) *trace-output*) + ,@(print-db-aux (cdr forms)))) + ((null (cdr forms)) + `((print ',(car forms) *trace-output*) + (let ((values (multiple-value-list ,(car forms)))) + (prin1 (car values) *trace-output*) + (apply #'values values)))) + (t `((print ',(car forms) *trace-output*) + (prin1 ,(car forms) *trace-output*) + ,@(print-db-aux (cdr forms))))))) + + Index: /branches/new-random/lib/read.lisp =================================================================== --- /branches/new-random/lib/read.lisp (revision 13309) +++ /branches/new-random/lib/read.lisp (revision 13309) @@ -0,0 +1,250 @@ +;;;-*-Mode: LISP; Package: CCL -*- +;;; +;;; Copyright (C) 2009 Clozure Associates +;;; Copyright (C) 1994-2001 Digitool, Inc +;;; This file is part of Clozure CL. +;;; +;;; Clozure CL is licensed under the terms of the Lisp Lesser GNU Public +;;; License , known as the LLGPL and distributed with Clozure CL as the +;;; file "LICENSE". The LLGPL consists of a preamble and the LGPL, +;;; which is distributed with Clozure CL as the file "LGPL". Where these +;;; conflict, the preamble takes precedence. +;;; +;;; Clozure CL is referenced in the preamble as the "LIBRARY." +;;; +;;; The LLGPL is also available online at +;;; http://opensource.franz.com/preamble.html + +(in-package "CCL") + + + +(define-condition simple-reader-error (reader-error simple-error) () + (:report (lambda (c output-stream) + (format output-stream "Reader error ~a:~%~?" + (stream-error-context c) + (simple-condition-format-control c) + (simple-condition-format-arguments c))))) + +(defun signal-reader-error (input-stream format-string &rest format-args) + (error 'simple-reader-error :stream input-stream + :format-control format-string :format-arguments format-args)) + +#| ; Can't see any reason to leave this in +(defun read-file-to-list (file &aux result) + ;(print-db (setq file (prepend-default-dir file))) + (with-open-file (stream file :direction :input) + (setq result (read-file-to-list-aux stream))) + result) + +(defun read-file-to-list-aux (stream) + (if (eofp stream) + nil + (let ((form (read stream nil *eof-value* nil))) + ;(%print "just read " form) + (if (eq form *eof-value*) + nil + (cons form (read-file-to-list-aux stream)))))) +|# + +(set-dispatch-macro-character #\# #\* + (qlfun |#*-reader| (input-stream sub-char int + &aux list list-length array array-length last-bit) + (declare (ignore sub-char)) + (do* ((char (read-char input-stream nil nil t) + (read-char input-stream nil nil t)) + (attr (%character-attribute char (rdtab.ttab *readtable*)) + (%character-attribute char (rdtab.ttab *readtable*)))) + ((or (null char) + (= $cht_tmac attr) + (= $cht_wsp attr)) + (if char (unread-char char input-stream))) + (let ((number (- (char-code char) 48))) + (if (or (<= 0 number 1) *read-suppress*) + (setq list (cons number list)) + (signal-reader-error input-stream "reader macro #* got illegal character ~S" char)))) + (setq last-bit (car list)) + (setq list (nreverse list)) + (setq list-length (list-length list)) + (if (not (integerp int)) + (setq int list-length)) + (cond (*read-suppress* nil) + ((and (= 0 list-length) (> int 0)) + (signal-reader-error input-stream "reader macro #~S* needs something" int)) + ((> list-length int) + (signal-reader-error input-stream "reader macro #~S* can't fit ~S" int list)) + (t (setq array-length (if int int list-length)) + (setq array (make-array array-length :element-type 'bit)) + (do ((i 0 (1+ i)) + (bit-list list (cdr bit-list))) + ((>= i array-length)) + (aset array i (if bit-list + (car bit-list) + last-bit))) + array)))) + +(set-dispatch-macro-character #\# #\A + (qlfun |#A-reader| (stream ignore dimensions) + (declare (ignore ignore)) + (cond (*read-suppress* + (read stream () () t) + nil) + ((not dimensions) + (signal-reader-error stream "reader macro #A used without a rank integer")) + ((eql dimensions 0) ;0 dimensional array + (make-array nil :initial-contents (read-internal stream t nil t))) + ((and (integerp dimensions) (> dimensions 0)) + (let ((init-list (read-internal stream t nil t))) + (cond ((not (typep init-list 'sequence)) + (signal-reader-error stream "The form following a #~SA reader macro should have been a sequence, but it was: ~S" dimensions init-list)) + ((= (length init-list) 0) + (make-array (make-list dimensions :initial-element 0))) + ((= dimensions 1) + (make-array (length init-list) :initial-contents init-list)) + ((vectorp init-list) + (let ((dlist (make-list dimensions))) + (do ((dl dlist (cdr dl)) + (il init-list (svref il 0))) + ((null dl)) + (if (vectorp il) + (rplaca dl (length il)) + (signal-reader-error stream "Initial contents for #A is inconsistent with dimensions: #~SA~S" dimensions init-list))) + (make-array dlist :initial-contents init-list))) + ((listp init-list) + (let ((dlist (make-list dimensions))) + (do ((dl dlist (cdr dl)) + (il init-list (car il))) + ((null dl)) + (if (listp il) + (rplaca dl (list-length il)) + (signal-reader-error stream "Initial contents for #A is inconsistent with dimensions: #~SA~S" dimensions init-list))) + (make-array dlist :initial-contents init-list))) + (t + (signal-reader-error stream "#~SA~S invalid." dimensions init-list))))) + (t (signal-reader-error stream "Dimensions argument to #A not a non-negative integer: ~S" dimensions))))) + +(set-dispatch-macro-character #\# #\S + (qlfun |#S-reader| (input-stream sub-char int &aux list sd) + (declare (ignore sub-char int)) + (setq list (read-internal input-stream t nil t)) + (unless *read-suppress* + (unless (and (consp list) + (symbolp (%car list)) + (setq sd (gethash (%car list) %defstructs%)) + (setq sd (sd-constructor sd))) + (error "Can't initialize structure from ~S." list)) + (let ((args ()) (plist (cdr list))) + (unless (plistp plist) (report-bad-arg plist '(satisfies plistp))) + (while plist + (push (make-keyword (pop plist)) args) + (push (pop plist) args)) + (apply sd (nreverse args)))))) + +;;;from slisp reader2.lisp, and apparently not touched in 20 years. +(defun parse-integer (string &key (start 0) end + (radix 10) junk-allowed) + "Examine the substring of string delimited by start and end + (default to the beginning and end of the string) It skips over + whitespace characters and then tries to parse an integer. The + radix parameter must be between 2 and 36." + (flet ((parse-integer-not-integer-string (s) + (error 'parse-integer-not-integer-string :string s))) + (declare (inline parse-integer-not-integer-string)) + (unless (typep string 'string) + (setq string (require-type string 'string))) + (setq end (check-sequence-bounds string start end)) + (setq radix (%validate-radix radix)) + (let ((index (do ((i start (1+ i))) + ((= i end) + (if junk-allowed + (return-from parse-integer (values nil end)) + (parse-integer-not-integer-string string))) + (unless (whitespacep (char string i)) (return i)))) + (minusp nil) + (found-digit nil) + (result 0)) + (let ((char (char string index))) + (cond ((char= char #\-) + (setq minusp t) + (setq index (1+ index))) + ((char= char #\+) + (setq index (1+ index)) + ))) + (loop + (when (= index end) (return nil)) + (let* ((char (char string index)) + (weight (digit-char-p char radix))) + (cond (weight + (setq result (+ weight (* result radix)) + found-digit t)) + (junk-allowed (return nil)) + ((whitespacep char) + (until (eq (setq index (1+ index)) end) + (unless (whitespacep (char string index)) + (parse-integer-not-integer-string string))) + (return nil)) + (t + (parse-integer-not-integer-string string)))) + (setq index (1+ index))) + (values + (if found-digit + (if minusp (- result) result) + (if junk-allowed + nil + (parse-integer-not-integer-string string))) + index)))) + + +(set-dispatch-macro-character #\# #\# + #'(lambda (stream char arg) + (declare (ignore stream)) + (if *read-suppress* + nil + (if arg + (let ((pair (assoc arg %read-objects%))) ;Not assq, could be bignum! + (if pair + (cdr pair) + (%err-disp $xnordlbl arg))) + (%err-disp $xrdndarg char))))) + +(set-dispatch-macro-character + #\# + #\= + #'(lambda (stream char arg &aux lab form) + (cond (*read-suppress* (values)) + ((null arg) (%err-disp $xrdndarg char)) + ((assoc arg %read-objects%) ;Not assq, could be bignum! + (%err-disp $xduprdlbl arg)) + (t (setq lab (cons arg nil)) + (push (%rplacd lab lab) %read-objects%) + (setq form (read stream t nil t)) + (when (eq form lab) ;#n= #n#. No can do. + (%err-disp $xnordlbl (%car lab))) + (%rplacd lab form) + (let ((scanned nil)) + (labels ((circle-subst (tree) + (if (memq tree %read-objects%) + (progn + (unless (memq tree scanned) + (setq scanned (%temp-cons tree scanned)) + (circle-subst (cdr tree))) + (cdr tree)) + (let ((gvectorp (and (gvectorp tree) (not (or (symbolp tree) (functionp tree)))))) + (unless (or (and (atom tree) (not gvectorp)) (memq tree scanned)) + (setq scanned (%temp-cons tree scanned)) + (if gvectorp + (let* ((subtype (typecode tree))) + (dotimes (i (uvsize tree)) + (declare (fixnum i)) + (unless (and (eql i 0) (eql subtype target::subtag-instance)) + (setf (uvref tree i) (circle-subst (uvref tree i)))))) + (locally + (declare (type cons tree)) + (rplaca tree (circle-subst (car tree))) + (rplacd tree (circle-subst (cdr tree)))))) + tree)))) + (declare (dynamic-extent #'circle-subst)) + (circle-subst form))))))) + + + Index: /branches/new-random/lib/sequences.lisp =================================================================== --- /branches/new-random/lib/sequences.lisp (revision 13309) +++ /branches/new-random/lib/sequences.lisp (revision 13309) @@ -0,0 +1,2154 @@ +;;-*-Mode: LISP; Package: CCL -*- +;;; +;;; Copyright (C) 2009 Clozure Associates +;;; Copyright (C) 1994-2001 Digitool, Inc +;;; This file is part of Clozure CL. +;;; +;;; Clozure CL is licensed under the terms of the Lisp Lesser GNU Public +;;; License , known as the LLGPL and distributed with Clozure CL as the +;;; file "LICENSE". The LLGPL consists of a preamble and the LGPL, +;;; which is distributed with Clozure CL as the file "LGPL". Where these +;;; conflict, the preamble takes precedence. +;;; +;;; Clozure CL is referenced in the preamble as the "LIBRARY." +;;; +;;; The LLGPL is also available online at +;;; http://opensource.franz.com/preamble.html + +(in-package "CCL") + +;; +;; utility functions +;; +;; these probably want to be in-line + +(defun make-sequence-like (sequence length) + (seq-dispatch + sequence + (make-list length) + (make-array length :element-type (array-element-type sequence)))) + +(defun adjust-test-args (item test test-not) + ;; after running this "test" is the real test, a null test means "eq" + ;; and "test-not" is used as a flag + (when test-not + (if test + (error "Both ~s and ~s keywords supplied" :test :test-not) + (setq test test-not))) + (if test + (if (or (eq test #'eq) + (eq test 'eq) + (and (or (eq test #'equal) (eq test 'equal)) + (or (fixnump item) (symbolp item)))) + (setq test nil) + (if (eq test #'funcall) + (setq test 'funcall))) + (if (or (macptrp item) (and (not (fixnump item)) (numberp item))) + (setq test #'eql))) + (values test test-not)) + +(defun adjust-key (key) + (and (neq key 'identity) + (neq key #'identity) + key)) + +(defun matchp2 (item elt test test-not key) + (if key + (setq elt (funcall key elt))) + (let ((res (if test + (if (eq test 'funcall) + (funcall item elt) + (funcall test item elt)) + (eq item elt)))) + (if test-not + (not res) + res))) + +;;; CTYPE is a recognizable subtype of VECTOR, which means that it's either +;;; a) an ARRAY-CTYPE +;;; b) a UNION-CTYPE whose leaves are ARRAY-CTYPE +;;; c) the NIL type, which is trivially a subtype of VECTOR but isn't really +;;; worth considering here +;;; d) a MEMBER-CTYPE whose members are all vectors and which therefore have +;;; corresponding ARRAY-CTYPEs. +;;; Try to find the interesection of all ARRAY-CTYPEs referenced in CTYPE and +;;; return it. +;;; Note that this intersection may be the null type. +(defun simplify-vector-ctype (ctype) + (typecase ctype + (array-ctype + (make-array-ctype :complexp nil + :element-type (array-ctype-element-type ctype) + :specialized-element-type (array-ctype-specialized-element-type ctype) + :dimensions '(*))) + + (named-ctype ctype) + (member-ctype + (apply #'type-intersection (mapcar #'(lambda (x) + (simplify-vector-ctype + (ctype-of x))) + (member-ctype-members ctype)))) + (union-ctype + (apply #'type-intersection (mapcar #'simplify-vector-ctype (union-ctype-types ctype)))))) + +(defun make-sequence (type length &key (initial-element nil initial-element-p)) + "Return a sequence of the given TYPE and LENGTH, with elements initialized + to INITIAL-ELEMENT." + (setq length (require-type length 'fixnum)) + (let* ((ctype (specifier-type type))) + (declare (fixnum length)) + (if (< length 0) (report-bad-arg length '(and fixnum unsigned-byte))) + (let ((tlength (array-ctype-length ctype))) + (if (and tlength (neq tlength length)) + (error 'invalid-subtype-error + :datum type + :expected-type `(vector ,(type-specifier (array-ctype-element-type ctype)) ,length)))) + (cond + ((csubtypep ctype (specifier-type 'base-string)) + (if initial-element-p + (make-string length + :element-type 'base-char + :initial-element initial-element) + (make-string length + :element-type 'base-char))) + ((csubtypep ctype (specifier-type 'vector)) + (let* ((atype (simplify-vector-ctype ctype))) + (unless (typep atype 'array-ctype) + (error "Can't determine vector element-type of ~s" (type-specifier ctype))) + (let* ((element-type (type-specifier (array-ctype-element-type atype)))) + (if (eq element-type '*) (setq element-type t)) + (if initial-element-p + (make-array (the fixnum length) + :element-type element-type + :initial-element initial-element) + (make-array (the fixnum length) + :element-type element-type))))) + ((csubtypep ctype (specifier-type 'null)) + (unless (zerop length) + (error 'invalid-subtype-error :datum type :expected-type 'cons))) + ((csubtypep ctype (specifier-type 'cons)) + (if (zerop length) + (error 'invalid-subtype-error :datum type :expected-type 'null) + (make-list length :initial-element initial-element))) + ((csubtypep ctype (specifier-type 'list)) + (make-list length :initial-element initial-element)) + (t (error 'invalid-subtype-error :datum type + :expected-type 'sequence))))) + + + +;;; Subseq: + +;;; SRC is a (SIMPLE-ARRAY * (*)), TYPECODE is its ... typecode, +;;; START and END are fixnums and sanity-checked. +(defun simple-1d-array-subseq (src typecode start end) + (declare (fixnum start end typecode)) + (let* ((n (- end start)) + (dest (%alloc-misc n typecode))) + (declare (fixnum n)) + (if (= typecode target::subtag-simple-vector) + (%copy-gvector-to-gvector src start dest 0 n) + (ecase typecode + ((#.target::subtag-s8-vector + #.target::subtag-u8-vector) + (%copy-ivector-to-ivector src start dest 0 n)) + ((#.target::subtag-s16-vector + #.target::subtag-u16-vector) + (%copy-ivector-to-ivector src + (the fixnum (+ start start)) + dest + 0 + (the fixnum (+ n n)))) + ((#.target::subtag-s32-vector + #.target::subtag-u32-vector + #.target::subtag-single-float-vector + #+32-bit-target #.target::subtag-fixnum-vector + #.target::subtag-simple-base-string) + (%copy-ivector-to-ivector src + (the fixnum (ash start 2)) + dest + 0 + (the fixnum (ash n 2)))) + ;; DOUBLE-FLOAT vectors have extra alignment padding on ppc32/x8632. + #+(or ppc32-target x8632-target) + (#.target::subtag-double-float-vector + (%copy-ivector-to-ivector src + (the fixnum (+ (the fixnum (ash start 3)) + (- target::misc-dfloat-offset + target::misc-data-offset))) + dest + (- target::misc-dfloat-offset + target::misc-data-offset) + (the fixnum (ash n 3)))) + #+64-bit-target + ((#.target::subtag-double-float-vector + #.target::subtag-s64-vector + #.target::subtag-u64-vector + #.target::subtag-fixnum-vector) + (%copy-ivector-to-ivector src + (the fixnum (ash start 3)) + dest + 0 + (the fixnum (ash n 3)))) + (#.target::subtag-bit-vector + ;; We can probably do a byte at a time if (not (logtest start 7)) + (if (not (logtest start 7)) + (%copy-ivector-to-ivector src + (the fixnum (ash (the fixnum (+ start 7)) + -3)) + dest + 0 + (the fixnum (ash (the fixnum (+ n 7)) + -3))) + ;; Harder to optimize this case. + (locally (declare (simple-bit-vector src dest) + (optimize (speed 3) (safety 0))) + (do* ((i start (1+ i)) + (j 0 (1+ j))) + ((= i end) dest) + (declare (fixnum i j)) + (setf (sbit dest j) (sbit src i)))))))))) + + +(defun nthcdr-error (index list &aux (copy list)) + "If index > length, error" + (dotimes (i index copy) + (declare (fixnum i)) + (if copy + (setq copy (cdr copy)) + (%err-disp $XACCESSNTH index list)))) + +; slisp didn't error if end > length, or if start > end. +(defun list-subseq* (sequence start end) + (declare (fixnum start end)) + (if (= start end) + nil + (let* ((groveled (nthcdr-error start sequence)) + (result (list (car groveled)))) + (when groveled + (do ((list (cdr groveled) (cdr list)) + (splice result (cdr (rplacd splice (list (car list))))) + (index (1+ start) (1+ index))) + ((= index end) result) + (declare (fixnum index)) + ()))))) + +; This ensures that start & end will be non-negative FIXNUMS ... +; This implies that the address space is < 2^31 bytes, i.e., no list +; can have a length > most-positive fixnum. Let them report it as a +; bug ... + +(defun subseq (sequence start &optional end) + "Return a copy of a subsequence of SEQUENCE starting with element number + START and continuing to the end of SEQUENCE or the optional END." + (setq end (check-sequence-bounds sequence start end)) + (locally + (declare (fixnum start end)) + (seq-dispatch + sequence + (list-subseq* sequence start end) + (let* ((typecode (typecode sequence))) + (declare (fixnum typecode)) + (when (= typecode target::subtag-vectorH) + (multiple-value-bind (data offset) + (array-data-and-offset sequence) + (declare (fixnum offset)) + (incf start offset) + (incf end offset) + (setq sequence data typecode (typecode data)))) + (simple-1d-array-subseq sequence typecode start end))))) + + +;;; Copy-seq: + +(defun copy-seq (sequence) + "Return a copy of SEQUENCE which is EQUAL to SEQUENCE but not EQ." + (seq-dispatch + sequence + (copy-list sequence) + (let* ((length (length sequence)) + (subtype (element-type-subtype (array-element-type sequence))) + (result (%alloc-misc length subtype)) + ) + (multiple-value-bind (src offset) (array-data-and-offset sequence) + (declare (fixnum offset)) + (dotimes (i length result) + (declare (fixnum i)) + (setf (uvref result i) (uvref src offset)) + (incf offset)))))) + + + +;;; Fill: + +(defun fill (sequence item &key (start 0) end) + "Replace the specified elements of SEQUENCE with ITEM. + !$ could be sped up by calling iv-fill, sv-fill to avoid aref overhead." + (setq end (check-sequence-bounds sequence start end)) + (seq-dispatch + sequence + (do* ((current (nthcdr start sequence) (cdr (the list current))) + (index start (1+ index))) + ((or (atom current) (= index end)) sequence) + (rplaca (the cons current) item)) + (if (and (typep sequence 'ivector) + (eql start 0) + (eql end (uvsize sequence))) + (%init-misc item sequence) + (do ((index start (1+ index))) + ((= index end) sequence) + (aset sequence index item))))) + +;;; Replace: + +(defun replace (target-sequence source-sequence &key + ((:start1 target-start) 0) + ((:end1 target-end)) + ((:start2 source-start) 0) + ((:end2 source-end))) + "The target sequence is destructively modified by copying successive + elements into it from the source sequence." + (setq target-end (check-sequence-bounds target-sequence target-start + target-end)) + (setq source-end (check-sequence-bounds source-sequence source-start + source-end)) + (locally (declare (fixnum target-start target-end source-start source-end)) + (seq-dispatch + target-sequence + (seq-dispatch + source-sequence + (if (and (eq target-sequence source-sequence) + (> target-start source-start)) + (let ((new-elts (subseq source-sequence source-start + (+ source-start + (min (- target-end target-start) + (- source-end source-start)))))) + (do ((n new-elts (cdr n)) + (o (nthcdr target-start target-sequence) (cdr o))) + ((null n) target-sequence) + (rplaca o (car n)))) + (do ((target-index target-start (1+ target-index)) + (source-index source-start (1+ source-index)) + (target-sequence-ref (nthcdr target-start target-sequence) + (cdr target-sequence-ref)) + (source-sequence-ref (nthcdr source-start source-sequence) + (cdr source-sequence-ref))) + ((or (= target-index target-end) (= source-index source-end) + (null target-sequence-ref) (null source-sequence-ref)) + target-sequence) + (declare (fixnum target-index source-index)) + (rplaca target-sequence-ref (car source-sequence-ref)))) + (do ((target-index target-start (1+ target-index)) + (source-index source-start (1+ source-index)) + (target-sequence-ref (nthcdr target-start target-sequence) + (cdr target-sequence-ref))) + ((or (= target-index target-end) (= source-index source-end) + (null target-sequence-ref)) + target-sequence) + (declare (fixnum target-index source-index)) + (rplaca target-sequence-ref (aref source-sequence source-index)))) + (seq-dispatch + source-sequence + (do ((target-index target-start (1+ target-index)) + (source-index source-start (1+ source-index)) + (source-sequence (nthcdr source-start source-sequence) + (cdr source-sequence))) + ((or (= target-index target-end) (= source-index source-end) + (null source-sequence)) + target-sequence) + (declare (fixnum target-index source-index)) + (aset target-sequence target-index (car source-sequence))) + ;; If we are copying around in the same vector, be careful not + ;; to copy the same elements over repeatedly. We do this by + ;; copying backwards. + (if (and (eq target-sequence source-sequence) + (> target-start source-start)) + (let ((nelts (min (- target-end target-start) + (- source-end source-start)))) + (do ((target-index (+ target-start nelts -1) (1- target-index)) + (source-index (+ source-start nelts -1) (1- source-index))) + ((= target-index (1- target-start)) target-sequence) + (aset target-sequence target-index + (aref source-sequence source-index)))) + (do ((target-index target-start (1+ target-index)) + (source-index source-start (1+ source-index))) + ((or (= target-index target-end) (= source-index source-end)) + target-sequence) + (declare (fixnum target-index source-index)) + (aset target-sequence target-index + (aref source-sequence source-index)))))))) + +;;; Concatenate: + + +(defun concatenate (output-type-spec &rest sequences) + "Return a new sequence of all the argument sequences concatenated together + which shares no structure with the original argument sequences of the + specified OUTPUT-TYPE-SPEC." + (declare (dynamic-extent sequences)) + (if (memq output-type-spec '(string simple-string)) + (setq output-type-spec 'base-string) + (unless (memq output-type-spec '(string simple-string base-string list vector + simple-base-string + bit-vector simple-bit-vector)) + (setq output-type-spec (type-expand output-type-spec)))) + (case (if (atom output-type-spec) output-type-spec (car output-type-spec)) + (list (apply #'concat-to-list* sequences)) + ((simple-vector simple-string simple-base-string base-string vector string array + bit-vector simple-bit-vector) + (apply #'concat-to-simple* output-type-spec sequences)) + (t + (if (subtypep output-type-spec 'vector) + (apply #'concat-to-simple* output-type-spec sequences) + (if (subtypep output-type-spec 'list) + (apply #'concat-to-list* sequences) + (error "~S: invalid output type specification." output-type-spec)))))) + +;;; Internal Frobs: + +(defun concat-to-list* (&rest sequences) + (declare (dynamic-extent sequences)) + (let* ((result (list nil)) + (splice result)) + (dolist (sequence sequences (%cdr result)) + (seq-dispatch + sequence + (dolist (item sequence) + (setq splice (%cdr (%rplacd splice (list item))))) + (dotimes (i (length sequence)) + (setq splice (%cdr (%rplacd splice (list (aref sequence i)))))))))) + + +(defun concat-to-simple* (output-type-spec &rest arg-sequences) + (declare (dynamic-extent arg-sequences)) + (do ((seqs arg-sequences (cdr seqs)) + (total-length 0) + ;(lengths ()) + ) + ((null seqs) + (do ((sequences arg-sequences (cdr sequences)) + ;(lengths lengths (cdr lengths)) + (index 0) + (result (make-sequence output-type-spec total-length))) + ((= index total-length) result) + (let ((sequence (car sequences))) + (seq-dispatch + sequence + (do ((sequence sequence (cdr sequence))) + ((atom sequence)) + (aset result index (car sequence)) + (setq index (1+ index))) + (let ((len (length sequence))) + (do ((jndex 0 (1+ jndex))) + ((= jndex len)) + (aset result index (aref sequence jndex)) + (setq index (1+ index)))))))) + (let ((length (length (car seqs)))) + ;(setq lengths (nconc lengths (list length))) ; if itsa list, we dont care about its length, if itsan array, length twice is cheap + (setq total-length (+ total-length length))))) + +(defun concat-to-string (&rest sequences) + (declare (dynamic-extent sequences)) + (let* ((size 0)) + (declare (fixnum size)) + (dolist (seq sequences) + (setq size (+ size (the fixnum (length seq))))) + (let* ((result (make-string size)) + (out 0)) + (declare (simple-string result) (fixnum out)) + (dolist (seq sequences result) + (etypecase seq + (simple-string + (let* ((n (length seq))) + (declare (fixnum n)) + (%copy-ivector-to-ivector seq + 0 + result + (the fixnum (ash out 2)) + (the fixnum (ash n 2))) + (incf out n))) + (string + (let* ((n (length seq))) + (declare (fixnum n)) + (multiple-value-bind (data offset) (array-data-and-offset seq) + (declare (fixnum offset)) + (%copy-ivector-to-ivector data + (the fixnum (ash offset 2)) + result + (the fixnum (ash out 2)) + (the fixnum (ash n 2))) + (incf out n)))) + (vector + (dotimes (i (length seq)) + (setf (schar result out) (aref seq i)) + (incf out))) + (list + (dolist (elt seq) + (setf (schar result out) elt)))))))) + +;This one doesn't choke on circular lists, doesn't cons as much, and is +;about 1/8K smaller to boot. +(defun map (type function sequence &rest more-sequences) + (declare (dynamic-extent more-sequences)) + (let* ((sequences (cons sequence more-sequences)) + (arglist (make-list (length sequences))) + (index 0) + args seq p (ans ())) + (declare (dynamic-extent sequences arglist)) + (unless (or (null type) + (eq type 'list) + (memq (if (consp type) (%car type) type) + '(simple-vector simple-string vector string array + simple-array bit-vector simple-bit-vector)) + (subtypep type 'sequence)) + (report-bad-arg type 'sequence)) + (loop + (setq p sequences args arglist) + (while p + (cond ((null (setq seq (%car p))) (return)) + ((consp seq) + (%rplaca p (%cdr seq)) + (%rplaca args (%car seq))) + ((eq index (length seq)) (return)) + (t (%rplaca args (elt seq index)))) + (setq args (%cdr args) p (%cdr p))) + (setq p (apply function arglist)) + (if type (push p ans)) + (setq index (%i+ index 1))) + (when type + (setq ans (nreverse ans)) + (if (eq type 'list) ans (coerce ans type))))) + +;;;;;;;;;;;;;;;;; +;; +;; some, every, notevery, notany +;; +;; these all call SOME-XX-MULTI or SOME-XX-ONE +;; SOME-XX-MULTI should probably be coded in lap +;; +;; these should be transformed at compile time +;; +;; we may want to consider open-coding when +;; the predicate is a lambda +;; + +(eval-when (:execute :compile-toplevel) + (defmacro negating-quantifier-p (quantifier-constant) + `(%i> ,quantifier-constant $notany)) + ) + +; Vector is guaranteed to be simple; new-size is guaranteed <= (length vector). +; Return vector with its size adjusted and extra doublewords zeroed out. +; Should only be called on freshly consed vectors... + + + +(defun some (predicate one-seq &rest sequences) + "Apply PREDICATE to the 0-indexed elements of the sequences, then + possibly to those with index 1, and so on. Return the first + non-NIL value encountered, or NIL if the end of any sequence is reached." + (declare (dynamic-extent sequences)) + (if sequences + (some-xx-multi $some nil predicate one-seq sequences) + (some-xx-one $some nil predicate one-seq))) + +(defun notany (predicate one-seq &rest sequences) + "Apply PREDICATE to the 0-indexed elements of the sequences, then + possibly to those with index 1, and so on. Return NIL as soon + as any invocation of PREDICATE returns a non-NIL value, or T if the end + of any sequence is reached." + (declare (dynamic-extent sequences)) + (if sequences + (some-xx-multi $notany t predicate one-seq sequences) + (some-xx-one $notany t predicate one-seq))) + +(defun every (predicate one-seq &rest sequences) + "Apply PREDICATE to the 0-indexed elements of the sequences, then + possibly to those with index 1, and so on. Return NIL as soon + as any invocation of PREDICATE returns NIL, or T if every invocation + is non-NIL." + (declare (dynamic-extent sequences)) + (if sequences + (some-xx-multi $every t predicate one-seq sequences) + (some-xx-one $every t predicate one-seq))) + +(defun notevery (predicate one-seq &rest sequences) + "Apply PREDICATE to 0-indexed elements of the sequences, then + possibly to those with index 1, and so on. Return T as soon + as any invocation of PREDICATE returns NIL, or NIL if every invocation + is non-NIL." + (declare (dynamic-extent sequences)) + (if sequences + (some-xx-multi $notevery nil predicate one-seq sequences) + (some-xx-one $notevery nil predicate one-seq))) + +(defun some-xx-multi (caller at-end predicate first-seq sequences) + (let* ((sequences (cons first-seq sequences)) + (min-vector-length target::target-most-positive-fixnum) + (arg-slice (make-list (list-length sequences))) + (cur-slice arg-slice) + (not-result (negating-quantifier-p caller)) + result) + (declare (fixnum min-vector-length) + (list sequences arg-slice cur-slice) + (dynamic-extent sequences arg-slice)) + (dolist (seq sequences) + (seq-dispatch seq + nil + (setq min-vector-length (min min-vector-length + (length seq))))) + (dotimes (index min-vector-length) + (dolist (one-seq sequences) + (%rplaca cur-slice + (if (vectorp one-seq) + (aref one-seq index) + (if one-seq + (progn + (%rplaca (memq one-seq sequences) (cdr one-seq)) + (%car one-seq)) + (return-from some-xx-multi at-end)))) + (setq cur-slice (%cdr cur-slice))) + (setq result (apply predicate arg-slice) + cur-slice arg-slice) + (if not-result + (when (not result) + (return-from some-xx-multi + (if (eq caller $every) nil t))) + (when result + (return-from some-xx-multi + (if (eq caller $some) result nil))))) + at-end)) + + +(defun some-xx-one (caller at-end predicate seq + &aux (not-result (negating-quantifier-p caller)) + result) + (if (vectorp seq) + (if (simple-vector-p seq) + (locally (declare (type simple-vector seq)) + (dovector (element seq) + (setq result (funcall predicate element)) + (if not-result + (when (not result) + (return-from some-xx-one + (if (eq caller $every) nil t))) + (when result + (return-from some-xx-one + (if (eq caller $some ) result nil)))))) + (dovector (element seq) + (setq result (funcall predicate element)) + (if not-result + (when (not result) + (return-from some-xx-one + (if (eq caller $every) nil t))) + (when result + (return-from some-xx-one + (if (eq caller $some ) result nil)))))) + (dolist (element seq) + (setq result (funcall predicate element)) + (if not-result + (when (not result) + (return-from some-xx-one + (if (eq caller $every) nil t))) + (when result + (return-from some-xx-one + (if (eq caller $some ) result nil)))))) + at-end) + +;;; simple positional versions of find, position + +(defun find-positional-test-key (item sequence test key) + (if sequence + (seq-dispatch + sequence + (let ((cons (member item sequence :test test :key key))) + (and cons (%car cons))) + (let ((pos (vector-position-1 item sequence nil test nil 0 nil key))) + (and pos (aref sequence pos)))))) + +(defun find-positional-test-not-key (item sequence test-not key) + (if sequence + (seq-dispatch + sequence + (let ((cons (member item sequence :test-not test-not :key key))) + (and cons (%car cons))) + (let ((pos (vector-position-1 item sequence nil nil test-not 0 nil key))) + (and pos (aref sequence pos)))))) + +(defun position-positional-test-key (item sequence test key) + (if sequence + (seq-dispatch + sequence + (progn + (setq key (adjust-key key)) + (setq test + (adjust-test-args item test nil)) + (if (or test key) + (list-position/find-complex nil item sequence 0 nil test nil key) + (list-position/find-simple nil item sequence 0 nil))) + (vector-position-1 item sequence nil test nil 0 nil key)))) + +(defun position-positional-test-not-key (item sequence test-not key) + (if sequence + (seq-dispatch + sequence + (progn + (setq key (adjust-key key)) + (multiple-value-bind (test test-not) + (adjust-test-args item nil test-not) + (list-position/find-complex nil item sequence 0 nil test test-not key))) + (vector-position-1 item sequence nil nil test-not 0 nil key)))) + + +;;; Reduce: + +(eval-when (:execute :compile-toplevel) + + (defmacro list-reduce (function sequence start end initial-value ivp key) + (let ((what `(if ,key (funcall ,key (car sequence)) (car sequence)))) + `(let ((sequence (nthcdr ,start ,sequence))) + (do ((count (if ,ivp ,start (1+ ,start)) (1+ count)) + (sequence (if ,ivp sequence (cdr sequence)) + (cdr sequence)) + (value (if ,ivp ,initial-value ,what) + (funcall ,function value ,what))) + ((= count ,end) value))))) + + (defmacro list-reduce-from-end (function sequence start end + initial-value ivp key) + (let ((what `(if ,key (funcall ,key (car sequence)) (car sequence)))) + `(let ((sequence (nthcdr (- (length ,sequence) ,end) (reverse ,sequence)))) + (do ((count (if ,ivp ,start (1+ ,start)) (1+ count)) + (sequence (if ,ivp sequence (cdr sequence)) + (cdr sequence)) + (value (if ,ivp ,initial-value ,what) + (funcall ,function ,what value))) + ((= count ,end) value))))) + + ) ;; end eval-when + +(defun reduce (function sequence &key from-end (start 0) + end (initial-value nil ivp) key) + "The specified Sequence is ``reduced'' using the given Function. + See manual for details." + (unless end (setq end (length sequence))) + (if (= end start) + (if ivp initial-value (funcall function)) + (seq-dispatch + sequence + (if from-end + (list-reduce-from-end function sequence start end initial-value ivp key) + (list-reduce function sequence start end initial-value ivp key)) + (let* ((disp (if from-end -1 1)) + (index (if from-end (1- end) start)) + (terminus (if from-end (1- start) end)) + (value (if ivp initial-value + (let ((elt (aref sequence index))) + (setq index (+ index disp)) + (if key (funcall key elt) elt)))) + (element nil)) + (do* () + ((= index terminus) value) + (setq element (aref sequence index) + index (+ index disp) + element (if key (funcall key element) element) + value (funcall function (if from-end element value) (if from-end value element)))))))) + +(defun map-into (result-sequence function &rest sequences) + (declare (dynamic-extent sequences)) + (let* ((nargs (list-length sequences)) + (temp (make-list (length sequences))) + (maxcnt (seq-dispatch result-sequence (length result-sequence) (array-total-size result-sequence))) + (rseq result-sequence)) + (declare (fixnum nargs maxcnt)) + (declare (dynamic-extent temp)) + ; this declaration is maybe bogus + (dolist (seq sequences) + (let ((len (length seq))) + (declare (fixnum len)) + (if (< len maxcnt)(setq maxcnt len)))) + (dotimes (cnt maxcnt) + (let ((args temp)(seqs sequences)) + (dotimes (i nargs) + (let ((seq (%car seqs))) + (cond ((listp seq) + (%rplaca seqs (%cdr seq)) + (%rplaca args (%car seq))) + (t (%rplaca args (aref seq cnt))))) + (setq args (%cdr args)) + (setq seqs (%cdr seqs)))) + (let ((res (apply function temp))) + (cond ((consp rseq) + (%rplaca rseq res) + (setq rseq (%cdr rseq))) + (t (setf (aref result-sequence cnt) res))))) + (when (and (not (listp result-sequence)) + (array-has-fill-pointer-p result-sequence)) + (setf (fill-pointer result-sequence) maxcnt)) + result-sequence)) + + +;;; Coerce: + +#| +; don't know if this is always right +; It's almost never right: the "type-spec" could be something +; defined with DEFTYPE, whose last element (if it has one) has +; nothing to do with the "length" of the specified type. +(defun specifier-length (type-spec) + (if (consp type-spec) + (let ((len? (car (last type-spec)))) + (if (fixnump len?) len?)))) +|# + + +(defun array-ctype-length (ctype) + (if (typep ctype 'array-ctype) + (let* ((dims (array-ctype-dimensions ctype))) + (if (listp dims) + (if (null (cdr dims)) + (let* ((dim0 (car dims))) + (unless (eq dim0 '*) dim0))))))) + + + + +; from optimizer - just return object if type is OK + + +;If you change this, remember to change the transform. +(defun coerce (object output-type-spec) + "Coerce the Object to an object of type Output-Type-Spec." + (let* ((type (specifier-type output-type-spec))) + (if (%typep object type) + object + (cond + ((csubtypep type (specifier-type 'character)) + (character object)) + ((eq output-type-spec 'standard-char) + (let ((char (character object))) + (unless (standard-char-p char) (%err-disp $xcoerce object 'standard-char)) + char)) + ((eq output-type-spec 'compiled-function) + (coerce-to-compiled-function object)) + ((csubtypep type (specifier-type 'function)) + (coerce-to-function-1 object)) + ((csubtypep type (specifier-type 'cons)) + (if object + (coerce-to-list object) + (report-bad-arg object 'cons))) + ((csubtypep type (specifier-type 'list)) + (coerce-to-list object)) + ((csubtypep type (specifier-type 'string)) + (let ((length (array-ctype-length type))) + (if (and length (neq length (length object))) + (report-bad-arg (make-string length) `(string ,(length object))))) + (coerce-to-uarray object #.(type-keyword-code :simple-string) + t)) + ((csubtypep type (specifier-type 'vector)) + (let ((length (array-ctype-length type))) + (if (and length (neq length (length object))) + (error 'invalid-subtype-error + :datum output-type-spec + :expected-type `(vector * ,(length object))))) + (let* ((atype (simplify-vector-ctype type))) + (unless (typep atype 'array-ctype) + (error "Can't determine vector type of ~s" output-type-spec)) + (let* ((element-type (type-specifier (array-ctype-element-type atype)))) + (let ((length (array-ctype-length atype))) + (if (and length (neq length (length object))) + (report-bad-arg (make-array length :element-type element-type) + `(vector ,element-type ,(length object)))) + (coerce-to-uarray object (element-type-subtype element-type) t))))) + ((csubtypep type (specifier-type 'array)) + (let* ((dims (array-ctype-dimensions type))) + (when (consp dims) + (when (not (null (cdr dims)))(error "~s is not a sequence type." output-type-spec)))) + (let ((length (array-ctype-length type))) + (if (and length (neq length (length object))) + (error "Length of ~s is not ~s." object length))) + (coerce-to-uarray object (element-type-subtype (type-specifier + (array-ctype-element-type type))) t)) + ((numberp object) + (let ((res + (cond + ((csubtypep type (specifier-type 'double-float)) + (float object 1.0d0)) + ((csubtypep type (specifier-type 'float)) + (float object 1.0s0)) + ((csubtypep type (specifier-type 'complex)) + (coerce-to-complex object output-type-spec))))) + (unless res ;(and res (%typep res type)) + (error "~S can't be coerced to type ~S." object output-type-spec)) + res)) + (t (error "~S can't be coerced to type ~S." object output-type-spec)))))) + +(defun %coerce-to-string (seq) + (let* ((len (length seq)) + (string (make-string len))) + (declare (fixnum len) (simple-base-string string)) + (if (typep seq 'list) + (do* ((l seq (cdr l)) + (i 0 (1+ i))) + ((null l) string) + (declare (list l) ; we know that it's a proper list because LENGTH won + (fixnum i)) + (setf (schar string i) (car l))) + (dotimes (i len string) + (setf (schar string i) (aref seq i)))))) + +(defun %coerce-to-vector (seq subtype) + (let* ((len (length seq)) + (vector (%alloc-misc len subtype))) + (declare (fixnum len) (type (simple-array * (*)) vector)) + (if (typep seq 'list) + (do* ((l seq (cdr l)) + (i 0 (1+ i))) + ((null l) vector) + (declare (list l) ; we know that it's a proper list because LENGTH won + (fixnum i)) + (setf (uvref vector i) (car l))) + (dotimes (i len vector) + (setf (uvref vector i) (aref seq i)))))) + +(defun %coerce-to-list (seq) + (if (typep seq 'list) + seq + (collect ((result)) + (dotimes (i (length seq) (result)) + (result (aref seq i)))))) + + + + +(defun coerce-to-complex (object output-type-spec) + (if (consp output-type-spec) + (let ((type2 (cadr output-type-spec))) + (if (complexp object) + (complex (coerce (realpart object) type2)(coerce (imagpart object) type2)) + (complex (coerce object type2) 0))) + (complex object))) + + +(defun coerce-to-function-1 (thing) + (if (functionp thing) + thing + (if (symbolp thing) + (%function thing) + (if (lambda-expression-p thing) + (%make-function nil thing nil) + (%err-disp $xcoerce thing 'function))))) + +;;; Internal Frobs: +;(coerce object ') +(defun coerce-to-uarray (object subtype simple-p) + (if (typep object 'array) + (if (and (or (not simple-p) (typep object 'simple-array)) + (or (null subtype) (eq (array-element-subtype object) subtype))) + object + ;Make an array of the same shape as object but different subtype.. + (%copy-array subtype object)) + (if (typep object 'list) + (%list-to-uvector subtype object) + (%err-disp $xcoerce object 'array)))) + +;(coerce object 'list) +(defun coerce-to-list (object) + (seq-dispatch + object + object + (let* ((n (length object))) + (declare (fixnum n)) + (multiple-value-bind (data offset) (array-data-and-offset object) + (let* ((head (cons nil nil)) + (tail head)) + (declare (dynamic-extent head) + (cons head tail)) + (do* ((i 0 (1+ i)) + (j offset (1+ j))) + ((= i n) (cdr head)) + (declare (fixnum i j)) + (setq tail (cdr (rplacd tail (cons (uvref data j) nil)))))))))) + + +(defun %copy-array (new-subtype array) + ;To be rewritten once make-array disentangled (so have a subtype-based entry + ;point) + (make-array (if (eql 1 (array-rank array)) + (length array) + (array-dimensions array)) + :element-type (element-subtype-type new-subtype) + :initial-contents array ;***** WRONG ***** + )) + +(defun check-count (c) + (if c + (min (max (require-type c 'integer) 0) target::target-most-positive-fixnum) + target::target-most-positive-fixnum)) + +;;; Delete: + +(defun list-delete-1 (item list from-end test test-not start end count key + &aux (temp list) revp) + (unless end (setq end target::target-most-positive-fixnum)) + (when (and from-end count) + (let ((len (length temp))) + (if (not (%i< start len)) + (return-from list-delete-1 temp)) + (setq temp (nreverse temp) revp t) + (psetq end (%i- len start) + start (%i- len (%imin len end))))) + (setq key (adjust-key key)) + (multiple-value-setq (test test-not) + (adjust-test-args item test test-not)) + (setq temp + (if (or test key test-not) + (list-delete-moderately-complex item temp start end count test test-not key) + (list-delete-very-simple item temp start end count))) + (if revp + (nreverse temp) + temp)) + + +(defun list-delete-very-simple (item list start end count) + (unless start (setq start 0)) + (unless end (setq end target::target-most-positive-fixnum)) + (setq count (check-count count)) + (do* ((handle (cons nil list)) + (splice handle) + (numdeleted 0) + (i 0 (1+ i))) + ((or (eq i end) (null (%cdr splice)) (eq numdeleted count)) + (%cdr handle)) + (declare (fixnum i start end count numdeleted) ; declare-type-free !! + (dynamic-extent handle) + (list splice handle)) + (if (and (%i>= i start) (eq item (car (%cdr splice)))) + (progn + (%rplacd splice (%cddr splice)) + (setq numdeleted (%i+ numdeleted 1))) + (setq splice (%cdr splice))))) + +(defun list-delete-moderately-complex (item list start end count test test-not key) + (unless start (setq start 0)) + (unless end (setq end target::target-most-positive-fixnum)) + (setq count (check-count count)) + (do* ((handle (cons nil list)) + (splice handle) + (numdeleted 0) + (i 0 (1+ i))) + ((or (= i end) (null (cdr splice)) (= numdeleted count)) + (cdr handle)) + (declare (fixnum i start end count numdeleted) + (dynamic-extent handle) + (list splice)) + (if (and (>= i start) (matchp2 item (cadr splice) test test-not key)) + (progn + (rplacd splice (cddr splice)) + (setq numdeleted (1+ numdeleted))) + (setq splice (cdr splice))))) + +(defun list-delete (item list &key from-end test test-not (start 0) + end count key + &aux (temp list) revp) + (unless end (setq end target::target-most-positive-fixnum)) + (when (and from-end count) + (let ((len (length temp))) + (if (not (%i< start len)) + (return-from list-delete temp)) + (setq temp (nreverse temp) revp t) + (psetq end (%i- len start) + start (%i- len (%imin len end))))) + (setq key (adjust-key key)) + (multiple-value-setq (test test-not) + (adjust-test-args item test test-not)) + (setq temp + (if (or test key test-not) + (list-delete-moderately-complex item temp start end count test test-not key) + (list-delete-very-simple item temp start end count))) + (if revp + (nreverse temp) + temp)) + +; The vector will be freshly consed & nothing is displaced to it, +; so it's legit to destructively truncate it. +; Likewise, it's ok to access its components with UVREF. + +(defun simple-vector-delete (item vector test test-not key start end inc count + &aux (length (length vector)) + subtype pos fill) + (setq key (adjust-key key)) + (multiple-value-setq (test test-not) (adjust-test-args item test test-not)) + (setq end (check-sequence-bounds vector start end)) + (setq fill start) + (if (%i< inc 0) (psetq start (%i- end 1) end (%i- start 1))) + (let* ((bv (make-array (the fixnum (length vector)) :element-type 'bit :Initial-element 0)) + offset) + (declare (dynamic-extent bv) + (type (simple-array bit (*)) bv)) + (multiple-value-setq (vector offset)(array-data-and-offset vector)) + (setq subtype (typecode vector)) + (setq pos start) + (loop + (when (or (eq count 0) (eq pos end)) + (unless (eq pos end) + (incf fill (abs (- pos end)))) + (return)) + (if (matchp2 item (uvref vector (%i+ pos offset)) + test test-not key) + (progn (setf (aref bv pos) 1) + (setq count (%i- count 1))) + (setq fill (%i+ fill 1))) + (setq pos (%i+ pos inc))) + (when (%i< inc 0) + (psetq start (%i+ end 1) end (%i+ start 1))) + (let* ((tail (- length end)) + (size (+ fill tail)) + (new-vect (%alloc-misc size subtype)) + (fill-end fill)) + (declare (fixnum tail size)) + (when (neq 0 start) + (dotimes (i start) + (setf (uvref new-vect i) (uvref vector (%i+ offset i))) + )) + (setq fill start) + (setq pos start) + (loop + (if (eq fill fill-end) (return)) + (if (neq 1 (aref bv pos)) + (progn + (setf (uvref new-vect fill) (uvref vector (%i+ offset pos))) + (setq fill (%i+ fill 1)))) + (setq pos (%i+ pos 1))) + (setq pos end) + (loop + (when (eq fill size) (return)) + (setf (uvref new-vect fill) (uvref vector (%i+ offset pos))) + (setq fill (%i+ fill 1) + pos (%i+ pos 1))) + new-vect))) + + +; When a vector has a fill pointer & it can be "destructively modified" by adjusting +; that fill pointer. +(defun vector-delete (item vector test test-not key start end inc count + &aux (length (length vector)) pos fill val) + (setq key (adjust-key key)) + (multiple-value-setq (test test-not) (adjust-test-args item test test-not)) + (setq end (check-sequence-bounds vector start end)) + (if (%i< inc 0) (psetq start (%i- end 1) end (%i- start 1))) + (setq fill (setq pos start)) + (loop + (if (or (eq count 0) (eq pos end)) (return)) + (if (matchp2 item (setq val (aref vector pos)) test test-not key) + (setq count (%i- count 1)) + (progn + (if (neq fill pos) (setf (aref vector fill) val)) + (setq fill (%i+ fill inc)))) + (setq pos (%i+ pos inc))) + (if (%i> fill pos) (psetq fill (%i+ pos 1) pos (%i+ fill 1))) + (loop + (if (eq pos length) (return)) + (setf (aref vector fill) (aref vector pos)) + (setq fill (%i+ fill 1) pos (%i+ pos 1))) + (when (eq t (array-element-type vector)) + (let ((old-fill (fill-pointer vector)) + (i fill)) + (declare (fixnum i old-fill)) + (loop + (when (>= i old-fill) (return)) + (setf (aref vector i) nil) + (incf i)))) + (setf (fill-pointer vector) fill) + vector) + +(defun delete (item sequence &key from-end test test-not (start 0) + end count key) + "Return a sequence formed by destructively removing the specified ITEM from + the given SEQUENCE." + (setq count (check-count count)) + (if sequence + (seq-dispatch + sequence + (list-delete-1 item + sequence + from-end + test + test-not + start + end + count + key) + (if (array-has-fill-pointer-p sequence) + (vector-delete item sequence test test-not key start end (if from-end -1 1) count) + (simple-vector-delete item + sequence + test test-not key start end (if from-end -1 1) count))))) + +(defun delete-if (test sequence &key from-end (start 0) + end count key) + "Return a sequence formed by destructively removing the elements satisfying + the specified PREDICATE from the given SEQUENCE." + (delete test sequence + :test #'funcall + :from-end from-end + :start start + :end end + :count count + :key key)) + +(defun delete-if-not (test sequence &key from-end (start 0) end count key) + "Return a sequence formed by destructively removing the elements not + satisfying the specified PREDICATE from the given SEQUENCE." + (delete test sequence + :test-not #'funcall + :from-end from-end + :start start + :end end + :count count + :key key)) + + + +;;; Remove: + + + +(defun remove (item sequence &key from-end test test-not (start 0) + end count key) + "Return a copy of SEQUENCE with elements satisfying the test (default is + EQL) with ITEM removed." + (setq count (check-count count)) + (seq-dispatch + sequence + (list-delete-1 item + (copy-list sequence) + from-end + test + test-not + start + end + count + key) + (simple-vector-delete item + sequence + test + test-not + key + start + end + (if from-end -1 1) + count))) + + + + +(defun remove-if (test sequence &key from-end (start 0) + end count key) + "Return a copy of sequence with elements such that predicate(element) + is non-null removed" + (setq count (check-count count)) + (remove test sequence + :test #'funcall + :from-end from-end + :start start + :end end + :count count + :key key)) + +(defun remove-if-not (test sequence &key from-end (start 0) + end count key) + "Return a copy of sequence with elements such that predicate(element) + is null removed" + (setq count (check-count count)) + (remove test sequence + :test-not #'funcall + :from-end from-end + :start start + :end end + :count count + :key key)) + +;;; Remove-Duplicates: + +;;; Remove duplicates from a list. If from-end, remove the later duplicates, +;;; not the earlier ones. Thus if we check from-end we don't copy an item +;;; if we look into the already copied structure (from after :start) and see +;;; the item. If we check from beginning we check into the rest of the +;;; original list up to the :end marker (this we have to do by running a +;;; do loop down the list that far and using our test. +; test-not is typically NIL, but member doesn't like getting passed NIL +; for its test-not fn, so I special cased the call to member. --- cfry + +(defun remove-duplicates (sequence &key (test #'eql) test-not (start 0) + from-end end key) + "The elements of SEQUENCE are compared pairwise, and if any two match, + the one occurring earlier is discarded, unless FROM-END is true, in + which case the one later in the sequence is discarded. The resulting + sequence is returned. + + The :TEST-NOT argument is deprecated." + (setq end (check-sequence-bounds sequence start end)) + (delete-duplicates (copy-seq sequence) :from-end from-end :test test + :test-not test-not :start start :end end :key key)) + +;;; Delete-Duplicates: + +(defparameter *delete-duplicates-hash-threshold* 200) + +(defun list-delete-duplicates* (list test test-not key from-end start end) + ;;(%print "test:" test "test-not:" test-not "key:" key) + (let* ((len (- end start)) + (handle (cons nil list)) + (previous (nthcdr start handle))) + (declare (dynamic-extent handle)) + (if (and (> len *delete-duplicates-hash-threshold*) + (or (eq test 'eq) (eq test 'eql) (eq test 'equal) (eq test 'equalp) + (eq test #'eq) (eq test #'eql) (eq test #'equal) (eq test #'equalp))) + (let ((hash (make-hash-table :size len :test test :shared nil))) + (loop for i from start below end as obj in (cdr previous) + do (incf (gethash (funcall key obj) hash 0))) + (loop for i from start below end while (cdr previous) + do (let* ((current (cdr previous)) + (obj (car current)) + (obj-key (funcall key obj))) + (if (if from-end + ;; Keep first ref + (prog1 (gethash obj-key hash) (setf (gethash obj-key hash) nil)) + ;; Keep last ref + (eql (decf (gethash obj-key hash)) 0)) + (setq previous current) + (rplacd previous (cdr current)))))) + (do ((current (cdr previous) (cdr current)) + (index start (1+ index))) + ((or (= index end) (null current))) + ;;(%print "outer loop top current:" current "previous:" previous) + (if (do ((x (if from-end + (nthcdr (1+ start) handle) + (cdr current)) + (cdr x)) + (i (1+ index) (1+ i))) + ((or (null x) + (and (not from-end) (= i end)) + (eq x current)) + nil) + ;;(%print "inner loop top x:" x "i:" i) + (if (list-delete-duplicates*-aux current x test test-not key) + (return t))) + (rplacd previous (cdr current)) + (setq previous (cdr previous))))) + (cdr handle))) + +(defun list-delete-duplicates*-aux (current x test test-not key) + (if test-not + (not (funcall test-not + (funcall key (car current)) + (funcall key (car x)))) + (funcall test + (funcall key (car current)) + (funcall key (car x))))) + + +(defun vector-delete-duplicates* (vector test test-not key from-end start end + &optional (length (length vector))) + (declare (vector vector)) + (let* ((len (- end start)) + (index start) + (jndex start)) + (if (and (not test-not) + (> len *delete-duplicates-hash-threshold*) + (or (eq test 'eq) (eq test 'eql) (eq test 'equal) (eq test 'equalp) + (eq test #'eq) (eq test #'eql) (eq test #'equal) (eq test #'equalp))) + (let ((hash (make-hash-table :size len :test test :shared nil))) + (loop for i from start below end as obj = (aref vector i) + do (incf (gethash (funcall key obj) hash 0))) + (loop while (< index end) as obj = (aref vector index) as obj-key = (funcall key obj) + do (incf index) + do (when (if from-end + (prog1 (gethash obj-key hash) (setf (gethash obj-key hash) nil)) + (eql (decf (gethash obj-key hash)) 0)) + (aset vector jndex obj) + (incf jndex)))) + (loop while (< index end) as obj = (aref vector index) + do (incf index) + do (unless (position (funcall key obj) vector :key key + :start (if from-end start index) :test test + :end (if from-end jndex end) :test-not test-not) + (aset vector jndex obj) + (incf jndex)))) + (do ((index index (1+ index)) ; copy the rest of the vector + (jndex jndex (1+ jndex))) + ((= index length) + (setq vector (shrink-vector vector jndex))) + (aset vector jndex (aref vector index))))) + + +(defun delete-duplicates (sequence &key (test #'eql) test-not (start 0) from-end end key) + "The elements of SEQUENCE are examined, and if any two match, one is + discarded. The resulting sequence, which may be formed by destroying the + given sequence, is returned. + Sequences of type STR have a NEW str returned." + (setq end (check-sequence-bounds sequence start end)) + (unless key (setq key #'identity)) + (seq-dispatch sequence + (if sequence + (list-delete-duplicates* sequence test test-not key from-end start end)) + (vector-delete-duplicates* sequence test test-not key from-end start end))) + +(defun list-substitute* (pred new list start end count key + test test-not old) + ;(print-db pred new list start end count key test test-not old) + (let* ((result (list nil)) + elt + (splice result) + (list list)) ; Get a local list for a stepper. + (do ((index 0 (1+ index))) + ((= index start)) + (setq splice (cdr (rplacd splice (list (car list))))) + (setq list (cdr list))) + (do ((index start (1+ index))) + ((or (and end (= index end)) (null list) (= count 0))) + (setq elt (car list)) + (setq splice + (cdr (rplacd splice + (list + (cond ((case pred + (normal + (if test-not + (not (funcall test-not old + ;fry mod to slisp, which had arg order of OLD and ELT reversed. + (funcall key elt))) + (funcall test old + (funcall key elt)))) + (if (funcall test (funcall key elt))) + (if-not (not (funcall test + (funcall key elt))))) + (setq count (1- count)) + new) + (t elt)))))) + (setq list (cdr list))) + (do () + ((null list)) + (setq splice (cdr (rplacd splice (list (car list))))) + (setq list (cdr list))) + (cdr result))) + +;;; Replace old with new in sequence moving from left to right by incrementer +;;; on each pass through the loop. Called by all three substitute functions. +(defun vector-substitute* (pred new sequence incrementer left right length + start end count key test test-not old) + (let ((result (make-sequence-like sequence length)) + (index left)) + (do () + ((= index start)) + (aset result index (aref sequence index)) + (setq index (+ index incrementer))) + (do ((elt)) + ((or (= index end) (= count 0))) + (setq elt (aref sequence index)) + (aset result index + (cond ((case pred + (normal + (if test-not + (not (funcall test-not old (funcall key elt))) ;cfry mod + (funcall test old (funcall key elt)))) ;cfry mod + (if (funcall test (funcall key elt))) + (if-not (not (funcall test (funcall key elt))))) + (setq count (1- count)) + new) + (t elt))) + (setq index (+ index incrementer))) + (do () + ((= index right)) + (aset result index (aref sequence index)) + (setq index (+ index incrementer))) + result)) + +;;; Substitute: + +(defun substitute (new old sequence &key from-end (test #'eql) test-not + (start 0) count + end (key #'identity)) + "Return a sequence of the same kind as SEQUENCE with the same elements, + except that all elements equal to OLD are replaced with NEW. See manual + for details." + (setq count (check-count count)) + (let ((length (length sequence)) ) + (setq end (check-sequence-bounds sequence start end)) + (seq-dispatch + sequence + (if from-end + (nreverse (list-substitute* 'normal new (reverse sequence) (- length end) + (- length start) count key test test-not old)) + (list-substitute* 'normal new sequence start end count key test test-not + old)) + (if from-end + (vector-substitute* 'normal new sequence -1 (1- length) -1 length + (1- end) (1- start) count key test test-not old) + (vector-substitute* 'normal new sequence 1 0 length length + start end count key test test-not old))))) + + +(defun substitute-if (new test sequence &key from-end (start 0) + (end (length sequence)) + count (key #'identity)) + "Return a sequence of the same kind as SEQUENCE with the same elements + except that all elements satisfying the PRED are replaced with NEW. See + manual for details." + (substitute new test sequence + :from-end from-end + :test #'funcall + :start start + :end end + :from-end from-end + :count count + :key key)) + +(defun substitute-if-not (new test sequence &key from-end (start 0) + (end (length sequence)) + count (key #'identity)) + "Return a sequence of the same kind as SEQUENCE with the same elements + except that all elements not satisfying the PRED are replaced with NEW. + See manual for details." + (substitute new test sequence + :from-end from-end + :test-not #'funcall + :start start + :end end + :from-end from-end + :count count + :key key)) + +;;; NSubstitute: + +(defun nsubstitute (new old sequence &key from-end (test #'eql) test-not + end + (count target::target-most-positive-fixnum) (key #'identity) (start 0)) + "Return a sequence of the same kind as SEQUENCE with the same elements + except that all elements equal to OLD are replaced with NEW. The SEQUENCE + may be destructively modified. See manual for details." + (setq count (check-count count)) + (let ((incrementer 1) + (length (length sequence))) + (setq end (check-sequence-bounds sequence start end)) + (seq-dispatch + sequence + (if from-end + (nreverse (nlist-substitute* + new old (nreverse (the list sequence)) + test test-not + (- length end) + (- length start) + count key)) + (nlist-substitute* new old sequence + test test-not start end count key)) + (progn + (if from-end + (psetq start (1- end) + end (1- start) + incrementer -1)) + (nvector-substitute* new old sequence incrementer + test test-not start end count key))))) + +(defun nlist-substitute* (new old sequence test test-not start end count key) + (do ((list (nthcdr start sequence) (cdr list)) + (index start (1+ index))) + ((or (and end (= index end)) (null list) (= count 0)) sequence) + (when (if test-not + (not (funcall test-not old (funcall key (car list)))) ;cfry mod + (funcall test old (funcall key (car list)))) ;cfry mod + (rplaca list new) + (setq count (1- count))))) + +(defun nvector-substitute* (new old sequence incrementer + test test-not start end count key) + (do ((index start (+ index incrementer))) + ((or (= index end) (= count 0)) sequence) + (when (if test-not + (not (funcall test-not old (funcall key (aref sequence index)))) + ;above cfry mod. both order of argss to test-not and paren error + ; between the funcall key and the funcall test-not + (funcall test old (funcall key (aref sequence index)))) ;cfry mod + (aset sequence index new) + (setq count (1- count))))) + +;;; NSubstitute-If: + +(defun nsubstitute-if (new test sequence &key from-end (start 0) + end + (count target::target-most-positive-fixnum) (key #'identity)) + "Return a sequence of the same kind as SEQUENCE with the same elements + except that all elements satisfying the PRED are replaced with NEW. + SEQUENCE may be destructively modified. See manual for details." + (nsubstitute new test sequence + :from-end from-end + :test #'funcall + :start start + :end end + :count count + :key key)) + + +;;; NSubstitute-If-Not: + +(defun nsubstitute-if-not (new test sequence &key from-end (start 0) + end (count target::target-most-positive-fixnum) (key #'identity)) + "Return a sequence of the same kind as SEQUENCE with the same elements + except that all elements not satisfying the TEST are replaced with NEW. + SEQUENCE may be destructively modified. See manual for details." + (nsubstitute new test sequence + :from-end from-end + :test-not #'funcall + :start start + :end end + :count count + :key key)) + + +;;; Position: + +(defun list-position/find-1 (eltp item list from-end test test-not start end key &aux hard) + ;;if eltp is true, return element, otherwise return position + (setq key (adjust-key key)) + (multiple-value-setq (test test-not) + (adjust-test-args item test test-not)) + (setq end (check-sequence-bounds list start end) + hard (or test key test-not)) + (if from-end + (if hard + (list-position/find-from-end-complex eltp item list start end test test-not key) + (list-position/find-from-end-simple eltp item list start end)) + (if hard + (list-position/find-complex eltp item list start end test test-not key) + (list-position/find-simple eltp item list start end)))) + +(defun position (item sequence &key from-end test test-not (start 0) end key) + (if sequence + (seq-dispatch + sequence + (list-position/find-1 nil item sequence from-end test test-not start end key) + (vector-position-1 item sequence from-end test test-not start end key)))) + +;Is it really necessary for these internal functions to take keyword args? +(defun list-position/find (eltp item list &key from-end test test-not (start 0) end key &aux hard) + ;;if eltp is true, return element, otherwise return position + (setq key (adjust-key key)) + (multiple-value-setq (test test-not) + (adjust-test-args item test test-not)) + (setq end (check-sequence-bounds list start end) + hard (or test key test-not)) + (if from-end + (if hard + (list-position/find-from-end-complex eltp item list start end test test-not key) + (list-position/find-from-end-simple eltp item list start end)) + (if hard + (list-position/find-complex eltp item list start end test test-not key) + (list-position/find-simple eltp item list start end)))) + +;;; make these things positional + + + +;;; add a simple-vector case + +(defun vector-position-1 (item vector from-end test test-not start end key + &aux (inc (if from-end -1 1)) pos) + (setq end (check-sequence-bounds vector start end)) + (setq key (adjust-key key)) + (multiple-value-setq (test test-not) (adjust-test-args item test test-not)) + (if from-end (psetq start (%i- end 1) end (%i- start 1))) + (setq pos start) + (if (simple-vector-p vector) + (locally (declare (type simple-vector vector) + (optimize (speed 3) (safety 0))) + (loop + (if (eq pos end) (return)) + (if (matchp2 item (aref vector pos) test test-not key) (return pos)) + (setq pos (%i+ pos inc)))) + (loop + (if (eq pos end) (return)) + (if (matchp2 item (aref vector pos) test test-not key) (return pos)) + (setq pos (%i+ pos inc))))) + +(defun list-position/find-simple (eltp item list start end &aux (pos 0)) + (loop + (if (or (eq pos start) (null list)) + (return) + (setq list (cdr list) pos (%i+ pos 1)))) + (loop + (if (and list (neq end pos)) + (if (eq item (car list)) + (return (if eltp item pos)) + (setq list (%cdr list) pos (%i+ pos 1))) + (return)))) + +(defun list-position/find-complex (eltp item list start end test test-not key &aux (pos 0)) + (loop + (if (or (eq pos start) (null list)) + (return) + (setq list (cdr list) pos (%i+ pos 1)))) + (loop + (if (and list (neq end pos)) + (progn + (if (matchp2 item (car list) test test-not key) + (return (if eltp (%car list) pos)) + (setq list (%cdr list) pos (%i+ pos 1)))) + (return)))) + +(defun list-position/find-from-end-simple (eltp item list start end &aux (pos 0) ret) + (loop + (if (or (eq pos start) (null list)) + (return) + (setq list (cdr list) pos (%i+ pos 1)))) + (loop + (if (and list (neq end pos)) + (progn + (if (eq item (car list)) (setq ret pos)) + (setq list (%cdr list) pos (%i+ pos 1))) + (return (if eltp (if ret item) ret))))) + +(defun list-position/find-from-end-complex (eltp item list start end test test-not key + &aux (pos 0) ret val) + (loop + (if (or (eq pos start) (null list)) + (return) + (setq list (cdr list) pos (%i+ pos 1)))) + (loop + (if (and list (neq end pos)) + (progn + (if (matchp2 item (setq val (car list)) test test-not key) + (setq ret (if eltp val pos))) + (setq list (%cdr list) pos (%i+ pos 1))) + (return ret)))) + +(defun vector-position (item vector &key from-end test test-not (start 0) end key + &aux (inc (if from-end -1 1)) pos) + (setq end (check-sequence-bounds vector start end)) + (setq key (adjust-key key)) + (multiple-value-setq (test test-not) (adjust-test-args item test test-not)) + (if from-end (psetq start (%i- end 1) end (%i- start 1))) + (setq pos start) + (loop + (if (eq pos end) (return)) + (if (matchp2 item (aref vector pos) test test-not key) (return pos)) + (setq pos (%i+ pos inc)))) + +;;; Position-if: + +(defun position-if (test sequence &key from-end (start 0) end key) + (position test sequence + :test #'funcall + :from-end from-end + :start start + :end end + :key key)) + + +;;; Position-if-not: + +(defun position-if-not (test sequence &key from-end (start 0) end key) + (position test sequence + :test-not #'funcall + :from-end from-end + :start start + :end end + :key key)) + +;;; Count: + +(defun vector-count-from-start (test item sequence start end key) + (declare (fixnum start end)) + (do* ((index start (1+ index)) + (count 0)) + ((= index end) count) + (declare (fixnum index count)) + (when (funcall test item (funcall key (aref sequence index))) + (incf count)))) + +(defun vector-count-from-end (test item sequence start end key) + (declare (fixnum start end)) + (do* ((index (1- end) (1- index)) + (count 0) + (limit (1- start))) + ((= index limit) count) + (declare (fixnum index count limit)) + (when (funcall test item (funcall key (aref sequence index))) + (incf count)))) + +(defun vector-count-not-p-from-start (test-not item sequence start end key) + (declare (fixnum start end)) + (do* ((index start (1+ index)) + (count 0)) + ((= index end) count) + (declare (fixnum index count)) + (unless (funcall test-not item (funcall key (aref sequence index))) + (incf count)))) + +(defun vector-count-not-p-from-end (test-not item sequence start end key) + (declare (fixnum start end)) + (do* ((index (1- end) (1- index)) + (count 0) + (limit (1- start))) + ((= index limit) count) + (declare (fixnum index count limit)) + (unless (funcall test-not item (funcall key (aref sequence index))) + (incf count)))) + +(defun list-count-from-start (test item sequence start end key) + (declare (fixnum start end) (list sequence)) + (do* ((seq (nthcdr start sequence) (cdr seq)) + (element (car seq) (car seq)) + (index start (1+ index)) + (count 0)) + ((or (= index end) (null seq)) count) + (declare (fixnum index count) (list seq)) + (when (funcall test item (funcall key element)) + (incf count)))) + +(defun list-count-from-end (test item sequence start end key) + (declare (fixnum start end)) + (let* ((len (length sequence))) + (declare (fixnum len)) + (list-count-from-start test item (reverse sequence) (- len end) (- len start) key))) + +(defun list-count-not-p-from-start (test-not item sequence start end key) + (declare (fixnum start end) (list sequence)) + (do* ((seq (nthcdr start sequence) (cdr seq)) + (element (car seq) (car seq)) + (index start (1+ index)) + (count 0)) + ((or (= index end) (null seq)) count) + (declare (fixnum index count) (list seq)) + (unless (funcall test-not item (funcall key element)) + (incf count)))) + +(defun list-count-not-p-from-end (test-not item sequence start end key) + (declare (fixnum start end)) + (let* ((len (length sequence))) + (declare (fixnum len)) + (list-count-not-p-from-start test-not item (reverse sequence) (- len end) (- len start) key))) + +(defun count (item sequence &key from-end (test #'eql testp) + (test-not nil notp) (start 0) end key) + "Return the number of elements in SEQUENCE satisfying a test with ITEM, + which defaults to EQL." + (if (and testp notp) + (test-not-error test test-not)) + (unless key + (setq key #'identity)) + (setq end (check-sequence-bounds sequence start end)) + (if sequence + (seq-dispatch + sequence + (if notp + (if from-end + (list-count-not-p-from-end test-not item sequence start end key) + (list-count-not-p-from-start test-not item sequence start end key)) + (if from-end + (list-count-from-end test item sequence start end key) + (list-count-from-start test item sequence start end key))) + (if notp + (if from-end + (vector-count-not-p-from-end test-not item sequence start end key) + (vector-count-not-p-from-start test-not item sequence start end key)) + (if from-end + (vector-count-from-end test item sequence start end key) + (vector-count-from-start test item sequence start end key)))) + 0)) + + +;;; Count-if: + +(defun count-if (test sequence &key from-end (start 0) end key) + "Return the number of elements in SEQUENCE satisfying PRED(el)." + (count test sequence + :test #'funcall + :from-end from-end + :start start + :end end + :key key)) + +;;; Count-if-not: + +(defun count-if-not (test sequence &key from-end (start 0) end key) + "Return the number of elements in SEQUENCE not satisfying TEST(el)." + (count test sequence + :test-not #'funcall + :from-end from-end + :start start + :end end + :key key)) + + +;;; Find: + +(defun find (item sequence &key from-end test test-not (start 0) end key &aux temp) + (if sequence + (seq-dispatch + sequence + (list-position/find-1 t item sequence from-end test test-not start end key) + (if (setq temp (vector-position-1 item sequence from-end test test-not start end key)) + (aref sequence temp))))) + +(defun find-if (test sequence &key from-end (start 0) end key) + (find test sequence + :test #'funcall + :from-end from-end + :start start + :end end + :key key)) + +(defun find-if-not (test sequence &key from-end (start 0) end key) + (find test sequence + :test-not #'funcall + :from-end from-end + :start start + :end end + :key key)) + + +;;; Mismatch: + +(defun mismatch (seq1 seq2 &key (from-end nil) + (test #'eql) + (test-not nil) + (key #'identity) + (start1 0) + (start2 0) + (end1 nil) + (end2 nil) + &aux (length1 (length seq1)) + (length2 (length seq2)) + (vectorp1 (vectorp seq1)) + (vectorp2 (vectorp seq2))) + "The specified subsequences of SEQUENCE1 and SEQUENCE2 are compared + element-wise. If they are of equal length and match in every element, the + result is NIL. Otherwise, the result is a non-negative integer, the index + within SEQUENCE1 of the leftmost position at which they fail to match; or, + if one is shorter than and a matching prefix of the other, the index within + SEQUENCE1 beyond the last position tested is returned. If a non-NIL + :FROM-END argument is given, then one plus the index of the rightmost + position in which the sequences differ is returned." + ;seq type-checking is done by length + ;start/end type-cheking is done by <= (below) + ;test/key type-checking is done by funcall + ;no check for both test and test-not + (or end1 (setq end1 length1)) + (or end2 (setq end2 length2)) + (unless (and (<= start1 end1 length1) + (<= start2 end2 length2)) + (error "Sequence arg out of range")) + (unless vectorp1 + (setq seq1 (nthcdr start1 seq1)) + (if from-end + (do* ((s1 ()) + (i start1 (1+ i))) + ((= i end1) (setq seq1 s1)) + (push (pop seq1) s1)))) + (unless vectorp2 + (setq seq2 (nthcdr start2 seq2)) + (if from-end + (do* ((s2 ()) + (i start2 (1+ i))) + ((= i end2) (setq seq2 s2)) + (push (pop seq2) s2)))) + (when test-not (setq test test-not)) + (if from-end + ;from-end + (let* ((count1 end1) + (count2 end2) + (elt1) + (elt2)) + (loop + (if (or (eq count1 start1) + (eq count2 start2)) + (return-from mismatch + (if (and (eq count1 start1) + (eq count2 start2)) + nil + count1))) + + (setq count1 (%i- count1 1) + count2 (%i- count2 1)) + + (setq elt1 (funcall key (if vectorp1 + (aref seq1 count1) + (prog1 + (%car seq1) + (setq seq1 (%cdr seq1))))) + elt2 (funcall key (if vectorp2 + (aref seq2 count2) + (prog1 + (%car seq2) + (setq seq2 (%cdr seq2)))))) + + (when (if test-not + (funcall test elt1 elt2) + (not (funcall test elt1 elt2))) + (return-from mismatch (%i+ count1 1))))) + ;from-start + (let* ((count1 start1) + (count2 start2) + (elt1) + (elt2)) + (loop + (if (or (eq count1 end1) + (eq count2 end2)) + (return-from mismatch + (if (and (eq count1 end1) + (eq count2 end2)) + nil + count1))) + (setq elt1 (funcall key (if vectorp1 + (aref seq1 count1) + (prog1 + (%car seq1) + (setq seq1 (%cdr seq1))))) + elt2 (funcall key (if vectorp2 + (aref seq2 count2) + (prog1 + (%car seq2) + (setq seq2 (%cdr seq2)))))) + + (when (if test-not + (funcall test elt1 elt2) + (not (funcall test elt1 elt2))) + (return-from mismatch count1)) + (setq count1 (%i+ count1 1) + count2 (%i+ count2 1)) + + )))) + + +;;; Search comparison functions: + +(eval-when (:execute :compile-toplevel) + + ;;; Compare two elements + + (defmacro xcompare-elements (elt1 elt2) + `(if (not key) + (if test-not + (not (funcall test-not ,elt1 ,elt2)) + (funcall test ,elt1 ,elt2)) + (let* ((e1 (funcall key ,elt1)) + (e2 (funcall key ,elt2))) + (if test-not + (not (funcall test-not e1 e2)) + (funcall test e1 e2))))) + + (defmacro vector-vector-search (sub main) + `(let ((first-elt (aref ,sub start1)) + (last-one nil)) + (do* ((index2 start2 (1+ index2)) + (terminus (%i- end2 (%i- end1 start1)))) + ((> index2 terminus)) + (declare (fixnum index2 terminus)) + (if (xcompare-elements first-elt (aref ,main index2)) + (if (do* ((subi1 (1+ start1)(1+ subi1)) + (subi2 (1+ index2) (1+ subi2))) + ((eq subi1 end1) t) + (declare (fixnum subi1 subi2)) + (if (not (xcompare-elements (aref ,sub subi1) (aref ,main subi2))) + (return nil))) + (if from-end + (setq last-one index2) + (return-from search index2))))) + last-one)) + + (defmacro list-list-search (sub main) + `(let* ((sub-sub (nthcdr start1 ,sub)) + (first-elt (%car sub-sub)) + (last-one nil)) + (do* ((index2 start2 (1+ index2)) + (sub-main (nthcdr start2 ,main) (%cdr sub-main)) + (terminus (%i- end2 (%i- end1 start1)))) + ((> index2 terminus)) + (declare (fixnum index2 terminus)) + (if (xcompare-elements first-elt (car sub-main)) + (if (do* ((ss (%cdr sub-sub) (%cdr ss)) + (pos (1+ start1) (1+ pos)) + (sm (%cdr sub-main) (cdr sm))) + ((or (null ss) (= pos end1)) t) + (declare (fixnum pos)) + (if (not (xcompare-elements (%car ss) (%car sm))) + (return nil))) + (if from-end + (setq last-one index2) + (return-from search index2))))) + last-one)) + + (defmacro list-vector-search (sub main) + `(let* ((sub-sub (nthcdr start1 ,sub)) + (first-elt (%car sub-sub)) + (last-one nil)) + (do* ((index2 start2 (1+ index2)) + (terminus (%i- end2 (%i- end1 start1)))) + ((> index2 terminus)) + (declare (fixnum index2 terminus)) + (if (xcompare-elements first-elt (aref ,main index2)) + (if (do* ((ss (%cdr sub-sub) (%cdr ss)) + (pos (1+ start1) (1+ pos)) + (subi2 (1+ index2) (1+ subi2))) + ((or (null ss) (= pos end1)) t) + (declare (fixnum subi2 pos)) + (if (not (xcompare-elements (%car ss) (aref ,main subi2))) + (return nil))) + (if from-end + (setq last-one index2) + (return-from search index2))))) + last-one)) + + (defmacro vector-list-search (sub main) + `(let ((first-elt (aref ,sub start1)) + (last-one nil)) + (do* ((index2 start2 (1+ index2)) + (sub-main (nthcdr start2 ,main) (%cdr sub-main)) + (terminus (%i- end2 (%i- end1 start1)))) + ((> index2 terminus)) + (declare (fixnum index2 terminus)) + (if (xcompare-elements first-elt (car sub-main)) + (if (do* ((subi1 (1+ start1)(1+ subi1)) + (sm (%cdr sub-main) (cdr sm))) + ((eq subi1 end1) t) + (declare (fixnum subi1)) + (if (not (xcompare-elements (aref ,sub subi1) (car sm))) + (return nil))) + (if from-end + (setq last-one index2) + (return-from search index2))))) + last-one)) + + + ) + + + +(defun search (sequence1 sequence2 &key from-end (test #'eql) test-not + (start1 0) end1 (start2 0) end2 (key #'identity)) + (setq end1 (check-sequence-bounds sequence1 start1 end1)) + (setq end2 (check-sequence-bounds sequence2 start2 end2)) + (setq key (adjust-key key)) + (locally (declare (fixnum start1 end1 start2 end2)) + (if (eq 0 (%i- end1 start1))(if from-end end2 start2) + (seq-dispatch sequence1 + (seq-dispatch sequence2 + (list-list-search sequence1 sequence2) + (list-vector-search sequence1 sequence2)) + (seq-dispatch sequence2 + (vector-list-search sequence1 sequence2) + (vector-vector-search sequence1 sequence2)))))) + +(defun make-string (size &key (initial-element () initial-element-p) (element-type 'character element-type-p)) + "Given a character count and an optional fill character, makes and returns + a new string COUNT long filled with the fill character." + (declare (optimize (speed 1) (safety 1))) + (when (and initial-element-p (not (typep initial-element 'character))) + (report-bad-arg initial-element 'character)) + (when (and element-type-p + (not (or (member element-type '(character base-char standard-char)) + (subtypep element-type 'character)))) + (error ":element-type ~S is not a subtype of CHARACTER" element-type)) + (if initial-element-p + (make-string size :element-type 'base-char :initial-element initial-element) + (make-string size :element-type 'base-char))) Index: /branches/new-random/lib/setf-runtime.lisp =================================================================== --- /branches/new-random/lib/setf-runtime.lisp (revision 13309) +++ /branches/new-random/lib/setf-runtime.lisp (revision 13309) @@ -0,0 +1,134 @@ +; -*- Mode: Lisp; Package: CCL; -*- +;;; +;;; Copyright (C) 2009 Clozure Associates +;;; Copyright (C) 1994-2001 Digitool, Inc +;;; This file is part of Clozure CL. +;;; +;;; Clozure CL is licensed under the terms of the Lisp Lesser GNU Public +;;; License , known as the LLGPL and distributed with Clozure CL as the +;;; file "LICENSE". The LLGPL consists of a preamble and the LGPL, +;;; which is distributed with Clozure CL as the file "LGPL". Where these +;;; conflict, the preamble takes precedence. +;;; +;;; Clozure CL is referenced in the preamble as the "LIBRARY." +;;; +;;; The LLGPL is also available online at +;;; http://opensource.franz.com/preamble.html + +; +; setf-runtime.lisp - runtime support for setf expressions + +(in-package "CCL") + +(defun set-cadr (list new-value) + (set-car (cdr list) new-value)) + +(defun set-cdar (list new-value) + (set-cdr (car list) new-value)) + +(defun set-caar (list new-value) + (set-car (car list) new-value)) + +(defun set-cddr (list new-value) + (set-cdr (cdr list) new-value)) + +(defun %set-nthcdr (index list new-value) + "If INDEX is 0, just return NEW-VALUE." + (if (not (zerop index)) + (rplacd (nthcdr (1- index) list) + new-value)) + new-value) + +(defun set-fifth (list new-value) + (set-car (cddddr list) new-value)) + +(defun set-sixth (list new-value) + (set-car (cdr (cddddr list)) new-value)) + +(defun set-seventh (list new-value) + (set-car (cddr (cddddr list)) new-value)) + +(defun set-eighth (list new-value) + (set-car (cdddr (cddddr list)) new-value)) + +(defun set-ninth (list new-value) + (set-car (cddddr (cddddr list)) new-value)) + +(defun set-tenth (list new-value) + (set-car (cdr (cddddr (cddddr list))) new-value)) + +(defun set-caaar (list new-value) + (set-car (caar list) new-value)) + +(defun set-caadr (list new-value) + (set-car (cadr list) new-value)) + +(defun set-cadar (list new-value) + (set-car (cdar list) new-value)) + +(defun set-caddr (list new-value) + (set-car (cddr list) new-value)) + +(defun set-cdaar (list new-value) + (set-cdr (caar list) new-value)) + +(defun set-cdadr (list new-value) + (set-cdr (cadr list) new-value)) + +(defun set-cddar (list new-value) + (set-cdr (cdar list) new-value)) + +(defun set-cdddr (list new-value) + (set-cdr (cddr list) new-value)) + +(defun set-caaaar (list new-value) + (set-car (caaar list) new-value)) + +(defun set-caaadr (list new-value) + (set-car (caadr list) new-value)) + +(defun set-caadar (list new-value) + (set-car (cadar list) new-value)) + +(defun set-caaddr (list new-value) + (set-car (caddr list) new-value)) + +(defun set-cadaar (list new-value) + (set-car (cdaar list) new-value)) + +(defun set-cadadr (list new-value) + (set-car (cdadr list) new-value)) + +(defun set-caddar (list new-value) + (set-car (cddar list) new-value)) + +(defun set-cadddr (list new-value) + (set-car (cdddr list) new-value)) + +(defun set-cdaaar (list new-value) + (set-cdr (caaar list) new-value)) + +(defun set-cdaadr (list new-value) + (set-cdr (caadr list) new-value)) + +(defun set-cdadar (list new-value) + (set-cdr (cadar list) new-value)) + +(defun set-cdaddr (list new-value) + (set-cdr (caddr list) new-value)) + +(defun set-cddaar (list new-value) + (set-cdr (cdaar list) new-value)) + +(defun set-cddadr (list new-value) + (set-cdr (cdadr list) new-value)) + +(defun set-cdddar (list new-value) + (set-cdr (cddar list) new-value)) + +(defun set-cddddr (list new-value) + (set-cdr (cdddr list) new-value)) + + + +; End of setf-runtime.lisp Index: /branches/new-random/lib/setf.lisp =================================================================== --- /branches/new-random/lib/setf.lisp (revision 13309) +++ /branches/new-random/lib/setf.lisp (revision 13309) @@ -0,0 +1,908 @@ +;;;-*-Mode: LISP; Package: CCL -*- +;;; +;;; Copyright (C) 2009 Clozure Associates +;;; Copyright (C) 1994-2001 Digitool, Inc +;;; This file is part of Clozure CL. +;;; +;;; Clozure CL is licensed under the terms of the Lisp Lesser GNU Public +;;; License , known as the LLGPL and distributed with Clozure CL as the +;;; file "LICENSE". The LLGPL consists of a preamble and the LGPL, +;;; which is distributed with Clozure CL as the file "LGPL". Where these +;;; conflict, the preamble takes precedence. +;;; +;;; Clozure CL is referenced in the preamble as the "LIBRARY." +;;; +;;; The LLGPL is also available online at +;;; http://opensource.franz.com/preamble.html + +(in-package "CCL") + +;;Bootstrapping. +(defvar %setf-methods% (let ((a (make-hash-table :test #'eq))) + (do-all-symbols (s) + (let ((f (get s 'bootstrapping-setf-method))) + (when f + (setf (gethash s a) f) + (remprop s 'bootstrapping-setf-method)))) + a)) +(defun %setf-method (name) + (gethash name %setf-methods%)) + +(defun store-setf-method (name fn &optional doc) + (puthash name %setf-methods% fn) + (let ((type-and-refinfo (and #-bccl (boundp '%structure-refs%) + (gethash name %structure-refs%)))) + (typecase type-and-refinfo + (fixnum + (puthash name %structure-refs% (%ilogior2 (%ilsl $struct-r/o 1) + type-and-refinfo))) + (cons + (setf (%cdr type-and-refinfo) (%ilogior2 (%ilsl $struct-r/o 1) + (%cdr type-and-refinfo)))) + (otherwise nil))) + (set-documentation name 'setf doc) ;clears it if doc = nil. + name) + + +;;; Note: The expansions for SETF and friends create needless LET-bindings of +;;; argument values when using get-setf-method. +;;; That's why SETF no longer uses get-setf-method. If you change anything +;;; here, be sure to make the corresponding change in SETF. + +(defun get-setf-expansion (form &optional env) + "Return five values needed by the SETF machinery: a list of temporary + variables, a list of values with which to fill them, a list of temporaries + for the new values, the setting function, and the accessing function." + ;This isn't actually used by setf, but it has to be compatible. + (get-setf-expansion-aux form env t)) + +(defun get-setf-expansion-aux (form environment multiple-store-vars-p) + (let* ((temp nil) + (accessor nil)) + (if (atom form) + (progn + (unless (symbolp form) (signal-program-error $XNotSym form)) + (multiple-value-bind (symbol-macro-expansion expanded) + (macroexpand-1 form environment) + (if expanded + (get-setf-expansion-aux symbol-macro-expansion environment + multiple-store-vars-p) + (let ((new-var (gensym))) + (values nil nil (list new-var) `(setq ,form ,new-var) form))))) + (multiple-value-bind (ftype local-p) + (function-information (setq accessor (car form)) environment) + (if local-p + (if (eq ftype :function) + ;Local function or macro, so don't use global setf definitions. + (default-setf-method form) + (get-setf-expansion-aux (macroexpand-1 form environment) environment multiple-store-vars-p)) + (cond + ((setq temp (gethash accessor %setf-methods%)) + (if (symbolp temp) + (let ((new-var (gensym)) + (args nil) + (vars nil) + (vals nil)) + (dolist (x (cdr form)) + ;; Rebinding defeats optimizations, so avoid it if can. + (if (constantp x environment) + (push x args) + (let ((var (gensym))) + (push var vars) + (push var args) + (push x vals)))) + (setq args (nreverse args)) + (values (nreverse vars) + (nreverse vals) + (list new-var) + `(,temp ,@args ,new-var) + `(,accessor ,@args))) + (multiple-value-bind (temps values storevars storeform accessform) + (funcall temp form environment) + (when (and (not multiple-store-vars-p) (not (= (length storevars) 1))) + (signal-program-error "Multiple store variables not expected in setf expansion of ~S" form)) + (values temps values storevars storeform accessform)))) + ((and (type-and-refinfo-p (setq temp (or (environment-structref-info accessor environment) + (and #-bccl (boundp '%structure-refs%) + (gethash accessor %structure-refs%))))) + (not (refinfo-r/o (if (consp temp) (%cdr temp) temp)))) + (if (consp temp) + (let ((type (%car temp))) + (multiple-value-bind + (temps values storevars storeform accessform) + (get-setf-method (defstruct-ref-transform (%cdr temp) (%cdr form) environment) environment) + (values temps values storevars + (let ((storevar (first storevars))) + `(the ,type + (let ((,storevar (require-type ,storevar ',type))) + ,storeform))) + `(the ,type ,accessform)))) + (get-setf-method (defstruct-ref-transform temp (%cdr form) environment) environment))) + (t + (multiple-value-bind (res win) + (macroexpand-1 form environment) + (if win + (get-setf-expansion-aux res environment multiple-store-vars-p) + (default-setf-method form)))))))))) + +(defun default-setf-method (form) + (let ((new-value (gensym)) + (temp-vars ()) + (temp-args ()) + (temp-vals ())) + (dolist (val (cdr form)) + (if (fixnump val) + (push val temp-args) + (let ((var (gensym))) + (push var temp-vars) + (push val temp-vals) + (push var temp-args)))) + (setq temp-vars (nreverse temp-vars) + temp-args (nreverse temp-args) + temp-vals (nreverse temp-vals)) + (values temp-vars + temp-vals + (list new-value) + `(funcall #'(setf ,(car form)) ,new-value ,@temp-args) + `(,(car form) ,@temp-args)))) + +;;; The inverse for a generalized-variable reference function is stored in +;;; one of two ways: +;;; +;;; A SETF-INVERSE property corresponds to the short form of DEFSETF. It is +;;; the name of a function takes the same args as the reference form, plus a +;;; new-value arg at the end. +;;; +;;; A SETF-METHOD-EXPANDER property is created by the long form of DEFSETF or +;;; by DEFINE-SETF-METHOD. It is a function that is called on the reference +;;; form and that produces five values: a list of temporary variables, a list +;;; of value forms, a list of the single store-value form, a storing function, +;;; and an accessing function. + +(eval-when (eval compile) + (require 'defstruct-macros)) + +(defmacro set-get (symbol indicator value &optional (value1 () default-p)) + (if default-p + `(put ,symbol ,indicator (progn ,value ,value1)) + `(put ,symbol ,indicator ,value))) + +; (defsetf get set-get) +(store-setf-method 'get 'SET-GET) + +; does this wrap a named block around the body yet ? +(defmacro define-setf-expander (access-fn lambda-list &body body) + "Syntax like DEFMACRO, but creates a setf expander function. The body + of the definition must be a form that returns five appropriate values." + (unless (symbolp access-fn) + (signal-program-error $xnotsym access-fn)) + (multiple-value-bind (lambda-form doc) + (parse-macro-1 access-fn lambda-list body) + `(eval-when (load compile eval) + (record-source-file ',access-fn 'setf-expander) + (store-setf-method ',access-fn + (nfunction ,access-fn ,lambda-form) + ,@(when doc (list doc)))))) + +(defun rename-lambda-vars (lambda-list) + (let* ((vars nil) + (temps nil) + (new-lambda nil) + (state nil)) + (flet ((temp-symbol (s) (make-symbol (symbol-name s)))) + (declare (inline temp-symbol)) + (dolist (item lambda-list) + (if (memq item lambda-list-keywords) + (setq state item item (list 'quote item)) + (if (atom item) + (progn + (push item vars)) + (locally (declare (type cons item)) + (when (consp (cddr item)) + (push (caddr item) vars)) + (if (and (eq state '&key) (consp (car item))) + (progn + (push (cadar item) vars) + (setq item `(list (list ,(list 'quote (caar item)) ,(cadar item)) ,@(cdr item)))) + (progn + (push (car item) vars) + (setq item `(list ,(car item) ,@(cdr item)))))))) + (push item new-lambda)) + (setq temps (mapcar #'temp-symbol vars)) + (values `(list ,@(nreverse new-lambda)) (nreverse temps) (nreverse vars))))) + +(defmacro defsetf (access-fn &rest rest &environment env) + "Associates a SETF update function or macro with the specified access + function or macro. The format is complex. See the manual for details." + (unless (symbolp access-fn) (signal-program-error $xnotsym access-fn)) + (if (non-nil-symbol-p (%car rest)) + `(eval-when (:compile-toplevel :load-toplevel :execute) + (store-setf-method + ',access-fn + ',(%car rest) + ,@(%cdr rest))) + (destructuring-bind (lambda-list (store-var &rest mv-store-vars) &body body) + rest + (unless (verify-lambda-list lambda-list) + (signal-program-error $XBadLambdaList lambda-list)) + (let* ((store-vars (cons store-var mv-store-vars))) + (multiple-value-bind (lambda-list lambda-temps lambda-vars) + (rename-lambda-vars lambda-list) + (multiple-value-bind (body decls doc) + (parse-body body env t) + (setq body `((block ,access-fn ,@body))) + (let* ((args (gensym)) + (dummies (gensym)) + (newval-vars (gensym)) + (new-access-form (gensym)) + (access-form (gensym)) + (environment (gensym))) + `(eval-when (:compile-toplevel :load-toplevel :execute) + (record-source-file ',access-fn 'setf-expander) + (store-setf-method + ',access-fn + #'(lambda (,access-form ,environment) + (declare (ignore ,environment)) + (do* ((,args (cdr ,access-form) (cdr ,args)) + (,dummies nil (cons (gensym) ,dummies)) + (,newval-vars (mapcar #'(lambda (v) (declare (ignore v)) (gensym)) ',store-vars)) + (,new-access-form nil)) + ((atom ,args) + (setq ,new-access-form + (cons (car ,access-form) ,dummies)) + (destructuring-bind ,(append lambda-vars store-vars ) + `,(append ',lambda-temps ,newval-vars) + ,@decls + (values + ,dummies + (cdr ,access-form) + ,newval-vars + `((lambda ,,lambda-list ,,@body) + ,@,dummies) + ,new-access-form)))))) + ,@(if doc (list doc)) + ',access-fn)))))))) + +(defmacro define-modify-macro (name lambda-list function &optional doc-string) + "Creates a new read-modify-write macro like PUSH or INCF." + (let ((other-args nil) + (rest-arg nil) + (env (gensym)) + (reference (gensym))) + + ;; Parse out the variable names and rest arg from the lambda list. + (do ((ll lambda-list (cdr ll)) + (arg nil)) + ((null ll)) + (setq arg (car ll)) + (cond ((eq arg '&optional)) + ((eq arg '&rest) + (if (symbolp (cadr ll)) + (setq rest-arg (cadr ll)) + (error "Non-symbol &rest arg in definition of ~S." name)) + (if (null (cddr ll)) + (return nil) + (error "Illegal stuff after &rest arg in Define-Modify-Macro."))) + ((memq arg '(&key &allow-other-keys &aux)) + (error "~S not allowed in Define-Modify-Macro lambda list." arg)) + ((symbolp arg) + (push arg other-args)) + ((and (listp arg) (symbolp (car arg))) + (push (car arg) other-args)) + (t (error "Illegal stuff in lambda list of Define-Modify-Macro.")))) + (setq other-args (nreverse other-args)) + `(defmacro ,name (,reference ,@lambda-list &environment ,env) + ,doc-string + (multiple-value-bind (dummies vals newval setter getter) + (get-setf-method ,reference ,env) + (do ((d dummies (cdr d)) + (v vals (cdr v)) + (let-list nil (cons (list (car d) (car v)) let-list))) + ((null d) + (push + (list (car newval) + ,(if rest-arg + `(list* ',function getter ,@other-args ,rest-arg) + `(list ',function getter ,@other-args))) + let-list) + `(let* ,(nreverse let-list) + ,setter))))))) + +(defmacro incf (place &optional (delta 1) &environment env) + "The first argument is some location holding a number. This number is +incremented by the second argument, DELTA, which defaults to 1." + (if (and (symbolp (setq place (%symbol-macroexpand place env))) + (or (constantp delta) + (and (symbolp delta) + (not (nth-value 1 (%symbol-macroexpand delta env)))))) + `(setq ,place (+ ,place ,delta)) + (multiple-value-bind (dummies vals newval setter getter) + (get-setf-method place env) + (let ((d (gensym)) + ;; Doesn't propagate inferred types, but better than nothing. + (d-type (cond ((constantp delta) (type-of delta)) + ((and (consp delta) (eq (car delta) 'the)) (cadr delta)) + (t t))) + (v-type (if (and (consp place) (eq (car place) 'the)) (cadr place) t))) + `(let* (,@(mapcar #'list dummies vals) + (,d ,delta) + (,(car newval) (+ ,getter ,d))) + (declare (type ,d-type ,d) (type ,v-type ,(car newval))) + ,setter))))) + +(defmacro decf (place &optional (delta 1) &environment env) + "The first argument is some location holding a number. This number is +decremented by the second argument, DELTA, which defaults to 1." + (if (and (symbolp (setq place (%symbol-macroexpand place env))) + (or (constantp delta) + (and (symbolp delta) + (not (nth-value 1 (%symbol-macroexpand delta env)))))) + `(setq ,place (- ,place ,delta)) + (multiple-value-bind (dummies vals newval setter getter) + (get-setf-method place env) + (let* ((d (gensym)) + ;; Doesn't propagate inferred types, but better than nothing. + (d-type (cond ((constantp delta) (type-of delta)) + ((and (consp delta) (eq (car delta) 'the)) (cadr delta)) + (t t))) + (v-type (if (and (consp place) (eq (car place) 'the)) (cadr place) t))) + `(let* (,@(mapcar #'list dummies vals) + (,d ,delta) + (,(car newval) (- ,getter ,d))) + (declare (type ,d-type ,d) (type ,v-type ,(car newval))) + ,setter))))) + +(defmacro psetf (&whole call &rest pairs &environment env) ;same structure as psetq + "This is to SETF as PSETQ is to SETQ. Args are alternating place + expressions and values to go into those places. All of the subforms and + values are determined, left to right, and only then are the locations + updated. Returns NIL." + (when pairs + (if (evenp (length pairs)) + (let* ((places nil) + (values nil) + (tempsets nil) + (the-progn (list 'progn)) + (place nil) + (body the-progn) + (valform nil)) + (loop + (setq place (pop pairs) valform (pop pairs)) + (if (null pairs) (return)) + (push place places) + (push valform values) + (multiple-value-bind (temps vals newvals setter getter) + (get-setf-method-multiple-value place env) + (push (list temps vals newvals setter getter) tempsets))) + (dolist (temp tempsets) + (destructuring-bind (temps vals newvals setter getter) temp + (declare (ignore getter)) + (setq body + `(let + ,(let* ((let-list nil)) + (dolist (x temps (nreverse let-list)) + (push (list x (pop vals)) let-list))) + (multiple-value-bind ,newvals ,(pop values) + ,body))) + (push setter (cdr the-progn)))) + (push `(setf ,place ,valform) (cdr the-progn)) + `(progn ,body nil)) + (error "Odd number of args in the call ~S" call)))) + +;;Simple Setf specializations + + + +(defsetf cadr set-cadr) +(defsetf second set-cadr) + + +(defsetf cdar set-cdar) + +(defsetf caar set-caar) + +(defsetf cddr set-cddr) + +(defsetf elt set-elt) +(defsetf aref aset) +(defsetf svref svset) +(defsetf char set-char) +(defsetf bit %bitset) + +(defsetf schar set-schar) +(defsetf sbit %sbitset) +(defsetf symbol-value set) +(defsetf %schar %set-schar) + + +(defsetf symbol-plist set-symbol-plist) +(defsetf nth %setnth) + +(defsetf nthcdr %set-nthcdr) + +(defsetf fill-pointer set-fill-pointer) + + +(defsetf subseq (sequence start &optional (end nil)) (new-seq) + `(progn (replace ,sequence ,new-seq :start1 ,start :end1 ,end) + ,new-seq)) + + + +(defsetf third set-caddr) +(defsetf fourth set-cadddr) +(defsetf fifth set-fifth) +(defsetf sixth set-sixth) +(defsetf seventh set-seventh) +(defsetf eighth set-eighth) +(defsetf ninth set-ninth) +(defsetf tenth set-tenth) + + +(defsetf caaar set-caaar) +(defsetf caadr set-caadr) +(defsetf cadar set-cadar) +(defsetf caddr set-caddr) +(defsetf cdaar set-cdaar) +(defsetf cdadr set-cdadr) +(defsetf cddar set-cddar) +(defsetf cdddr set-cdddr) + + + + +(defsetf caaaar set-caaaar) +(defsetf caaadr set-caaadr) +(defsetf caadar set-caadar) +(defsetf caaddr set-caaddr) +(defsetf cadaar set-cadaar) +(defsetf cadadr set-cadadr) +(defsetf caddar set-caddar) +(defsetf cadddr set-cadddr) + + +(defsetf cdaaar set-cdaaar) +(defsetf cdaadr set-cdaadr) +(defsetf cdadar set-cdadar) +(defsetf cdaddr set-cdaddr) +(defsetf cddaar set-cddaar) +(defsetf cddadr set-cddadr) +(defsetf cdddar set-cdddar) +(defsetf cddddr set-cddddr) + +(defsetf %fixnum-ref %fixnum-set) + +(define-setf-method the (typespec expr &environment env) + (multiple-value-bind (dummies vals newval setter getter) + (get-setf-method expr env) + (let ((store-var (gensym))) + (values + dummies + vals + (list store-var) + `(let ((,(car newval) ,store-var)) + ,setter) + `(the ,typespec ,getter))))) + + +(define-setf-method apply (function &rest args &environment env) + (if (and (listp function) + (= (list-length function) 2) + (eq (first function) 'function) + (symbolp (second function))) + (setq function (second function)) + (error + "Setf of Apply is only defined for function args of form #'symbol.")) + (multiple-value-bind (dummies vals newval setter getter) + (get-setf-expansion (cons function args) env) + ;; Make sure the place is one that we can handle. + ;;Mainly to insure against cases of ldb and mask-field and such creeping in. + (let* ((last-arg (car (last args))) + (last-val (car (last vals))) + (last-dummy (car (last dummies))) + (last-getter (car (last getter))) + (last2-setter (car (last setter 2))) + (last-setter (car (last setter)))) + (cond ((and (or (and (eq last-arg last-val) + (eq last-getter last-dummy)) + (eq last-arg last-getter)) + newval + (null (cdr newval)) + (eq last-setter (car newval)) + (or (and (eq last-arg last-val) + (eq last2-setter last-dummy)) + (eq last-arg last2-setter))) + ;; (setf (foo ... argn) bar) -> (set-foo ... argn bar) + (values dummies vals newval + `(apply+ (function ,(car setter)) ,@(cdr setter)) + `(apply (function ,(car getter)) ,@(cdr getter)))) + ((and (or (and (eq last-arg last-val) + (eq last-getter last-dummy)) + (eq last-arg last-getter)) + newval + (null (cdr newval)) + (eq (car setter) 'funcall) + (eq (third setter) (car newval)) + (or (and (eq last-arg last-val) + (eq last-setter last-dummy)) + (eq last-arg last-setter))) + ;; (setf (foo ... argn) bar) -> (funcall #'(setf foo) bar ... argn) [with bindings for evaluation order] + (values dummies vals newval + `(apply ,@(cdr setter)) + `(apply (function ,(car getter)) ,@(cdr getter)))) + (t (error "Apply of ~S is not understood as a location for Setf." + function)))))) + +;;These are the supporting functions for the am-style hard-cases of setf. +(defun assoc-2-lists (list1 list2) + "Not CL. Returns an assoc-like list with members taken by associating corresponding + elements of each list. uses list instead of cons. + Will stop when first list runs out." + (do* ((lst1 list1 (cdr lst1)) + (lst2 list2 (cdr lst2)) + (result nil)) + ((null lst1) result) + (setq result (cons (list (car lst1) + (car lst2)) + result)))) + +(defun make-gsym-list (size) + "Not CL. Returns a list with size members, each being a different gensym" + (let ((temp nil)) + (dotimes (arg size temp) + (declare (fixnum arg)) + (setq temp (cons (gensym) temp))))) +;;;;;;; + +(define-setf-method getf (plist prop &optional (default () default-p) + &aux (prop-p (not (quoted-form-p prop))) + &environment env) + (multiple-value-bind (vars vals stores store-form access-form) + (get-setf-method plist env) + (when default-p (setq default (list default))) + (let ((prop-var (if prop-p (gensym) prop)) + (store-var (gensym)) + (default-var (if default-p (list (gensym))))) + (values + `(,@vars ,.(if prop-p (list prop-var)) ,@default-var) + `(,@vals ,.(if prop-p (list prop)) ,@default) + (list store-var) + `(let* ((,(car stores) (setprop ,access-form ,prop-var ,store-var))) + ,store-form + ,store-var) + `(getf ,access-form ,prop-var ,@default-var))))) + +(define-setf-method getf-test (plist prop test &optional (default () default-p) + &aux (prop-p (not (quoted-form-p prop))) + &environment env) + (multiple-value-bind (vars vals stores store-form access-form) + (get-setf-method plist env) + (when default-p (setq default (list default))) + (let ((prop-var (if prop-p (gensym) prop)) + (test-var (gensym)) + (store-var (gensym)) + (default-var (if default-p (list (gensym))))) + (values + `(,@vars ,.(if prop-p (list prop-var)) ,test-var ,@default-var) + `(,@vals ,.(if prop-p (list prop)) ,test ,@default) + (list store-var) + `(let* ((,(car stores) (setprop-test ,access-form ,prop-var ,test-var ,store-var))) + ,store-form + ,store-var) + `(getf-test ,access-form ,prop-var ,test-var ,@default-var))))) + +(define-setf-method ldb (bytespec place &environment env) + "The first argument is a byte specifier. The second is any place form + acceptable to SETF. Replace the specified byte of the number in this + place with bits from the low-order end of the new value." + (multiple-value-bind (dummies vals newval setter getter) + (get-setf-method place env) + (let ((btemp (gensym)) + (gnuval (gensym))) + (values (cons btemp dummies) + (cons bytespec vals) + (list gnuval) + `(let ((,(car newval) (dpb ,gnuval ,btemp ,getter))) + ,setter + ,gnuval) + `(ldb ,btemp ,getter))))) + + +(define-setf-method mask-field (bytespec place &environment env) + "The first argument is a byte specifier. The second is any place form + acceptable to SETF. Replaces the specified byte of the number in this place + with bits from the corresponding position in the new value." + (multiple-value-bind (dummies vals newval setter getter) + (get-setf-method place env) + (let ((btemp (gensym)) + (gnuval (gensym))) + (values (cons btemp dummies) + (cons bytespec vals) + (list gnuval) + `(let ((,(car newval) (deposit-field ,gnuval ,btemp ,getter))) + ,setter + ,gnuval) + `(mask-field ,btemp ,getter))))) + +(defmacro shiftf (arg1 arg2 &rest places-&-nuval &environment env) + "One or more SETF-style place expressions, followed by a single + value expression. Evaluates all of the expressions in turn, then + assigns the value of each expression to the place on its left, + returning the value of the leftmost." + (setq places-&-nuval (list* arg1 arg2 places-&-nuval)) + (let* ((nuval (car (last places-&-nuval))) + (places (cdr (reverse places-&-nuval))) ; not nreverse, since &rest arg shares structure with &whole. + (setters (list 'progn)) + (last-getter nuval) + last-let-list + let-list + (body setters)) + (dolist (place places) + (multiple-value-bind (vars values storevars setter getter) + (get-setf-method-multiple-value place env) + (dolist (v vars) + (push (list v (pop values)) let-list)) + (push setter (cdr setters)) + (setq body + (if last-let-list + `(let* ,(nreverse last-let-list) + (multiple-value-bind ,storevars ,last-getter + ,body)) + `(multiple-value-bind ,storevars ,last-getter + ,body)) + last-let-list let-list + let-list nil + last-getter getter))) + (if last-let-list + `(let* ,(nreverse last-let-list) + (multiple-value-prog1 ,last-getter + ,body)) + `(multiple-value-prog1 ,last-getter + ,body)))) + +;(shiftf (car x)(cadr x) 3) + +#| +(defmacro rotatef (&rest args &environment env) + (let* ((setf-result nil) + (let-result nil) + (last-store nil) + (fixpair nil)) + (dolist (arg args) + (multiple-value-bind (vars vals storevars setter getter) + (get-setf-method arg env) + (dolist (var vars) + (push (list var (pop vals)) let-result)) + (push (list last-store getter) let-result) + (unless fixpair (setq fixpair (car let-result))) + (push setter setf-result) + (setq last-store (car storevars)))) + (rplaca fixpair last-store) + `(let* ,(nreverse let-result) ,@(nreverse setf-result) nil))) + + +;(rotatef (blob x)(blob y)) +(defun blob (x) (values (car x)(cadr x))) +(define-setf-method blob (x) + (let ((v1 (gensym))(v2 (gensym))(v3 (gensym))) + (values + (list v1) + (list x) + (list v2 v3) + `(progn (setf (car ,v1) ,v2) + (setf (cadr ,v1) ,v3)) + `(values (car ,v1)(cadr ,v1))))) +|# + +(defmacro rotatef (&rest args &environment env) + "Takes any number of SETF-style place expressions. Evaluates all of the + expressions in turn, then assigns to each place the value of the form to + its right. The rightmost form gets the value of the leftmost. + Returns NIL." + (when args + (let* ((places (reverse args)) ; not nreverse, since &rest arg shares structure with &whole. + (final-place (pop places)) + (setters (list 'progn nil)) + last-let-list + let-list + (body setters)) + (multiple-value-bind (final-vars final-values final-storevars + final-setter last-getter) + (get-setf-method-multiple-value final-place env) + (dolist (v final-vars) + (push (list v (pop final-values)) last-let-list)) + (push final-setter (cdr setters)) + (dolist (place places) + (multiple-value-bind (vars values storevars setter getter) + (get-setf-method-multiple-value place env) + (dolist (v vars) + (push (list v (pop values)) let-list)) + (push setter (cdr setters)) + (setq body + (if last-let-list + `(let* ,(nreverse last-let-list) + (multiple-value-bind ,storevars ,last-getter + ,body)) + `(multiple-value-bind ,storevars ,last-getter + ,body)) + last-let-list let-list + let-list nil + last-getter getter))) + (if last-let-list + `(let* ,(nreverse last-let-list) + (multiple-value-bind ,final-storevars ,last-getter + ,body)) + `(multiple-value-bind ,final-storevars ,last-getter + ,body)))))) + + + +(defmacro push (value place &environment env) + "Takes an object and a location holding a list. Conses the object onto + the list, returning the modified list. OBJ is evaluated before PLACE." + (if (not (consp place)) + `(setq ,place (cons ,value ,place)) + (multiple-value-bind (dummies vals store-var setter getter) + (get-setf-method place env) + (let ((valvar (gensym))) + `(let* ((,valvar ,value) + ,@(mapcar #'list dummies vals) + (,(car store-var) (cons ,valvar ,getter))) + ,@dummies + ,(car store-var) + ,setter))))) + +(defmacro pushnew (value place &rest keys &environment env) + "Takes an object and a location holding a list. If the object is + already in the list, does nothing; otherwise, conses the object onto + the list. Returns the modified list. If there is a :TEST keyword, this + is used for the comparison." + (if (not (consp place)) + `(setq ,place (adjoin ,value ,place ,@keys)) + (let ((valvar (gensym))) + (multiple-value-bind (dummies vals store-var setter getter) + (get-setf-method place env) + `(let* ((,valvar ,value) + ,@(mapcar #'list dummies vals) + (,(car store-var) (adjoin ,valvar ,getter ,@keys))) + ,@dummies + ,(car store-var) + ,setter))))) + +(defmacro pop (place &environment env &aux win) + "The argument is a location holding a list. Pops one item off the front + of the list and returns it." + (while (atom place) + (multiple-value-setq (place win) (macroexpand-1 place env)) + (unless win + (return-from pop + `(prog1 (car ,place) (setq ,place (cdr (the list ,place))))))) + (let ((value (gensym))) + (multiple-value-bind (dummies vals store-var setter getter) + (get-setf-method place env) + `(let* (,@(mapcar #'list dummies vals) + (,value ,getter) + (,(car store-var) (cdr ,value))) + ,@dummies + ,(car store-var) + (prog1 + (%car ,value) + ,setter))))) + +(defmacro %pop (symbol) + `(prog1 (%car ,symbol) (setq ,symbol (%cdr ,symbol)))) + +#| +(defmacro push (item place) + (if (not (consp place)) + `(setq ,place (cons ,item ,place)) + (let* ((arg-num (1- (length place))) + (place-args (make-gsym-list arg-num))) + `(let ,(cons (list 'nu-item item) + (reverse (assoc-2-lists place-args (cdr place)))) + (setf (,(car place) ,@place-args) + (cons nu-item (,(car place) ,@place-args))))))) + +(defmacro pushnew (item place &rest key-args) + (let ((item-gsym (gensym))) + (if (not (consp place)) + `(let ((,item-gsym ,item)) + (setq ,place (adjoin ,item-gsym ,place ,@key-args))) + (let* ((arg-num (1- (length place))) + (place-args (make-gsym-list arg-num))) + `(let ,(cons (list item-gsym item) + (reverse (assoc-2-lists place-args (cdr place)))) + (setf (,(car place) ,@place-args) + (adjoin ,item-gsym (,(car place) ,@place-args) + ,@key-args))))))) +(defmacro pop (place) + (if (not (consp place)) ; screw: symbol macros. + `(prog1 (car ,place) (setq ,place (%cdr ,place))) + (let* ((arg-num (1- (length place))) + (place-args (make-gsym-list arg-num))) + `(let ,(reverse (assoc-2-lists place-args (cdr place))) + (prog1 (car (,(car place) ,@place-args)) + (setf (,(car place) ,@place-args) + (cdr (,(car place) ,@place-args)))))))) +|# + +(defmacro remf (place indicator &environment env) + "Place may be any place expression acceptable to SETF, and is expected + to hold a property list or (). This list is destructively altered to + remove the property specified by the indicator. Returns T if such a + property was present, NIL if not." + (multiple-value-bind (dummies vals newval setter getter) + (get-setf-method place env) + (do* ((d dummies (cdr d)) + (v vals (cdr v)) + (let-list nil) + (ind-temp (gensym)) + (local1 (gensym)) + (local2 (gensym))) + ((null d) + (push (list ind-temp indicator) let-list) + (push (list (car newval) getter) let-list) + `(let* ,(nreverse let-list) + (do ((,local1 ,(car newval) (cddr ,local1)) + (,local2 nil ,local1)) + ((atom ,local1) nil) + (cond ((atom (cdr ,local1)) + (error "Odd-length property list in REMF.")) + ((eq (car ,local1) ,ind-temp) + (cond (,local2 + (rplacd (cdr ,local2) (cddr ,local1)) + (return t)) + (t (setq ,(car newval) (cddr ,(car newval))) + ,setter + (return t)))))))) + (push (list (car d) (car v)) let-list)))) + +(defmacro remf-test (place indicator test &environment env) + "Place may be any place expression acceptable to SETF, and is expected + to hold a property list or (). This list is destructively altered to + remove the property specified by the indicator. Returns T if such a + property was present, NIL if not." + (multiple-value-bind (dummies vals newval setter getter) + (get-setf-method place env) + (do* ((d dummies (cdr d)) + (v vals (cdr v)) + (let-list nil) + (ind-temp (gensym)) + (test-temp (gensym)) + (local1 (gensym)) + (local2 (gensym))) + ((null d) + (push (list (car newval) getter) let-list) + (push (list ind-temp indicator) let-list) + (push (list test-temp test) let-list) + `(let* ,(nreverse let-list) + (do ((,local1 ,(car newval) (cddr ,local1)) + (,local2 nil ,local1)) + ((atom ,local1) nil) + (cond ((atom (cdr ,local1)) + (error "Odd-length property list in REMF.")) + ((funcall ,test-temp (car ,local1) ,ind-temp) + (cond (,local2 + (rplacd (cdr ,local2) (cddr ,local1)) + (return t)) + (t (setq ,(car newval) (cddr ,(car newval))) + ,setter + (return t)))))))) + (push (list (car d) (car v)) let-list)))) + +(define-setf-expander values (&rest places &environment env) + (let* ((setters ()) + (getters ()) + (all-dummies ()) + (all-vals ()) + (newvals ())) + (dolist (place places) + (multiple-value-bind (dummies vals newval setter getter) + (get-setf-expansion place env) + (setf all-dummies (append all-dummies dummies (cdr newval))) + (setf all-vals (append all-vals vals (mapcar (constantly nil) (cdr newval)))) + (setf newvals (append newvals (list (car newval)))) + (push setter setters) + (push getter getters))) + (values all-dummies all-vals newvals + `(values ,@(nreverse setters)) `(values ,@(nreverse getters))))) Index: /branches/new-random/lib/sort.lisp =================================================================== --- /branches/new-random/lib/sort.lisp (revision 13309) +++ /branches/new-random/lib/sort.lisp (revision 13309) @@ -0,0 +1,505 @@ +;;;-*-Mode: LISP; Package: CCL -*- +;;; +;;; Copyright (C) 2009 Clozure Associates +;;; Copyright (C) 1994-2001 Digitool, Inc +;;; This file is part of Clozure CL. +;;; +;;; Clozure CL is licensed under the terms of the Lisp Lesser GNU Public +;;; License , known as the LLGPL and distributed with Clozure CL as the +;;; file "LICENSE". The LLGPL consists of a preamble and the LGPL, +;;; which is distributed with Clozure CL as the file "LGPL". Where these +;;; conflict, the preamble takes precedence. +;;; +;;; Clozure CL is referenced in the preamble as the "LIBRARY." +;;; +;;; The LLGPL is also available online at +;;; http://opensource.franz.com/preamble.html + +;;; Sort + +;;; sorts a sequence destructively using a predicate which must be a +;;; of two arguments which returns non-() only if the first argument is +;;; strictly less than the second. The keyfun (if present) must be a +;;; function of one argument. The predicate is applied to keyfun of the +;;; sequence elements, or directly to the elements if the keyfun is not +;;; given. + +;;; Sort dispatches to type specific sorting routines. + +(in-package "CCL") + +(defun sort (sequence predicate &key key) + "Returns SEQUENCE, which has been modified to be in order. + If sequence is a displaced array, sorts just that portion of the + data-array which is part of SEQUENCE." + (if (< (length sequence) 2) + sequence + (if (listp sequence) + (sort-list sequence predicate key) + (quick-sort-vector sequence predicate key)))) + +(defun stable-sort (sequence predicate &key key) + "Returns SEQUENCE, which has been modified to be in order. + If sequence is a displaced array, sorts just that portion of the + data-array which is part of SEQUENCE." + (if (< (length sequence) 2) + sequence + (if (listp sequence) + (sort-list sequence predicate key) + (merge-sort-vector sequence predicate key)))) + + +;;; Vector sorting. +;;; The quick-sort is a little slower than the merge-sort, but it doesn't cons. +;;; The merge-sort is stable. +;;; Note that there are three version of each: +;;; AREF for non-simple (eventually) vectors. +;;; %SVREF with a key. +;;; %SVREF without a key. +;;; Other than that, the three versions are duplicates. +(defun merge-sort-vector (vector pred key) + (canonicalize-pred-and-key) + (let* ((end (length vector))) + (when (> end 1) + (multiple-value-bind (real-vector start) + (array-data-and-offset vector) + (incf end start) + (unless (fixnump end) + (error "Sorry, can't sort vectors larger than ~d." most-positive-fixnum)) + (let* ((temp-array (make-array (the fixnum end)))) + (declare (dynamic-extent temp-array)) + (if (simple-vector-p real-vector) + (if key + (%merge-sort-simple-vector + real-vector start end pred key temp-array nil) + (%merge-sort-simple-vector-no-key + real-vector start end pred temp-array nil)) + (%merge-sort-vector real-vector start end pred key temp-array nil)))))) + vector) + +(defun quick-sort-vector (vector pred key) + (canonicalize-pred-and-key) + (let ((end (length vector))) + (when (> end 1) + (multiple-value-bind (real-vector start) + (array-data-and-offset vector) + (incf end (%i- start 1)) +; No vector should have a length that's not a fixnum. + '(unless (fixnump end) + (error "Sorry, can't sort vectors larger than ~d." most-positive-fixnum)) + (if (simple-vector-p real-vector) + (if key + (%quick-sort-simple-vector real-vector start end pred key) + (%quick-sort-simple-vector-no-key real-vector start end pred)) + (%quick-sort-vector + real-vector start end pred (or key #'identity)))))) + vector) + +;;; merge-sort internals + +(defun %merge-sort-vector (vector start end pred key + temp-vec res-temp?) + ;; If somebody wanted to do it, half of these arefs can be %svrefs, + ;; but you'd need two loops in the merge code + ;; (temp-vec is simple if res-temp? is false). + ;; But who sorts non-svref'able vectors anyway? + (let* ((mid (%ilsr 1 (%i+ start end)))) + (if (%i<= (%i- mid 1) start) + (unless res-temp? + (setf (aref temp-vec start) (aref vector start))) + (%merge-sort-vector + vector start mid pred key temp-vec (not res-temp?))) + (if (%i>= (%i+ mid 1) end) + (unless res-temp? + (setf (aref temp-vec mid) (aref vector mid))) + (%merge-sort-vector + vector mid end pred key temp-vec (not res-temp?))) + + (unless res-temp? + (psetq vector temp-vec temp-vec vector)) + + (%merge-vectors vector start mid vector mid end temp-vec start pred key))) + +(defun %merge-sort-simple-vector (vector start end pred key + temp-vec res-temp?) + (let* ((mid (%ilsr 1 (%i+ start end)))) + (if (%i<= (%i- mid 1) start) + (unless res-temp? + (setf (%svref temp-vec start) (%svref vector start))) + (%merge-sort-simple-vector + vector start mid pred key temp-vec (not res-temp?))) + (if (%i>= (%i+ mid 1) end) + (unless res-temp? + (setf (%svref temp-vec mid) (%svref vector mid))) + (%merge-sort-simple-vector + vector mid end pred key temp-vec (not res-temp?))) + + (unless res-temp? + (psetq vector temp-vec temp-vec vector)) + + (%merge-simple-vectors + vector start mid vector mid end temp-vec start pred key))) + +(defun %merge-sort-simple-vector-no-key (vector start end pred + temp-vec res-temp?) + (let* ((mid (%ilsr 1 (%i+ start end)))) + (if (%i<= (%i- mid 1) start) + (unless res-temp? + (setf (%svref temp-vec start) (%svref vector start))) + (%merge-sort-simple-vector-no-key + vector start mid pred temp-vec (not res-temp?))) + (if (%i>= (%i+ mid 1) end) + (unless res-temp? + (setf (%svref temp-vec mid) (%svref vector mid))) + (%merge-sort-simple-vector-no-key + vector mid end pred temp-vec (not res-temp?))) + + (unless res-temp? + (psetq vector temp-vec temp-vec vector)) + + (%merge-simple-vectors-no-key + vector start mid vector mid end temp-vec start pred))) + +(defun %merge-vectors (a1 start1 end1 a2 start2 end2 + out start-out pred key) + (let* ((i1 start1) + (i2 start2) + (i-out start-out) + v1 v2 k1 k2) + (cond ((eq start1 end1) + (when (eq start2 end2) + (return-from %merge-vectors out)) + (setq i1 start2 + end1 end2 + a1 a2 + v1 (aref a1 i1))) + ((eq start2 end2) + (setq i1 start1 + v1 (aref a1 i1))) + (t + (setq v1 (aref a1 i1) + v2 (aref a2 i2) + k1 (if key (funcall key v1) v1) + k2 (if key (funcall key v2) v2)) + (loop (if (funcall pred k2 k1) + (progn (setf (aref out i-out) v2 + i-out (%i+ i-out 1) + i2 (%i+ i2 1)) + (when (eq i2 end2) + (return)) + (setq v2 (aref a2 i2) + k2 (if key (funcall key v2) v2))) + (progn (setf (aref out i-out) v1 + i-out (%i+ i-out 1) + i1 (%i+ i1 1)) + (when (eq i1 end1) + (setq a1 a2 i1 i2 end1 end2 v1 v2) + (return)) + (setq v1 (aref a1 i1) + k1 (if key (funcall key v1) v1))))))) + (loop + (setf (aref out i-out) v1 + i1 (%i+ i1 1)) + (if (eq i1 end1) + (return out)) + (setq v1 (aref a1 i1) + i-out (%i+ i-out 1))))) + +(defun %merge-simple-vectors (a1 start1 end1 a2 start2 end2 + out start-out pred key) + (let* ((i1 start1) + (i2 start2) + (i-out start-out) + v1 v2 k1 k2) + (cond ((eq start1 end1) + (when (eq start2 end2) + (return-from %merge-simple-vectors out)) + (setq i1 start2 + end1 end2 + a1 a2 + v1 (%svref a1 i1))) + ((eq start2 end2) + (setq i1 start1 + v1 (%svref a1 i1))) + (t + (setq v1 (%svref a1 i1) + v2 (%svref a2 i2) + k1 (if key (funcall key v1) v1) + k2 (if key (funcall key v2) v2)) + (loop (if (funcall pred k2 k1) + (progn (setf (%svref out i-out) v2 + i-out (%i+ i-out 1) + i2 (%i+ i2 1)) + (when (eq i2 end2) + (return)) + (setq v2 (%svref a2 i2) + k2 (funcall key v2))) + (progn (setf (%svref out i-out) v1 + i-out (%i+ i-out 1) + i1 (%i+ i1 1)) + (when (eq i1 end1) + (setq a1 a2 i1 i2 end1 end2 v1 v2) + (return)) + (setq v1 (%svref a1 i1) + k1 (funcall key v1))))))) + (loop + (setf (%svref out i-out) v1 + i1 (%i+ i1 1)) + (if (eq i1 end1) + (return out)) + (setq v1 (%svref a1 i1) + i-out (%i+ i-out 1))))) + +(defun %merge-simple-vectors-no-key (a1 start1 end1 a2 start2 end2 + out start-out pred) + (let* ((i1 start1) + (i2 start2) + (i-out start-out) + v1 v2) + (cond ((eq start1 end1) + (when (eq start2 end2) + (return-from %merge-simple-vectors-no-key out)) + (setq i1 start2 + end1 end2 + a1 a2 + v1 (%svref a1 i1))) + ((eq start2 end2) + (setq i1 start1 + v1 (%svref a1 i1))) + (t + (setq v1 (%svref a1 i1) + v2 (%svref a2 i2)) + (loop (if (funcall pred v2 v1) + (progn (setf (%svref out i-out) v2 + i-out (%i+ i-out 1) + i2 (%i+ i2 1)) + (when (eq i2 end2) + (return)) + (setq v2 (%svref a2 i2))) + (progn (setf (%svref out i-out) v1 + i-out (%i+ i-out 1) + i1 (%i+ i1 1)) + (when (eq i1 end1) + (setq a1 a2 i1 i2 end1 end2 v1 v2) + (return)) + (setq v1 (%svref a1 i1))))))) + (loop + (setf (%svref out i-out) v1 + i1 (%i+ i1 1)) + (if (eq i1 end1) + (return out)) + (setq v1 (%svref a1 i1) + i-out (%i+ i-out 1))))) + + +;;; Quick sort internals +(defun %quick-sort-vector (vector start end pred key) + (declare (optimize (speed 3) (safety 0))) + (declare (fixnum start end)) + (if (< start end) + (let* ((p (the fixnum (+ start (the fixnum (ash (the fixnum (- end start)) -1))))) + (Ai (aref vector p)) + (x (funcall key Ai)) + (pivot Ai) + (i start) + (j (the fixnum (1+ end))) + Aj) + (declare (fixnum p i j)) + (setf (aref vector p) (aref vector start) + (aref vector start) Ai) + (block partition + (loop + (loop (unless (> (decf j) i) (return-from partition)) + (unless (funcall pred + x + (funcall key (setq Aj (aref vector j)))) + (return))) + (loop (unless (< (incf i) j) (return-from partition)) + (unless (funcall pred + (funcall key (setq Ai (aref vector i))) + x) + (return))) + (setf (aref vector i) Aj + (aref vector j) Ai))) + (setf (aref vector start) (aref vector j) + (aref vector j) pivot) + ; This compare is important. It limits stack depth to log(end-start) + (if (< (the fixnum (- j start)) (the fixnum (- end j))) + (progn + (%quick-sort-vector vector start (the fixnum (1- j)) pred key) + (%quick-sort-vector vector (the fixnum (1+ j)) end pred key)) + (progn + (%quick-sort-vector vector (the fixnum (1+ j)) end pred key) + (%quick-sort-vector vector start (the fixnum (1- j)) pred key)))) + vector)) + +(defun %quick-sort-simple-vector (vector start end pred key) + (declare (optimize (speed 3) (safety 0))) + (declare (type simple-vector vector) + (fixnum start end)) + (if (< start end) + (let* ((p (the fixnum (+ start (the fixnum (ash (the fixnum (- end start)) -1))))) + (Ai (svref vector p)) + (pivot Ai) + (x (funcall key Ai)) + (i start) + (j (the fixnum (1+ end))) + Aj) + (declare (fixnum p i j)) + (setf (svref vector p) (svref vector start) + (svref vector start) Ai) + (block partition + (loop + (loop (unless (> (decf j) i) (return-from partition)) + (unless (funcall pred + x + (funcall key (setq Aj (svref vector j)))) + (return))) + (loop (unless (< (incf i) j) (return-from partition)) + (unless (funcall pred + (funcall key (setq Ai (svref vector i))) + x) + (return))) + (setf (aref vector i) Aj + (aref vector j) Ai))) + (setf (svref vector start) (svref vector j) + (svref vector j) pivot) + (if (< (the fixnum (- j start)) (the fixnum (- end j))) + (progn + (%quick-sort-simple-vector vector start (the fixnum (1- j)) pred key) + (%quick-sort-simple-vector vector (the fixnum (1+ j)) end pred key)) + (progn + (%quick-sort-simple-vector vector (the fixnum (1+ j)) end pred key) + (%quick-sort-simple-vector vector start (the fixnum (1- j)) pred key)))) + vector)) + +(defun %quick-sort-simple-vector-no-key (vector start end pred) + (declare (optimize (speed 3) (safety 0))) + (declare (type simple-vector vector) + (fixnum start end)) + (if (< start end) + (let* ((p (the fixnum (+ start (the fixnum (ash (the fixnum (- end start)) -1))))) + (x (svref vector p)) + (i start) + (j (the fixnum (1+ end))) + Ai Aj) + (declare (fixnum p i j)) + (setf (svref vector p) (svref vector start) + (svref vector start) x) + (block partition + (loop + (loop (unless (> (decf j) i) (return-from partition)) + (unless (funcall pred + x + (setq Aj (svref vector j))) + (return))) + (loop (unless (< (incf i) j) (return-from partition)) + (unless (funcall pred + (setq Ai (svref vector i)) + x) + (return))) + (setf (aref vector i) Aj + (aref vector j) Ai))) + (setf (svref vector start) (svref vector j) + (svref vector j) x) + (if (< (the fixnum (- j start)) (the fixnum (- end j))) + (progn + (%quick-sort-simple-vector-no-key vector start (the fixnum (1- j)) pred) + (%quick-sort-simple-vector-no-key vector (the fixnum (1+ j)) end pred)) + (progn + (%quick-sort-simple-vector-no-key vector (the fixnum (1+ j)) end pred) + (%quick-sort-simple-vector-no-key vector start (the fixnum (1- j)) pred)))) + vector)) + + + +;; This conses like crazy if you merge lists into vectors or vice-versa, but +;; I don't want to write 6 more merging routines. Fry's coerce's +;; will have to stand for now. +;; Only difficulty here is parsing the result-type for vectors. +(defun merge (result-type sequence1 sequence2 predicate &key key) + "Merge the sequences SEQUENCE1 and SEQUENCE2 destructively into a + sequence of type RESULT-TYPE using PREDICATE to order the elements. + If result-type specifies an array, the returned array will not be + a complex array. Usually, result-type is either LIST, ARRAY or STRING." + (let* ((result-len (+ (length sequence1) (length sequence2))) + (result-ctype (specifier-type result-type))) + (cond ((csubtypep result-ctype (specifier-type 'null)) + (unless (zerop result-len) + (error 'invalid-subtype-error :datum result-type + :expected-type 'cons))) + ((csubtypep result-ctype (specifier-type 'list)) + (canonicalize-pred-and-key predicate key) + (values ; For the terminally pedantic. + (merge-lists* (if (listp sequence1) + sequence1 + (coerce sequence1 'list)) + (if (listp sequence2) + sequence2 + (coerce sequence2 'list)) + predicate key))) + ((csubtypep result-ctype (specifier-type 'vector)) + (merge-vectors (if (listp sequence1) + (coerce sequence1 'vector) + sequence1) + (if (listp sequence2) + (coerce sequence2 'vector) + sequence2) + predicate key + result-type)) + (t (error 'invalid-subtype-error + :datum result-type + :expected-type 'sequence))))) + +(defun merge-vectors (vector-1 vector-2 pred key + &optional (result-type 'vector)) + "Internal function. Use MERGE instead." + (canonicalize-pred-and-key) + (let* ((length-1 (length vector-1)) + (length-2 (length vector-2)) + (result-length (+ length-1 length-2)) + (result (make-merge-vectors-result + result-type result-length vector-1 vector-2)) + real-vector-1 start-1 real-vector-2 start-2) + (multiple-value-setq (real-vector-1 start-1) + (array-data-and-offset vector-1)) + (multiple-value-setq (real-vector-2 start-2) + (array-data-and-offset vector-2)) + (incf length-1 start-1) + (incf length-2 start-2) + (if (and (simple-vector-p real-vector-1) (simple-vector-p real-vector-2) + (simple-vector-p result)) + (if key + (%merge-simple-vectors real-vector-1 start-1 length-1 + real-vector-2 start-2 length-2 + result 0 pred key) + (%merge-simple-vectors-no-key real-vector-1 start-1 length-1 + real-vector-2 start-2 length-2 + result 0 pred)) + (%merge-vectors real-vector-1 start-1 length-1 + real-vector-2 start-2 length-2 + result 0 pred key)))) + +;; OK, here goes the type parsing... +(defun make-merge-vectors-result (result-type result-length vector-1 vector-2) + (let* ((ctype (specifier-type result-type))) + (let* ((size (array-ctype-length ctype)) + (elt-type (array-or-union-ctype-element-type ctype))) + (if (eq elt-type '*) + (let ((et1 (array-element-type vector-1)) + (et2 (array-element-type vector-2))) + (setq elt-type (if (eq et1 et2) et1 `(or ,et1 ,et2))))) + (if (and size (not (eq size result-length))) + (error 'invalid-subtype-error + :datum result-type + :expected-type `(vector ,elt-type ,result-length)) + (make-array (the fixnum (or size result-length)) + :element-type elt-type))))) + + +;; Gee, that wasn't so bad after all. +;; Well, when you're building on the shoulders of giants, +;; your little effort can seem great. + + +;; "If I haven't seen as far as others, it's because giants were standing on my shoulders." Index: /branches/new-random/lib/source-files.lisp =================================================================== --- /branches/new-random/lib/source-files.lisp (revision 13309) +++ /branches/new-random/lib/source-files.lisp (revision 13309) @@ -0,0 +1,770 @@ +;;;-*- Mode: Lisp; Package: CCL -*- +;;; +;;; Copyright (C) 2009 Clozure Associates +;;; Copyright (C) 1994-2001 Digitool, Inc +;;; This file is part of Clozure CL. +;;; +;;; Clozure CL is licensed under the terms of the Lisp Lesser GNU Public +;;; License , known as the LLGPL and distributed with Clozure CL as the +;;; file "LICENSE". The LLGPL consists of a preamble and the LGPL, +;;; which is distributed with Clozure CL as the file "LGPL". Where these +;;; conflict, the preamble takes precedence. +;;; +;;; Clozure CL is referenced in the preamble as the "LIBRARY." +;;; +;;; The LLGPL is also available online at +;;; http://opensource.franz.com/preamble.html + +(in-package "CCL") + +;; If we're reloading this file, don't want to be calling functions from here with +;; only some of them redefined. So revert to the bootstrapping version until the end. +(fset 'record-source-file #'level-1-record-source-file) + +(defvar *source-files-lock* (make-lock "Source Files Lock")) + +(defvar *unique-setf-names* (make-hash-table :test #'eq)) + +(defun canonical-maybe-setf-name (name) + (if (setf-function-name-p name) + (let ((tem (%setf-method (%cadr name)))) + (if (non-nil-symbol-p tem) ;; e.g. (setf car) => set-car + tem + (or (gethash (%cadr name) *unique-setf-names*) + (setf (gethash (%cadr name) *unique-setf-names*) (list 'setf (%cadr name)))))) + name)) + +(defgeneric name-of (thing) + (:method ((thing t)) thing) + (:method ((thing method-function)) (name-of (%method-function-method thing))) + (:method ((thing function)) (name-of (function-name thing))) + (:method ((thing method)) `(:method ,(method-name thing) ,@(method-qualifiers thing) ,(method-specializers thing))) + (:method ((thing class)) (class-name thing)) + (:method ((thing method-combination)) (method-combination-name thing)) + (:method ((thing package)) (package-name thing)) + (:method ((thing eql-specializer)) `(eql ,(eql-specializer-object thing)))) + +;; This used to be weak, but the keys are symbols-with-definitions, so why bother. +;; Set a high rehash threshold because space matters more than speed here. +;; Do not use lock-free hash tables, because they optimize reads at the expense of +;; writes/rehashes. Writes/rehashes affect file-compilation speed, which matters. +(defvar %source-files% (make-hash-table :test #'eq + :size 14000 + :rehash-size 1.8 ;; compensate for high threshold + :rehash-threshold .95 + :lock-free nil)) + + + +(defvar *direct-methods-only* t + "If true, method name source location lookup will find direct methods only. If false, + include all applicable methods") + + +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; +;; +;; Definition types +;; +;; Definition types are uniquely identified by a symbol, but are implemented as +;; classes so they can inherit/customize behavior. They have no instances other +;; than the class prototype, which is used to invoke methods. +;; + +(defgeneric definition-type-name (def-type) + (:documentation "The preferred user-visible name of the def-type. Used for +error messages etc. The default method returns the name specified in +define-definition-type.")) + +(defclass definition-type () + ((name :allocation :class :reader definition-type-name :initform t)) + (:documentation "Superclass of all definition types")) + +(defgeneric definition-base-name (def-type def) + ;; Note that a def can have multiple base names, but each one needs a different def-type + (:documentation "Return the name that, when the user asks for all definitions of that +name, this def should be included. Typically this is a symbol. It's used as a key in +an EQ hash table, so must return EQ values for equivalent definitions. +The default method returns the rightmost atom in name") + (:method ((dt definition-type) name) + (while (consp name) + (let ((x (last name))) + (setq name (or (cdr x) (car x))))) + name)) + +(defgeneric definition-same-p (def-type def1 def2) + (:documentation "Returns true if the two definitions are equivalent, i.e. one should +replace the other. The default method calls EQUAL.") + (:method ((dt definition-type) name1 name2) + (equal name1 name2))) + +(defgeneric definition-bound-p (def-type def) + (:documentation "Returns true if def is currently defined. Used to decide whether to issue +redefinition warnings. The default method returns T.") + (:method ((dt definition-type) name) + (declare (ignore name)) + t)) + +;;;;;;;;;; + +(defvar *definition-types* () + "alist of all known definition type names and their class prototypes") + +(defmethod print-object ((dt definition-type) stream) + (if *print-escape* + (let ((definedp (class-name (class-of dt)))) + (print-unreadable-object (dt stream :type definedp :identity t) + (unless definedp + (format stream "#:~s " 'definition-type)) ;; subtly indicate it's a subclass... + (format stream "~s" (definition-type-name dt)))) + (format stream "~s" (definition-type-name dt)))) + +(defmethod name-of ((thing definition-type)) + (definition-type-name thing)) + +(defmacro define-definition-type (name supers &rest options) + "Defines a class named name-DEFINITION-TYPE and registers it as the class of +definition type NAME" + (loop with known-keys = '( ;; Backward compatibility + #+ccl-0711 :default-name-function) + for (key . nil) in options + unless (memq key known-keys) + do (signal-program-error "Unknown option ~s" key)) + (let ((class-name (intern (%str-cat (symbol-name name) "-DEFINITION-TYPE")))) + `(progn + (defclass ,class-name ,(or supers '(definition-type)) + ((name :allocation :class :initform ',name))) + (record-source-file ',name 'definition-type) + (register-definition-type (find-class ',class-name) '(,name))))) + +(defun register-definition-type (class names) + (let ((instance (class-prototype class))) + (with-lock-grabbed (*source-files-lock*) + ;; If had a previous definition, the defclass will signal any duplicate + ;; definition warnings, so here just silently replace previous one. + (without-interrupts + (setq *definition-types* + (remove instance *definition-types* :key #'cdr))) + (loop for name in names + unless (without-interrupts + (unless (assq name *definition-types*) + (push (cons name instance) *definition-types*))) + do (error "There is already a different definition type ~s named ~s" + (cdr (assq name *definition-types*)) + name))) + ;; Return instance for use in make-load-form + instance)) + +(defun auto-create-definition-type (name) + ;; Use an anonymous class, so this means can't write methods on it. + ;; If you want to write methods on it, use define-definition-type first. + (let* ((super (find-class 'definition-type)) + (new-class (make-instance (class-of super) + :direct-superclasses (list super) + :direct-slots `((:name name + :allocation :class + :initform ',name + :initfunction ,(constantly name)))))) + (register-definition-type new-class (list name)) + (class-prototype new-class))) + +(defmethod definition-type-instance ((dt definition-type) &key (if-does-not-exist :error)) + (if (rassoc dt *definition-types* :test #'eq) + dt + (ecase if-does-not-exist + ((nil) nil) + ((:error) (error "~s is not a known definition-type" dt))))) + +(defmethod definition-type-instance ((name symbol) &key (if-does-not-exist :error)) + (or (cdr (assq name *definition-types*)) + (ecase if-does-not-exist + ((nil) nil) + ((:error) (error "~s is not a known definition-type" name)) + ((:create) (auto-create-definition-type name))))) + +(defmethod definition-type-instance ((class class) &key (if-does-not-exist :error)) + (definition-type-instance (class-prototype class) :if-does-not-exist if-does-not-exist)) + +(defmethod make-load-form ((dt definition-type) &optional env) + (declare (ignore env)) + (let ((names (loop for (name . instance) in *definition-types* + when (eq dt instance) collect name))) + `(register-definition-type ',(class-of dt) ',names))) + + +(register-definition-type (find-class 'definition-type) '(t)) + +(defparameter *t-definition-type* (definition-type-instance 't)) + +(define-definition-type function ()) + +(defparameter *function-definition-type* (definition-type-instance 'function)) + +(defmethod definition-base-name ((dt function-definition-type) name) + (while (and (consp name) (not (setf-function-name-p name))) + (let ((x (last name))) + (or (setq name (cdr x)) + ;; Try to detect the (:internal .... ) case + (when (and (setq name (car x)) + ;;check for plausible method name + (setq x (method-def-parameters name)) + (neq x 'setf) + (not (keywordp x))) + (setq name x))))) + (canonical-maybe-setf-name name)) + +(defmethod definition-bound-p ((dt function-definition-type) name) + (and (or (symbolp name) (setf-function-name-p name)) + (or (fboundp name) + ;; treat long-form setf expanders like macros. + (and (consp name) (functionp (%setf-method (cadr name))))))) + +(define-definition-type macro (function-definition-type)) + +(define-definition-type compiler-macro (macro-definition-type)) + +(define-definition-type symbol-macro (macro-definition-type)) + +(define-definition-type setf-expander (macro-definition-type)) + +(define-definition-type generic-function (function-definition-type)) + +(define-definition-type method ()) + +(defparameter *method-definition-type* (definition-type-instance 'method)) + +(defmethod definition-base-name ((dt method-definition-type) (name cons)) + (if (setf-function-name-p name) + (canonical-maybe-setf-name name) + (definition-base-name *function-definition-type* (car name)))) + +;; defmethod passes the actual method into record-source-file +(defmethod definition-base-name ((dt method-definition-type) (method method)) + (definition-base-name dt (method-name method))) + +(defmethod definition-base-name ((dt method-definition-type) (fn method-function)) + (definition-base-name dt (function-name fn))) + +(defmethod definition-same-p ((dt method-definition-type) m1 m2) + (multiple-value-bind (n1 q1 s1) (method-def-parameters m1) + (multiple-value-bind (n2 q2 s2) (method-def-parameters m2) + (and (definition-same-p *function-definition-type* n1 n2) + (equal q1 q2) + (eql (length s1) (length s2)) + (every #'(lambda (s1 s2) + (or (equal s1 s2) + (progn + (when (symbolp s2) (rotatef s1 s2)) + (and (symbolp s1) + (classp s2) + (or (eq (find-class s1 nil) s2) + (eq s1 (class-name s2))))))) + s1 s2))))) + +(defmethod definition-bound-p ((dt method-definition-type) meth &aux fn) + (when (setq fn (method-def-parameters meth)) + (loop for m in (and (setq fn (fboundp fn)) + (typep fn 'generic-function) + (generic-function-methods fn)) + thereis (definition-same-p dt meth m)))) + +(define-definition-type reader-method (method-definition-type)) + +(define-definition-type writer-method (method-definition-type)) + +(define-definition-type callback (function-definition-type)) + +(define-definition-type structure-accessor (function-definition-type)) + +(define-definition-type type ()) + +(define-definition-type class ()) + +(defmethod definition-bound-p ((dt class-definition-type) name) + (and (non-nil-symbol-p name) (find-class name nil))) + +(define-definition-type condition (class-definition-type)) + +(define-definition-type structure ()) + +(define-definition-type definition-type ()) + +(defmethod definition-bound-p ((dt definition-type-definition-type) name) + (definition-type-instance name :if-does-not-exist nil)) + +(define-definition-type method-combination ()) + +(define-definition-type variable ()) + +(defmethod definition-bound-p ((dt variable-definition-type) name) + (and (non-nil-symbol-p name) (boundp name))) + +(define-definition-type constant (variable-definition-type)) + +(define-definition-type package ()) + +(defmethod definition-base-name ((dt package-definition-type) name) + (if (or (stringp name) (non-nil-symbol-p name)) + (intern (string name) :keyword) + name)) + +(defmethod definition-bound-p ((dt package-definition-type) name) + (and (or (stringp name) (symbolp name)) + (find-package (string name)))) + +(defmethod definition-same-p ((dt package-definition-type) d1 d2) + (and (or (stringp d1) (symbolp d1)) + (or (stringp d2) (symbolp d2)) + (equal (string d1) (string d2)))) + + +;;;;;;;;;;; + +(declaim (inline default-definition-type)) + +(defun default-definition-type (name) + (if (typep name 'method) + *method-definition-type* + *function-definition-type*)) + +;; remember & reuse last few (TYPE . file) entries +(let ((cache (make-list 10 :initial-element nil))) + (defun type-file-cons (type files) + (loop for prev = nil then p for p = cache then (cdr p) + do (when (or (and (eq type (caar p)) (equal files (cdar p))) + (and (null (cdr p)) + (setf (car p) (cons type files)))) + (when prev ;; move to front unless already there + (setf (cdr prev) (cdr p)) + (setf (cdr p) cache) + (setq cache p)) + (return (car p)))))) + +(defun %source-file-entries (key) + (let ((data (gethash key %source-files%))) + (if (and (listp data) + (listp (%cdr data))) + data + (list data)))) + +(defun %set-source-file-entries (key list &aux data) + (setf (gethash key %source-files%) + (if (and list + (null (cdr list)) + ;; One element, but make sure can recognize it. + (not (and (listp (%car list)) + (listp (%cdar data))))) + (car list) + list))) + +(defun make-def-source-entry (key type name files) + (setq files (if (or (%cdr files) (listp (%car files))) files (%car files))) + (cond ((eq type (default-definition-type name)) + (if (and (eq name key) (atom files)) + files + (cons name files))) + ((eq name key) + (type-file-cons type files)) + (t + (cons (cons type name) files)))) + +(defun decode-def-source-entry (key entry) + (if (atom entry) + (and entry (values (default-definition-type key) key (list entry))) + (let* ((file-or-files (%cdr entry)) + (files (if (consp file-or-files) file-or-files (list file-or-files)))) + (cond ((typep (%car entry) 'definition-type) + (values (%car entry) key files)) + ((and (consp (%car entry)) (typep (%caar entry) 'definition-type)) + (values (%caar entry) (%cdar entry) files)) + (t + (values (default-definition-type (%car entry)) (%car entry) files)))))) + +(defun def-source-entry.name (key entry) + (assert (not (null entry))) + (cond ((atom entry) key) + ((typep (%car entry) 'definition-type) key) + ((and (consp (%car entry)) (typep (%caar entry) 'definition-type)) + (%cdar entry)) + (t + (%car entry)))) + +(defun def-source-entry.type (key entry) + (cond ((atom entry) (default-definition-type key)) + ((typep (%car entry) 'definition-type) (%car entry)) + ((and (consp (%car entry)) (typep (%caar entry) 'definition-type)) + (%caar entry)) + (t + (default-definition-type (%car entry))))) + +(defun def-source-entry.sources (key entry) + (declare (ignore key)) + (cond ((consp entry) + (if (consp (%cdr entry)) (%cdr entry) (list (%cdr entry)))) + (entry (list entry)) + (t nil))) + + +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; +;;; + + +;; Some objects (specifically functions) have source location information associated with the +;; object itself, in addition to any source locations associated with its definition. This +;; allows us to find source for, e.g., anonymous functions. +(defgeneric get-object-sources (thing) + ;; returns a list of entries ((a-type . a-name) source . previous-sources) + (:method ((thing t)) nil) + (:method ((fn function)) + (let ((source (function-source-note fn))) + (when source + (list (list* (cons *function-definition-type* (or (name-of fn) fn)) source nil))))) + (:method ((fn method-function)) + (let ((source (function-source-note fn))) + (when source + (list (list* (cons *method-definition-type* (%method-function-method fn)) source nil))))) + (:method ((m method)) + (get-object-sources (method-function m)))) + +(defun find-definition-sources (name &optional (type t)) + "Returns a list of entries ((a-type . a-name) source . previous-sources), where +a-type is a subtype of TYPE, and a-name is either NAME or it's a special case of +NAME (e.g. if NAME is the name of generic function, a-name could be a method of NAME). + +If NAME is not a cons or symbol, it's assumed to be an object (e.g. class or +function) whose source location we try to heuristically locate, usually by looking up +the sources of its name. + +If NAME is a method name and *DIRECT-METHODS-ONLY* is false, will also locate all +applicable methods. + +The returned list is guaranteed freshly consed (ie suitable for nconc'ing)." + + (let* ((dt-class (class-of (definition-type-instance type))) + (matches (get-object-sources name))) + (if matches + (setq matches (delete-if-not (lambda (info) (typep (caar info) dt-class)) matches)) + ;; No intrinsic source info for the thing itself, look it up by name. + (let (seen-dts implicit-type implicit-dt-class implicit-name) + (typecase name + (method + (setq implicit-type 'method implicit-name name)) + (method-function + (setq implicit-type 'method implicit-name (%method-function-method name))) + (function + (setq implicit-type 'function implicit-name (name-of name))) + (method-combination + (setq implicit-type 'method-combination implicit-name (name-of name))) + (package + (setq implicit-type 'package implicit-name (name-of name))) + (class + (setq implicit-type 'class implicit-name (name-of name))) + (t + (locally + (declare (ftype function xref-entry-p xref-entry-full-name xref-entry-type)) + (if (and (find-class 'xref-entry nil) + (xref-entry-p name)) + (setq implicit-type (xref-entry-type name) implicit-name (xref-entry-full-name name)) + (setq implicit-type t implicit-name name))))) + (setq implicit-dt-class (class-of (definition-type-instance implicit-type))) + (with-lock-grabbed (*source-files-lock*) + (loop for (nil . dt) in *definition-types* + when (and (typep dt dt-class) (typep dt implicit-dt-class) (not (memq dt seen-dts))) + do (let* ((key (definition-base-name dt implicit-name)) + (all (%source-file-entries key))) + (push dt seen-dts) + (loop for entry in all + when (and (eq dt (def-source-entry.type key entry)) + (or (eq implicit-name key) ;; e.g. all methods on a gf + (definition-same-p dt implicit-name (def-source-entry.name key entry)))) + do (multiple-value-bind (type name files) + (decode-def-source-entry key entry) + (push (cons (cons type name) files) matches)))))))) + + ;; include indirect applicable methods. Who uses this case? + (when (and (eq type 'method) + (not (typep name 'method)) + (not *direct-methods-only*)) + (multiple-value-bind (sym qualifiers specializers) (method-def-parameters name) + (when sym + (loop for m in (find-applicable-methods sym specializers qualifiers) + unless (definition-same-p *method-definition-type* m name) + do (setq matches (nconc (find-definition-sources m 'method) matches)))))) + matches)) + +;;; backward compatibility + +;;; modified version of %method-applicable-p - args are class names +;;; not instances +(defun %my-method-applicable-p (method args cpls) + (do* ((specs (%method-specializers method) (%cdr specs)) + (args args (%cdr args)) + (cpls cpls (%cdr cpls))) + ((null args) t) + (let ((spec (%car specs)) + (arg (%car args))) + (if (typep spec 'eql-specializer) + (if (consp arg) + (unless (eql (cadr arg) (eql-specializer-object spec)) + (return nil)) + (if (typep (eql-specializer-object spec) arg) + ;(unless (eq arg *null-class*) (return :undecidable)) + t ;; include if it's at all possible it might be applicable. + (return nil))) + (unless (memq spec (%car cpls)) + (return nil)))))) + +;;; modified version of %compute-applicable-methods* +;;; omit errors and args are class names not instances +;;; returns a new list. +(defun find-applicable-methods (name args qualifiers) + (let ((gf (fboundp name))) + (when (and gf (typep gf 'standard-generic-function)) + (let* ((methods (or (%gf-methods gf) + (return-from find-applicable-methods nil))) + (arg-count (length (%method-specializers (car methods)))) + (args-length (length args)) + (bits (inner-lfun-bits gf)) + res) + (unless (or (logbitp $lfbits-rest-bit bits) + (logbitp $lfbits-restv-bit bits) + (logbitp $lfbits-keys-bit bits) + (<= args-length + (+ (ldb $lfbits-numreq bits) (ldb $lfbits-numopt bits)))) + ;(error "Too many args for ~s" gf) + (return-from find-applicable-methods)) + (when (< arg-count args-length) + (setq args (subseq args 0 (setq args-length arg-count)))) + (setq args (mapcar (lambda (arg) + (typecase arg + (eql-specializer `(eql ,(eql-specializer-object arg))) + (class arg) + (symbol (or (find-class (or arg t) nil) + ;;(error "Invalid class name ~s" arg) + (return-from find-applicable-methods))) + (t + (unless (and (consp arg) (eql (car arg) 'eql) (null (cddr arg))) + ;;(error "Invalid specializer ~s" arg) + (return-from find-applicable-methods)) + arg))) + args)) + (let ((cpls (make-list args-length))) + (declare (dynamic-extent cpls)) + (do ((args-tail args (cdr args-tail)) + (cpls-tail cpls (cdr cpls-tail))) + ((null cpls-tail)) + (declare (type list args-tail cpls-tail)) + (let ((arg (car args-tail))) + (setf (car cpls-tail) + (%class-precedence-list (if (consp arg) + (class-of (cadr arg)) + arg))))) + (dolist (m methods) + (when (%my-method-applicable-p m args cpls) + (push m res))) + (let ((methods (sort-methods res cpls (%gf-precedence-list gf)))) + (when (eq (generic-function-method-combination gf) + *standard-method-combination*) + ; around* (befores) (afters) primaries* + (setq methods (compute-method-list methods)) + (when methods + (setq methods + (if (not (consp methods)) + (list methods) + (let ((afters (cadr (member-if #'listp methods)))) + (when afters (nremove afters methods)) + (nconc + (mapcan #'(lambda (x)(if (listp x) x (cons x nil))) + methods) + afters)))))) + (if (and qualifiers (neq qualifiers t)) + (delete-if #'(lambda (m)(not (equal qualifiers (%method-qualifiers m)))) + methods) + methods))))))) + +;;; Do this just in case record source file doesn't remember the right +;;; definition +(defun methods-match-p (x y) + (or (eq x y) + (and (typep x 'method) + (typep y 'method) + (equal (method-name x) + (method-name y)) + (equal (method-specializers x) + (method-specializers y)) + (equal (method-qualifiers x) + (method-qualifiers y))))) + +(defun edit-definition-p (name &optional (type t)) ;exported + (let ((specs (get-source-files-with-types name type))) + (when (and (null specs) + (symbolp name)) + (let* ((str (symbol-name name)) + (len (length str))) + (when (and (> len 0) (memq (char str (1- len)) '(#\. #\, #\:))) + (let ((newsym (find-symbol (%substr str 0 (1- len)) (symbol-package name)))) + (when newsym + (setq specs (get-source-files-with-types newsym type))))))) + specs)) + +(defun get-source-files-with-types (name &optional (type t)) + (let ((list (find-definition-sources name type))) + ;; Convert to old format, (type-or-name . file) + (loop for ((dt . full-name) . sources) in list + as spec = (if (eq full-name name) (definition-type-name dt) full-name) + nconc (mapcan (lambda (s) + (when s (list (cons spec (source-note-filename s))))) + sources)))) + + +;; For ilisp. +(defun %source-files (name) + (let ((type-list ()) + (meth-list ())) + (loop for ((dt . full-name) . sources) in (find-definition-sources name t) + as files = (mapcan #'(lambda (s) + (and s (setq s (source-note-filename s)) (list s))) + sources) + when files + do (if (typep dt 'method-definition-type) + (dolist (file files) + (push (cons full-name file) meth-list)) + (push (cons (definition-type-name dt) files) type-list))) + (when meth-list + (push (cons 'method meth-list) type-list)) + type-list)) + +;; For CVS slime as of 11/15/2008. +(defun get-source-files-with-types&classes (sym &optional (type t) classes qualifiers the-method) + (let* ((name (or the-method + (and (or (eq type 'method) classes qualifiers) + `(sym ,@qualifiers ,classes)) + sym))) + (get-source-files-with-types name type))) + + +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; +;;; record-source-file + +;; Returns nil if not a method/method name +(defun method-def-parameters (m) + (when (typep m 'method-function) + (setq m (%method-function-method m))) + (if (typep m 'method) + (values (method-name m) + (method-qualifiers m) + (method-specializers m)) + (let (name quals specs data last) + (when (consp m) + (when (eq (car m) :method) (setq m (cdr m))) + ;; (name spec1 .. specn) or (name qual1 .. qualn (spec1 ... specn)) + (setq data (cdr m) last (last data)) + (when (null (cdr last)) + (setq last (car last)) + (if (and (listp last) (neq (car last) 'eql)) + (setq quals (butlast data) specs last) + (setq specs data)) + (setq name (car m)) + (when (and (or (non-nil-symbol-p name) (setf-function-name-p name)) + (every #'(lambda (q) (not (listp q))) quals) + (every #'(lambda (s) + (or (non-nil-symbol-p s) + (classp s) + (and (consp s) + (consp (cdr s)) + (null (cddr s)) + (eq (car s) 'eql)))) + specs)) + (values name quals specs))))))) + +(defmethod record-definition-source ((dt definition-type) name source) + (let* ((key (definition-base-name dt name)) + (all (%source-file-entries key)) + (e-loc nil) + (e-files nil)) + (loop for ptr on all as entry = (car ptr) + do (when (and (eq dt (def-source-entry.type key entry)) + (definition-same-p dt name (def-source-entry.name key entry))) + (setq e-files (def-source-entry.sources key entry)) + (let ((old (flet ((same-file (x y) + (setq x (source-note-filename x)) + (setq y (source-note-filename y)) + (or (equal x y) + (and x + y + (or (stringp x) (pathnamep x)) + (or (stringp y) (pathnamep y)) + (equal + (or (probe-file x) (full-pathname x)) + (or (probe-file y) (full-pathname y))))))) + (member source e-files :test #'same-file)))) + (when (and old (neq source (car e-files))) ;; move to front + (setq e-files (cons source (remove (car old) e-files :test #'eq))))) + (return (setq e-loc ptr)))) + (unless (and e-files (eq source (car e-files))) + ;; Never previously defined in this file + (when (and (car e-files) ; don't warn if last defined interactively + *warn-if-redefine* + (definition-bound-p dt name)) + (warn "~A ~S previously defined in: ~A is now being redefined in: ~A~%" + (definition-type-name dt) + name + (source-note-filename (car e-files)) + (or (source-note-filename source) "{No file}"))) + (setq e-files (cons source e-files))) + (let ((entry (make-def-source-entry key dt name e-files))) + (if e-loc + (setf (car e-loc) entry) + (push entry all)) + (%set-source-file-entries key all)) + name)) + +(defmethod record-definition-source ((dt method-definition-type) (m method) source) + ;; In cases of non-toplevel method definitions, as in the expansion of defgeneric, + ;; the method function note has more specific info than *loading-toplevel-location*. + (call-next-method dt m (or (function-source-note (method-function m)) source))) + +;;; avoid hanging onto beezillions of pathnames +(defparameter *last-back-translated-name* (cons nil nil)) + +;; Define the real record-source-file, which will be the last defn handled by the +;; bootstrapping record-source-file, so convert all queued up data right afterwards. +(progn + +(defun record-source-file (name def-type &optional (source (or *loading-toplevel-location* + *loading-file-source-file*))) + (when (and source *record-source-file*) + (with-lock-grabbed (*source-files-lock*) + (let ((file-name (source-note-filename source))) + (when file-name + (unless (equalp file-name (car *last-back-translated-name*)) + (setf (car *last-back-translated-name*) file-name) + (setf (cdr *last-back-translated-name*) + (if (physical-pathname-p file-name) + (namestring (back-translate-pathname file-name)) + file-name))) + (setq file-name (cdr *last-back-translated-name*)) + (if (source-note-p source) + (setf (source-note-filename source) file-name) + (setq source file-name)))) + (when (eq def-type 't) (report-bad-arg def-type '(not (eql t)))) + (record-definition-source (definition-type-instance def-type + :if-does-not-exist :create) + name + source)))) + +;; Collect level-0 source file info +(do-all-symbols (s) + (let ((f (get s 'bootstrapping-source-files))) + (when f + (if (consp f) + (destructuring-bind ((type . source)) f + (when source (record-source-file s type source))) + (record-source-file s 'function f)) + (remprop s 'bootstrapping-source-files)))) + +;; Collect level-1 source file info +(when (consp *record-source-file*) + (let ((list (nreverse (shiftf *record-source-file* t)))) + (while list + (apply #'record-source-file (pop list))))) +) Index: /branches/new-random/lib/streams.lisp =================================================================== --- /branches/new-random/lib/streams.lisp (revision 13309) +++ /branches/new-random/lib/streams.lisp (revision 13309) @@ -0,0 +1,192 @@ +;;;-*-Mode: LISP; Package: CCL -*- +;;; +;;; Copyright (C) 2009 Clozure Associates +;;; Copyright (C) 1994-2001 Digitool, Inc +;;; This file is part of Clozure CL. +;;; +;;; Clozure CL is licensed under the terms of the Lisp Lesser GNU Public +;;; License , known as the LLGPL and distributed with Clozure CL as the +;;; file "LICENSE". The LLGPL consists of a preamble and the LGPL, +;;; which is distributed with Clozure CL as the file "LGPL". Where these +;;; conflict, the preamble takes precedence. +;;; +;;; Clozure CL is referenced in the preamble as the "LIBRARY." +;;; +;;; The LLGPL is also available online at +;;; http://opensource.franz.com/preamble.html + +; streams.lisp +;;;General io-functions + +(in-package "CCL") + +(eval-when (:execute :compile-toplevel) + (require :level-2) + (require :streams) + (require :backquote) + + ) + + + + + + +(defun read-line (&optional input-stream (eof-error-p t) eof-value recursive-p) + + (declare (ignore recursive-p) + (optimize (speed 3))) + (let* ((input-stream (designated-input-stream input-stream))) + (multiple-value-bind (string eof) + (if (typep input-stream 'basic-stream) + (let* ((ioblock (basic-stream-ioblock input-stream))) + (with-ioblock-input-locked (ioblock) + (funcall (ioblock-read-line-function ioblock) ioblock))) + (stream-read-line input-stream)) + (if eof + (if (= (length string) 0) + (if eof-error-p + (signal-eof-error input-stream) + (values eof-value t)) + (values string t)) + (values string nil))))) + +(eval-when (:compile-toplevel) + (declaim (inline read-char-internal))) + +(defun read-char-internal (input-stream eof-error-p eof-value) + (declare (optimize (speed 3) (space 0))) + (check-eof + (if (or (typep input-stream 'basic-stream) + (typep (setq input-stream (designated-input-stream input-stream)) + 'basic-stream)) + (let* ((ioblock (basic-stream-ioblock input-stream))) + (funcall (ioblock-read-char-function ioblock) ioblock)) + (stream-read-char input-stream)) + input-stream eof-error-p eof-value)) + +(defun read-char (&optional input-stream (eof-error-p t) eof-value recursive-p) + (declare (ignore recursive-p)) + (read-char-internal input-stream eof-error-p eof-value)) + +(defun unread-char (char &optional input-stream) + (let* ((input-stream (designated-input-stream input-stream))) + (if (typep input-stream 'basic-stream) + (let* ((ioblock (basic-stream-ioblock input-stream))) + (funcall (ioblock-unread-char-function ioblock) ioblock char)) + (stream-unread-char input-stream char)) + nil)) + +(defun peek-char (&optional peek-type input-stream + (eof-error-p t) eof-value recursive-p) + (declare (ignore recursive-p)) + (let* ((input-stream (designated-input-stream input-stream))) + (cond ((null peek-type) + (check-eof (stream-peek-char input-stream) input-stream eof-error-p eof-value)) + (t + (do* ((value (stream-peek-char input-stream) (stream-peek-char input-stream))) + ((eq value :eof) + (return (check-eof value input-stream eof-error-p eof-value))) + (if (eq peek-type t) + (unless (whitespacep value) + (return value)) + (if (characterp peek-type) + (if (eql peek-type value) + (return value)) + (report-bad-arg peek-type '(or character (member nil t))))) + (stream-read-char input-stream)))))) + +(defun read-char-no-hang (&optional input-stream (eof-error-p t) eof-value recursive-p) + (declare (ignore recursive-p)) + (setq input-stream (designated-input-stream input-stream)) + (check-eof (stream-read-char-no-hang input-stream) input-stream eof-error-p eof-value)) + +(defun read-byte (stream &optional (eof-error-p t) eof-value) + (declare (optimize (speed 3) (space 0))) + (if (typep stream 'basic-stream) + (let* ((ioblock (basic-stream-ioblock stream))) + (check-eof (funcall (ioblock-read-byte-function ioblock) ioblock) + stream + eof-error-p + eof-value)) + (check-eof + (stream-read-byte stream) + stream + eof-error-p + eof-value))) + +;;;;;;;;;;;; OUTPUT STREAMS + +(defun clear-output (&optional stream) + (let* ((stream (real-print-stream stream))) + (stream-clear-output stream) + nil)) + +(defun finish-output (&optional stream) + (let* ((stream (real-print-stream stream))) + (stream-finish-output stream) + nil)) + + + +(defun line-length (stream) + (declare (ignore stream)) + 80) + +(defun write-byte (byte stream) + (declare (optimize (speed 3) (space 0))) + "Write one byte, BYTE, to STREAM." + (if (typep stream 'basic-stream) + (let* ((ioblock (basic-stream-ioblock stream))) + (funcall (ioblock-write-byte-function ioblock) ioblock byte)) + (stream-write-byte stream byte)) + byte) + + +;;;General stream functions + + + +(defmacro with-open-stream ((var stream) &body body &aux (svar (gensym))) + "Perform a series of operations on stream, return a value, and then +close the stream. VAR is bound to the value of STREAM, and then BODY is +executed as an implicit progn. STREAM is automatically closed on exit +from with-open-stream, no matter whether the exit is normal or abnormal. +The stream has dynamic extent; its extent ends when the form is exited." + `(let (,svar) + (unwind-protect + (let ((,var (setq ,svar ,stream))) + ,@body) + (when ,svar (close ,svar))))) + + + + +;; + +;;; from i/o chapter of steele +;;; Ever notice that -much- of this code is from the i/o chapter +;;; of steele ? Strange but true ... + +(defun read-from-string (string &optional (eof-error-p t) eof-value + &key (start 0) end preserve-whitespace + &aux idx) + "The characters of string are successively given to the lisp reader + and the lisp object built by the reader is returned. Macro chars + will take effect." + (values + (with-input-from-string (stream string :index idx :start start :end end) + (if preserve-whitespace + (read-preserving-whitespace stream eof-error-p eof-value) + (read stream eof-error-p eof-value))) + idx)) + + +;;;File Stuff here + +(defun dribble (&optional filename) + "With a file name as an argument, dribble opens the file and sends a + record of further I/O to that file. Without an argument, it closes + the dribble file, and quits logging." + (process-dribble *current-process* filename)) + Index: /branches/new-random/lib/systems.lisp =================================================================== --- /branches/new-random/lib/systems.lisp (revision 13309) +++ /branches/new-random/lib/systems.lisp (revision 13309) @@ -0,0 +1,216 @@ +;;;-*-Mode: LISP; Package: CCL -*- +;;; +;;; Copyright (C) 2009 Clozure Associates +;;; Copyright (C) 1994-2001 Digitool, Inc +;;; This file is part of Clozure CL. +;;; +;;; Clozure CL is licensed under the terms of the Lisp Lesser GNU Public +;;; License , known as the LLGPL and distributed with Clozure CL as the +;;; file "LICENSE". The LLGPL consists of a preamble and the LGPL, +;;; which is distributed with Clozure CL as the file "LGPL". Where these +;;; conflict, the preamble takes precedence. +;;; +;;; Clozure CL is referenced in the preamble as the "LIBRARY." +;;; +;;; The LLGPL is also available online at +;;; http://opensource.franz.com/preamble.html + +(in-package "CCL") + +;;; module-name binary (source . files-depends-on) +;;; ----------- ------ --------------------------- +(defparameter *ccl-system* + '( + (level-1 "ccl:ccl;level-1" ("ccl:l1;level-1.lisp")) + (runtime "ccl:ccl;runtime" ("ccl:l1;runtime.lisp")) + (level-1-test "ccl:level-1-test" ("ccl:l1;level-1-test.lisp")) + (l1-cl-package "ccl:l1f;l1-cl-package" ("ccl:l1;l1-cl-package.lisp")) + (l1-utils "ccl:l1f;l1-utils" ("ccl:l1;l1-utils.lisp")) + (l1-numbers "ccl:l1f;l1-numbers" ("ccl:l1;l1-numbers.lisp")) + (l1-init "ccl:l1f;l1-init" ("ccl:l1;l1-init.lisp")) + (version "ccl:l1f;version" ("ccl:l1;version.lisp")) + (l1-boot-1 "ccl:l1f;l1-boot-1" ("ccl:l1;l1-boot-1.lisp")) + (l1-boot-2 "ccl:l1f;l1-boot-2" ("ccl:l1;l1-boot-2.lisp")) + (l1-boot-3 "ccl:l1f;l1-boot-3" ("ccl:l1;l1-boot-3.lisp")) + (l1-boot-lds "ccl:l1f;l1-boot-lds" ("ccl:l1;l1-boot-lds.lisp")) + (l1-files "ccl:l1f;l1-files" ("ccl:l1;l1-files.lisp")) + (l1-sort "ccl:l1f;l1-sort" ("ccl:l1;l1-sort.lisp")) + (l1-dcode "ccl:l1f;l1-dcode" ("ccl:l1;l1-dcode.lisp")) + (l1-clos-boot "ccl:l1f;l1-clos-boot" ("ccl:l1;l1-clos-boot.lisp")) + (l1-clos "ccl:l1f;l1-clos" ("ccl:l1;l1-clos.lisp")) + (l1-io "ccl:l1f;l1-io" ("ccl:l1;l1-io.lisp")) + (l1-unicode "ccl:l1f;l1-unicode" ("ccl:l1;l1-unicode.lisp")) + + (l1-streams "ccl:l1f;l1-streams" ("ccl:l1;l1-streams.lisp")) + (l1-events "ccl:l1f;l1-events" ("ccl:l1;l1-events.lisp")) + (ppc-trap-support "ccl:l1f;ppc-trap-support" ("ccl:l1;ppc-trap-support.lisp")) + (x86-trap-support "ccl:l1f;x86-trap-support" ("ccl:l1;x86-trap-support.lisp")) + + (l1-format "ccl:l1f;l1-format" ("ccl:l1;l1-format.lisp")) + (l1-readloop "ccl:l1f;l1-readloop" ("ccl:l1;l1-readloop.lisp")) + (l1-readloop-lds "ccl:l1f;l1-readloop-lds" ("ccl:l1;l1-readloop-lds.lisp")) + (l1-reader "ccl:l1f;l1-reader" ("ccl:l1;l1-reader.lisp")) + (l1-error-system "ccl:l1f;l1-error-system" ("ccl:l1;l1-error-system.lisp")) + (ppc-error-signal "ccl:l1f;ppc-error-signal" ("ccl:l1;ppc-error-signal.lisp")) + (x86-error-signal "ccl:l1f;x86-error-signal" ("ccl:l1;x86-error-signal.lisp")) + (l1-error-signal "ccl:l1f;l1-error-signal" ("ccl:l1;l1-error-signal.lisp")) + (l1-aprims "ccl:l1f;l1-aprims" ("ccl:l1;l1-aprims.lisp")) + (l1-callbacks "ccl:l1f;l1-callbacks" ("ccl:l1;l1-callbacks.lisp")) + (ppc-callback-support "ccl:l1f;ppc-callback-support" ("ccl:l1;ppc-callback-support.lisp")) + (x86-callback-support "ccl:l1f;x86-callback-support" ("ccl:l1;x86-callback-support.lisp")) + (l1-sysio "ccl:l1f;l1-sysio" ("ccl:l1;l1-sysio.lisp")) + (l1-symhash "ccl:l1f;l1-symhash" ("ccl:l1;l1-symhash.lisp")) + (l1-pathnames "ccl:l1f;l1-pathnames" ("ccl:l1;l1-pathnames.lisp")) + (l1-lisp-threads "ccl:l1f;l1-lisp-threads" ("ccl:l1;l1-lisp-threads.lisp")) + (l1-sockets "ccl:l1f;l1-sockets" ("ccl:l1;l1-sockets.lisp")) + (ppc-threads-utils "ccl:l1f;ppc-threads-utils" ("ccl:l1;ppc-threads-utils.lisp")) + (x86-threads-utils "ccl:l1f;x86-threads-utils" ("ccl:l1;x86-threads-utils.lisp")) + (l1-application "ccl:l1f;l1-application" ("ccl:l1;l1-application.lisp")) + (l1-processes "ccl:l1f;l1-processes" ("ccl:l1;l1-processes.lisp")) + + (l1-typesys "ccl:l1f;l1-typesys" ("ccl:l1;l1-typesys.lisp")) + (sysutils "ccl:l1f;sysutils" ("ccl:l1;sysutils.lisp")) + (nx "ccl:l1f;nx" ("ccl:compiler;nx.lisp" + "ccl:compiler;nx0.lisp" + "ccl:compiler;lambda-list.lisp" + "ccl:compiler;nx-basic.lisp" + "ccl:compiler;nx1.lisp")) + (nxenv "ccl:bin;nxenv" ("ccl:compiler;nxenv.lisp")) + (nx2 "ccl:bin;nx2" ("ccl:compiler;nx2.lisp")) + (nx-base-app "ccl:l1f;nx-base-app" ("ccl:compiler;nx-base-app.lisp" + "ccl:compiler;lambda-list.lisp")) + (dll-node "ccl:bin;dll-node" ("ccl:compiler;dll-node.lisp")) + (ppc32-arch "ccl:bin;ppc32-arch" ("ccl:compiler;PPC;PPC32;ppc32-arch.lisp")) + (ppc-arch "ccl:bin;ppc-arch" ("ccl:compiler;PPC;ppc-arch.lisp")) + (x86-arch "ccl:bin;x86-arch" ("ccl:compiler;X86;x86-arch.lisp")) + (ppc64-arch "ccl:bin;ppc64-arch" ("ccl:compiler;PPC;PPC64;ppc64-arch.lisp")) + (x8632-arch "ccl:bin;x8632-arch" ("ccl:compiler;X86;X8632;x8632-arch.lisp")) + (x8664-arch "ccl:bin;x8664-arch" ("ccl:compiler;X86;X8664;x8664-arch.lisp")) + (arch "ccl:bin;arch" ("ccl:compiler;arch.lisp")) + (ppcenv "ccl:bin;ppcenv" ("ccl:lib;ppcenv.lisp")) + (x8664env "ccl:bin;x8664env" ("ccl:lib;x8664env.lisp")) + (x8632env "ccl:bin;x8632env" ("ccl:lib;x8632env.lisp")) + (vreg "ccl:bin;vreg" ("ccl:compiler;vreg.lisp")) + (ppc-asm "ccl:bin;ppc-asm" ("ccl:compiler;PPC;ppc-asm.lisp")) + (x86-asm "ccl:bin;x86-asm" ("ccl:compiler;X86;x86-asm.lisp")) + (vinsn "ccl:bin;vinsn" ("ccl:compiler;vinsn.lisp")) + (ppc32-vinsns "ccl:bin;ppc32-vinsns" ("ccl:compiler;PPC;PPC32;ppc32-vinsns.lisp")) + (ppc64-vinsns "ccl:bin;ppc64-vinsns" ("ccl:compiler;PPC;PPC64;ppc64-vinsns.lisp")) + (x8632-vinsns "ccl:bin;x8632-vinsns" ("ccl:compiler;X86;X8632;x8632-vinsns.lisp")) + (x8664-vinsns "ccl:bin;x8664-vinsns" ("ccl:compiler;X86;X8664;x8664-vinsns.lisp")) + (reg "ccl:bin;reg" ("ccl:compiler;reg.lisp")) + (subprims "ccl:bin;subprims" ("ccl:compiler;subprims.lisp")) + (risc-lap "ccl:bin;risc-lap" ("ccl:compiler;risc-lap.lisp")) + (ppc-lap "ccl:bin;ppc-lap" ("ccl:compiler;PPC;ppc-lap.lisp")) + (x86-lap "ccl:bin;x86-lap" ("ccl:compiler;X86;x86-lap.lisp")) + (backend "ccl:bin;backend" ("ccl:compiler;backend.lisp")) + (ppc32-backend "ccl:bin;ppc32-backend" ("ccl:compiler;PPC;PPC32;ppc32-backend.lisp")) + (ppc64-backend "ccl:bin;ppc64-backend" ("ccl:compiler;PPC;PPC64;ppc64-backend.lisp")) + (ppc-backend "ccl:bin;ppc-backend" ("ccl:compiler;PPC;ppc-backend.lisp")) + (x8632-backend "ccl:bin;x8632-backend" ("ccl:compiler;X86;X8632;x8632-backend.lisp")) + (x8664-backend "ccl:bin;x8664-backend" ("ccl:compiler;X86;X8664;x8664-backend.lisp")) + (x86-backend "ccl:bin;x86-backend" ("ccl:compiler;X86;x86-backend.lisp")) + (ppc2 "ccl:bin;ppc2" ("ccl:compiler;PPC;ppc2.lisp")) + (x862 "ccl:bin;x862" ("ccl:compiler;X86;x862.lisp")) + + (ppc-lapmacros "ccl:bin;ppc-lapmacros" ("ccl:compiler;PPC;ppc-lapmacros.lisp")) + (x86-lapmacros "ccl:bin;x86-lapmacros" ("ccl:compiler;X86;x86-lapmacros.lisp")) + (ppc-disassemble "ccl:bin;ppc-disassemble" ("ccl:compiler;PPC;ppc-disassemble.lisp")) + (x86-disassemble "ccl:bin;x86-disassemble" ("ccl:compiler;X86;x86-disassemble.lisp")) + (xfasload "ccl:xdump;xfasload" ("ccl:xdump;xfasload.lisp")) + (xppcfasload "ccl:xdump;xppcfasload" ("ccl:xdump;xppcfasload.lisp")) + (xx8632fasload "ccl:xdump;xx8632-fasload" ("ccl:xdump;xx8632-fasload.lisp")) + (xx8664fasload "ccl:xdump;xx8664-fasload" ("ccl:xdump;xx8664-fasload.lisp")) + (heap-image "ccl:xdump;heap-image" ("ccl:xdump;heap-image.lisp")) + (xsym "ccl:xdump;xsym" ("ccl:xdump;xsym.lisp")) + (number-macros "ccl:bin;number-macros" ("ccl:lib;number-macros.lisp")) + (number-case-macro "ccl:bin;number-case-macro" ("ccl:lib;number-case-macro.lisp")) + (optimizers "ccl:bin;optimizers" ("ccl:compiler;optimizers.lisp")) + (backquote "ccl:bin;backquote" ("ccl:lib;backquote.lisp")) + (lispequ "ccl:library;lispequ" ("ccl:library;lispequ.lisp")) + (sysequ "ccl:bin;sysequ" ("ccl:lib;sysequ.lisp")) + (toolequ "ccl:bin;toolequ" ("ccl:lib;toolequ.lisp")) + (level-2 "ccl:bin;level-2" ("ccl:lib;level-2.lisp")) + (macros "ccl:bin;macros" ("ccl:lib;macros.lisp")) + (defstruct-macros "ccl:bin;defstruct-macros" ("ccl:lib;defstruct-macros.lisp")) + (foreign-types "ccl:bin;foreign-types" ("ccl:lib;foreign-types.lisp")) + (ffi-linuxppc32 "ccl:bin;ffi-linuxppc32" ("ccl:lib;ffi-linuxppc32.lisp")) + (ffi-darwinppc32 "ccl:bin;ffi-darwinppc32" ("ccl:lib;ffi-darwinppc32.lisp")) + (ffi-darwinppc64 "ccl:bin;ffi-darwinppc64" ("ccl:lib;ffi-darwinppc64.lisp")) + (ffi-linuxppc64 "ccl:bin;ffi-linuxppc64" ("ccl:lib;ffi-linuxppc64.lisp")) + (ffi-darwinx8632 "ccl:bin;ffi-darwinx8632" ("ccl:lib;ffi-darwinx8632.lisp")) + (ffi-linuxx8664 "ccl:bin;ffi-linuxx8664" ("ccl:lib;ffi-linuxx8664.lisp")) + (ffi-darwinx8664 "ccl:bin;ffi-darwinx8664" ("ccl:lib;ffi-darwinx8664.lisp")) + (ffi-freebsdx8664 "ccl:bin;ffi-freebsdx8664" ("ccl:lib;ffi-freebsdx8664.lisp")) + (ffi-solarisx8664 "ccl:bin;ffi-solarisx8664" ("ccl:lib;ffi-solarisx8664.lisp")) + (ffi-win64 "ccl:bin;ffi-win64" ("ccl:lib;ffi-win64.lisp")) + (ffi-linuxx8632 "ccl:bin;ffi-linuxx8632" ("ccl:lib;ffi-linuxx8632.lisp")) + (ffi-win32 "ccl:bin;ffi-win32" ("ccl:lib;ffi-win32.lisp")) + (ffi-solarisx8632 "ccl:bin;ffi-solarisx8632" ("ccl:lib;ffi-solarisx8632.lisp")) + (ffi-freebsdx8632 "ccl:bin;ffi-freebsdx8632" ("ccl:lib;ffi-freebsdx8632.lisp")) + + (db-io "ccl:bin;db-io" ("ccl:lib;db-io.lisp")) + (hash "ccl:bin;hash" ("ccl:lib;hash.lisp")) + (nfcomp "ccl:bin;nfcomp" ("ccl:lib;nfcomp.lisp")) + (lists "ccl:bin;lists" ("ccl:lib;lists.lisp")) + (chars "ccl:bin;chars" ("ccl:lib;chars.lisp")) + (streams "ccl:bin;streams" ("ccl:lib;streams.lisp")) + (pathnames "ccl:bin;pathnames" ("ccl:lib;pathnames.lisp")) + (describe "ccl:bin;describe" ("ccl:lib;describe.lisp")) + (mcl-compat "ccl:bin;mcl-compat" ("ccl:lib;mcl-compat.lisp")) + (backtrace "ccl:bin;backtrace" ("ccl:lib;backtrace.lisp")) + (ppc-backtrace "ccl:bin;ppc-backtrace" ("ccl:lib;ppc-backtrace.lisp")) + (x86-backtrace "ccl:bin;x86-backtrace" ("ccl:lib;x86-backtrace.lisp")) + (x86-watch "ccl:bin;x86-watch" ("ccl:lib;x86-watch.lisp")) + (backtrace-lds "ccl:bin;backtrace-lds" ("ccl:lib;backtrace-lds.lisp")) + (apropos "ccl:bin;apropos" ("ccl:lib;apropos.lisp")) + (numbers "ccl:bin;numbers" ("ccl:lib;numbers.lisp")) + (dumplisp "ccl:bin;dumplisp" ("ccl:lib;dumplisp.lisp")) + (defstruct "ccl:bin;defstruct" ("ccl:lib;defstruct.lisp" + "ccl:lib;defstruct-macros.lisp")) + (defstruct-lds "ccl:bin;defstruct-lds" ("ccl:lib;defstruct-lds.lisp" + "ccl:lib;defstruct-macros.lisp")) + (method-combination + "ccl:bin;method-combination" + ("ccl:lib;method-combination.lisp")) + (encapsulate "ccl:bin;encapsulate" ("ccl:lib;encapsulate.lisp")) + (read "ccl:bin;read" ("ccl:lib;read.lisp")) + (misc "ccl:bin;misc" ("ccl:lib;misc.lisp")) + (arrays-fry "ccl:bin;arrays-fry" ("ccl:lib;arrays-fry.lisp")) + (sequences "ccl:bin;sequences" ("ccl:lib;sequences.lisp")) + (sort "ccl:bin;sort" ("ccl:lib;sort.lisp")) + (setf "ccl:bin;setf" ("ccl:lib;setf.lisp")) + (setf-runtime "ccl:bin;setf-runtime" ("ccl:lib;setf-runtime.lisp")) + (format "ccl:bin;format" ("ccl:lib;format.lisp")) + (case-error "ccl:bin;case-error" ("ccl:lib;case-error.lisp")) + (pprint "ccl:bin;pprint" ("ccl:lib;pprint.lisp")) + (time "ccl:bin;time" ("ccl:lib;time.lisp")) + (print-db "ccl:bin;print-db" ("ccl:lib;print-db.lisp")) +; (eval "ccl:bin;eval" ("ccl:lib;eval.lisp")) + + (arglist "ccl:bin;arglist" ("ccl:lib;arglist.lisp")) + + (edit-callers "ccl:bin;edit-callers" ("ccl:lib;edit-callers.lisp")) + ;; (hash-cons "ccl:library;hash-cons" ("ccl:library;hash-cons.lisp")) + ;; (step "ccl:bin;step" ("ccl:lib;step.lisp")) + (ccl-export-syms "ccl:bin;ccl-export-syms" ("ccl:lib;ccl-export-syms.lisp")) + (systems "ccl:bin;systems" ("ccl:lib;systems.lisp")) + (compile-ccl "ccl:bin;compile-ccl" ("ccl:lib;compile-ccl.lisp")) + (ppc-init-ccl "ccl:bin;ppc-init-ccl" ("ccl:lib;ppc-init-ccl.lisp")) + (distrib-inits "ccl:bin;distrib-inits" ("ccl:lib;distrib-inits.lisp")) + (lisp-package "ccl:library;lisp-package" ("ccl:library;lisp-package.lisp")) + ;; need to add swapping, xdump to CCL's *module-search-path* + (xdump "ccl:xdump;xdump" ("ccl:xdump;xdump.lisp")) + (fasload "ccl:xdump;fasload" ("ccl:xdump;fasload.lisp")) + (loop "ccl:library;loop" ("ccl:library;loop.lisp")) + (linux-files "ccl:l1f;linux-files" ("ccl:level-1;linux-files.lisp")) + (source-files "ccl:bin;source-files" ("ccl:lib;source-files.lisp")) + (cover "ccl:bin;cover" ("ccl:library;cover.lisp")) + (leaks "ccl:bin;leaks" ("ccl:library;leaks.lisp")) + (core-files "ccl:bin;core-files" ("ccl:library;core-files.lisp")) + + (prepare-mcl-environment "ccl:bin;prepare-mcl-environment" ("ccl:lib;prepare-mcl-environment.lisp")) + (defsystem "ccl:tools;defsystem" ("ccl:tools;defsystem.lisp")) + (asdf "ccl:tools;asdf" ("ccl:tools;asdf.lisp")) + (jp-encode "ccl:bin;jp-encode" ("ccl:library;jp-encode.lisp")))) + Index: /branches/new-random/lib/time.lisp =================================================================== --- /branches/new-random/lib/time.lisp (revision 13309) +++ /branches/new-random/lib/time.lisp (revision 13309) @@ -0,0 +1,265 @@ +;;;-*-Mode: LISP; Package: CCL -*- +;;; +;;; Copyright (C) 2009 Clozure Associates +;;; Copyright (C) 1994-2001 Digitool, Inc +;;; This file is part of Clozure CL. +;;; +;;; Clozure CL is licensed under the terms of the Lisp Lesser GNU Public +;;; License , known as the LLGPL and distributed with Clozure CL as the +;;; file "LICENSE". The LLGPL consists of a preamble and the LGPL, +;;; which is distributed with Clozure CL as the file "LGPL". Where these +;;; conflict, the preamble takes precedence. +;;; +;;; Clozure CL is referenced in the preamble as the "LIBRARY." +;;; +;;; The LLGPL is also available online at +;;; http://opensource.franz.com/preamble.html + +(in-package "CCL") + +(eval-when (:compile-toplevel :execute) + (defconstant seconds-in-week (* 60 60 24 7)) + (defconstant weeks-offset 2145) + (defconstant seconds-offset 432000) + (defconstant minutes-per-day (* 24 60)) + (defconstant quarter-days-per-year (1+ (* 365 4))) + (defconstant quarter-days-per-century 146097) + (defconstant november-17-1858 678882) + (defconstant weekday-november-17-1858 2) +) + +(defun gctime () + (let* ((timeval-size (record-length :timeval))) + (%stack-block ((copy (* timeval-size 5))) + (#_memmove copy *total-gc-microseconds* (* timeval-size 5)) + (macrolet ((funk (arg) + (ecase internal-time-units-per-second + (1000000 `(timeval->microseconds ,arg)) + (1000 `(timeval->milliseconds ,arg))))) + (values + (funk copy) + (funk (%incf-ptr copy timeval-size)) + (funk (%incf-ptr copy timeval-size)) + (funk (%incf-ptr copy timeval-size)) + (funk (%incf-ptr copy timeval-size))))))) + + + + +;;; This should stop using #_localtime_r: not all times can be represented +;;; as a signed natural offset from the start of Unix time. +;;; For now, if the time won't fit in a :time_t, use an arbitrary time +;;; value to get the time zone and assume that DST was -not- in effect. +#-windows-target +(defun get-timezone (time) + (let* ((toobig (not (typep time '(signed-byte + #+32-bit-target 32 + #+64-bit-target 64))))) + (when toobig + (setq time 0)) + (rlet ((when :time_t) + (tm :tm)) + (setf (pref when :time_t) time) + (with-macptrs ((ltm (#_localtime_r when tm))) + (if (%null-ptr-p ltm) + (values 0 nil) + (progn + (values (floor #-solaris-target (pref tm :tm.tm_gmtoff) + #+solaris-target #&altzone + -60) + (unless toobig (not (zerop (pref tm :tm.tm_isdst))))))))))) + +#+windows-target +(defun get-timezone (time) + (declare (ignore time)) + (rlet ((tzinfo #>TIME_ZONE_INFORMATION)) + (let* ((id (#_GetTimeZoneInformation tzinfo)) + (minutes-west (pref tzinfo #>TIME_ZONE_INFORMATION.Bias)) + (is-dst (= id #$TIME_ZONE_ID_DAYLIGHT))) + (values (floor (+ minutes-west + (if is-dst + (pref tzinfo #>TIME_ZONE_INFORMATION.DaylightBias) + 0))) + is-dst)))) + + + +(defun decode-universal-time (universal-time &optional time-zone) + "Converts a universal-time to decoded time format returning the following + nine values: second, minute, hour, date, month, year, day of week (0 = + Monday), T (daylight savings time) or NIL (standard time), and timezone. + Completely ignores daylight-savings-time when time-zone is supplied." + (multiple-value-bind (weeks secs) + (truncate (+ universal-time seconds-offset) + seconds-in-week) + (let* ((weeks (+ weeks weeks-offset)) + (second NIL) + (minute NIL) + (hour NIL) + (date NIL) + (month NIL) + (year NIL) + (day NIL) + (daylight NIL) + (timezone (if (null time-zone) + (multiple-value-bind + (minwest dst) + (get-timezone (- universal-time + unix-to-universal-time)) + (setf daylight dst) + minwest) + (* time-zone 60)))) + (declare (fixnum timezone)) + (multiple-value-bind (t1 seconds) (truncate secs 60) + (setq second seconds) + (setq t1 (- t1 timezone)) + (let* ((tday (if (< t1 0) + (1- (truncate (1+ t1) minutes-per-day)) + (truncate t1 minutes-per-day)))) + (multiple-value-setq (hour minute) + (truncate (- t1 (* tday minutes-per-day)) 60)) + (let* ((t2 (1- (* (+ (* weeks 7) tday november-17-1858) 4))) + (tcent (truncate t2 quarter-days-per-century))) + (setq t2 (mod t2 quarter-days-per-century)) + (setq t2 (+ (- t2 (mod t2 4)) 3)) + (setq year (+ (* tcent 100) (truncate t2 quarter-days-per-year))) + (let ((days-since-mar0 (1+ (truncate (mod t2 quarter-days-per-year) + 4)))) + (setq day (mod (+ tday weekday-november-17-1858) 7)) + (let ((t3 (+ (* days-since-mar0 5) 456))) + (cond ((>= t3 1989) + (setq t3 (- t3 1836)) + (setq year (1+ year)))) + (multiple-value-setq (month t3) (truncate t3 153)) + (setq date (1+ (truncate t3 5)))))))) + (values second minute hour date month year day + daylight + (if daylight + (1+ (/ timezone 60)) + (/ timezone 60)))))) + +(defun get-decoded-time () + "Return nine values specifying the current time as follows: + second, minute, hour, date, month, year, day of week (0 = Monday), T + (daylight savings times) or NIL (standard time), and timezone." + (decode-universal-time (get-universal-time))) + +(defun current-year () + (nth-value 5 (get-decoded-time))) + +(defun leap-years-before (year) + (let ((years (- year 1901))) + (+ (- (truncate years 4) + (truncate years 100)) + (truncate (+ years 300) 400)))) + +(defvar *days-before-month* + (let* ((results (list nil))) + (let ((sum 0)) + (dolist (days-per-month '(31 28 31 30 31 30 31 31 30 31 30 31)) + (push sum results) + (incf sum days-per-month))) + (coerce (nreverse results) 'vector))) + +(defun encode-universal-time (second minute hour date month year + &optional time-zone) + "The time values specified in decoded format are converted to + universal time, which is returned." + (declare (type (mod 60) second) + (type (mod 60) minute) + (type (mod 24) hour) + (type (integer 1 31) date) + (type (integer 1 12) month) + (type unsigned-byte year) + (type (or null rational) time-zone)) + (when (< year 100) + (let* ((this (current-year)) + (past (- this 50)) + (future (+ this 49)) + (maybe-past (+ (- past (mod past 100)) year)) + (maybe-future (+ (- future (mod future 100)) year))) + (if (>= maybe-past past) + (setq year maybe-past) + (setq year maybe-future)))) + + (let* ((days (+ (1- date) + (aref *days-before-month* month) + (if (> month 2) + (leap-years-before (1+ year)) + (leap-years-before year)) + (* (- year 1900) 365))) + (hours (+ hour (* days 24)))) + (if time-zone + (+ second (* (+ minute (* (+ hours time-zone) 60)) 60)) + (let* ((minwest-guess + (get-timezone (- (* hours 60 60) + unix-to-universal-time))) + (guess (+ minute (* hours 60) minwest-guess)) + (minwest + (get-timezone (- (* guess 60) + unix-to-universal-time)))) + (+ second (* (+ guess (- minwest minwest-guess)) 60)))))) + + +#+windows-target +(defun %windows-sleep (millis) + (do* ((start (floor (get-internal-real-time) + (floor internal-time-units-per-second 1000)) + (floor (get-internal-real-time) + (floor internal-time-units-per-second 1000))) + (millis millis (- stop start)) + (stop (+ start millis))) + ((or (<= millis 0) + (not (eql (#_SleepEx millis #$true) #$WAIT_IO_COMPLETION)))))) + +(defun sleep (seconds) + "This function causes execution to be suspended for N seconds. N may + be any non-negative, non-complex number." + (when (minusp seconds) (report-bad-arg seconds '(real 0 *))) + #-windows-target + (multiple-value-bind (secs nanos) + (nanoseconds seconds) + (%nanosleep secs nanos)) + #+windows-target + (%windows-sleep (round (* seconds 1000)))) + + +(defun %internal-run-time () + ;; Returns user and system times in internal-time-units as multiple values. + #-windows-target + (rlet ((usage :rusage)) + (%%rusage usage) + (let* ((user-seconds (pref usage :rusage.ru_utime.tv_sec)) + (system-seconds (pref usage :rusage.ru_stime.tv_sec)) + (user-micros (pref usage :rusage.ru_utime.tv_usec)) + (system-micros (pref usage :rusage.ru_stime.tv_usec))) + (values (+ (* user-seconds internal-time-units-per-second) + (round user-micros (floor 1000000 internal-time-units-per-second))) + (+ (* system-seconds internal-time-units-per-second) + (round system-micros (floor 1000000 internal-time-units-per-second)))))) + #+windows-target + (rlet ((start #>FILETIME) + (end #>FILETIME) + (kernel #>FILETIME) + (user #>FILETIME)) + (#_GetProcessTimes (#_GetCurrentProcess) start end kernel user) + (let* ((user-100ns (dpb (pref user #>FILETIME.dwHighDateTime) + (byte 32 32) + (pref user #>FILETIME.dwLowDateTime))) + (kernel-100ns (dpb (pref kernel #>FILETIME.dwHighDateTime) + (byte 32 32) + (pref kernel #>FILETIME.dwLowDateTime))) + (convert (floor 10000000 internal-time-units-per-second))) + (values (floor user-100ns convert) (floor kernel-100ns convert))))) + +(defun get-internal-run-time () + "Return the run time in the internal time format. (See + INTERNAL-TIME-UNITS-PER-SECOND.) This is useful for finding CPU usage." + (multiple-value-bind (user sys) (%internal-run-time) + (+ user sys))) + + + + + + Index: /branches/new-random/lib/x86-backtrace.lisp =================================================================== --- /branches/new-random/lib/x86-backtrace.lisp (revision 13309) +++ /branches/new-random/lib/x86-backtrace.lisp (revision 13309) @@ -0,0 +1,460 @@ +;;;-*-Mode: LISP; Package: CCL -*- +;;; +;;; Copyright (C) 2006-2009 Clozure Associates and contributors +;;; This file is part of Clozure CL. +;;; +;;; Clozure CL is licensed under the terms of the Lisp Lesser GNU Public +;;; License , known as the LLGPL and distributed with Clozure CL as the +;;; file "LICENSE". The LLGPL consists of a preamble and the LGPL, +;;; which is distributed with Clozure CL as the file "LGPL". Where these +;;; conflict, the preamble takes precedence. +;;; +;;; Clozure CL is referenced in the preamble as the "LIBRARY." +;;; +;;; The LLGPL is also available online at +;;; http://opensource.franz.com/preamble.html + + +(in-package "CCL") + + +;;; Returns two values: +;;; [nil, nil] if it can be reliably determined that function uses no registers at PC +;;; [mask, saved-location] if it can be reliably determined that the registers specified by "mask" +;;; were saved at "saved-location" in the function's stack frame +;;; [mask, nil] if registers in "mask" MAY have been saved, but we don't know how to restore them +;;; (perhaps because the "at-pc" argument wasn't specified. + + +(defun registers-used-by (function &optional at-pc) + (multiple-value-bind (mask stack-location rpc) + (%function-register-usage function) + (if (or (null mask) + (and at-pc rpc (<= at-pc rpc))) + (values nil nil) + (values (canonicalize-register-mask mask) (if (and at-pc rpc) stack-location))))) + +(defun canonicalize-register-mask (mask) + (dpb (ldb (byte 2 14) mask) (byte 2 2) (ldb (byte 2 11) mask))) + +(defun xcf-p (p) + (eql 0 (%fixnum-ref p target::lisp-frame.return-address))) + +(defun %current-xcf () + (do* ((q (%get-frame-ptr) (%%frame-backlink q))) + ((zerop q)) + (declare (fixnum q)) + (when (xcf-p q) (return q)))) + +;;; Try to determine the program counter value, relative to an xcf's nominal function. +(defun pc-from-xcf (xcf) + (let* ((nominal-function (%fixnum-ref xcf target::xcf.nominal-function)) + (containing-object (%fixnum-ref xcf target::xcf.containing-object))) + (when (typep nominal-function 'function) + (if (eq containing-object (function-to-function-vector nominal-function)) + (- (%fixnum-ref xcf target::xcf.relative-pc) + #+x8632-target x8632::fulltag-misc + #+x8664-target x8664::tag-function) + (let* ((tra (%fixnum-ref xcf target::xcf.ra0))) + (if (and #+x8664-target (= (lisptag tra) x8664::tag-tra) + #+x8632-target (= (fulltag tra) x8632::fulltag-tra) + (eq nominal-function (%return-address-function tra))) + (%return-address-offset tra))))))) + +(defun cfp-lfun (p) + (if (xcf-p p) + (values + (%fixnum-ref p target::xcf.nominal-function) + (pc-from-xcf p)) + (%cfp-lfun p))) + +;;; On PPC, some frames on the control stack are associated with catch +;;; frames rather than with function calls. The whole concept doesn't +;;; really apply here (e.g., nothing we encounter while walking frame +;;; pointer links belongs to a catch frame.) +(defun catch-csp-p (p context) + (declare (ignore p context))) + +(defun %raw-frame-ref (frame context idx bad) + (declare (fixnum frame idx)) + (let* ((base (parent-frame frame context)) + (raw-size (- base frame))) + (declare (fixnum base raw-size)) + (if (and (>= idx 0) + (< idx raw-size)) + (let* ((addr (- (the fixnum (1- base)) + idx))) + (multiple-value-bind (db-count first-db last-db) + (count-db-links-in-frame frame base context) + (let* ((is-db-link + (unless (zerop db-count) + (do* ((last last-db (previous-db-link last first-db))) + ((null last)) + (when (= addr last) + (return t)))))) + (if is-db-link + (oldest-binding-frame-value context addr) + (%fixnum-ref addr))))) + bad))) + +(defun %raw-frame-set (frame context idx new) + (declare (fixnum frame idx)) + (let* ((base (parent-frame frame context)) + (raw-size (- base frame))) + (declare (fixnum base raw-size)) + (if (and (>= idx 0) + (< idx raw-size)) + (let* ((addr (- (the fixnum (1- base)) + idx))) + (multiple-value-bind (db-count first-db last-db) + (count-db-links-in-frame frame base context) + (let* ((is-db-link + (unless (zerop db-count) + (do* ((last last-db (previous-db-link last first-db))) + ((null last)) + (when (= addr last) + (return t)))))) + (if is-db-link + (setf (oldest-binding-frame-value context addr) new) + (setf (%fixnum-ref addr) new)))))))) + +(defun %stack< (index1 index2 &optional context) + (let* ((tcr (if context (bt.tcr context) (%current-tcr))) + (vs-area (%fixnum-ref tcr target::tcr.vs-area))) + (and (%ptr-in-area-p index1 vs-area) + (%ptr-in-area-p index2 vs-area) + (< (the fixnum index1) (the fixnum index2))))) + + + + +(defun register-number->saved-register-index (regnum) + (ecase regnum + (#.x8664::save3 0) + (#.x8664::save2 1) + (#.x8664::save1 2) + (#.x8664::save0 3))) + + +(defun get-register-value (address last-catch index) + (if address + (%fixnum-ref address) + (uvref last-catch (+ index + #+x8632-target + x8632::catch-frame.db-link-cell + #+x8664-target + x8664::catch-frame.save-save3-cell)))) + +;;; Inverse of get-register-value + +(defun set-register-value (value address last-catch index) + (if address + (%fixnum-set address value) + (setf (uvref last-catch (+ index + #+x8632-target + x8632::catch-frame.db-link-cell + #+x8664-target + x8664::catch-frame.save-save3-cell)) + value))) + +(defun %find-register-argument-value (context cfp regval bad) + (let* ((last-catch (last-catch-since cfp context)) + (index (register-number->saved-register-index regval))) + (do* ((frame cfp (child-frame frame context)) + (first t)) + ((null frame)) + (if (xcf-p frame) + (with-macptrs (xp) + (%setf-macptr-to-object xp (%fixnum-ref frame x8664::xcf.xp)) + (return-from %find-register-argument-value + (encoded-gpr-lisp xp regval))) + (progn + (unless first + (multiple-value-bind (lfun pc) + (cfp-lfun frame) + (when lfun + (multiple-value-bind (mask where) + (registers-used-by lfun pc) + (when (if mask (logbitp index mask)) + (return-from %find-register-argument-value + (if where + (let ((offset (logcount (logandc2 mask (1- (ash 1 (1+ index))))))) + (raw-frame-ref frame context (+ where offset) bad)) + bad))))))) + (setq first nil)))) + (get-register-value nil last-catch index))) + +(defun %set-register-argument-value (context cfp regval new) + (let* ((last-catch (last-catch-since cfp context)) + (index (register-number->saved-register-index regval))) + (do* ((frame cfp (child-frame frame context)) + (first t)) + ((null frame)) + (if (xcf-p frame) + (with-macptrs (xp) + (%setf-macptr-to-object xp (%fixnum-ref frame x8664::xcf.xp)) + (return-from %set-register-argument-value + (setf (encoded-gpr-lisp xp regval) new))) + (progn + (unless first + (multiple-value-bind (lfun pc) + (cfp-lfun frame) + (when lfun + (multiple-value-bind (mask where) + (registers-used-by lfun pc) + (when (if mask (logbitp index mask)) + (incf where (logcount (logandc2 mask (1- (ash 1 (1+ index)))))) + + (return-from %set-register-argument-value + (raw-frame-set frame context where new))))))) + (setq first nil)))) + (set-register-value new nil last-catch index))) + +;;; Used for printing only. +(defun index->address (p) + (ldb (byte #+32-bit-target 32 #+64-bit-target 64 0) (ash p target::fixnumshift))) + +(defun exception-frame-p (x) + (and x (xcf-p x))) + +;;; Function has failed a number-of-arguments check; return a list +;;; of the actual arguments. +;;; On x86-64, the kernel has finished the frame and pushed everything +;;; for us, so all that we need to do is to hide any inherited arguments. +(defun arg-check-call-arguments (fp function) + (when (xcf-p fp) + (with-macptrs (xp) + (%setf-macptr-to-object xp (%fixnum-ref fp target::xcf.xp)) + (let* ((numinh (ldb $lfbits-numinh (lfun-bits function))) + (nargs (- (xp-argument-count xp) numinh)) + (p (- (%fixnum-ref fp target::xcf.backptr) + (* target::node-size numinh)))) + (declare (fixnum numinh nargs p)) + (collect ((args)) + (dotimes (i nargs (args)) + (args (%fixnum-ref p (- target::node-size))) + (decf p))))))) + +(defun vsp-limits (frame context) + (let* ((parent (parent-frame frame context))) + (if (xcf-p frame) + (values (+ frame (ash target::xcf.size (- target::word-shift))) + parent) + (let* ((tra (%fixnum-ref frame target::lisp-frame.return-address))) + (values (+ frame 2 (if (eq tra (%get-kernel-global ret1valaddr)) 1 0)) + parent))))) + +(defun last-catch-since (fp context) + (let* ((tcr (if context (bt.tcr context) (%current-tcr))) + (catch (%catch-top tcr)) + (last-catch nil)) + (loop + (unless catch (return last-catch)) + (let ((catch-fp (uvref catch + #+x8632-target + x8632::catch-frame.ebp-cell + #+x8664-target + x8664::catch-frame.rbp-cell))) + (when (%stack< fp catch-fp context) (return last-catch)) + (setq last-catch catch + catch (next-catch catch)))))) + +(defun last-xcf-since (target-fp start-fp context) + (do* ((last-xcf nil) + (fp start-fp (parent-frame fp context))) + ((or (eql fp target-fp) + (null fp) + (%stack< target-fp fp)) last-xcf) + (if (xcf-p fp) (setq last-xcf fp)))) + +(defun match-local-name (cellno info pc) + (when info + (let* ((syms (%car info)) + (ptrs (%cdr info))) + (dotimes (i (length syms)) + (let ((j (%i+ i (%i+ i i )))) + (and (eq (uvref ptrs j) (%ilogior (%ilsl (+ 6 target::word-shift) cellno) #o77)) + (%i>= pc (uvref ptrs (%i+ j 1))) + (%i< pc (uvref ptrs (%i+ j 2))) + (return (aref syms i)))))))) + +(defun apply-in-frame (frame function arglist &optional context) + (setq function (coerce-to-function function)) + (let* ((parent (parent-frame frame context))) + (when parent + (if (xcf-p parent) + (error "Can't unwind to exception frame ~s" frame) + (setq frame parent)) + (if (or (null context) + (eq (bt.tcr context) (%current-tcr))) + (%apply-in-frame frame function arglist) + (let* ((process (tcr->process (bt.tcr context)))) + (if process + (process-interrupt process #'%apply-in-frame frame function arglist) + (error "Can't find process for backtrace context ~s" context))))))) + +(defun return-from-frame (frame &rest values) + (apply-in-frame frame #'values values nil)) + + +(defun last-tsp-before (target) + (declare (fixnum target)) + (do* ((tsp (%fixnum-ref (%current-tcr) target::tcr.save-tsp) + (%fixnum-ref tsp target::tsp-frame.backptr))) + ((zerop tsp) nil) + (declare (fixnum tsp)) + (when (> (the fixnum (%fixnum-ref tsp #+x8632-target x8632::tsp-frame.ebp + #+x8664-target x8664::tsp-frame.rbp)) + target) + (return tsp)))) + + + + +;;; We can't determine this reliably (yet). +(defun last-foreign-sp-before (target) + (declare (fixnum target)) + (do* ((cfp (%fixnum-ref (%current-tcr) target::tcr.foreign-sp) + (%fixnum-ref cfp target::csp-frame.backptr))) + ((zerop cfp)) + (declare (fixnum cfp)) + (let* ((rbp (%fixnum-ref cfp #+x8632-target x8632::csp-frame.ebp + #+x8664-target x8664::csp-frame.rbp))) + (declare (fixnum rbp)) + (if (> rbp target) + (return cfp) + (if (zerop rbp) + (return nil)))))) + + +(defun %tsp-frame-containing-progv-binding (db) + (declare (fixnum db)) + (do* ((tsp (%fixnum-ref (%current-tcr) target::tcr.save-tsp) next) + (next (%fixnum-ref tsp target::tsp-frame.backptr) + (%fixnum-ref tsp target::tsp-frame.backptr))) + () + (declare (fixnum tsp next)) + (let* ((rbp (%fixnum-ref tsp #+x8632-target x8632::tsp-frame.ebp + #+x8664-target x8664::tsp-frame.rbp))) + (declare (fixnum rbp)) + (if (zerop rbp) + (return (values nil nil)) + (if (and (> db tsp) + (< db next)) + (return (values tsp rbp))))))) + + + + + + +(defun last-binding-before (frame) + (declare (fixnum frame)) + (do* ((db (%current-db-link) (%fixnum-ref db 0)) + (tcr (%current-tcr)) + (vs-area (%fixnum-ref tcr target::tcr.vs-area)) + (vs-low (%fixnum-ref vs-area target::area.low)) + (vs-high (%fixnum-ref vs-area target::area.high))) + ((eql db 0) nil) + (declare (fixnum db vs-low vs-high)) + (if (and (> db vs-low) + (< db vs-high)) + (if (> db frame) + (return db)) + ;; db link points elsewhere; PROGV uses the temp stack + ;; to store an indefinite number of bindings. + (multiple-value-bind (tsp rbp) + (%tsp-frame-containing-progv-binding db) + (if tsp + (if (> rbp frame) + (return db) + ;; If the tsp frame is too young, we can skip + ;; all of the bindings it contains. The tsp + ;; frame contains two words of overhead, followed + ;; by a count of binding records in the frame, + ;; followed by the youngest of "count" binding + ;; records (which happens to be the value of + ;; "db".) Skip "count" binding records. + (dotimes (i (the fixnum (%fixnum-ref tsp target::dnode-size))) + (setq db (%fixnum-ref db 0)))) + ;; If the binding record wasn't on the temp stack and wasn't + ;; on the value stack, that probably means that things are + ;; seriously screwed up. This error will be almost + ;; meaningless to the user. + (error "binding record (#x~16,'0x/#x~16,'0x) not on temp or value stack" (index->address db) db)))))) + + + +(defun find-x8664-saved-nvrs (frame start-fp context) + (let* ((locations (make-array 16 :initial-element nil)) + (need (logior (ash 1 x8664::save0) + (ash 1 x8664::save1) + (ash 1 x8664::save2) + (ash 1 x8664::save3)))) + (declare (fixnum need) + (dynamic-extent locations)) + (do* ((parent frame child) + (child (child-frame parent context) (child-frame child context))) + ((or (= need 0) (eq child start-fp)) + (values (%svref locations x8664::save0) + (%svref locations x8664::save1) + (%svref locations x8664::save2) + (%svref locations x8664::save3))) + (multiple-value-bind (lfun pc) (cfp-lfun child) + (when (and lfun pc) + (multiple-value-bind (used where) (registers-used-by lfun pc) + (when (and used where (logtest used need)) + (locally (declare (fixnum used)) + (do* ((i x8664::save3 (1+ i))) + ((or (= i 16) (= used 0))) + (declare (type (mod 16) i)) + (when (logbitp i used) + (when (logbitp i need) + (setq need (logandc2 need (ash 1 i))) + (setf (%svref locations i) + (- (the fixnum (1- parent)) + (+ where (logcount (logandc2 used (1+ (ash 1 (1+ i))))))))) + (setq used (logandc2 used (ash 1 i))))))))))))) + + + +(defun %apply-in-frame (frame function arglist) + (target-arch-case + (:x8632 (error "%apply-in-frame doesn't work for x8632 yet")) + (:x8664 + (let* ((target-catch (last-catch-since frame nil)) + (start-fp (if target-catch + (uvref target-catch x8664::catch-frame.rbp-cell) + (%get-frame-ptr))) + (target-xcf (last-xcf-since frame start-fp nil)) + (target-db-link (last-binding-before frame)) + (target-tsp (last-tsp-before frame)) + (target-foreign-sp (last-foreign-sp-before frame))) + (multiple-value-bind (save0-loc save1-loc save2-loc save3-loc) + (find-x8664-saved-nvrs frame start-fp nil) + (let* ((thunk (%clone-x86-function #'%%apply-in-frame-proto + frame + target-catch + target-db-link + target-xcf + target-tsp + target-foreign-sp + (if save0-loc + (- save0-loc frame) + 0) + (if save1-loc + (- save1-loc frame) + 0) + (if save2-loc + (- save2-loc frame) + 0) + (if save3-loc + (- save3-loc frame) + 0) + (coerce-to-function function) + arglist + 0))) + (funcall thunk))))))) + + + Index: /branches/new-random/lib/x86-watch.lisp =================================================================== --- /branches/new-random/lib/x86-watch.lisp (revision 13309) +++ /branches/new-random/lib/x86-watch.lisp (revision 13309) @@ -0,0 +1,87 @@ +;;; Copyright 2009 Clozure Associates +;;; This file is part of Clozure CL. +;;; +;;; Clozure CL is licensed under the terms of the Lisp Lesser GNU +;;; Public License , known as the LLGPL and distributed with Clozure +;;; CL as the file "LICENSE". The LLGPL consists of a preamble and +;;; the LGPL, which is distributed with Clozure CL as the file "LGPL". +;;; Where these conflict, the preamble takes precedence. +;;; +;;; Clozure CL is referenced in the preamble as the "LIBRARY." +;;; +;;; The LLGPL is also available online at +;;; http://opensource.franz.com/preamble.html + +(in-package "CCL") + +;;; Return the effective address of a memory operand by using the +;;; register state in xp, or NIL if we can't figure it out. +;;; Needs to run inside a without-gcing form. +(defun x86-memory-operand-ea (xp op) + (let* ((seg (x86::x86-memory-operand-seg op)) + (disp (x86::x86-memory-operand-disp op)) + (base (x86::x86-memory-operand-base op)) + (index (x86::x86-memory-operand-index op)) + (scale (x86::x86-memory-operand-scale op))) + (cond + ((and base index (not seg)) + (let* ((base-re (x86::x86-register-operand-entry base)) + (index-re (x86::x86-register-operand-entry index)) + (base-num (x86::reg-entry-reg-num base-re)) + (index-num (x86::reg-entry-reg-num index-re)) + (base-val nil) + (index-val nil)) + (when (logtest (x86::reg-entry-reg-flags base-re) x86::+regrex+) + (incf base-num 8)) + (setq base-val (encoded-gpr-integer xp base-num)) + (when (logtest (x86::reg-entry-reg-flags index-re) x86::+regrex+) + (incf index-num 8)) + (setq index-val (encoded-gpr-integer xp index-num)) + (when scale + (setq index-val (ash index-val scale))) + (+ (or disp 0) base-val index-val)))))) + +;;; Try to emulate the disassembled instruction using the +;;; register state in xp. Return NIL if we couldn't do it. +;;; This will run with other threads suspended. +(defun x86-emulate-instruction (xp instruction) + (let* ((mnemonic (x86-di-mnemonic instruction)) + (op0 (x86-di-op0 instruction)) + (op1 (x86-di-op1 instruction)) + (op2 (x86-di-op2 instruction))) + (when (and op0 op1 (not op2) + (typep op0 'x86::x86-register-operand) + (typep op1 'x86::x86-memory-operand)) + (without-gcing + (let* ((src-re (x86::x86-register-operand-entry op0)) + (src-num (x86::reg-entry-reg-num src-re)) + (src-val nil) + (ea (x86-memory-operand-ea xp op1))) + (when (logtest (x86::reg-entry-reg-flags src-re) x86::+regrex+) + (incf src-num 8)) + (setq src-val (encoded-gpr-integer xp src-num)) + (when ea + (with-macptrs ((p (%int-to-ptr ea))) + (cond + ((string= mnemonic "movb") + (setf (%get-signed-byte p) (ldb (byte 8 0) src-val))) + ((string= mnemonic "movw") + (setf (%get-signed-word p) (ldb (byte 16 0) src-val))) + ((string= mnemonic "movl") + (setf (%get-signed-long p) (ldb (byte 32 0) src-val))) + ((string= mnemonic "movq") + (setf (%%get-signed-longlong p 0) (ldb (byte 64 0) src-val))))))))))) + +(defun x86-can-emulate-instruction (instruction) + (let* ((mnemonic (x86-di-mnemonic instruction)) + (op0 (x86-di-op0 instruction)) + (op1 (x86-di-op1 instruction)) + (op2 (x86-di-op2 instruction))) + (when (and op0 op1 (not op2) + (typep op0 'x86::x86-register-operand) + (typep op1 'x86::x86-memory-operand) + (member mnemonic '("movb" "movw" "movl" "movq") :test 'string=)) + (let* ((seg (x86::x86-memory-operand-seg op1)) + (base (x86::x86-memory-operand-base op1)) + (index (x86::x86-memory-operand-index op1))) + (and base index (not seg)))))) Index: /branches/new-random/lib/x8632env.lisp =================================================================== --- /branches/new-random/lib/x8632env.lisp (revision 13309) +++ /branches/new-random/lib/x8632env.lisp (revision 13309) @@ -0,0 +1,71 @@ +; -*- Mode:Lisp; Package:CCL; -*- +;;; +;;; Copyright (C) 2005-2009 Clozure Associates +;;; This file is part of Clozure CL. +;;; +;;; Clozure CL is licensed under the terms of the Lisp Lesser GNU Public +;;; License , known as the LLGPL and distributed with Clozure CL as the +;;; file "LICENSE". The LLGPL consists of a preamble and the LGPL, +;;; which is distributed with Clozure CL as the file "LGPL". Where these +;;; conflict, the preamble takes precedence. +;;; +;;; Clozure CL is referenced in the preamble as the "LIBRARY." +;;; +;;; The LLGPL is also available online at +;;; http://opensource.franz.com/preamble.html + +(in-package "CCL") + +(defconstant $numx8632saveregs 0) +(defconstant $numx8632argregs 2) + + +(defconstant x8632-nonvolatile-registers-mask 0) + +(defconstant x8632-arg-registers-mask + (logior (ash 1 x8632::arg_z) + (ash 1 x8632::arg_y))) + +(defconstant x8632-temp-registers-mask + (logior (ash 1 x8632::temp0) + (ash 1 x8632::temp1))) + +(defconstant x8632-tagged-registers-mask + (logior x8632-temp-registers-mask + x8632-arg-registers-mask + x8632-nonvolatile-registers-mask)) + + + +(defconstant x8632-temp-node-regs + (make-mask x8632::temp0 + x8632::temp1 + x8632::arg_y + x8632::arg_z)) + +(defconstant x8632-nonvolatile-node-regs 0) + +(defconstant x8632-node-regs (logior x8632-temp-node-regs x8632-nonvolatile-node-regs)) + +(defconstant x8632-imm-regs (make-mask + x8632::imm0)) + +;;; Fine if we assume SSE support; not so hot when using x87 +(defconstant x8632-temp-fp-regs (make-mask x8632::fp0 + x8632::fp1 + x8632::fp2 + x8632::fp3 + x8632::fp4 + x8632::fp5 + x8632::fp6 + x8632::fp7)) + + + +(defconstant x8632-cr-fields (make-mask 0)) + +;;; hmm. +(defconstant $undo-x86-c-frame 16) + + +(ccl::provide "X8632ENV") Index: /branches/new-random/lib/x8664env.lisp =================================================================== --- /branches/new-random/lib/x8664env.lisp (revision 13309) +++ /branches/new-random/lib/x8664env.lisp (revision 13309) @@ -0,0 +1,84 @@ +; -*- Mode:Lisp; Package:CCL; -*- +;;; +;;; Copyright (C) 2005-2009 Clozure Associates +;;; This file is part of Clozure CL. +;;; +;;; Clozure CL is licensed under the terms of the Lisp Lesser GNU Public +;;; License , known as the LLGPL and distributed with Clozure CL as the +;;; file "LICENSE". The LLGPL consists of a preamble and the LGPL, +;;; which is distributed with Clozure CL as the file "LGPL". Where these +;;; conflict, the preamble takes precedence. +;;; +;;; Clozure CL is referenced in the preamble as the "LIBRARY." +;;; +;;; The LLGPL is also available online at +;;; http://opensource.franz.com/preamble.html + +(in-package "CCL") + +(defconstant $numx8664saveregs 4) +(defconstant $numx8664argregs 3) + + +(defconstant x8664-nonvolatile-registers-mask + (logior (ash 1 x8664::save0) + (ash 1 x8664::save1) + (ash 1 x8664::save2) + (ash 1 x8664::save3))) + +(defconstant x8664-arg-registers-mask + (logior (ash 1 x8664::arg_z) + (ash 1 x8664::arg_y) + (ash 1 x8664::arg_x))) + +(defconstant x8664-temp-registers-mask + (logior (ash 1 x8664::temp0) + (ash 1 x8664::temp1) + (ash 1 x8664::temp2))) + + +(defconstant x8664-tagged-registers-mask + (logior x8664-temp-registers-mask + x8664-arg-registers-mask + x8664-nonvolatile-registers-mask)) + + +(defconstant x8664-temp-node-regs + (make-mask x8664::temp0 + x8664::temp1 + x8664::temp2 + x8664::arg_x + x8664::arg_y + x8664::arg_z)) + +(defconstant x8664-nonvolatile-node-regs + (make-mask x8664::save0 + x8664::save1 + x8664::save2 + x8664::save3)) + + +(defconstant x8664-node-regs (logior x8664-temp-node-regs x8664-nonvolatile-node-regs)) + +(defconstant x8664-imm-regs (make-mask + x8664::imm0 + x8664::imm1 + x8664::imm2)) + +(defconstant x8664-temp-fp-regs (make-mask x8664::fp0 + x8664::fp1 + x8664::fp2 + x8664::fp3 + x8664::fp4 + x8664::fp5 + x8664::fp6 + x8664::fp7)) + + + +(defconstant x8664-cr-fields (make-mask 0)) + +(defconstant $undo-x86-c-frame 16) + + +(ccl::provide "X8664ENV") Index: /branches/new-random/lib/xref.lisp =================================================================== --- /branches/new-random/lib/xref.lisp (revision 13309) +++ /branches/new-random/lib/xref.lisp (revision 13309) @@ -0,0 +1,659 @@ +;;; -*- Mode: Lisp; Package: CCL; indent-tabs-mode: nil -*- +;;; +;;; Copyright (C) 2003 Oliver Markovic +;;; This file is part of Clozure CL. +;;; +;;; Clozure CL is licensed under the terms of the Lisp Lesser GNU Public +;;; License , known as the LLGPL and distributed with Clozure CL as the +;;; file "LICENSE". The LLGPL consists of a preamble and the LGPL, +;;; which is distributed with Clozure CL as the file "LGPL". Where these +;;; conflict, the preamble takes precedence. +;;; +;;; Clozure CL is referenced in the preamble as the "LIBRARY." +;;; +;;; The LLGPL is also available online at +;;; http://opensource.franz.com/preamble.html + +(in-package "CCL") + +(eval-when (:compile-toplevel :load-toplevel :execute) + (export '(*RECORD-XREF-INFO* + *LOAD-XREF-INFO* + XREF-ENTRY + XREF-ENTRY-NAME + XREF-ENTRY-TYPE + XREF-ENTRY-FULL-NAME + XREF-ENTRY-METHOD-QUALIFIERS + XREF-ENTRY-METHOD-SPECIALIZERS + XREF-ENTRY-P + XREF-ENTRY-EQUAL + DISCARD-ALL-XREF-INFO + GET-RELATION + MACROS-CALLED-BY + START-XREF + STOP-XREF + WHO-BINDS + WHO-CALLS + WHO-DIRECTLY-CALLS + WHO-INDIRECTLY-CALLS + WHO-REFERENCES + WHO-SETS + WHO-USES + WITH-XREF + XREF-DESCRIBE))) + +(defpackage "CROSS-REFERENCE" + (:use "CL") + (:nicknames "XREF") + (:import-from "CCL" + "*RECORD-XREF-INFO*" + "*LOAD-XREF-INFO*" + "XREF-ENTRY" + "XREF-ENTRY-NAME" + "XREF-ENTRY-TYPE" + "XREF-ENTRY-FULL-NAME" + "XREF-ENTRY-METHOD-QUALIFIERS" + "XREF-ENTRY-METHOD-SPECIALIZERS" + "XREF-ENTRY-P" + "XREF-ENTRY-EQUAL" + "DISCARD-ALL-XREF-INFO" + "GET-RELATION" + "MACROS-CALLED-BY" + "START-XREF" + "STOP-XREF" + "WHO-BINDS" + "WHO-CALLS" + "WHO-DIRECTLY-CALLS" + "WHO-INDIRECTLY-CALLS" + "WHO-REFERENCES" + "WHO-SETS" + "WHO-USES" + "WITH-XREF" + "XREF-DESCRIBE") + (:export "*RECORD-XREF-INFO*" + "*LOAD-XREF-INFO*" + "XREF-ENTRY" + "XREF-ENTRY-NAME" + "XREF-ENTRY-TYPE" + "XREF-ENTRY-FULL-NAME" + "XREF-ENTRY-METHOD-QUALIFIERS" + "XREF-ENTRY-METHOD-SPECIALIZERS" + "XREF-ENTRY-P" + "XREF-ENTRY-EQUAL" + "DISCARD-ALL-XREF-INFO" + "GET-RELATION" + "MACROS-CALLED-BY" + "START-XREF" + "STOP-XREF" + "WHO-BINDS" + "WHO-CALLS" + "WHO-DIRECTLY-CALLS" + "WHO-INDIRECTLY-CALLS" + "WHO-REFERENCES" + "WHO-SETS" + "WHO-USES" + "WITH-XREF" + "XREF-DESCRIBE")) + + +;; *RECORD-XREF-INFO* -- external +;; +;; Cross-referencing information will only be recorded if this flag +;; is set. It is usually set/unset by START-XREF/STOP-XREF +(defvar *record-xref-info* nil + "Flag indicating wether cross-referencing information should be recorded.") + +;; *LOAD-XREF-INFO* -- external +;; +;; FIXME: We don't save any information yet... +(defvar *load-xref-info* nil + "Flag indicating wether cross-referencing information should be loaded +from FASLs.") + + + +;; START-XREF -- external +;; +(defun start-xref () + "Start recording cross-referencing information while compiling." + (setf *record-xref-info* t) + (setf *load-xref-info* t) + t) + +;; STOP-XREF -- external +;; +(defun stop-xref () + "Stop recording cross-referencing information while compiling." + (setf *record-xref-info* nil) + (setf *load-xref-info* nil) + nil) + +;; WITH-XREF -- external +;; +(defmacro with-xref (&body body) + "Execute BODY with cross-referencing turned on." + (let ((return-value (gensym "RETURN-VALUE"))) + `(let ((*record-xref-info* t) + (*load-xref-info* t) + (,return-value nil)) + (setf ,return-value (progn ,@body)) + ,return-value))) + + +;; XREF-ENTRY -- external +;; +(defstruct (xref-entry + (:constructor %make-xref-entry) + (:print-function %print-xref-entry)) + name + type + (method-qualifiers nil) + (method-specializers nil)) + +;; %PRINT-XREF-ENTRY -- internal +;; +(defun %print-xref-entry (struct stream d) + (declare (ignore d)) + (if *print-readably* + (format stream "#S(xref::xref-entry :name '~A :type '~A :method-qualifiers ~A :method-specializers ~A)" + (xref-entry-name struct) + (xref-entry-type struct) + (xref-entry-method-qualifiers struct) + (xref-entry-method-specializers struct)) + (print-unreadable-object (struct stream :type t) + (format stream "~A ~A~@[ ~A~]~@[ ~A~]" + (xref-entry-name struct) + (xref-entry-type struct) + (xref-entry-method-qualifiers struct) + (xref-entry-method-specializers struct))))) + +;; MAKE-XREF-ENTRY -- internal +;; +;; Takes a simple input form and makes a XREF-ENTRY from it. The input is +;; assumed to be a function, macro or variable when a simple symbol is passed, +;; or a method when it is a cons. Since this needs to also handle the ouput +;; from CCL::CALLERS, there is additional hackery trying to do the right thing. +(defun make-xref-entry (input relation) + (etypecase input + (symbol + (let ((type (ecase relation + ((:direct-calls :indirect-calls) 'function) + ((:binds :sets :references) 'variable) + ((:macro-calls) 'macro)))) + (%make-xref-entry :name input :type type))) + (method + (let ((name (method-name input)) + (qualifiers (method-qualifiers input)) + (specializers (canonicalize-specializers (method-specializers input)))) + (%make-xref-entry :name name :type 'method + :method-qualifiers (unless (eql qualifiers t) qualifiers) + :method-specializers specializers))) + (cons + (case (car input) + ((ppc-lap-macro compiler-macro-function) + (%make-xref-entry :name (cadr input) :type (car input))) + ((:internal) + (make-xref-entry (car (last input)) relation)) + (t + (multiple-value-bind (type name specializers qualifiers) + (parse-definition-spec input) + (%make-xref-entry :name name :type type + :method-qualifiers (unless (eql qualifiers t) qualifiers) + :method-specializers specializers))))))) + +(defun parse-definition-spec (form) + (let ((type t) + name classes qualifiers) + (cond + ((consp form) + (cond ((eq (car form) 'setf) + (setq name form)) + (t + (when (eq (car form) :method) (pop form)) + (setq name (car form)) + (let* ((last (car (last (cdr form))))) + (cond ((and (listp last)(or (null last)(neq (car last) 'eql))) + (setq classes last) + (setq qualifiers (butlast (cdr form)))) + (t (setq classes (cdr form))))) + (cond ((null qualifiers) + (setq qualifiers t)) + ((equal qualifiers '(:primary)) + (setq qualifiers nil)))))) + (t (setq name form))) + (when (setf-function-name-p name) + (setq name (canonical-maybe-setf-name name))) + (when (not (or (symbolp name) + (setf-function-name-p name))) + (return-from parse-definition-spec)) + (when (consp qualifiers) + (mapc #'(lambda (q) + (when (listp q) + (return-from parse-definition-spec))) + qualifiers)) + (when classes + (mapc #'(lambda (c) + (when (not (and c (or (symbolp c)(and (consp c)(eq (car c) 'eql))))) + (return-from parse-definition-spec))) + classes)) + (when (or (consp classes)(consp qualifiers))(setq type 'method)) + (values type name classes qualifiers))) + +;; XREF-ENTRY-EQUAL -- external +;; +;; Simply compares all slots. +(defun xref-entry-equal (entry1 entry2) + (and (eql (xref-entry-name entry1) (xref-entry-name entry2)) + (eql (xref-entry-type entry1) (xref-entry-type entry2)) + (equal (xref-entry-method-qualifiers entry1) + (xref-entry-method-qualifiers entry2)) + (equal (xref-entry-method-specializers entry1) + (xref-entry-method-specializers entry2)))) + +;; XREF-ENTRY-FULL-NAME -- external +;; +(defun xref-entry-full-name (entry) + (if (eql (xref-entry-type entry) 'method) + `(:method ,(xref-entry-name entry) + ,@(xref-entry-method-qualifiers entry) + ,(xref-entry-method-specializers entry)) + (xref-entry-name entry))) + + +;; %DB-KEY-FROM-XREF-ENTRY -- internal +;; +;; This is mostly the inverse to MAKE-XREF-ENTRY, since it takes an entry +;; and returns either a symbol (for functions, macros and variables) or a +;; list in the form (METHOD-NAME QUALIFIERS (SPECIALIZERS)) for a method. +;; These are used as keys in the database hash-tables. +(defun %db-key-from-xref-entry (entry) + (if (eql (xref-entry-type entry) 'method) + `(,(xref-entry-name entry) + ,@(xref-entry-method-qualifiers entry) + ,(xref-entry-method-specializers entry)) + (xref-entry-name entry))) + +;; %SOURCE-FILE-FOR-XREF-ENTRY -- internal +;; +(defun %source-file-for-xref-entry (entry) + (multiple-value-bind (files name type specializers qualifiers) + (edit-definition-p (%db-key-from-xref-entry entry) + (if (eql (xref-entry-type entry) 'macro) + 'function + (xref-entry-type entry))) + (declare (ignore name type specializers qualifiers)) + (let ((filename (if (consp files) (cdar files) files))) + (when filename + (truename filename))))) + + +;; MAKE-XREF-DATABASE -- internal +;; +;; This returns a fresh cross-referencing "database". It's a simple association +;; list with two hash-tables per entry. The CAR hash holds the direct entries +;; e.g. KEY calls/references/etc VALUE, while the CDR holds inverse hash (KEY +;; is called/referenced/etc by VALUE. +(defun make-xref-database () + (list :binds (cons (make-hash-table :test #'equal) + (make-hash-table :test #'equal)) + :references (cons (make-hash-table :test #'equal) + (make-hash-table :test #'equal)) + :sets (cons (make-hash-table :test #'equal) + (make-hash-table :test #'equal)) + :direct-calls (cons (make-hash-table :test #'equal) + (make-hash-table :test #'equal)) + :indirect-calls (cons (make-hash-table :test #'equal) + (make-hash-table :test #'equal)) + :macro-calls (cons (make-hash-table :test #'equal) + (make-hash-table :test #'equal)))) + +;; *XREF-DATABASE* -- internal +;; +;; The one and only cross-referencing database. +(defvar *xref-database* (make-xref-database)) + + +;; %XREF-TABLE -- internal +;; +;; Returns the appropriate table for a given relation. +(defun %xref-table (relation inversep) + (if inversep + (cdr (getf *xref-database* relation)) + (car (getf *xref-database* relation)))) + + +;; DISCARD-ALL-XREF-INFO -- external +;; +(defun discard-all-xref-info () + "Clear the cross-referencing database." + (setf *xref-database* (make-xref-database)) + t) + + +;; %ADD-XREF-ENTRY -- internal +;; +;; The compiler adds cross-referencing information by calling this +;; (see NX-RECORD-XREF-INFO). +(defun %add-xref-entry (relation name1 name2) + (when (and *record-xref-info* relation name1 name2) + (pushnew (make-xref-entry name2 relation) + (gethash name1 (%xref-table relation nil)) + :test #'xref-entry-equal) + (pushnew (make-xref-entry name1 relation) + (gethash name2 (%xref-table relation t)) + :test #'xref-entry-equal) + t)) + + + + +;; %DISCARD-XREF-INFO-FOR-FUNCTION -- internal +;; +;; This rather expensive operation removes all traces of a given function +;; from the cross-referencing database. It needs to be called whenever a +;; function gets redefined, so we don't pick up stale xref entries. +(defun %discard-xref-info-for-function (func) + ;; need to go through every possible relation + (dolist (relation '(:direct-calls :indirect-calls :macro-calls + :binds :references :sets)) + ;; get a list of the places to which the func points to... + (dolist (entry (gethash func (%xref-table relation nil))) + (let ((key (%db-key-from-xref-entry entry))) + ;; ... and remove it from there + (setf (gethash key (%xref-table relation t)) + (delete func (gethash key (%xref-table relation t)))))) + ;; the non-inverse case is easy + (remhash func (%xref-table relation nil)))) + + +;; GET-RELATION -- external +;; +;; FIXME: Implement filtering by files. +;; And what the heck should errorp do? +(defun get-relation (relation name1 name2 &key in-files in-functions exhaustive errorp) + "Returns a list of matches for RELATION between NAME1 and NAME2. Results can +be filtered by passing a list of files in IN-FILES or functions in IN-FUNCTIONS. +If EXHAUSTIVE is true, it will also look for callers for which no xref information +is present by looping through all defined functions in memory." + (when (and (eql name1 :wild) (eql name2 :wild)) + (error "Only one wildcard allowed in a cross-reference query")) + (ecase relation + ((:binds :references :sets :direct-calls :indirect-calls :macro-calls) + (let ((lookup-table (%xref-table relation nil)) + (inverse-lookup-table (%xref-table relation t))) + (let ((matches (if (eql name1 :wild) + (%do-wild-xref-lookup name2 inverse-lookup-table + in-files in-functions) + (if (eql name2 :wild) + (%do-wild-xref-lookup name1 lookup-table + in-files in-functions) + (%do-simple-xref-lookup name1 name2 lookup-table + in-files in-functions))))) + ;; search all lfuns if exhaustive is t + (when (and exhaustive (eql name1 :wild) (or (eql relation :direct-calls) + (eql relation :indirect-calls))) + (dolist (caller (callers name2)) + (pushnew (make-xref-entry caller relation) + matches + :test #'xref-entry-equal))) + matches))) + (:calls + (let ((direct-calls (get-relation :direct-calls name1 name2 + :in-files in-files :in-functions in-functions + :exhaustive exhaustive :errorp errorp)) + (indirect-calls (get-relation :indirect-calls name1 name2 + :in-files in-files :in-functions in-functions + :exhaustive exhaustive :errorp errorp)) + (macro-calls (get-relation :macro-calls name1 name2 + :in-files in-files :in-functions in-functions + :exhaustive exhaustive :errorp errorp))) + (if (or (eql name1 :wild) (eql name2 :wild)) + ;; need to weed out possible duplicates here + (let ((matches nil)) + (dolist (c direct-calls) (pushnew c matches)) + (dolist (c indirect-calls) (pushnew c matches)) + (dolist (c macro-calls) (pushnew c matches)) + matches) + (when (or direct-calls indirect-calls macro-calls) + name2)))) + (:uses + (let ((binds (get-relation :binds name1 name2 :in-files in-files + :in-functions in-functions :errorp errorp + :exhaustive exhaustive)) + (references (get-relation :binds name1 name2 :in-files in-files + :in-functions in-functions :errorp errorp + :exhaustive exhaustive)) + (sets (get-relation :sets name1 name2 :in-files in-files + :in-functions in-functions :errorp errorp + :exhaustive exhaustive))) + (if (or (eql name1 :wild) (eql name2 :wild)) + (concatenate 'list binds references sets) + (when (or binds references sets) + name2)))))) + +;; %DO-WILD-XREF-LOOKUP -- internal +;; +;; Does a wild lookup into the xref database and returns a list of matches. +;; +;; FIXME: implement filtering by files +(defun %do-wild-xref-lookup (name table in-files in-functions) + (declare (ignore in-files)) + (multiple-value-bind (value foundp) (gethash name table) + (declare (ignore foundp)) + (if in-functions + (remove-if (lambda (x) (not (find x in-functions))) value) + value))) + +;; %DO-SIMPLE-XREF-LOOKUP -- internal +;; +;; Does a simple lookup into the xref database and returns NAME2 if a relation +;; between NAME1 and NAME2 exists. +;; +;; FIXME: implement filtering by files +(defun %do-simple-xref-lookup (name1 name2 table in-files in-functions) + (declare (ignore in-files)) + (when (some (lambda (x) + (when in-functions + (find x in-functions)) + (eql x name2)) + (gethash name1 table)) + name2)) + + +(defun %print-xref-entries (entries stream verbose) + (dolist (entry entries) + (if (eql (xref-entry-type entry) 'method) + ;; print qualifiers and specializers if it's a method + (format stream "~5,5T~A ~@[~A ~]~A~%" + (xref-entry-name entry) + (xref-entry-method-qualifiers entry) + (xref-entry-method-specializers entry)) + (format stream "~5,5T~A~%" (xref-entry-name entry))) + ;; print extra information when verbose + (when verbose + (format stream "~5,5T Type: ~A~%" (xref-entry-type entry)) + (let ((file (%source-file-for-xref-entry entry))) + (format stream "~5,5T File: ~A~%~%" (if file file "not recorded")))))) + + +;; WHO-DIRECTLY-CALLS -- external +;; +(defun who-directly-calls (name &key inverse in-files in-functions verbose + (stream *standard-output*)) + "Prints information about direct callers of NAME. If INVERSE is true, +it will print direct callees of NAME instead." + (let ((callers/callees (if inverse + (get-relation :direct-calls name :wild + :in-files in-files + :in-functions in-functions) + (get-relation :direct-calls :wild name + :in-files in-files + :in-functions in-functions + :exhaustive t)))) + (format stream "~%~T") + (if callers/callees + (progn + (format stream "~A ~:[is directly called by~;directly calls~]:~%" + name inverse) + (%print-xref-entries callers/callees stream verbose)) + (format stream "No direct ~:[callers~;callees~] of ~A were found in the database~%" + inverse name))) + (values)) + +;; WHO-INDIRECTLY-CALLS -- external +;; +;; FIXME: Implement this (we can't currently detect indirect calls). +(defun who-indirectly-calls (name &key inverse in-files in-functions verbose + (stream *standard-output*)) + "Prints information about indirect callers of NAME. If INVERSE is true, +it will print indirect callees of NAME instead." + (let ((callers/callees (if inverse + (get-relation :indirect-calls name :wild + :in-files in-files + :in-functions in-functions) + (get-relation :indirect-calls :wild name + :in-files in-files + :in-functions in-functions)))) + (format stream "~%~T") + (if callers/callees + (progn + (format stream "~A ~:[is indirectly called by~;indirectly calls~]:~%" + name inverse) + (%print-xref-entries callers/callees stream verbose)) + (format stream "No indirect ~:[callers~;callees~] of ~A were found in the database~%" + inverse name))) + (values)) + +;; MACROS-CALLED-BY -- external +;; +(defun macros-called-by (name &key inverse in-files in-functions verbose + (stream *standard-output*)) + "Prints information about macros which get called by NAME. If INVERSE is true, +it will list all functions which macroexpand NAME instead." + (let ((callers/callees (if (not inverse) + (get-relation :macro-calls name :wild + :in-files in-files + :in-functions in-functions) + (get-relation :macro-calls :wild name + :in-files in-files + :in-functions in-functions)))) + (format stream "~%~T") + (if callers/callees + (progn + (format stream "~A ~:[is macro called by~;macro calls~]:~%" + name (not inverse)) + (%print-xref-entries callers/callees stream verbose)) + (format stream "No macro ~:[callers~;callees~] of ~A were found in the database~%" + (not inverse) name))) + (values)) + +;; WHO-CALLS -- external +;; +(defun who-calls (name &key inverse in-files in-functions verbose + (stream *standard-output*)) + "Shorthand for WHO-DIRECTLY-CALLS, WHO-INDIRECTLY-CALLS and +MACROS-CALLED-BY." + (who-directly-calls name :inverse inverse :stream stream :verbose verbose + :in-files in-files :in-functions in-functions) + (who-indirectly-calls name :inverse inverse :stream stream :verbose verbose + :in-files in-files :in-functions in-functions) + (macros-called-by name :inverse (not inverse) :stream stream :verbose verbose + :in-files in-files :in-functions in-functions) + (values)) + + +;; WHO-BINDS -- external +;; +(defun who-binds (name &key inverse in-files in-functions verbose + (stream *standard-output*)) + "Prints a list of functions which bind NAME. If INVERSE is true, it will +print a list of variables bound by NAME instead." + (let ((bindings (if inverse + (get-relation :binds name :wild :in-files in-files + :in-functions in-functions) + (get-relation :binds :wild name :in-files in-files + :in-functions in-functions)))) + (format stream "~%~T") + (if bindings + (progn + (format stream "~A ~:[is bound by~;binds~]:" name inverse) + (%print-xref-entries bindings stream verbose)) + (format stream "No ~:[bindings of~;symbols bound by~] ~A were found in the database~%" + inverse name))) + (values)) + +;; WHO-REFERENCES -- external +;; +(defun who-references (name &key inverse in-files in-functions verbose + (stream *standard-output*)) + "Prints a list of functions which reference NAME. If INVERSE is true, it will +print a list of variables referenced by NAME instead." + (let ((references (if inverse + (get-relation :references name :wild :in-files in-files + :in-functions in-functions) + (get-relation :references :wild name :in-files in-files + :in-functions in-functions)))) + (format stream "~%~T") + (if references + (progn + (format stream "~A ~:[is referenced by~;references~]:~%" name inverse) + (%print-xref-entries references stream verbose)) + (format stream "No ~:[references to~;symbols referenced by~] ~A were found in the database~%" + inverse name))) + (values)) + +;; WHO-SETS -- external +;; +(defun who-sets (name &key inverse in-files in-functions verbose + (stream *standard-output*)) + "Prints a list of functions which set NAME. If INVERSE is true, it will +print a list of variables set by NAME instead." + (let ((sets (if inverse + (get-relation :sets name :wild :in-files in-files + :in-functions in-functions) + (get-relation :sets :wild name :in-files in-files + :in-functions in-functions)))) + (format stream "~%~T") + (if sets + (progn + (format stream "~A ~:[is set by~;sets~]:~%" name inverse) + (%print-xref-entries sets stream verbose)) + (format stream "No ~:[settings of~;symbols set by~] ~A were found in the database~%" + inverse name))) + (values)) + +;; WHO-USES -- external +;; +(defun who-uses (name &key inverse in-files in-functions verbose + (stream *standard-output*)) + "Shorthand for WHO-BINDS, WHO-REFERENCES and WHO-SETS." + (who-binds name :inverse inverse :stream stream :verbose verbose + :in-files in-files :in-functions in-functions) + + (who-references name :inverse inverse :stream stream :verbose verbose + :in-files in-files :in-functions in-functions) + + (who-sets name :inverse inverse :stream stream :verbose verbose + :in-files in-files :in-functions in-functions) + (values)) + + +;; XREF-DESCRIBE -- external +;; +(defun xref-describe (name &key verbose) + "Prints relevant cross-referencing information about NAME." + (if (fboundp name) + (progn + (who-calls name :stream *terminal-io* :verbose verbose) + (who-calls name :inverse t :stream *terminal-io* :verbose verbose) + (who-uses name :inverse t :stream *terminal-io* :verbose verbose)) + (who-uses name :stream *terminal-io* :verbose verbose)) + (values)) + + +;;; Hook into the Clozure CL compiler frontend, by pointing a couple +;;; of its variables at our functions. +(setq ccl::*nx-discard-xref-info-hook* #'%discard-xref-info-for-function) +(setq ccl::*nx-add-xref-entry-hook* #'%add-xref-entry) + +(provide :xref) Index: /branches/new-random/library/.cvsignore =================================================================== --- /branches/new-random/library/.cvsignore (revision 13309) +++ /branches/new-random/library/.cvsignore (revision 13309) @@ -0,0 +1,2 @@ +*fsl +*~.* Index: /branches/new-random/library/chud-metering.lisp =================================================================== --- /branches/new-random/library/chud-metering.lisp (revision 13309) +++ /branches/new-random/library/chud-metering.lisp (revision 13309) @@ -0,0 +1,306 @@ +;;;-*-Mode: LISP; Package: (CHUD (:USE CL CCL)) -*- +;;; +;;; Copyright (C) 2005,2008,2009 Clozure Associates and contributors +;;; This file is part of Clozure CL. +;;; +;;; Clozure CL is licensed under the terms of the Lisp Lesser GNU Public +;;; License , known as the LLGPL and distributed with Clozure CL as the +;;; file "LICENSE". The LLGPL consists of a preamble and the LGPL, +;;; which is distributed with Clozure CL as the file "LGPL". Where these +;;; conflict, the preamble takes precedence. +;;; +;;; Clozure CL is referenced in the preamble as the "LIBRARY." +;;; +;;; The LLGPL is also available online at +;;; http://opensource.franz.com/preamble.html + +;;; Some of this is based on work done by Dan Knapp and Hamilton Link +;;; (and possibly others.) + +;;; CHUD 4.4.3-5 claims to offer 64-bit support; however, the library +;;; which provides the API to control CHUD metering functions still +;;; seems to be 32-bit only. Conditionalization for x86-64 and +;;; for 64-bit targets is (so far) just an exercise. + +(defpackage "CHUD" + (:use "CL" "CCL") + (:export "METER" "*SHARK-CONFIG-FILE*")) + +(in-package "CHUD") + +(eval-when (:compile-toplevel :load-toplevel :execute) + (progn + #-darwin-target + (error "This code is Darwin/MacOSX-specific."))) + + +(defparameter *shark-session-path* nil) + +(defloadvar *written-spatch-file* nil) + +(defparameter *shark-session-native-namestring* nil) + +(defparameter *shark-config-file* nil "Full pathname of .cfg file to use for profiling, or NIL.") + +(defun finder-open-file (namestring) + "Open the file named by NAMESTRING, as if it was double-clicked on +in the finder" + (run-program "/usr/bin/open" (list namestring) :output nil)) + +(defun ensure-shark-session-path () + (unless *shark-session-path* + (multiple-value-bind (second minute hour date month year) + (decode-universal-time (get-universal-time)) + (let* ((subdir (format nil "profiling-session-~A-~d_~d-~d-~d_~d.~d.~d" + (pathname-name + (car + ccl::*command-line-argument-list*)) + (ccl::getpid) + month + date + year + hour + minute + second)) + (dir (make-pathname :directory (append (pathname-directory (user-homedir-pathname)) (list subdir)) :defaults nil)) + (native-name (ccl::native-untranslated-namestring dir))) + (ensure-directories-exist dir) + (setenv "SHARK_SEARCH_PATH_PATCH_FILES" native-name) + (setq *shark-session-native-namestring* + native-name + *shark-session-path* dir)))) + *shark-session-path*) + + + + +(defloadvar *shark-process* nil) +(defloadvar *sampling* nil) + +(defvar *debug-shark-process-output* nil) + + +(defun safe-shark-function-name (function) + (let* ((name (format nil "~s" function))) + (subseq (nsubstitute #\0 #\# (nsubstitute #\. #\Space name)) 1))) + +(defun print-shark-spatch-record (fn &optional (stream t)) + (let* ((code-vector #+ppc-target (uvref fn 0) #-ppc-target fn) + (startaddr (+ (ccl::%address-of code-vector) + #+x8664-target 0 + #+ppc32-target target::misc-data-offset + #-ppc32-target 0)) + (endaddr (+ startaddr + #+x8664-target + (1+ (ash (1- (ccl::%function-code-words fn) + ) target::word-shift)) + #+ppc-target + (* 4 (- (uvsize code-vector) + #+ppc64-target 2 + #-ppc64-target 1))))) + ;; i hope all lisp sym characters are allowed... we'll see + (format stream "{~%~@ + ~a~@ + ~@?~@ + ~@?~@ + }~%" + (safe-shark-function-name fn) + #+32-bit-target "0x~8,'0x" #+64-bit-target "0x~16,'0x" + startaddr + #+32-bit-target "0x~8,'0x" #+64-bit-target "0x~16,'0x" + endaddr))) + +#+x8664-target +(ccl::defx86lapfunction dynamic-dnode ((x arg_z)) + (movq (% x) (% imm0)) + (ref-global x86::heap-start arg_y) + (subq (% arg_y) (% imm0)) + (shrq ($ x8664::dnode-shift) (% imm0)) + (box-fixnum imm0 arg_z) + (single-value-return)) + +#+x8632-target +(ccl::defx8632lapfunction dynamic-dnode ((x arg_z)) + (movl (% x) (% imm0)) + (ref-global x86::heap-start arg_y) + (subl (% arg_y) (% imm0)) + (shrl ($ x8632::dnode-shift) (% imm0)) + (box-fixnum imm0 arg_z) + (single-value-return)) + +#+x8664-target +(defun identify-functions-with-pure-code () + (ccl::freeze) + (ccl::collect ((functions)) + (block walk + (let* ((frozen-dnodes (ccl::frozen-space-dnodes))) + (ccl::%map-areas (lambda (o) + (when (>= (dynamic-dnode o) frozen-dnodes) + (return-from walk nil)) + (when (typep o 'ccl::function-vector) + (functions (ccl::function-vector-to-function o)))) + ccl::area-dynamic + ))) + (functions))) + +#+x8632-target +(defun identify-functions-with-pure-code () + (ccl::freeze) + (ccl::collect ((functions)) + (block walk + (let* ((frozen-dnodes (ccl::frozen-space-dnodes))) + (ccl::%map-areas (lambda (o) + (when (>= (dynamic-dnode o) frozen-dnodes) + (return-from walk nil)) + (when (typep o 'function) + (functions o))) + ccl::area-dynamic + ))) + (functions))) + +#+ppc-target +(defun identify-functions-with-pure-code () + (ccl::purify) + (multiple-value-bind (pure-low pure-high) + + (ccl::do-gc-areas (a) + (when (eql(ccl::%fixnum-ref a target::area.code) + ccl::area-readonly) + (return + (values (ash (ccl::%fixnum-ref a target::area.low) target::fixnumshift) + (ash (ccl::%fixnum-ref a target::area.active) target::fixnumshift))))) + (let* ((hash (make-hash-table :test #'eq))) + (ccl::%map-lfuns #'(lambda (f) + (let* ((code-vector (ccl:uvref f 0)) + (startaddr (+ (ccl::%address-of code-vector) + target::misc-data-offset))) + (when (and (>= startaddr pure-low) + (< startaddr pure-high)) + (push f (gethash code-vector hash)))))) + (let* ((n 0)) + (declare (fixnum n)) + (maphash #'(lambda (k v) + (declare (ignore k)) + (if (null (cdr v)) + (incf n))) + hash) + (let* ((functions ())) + (maphash #'(lambda (k v) + (declare (ignore k)) + (when (null (cdr v)) + (push (car v) functions))) + hash) + (sort functions + #'(lambda (x y) + (< (ccl::%address-of (uvref x 0) ) + (ccl::%address-of (uvref y 0)))))))))) + + + + +(defun generate-shark-spatch-file () + (let* ((functions (identify-functions-with-pure-code))) + (with-open-file (f (make-pathname + :host nil + :directory (pathname-directory + (ensure-shark-session-path)) + :name (format nil "~a_~D" + (pathname-name + (car + ccl::*command-line-argument-list*)) + (ccl::getpid)) + :type "spatch") + :direction :output + :if-exists :supersede) + (format f "!SHARK_SPATCH_BEGIN~%") + (dolist (fun functions) + (print-shark-spatch-record fun f)) + (format f "!SHARK_SPATCH_END~%")))) + +(defun terminate-shark-process () + (when *shark-process* + (signal-external-process *shark-process* #$SIGUSR2)) + (setq *shark-process* nil + *sampling* nil)) + +(defun toggle-sampling () + (if *shark-process* + (progn + (signal-external-process *shark-process* #$SIGUSR1) + (setq *sampling* (not *sampling*))) + (warn "No active shark procsss"))) + +(defun enable-sampling () + (unless *sampling* (toggle-sampling))) + +(defun disable-sampling () + (when *sampling* (toggle-sampling))) + +(defun ensure-shark-process (reset hook) + (when (or (null *shark-process*) reset) + (terminate-shark-process) + (when (or reset (not *written-spatch-file*)) + (generate-shark-spatch-file)) + (let* ((args (list "-b" "-1" "-a" (format nil "~d" (ccl::getpid)) + "-d" *shark-session-native-namestring*))) + (when *shark-config-file* + (push (ccl::native-untranslated-namestring *shark-config-file*) + args) + (push "-m" args)) + (setq *shark-process* + (run-program "/usr/bin/shark" + args + :output :stream + :status-hook hook + :wait nil)) + (let* ((output (external-process-output-stream *shark-process*))) + (do* ((line (read-line output nil nil) (read-line output nil nil))) + ((null line)) + (when *debug-shark-process-output* + (format t "~&~a" line)) + (when (search "ready." line :key #'char-downcase) + (sleep 1) + (return))))))) + +(defun display-shark-session-file (line) + (let* ((last-quote (position #\' line :from-end t)) + (first-quote (and last-quote (position #\' line :end (1- last-quote) :from-end t))) + (path (and first-quote (subseq line (1+ first-quote) last-quote)))) + (when path (finder-open-file path)))) + +(defun scan-shark-process-output (p) + (with-interrupts-enabled + (let* ((out (ccl::external-process-output p))) + (do* ((line (read-line out nil nil) (read-line out nil nil))) + ((null line)) + (when *debug-shark-process-output* + (format t "~&~a" line)) + (when (search "Created session file:" line) + (display-shark-session-file line) + (return)))))) + + + +(defmacro meter (form &key reset debug-output) + (let* ((hook (gensym)) + (block (gensym)) + (process (gensym))) + `(block ,block + (flet ((,hook (p) + (when (or (eq (external-process-status p) :exited) + (eq (external-process-status p) :signaled)) + (setq *shark-process* nil + *sampling* nil)))) + (let* ((*debug-shark-process-output* ,debug-output)) + (ensure-shark-process ,reset #',hook) + (unwind-protect + (progn + (enable-sampling) + ,form) + (disable-sampling) + (let* ((,process *shark-process*)) + (when ,process + (scan-shark-process-output ,process))))))))) + +;;; Try to clean up after ourselves when the lisp quits. +(pushnew 'terminate-shark-process ccl::*save-exit-functions*) Index: /branches/new-random/library/chud-metering.txt =================================================================== --- /branches/new-random/library/chud-metering.txt (revision 13309) +++ /branches/new-random/library/chud-metering.txt (revision 13309) @@ -0,0 +1,157 @@ +Using Apple's CHUD metering tools from CCL +========================================== + +Prerequisites +------------- + +Apple's CHUD metering tools are available (as of this writing) from: + +. + +The CHUD tools are also generally bundled with Apple's XCode tools. +CHUD 4.5.0 (which seems to be bundled with XCode 3.0) seems to work +well with this interface; later versions may have problems. +Versions of CHUD as old as 4.1.1 may work with 32-bit PPC versions +of CCL; later versions (not sure exactly -what- versions) added +x86, ppc64, and x86-64 support. + +One way to tell whether any version of the CHUD tools is installed +is to try to invoke the "shark" command-line program (/usr/bin/shark) +from the shell: + +shell> shark --help + +and verifying that that prints a usage summary. + +CHUD consists of several components, including command-line programs, +GUI applications, kernel extensions, and "frameworks" (collections of +libraries, headers, and other resources which applications can use to +access functionality provided by the other components.) Past versions +of CCL/OpenMCL have used the CHUD framework libraries to control the +CHUD profiler. Even though the rest of CHUD is currently 64-bit aware, +the frameworks are unfortunately still only available as 32-bit libraries, +so the traditional way of controlling the profiling facility from OpenMCL +has only worked from DarwinPPC32 versions. + +Two of the CHUD component programs are of particular interest: + +1) The "Shark" application (often installed in +"/Developer/Applications/Performance Tools/Shark.app"), which provides +a graphical user interface for exploring and analyzing profiling results +and provides tools for creating "sampling configurations" (see below), +among other things. + +2) the "shark" program ("/usr/bin/shark"), which can be used to control +the CHUD profiling facility and to collect sampling data, which can then +be displayed and analyzed in Shark.app. + +The fact that these two (substantially different) programs have names that +differ only in alphabetic case may be confusing. The discussion below +tries to consistently distinguish between "the shark program" and "the +Shark application". + +Usage synopsis +-------------- + +? (defun fact (n) (if (zerop n) 1 (* n (fact (1- n))))) +FACT +? (require "CHUD-METERING") +"CHUD-METERING" +("CHUD-METERING") +? (chud:meter (null (fact 10000))) +NIL ; since that large number is not NULL + +and, a few seconds after the result is returned, a file whose +name is of the form "session_nnn.mshark" will open in Shark.app. + +The fist time that CHUD:METER is used in a lisp session, it'll do a +few things to prepare subsequent profiling sessions. Those things +include: + +1) creating a directory to store files that are related to using +the CHUD tools in this lisp session. This directory is created in +the user's home directory and has a name of the form: + +profiling-session--_-
-_.. + +where is the lisp's process id, is the name of +the lisp kernel (of all things ...), and the other values provide +a timestamp. + +2) does whatever needs to be done to ensure that currently-defined +lisp functions don't move around as the result of GC activity, then +writes a text file describing the names and addresses of those functions +to the profiling-session directory created above. (The naming conventions +for and format of that file are described in + + + +3) run the shark program ("/usr/bin/shark") and wait until it's ready to +receive signals that control its operation. + +This startup activity typically takes a few seconds; after it's been +completed, subsequent use of CHUD:METER doesn't involve that overhead. +(See the discussion of :RESET below.) + +After any startup activity is complete, CHUD:METER arranges to send +a "start profiling" signal to the running shark program, executes +the form, sends a "stop profiling" signal to the shark program, and +reads its diagnostic output, looking for the name of the ".mshark" +file it produces. If it's able to find this filename, it arranges +for "Shark.app" to open it + +Profiling "configurations". +-------------------------- + +By default, a shark profiling session will: +a) use "time based" sampling, to periodically interrupt the lisp + process and note the value of the program counter and at least + a few levels of call history. +b) do this sampling once every millisecond +c) run for up to 30 seconds, unless told to stop earlier. + +This is known as "the default configuration"; it's possible to use +items on the "Config" menu in the Shark application to create alternate +configurations which provide different kinds of profiling parameters +and to save these configurations in files for subsequent reuse. +(The set of things that CHUD knows how to monitor is large and interesting.) + +You use alternate profiling configurations (created and "exported" via +Shark.app) with CHUD:METER, but the interface is a little awkward. + +Reference +--------- + +CHUD:*SHARK-CONFIG-FILE* [Variable] + +When non-null, this should be the pathname of an alternate profiling +configuration file created by the "Config Editor" in Shark.app. + +(CHUD:METER form &key (reset nil) (debug-output nil)) [Macro] + +Executes FORM (an arbitrary lisp form) and returns whatever result(s) +it returns, with CHUD profiling enabled during the form's execution. +Tries to determine the name of the session file (*.mshark) to which +the shark program wrote profiling data and opens this file in the +Shark application. + +Arguments: + +debug-output - when non-nil, causes output generated by the shark program to + be echoed to *TERMINAL-IO*. For debugging. +reset - when non-nil, terminates any running instance of the + shark program created by previous invocations of CHUD:METER + in this lisp session, generates a new .spatch file + (describing the names and addresses of lisp functions), + and starts a new instance of the shark program; if + CHUD:*SHARK-CONFIG-FILE* is non-NIL when this new instance + is started, that instance is told to use the specified + config file for profiling (in lieu of the default profiling + configuration.) + +Acknowledgments +--------------- + +Both Dan Knapp and Hamilton Link have posted similar CHUD interfaces +to openmcl-devel in the past; Hamilton's also reported bugs in the +spatch mechanism to CHUD developers (and gotten those bugs fixed.) Index: /branches/new-random/library/core-files.lisp =================================================================== --- /branches/new-random/library/core-files.lisp (revision 13309) +++ /branches/new-random/library/core-files.lisp (revision 13309) @@ -0,0 +1,1159 @@ +;;; +;;; Copyright (C) 2009, Clozure Associates and contributors +;;; This file is part of Clozure CL. +;;; +;;; Clozure CL is licensed under the terms of the Lisp Lesser GNU Public +;;; License , known as the LLGPL and distributed with Clozure CL as the +;;; file "LICENSE". The LLGPL consists of a preamble and the LGPL, +;;; which is distributed with Clozure CL as the file "LGPL". Where these +;;; conflict, the preamble takes precedence. +;;; +;;; Clozure CL is referenced in the preamble as the "LIBRARY." +;;; +;;; The LLGPL is also available online at +;;; http://opensource.franz.com/preamble.html + +;; Functions to examine core files. + +(in-package :ccl) + +#+:linuxx8664-target +(progn + +(export '(open-core close-core + core-heap-utilization map-core-areas map-core-pointers + core-q core-l core-w core-b + core-consp core-symbolp core-functionp core-listp core-nullp core-uvector-p + core-uvtype core-uvtypep core-uvref core-uvsize + core-car core-cdr core-object-type core-istruct-type + copy-from-core core-list + core-keyword-package core-find-package core-find-symbol + core-package-names core-package-name + core-map-symbols + core-symbol-name core-symbol-value core-symbol-package + core-gethash core-hash-table-count + core-lfun-name core-lfun-bits + core-find-class + core-instance-class + core-instance-p + core-instance-class-name + core-string-equal + core-all-processes core-process-name + core-find-process-for-id + core-print + core-print-call-history + )) + +(eval-when (:compile-toplevel :execute) + (require "HASHENV" "ccl:xdump;hashenv")) + +;; The intended way to use these facilities is to open up a particular core file once, +;; and then repeatedly call functions to examine it. So for convenience, we keep the +;; core file in a global var, rather than making all user functions take an extra arg. +;; There is nothing intrinsic that would prevent having multiple core files open at once. + +(defvar *current-core* nil) + + +(defstruct core-info + pathname + sections + ;; uses either stream or ivector, determined at runtime + stream + mapped-ivector + raw-ivector + ;; caches + symbol-ptrs + classes-hash-table-ptr + lfun-names-table-ptr + process-class + ) + +(defmethod print-object :around ((core core-info) (stream t)) + (let ((*print-array* nil)) + (call-next-method))) + +(declaim (type (or null core-info) *current-core*) + (ftype (function () core-info) current-core) + (inline current-core)) + +(defun current-core () + (or *current-core* (require-type *current-core* 'core-info))) + +(defun close-core () + (let ((core *current-core*)) + (setq *current-core* nil) + (when core + (when (core-info-stream core) + (close (core-info-stream core))) + (when (core-info-mapped-ivector core) + (unmap-ivector (core-info-mapped-ivector core))) + t))) + +;; TODO: after load sections, check if highest heap address is a fixnum, and +;; arrange to use fixnum-only versions of the reading functions. +(defun open-core (pathname &key (method :mmap)) + (when *current-core* + (close-core)) + (let* ((sections (readelf-sections pathname)) + (core (make-core-info :pathname pathname :sections sections))) + (ecase method + (:mmap (let ((mapped-vector (map-file-to-ivector pathname '(unsigned-byte 8)))) + (multiple-value-bind (vector offset) (array-data-and-offset mapped-vector) + (loop for data across sections do (incf (cdr data) offset)) + (setf (core-info-mapped-ivector core) mapped-vector) + (setf (core-info-raw-ivector core) vector)))) + (:stream (setf (core-info-stream core) + (open pathname :element-type '(unsigned-byte 8))))) + (setq *current-core* core)) + pathname) + +;; Kinda stupid to call external program for this... +(defun readelf-sections (pathname) + (flet ((split (line start end) + (loop while (setq start (position-if-not #'whitespacep line :start start :end end)) + as match = (cdr (assq (char line start) '((#\[ . #\]) (#$ . #$) (#\< . #\>)))) + as next = (if match + (1+ (or (position match line :start (1+ start) :end end) + (error "Unmatched ~c at position ~s" (char line start) start))) + (or (position-if #'whitespacep line :start start :end end) end)) + collect (subseq line start next) + do (setq start next)))) + (let* ((file (native-translated-namestring pathname)) + (string (with-output-to-string (output) + (ccl:run-program "readelf" `("--sections" ,file) :output output))) + (sections (loop + for start = (1+ (position #\newline string + :start (1+ (position #\newline string + :start (position #\[ string))))) + then next + for next = (1+ (position #\newline string + :start (1+ (position #\newline string :start start)))) + while (eql #\space (aref string next)) + nconc + (destructuring-bind (number name type address filepos size &optional ent-size flags link info align) + (split string start next) + (assert (and (eql (char number 0) #\[) (eql (char number (1- (length number))) #\]))) + (setq number (read-from-string number :start 1 :end (1- (length number)))) + (when (eql number 0) + (shiftf align info link flags ent-size size filepos address type name "")) + (setq address (parse-integer address :radix 16)) + (setq filepos (parse-integer filepos :radix 16)) + (setq size (parse-integer size :radix 16)) + (setq ent-size (parse-integer ent-size :radix 16)) + (unless (eql size 0) + (assert (and (equal link "0") (equal info "0") (equal align "1"))) + (list (list address filepos size)))))) + (sections (cons (list most-positive-fixnum 0 0) sections));; hack for loop below + (sections (sort sections #'< :key #'car));; sort by address + (sections (loop + with cur-address = -1 + with cur-filepos = -1 + with cur-end = cur-address + for (address filepos size) in sections + unless (or (= (+ cur-filepos (- address cur-address)) filepos) + (= cur-address cur-end)) + collect (cons cur-address cur-filepos) + do (if (= (+ cur-filepos (- address cur-address)) filepos) + (setq cur-end (max (+ address size) cur-end)) + (progn + (assert (<= cur-end address));; no overlap. + (setq cur-address address cur-filepos filepos cur-end (+ address size))))))) + (coerce sections 'vector)))) + +(declaim (inline core-ivector-readb core-ivector-readw core-ivector-readl core-ivector-readq + core-stream-readb core-stream-readw core-stream-readl core-stream-readq)) +(declaim (ftype (function (t t) (unsigned-byte 8)) core-ivector-readb core-stream-readb) + (ftype (function (t t) (unsigned-byte 16)) core-ivector-readw core-stream-readw) + (ftype (function (t t) (unsigned-byte 32)) core-ivector-readl core-stream-readl) + (ftype (function (t t) (unsigned-byte 64)) core-ivector-readq core-stream-readq) + (ftype (function (integer) fixnum) core-offset-for-address)) + +(defun core-offset-for-address (address) + ;; sections are sorted, so could do binary search if this became a bottleneck. + ;; (there are around 50 sections) + (or (loop for prev = nil then sect as sect across (core-info-sections (current-core)) + do (when (< address (car sect)) + (return (and prev (+ (cdr prev) (- address (car prev))))))) + (error "Unknown core address x~x" address))) + +(defun core-stream-readb (s offset) + (declare (type basic-input-stream s) (optimize (speed 3) (safety 0))) + (when offset (stream-position s offset)) + (read-byte s)) + +(defun core-stream-readw (s offset) + (declare (type basic-input-stream s) (optimize (speed 3) (safety 0))) + (when offset (stream-position s offset)) + (%i+ (core-stream-readb s nil) (ash (core-stream-readb s nil) 8))) + +(defun core-stream-readl (s offset) + (declare (type basic-input-stream s) (optimize (speed 3) (safety 0))) + (when offset (stream-position s offset)) + (%i+ (core-stream-readw s nil) (ash (core-stream-readw s nil) 16))) + +(defun core-stream-readq (s offset) + (declare (type basic-input-stream s) (optimize (speed 3) (safety 0))) + (when offset (stream-position s offset)) + (+ (core-stream-readl s nil) (ash (core-stream-readl s nil) 32))) + +(defun core-ivector-readb (vec offset) + (declare (type (simple-array (unsigned-byte 8) (*)) vec) (fixnum offset) + (optimize (speed 3) (safety 0))) + (aref vec offset)) + +(defun core-ivector-readw (vec offset) + (declare (optimize (speed 3) (safety 0))) + (%i+ (core-ivector-readb vec offset) (ash (core-ivector-readb vec (%i+ offset 1)) 8))) + +(defun core-ivector-readl (vec offset) + (declare (optimize (speed 3) (safety 0))) + (%i+ (core-ivector-readw vec offset) (ash (core-ivector-readw vec (%i+ offset 2)) 16))) + +(defun core-ivector-readq (vec offset) + (declare (optimize (speed 3) (safety 0))) + (+ (core-ivector-readl vec offset) (ash (core-ivector-readl vec (%i+ offset 4)) 32))) + + +(defun core-q (address &optional (offset 0)) + (declare (optimize (speed 3) (safety 0))) + (let* ((core (current-core)) + (ivector (core-info-raw-ivector core))) + (declare (type core-info core)) + (if ivector + (core-ivector-readq ivector (core-offset-for-address (+ address offset))) + (core-stream-readq (core-info-stream core) (core-offset-for-address (+ address offset)))))) + +(defun core-l (address &optional (offset 0)) + (declare (optimize (speed 3) (safety 0))) + (let* ((core (current-core)) + (ivector (core-info-raw-ivector core))) + (declare (type core-info core)) + (if ivector + (core-ivector-readl ivector (core-offset-for-address (+ address offset))) + (core-stream-readl (core-info-stream core) (core-offset-for-address (+ address offset)))))) + +(defun core-w (address &optional (offset 0)) + (declare (optimize (speed 3) (safety 0))) + (let* ((core (current-core)) + (ivector (core-info-raw-ivector core))) + (declare (type core-info core)) + (if ivector + (core-ivector-readw ivector (core-offset-for-address (+ address offset))) + (core-stream-readw (core-info-stream core) (core-offset-for-address (+ address offset)))))) + +(defun core-b (address &optional (offset 0)) + (declare (optimize (speed 3) (safety 0))) + (let* ((core (current-core)) + (ivector (core-info-raw-ivector core))) + (declare (type core-info core)) + (if ivector + (core-ivector-readb ivector (core-offset-for-address (+ address offset))) + (core-stream-readb (core-info-stream core) (core-offset-for-address (+ address offset)))))) + +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; +;; +;; general utilities + +;; NIL is constant, assume is same in core as here. +(defun kernel-global-address (global) + (check-type global symbol) + (+ (target-nil-value) (target::%kernel-global global))) + +(defun nil-relative-symbol-address (sym) + (+ (target-nil-value) + #x20 ;;; dunno why + (* (or (position sym x86::*x86-nil-relative-symbols* :test #'eq) + (error "Not a nil-relative symbol ~s" sym)) + target::symbol.size) + (- target::fulltag-symbol target::fulltag-nil))) + +(defun core-area-name (code) + (or (heap-area-name code) + (and (integerp code) + (not (logtest code (1- (ash 1 target::fixnum-shift)))) + (heap-area-name (ash code (- target::fixnum-shift)))))) + +(defx86lapfunction %%raw-obj ((address arg_z)) + (unbox-fixnum address arg_z) + (single-value-return)) + +(declaim (inline uvheader-p uvheader-typecode uvheader-size)) + +(defun uvheader-p (header) + (let ((tag (logand header target::fulltagmask))) + (declare (fixnum tag)) + (and (<= target::fulltag-nodeheader-0 tag) + (<= tag target::fulltag-immheader-2) + (neq tag target::fulltag-odd-fixnum)))) + +(defun uvheader-typecode (header) + (the fixnum (logand #xFF header))) + +(defun uvheader-size (header) + (ash header (- target::num-subtag-bits))) + +(defun uvheader-byte-size (header) + (x8664::x8664-misc-byte-count (uvheader-typecode header) (uvheader-size header))) + +(defun uvheader-type (header) + (let* ((typecode (uvheader-typecode header)) + (low4 (logand typecode target::fulltagmask)) + (high4 (ash typecode (- target::ntagbits)))) + (declare (type (unsigned-byte 8) typecode) + (type (unsigned-byte 4) low4 high4)) + (cond ((eql low4 x8664::fulltag-immheader-0) + (%svref *immheader-0-types* high4)) + ((eql low4 x8664::fulltag-immheader-1) + (%svref *immheader-1-types* high4)) + ((eql low4 x8664::fulltag-immheader-2) + (%svref *immheader-2-types* high4)) + ((eql low4 x8664::fulltag-nodeheader-0) + (%svref *nodeheader-0-types* high4)) + ((eql low4 x8664::fulltag-nodeheader-1) + (%svref *nodeheader-1-types* high4)) + (t 'bogus)))) + +(defun uvheader-type-typecode (symbol &aux pos) + (unless (eq symbol 'bogus) + (cond ((setq pos (position symbol *immheader-0-types*)) + (logior (ash pos target::ntagbits) target::fulltag-immheader-0)) + ((setq pos (position symbol *immheader-1-types*)) + (logior (ash pos target::ntagbits) target::fulltag-immheader-1)) + ((setq pos (position symbol *immheader-2-types*)) + (logior (ash pos target::ntagbits) target::fulltag-immheader-2)) + ((setq pos (position symbol *nodeheader-0-types*)) + (logior (ash pos target::ntagbits) target::fulltag-nodeheader-0)) + ((setq pos (position symbol *nodeheader-1-types*)) + (logior (ash pos target::ntagbits) target::fulltag-nodeheader-1))))) + +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; +;; +;; Core heap + +(defun map-core-areas (function &key area) + (setq area (cond ((or (eq area t) (eq area nil)) nil) + ((consp area) (mapcar #'heap-area-code area)) + (t (list (heap-area-code area))))) + (loop for area-ptr = (core-q (core-q (kernel-global-address 'all-areas)) target::area.succ) + then (core-q area-ptr target::area.succ) + as code = (ash (core-q area-ptr target::area.code) (- target::fixnum-shift)) + until (= code area-void) + do (when (and (<= area-readonly code) + (<= code area-dynamic) + (or (null area) (member code area)) + (< (core-q area-ptr target::area.low) (core-q area-ptr target::area.active))) + #+debug + (format t "~& AREA at x~x, type = ~a low = x~x active = x~x (size = x~x out of x~x)" + area-ptr (core-area-name code) + (core-q area-ptr target::area.low) + (core-q area-ptr target::area.active) + (- (core-q area-ptr target::area.active) (core-q area-ptr target::area.low)) + (- (core-q area-ptr target::area.high) (core-q area-ptr target::area.low))) + (map-core-area area-ptr function)))) + +(defun map-core-area (area-ptr fun) + (let* ((ptr (core-q area-ptr target::area.low)) + (end (core-q area-ptr target::area.active))) + (loop + (when (>= ptr end) (return)) + (let ((header (core-q ptr))) + (cond ((uvheader-p header) + (let ((subtag (uvheader-typecode header))) + (funcall fun + (+ ptr (cond ((eq subtag target::subtag-symbol) target::fulltag-symbol) + ((eq subtag target::subtag-function) target::fulltag-function) + (t target::fulltag-misc))))) + (let* ((bytes (uvheader-byte-size header)) + (total (logandc2 (%i+ bytes (+ target::node-size (1- target::dnode-size))) + (1- target::dnode-size)))) + (declare (fixnum bytes total)) + (incf ptr total))) + (t + (funcall fun (+ ptr target::fulltag-cons)) + (incf ptr target::cons.size))))))) + + +(declaim (inline core-consp core-symbolp core-functionp core-listp core-nullp)) + +(defun core-consp (ptr) + (eq (logand ptr target::fulltagmask) target::fulltag-cons)) + +(defun core-symbolp (ptr) + (eq (logand ptr target::fulltagmask) target::fulltag-symbol)) + +(defun core-functionp (ptr) + (eq (logand ptr target::fulltagmask) target::fulltag-function)) + +(defun core-listp (ptr) + (eq (logand ptr target::tagmask) target::tag-list)) + +(defun core-nullp (obj) + (eq (logand obj target::fulltagmask) target::fulltag-nil)) + +;; uvector utilities +(declaim (inline core-uvector-p core-uvheader core-uvtypecode core-uvtype)) + +(defun core-uvector-p (ptr) + (%i>= (logand ptr target::fulltagmask) target::fulltag-misc)) + +(defun core-uvheader (vec-ptr) + (core-q (logandc2 vec-ptr target::fulltagmask))) + +(defun core-uvtypecode (vec-ptr) + (uvheader-typecode (core-uvheader vec-ptr))) + +(defun core-uvtype (vec-ptr) + (uvheader-type (core-uvheader vec-ptr))) + +(defmacro core-uvtypep (vec-ptr type &aux temp) + (when (keywordp type) + (setq type (type-keyword-code type))) + (when (and (or (symbolp (setq temp type)) + (and (quoted-form-p type) + (symbolp (setq temp (cadr type))))) + (setq temp (find-symbol (symbol-name temp) :ccl)) + (setq temp (uvheader-type-typecode temp))) + (setq type temp)) + (when (constant-symbol-p type) + (setq temp (symbol-value type)) + (when (<= 0 temp #xFF) (setq type temp))) + `(let ((vec-ptr ,vec-ptr)) + (and (core-uvector-p vec-ptr) + (eq (core-uvtypecode vec-ptr) ,type)))) + +(defun core-uvref (vec-ptr index) + (let* ((header (core-uvheader vec-ptr)) + (addr (+ (logandc2 vec-ptr target::fulltagmask) target::node-size)) + (typecode (uvheader-typecode header)) + (tag (logand typecode target::fulltagmask)) + (len (uvheader-size header))) + (assert (< -1 index len)) + (cond ((or (eql tag target::fulltag-nodeheader-0) + (eql tag target::fulltag-nodeheader-1)) + (core-q addr (ash index target::word-shift))) + ((eql tag target::ivector-class-64-bit) + (cond ((eq typecode target::subtag-double-float-vector) + (error "~s not implemented yet" 'target::subtag-double-float-vector)) + (t + (core-q addr (ash index target::word-shift))))) + ((eq tag target::ivector-class-32-bit) + (cond ((eq typecode target::subtag-simple-base-string) + (code-char (core-l addr (ash index 2)))) + ((eq typecode target::subtag-single-float-vector) + (error "~s not implemented yet" 'target::subtag-single-float-vector)) + (t (core-l addr (ash index 2))))) + ((eq typecode target::subtag-bit-vector) + (let ((byte (core-b addr (ash (+ index 7) -3)))) + (error "not implemented, for ~b" byte))) + ((>= typecode target::min-8-bit-ivector-subtag) + (core-b addr index)) + (t (core-w addr (ash index 1)))))) + +(defun core-uvsize (vec-ptr) + (uvheader-size (core-uvheader vec-ptr))) + +(defun core-car (obj) + (assert (core-listp obj)) + (core-q obj target::cons.car)) + +(defun core-cdr (obj) + (assert (core-listp obj)) + (core-q obj target::cons.cdr)) + +(defun core-object-type (obj) + (let ((fulltag (logand obj target::fulltagmask))) + (cond ((eq fulltag target::fulltag-cons) 'cons) + ((eq fulltag target::fulltag-nil) 'null) + ((eq (logand fulltag target::tagmask) target::tag-fixnum) 'fixnum) + ((and (or (eq fulltag target::fulltag-imm-0) + (eq fulltag target::fulltag-imm-1)) + (fixnump obj)) + ;; Assumes we're running on same architecture as core file. + (type-of (%%raw-obj obj))) + ((eq (logand fulltag target::tagmask) target::tag-tra) 'tagged-return-address) + ((eq fulltag target::fulltag-misc) (core-uvtype obj)) + ((eq fulltag target::fulltag-symbol) 'symbol) + ;; TODO: Could get hairier based on lfun-bits, but usually don't care. + ((eq fulltag target::fulltag-function) 'function) + (t (cerror "treat as ~*~s" "Invalid object tag at #x~x" obj 'bogus) + 'bogus)))) + +(defun core-istruct-type (obj) + (and (core-uvtypep obj :istruct) + (core-car (core-uvref obj 0)))) + + +(defun core-object-type-and-size (obj) + (let ((fulltag (logand obj target::fulltagmask))) + (if (eq fulltag target::fulltag-cons) + (values 'cons target::dnode-size target::dnode-size) + (if (%i<= target::fulltag-misc fulltag) + (let* ((header (core-uvheader obj)) + (logsize (uvheader-byte-size header)) + ;; total including header and alignment. + (total (logandc2 (+ logsize target::node-size (1- target::dnode-size)) + (1- target::dnode-size)))) + (values (uvheader-type header) logsize total)))))) + +(defun core-heap-utilization (&key area unit sort) + (let* ((hash (make-hash-table :shared nil)) + (total-physsize 0) + (div (ecase unit + ((nil) 1) + (:kb 1024.0d0) + (:mb (* 1024.0d0 1024.0d0)) + (:gb (* 1024.0d0 1024.0d0 1024.0d0)))) + (sort-key (ecase sort + (:count #'cadr) + (:logical-size #'caddr) + ((:physical-size nil) #'cdddr))) + (all nil)) + (map-core-areas (lambda (obj) + (multiple-value-bind (type logsize physsize) (core-object-type-and-size obj) + (let ((a (or (gethash type hash) + (setf (gethash type hash) (list* 0 0 0))))) + (incf (car a)) + (incf (cadr a) logsize) + (incf (cddr a) physsize)))) + :area area) + (maphash (lambda (type data) + (incf total-physsize (cddr data)) + (push (cons type data) all)) + hash) + (setq all (sort all #'> :key sort-key)) + (format t "~&Object type~42tCount Logical size Physical size % of Heap~%~50t~a~66t~:*~a" + (ecase unit + ((nil) " (in bytes)") + (:kb "(in kilobytes)") + (:mb "(in megabytes)") + (:gb "(in gigabytes)"))) + (loop for (type count logsize . physsize) in all + do (if unit + (format t "~&~a~36t~11d~16,2f~16,2f~11,2f%" + type + count + (/ logsize div) + (/ physsize div) + (* 100.0 (/ physsize total-physsize))) + (format t "~&~a~36t~11d~16d~16d~11,2f%" + type + count + logsize + physsize + (* 100.0 (/ physsize total-physsize))))) + (if unit + (format t "~&Total~63t~16,2f" (/ total-physsize div)) + (format t "~&Total~63t~16d" total-physsize))) + (values)) + + +(defstruct unresolved-address address) + +(defmethod print-object ((obj unresolved-address) stream) + (let* ((address (unresolved-address-address obj))) + (format stream "#" + (core-object-type address) + (and (core-uvector-p address) (core-uvsize address)) + address))) + +(defun copy-from-core (obj &key (depth 1)) + (check-type depth (integer 0)) + (when (unresolved-address-p obj) + (setq obj (unresolved-address-address obj))) + (let ((fulltag (logand obj target::fulltagmask))) + (cond ((eq fulltag target::fulltag-nil) nil) + ((eq (logand fulltag target::tagmask) target::tag-fixnum) + (ash obj (- target::fixnum-shift))) + ((and (fixnump obj) + (or (eq fulltag target::fulltag-imm-0) + (eq fulltag target::fulltag-imm-1))) + (%%raw-obj obj)) + ((< (decf depth) 0) + (make-unresolved-address :address obj)) + ((%i<= target::fulltag-misc fulltag) + (or (and (core-uvtypep obj :package) + (find-package (core-package-name obj))) + (let ((v (%copy-uvector-from-core obj depth))) + (when (and (symbolp v) (<= depth 1)) + ;; Need to fix up the package slot else it's not useful + (let ((pp (%svref (symptr->symvector v) target::symbol.package-predicate-cell))) + (when (unresolved-address-p pp) + (setq pp (copy-from-core pp :depth 1))) + (when (and (consp pp) (unresolved-address-p (car pp))) + (let ((pkg (unresolved-address-address (car pp)))) + (when (and (core-uvtypep pkg :package) + (setq pkg (find-package (core-package-name pkg)))) + (setf (car pp) pkg)))) + (setf (%svref (symptr->symvector v) target::symbol.package-predicate-cell) pp)) + ;; ditto for pname + (let ((pp (%svref (symptr->symvector v) target::symbol.pname-cell))) + (when (unresolved-address-p pp) + (setf (%svref (symptr->symvector v) target::symbol.pname-cell) + (copy-from-core pp :depth 1))))) + v))) + ((eq fulltag target::fulltag-cons) + (cons (copy-from-core (core-car obj) :depth depth) + (copy-from-core (core-cdr obj) :depth depth))) + (t (make-unresolved-address :address obj))))) + +(defun %copy-uvector-from-core (vec-ptr depth) + (let* ((header (core-uvheader vec-ptr)) + (addr (+ (logandc2 vec-ptr target::fulltagmask) target::node-size)) + (typecode (uvheader-typecode header)) + (tag (logand typecode target::fulltagmask)) + (len (uvheader-size header)) + (vec (%alloc-misc len typecode))) + (cond ((or (eq tag target::fulltag-nodeheader-0) + (eq tag target::fulltag-nodeheader-1)) + (when (eql typecode target::subtag-function) + ;; Don't bother copying the code for now + (let ((skip (core-l addr))) + (assert (<= 0 skip len)) + (incf addr (ash skip target::word-shift)) + (decf len skip))) + (dotimes (i len) + (setf (%svref vec i) + (copy-from-core (core-q addr (ash i target::word-shift)) :depth depth))) + (let ((ptrtag (logand vec-ptr target::fulltagmask))) + (cond ((eql ptrtag target::fulltag-symbol) + (%symvector->symptr vec)) + ((eql ptrtag target::fulltag-function) + (%function-vector-to-function vec)) + (t vec)))) + ((eq tag target::ivector-class-64-bit) + (cond ((eq typecode target::subtag-double-float-vector) + (warn "~s not implemented yet" 'target::subtag-double-float-vector) + (make-unresolved-address :address vec-ptr)) + (t + (dotimes (i len vec) + (setf (uvref vec i) (core-q addr (ash i target::word-shift))))))) + ((eq tag target::ivector-class-32-bit) + (cond ((eq typecode target::subtag-simple-base-string) + (dotimes (i len vec) + (setf (uvref vec i) (code-char (core-l addr (ash i 2)))))) + ((eq typecode target::subtag-single-float-vector) + (warn "~s not implemented yet" 'target::subtag-single-float-vector) + (make-unresolved-address :address vec-ptr)) + (t + (dotimes (i len vec) + (setf (uvref vec i) (core-l addr (ash i 2))))))) + ((eq typecode target::subtag-bit-vector) + (warn "bit vector not implemented yet") + (make-unresolved-address :address vec-ptr)) + ((>= typecode target::min-8-bit-ivector-subtag) + (dotimes (i len vec) + (setf (uvref vec i) (core-b addr i)))) + (t + (dotimes (i len vec) + (setf (uvref vec i) (core-w addr (ash i 1)))))))) + +(defun map-core-pointers (fn &key area) + (map-core-areas (lambda (obj) + (cond ((core-consp obj) + (funcall fn (core-car obj) obj 0) + (funcall fn (core-cdr obj) obj 1)) + (t + (let* ((header (core-uvheader obj)) + (subtag (logand header target::fulltagmask))) + (when (or (eq subtag target::fulltag-nodeheader-0) + (eq subtag target::fulltag-nodeheader-1)) + (let* ((typecode (uvheader-typecode header)) + (len (uvheader-size header)) + (addr (+ (logandc2 obj target::fulltagmask) target::node-size))) + (when (eql typecode target::subtag-function) + (let ((skip (core-l addr))) + (assert (<= 0 skip len)) + (incf addr (ash skip target::word-shift)) + (decf len skip))) + (dotimes (i len) + (funcall fn (core-q addr (ash i target::word-shift)) obj i)))))))) + :area area)) + +(defun core-find-tra-function (tra) + (assert (eq (logand tra target::tagmask) target::tag-tra)) + (map-core-areas (lambda (obj) + (when (core-uvtypep obj :function) + (let* ((addr (+ (logandc2 obj target::fulltagmask) target::node-size)) + (skip (core-l addr)) + (offset (- tra addr))) + (when (<= 0 offset (ash skip target::word-shift)) + (return-from core-find-tra-function (values obj (+ offset (- target::node-size + (logand obj target::fulltagmask))))))))))) + +(defun core-instance-class (obj) + (when (core-uvtypep obj :slot-vector) + (setq obj (core-uvref obj slot-vector.instance))) + (assert (core-uvtypep obj :instance)) + (core-uvref (core-uvref obj instance.class-wrapper) %wrapper-class)) + +(defun core-instance-p (obj class) + (and (core-uvtypep obj :instance) + (labels ((matchp (iclass) + (or (eql iclass class) + (loop for supers = (core-uvref (core-uvref iclass instance.slots) %class.local-supers) + then (core-cdr supers) + while (core-consp supers) + thereis (matchp (core-car supers)))))) + (matchp (core-instance-class obj))))) + + +(defun core-instance-class-name (obj) + (let* ((class (core-instance-class obj)) + (class-slots (core-uvref class instance.slots)) + (name (core-uvref class-slots %class.name))) + (core-symbol-name name))) + +(defun core-symptr (obj) + (if (core-nullp obj) + (nil-relative-symbol-address 'nil) + (when (core-uvtypep obj :symbol) + (let ((tag (logand obj target::fulltagmask))) + (unless (eq tag target::fulltag-symbol) + (incf obj (%i- target::fulltag-symbol tag)))) + obj))) + +(defun core-symbol-name (obj) + (when (setq obj (core-symptr obj)) + (copy-from-core (core-q obj target::symbol.pname) :depth 1))) + +(defun core-symbol-value (obj) + (when (setq obj (core-symptr obj)) + (core-q obj target::symbol.vcell))) + +(defun core-symbol-package (obj) + (when (setq obj (core-symptr obj)) + (let ((cell (core-q obj target::symbol.package-predicate))) + (if (core-consp cell) + (core-car cell) + cell)))) + +(defun core-all-packages-ptr () + (core-symbol-value (nil-relative-symbol-address '%all-packages%))) + +(defun core-keyword-package () + (core-symbol-value (nil-relative-symbol-address '*keyword-package*))) + +(defun core-symbol-pointers () + (or (core-info-symbol-ptrs (current-core)) + (let ((vector (make-array 1000 :adjustable t :fill-pointer 0)) + (keys (core-keyword-package))) + (map-core-areas (lambda (obj) + (when (core-symbolp obj) + (unless (eq (core-symbol-package obj) keys) + (vector-push-extend obj vector))))) + (setf (core-info-symbol-ptrs (current-core)) vector)))) + +(defun core-map-symbols (fun) + (loop for sym-ptr across (core-symbol-pointers) do (funcall fun sym-ptr))) + + +(defun core-string-equal (ptr string &aux (len (length string))) + (assert (core-uvtypep ptr :simple-string)) + (when (eq (core-uvsize ptr) len) + (loop for i from 0 below len + always (eql (core-uvref ptr i) (aref string i))))) + +(defun core-find-package (name &key error) + (setq name (string name)) + (or (loop for list-ptr = (core-all-packages-ptr) then (core-cdr list-ptr) + while (core-consp list-ptr) + as pkg-ptr = (core-car list-ptr) + when (loop for names-ptr = (core-uvref pkg-ptr pkg.names) then (core-cdr names-ptr) + while (core-consp names-ptr) + as name-ptr = (core-car names-ptr) + thereis (core-string-equal name-ptr name)) + do (return pkg-ptr)) + (and error (error "No package named ~s" name)))) + +(defun core-package-names (pkg-ptr) + (assert (core-uvtypep pkg-ptr :package)) + (copy-from-core (core-uvref pkg-ptr pkg.names) :depth 2)) + +(defun core-package-name (pkg-ptr) + (assert (core-uvtypep pkg-ptr :package)) + (copy-from-core (core-car (core-uvref pkg-ptr pkg.names)) :depth 1)) + +(defun core-find-symbol (name &optional (package (symbol-package name))) + ;; Unlike the real cl:find-symbol, this doesn't look for inherited symbols, + ;; you have to get the package right. + (let* ((symbol-name (string name)) + (name-len (length symbol-name)) + (pkg-ptr (if (integerp package) + package + (core-find-package (if (packagep package) + (package-name package) + (string package)) + :error t)))) + (assert (core-uvtypep pkg-ptr :package)) + (multiple-value-bind (primary secondary) (hash-pname symbol-name name-len) + (flet ((findsym (htab-ptr) + (let* ((vec-ptr (core-car htab-ptr)) + (vlen (core-uvsize vec-ptr))) + (loop for idx = (fast-mod primary vlen) then (+ i secondary) + for i = idx then (if (>= idx vlen) (- idx vlen) idx) + as sym = (core-uvref vec-ptr i) + until (eql sym 0) + do (when (and (core-symbolp sym) + (core-string-equal (core-q sym target::symbol.pname) symbol-name)) + (return (if (eq sym (nil-relative-symbol-address 'nil)) + (target-nil-value) + sym))))))) + (or (findsym (core-uvref pkg-ptr pkg.itab)) + (findsym (core-uvref pkg-ptr pkg.etab))))))) + +(defun core-gethash (key-ptr hash-ptr) + (when (core-uvtypep hash-ptr :istruct) + (setq hash-ptr (core-uvref hash-ptr nhash.vector))) + (assert (core-uvtypep hash-ptr :hash-vector)) + (loop for i from $nhash.vector_overhead below (core-uvsize hash-ptr) by 2 + do (when (eq (core-uvref hash-ptr i) key-ptr) + (return (core-uvref hash-ptr (1+ i)))))) + +(defun core-hash-table-count (hash-ptr) + (when (core-uvtypep hash-ptr :istruct) + (setq hash-ptr (core-uvref hash-ptr nhash.vector))) + (assert (core-uvtypep hash-ptr :hash-vector)) + (loop with rehashing = (%fixnum-address-of (%slot-unbound-marker)) + with free = (%fixnum-address-of (%unbound-marker)) + for i from $nhash.vector_overhead below (core-uvsize hash-ptr) by 2 + count (let ((value (core-uvref hash-ptr (1+ i)))) + (when (eq value rehashing) + (error "This table is being rehashed")) + (neq value free)))) + +(defun core-classes-hash-table-ptr () + (or (core-info-classes-hash-table-ptr (current-core)) + (setf (core-info-classes-hash-table-ptr (current-core)) + (core-symbol-value (core-find-symbol '%find-classes%))))) + +(defun core-find-class (name) + (let* ((name-ptr (etypecase name + (integer + (assert (core-symbolp name)) + name) + (symbol (core-find-symbol name)))) + (hash-ptr (core-classes-hash-table-ptr)) + (cell (core-gethash name-ptr hash-ptr)) + (class (and cell (core-uvref cell class-cell-class)))) + (and class (core-uvtypep class :instance) class))) + +(defun core-lfun-names-table-ptr () + (or (core-info-lfun-names-table-ptr (current-core)) + (setf (core-info-lfun-names-table-ptr (current-core)) + (core-symbol-value (core-find-symbol '*lfun-names*))))) + +(defun core-closure-function (fun) + (while (and (core-functionp fun) + (logbitp $lfbits-trampoline-bit (core-lfun-bits fun))) + (let* ((addr (+ (logandc2 fun target::fulltagmask) target::node-size))) + (setq fun (core-q addr (ash (core-l addr) target::word-shift))) + (when (core-uvtypep fun :simple-vector) + (setq fun (core-uvref fun 0))) + #+gz (assert (core-functionp fun)))) + fun) + + +(defun core-lfun-name (fn) + (assert (core-functionp fn)) + (flet ((lfun-name (fn) + (or (core-gethash fn (core-lfun-names-table-ptr)) + (let* ((lfbits (core-lfun-bits fn)) + (name (if (and (logbitp $lfbits-gfn-bit lfbits) + (not (logbitp $lfbits-method-bit lfbits))) + (core-uvref (core-uvref fn gf.slots) sgf.name) + (unless (logbitp $lfbits-noname-bit lfbits) + (core-uvref fn (- (core-uvsize fn) 2)))))) + (and name + (not (eql name (%fixnum-address-of (%slot-unbound-marker)))) + (not (core-nullp name)) + name))))) + (or (lfun-name fn) + (let ((inner-fn (core-closure-function fn))) + (and (core-functionp inner-fn) + (not (eql inner-fn fn)) + (lfun-name inner-fn)))))) + +(defun core-list (ptr) + (let ((cars (loop while (core-consp ptr) + collect (core-car ptr) + do (setq ptr (core-cdr ptr))))) + (if (core-nullp ptr) + cars + (nconc cars ptr)))) + +(defun core-all-processes () + (let* ((sym (core-find-symbol 'all-processes)) + (closure (core-uvref sym target::symbol.fcell-cell)) + (imm-start (core-l (logandc2 closure target::fulltagmask) target::node-size)) + (imm-end (core-uvsize closure)) + (vcell (loop for idx from (1+ imm-start) below imm-end as imm = (core-uvref closure idx) + when (core-uvtypep imm :value-cell) return imm)) + (val (core-uvref vcell target::value-cell.value-cell)) + (processes (core-list val))) + processes)) + +(defun core-process-name (proc) + (assert (core-uvtypep proc :instance)) + (let ((slots (core-uvref proc ccl::instance.slots))) + (copy-from-core (core-uvref slots 1) :depth 1))) + +(defun core-process-tcr (proc) + (assert (core-uvtypep proc :instance)) + (let* ((slots (core-uvref proc ccl::instance.slots)) + (thread (core-uvref slots 2))) + (core-uvref thread ccl::lisp-thread.tcr))) + +(defun core-find-process-for-id (lwp) + (loop for proc in (core-all-processes) + when (eql lwp (core-q (core-process-tcr proc) target::tcr.native-thread-id)) + return proc)) + +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; + +(defun core-process-class () + (or (core-info-process-class (current-core)) + (setf (core-info-process-class (current-core)) + (core-find-class 'process)))) + +(defun core-print (obj &optional (stream t) depth) + ;; TODO: could dispatch on core-object-type... + (cond ((core-nullp obj) (format stream "NIL")) + ((core-symbolp obj) + (core-print-symbol obj stream)) + ((core-uvtypep obj :function) + (core-print-function obj stream)) + ((core-instance-p obj (core-process-class)) + (core-print-process obj stream)) + ((and depth (< (decf depth) 0)) + (format stream "x~x" obj)) + ((core-consp obj) + (loop for sep = "(" then " " + for i from 0 below (or *print-length* 100) + while (core-consp obj) + do (format stream sep) + do (core-print (core-car obj) stream depth) + do (setq obj (core-cdr obj))) + (unless (core-nullp obj) + (format stream " . ") + (core-print obj stream depth)) + (format stream ")")) + (t (format stream "#" + (core-object-type obj) obj)))) + +(defun core-print-symbol (sym stream) + (let ((package (core-symbol-package sym))) + (cond ((core-nullp package) + (format stream "#:")) + ((eq package (core-keyword-package)) + (format stream ":")) + (t (let ((pkgname (core-package-name package))) + (unless (string-equal pkgname "COMMON-LISP") + (format stream "~a::" pkgname))))) + (format stream "~a" (core-symbol-name sym)))) + +(defun core-lfun-bits (fun) + (ash (core-uvref fun (1- (core-uvsize fun))) (- target::fixnum-shift))) + +(defun core-print-function (fun stream) + (let* ((lfbits (core-lfun-bits fun)) + (name (core-lfun-name fun))) + (format stream "#<") + (cond ((or (null name) (core-nullp name)) + (format stream "Anonymous function")) + ((logbitp $lfbits-method-bit lfbits) + (assert (core-uvtypep name :instance)) + (let* ((slot-vector (core-uvref name instance.slots)) + (method-qualifiers (core-uvref slot-vector %method.qualifiers)) + (method-specializers (core-uvref slot-vector %method.specializers)) + (method-name (core-uvref slot-vector %method.name))) + (format stream "Method-Function ") + (core-print method-name stream) + (format stream " ") + (unless (core-nullp method-qualifiers) + (if (core-nullp (core-cdr method-qualifiers)) + (core-print (core-car method-qualifiers) stream) + (core-print method-qualifiers stream)) + (format stream " ")) + ;; print specializer list but print names instead of classes. + (loop for sep = "(" then " " + while (core-consp method-specializers) + do (format stream sep) + do (let ((spec (core-car method-specializers))) + (if (core-uvtypep spec :instance) + (core-print (core-uvref (core-uvref spec instance.slots) %class.name) stream) + (core-print spec stream))) + do (setq method-specializers (core-cdr method-specializers))) + (unless (core-nullp method-specializers) + (format stream " . ") + (core-print method-specializers stream)) + (format stream ")"))) + (t + (if (logbitp $lfbits-gfn-bit lfbits) + (format stream "Generic Function ") + (format stream "Function ")) + (core-print name stream))) + (format stream " x~x>" fun))) + +(defun core-print-process (proc stream) + (format stream "#<~a ~s LWP(~d) #x~x>" + (core-instance-class-name proc) + (core-process-name proc) + (core-q (core-process-tcr proc) target::tcr.native-thread-id) + proc)) + +(defun dwim-core-frame-pointer (tcr &optional end) + (let* ((ret1valn (core-q (kernel-global-address 'ret1valaddr))) + (lexprs (list (core-q (kernel-global-address 'lexpr-return)) + (core-q (kernel-global-address 'lexpr-return1v)))) + (stack-area (core-q tcr target::tcr.vs-area)) + (fp (core-q stack-area target::area.high)) + (low (core-q stack-area target::area.low))) + (flet ((validp (pp) + (let ((tra (core-q pp target::lisp-frame.return-address))) + (when (eql tra ret1valn) + (setq tra (core-q pp target::lisp-frame.xtra))) + (or (eql (logand tra target::tagmask) target::tag-tra) + (eql tra 0) + (member tra lexprs))))) + (decf fp (* 2 target::node-size)) + (when (and end (<= low end fp)) + (setq low (- end 8))) + (loop while + (loop for pp downfrom (- fp target::node-size) above low by target::node-size + do (when (eql (core-q pp target::lisp-frame.backptr) fp) + (when (validp pp) + (return (setq fp pp)))))) + fp))) + +(defun core-stack-frame-values (tcr fp) + (let* ((bottom (core-q fp target::lisp-frame.backptr)) + (top (if (eql 0 (core-q fp target::lisp-frame.return-address)) + (+ fp target::xcf.size) + (+ fp (if (eql (core-q fp target::lisp-frame.return-address) + (core-q (kernel-global-address 'ret1valaddr))) + target::lisp-frame.size + target::lisp-frame.xtra)))) + (db-link (loop as db = (core-q tcr target::tcr.db-link) then (core-q db) + until (or (eql db 0) (>= db bottom)) + when (<= top db) return db))) + (loop for vsp from top below bottom by target::node-size + when (eql vsp db-link) + ;; The db-link will be followed by var and val, which we'll just collect normally + do (setq db-link (core-q db-link) vsp (+ vsp target::node-size)) + and collect `(:db-link ,db-link) + collect (core-q vsp)))) + +(defun core-print-call-history (process &key (stream t) origin detailed-p) + (flet ((fp-backlink (fp vs-end) + (let ((backlink (core-q fp target::lisp-frame.backptr))) + (when (or (eql backlink 0) + (<= vs-end backlink) + (<= vs-end (core-q backlink target::lisp-frame.backptr))) + (setq backlink vs-end)) + (assert (< fp backlink)) + backlink)) + (fp-tra (fp) + (let ((tra (core-q fp target::lisp-frame.return-address))) + (if (eql tra (core-q (kernel-global-address 'ret1valaddr))) + (core-q fp target::lisp-frame.xtra) + tra))) + (recover-fn (pc) + (when (and (eql (logand pc target::tagmask) target::tag-tra) + (eql (core-w pc) target::recover-fn-from-rip-word0) + (eql (core-b pc 2) target::recover-fn-from-rip-byte2)) + (+ pc target::recover-fn-from-rip-length + (- (core-l pc target::recover-fn-from-rip-disp-offset) + #x100000000))))) + (format stream "~&") + (core-print process stream) + (let* ((tcr (core-process-tcr process)) + (vs-area (core-q tcr target::tcr.vs-area)) + (vs-end (core-q vs-area target::area.high)) + (valence (core-q tcr target::tcr.valence)) + (fp (or origin + ;; TODO: find the registers in the core file! + (case valence + ;; TCR_STATE_LISP + (0 (let ((xp (core-q tcr target::tcr.suspend-context))) + (format stream "~&") + (if (eql xp 0) + (format stream "Unknown lisp context, guessing frame pointer:") + (core-print (core-q xp (* 10 target::node-size)) stream)) ;; r13 = fn + (if (eql xp 0) + (dwim-core-frame-pointer tcr) + ;; uc_mcontext.gregs[rbp] + (core-q xp (* 15 target::node-size))))) + ;; TCR_STATE_FOREIGN + (1 (format stream "~&In foreign code") + ;; the save-rbp seems to include some non-lisp frames sometimes, + ;; shave them down. + #+no (core-q tcr target::tcr.save-rbp) + (dwim-core-frame-pointer tcr (core-q tcr target::tcr.save-rbp))) + ;; TCR_STATE_EXCEPTION_WAIT + (2 (let ((xp (core-q tcr target::tcr.pending-exception-context))) + ;; regs start at index 5, in this order: + ;; arg_x temp1 ra0 save3 save2 fn save1 save0 arg_y arg_z + ;; rbp temp0 imm1 imm0 nargs rsp rip + (format stream " exception-wait") + (if (zerop xp) + (format stream "~&context unknown") + (let* ((fn (core-q xp (* 10 target::node-size))) + (sp (core-q xp (* 20 target::node-size))) + (ra (core-q sp))) + (if (and (core-functionp fn) + (and (<= fn ra) + (< ra (+ fn (* (core-uvsize fn) target::node-size))))) + (progn + (format stream "~&") + (core-print fn stream) + (format stream " + ~d" (- ra fn))) + (progn + (format stream "~&top of stack = x~x, r13 = " ra) + (core-print fn stream))))) + (unless (zerop xp) + (core-q xp (* 15 target::node-size)))))) + (error "Cannot find frame pointer")))) + (unless (<= (core-q vs-area target::area.low) fp vs-end) + (error "frame pointer x~x is not in stack area" fp)) + (loop while (< fp vs-end) for pc = (fp-tra fp) for fun = (recover-fn pc) + do (format stream "~&fp: x~x pc: x~x : " fp pc) + do (cond (fun + (core-print fun stream) + (format stream " + ~d " (- pc fun))) + ((eql pc 0) ;; exception frame + (let* ((nominal-function (core-q fp target::xcf.nominal-function)) + (obj (core-q fp target::xcf.containing-object))) + (when (core-functionp nominal-function) + (format stream "exception ") + (core-print nominal-function stream) + (format stream " + ~d" + (if (eq (- obj target::fulltag-misc) + (- nominal-function target::fulltag-function)) + (- (core-q fp target::xcf.relative-pc) target::tag-function) + (let ((pc (core-q fp target::xcf.ra0))) + (when (eql nominal-function (recover-fn pc)) + (- pc nominal-function)))))))) + ((eql pc (core-q (kernel-global-address 'lexpr-return))) + (format stream "lexpr return")) + ((eql pc (core-q (kernel-global-address 'lexpr-return1v))) + (format stream "lexpr1v return")) + (t + (if (eql (logand pc target::tagmask) target::tag-tra) + (format stream " # couldn't recover function") + (unless (core-nullp pc) + (format stream "bad frame!"))) + ;; can't trust backlink + (return))) + ;; TODO: print stack addressses + do (when detailed-p + (loop for val in (core-stack-frame-values tcr fp) + do (format stream "~& ") + do (if (integerp val) + (handler-case (core-print val stream) + (error () (format stream "#" val))) + (format stream "~a x~x" (car val) (cadr val))))) + do (setq fp (fp-backlink fp vs-end)))))) + + +) ; :x8664-target Index: /branches/new-random/library/cover.lisp =================================================================== --- /branches/new-random/library/cover.lisp (revision 13309) +++ /branches/new-random/library/cover.lisp (revision 13309) @@ -0,0 +1,856 @@ +;;;-*-Mode: LISP; Package: CCL -*- +;;; +;;; Copyright (C) 2008-2009 Clozure Associates +;;; This file is part of Clozure CL. +;;; +;;; Clozure CL is licensed under the terms of the Lisp Lesser GNU Public +;;; License , known as the LLGPL and distributed with Clozure CL as the +;;; file "LICENSE". The LLGPL consists of a preamble and the LGPL, +;;; which is distributed with Clozure CL as the file "LGPL". Where these +;;; conflict, the preamble takes precedence. +;;; +;;; Clozure CL is referenced in the preamble as the "LIBRARY." +;;; +;;; The LLGPL is also available online at +;;; http://opensource.franz.com/preamble.html + +;;; Code coverage reporting facility, originally inspired by SBCL's sb-cover API. + +(in-package :ccl) + +(export '(*compile-code-coverage* + report-coverage + reset-coverage + clear-coverage + save-coverage-in-file + restore-coverage-from-file + + save-coverage + restore-coverage + combine-coverage + read-coverage-from-file + write-coverage-to-file + + coverage-statistics + coverage-source-file + coverage-expressions-total + coverage-expressions-entered + coverage-expressions-covered + coverage-unreached-branches + coverage-code-forms-total + coverage-code-forms-covered + coverage-functions-total + coverage-functions-fully-covered + coverage-functions-partly-covered + coverage-functions-not-entered + + without-compiling-code-coverage)) + +(defconstant $not-executed-style 2) +(defconstant $totally-covered-style 5) +(defconstant $partially-covered-style 6) + +(defparameter *file-coverage* ()) +(defparameter *coverage-subnotes* (make-hash-table :test #'eq)) +(defparameter *emitted-code-notes* (make-hash-table :test #'eq)) +(defparameter *entry-code-notes* (make-hash-table :test #'eq)) + + +(defstruct (coverage-state (:conc-name "%COVERAGE-STATE-")) + alist) + +;; Wrapper in case we ever want to do dwim on raw alists +(defun coverage-state-alist (coverage) + (etypecase coverage + (coverage-state (%coverage-state-alist coverage)))) + + +(defun file-coverage-file (entry) + (car entry)) + +(defun file-coverage-functions (entry) + (cadr entry)) + +(defun file-coverage-toplevel-functions (entry) + (cddr entry)) + +(defun coverage-subnotes (note) ;; reversed parent chain + (gethash note *coverage-subnotes*)) + +(defun emitted-code-note-p (note) + (gethash note *emitted-code-notes*)) + +(defun entry-code-note-p (note) + (gethash note *entry-code-notes*)) + +(defun map-function-coverage (lfun fn &optional refs) + (let ((refs (cons lfun refs))) + (declare (dynamic-extent refs)) + (lfunloop for imm in lfun + when (code-note-p imm) + do (funcall fn imm) + when (and (functionp imm) + (not (memq imm refs))) + do (map-function-coverage imm fn refs)))) + +(defun get-function-coverage (fn refs) + (let ((entry (function-entry-code-note fn)) + (refs (cons fn refs))) + (declare (dynamic-extent refs)) + (when entry + (assert (eq fn (gethash entry *entry-code-notes* fn))) + (setf (gethash entry *entry-code-notes*) fn)) + (nconc + (and entry (list fn)) + (lfunloop for imm in fn + when (code-note-p imm) + do (setf (gethash imm *emitted-code-notes*) t) + when (and (functionp imm) + (not (memq imm refs))) + nconc (get-function-coverage imm refs))))) + +(defun get-coverage () + (setq *file-coverage* nil) + (clrhash *coverage-subnotes*) + (clrhash *emitted-code-notes*) + (clrhash *entry-code-notes*) + (loop for data in *code-covered-functions* + when (consp data) + do (destructuring-bind (file . toplevel-functions) data + (push (list* file + ;; Duplicates are possible if you have multiple instances of + ;; (load-time-value (foo)) where (foo) returns an lfun. + ;; CL-PPCRE does that. + (delete-duplicates + (loop for fn across toplevel-functions + nconc (get-function-coverage fn nil))) + toplevel-functions) + *file-coverage*))) + ;; Now get subnotes, including un-emitted ones. + (loop for note being the hash-key of *emitted-code-notes* + do (loop for n = note then parent as parent = (code-note-parent-note n) + while parent + do (pushnew n (gethash parent *coverage-subnotes*)) + until (emitted-code-note-p parent)))) + +#+debug +(defun show-notes (note) + (when (functionp note) + (setq note (function-entry-code-note note))) + (labels ((show (note indent label) + (dotimes (i indent) (write-char #\space)) + (format t "~a ~a" label note) + (unless (emitted-code-note-p note) + (format t " [Not Emitted]")) + (when (entry-code-note-p note) + (format t " (Entry to ~s)" (entry-code-note-p note))) + (format t "~%") + (when (code-note-p note) + (loop with subindent = (+ indent 3) + for sub in (coverage-subnotes note) as i upfrom 1 + do (show sub subindent (format nil "~a~d." label i)))))) + (show note 0 ""))) + +(defun assoc-by-filename (path alist) + (let* ((true-path (probe-file path))) + (find-if #'(lambda (data) + (or (equalp (car data) path) + (and true-path (equalp (probe-file (car data)) true-path)))) + alist))) + +(defun covered-functions-for-file (path) + (cdr (assoc-by-filename path *code-covered-functions*))) + +(defun clear-coverage () + "Clear all files from the coverage database. The files will be re-entered +into the database when the FASL files (produced by compiling with +CCL:*COMPILE-CODE-COVERAGE* set to true) are loaded again into the +image." + (setq *code-covered-functions* nil)) + +(defun reset-function-coverage (lfun) + (map-function-coverage lfun #'(lambda (note) + (setf (code-note-code-coverage note) nil)))) + +(defun reset-coverage () + "Reset all coverage data back to the `Not executed` state." + (loop for data in *code-covered-functions* + do (typecase data + (cons ;; (source-file . functions) + (loop for fn across (cdr data) + do (reset-function-coverage fn))) + (function (reset-function-coverage data))))) + +;; Name used for consistency checking across file save/restore +(defun function-covered-name (fn) + (let ((name (function-name fn))) + (and (symbolp name) + (symbol-package name) + name))) + + +(defun coverage-mismatch (why &rest args) + ;; Throw to somebody who knows what file we're working on. + (throw 'coverage-mismatch (cons why args))) + +(defmacro with-coverage-mismatch-catch ((saved-file) &body body) + `(let ((file ,saved-file) + (err (catch 'coverage-mismatch ,@body nil))) + (when err + (error "Mismatched coverage data for ~s, ~?" file (car err) (cdr err))))) + + +;; (name . #(i1 i2 ...)) where in is either an index or (index . subfncoverage). +(defun save-function-coverage (fn &optional (refs ())) + (let ((refs (cons fn refs))) + (declare (dynamic-extent refs)) + (cons (function-covered-name fn) + (lfunloop for imm in fn as i upfrom 0 + when (and (code-note-p imm) + (code-note-code-coverage imm)) + collect i into list + when (and (functionp imm) (not (memq imm refs))) + collect (cons i (save-function-coverage imm refs)) into list + finally (return (and list (coerce list 'vector))))))) + +(defun copy-function-coverage (fn-data) + (cons (car fn-data) + (and (cdr fn-data) + (map 'vector #'(lambda (imm-data) + (if (consp imm-data) + (cons (car imm-data) + (copy-function-coverage (cdr imm-data))) + imm-data)) + (cdr fn-data))))) + +(defun restore-function-coverage (fn saved-fn-data &optional (refs ())) + (let* ((refs (cons fn refs)) + (saved-name (car saved-fn-data)) + (saved-imms (cdr saved-fn-data)) + (nimms (length saved-imms)) + (n 0)) + (declare (dynamic-extent refs)) + (unless (equalp saved-name (function-covered-name fn)) + (coverage-mismatch "had function ~s now have ~s" saved-name fn)) + (lfunloop for imm in fn as i upfrom 0 + when (code-note-p imm) + do (let* ((next (and (< n nimms) (aref saved-imms n)))) + (when (if (consp next) (<= (car next) i) (and next (< next i))) + (coverage-mismatch "in ~s" fn)) + (when (setf (code-note-code-coverage imm) + (and (eql next i) 'restored)) + (incf n))) + when (and (functionp imm) (not (memq imm refs))) + do (let* ((next (and (< n nimms) (aref saved-imms n)))) + (unless (and (consp next) (eql (car next) i)) + (coverage-mismatch "in ~s" fn)) + (restore-function-coverage imm (cdr next) refs) + (incf n))))) + + +(defun add-function-coverage (fn-data new-fn-data) + (let* ((fn-name (car fn-data)) + (imms (cdr fn-data)) + (new-fn-name (car new-fn-data)) + (new-imms (cdr new-fn-data))) + (flet ((kar (x) (if (consp x) (%car x) x))) + (declare (inline kar)) + (unless (equalp fn-name new-fn-name) + (coverage-mismatch "function ~s vs. ~s" fn-name new-fn-name)) + (when new-imms + (loop for new across new-imms + as old = (find (kar new) imms :key #'kar) + if (and (null old) (fixnump new)) + collect new into extras + else do (unless (eql old new) + (if (and (consp new) (consp old)) + (add-function-coverage (cdr old) (cdr new)) + (coverage-mismatch "in function ~s" fn-name))) + finally (when extras + (setf (cdr fn-data) + (sort (concatenate 'vector imms extras) #'< :key #'kar)))))) + fn-data)) + + +(defun save-coverage () + "Returns a snapshot of the current coverage state" + (make-coverage-state + :alist (loop for data in *code-covered-functions* + when (consp data) + collect (cons (car data) + (map 'vector #'save-function-coverage (cdr data)))))) + +(defun combine-coverage (coverage-states) + (let ((result nil)) + (map nil + (lambda (coverage-state) + (loop for (saved-file . saved-fns) in (coverage-state-alist coverage-state) + for result-fns = (cdr (assoc-by-filename saved-file result)) + do (with-coverage-mismatch-catch (saved-file) + (cond ((null result-fns) + (push (cons saved-file + (map 'vector #'copy-function-coverage saved-fns)) + result)) + ((not (eql (length result-fns) (length saved-fns))) + (coverage-mismatch "different function counts")) + (t + (loop for result-fn across result-fns + for saved-fn across saved-fns + do (add-function-coverage result-fn saved-fn))))))) + coverage-states) + (make-coverage-state :alist (nreverse result)))) + + +(defun restore-coverage (coverage-state) + "Restore the code coverage data back to an earlier state produced by SAVE-COVERAGE." + (loop for (saved-file . saved-fns) in (coverage-state-alist coverage-state) + for fns = (covered-functions-for-file saved-file) + do (with-coverage-mismatch-catch (saved-file) + (cond ((null fns) + (warn "Couldn't restore saved coverage for ~s, no matching file present" + saved-file)) + ((not (eql (length fns) (length saved-fns))) + (coverage-mismatch "had ~s functions, now have ~s" + (length saved-fns) (length fns))) + (t + (map nil #'restore-function-coverage fns saved-fns)))))) + +(defvar *loading-coverage*) + +(defun write-coverage-to-file (coverage pathname) + "Write the coverage state COVERAGE in the file designated by PATHNAME" + (with-open-file (stream pathname + :direction :output + :if-exists :supersede + :if-does-not-exist :create) + (with-standard-io-syntax + (let ((*package* (pkg-arg "CCL"))) + (format stream "(in-package :ccl)~%~s~%" + `(setq *loading-coverage* ',(coverage-state-alist coverage))))) + (values))) + +(defun read-coverage-from-file (pathname) + " Return the coverage state saved in the file. Doesn't affect the current coverage state." + (let ((*package* (pkg-arg "CCL")) + (*loading-coverage* :none)) + (load pathname) + (when (eq *loading-coverage* :none) + (error "~s doesn't seem to be a saved coverage file" pathname)) + (make-coverage-state :alist *loading-coverage*))) + +(defun save-coverage-in-file (pathname) + "Save the current coverage state in the file designed by PATHNAME" + (write-coverage-to-file (save-coverage) pathname)) + +(defun restore-coverage-from-file (pathname) + "Set the current coverage state from the file designed by PATHNAME" + (restore-coverage (read-coverage-from-file pathname))) + +(defun common-coverage-directory () + (let* ((host :unknown) + (rev-dir ())) + (loop for data in *code-covered-functions* + when (consp data) + do (let ((file (probe-file (car data)))) + (when file + (cond ((eq host :unknown) + (setq host (pathname-host file) + rev-dir (reverse (pathname-directory file)))) + ((not (equalp host (pathname-host file))) + (return-from common-coverage-directory nil)) + (t + (let* ((path (pathname-directory file)) + (dir-len (length rev-dir)) + (len (length path))) + (if (< len dir-len) + (setq rev-dir (nthcdr (- dir-len len) rev-dir)) + (setq path (subseq path 0 dir-len))) + (loop for pp on (reverse path) until (equalp pp rev-dir) + do (pop rev-dir)))))))) + (unless (eq host :unknown) + (make-pathname :host host :directory (reverse rev-dir))))) + + +(defstruct (coverage-statistics (:conc-name "COVERAGE-")) + source-file + expressions-total + expressions-entered + expressions-covered + unreached-branches + code-forms-total + code-forms-covered + functions-total + functions-fully-covered + functions-partly-covered + functions-not-entered) + +(defun coverage-statistics () + (let* ((*file-coverage* nil) + (*coverage-subnotes* (make-hash-table :test #'eq :shared nil)) + (*emitted-code-notes* (make-hash-table :test #'eq :shared nil)) + (*entry-code-notes* (make-hash-table :test #'eq :shared nil))) + (get-coverage) + (loop for coverage in *file-coverage* + as stats = (make-coverage-statistics :source-file (file-coverage-file coverage)) + do (map nil (lambda (fn) + (let ((note (function-entry-code-note fn))) + (when note (precompute-note-coverage note)))) + (file-coverage-toplevel-functions coverage)) + do (destructuring-bind (total entered %entered covered %covered) + (count-covered-sexps coverage) + (declare (ignore %entered %covered)) + (setf (coverage-expressions-total stats) total) + (setf (coverage-expressions-entered stats) entered) + (setf (coverage-expressions-covered stats) covered)) + do (let ((count (count-unreached-branches coverage))) + (setf (coverage-unreached-branches stats) count)) + do (destructuring-bind (total covered %covered) (count-covered-aexps coverage) + (declare (ignore %covered)) + (setf (coverage-code-forms-total stats) total) + (setf (coverage-code-forms-covered stats) covered)) + do (destructuring-bind (total fully %fully partly %partly never %never) + (count-covered-entry-notes coverage) + (declare (ignore %fully %partly %never)) + (setf (coverage-functions-total stats) total) + (setf (coverage-functions-fully-covered stats) fully) + (setf (coverage-functions-partly-covered stats) partly) + (setf (coverage-functions-not-entered stats) never)) + collect stats))) + + +(defun report-coverage (output-file &key (external-format :default) (statistics t) (html t)) + "If :HTML is non-nil, generate an HTML report, consisting of an index file in OUTPUT-FILE +and, in the same directory, one html file for each instrumented source file that has been +loaded in the current session. +The external format of the source files can be specified with the EXTERNAL-FORMAT parameter. +If :STATISTICS is non-nil, a CSV file is generated with a table. If +:STATISTICS is a filename, that file is used, else 'statistics.csv' is +written to the output directory. +" + (let* ((paths) + (directory (make-pathname :name nil :type nil :defaults output-file)) + (coverage-dir (common-coverage-directory)) + (*file-coverage* nil) + (*coverage-subnotes* (make-hash-table :test #'eq :shared nil)) + (*emitted-code-notes* (make-hash-table :test #'eq :shared nil)) + (*entry-code-notes* (make-hash-table :test #'eq :shared nil)) + (index-file (and html (merge-pathnames output-file "index.html"))) + (stats-file (and statistics (merge-pathnames (if (or (stringp statistics) + (pathnamep statistics)) + (merge-pathnames statistics "statistics.csv") + "statistics.csv") + output-file)))) + (get-coverage) + (ensure-directories-exist directory) + (loop for coverage in *file-coverage* + as file = (or (probe-file (file-coverage-file coverage)) + (progn (warn "Cannot find ~s, won't report coverage" (file-coverage-file coverage)) + nil)) + do (when file + (let* ((src-name (enough-namestring file coverage-dir)) + (html-name (substitute + #\_ #\: (substitute + #\_ #\. (substitute + #\_ #\/ (namestring-unquote src-name)))))) + (when html + (with-open-file (stream (make-pathname :name html-name :type "html" :defaults directory) + :direction :output + :if-exists :supersede + :if-does-not-exist :create) + (report-file-coverage index-file coverage stream external-format))) + (push (list* src-name html-name coverage) paths)))) + (when (null paths) + (error "No code coverage data available")) + (setq paths (sort paths #'(lambda (path1 path2) + (let* ((f1 (car path1)) + (f2 (car path2))) + (or (string< (directory-namestring f1) + (directory-namestring f2)) + (and (equal (pathname-directory f1) + (pathname-directory f2)) + (string< (file-namestring f1) + (file-namestring f2)))))))) + (if html + (with-open-file (html-stream index-file + :direction :output + :if-exists :supersede + :if-does-not-exist :create) + (if stats-file + (with-open-file (stats-stream stats-file + :direction :output + :if-exists :supersede + :if-does-not-exist :create) + (report-coverage-to-streams paths html-stream stats-stream)) + (report-coverage-to-streams paths html-stream nil))) + (if stats-file + (with-open-file (stats-stream stats-file + :direction :output + :if-exists :supersede + :if-does-not-exist :create) + (report-coverage-to-streams paths nil stats-stream)) + (error "One of :HTML or :STATISTICS must be non-nil"))) + (values index-file stats-file))) + +(defun report-coverage-to-streams (paths html-stream stats-stream) + (when html-stream (write-coverage-styles html-stream)) + (unless paths + (warn "No coverage data found for any file, producing an empty report. Maybe you forgot to (SETQ CCL::*COMPILE-CODE-COVERAGE* T) before compiling?") + (when html-stream (format html-stream "
No code coverage data found.
~%")) + (when stats-stream (format stats-stream "No code coverage data found.~%")) + (return-from report-coverage-to-streams)) + (when html-stream (format html-stream "")) + (coverage-stats-head html-stream stats-stream) + (loop for prev = nil then src-name + for (src-name report-name . coverage) in paths + for even = nil then (not even) + do (when (or (null prev) + (not (equal (pathname-directory (pathname src-name)) + (pathname-directory (pathname prev))))) + (let ((dir (namestring (make-pathname :name nil :type nil :defaults src-name)))) + (when html-stream (format html-stream "~%" dir)) + (when stats-stream (format stats-stream "~a~%" dir)))) + do (coverage-stats-data html-stream stats-stream coverage even report-name src-name)) + (when html-stream (format html-stream "
~A
"))) + +(defun precompute-note-coverage (note &optional refs) + (when note + (let ((subnotes (coverage-subnotes note)) + (refs (cons note refs))) + (declare (dynamic-extent refs)) + (loop for sub in subnotes + when (member sub refs) + do (break "Circularity!!") + unless (member sub refs) + do (precompute-note-coverage sub refs)) + (when (and (or (not (emitted-code-note-p note)) + (code-note-code-coverage note)) + (loop for sub in subnotes + always (or (eq 'full (code-note-code-coverage sub)) + (entry-code-note-p sub)))) + (setf (code-note-code-coverage note) 'full))))) + + +(defun fill-with-text-style (coverage location-note styles) + (let ((style (case coverage + ((full) $totally-covered-style) + ((nil) $not-executed-style) + (t $partially-covered-style)))) + (fill styles style + :start (source-note-start-pos location-note) + :end (source-note-end-pos location-note)))) + +(defun update-text-styles (note styles) + (let ((source (code-note-source-note note))) + (when source + (fill-with-text-style (code-note-code-coverage note) source styles)) + (unless (and (emitted-code-note-p note) + (memq (code-note-code-coverage note) '(nil full)) + ;; If not a source note, descend in case have some subnotes + ;; that can be shown + source) + (loop for sub in (coverage-subnotes note) + unless (entry-code-note-p sub) + do (update-text-styles sub styles))))) + +(defun entry-note-unambiguous-source (entry-note) + ;; Return the nearest containing source note provided it can be done unambiguously. + (loop for n = entry-note then parent until (code-note-source-note n) + as parent = (code-note-parent-note n) + do (unless (and parent + (labels ((no-other-entry-subnotes (n refs) + (let ((subs (coverage-subnotes n)) + (refs (cons n refs))) + (declare (dynamic-extent refs)) + (loop for sub in subs + always (or (memq sub refs) + (eq sub entry-note) + (and (not (entry-code-note-p sub)) + (no-other-entry-subnotes sub refs))))))) + (no-other-entry-subnotes parent ()))) + (return nil)) + finally (return (code-note-source-note n)))) + +(defun colorize-source-note (note styles) + ;; Change coverage flag to 'full if all subforms are covered. + (precompute-note-coverage note) + ;; Now actually change text styles, from outside in. + ;; But first, a special kludge: + ;; In cases like (setq foo (function (lambda (x) x))), we can colorize "(setq foo (function " + ;; based on whether the setq got executed, and "(lambda (x) x)" on whether the inner + ;; function got executed. However, suppose have a macro "(setq-fun foo (x) x)" that + ;; expanded into the above, there isn't a clear way to show the distinction between + ;; just referencing the inner fn and executing it. In practice, the colorization + ;; based on the inner function is more interesting -- consider for example DEFUN, + ;; nobody cares whether the defun form itself got executed. + ;; So when showing the colorization of an inner function, we usurp the whole nearest source + ;; form, provided it can be done unambiguously. + (let ((n (entry-note-unambiguous-source note))) + (when n + (fill-with-text-style (code-note-code-coverage note) n styles))) + (update-text-styles note styles)) + +(defun function-source-form-note (fn) + ;; Find the outermost source form containing the fn. + (loop with sn = nil + for n = (function-entry-code-note fn) then (code-note-parent-note n) + do (when (null n) (return nil)) + do (when (setq sn (code-note-source-note n)) + (loop for s = (source-note-source sn) while (source-note-p s) + do (setq sn s)) + (return sn)))) + + +(defun colorize-function (fn styles &optional refs) + (let* ((note (function-entry-code-note fn)) + (source (function-source-form-note fn)) + (refs (cons fn refs))) + (declare (dynamic-extent refs)) + ;; Colorize the body of the function + (when note + (colorize-source-note note styles)) + ;; And now any subfunction references + (lfunloop for imm in fn + when (and (functionp imm) + (not (memq imm refs)) + ;; Make sure this fn is in the source we're currently looking at. + ;; It might not be, if it is referenced via (load-time-value (foo)) + ;; where (foo) returns an lfun from some different source entirely. + ;; CL-PPCRE does that. + (or (null source) + (eq source (function-source-form-note imm)) + #+debug (progn + (warn "Ignoring ref to ~s from ~s" imm fn) + nil))) + do (colorize-function imm styles refs)))) + +(defun report-file-coverage (index-file coverage html-stream external-format) + "Print a code coverage report of FILE into the stream HTML-STREAM." + (format html-stream "") + (write-coverage-styles html-stream) + (format html-stream "") + (let* ((source (with-open-file (s (file-coverage-file coverage) :external-format external-format) + (let ((string (make-string (file-length s)))) + (read-sequence string s) + string))) + (styles (make-array (length source) + :initial-element 0 + :element-type '(unsigned-byte 2)))) + (map nil #'(lambda (fn) (colorize-function fn styles)) (file-coverage-toplevel-functions coverage)) + (print-file-coverage-report index-file html-stream coverage styles source) + (format html-stream ""))) + +(defun print-file-coverage-report (index-file html-stream coverage styles source) + (let ((*print-case* :downcase)) + (format html-stream "
Coverage report: ~a
~%
~%" + (native-translated-namestring (make-pathname :name (pathname-name index-file) + :type (pathname-type index-file))) + (file-coverage-file coverage)) + (format html-stream "") + (coverage-stats-head html-stream nil) + (coverage-stats-data html-stream nil coverage) + (format html-stream "
") + + (format html-stream "
Key
~%") + (format html-stream "
Fully covered - every single instruction executed
" $totally-covered-style) + (format html-stream "
Partly covered - entered but some subforms not executed
" $partially-covered-style) + (format html-stream "
Never entered - not a single instruction executed
" $not-executed-style) + (format html-stream "
~%") + + (flet ((line (line) + (unless (eql line 0) + (format html-stream "")) + (incf line) + (format html-stream "
~%
~A
" line) + line)) + (loop with line = (line 0) with col = 0 + for last-style = nil then style + for char across source + for style across styles + do (unless (eq style last-style) + (when last-style + (format html-stream "")) + (format html-stream "" style)) + do (case char + ((#\Newline) + (setq style nil) + (setq col 0) + (setq line (line line))) + ((#\Space) + (incf col) + (write-string " " html-stream)) + ((#\Tab) + (dotimes (i (- 8 (mod col 8))) + (incf col) + (write-string " " html-stream))) + (t + (incf col) + (if (alphanumericp char) + (write-char char html-stream) + (format html-stream "&#~D;" (char-code char)))))) + (format html-stream "
")))) + + +(defun coverage-stats-head (html-stream stats-stream) + (when html-stream + (format html-stream "") + (format html-stream "Expressions") + (format html-stream "Branches") + (format html-stream "Code Forms") + (format html-stream "Functions") + (format html-stream "~{~A~}" + '("Source file" + ;; Expressions + "Total" "Entered" "% entered" "Fully covered" "% fully covered" + ;; Branches + "total unreached" + ;; Code forms + "Total" "Covered" "% covered" + ;; Functions + "Total" "Fully covered" "% fully covered" "Partly covered" "% partly covered" "Not entered" "% not entered"))) + (when stats-stream + (format stats-stream "~{~a~^,~}" + `("Source file" + "Expressions Total" "Expressions Entered" "% Expressions Entered" + "Unreached Branches" + "Code Forms Total" "Code Forms Covered" "% Code Forms Covered" + "Functions Total" "Functions Fully Covered" "% Functions Fully Covered" + "Functions Partly Covered" "% Functions Partly Covered" + "Functions Not Entered" "% Functions Not Entered")))) + +(defun coverage-stats-data (html-stream stats-stream coverage &optional evenp report-name src-name) + (when html-stream + (format html-stream "" evenp) + (if report-name + (format html-stream "~a" report-name src-name) + (format html-stream "~a" (file-coverage-file coverage)))) + (when stats-stream + (format stats-stream "~a," (file-coverage-file coverage))) + + (let ((exp-counts (count-covered-sexps coverage))) + (when html-stream + (format html-stream "~{~:[-~;~:*~a~]~:[-~;~:*~a~]~:[-~;~:*~5,1f%~]~:[-~;~:*~a~]~:[-~;~:*~5,1f%~]~}" exp-counts)) + (when stats-stream + (format stats-stream "~{~:[~;~:*~a~],~:[~;~:*~a~],~:[~;~:*~5,1f%~],~:[~;~:*~a~],~:[~;~:*~5,1f%~],~}" exp-counts))) + + (let ((count (count-unreached-branches coverage))) + (when html-stream + (format html-stream "~:[-~;~:*~a~]" count)) + (when stats-stream + (format stats-stream "~:[~;~:*~a~]," count))) + + (let ((exp-counts (count-covered-aexps coverage))) + (when html-stream + (format html-stream "~{~:[-~;~:*~a~]~:[-~;~:*~a~]~:[-~;~:*~5,1f%~]~}" exp-counts)) + (when stats-stream + (format stats-stream "~{~:[~;~:*~a~],~:[~;~:*~a~],~:[~;~:*~5,1f%~],~}" exp-counts))) + + (destructuring-bind (total . counts) (count-covered-entry-notes coverage) + (when html-stream + (format html-stream "~:[-~;~:*~a~]~{~:[-~;~:*~a~]~:[-~;~:*~5,1f%~]~}" total counts)) + (when stats-stream + (format stats-stream "~:[~;~:*~a~],~{~:[~;~:*~a~],~:[-~;~:*~5,1f%~]~^,~}~%" total counts)))) + +(defun map-coverage-entry-notes (coverage fn) + (map nil #'(lambda (function) + (let ((note (function-entry-code-note function))) + (when (and note + ;; Ignore toplevel functions created by the compiler. + (or (code-note-source-note note) + (code-note-parent-note note))) + (funcall fn note)))) + (file-coverage-functions coverage))) + + +(defun count-covered-entry-notes (coverage) + (let ((fully 0) (partly 0) (never 0) (total 0)) + (map-coverage-entry-notes + coverage + #'(lambda (note) + (incf total) + (case (code-note-code-coverage note) + ((full) (incf fully)) + ((nil) (incf never)) + (t (incf partly))))) + (if (> total 0) + (list total + fully (* 100.0 (/ fully total)) + partly (* 100.0 (/ partly total)) + never (* 100.0 (/ never total))) + '(0 0 -- 0 -- 0 --)))) + +(defun count-covered-aexps (coverage) + (let ((covered 0) (total 0)) + (map-coverage-entry-notes + coverage + (lambda (note) + (labels ((rec (note) + (when (emitted-code-note-p note) + (incf total) + (when (code-note-code-coverage note) + (incf covered))) + (loop for sub in (coverage-subnotes note) + unless (entry-code-note-p sub) do (rec sub)))) + (rec note)))) + (list total covered (if (> total 0) (* 100.0d0 (/ covered total)) '--)))) + +(defun count-covered-sexps (coverage) + ;; Count the number of source expressions that have been entered (regardless + ;; of whether or not they are completely covered). + (let ((entered 0) (covered 0) (total 0)) + (map-coverage-entry-notes + coverage + (lambda (note) + (labels ((rec (note) + (when (code-note-source-note note) + #+debug (format t "~&~s" note) + (incf total) + (when (code-note-code-coverage note) + (incf entered) + (when (eq (code-note-code-coverage note) 'full) + (incf covered)))) + (loop for sub in (coverage-subnotes note) + unless (entry-code-note-p sub) do (rec sub)))) + (rec note)))) + (list total + entered (if (> total 0) (* 100.0d0 (/ entered total)) '--) + covered (if (> total 0) (* 100.0d0 (/ covered total)) '--)))) + +(defun count-unreached-branches (coverage) + ;; Count the number of maximal unentered forms + (let ((count 0)) + (map-coverage-entry-notes + coverage + (lambda (note) + (labels ((rec (note parent) + (case (code-note-code-coverage note) + ((full) nil) + ((nil) (when parent (incf count))) + (t (loop for sub in (coverage-subnotes note) + unless (entry-code-note-p sub) do (rec sub note)))))) + (rec note nil)))) + count)) + +(defun write-coverage-styles (html-stream) + (format html-stream "" + $not-executed-style + $partially-covered-style + $totally-covered-style + )) Index: /branches/new-random/library/darwinppc-syscalls.lisp =================================================================== --- /branches/new-random/library/darwinppc-syscalls.lisp (revision 13309) +++ /branches/new-random/library/darwinppc-syscalls.lisp (revision 13309) @@ -0,0 +1,298 @@ +;;;-*-Mode: LISP; Package: CCL -*- +;;; +;;; Copyright (C) 2001-2009 Clozure Associates +;;; This file is part of Clozure CL. +;;; +;;; Clozure CL is licensed under the terms of the Lisp Lesser GNU Public +;;; License , known as the LLGPL and distributed with Clozure CL as the +;;; file "LICENSE". The LLGPL consists of a preamble and the LGPL, +;;; which is distributed with Clozure CL as the file "LGPL". Where these +;;; conflict, the preamble takes precedence. +;;; +;;; Clozure CL is referenced in the preamble as the "LIBRARY." +;;; +;;; The LLGPL is also available online at +;;; http://opensource.franz.com/preamble.html + +(in-package "CCL") + + +(eval-when (:compile-toplevel :load-toplevel :execute) + (require "SYSCALL")) + +(define-syscall (logior platform-os-darwin platform-cpu-ppc) syscalls::exit 1 (:int) :void ) +(define-syscall (logior platform-os-darwin platform-cpu-ppc) syscalls::fork 2 () :void) +(define-syscall (logior platform-os-darwin platform-cpu-ppc) syscalls::read 3 (:unsigned-fullword :address :unsigned-long) + :signed-long ) +(define-syscall (logior platform-os-darwin platform-cpu-ppc) syscalls::write 4 (:unsigned-fullword :address :unsigned-long) + :signed-long ) +(define-syscall (logior platform-os-darwin platform-cpu-ppc) syscalls::open 5 (:address :unsigned-fullword :unsigned-fullword) :signed-fullword :min-args 2 ) +(define-syscall (logior platform-os-darwin platform-cpu-ppc) syscalls::close 6 (:unsigned-fullword) :signed-fullword ) +(define-syscall (logior platform-os-darwin platform-cpu-ppc) syscalls::wait4 7 (:unsigned-fullword :address :signed-fullword :address) :unsigned-fullword ) + ; 8 is old creat +(define-syscall (logior platform-os-darwin platform-cpu-ppc) syscalls::link 9 (:address :address) :signed-fullword ) +(define-syscall (logior platform-os-darwin platform-cpu-ppc) syscalls::unlink 10 (:address) :signed-fullword ) + ; 11 is obsolete execv +(define-syscall (logior platform-os-darwin platform-cpu-ppc) syscalls::chdir 12 (:address) :signed-fullword ) +(define-syscall (logior platform-os-darwin platform-cpu-ppc) syscalls::fchdir 13 (:unsigned-fullword) :signed-fullword ) +(define-syscall (logior platform-os-darwin platform-cpu-ppc) syscalls::mknod 14 (:address :unsigned-fullword :unsigned-fullword) + :signed-fullword ) +(define-syscall (logior platform-os-darwin platform-cpu-ppc) syscalls::chmod 15 (:address :unsigned-fullword) :signed-fullword ) +(define-syscall (logior platform-os-darwin platform-cpu-ppc) syscalls::lchown 16 (:address :unsigned-fullword :unsigned-fullword) + :signed-fullword) +(define-syscall (logior platform-os-darwin platform-cpu-ppc) syscalls::getpid 20 () :signed-fullword ) +(define-syscall (logior platform-os-darwin platform-cpu-ppc) syscalls::setuid 23 (:unsigned-fullword) :signed-fullword ) +(define-syscall (logior platform-os-darwin platform-cpu-ppc) syscalls::getuid 24 () :unsigned-fullword ) +(define-syscall (logior platform-os-darwin platform-cpu-ppc) syscalls::geteuid 25 () :unsigned-fullword ) +(define-syscall (logior platform-os-darwin platform-cpu-ppc) syscalls::recvmsg 27 (:unsigned-fullword :address :unsigned-fullword):signed-fullword ) +(define-syscall (logior platform-os-darwin platform-cpu-ppc) syscalls::sendmsg 28 (:unsigned-fullword :address :unsigned-fullword):signed-fullword ) +(define-syscall (logior platform-os-darwin platform-cpu-ppc) syscalls::recvfrom 29 (:unsigned-fullword :address :unsigned-long :unsigned-fullword :address :address) :signed-fullword ) +(define-syscall (logior platform-os-darwin platform-cpu-ppc) syscalls::accept 30 (:unsigned-fullword :address :address) :signed-fullword ) +(define-syscall (logior platform-os-darwin platform-cpu-ppc) syscalls::getpeername 31 (:unsigned-fullword :address :address) :signed-fullword ) +(define-syscall (logior platform-os-darwin platform-cpu-ppc) syscalls::getsockname 32 (:unsigned-fullword :address :address) :signed-fullword ) +(define-syscall (logior platform-os-darwin platform-cpu-ppc) syscalls::kill 37 (:signed-fullword :unsigned-fullword) :signed-fullword ) +(define-syscall (logior platform-os-darwin platform-cpu-ppc) syscalls::sync 36 () :unsigned-fullword ) + ; 38 is old stat +(define-syscall (logior platform-os-darwin platform-cpu-ppc) syscalls::getppid 39 () :unsigned-fullword) +(define-syscall (logior platform-os-darwin platform-cpu-ppc) syscalls::dup 41 (:unsigned-fullword) :signed-fullword ) +(define-syscall (logior platform-os-darwin platform-cpu-ppc) syscalls::pipe 42 () :signed-doubleword ) +(define-syscall (logior platform-os-darwin platform-cpu-ppc) syscalls::getgid 47 () :unsigned-fullword) +(define-syscall (logior platform-os-darwin platform-cpu-ppc) syscalls::ioctl 54 (:unsigned-fullword :signed-fullword :address) :signed-fullword :min-args 2 ) +(define-syscall (logior platform-os-darwin platform-cpu-ppc) syscalls::dup2 90 (:unsigned-fullword :unsigned-fullword) :signed-fullword ) +(define-syscall (logior platform-os-darwin platform-cpu-ppc) syscalls::fcntl 92 (:unsigned-fullword :signed-fullword :signed-fullword) :signed-fullword :min-args 2 ) +(define-syscall (logior platform-os-darwin platform-cpu-ppc) syscalls::select 93 (:unsigned-fullword :address :address + :address :address) + :signed-fullword) +(define-syscall (logior platform-os-darwin platform-cpu-ppc) syscalls::fsync 95 (:unsigned-fullword) :signed-fullword ) +(define-syscall (logior platform-os-darwin platform-cpu-ppc) syscalls::socket 97 (:unsigned-fullword :unsigned-fullword :unsigned-fullword) :signed-fullword ) +(define-syscall (logior platform-os-darwin platform-cpu-ppc) syscalls::connect 98 (:unsigned-fullword :address :unsigned-fullword) :signed-fullword) +(define-syscall (logior platform-os-darwin platform-cpu-ppc) syscalls::bind 104 (:unsigned-fullword :address :unsigned-fullword) :signed-fullword ) +(define-syscall (logior platform-os-darwin platform-cpu-ppc) syscalls::setsockopt 105 (:unsigned-fullword :signed-fullword :signed-fullword :address :unsigned-fullword) :signed-fullword ) +(define-syscall (logior platform-os-darwin platform-cpu-ppc) syscalls::listen 106 (:unsigned-fullword :unsigned-fullword) :signed-fullword ) +(define-syscall (logior platform-os-darwin platform-cpu-ppc) syscalls::gettimeofday 116 (:address :address) :signed-fullword ) +(define-syscall (logior platform-os-darwin platform-cpu-ppc) syscalls::getrusage 117 (:signed-fullword :address) :signed-fullword ) +(define-syscall (logior platform-os-darwin platform-cpu-ppc) syscalls::getsockopt 118 (:unsigned-fullword :signed-fullword :unsigned-fullword :address :address) :signed-fullword ) +(define-syscall (logior platform-os-darwin platform-cpu-ppc) syscalls::fchmod 124 (:unsigned-fullword :unsigned-fullword) :signed-fullword ) +(define-syscall (logior platform-os-darwin platform-cpu-ppc) syscalls::rename 128 (:address :address) :signed-fullword) + ; 129 is old truncate + ; 130 is old ftruncate +(define-syscall (logior platform-os-darwin platform-cpu-ppc) syscalls::sendto 133 (:unsigned-fullword :address :unsigned-fullword :unsigned-fullword :address :unsigned-fullword) :signed-fullword ) + +(define-syscall (logior platform-os-darwin platform-cpu-ppc) syscalls::shutdown 134 (:unsigned-fullword :unsigned-fullword) :signed-fullword ) +(define-syscall (logior platform-os-darwin platform-cpu-ppc) syscalls::socketpair 135 (:unsigned-fullword :unsigned-fullword :unsigned-fullword :address) :signed-fullword ) + +(define-syscall (logior platform-os-darwin platform-cpu-ppc) syscalls::mkdir 136 (:address :unsigned-fullword) :signed-fullword) +(define-syscall (logior platform-os-darwin platform-cpu-ppc) syscalls::rmdir 137 (:address) :signed-fullword ) +(define-syscall (logior platform-os-darwin platform-cpu-ppc) syscalls::mount 167 (:address :address :unsigned-fullword :address) :signed-fullword ) +(define-syscall (logior platform-os-darwin platform-cpu-ppc) syscalls::setgid 181 (:unsigned-fullword) :signed-fullword ) +(define-syscall (logior platform-os-darwin platform-cpu-ppc) syscalls::stat 188 (:address :address) :signed-fullword ) +(define-syscall (logior platform-os-darwin platform-cpu-ppc) syscalls::fstat 189 (:unsigned-fullword :address) :signed-fullword ) +(define-syscall (logior platform-os-darwin platform-cpu-ppc) syscalls::lstat 190 (:address :address) :signed-fullword ) +(define-syscall (logior platform-os-darwin platform-cpu-ppc) syscalls::lseek 199 (:unsigned-fullword :signed-doubleword :unsigned-fullword) :signed-doubleword ) +(define-syscall (logior platform-os-darwin platform-cpu-ppc) syscalls::truncate 200 (:address :unsigned-doubleword) :signed-fullword ) +(define-syscall (logior platform-os-darwin platform-cpu-ppc) syscalls::ftruncate 201 (:unsigned-fullword :unsigned-doubleword) :signed-fullword ) + +(define-syscall (logior platform-os-darwin platform-cpu-ppc) syscalls::poll 230 ((:* (:struct :pollfd)) :int :int) :int) + +#+notdefinedyet +(progn + ; 17 is obsolete sbreak + ; 18 is old getfsstat + ; 19 is old lseek + ; 21 is obsolete mount + ; 22 is obsolete umount +(define-syscall (logior platform-os-darwin platform-cpu-ppc) syscalls::ptrace 26 () ) +(define-syscall (logior platform-os-darwin platform-cpu-ppc) syscalls::access 33 () ) +(define-syscall (logior platform-os-darwin platform-cpu-ppc) syscalls::chflags 34 () ) +(define-syscall (logior platform-os-darwin platform-cpu-ppc) syscalls::fchflags 35 () ) + ; 40 is old lstat +(define-syscall (logior platform-os-darwin platform-cpu-ppc) syscalls::getegid 43 () ) +(define-syscall (logior platform-os-darwin platform-cpu-ppc) syscalls::profil 44 () ) +(define-syscall (logior platform-os-darwin platform-cpu-ppc) syscalls::ktrace 45 () ) +(define-syscall (logior platform-os-darwin platform-cpu-ppc) syscalls::sigaction 46 () ) +(define-syscall (logior platform-os-darwin platform-cpu-ppc) syscalls::sigprocmask 48 () ) +(define-syscall (logior platform-os-darwin platform-cpu-ppc) syscalls::getlogin 49 () ) +(define-syscall (logior platform-os-darwin platform-cpu-ppc) syscalls::setlogin 50 () ) +(define-syscall (logior platform-os-darwin platform-cpu-ppc) syscalls::acct 51 () ) +(define-syscall (logior platform-os-darwin platform-cpu-ppc) syscalls::sigpending 52 () ) +(define-syscall (logior platform-os-darwin platform-cpu-ppc) syscalls::sigaltstack 53 () ) +(define-syscall (logior platform-os-darwin platform-cpu-ppc) syscalls::reboot 55 () ) +(define-syscall (logior platform-os-darwin platform-cpu-ppc) syscalls::revoke 56 () ) +(define-syscall (logior platform-os-darwin platform-cpu-ppc) syscalls::symlink 57 () ) +(define-syscall (logior platform-os-darwin platform-cpu-ppc) syscalls::readlink 58 () ) +(define-syscall (logior platform-os-darwin platform-cpu-ppc) syscalls::execve 59 () ) +(define-syscall (logior platform-os-darwin platform-cpu-ppc) syscalls::umask 60 () ) +(define-syscall (logior platform-os-darwin platform-cpu-ppc) syscalls::chroot 61 () ) + ; 62 is old fstat + ; 63 is unused + ; 64 is old getpagesize +(define-syscall (logior platform-os-darwin platform-cpu-ppc) syscalls::msync 65 () ) +(define-syscall (logior platform-os-darwin platform-cpu-ppc) syscalls::vfork 66 () ) + ; 67 is obsolete vread + ; 68 is obsolete vwrite +(define-syscall (logior platform-os-darwin platform-cpu-ppc) syscalls::sbrk 69 () ) +(define-syscall (logior platform-os-darwin platform-cpu-ppc) syscalls::sstk 70 () ) + ; 71 is old mmap + ; 72 is obsolete vadvise +(define-syscall (logior platform-os-darwin platform-cpu-ppc) syscalls::munmap 73 () ) +(define-syscall (logior platform-os-darwin platform-cpu-ppc) syscalls::mprotect 74 () ) +(define-syscall (logior platform-os-darwin platform-cpu-ppc) syscalls::madvise 75 () ) + ; 76 is obsolete vhangup + ; 77 is obsolete vlimit +(define-syscall (logior platform-os-darwin platform-cpu-ppc) syscalls::mincore 78 () ) +(define-syscall (logior platform-os-darwin platform-cpu-ppc) syscalls::getgroups 79 () ) +(define-syscall (logior platform-os-darwin platform-cpu-ppc) syscalls::setgroups 80 () ) +(define-syscall (logior platform-os-darwin platform-cpu-ppc) syscalls::getpgrp 81 () ) +(define-syscall (logior platform-os-darwin platform-cpu-ppc) syscalls::setpgid 82 () ) +(define-syscall (logior platform-os-darwin platform-cpu-ppc) syscalls::setitimer 83 () ) + ; 84 is old wait +(define-syscall (logior platform-os-darwin platform-cpu-ppc) syscalls::swapon 85 () ) +(define-syscall (logior platform-os-darwin platform-cpu-ppc) syscalls::getitimer 86 () ) + ; 87 is old gethostname + ; 88 is old sethostname +(define-syscall (logior platform-os-darwin platform-cpu-ppc) syscalls::getdtablesize 89 () ) + + + ; 94 is obsolete setdopt +(define-syscall (logior platform-os-darwin platform-cpu-ppc) syscalls::setpriority 96 () ) + ; 99 is old accept +(define-syscall (logior platform-os-darwin platform-cpu-ppc) syscalls::getpriority 100 () ) + ; 101 is old send + ; 102 is old recv +(define-syscall (logior platform-os-darwin platform-cpu-ppc) syscalls::sigreturn 103 () ) + ; 107 is obsolete vtimes + ; 108 is old sigvec + ; 109 is old sigblock + ; 110 is old sigsetmask +(define-syscall (logior platform-os-darwin platform-cpu-ppc) syscalls::sigsuspend 111 () ) + ; 112 is old sigstack + ; 113 is old recvmsg + ; 114 is old sendmsg + ; 115 is obsolete vtrace + ; 119 is obsolete resuba +(define-syscall (logior platform-os-darwin platform-cpu-ppc) syscalls::readv 120 () ) +(define-syscall (logior platform-os-darwin platform-cpu-ppc) syscalls::writev 121 () ) +(define-syscall (logior platform-os-darwin platform-cpu-ppc) syscalls::settimeofday 122 () ) +(define-syscall (logior platform-os-darwin platform-cpu-ppc) syscalls::fchown 123 () ) + ; 125 is old recvfrom + ; 126 is old setreuid + ; 127 is old setregid +(define-syscall (logior platform-os-darwin platform-cpu-ppc) syscalls::flock 131 () ) +(define-syscall (logior platform-os-darwin platform-cpu-ppc) syscalls::mkfifo 132 () ) +(define-syscall (logior platform-os-darwin platform-cpu-ppc) syscalls::utimes 138 () ) + ; 139 is unused +(define-syscall (logior platform-os-darwin platform-cpu-ppc) syscalls::adjtime 140 () ) + ; 141 is old getpeername + ; 142 is old gethostid + ; 143 is old sethostid + ; 144 is old getrlimit + ; 145 is old setrlimit + ; 146 is old killpg +(define-syscall (logior platform-os-darwin platform-cpu-ppc) syscalls::setsid 147 () ) + ; 148 is obsolete setquota + ; 149 is obsolete quota + ; 150 is old getsockname + ; 151 is reserved +(define-syscall (logior platform-os-darwin platform-cpu-ppc) syscalls::setprivexec 152 () ) + ; 153 is reserved + ; 154 is reserved +(define-syscall (logior platform-os-darwin platform-cpu-ppc) syscalls::nfssvc 155 () ) + ; 156 is old getdirentries +(define-syscall (logior platform-os-darwin platform-cpu-ppc) syscalls::statfs 157 () ) +(define-syscall (logior platform-os-darwin platform-cpu-ppc) syscalls::fstatfs 158 () ) +(define-syscall (logior platform-os-darwin platform-cpu-ppc) syscalls::unmount 159 () ) + ; 160 is obsolete async_daemon +(define-syscall (logior platform-os-darwin platform-cpu-ppc) syscalls::getfh 161 () ) + ; 162 is old getdomainname + ; 163 is old setdomainname + ; 164 is obsolete pcfs_mount +(define-syscall (logior platform-os-darwin platform-cpu-ppc) syscalls::quotactl 165 () ) + ; 166 is obsolete exportfs + + ; 168 is obsolete ustat + ; 169 is unused +(define-syscall (logior platform-os-darwin platform-cpu-ppc) syscalls::table 170 () ) + ; 171 is old wait_3 + ; 172 is obsolete rpause + ; 173 is unused + ; 174 is obsolete getdents +(define-syscall (logior platform-os-darwin platform-cpu-ppc) syscalls::gc_control 175 () ) +(define-syscall (logior platform-os-darwin platform-cpu-ppc) syscalls::add_profil 176 () ) + ; 177 is unused + ; 178 is unused + ; 179 is unused +(define-syscall (logior platform-os-darwin platform-cpu-ppc) syscalls::kdebug_trace 180 () ) +(define-syscall (logior platform-os-darwin platform-cpu-ppc) syscalls::setegid 182 () ) +(define-syscall (logior platform-os-darwin platform-cpu-ppc) syscalls::seteuid 183 () ) +(define-syscall (logior platform-os-darwin platform-cpu-ppc) syscalls::lfs_bmapv 184 () ) +(define-syscall (logior platform-os-darwin platform-cpu-ppc) syscalls::lfs_markv 185 () ) +(define-syscall (logior platform-os-darwin platform-cpu-ppc) syscalls::lfs_segclean 186 () ) +(define-syscall (logior platform-os-darwin platform-cpu-ppc) syscalls::lfs_segwait 187 () ) +(define-syscall (logior platform-os-darwin platform-cpu-ppc) syscalls::pathconf 191 () ) +(define-syscall (logior platform-os-darwin platform-cpu-ppc) syscalls::fpathconf 192 () ) +(define-syscall (logior platform-os-darwin platform-cpu-ppc) syscalls::getrlimit 194 () ) +(define-syscall (logior platform-os-darwin platform-cpu-ppc) syscalls::setrlimit 195 () ) +(define-syscall (logior platform-os-darwin platform-cpu-ppc) syscalls::getdirentries 196 () ) +(define-syscall (logior platform-os-darwin platform-cpu-ppc) syscalls::mmap 197 () ) +(define-syscall (logior platform-os-darwin platform-cpu-ppc) syscalls::__syscall 198 () ) +(define-syscall (logior platform-os-darwin platform-cpu-ppc) syscalls::__sysctl 202 () ) +(define-syscall (logior platform-os-darwin platform-cpu-ppc) syscalls::mlock 203 () ) +(define-syscall (logior platform-os-darwin platform-cpu-ppc) syscalls::munlock 204 () ) +(define-syscall (logior platform-os-darwin platform-cpu-ppc) syscalls::undelete 205 () ) +(define-syscall (logior platform-os-darwin platform-cpu-ppc) syscalls::ATsocket 206 () ) +(define-syscall (logior platform-os-darwin platform-cpu-ppc) syscalls::ATgetmsg 207 () ) +(define-syscall (logior platform-os-darwin platform-cpu-ppc) syscalls::ATputmsg 208 () ) +(define-syscall (logior platform-os-darwin platform-cpu-ppc) syscalls::ATPsndreq 209 () ) +(define-syscall (logior platform-os-darwin platform-cpu-ppc) syscalls::ATPsndrsp 210 () ) +(define-syscall (logior platform-os-darwin platform-cpu-ppc) syscalls::ATPgetreq 211 () ) +(define-syscall (logior platform-os-darwin platform-cpu-ppc) syscalls::ATPgetrsp 212 () ) + ; 213-215 are reserved for AppleTalk +(define-syscall (logior platform-os-darwin platform-cpu-ppc) syscalls::mkcomplex 216 () ) +(define-syscall (logior platform-os-darwin platform-cpu-ppc) syscalls::statv 217 () ) +(define-syscall (logior platform-os-darwin platform-cpu-ppc) syscalls::lstatv 218 () ) +(define-syscall (logior platform-os-darwin platform-cpu-ppc) syscalls::fstatv 219 () ) +(define-syscall (logior platform-os-darwin platform-cpu-ppc) syscalls::getattrlist 220 () ) +(define-syscall (logior platform-os-darwin platform-cpu-ppc) syscalls::setattrlist 221 () ) +(define-syscall (logior platform-os-darwin platform-cpu-ppc) syscalls::getdirentriesattr 222 () ) +(define-syscall (logior platform-os-darwin platform-cpu-ppc) syscalls::exchangedata 223 () ) +(define-syscall (logior platform-os-darwin platform-cpu-ppc) syscalls::checkuseraccess 224 () ) +(define-syscall (logior platform-os-darwin platform-cpu-ppc) syscalls::searchfs 225 () ) + + ; 226 - 230 are reserved for HFS expansion + ; 231 - 249 are reserved +(define-syscall (logior platform-os-darwin platform-cpu-ppc) syscalls::minherit 250 () ) +(define-syscall (logior platform-os-darwin platform-cpu-ppc) syscalls::semsys 251 () ) +(define-syscall (logior platform-os-darwin platform-cpu-ppc) syscalls::msgsys 252 () ) +(define-syscall (logior platform-os-darwin platform-cpu-ppc) syscalls::shmsys 253 () ) +(define-syscall (logior platform-os-darwin platform-cpu-ppc) syscalls::semctl 254 () ) +(define-syscall (logior platform-os-darwin platform-cpu-ppc) syscalls::semget 255 () ) +(define-syscall (logior platform-os-darwin platform-cpu-ppc) syscalls::semop 256 () ) +(define-syscall (logior platform-os-darwin platform-cpu-ppc) syscalls::semconfig 257 () ) +(define-syscall (logior platform-os-darwin platform-cpu-ppc) syscalls::msgctl 258 () ) +(define-syscall (logior platform-os-darwin platform-cpu-ppc) syscalls::msgget 259 () ) +(define-syscall (logior platform-os-darwin platform-cpu-ppc) syscalls::msgsnd 260 () ) +(define-syscall (logior platform-os-darwin platform-cpu-ppc) syscalls::msgrcv 261 () ) +(define-syscall (logior platform-os-darwin platform-cpu-ppc) syscalls::shmat 262 () ) +(define-syscall (logior platform-os-darwin platform-cpu-ppc) syscalls::shmctl 263 () ) +(define-syscall (logior platform-os-darwin platform-cpu-ppc) syscalls::shmdt 264 () ) +(define-syscall (logior platform-os-darwin platform-cpu-ppc) syscalls::shmget 265 () ) +(define-syscall (logior platform-os-darwin platform-cpu-ppc) syscalls::shm_open 266 () ) +(define-syscall (logior platform-os-darwin platform-cpu-ppc) syscalls::shm_unlink 267 () ) +(define-syscall (logior platform-os-darwin platform-cpu-ppc) syscalls::sem_open 268 () ) +(define-syscall (logior platform-os-darwin platform-cpu-ppc) syscalls::sem_close 269 () ) +(define-syscall (logior platform-os-darwin platform-cpu-ppc) syscalls::sem_unlink 270 () ) +(define-syscall (logior platform-os-darwin platform-cpu-ppc) syscalls::sem_wait 271 () ) +(define-syscall (logior platform-os-darwin platform-cpu-ppc) syscalls::sem_trywait 272 () ) +(define-syscall (logior platform-os-darwin platform-cpu-ppc) syscalls::sem_post 273 () ) +(define-syscall (logior platform-os-darwin platform-cpu-ppc) syscalls::sem_getvalue 274 () ) +(define-syscall (logior platform-os-darwin platform-cpu-ppc) syscalls::sem_init 275 () ) +(define-syscall (logior platform-os-darwin platform-cpu-ppc) syscalls::sem_destroy 276 () ) + ; 277 - 295 are reserved +(define-syscall (logior platform-os-darwin platform-cpu-ppc) syscalls::load_shared_file 296 () ) +(define-syscall (logior platform-os-darwin platform-cpu-ppc) syscalls::reset_shared_file 297 () ) + ; 298 - 323 are reserved +(define-syscall (logior platform-os-darwin platform-cpu-ppc) syscalls::mlockall 324 () ) +(define-syscall (logior platform-os-darwin platform-cpu-ppc) syscalls::munlockall 325 () ) + ; 326 is reserved +(define-syscall (logior platform-os-darwin platform-cpu-ppc) syscalls::issetugid 327 () ) +) Index: /branches/new-random/library/darwinx8632-syscalls.lisp =================================================================== --- /branches/new-random/library/darwinx8632-syscalls.lisp (revision 13309) +++ /branches/new-random/library/darwinx8632-syscalls.lisp (revision 13309) @@ -0,0 +1,296 @@ +;;; Copyright 2009 Clozure Associates +;;; This file is part of Clozure CL. +;;; +;;; Clozure CL is licensed under the terms of the Lisp Lesser GNU +;;; Public License , known as the LLGPL and distributed with Clozure +;;; CL as the file "LICENSE". The LLGPL consists of a preamble and +;;; the LGPL, which is distributed with Clozure CL as the file "LGPL". +;;; Where these conflict, the preamble takes precedence. +;;; +;;; Clozure CL is referenced in the preamble as the "LIBRARY." +;;; +;;; The LLGPL is also available online at +;;; http://opensource.franz.com/preamble.html + +(in-package "CCL") + +(eval-when (:compile-toplevel :load-toplevel :execute) + (require "SYSCALL")) + +(define-syscall (logior platform-os-darwin platform-cpu-x86 platform-word-size-32) syscalls::exit 1 (:int) :void ) +(define-syscall (logior platform-os-darwin platform-cpu-x86 platform-word-size-32) syscalls::fork 2 () :void) +(define-syscall (logior platform-os-darwin platform-cpu-x86 platform-word-size-32) syscalls::read 3 (:unsigned-fullword :address :unsigned-long) + :signed-long ) +(define-syscall (logior platform-os-darwin platform-cpu-x86 platform-word-size-32) syscalls::write 4 (:unsigned-fullword :address :unsigned-long) + :signed-long ) +(define-syscall (logior platform-os-darwin platform-cpu-x86 platform-word-size-32) syscalls::open 5 (:address :unsigned-fullword :unsigned-fullword) :signed-fullword :min-args 2 ) +(define-syscall (logior platform-os-darwin platform-cpu-x86 platform-word-size-32) syscalls::close 6 (:unsigned-fullword) :signed-fullword ) +(define-syscall (logior platform-os-darwin platform-cpu-x86 platform-word-size-32) syscalls::wait4 7 (:unsigned-fullword :address :signed-fullword :address) :unsigned-fullword ) + ; 8 is old creat +(define-syscall (logior platform-os-darwin platform-cpu-x86 platform-word-size-32) syscalls::link 9 (:address :address) :signed-fullword ) +(define-syscall (logior platform-os-darwin platform-cpu-x86 platform-word-size-32) syscalls::unlink 10 (:address) :signed-fullword ) + ; 11 is obsolete execv +(define-syscall (logior platform-os-darwin platform-cpu-x86 platform-word-size-32) syscalls::chdir 12 (:address) :signed-fullword ) +(define-syscall (logior platform-os-darwin platform-cpu-x86 platform-word-size-32) syscalls::fchdir 13 (:unsigned-fullword) :signed-fullword ) +(define-syscall (logior platform-os-darwin platform-cpu-x86 platform-word-size-32) syscalls::mknod 14 (:address :unsigned-fullword :unsigned-fullword) + :signed-fullword ) +(define-syscall (logior platform-os-darwin platform-cpu-x86 platform-word-size-32) syscalls::chmod 15 (:address :unsigned-fullword) :signed-fullword ) +(define-syscall (logior platform-os-darwin platform-cpu-x86 platform-word-size-32) syscalls::lchown 16 (:address :unsigned-fullword :unsigned-fullword) + :signed-fullword) +(define-syscall (logior platform-os-darwin platform-cpu-x86 platform-word-size-32) syscalls::getpid 20 () :signed-fullword ) +(define-syscall (logior platform-os-darwin platform-cpu-x86 platform-word-size-32) syscalls::setuid 23 (:unsigned-fullword) :signed-fullword ) +(define-syscall (logior platform-os-darwin platform-cpu-x86 platform-word-size-32) syscalls::getuid 24 () :unsigned-fullword ) +(define-syscall (logior platform-os-darwin platform-cpu-x86 platform-word-size-32) syscalls::geteuid 25 () :unsigned-fullword ) +(define-syscall (logior platform-os-darwin platform-cpu-x86 platform-word-size-32) syscalls::recvmsg 27 (:unsigned-fullword :address :unsigned-fullword):signed-fullword ) +(define-syscall (logior platform-os-darwin platform-cpu-x86 platform-word-size-32) syscalls::sendmsg 28 (:unsigned-fullword :address :unsigned-fullword):signed-fullword ) +(define-syscall (logior platform-os-darwin platform-cpu-x86 platform-word-size-32) syscalls::recvfrom 29 (:unsigned-fullword :address :unsigned-long :unsigned-fullword :address :address) :signed-fullword ) +(define-syscall (logior platform-os-darwin platform-cpu-x86 platform-word-size-32) syscalls::accept 30 (:unsigned-fullword :address :address) :signed-fullword ) +(define-syscall (logior platform-os-darwin platform-cpu-x86 platform-word-size-32) syscalls::getpeername 31 (:unsigned-fullword :address :address) :signed-fullword ) +(define-syscall (logior platform-os-darwin platform-cpu-x86 platform-word-size-32) syscalls::getsockname 32 (:unsigned-fullword :address :address) :signed-fullword ) +(define-syscall (logior platform-os-darwin platform-cpu-x86 platform-word-size-32) syscalls::kill 37 (:signed-fullword :unsigned-fullword) :signed-fullword ) +(define-syscall (logior platform-os-darwin platform-cpu-x86 platform-word-size-32) syscalls::sync 36 () :unsigned-fullword ) + ; 38 is old stat +(define-syscall (logior platform-os-darwin platform-cpu-x86 platform-word-size-32) syscalls::getppid 39 () :unsigned-fullword) +(define-syscall (logior platform-os-darwin platform-cpu-x86 platform-word-size-32) syscalls::dup 41 (:unsigned-fullword) :signed-fullword ) +(define-syscall (logior platform-os-darwin platform-cpu-x86 platform-word-size-32) syscalls::pipe 42 () :signed-doubleword ) +(define-syscall (logior platform-os-darwin platform-cpu-x86 platform-word-size-32) syscalls::getgid 47 () :unsigned-fullword) +(define-syscall (logior platform-os-darwin platform-cpu-x86 platform-word-size-32) syscalls::ioctl 54 (:unsigned-fullword :signed-fullword :address) :signed-fullword :min-args 2 ) +(define-syscall (logior platform-os-darwin platform-cpu-x86 platform-word-size-32) syscalls::dup2 90 (:unsigned-fullword :unsigned-fullword) :signed-fullword ) +(define-syscall (logior platform-os-darwin platform-cpu-x86 platform-word-size-32) syscalls::fcntl 92 (:unsigned-fullword :signed-fullword :signed-fullword) :signed-fullword :min-args 2 ) +(define-syscall (logior platform-os-darwin platform-cpu-x86 platform-word-size-32) syscalls::select 93 (:unsigned-fullword :address :address + :address :address) + :signed-fullword) +(define-syscall (logior platform-os-darwin platform-cpu-x86 platform-word-size-32) syscalls::fsync 95 (:unsigned-fullword) :signed-fullword ) +(define-syscall (logior platform-os-darwin platform-cpu-x86 platform-word-size-32) syscalls::socket 97 (:unsigned-fullword :unsigned-fullword :unsigned-fullword) :signed-fullword ) +(define-syscall (logior platform-os-darwin platform-cpu-x86 platform-word-size-32) syscalls::connect 98 (:unsigned-fullword :address :unsigned-fullword) :signed-fullword) +(define-syscall (logior platform-os-darwin platform-cpu-x86 platform-word-size-32) syscalls::bind 104 (:unsigned-fullword :address :unsigned-fullword) :signed-fullword ) +(define-syscall (logior platform-os-darwin platform-cpu-x86 platform-word-size-32) syscalls::setsockopt 105 (:unsigned-fullword :signed-fullword :signed-fullword :address :unsigned-fullword) :signed-fullword ) +(define-syscall (logior platform-os-darwin platform-cpu-x86 platform-word-size-32) syscalls::listen 106 (:unsigned-fullword :unsigned-fullword) :signed-fullword ) +(define-syscall (logior platform-os-darwin platform-cpu-x86 platform-word-size-32) syscalls::gettimeofday 116 (:address :address) :signed-fullword ) +(define-syscall (logior platform-os-darwin platform-cpu-x86 platform-word-size-32) syscalls::getrusage 117 (:signed-fullword :address) :signed-fullword ) +(define-syscall (logior platform-os-darwin platform-cpu-x86 platform-word-size-32) syscalls::getsockopt 118 (:unsigned-fullword :signed-fullword :unsigned-fullword :address :address) :signed-fullword ) +(define-syscall (logior platform-os-darwin platform-cpu-x86 platform-word-size-32) syscalls::fchmod 124 (:unsigned-fullword :unsigned-fullword) :signed-fullword ) +(define-syscall (logior platform-os-darwin platform-cpu-x86 platform-word-size-32) syscalls::rename 128 (:address :address) :signed-fullword) + ; 129 is old truncate + ; 130 is old ftruncate +(define-syscall (logior platform-os-darwin platform-cpu-x86 platform-word-size-32) syscalls::sendto 133 (:unsigned-fullword :address :unsigned-fullword :unsigned-fullword :address :unsigned-fullword) :signed-fullword ) + +(define-syscall (logior platform-os-darwin platform-cpu-x86 platform-word-size-32) syscalls::shutdown 134 (:unsigned-fullword :unsigned-fullword) :signed-fullword ) +(define-syscall (logior platform-os-darwin platform-cpu-x86 platform-word-size-32) syscalls::socketpair 135 (:unsigned-fullword :unsigned-fullword :unsigned-fullword :address) :signed-fullword ) + +(define-syscall (logior platform-os-darwin platform-cpu-x86 platform-word-size-32) syscalls::mkdir 136 (:address :unsigned-fullword) :signed-fullword) +(define-syscall (logior platform-os-darwin platform-cpu-x86 platform-word-size-32) syscalls::rmdir 137 (:address) :signed-fullword ) +(define-syscall (logior platform-os-darwin platform-cpu-x86 platform-word-size-32) syscalls::mount 167 (:address :address :unsigned-fullword :address) :signed-fullword ) +(define-syscall (logior platform-os-darwin platform-cpu-x86 platform-word-size-32) syscalls::setgid 181 (:unsigned-fullword) :signed-fullword ) +(define-syscall (logior platform-os-darwin platform-cpu-x86 platform-word-size-32) syscalls::stat 188 (:address :address) :signed-fullword ) +(define-syscall (logior platform-os-darwin platform-cpu-x86 platform-word-size-32) syscalls::fstat 189 (:unsigned-fullword :address) :signed-fullword ) +(define-syscall (logior platform-os-darwin platform-cpu-x86 platform-word-size-32) syscalls::lstat 190 (:address :address) :signed-fullword ) +(define-syscall (logior platform-os-darwin platform-cpu-x86 platform-word-size-32) syscalls::lseek 199 (:unsigned-fullword :signed-doubleword :unsigned-fullword) :signed-doubleword ) +(define-syscall (logior platform-os-darwin platform-cpu-x86 platform-word-size-32) syscalls::truncate 200 (:address :unsigned-doubleword) :signed-fullword ) +(define-syscall (logior platform-os-darwin platform-cpu-x86 platform-word-size-32) syscalls::ftruncate 201 (:unsigned-fullword :unsigned-doubleword) :signed-fullword ) +(define-syscall (logior platform-os-darwin platform-cpu-x86 platform-word-size-32) syscalls::poll 230 ((:* (:struct :pollfd)) :int :int) :int) + +#+notdefinedyet +(progn + ; 17 is obsolete sbreak + ; 18 is old getfsstat + ; 19 is old lseek + ; 21 is obsolete mount + ; 22 is obsolete umount +(define-syscall (logior platform-os-darwin platform-cpu-x86 platform-word-size-32) syscalls::ptrace 26 () ) +(define-syscall (logior platform-os-darwin platform-cpu-x86 platform-word-size-32) syscalls::access 33 () ) +(define-syscall (logior platform-os-darwin platform-cpu-x86 platform-word-size-32) syscalls::chflags 34 () ) +(define-syscall (logior platform-os-darwin platform-cpu-x86 platform-word-size-32) syscalls::fchflags 35 () ) + ; 40 is old lstat +(define-syscall (logior platform-os-darwin platform-cpu-x86 platform-word-size-32) syscalls::getegid 43 () ) +(define-syscall (logior platform-os-darwin platform-cpu-x86 platform-word-size-32) syscalls::profil 44 () ) +(define-syscall (logior platform-os-darwin platform-cpu-x86 platform-word-size-32) syscalls::ktrace 45 () ) +(define-syscall (logior platform-os-darwin platform-cpu-x86 platform-word-size-32) syscalls::sigaction 46 () ) +(define-syscall (logior platform-os-darwin platform-cpu-x86 platform-word-size-32) syscalls::sigprocmask 48 () ) +(define-syscall (logior platform-os-darwin platform-cpu-x86 platform-word-size-32) syscalls::getlogin 49 () ) +(define-syscall (logior platform-os-darwin platform-cpu-x86 platform-word-size-32) syscalls::setlogin 50 () ) +(define-syscall (logior platform-os-darwin platform-cpu-x86 platform-word-size-32) syscalls::acct 51 () ) +(define-syscall (logior platform-os-darwin platform-cpu-x86 platform-word-size-32) syscalls::sigpending 52 () ) +(define-syscall (logior platform-os-darwin platform-cpu-x86 platform-word-size-32) syscalls::sigaltstack 53 () ) +(define-syscall (logior platform-os-darwin platform-cpu-x86 platform-word-size-32) syscalls::reboot 55 () ) +(define-syscall (logior platform-os-darwin platform-cpu-x86 platform-word-size-32) syscalls::revoke 56 () ) +(define-syscall (logior platform-os-darwin platform-cpu-x86 platform-word-size-32) syscalls::symlink 57 () ) +(define-syscall (logior platform-os-darwin platform-cpu-x86 platform-word-size-32) syscalls::readlink 58 () ) +(define-syscall (logior platform-os-darwin platform-cpu-x86 platform-word-size-32) syscalls::execve 59 () ) +(define-syscall (logior platform-os-darwin platform-cpu-x86 platform-word-size-32) syscalls::umask 60 () ) +(define-syscall (logior platform-os-darwin platform-cpu-x86 platform-word-size-32) syscalls::chroot 61 () ) + ; 62 is old fstat + ; 63 is unused + ; 64 is old getpagesize +(define-syscall (logior platform-os-darwin platform-cpu-x86 platform-word-size-32) syscalls::msync 65 () ) +(define-syscall (logior platform-os-darwin platform-cpu-x86 platform-word-size-32) syscalls::vfork 66 () ) + ; 67 is obsolete vread + ; 68 is obsolete vwrite +(define-syscall (logior platform-os-darwin platform-cpu-x86 platform-word-size-32) syscalls::sbrk 69 () ) +(define-syscall (logior platform-os-darwin platform-cpu-x86 platform-word-size-32) syscalls::sstk 70 () ) + ; 71 is old mmap + ; 72 is obsolete vadvise +(define-syscall (logior platform-os-darwin platform-cpu-x86 platform-word-size-32) syscalls::munmap 73 () ) +(define-syscall (logior platform-os-darwin platform-cpu-x86 platform-word-size-32) syscalls::mprotect 74 () ) +(define-syscall (logior platform-os-darwin platform-cpu-x86 platform-word-size-32) syscalls::madvise 75 () ) + ; 76 is obsolete vhangup + ; 77 is obsolete vlimit +(define-syscall (logior platform-os-darwin platform-cpu-x86 platform-word-size-32) syscalls::mincore 78 () ) +(define-syscall (logior platform-os-darwin platform-cpu-x86 platform-word-size-32) syscalls::getgroups 79 () ) +(define-syscall (logior platform-os-darwin platform-cpu-x86 platform-word-size-32) syscalls::setgroups 80 () ) +(define-syscall (logior platform-os-darwin platform-cpu-x86 platform-word-size-32) syscalls::getpgrp 81 () ) +(define-syscall (logior platform-os-darwin platform-cpu-x86 platform-word-size-32) syscalls::setpgid 82 () ) +(define-syscall (logior platform-os-darwin platform-cpu-x86 platform-word-size-32) syscalls::setitimer 83 () ) + ; 84 is old wait +(define-syscall (logior platform-os-darwin platform-cpu-x86 platform-word-size-32) syscalls::swapon 85 () ) +(define-syscall (logior platform-os-darwin platform-cpu-x86 platform-word-size-32) syscalls::getitimer 86 () ) + ; 87 is old gethostname + ; 88 is old sethostname +(define-syscall (logior platform-os-darwin platform-cpu-x86 platform-word-size-32) syscalls::getdtablesize 89 () ) + + + ; 94 is obsolete setdopt +(define-syscall (logior platform-os-darwin platform-cpu-x86 platform-word-size-32) syscalls::setpriority 96 () ) + ; 99 is old accept +(define-syscall (logior platform-os-darwin platform-cpu-x86 platform-word-size-32) syscalls::getpriority 100 () ) + ; 101 is old send + ; 102 is old recv +(define-syscall (logior platform-os-darwin platform-cpu-x86 platform-word-size-32) syscalls::sigreturn 103 () ) + ; 107 is obsolete vtimes + ; 108 is old sigvec + ; 109 is old sigblock + ; 110 is old sigsetmask +(define-syscall (logior platform-os-darwin platform-cpu-x86 platform-word-size-32) syscalls::sigsuspend 111 () ) + ; 112 is old sigstack + ; 113 is old recvmsg + ; 114 is old sendmsg + ; 115 is obsolete vtrace + ; 119 is obsolete resuba +(define-syscall (logior platform-os-darwin platform-cpu-x86 platform-word-size-32) syscalls::readv 120 () ) +(define-syscall (logior platform-os-darwin platform-cpu-x86 platform-word-size-32) syscalls::writev 121 () ) +(define-syscall (logior platform-os-darwin platform-cpu-x86 platform-word-size-32) syscalls::settimeofday 122 () ) +(define-syscall (logior platform-os-darwin platform-cpu-x86 platform-word-size-32) syscalls::fchown 123 () ) + ; 125 is old recvfrom + ; 126 is old setreuid + ; 127 is old setregid +(define-syscall (logior platform-os-darwin platform-cpu-x86 platform-word-size-32) syscalls::flock 131 () ) +(define-syscall (logior platform-os-darwin platform-cpu-x86 platform-word-size-32) syscalls::mkfifo 132 () ) +(define-syscall (logior platform-os-darwin platform-cpu-x86 platform-word-size-32) syscalls::utimes 138 () ) + ; 139 is unused +(define-syscall (logior platform-os-darwin platform-cpu-x86 platform-word-size-32) syscalls::adjtime 140 () ) + ; 141 is old getpeername + ; 142 is old gethostid + ; 143 is old sethostid + ; 144 is old getrlimit + ; 145 is old setrlimit + ; 146 is old killpg +(define-syscall (logior platform-os-darwin platform-cpu-x86 platform-word-size-32) syscalls::setsid 147 () ) + ; 148 is obsolete setquota + ; 149 is obsolete quota + ; 150 is old getsockname + ; 151 is reserved +(define-syscall (logior platform-os-darwin platform-cpu-x86 platform-word-size-32) syscalls::setprivexec 152 () ) + ; 153 is reserved + ; 154 is reserved +(define-syscall (logior platform-os-darwin platform-cpu-x86 platform-word-size-32) syscalls::nfssvc 155 () ) + ; 156 is old getdirentries +(define-syscall (logior platform-os-darwin platform-cpu-x86 platform-word-size-32) syscalls::statfs 157 () ) +(define-syscall (logior platform-os-darwin platform-cpu-x86 platform-word-size-32) syscalls::fstatfs 158 () ) +(define-syscall (logior platform-os-darwin platform-cpu-x86 platform-word-size-32) syscalls::unmount 159 () ) + ; 160 is obsolete async_daemon +(define-syscall (logior platform-os-darwin platform-cpu-x86 platform-word-size-32) syscalls::getfh 161 () ) + ; 162 is old getdomainname + ; 163 is old setdomainname + ; 164 is obsolete pcfs_mount +(define-syscall (logior platform-os-darwin platform-cpu-x86 platform-word-size-32) syscalls::quotactl 165 () ) + ; 166 is obsolete exportfs + + ; 168 is obsolete ustat + ; 169 is unused +(define-syscall (logior platform-os-darwin platform-cpu-x86 platform-word-size-32) syscalls::table 170 () ) + ; 171 is old wait_3 + ; 172 is obsolete rpause + ; 173 is unused + ; 174 is obsolete getdents +(define-syscall (logior platform-os-darwin platform-cpu-x86 platform-word-size-32) syscalls::gc_control 175 () ) +(define-syscall (logior platform-os-darwin platform-cpu-x86 platform-word-size-32) syscalls::add_profil 176 () ) + ; 177 is unused + ; 178 is unused + ; 179 is unused +(define-syscall (logior platform-os-darwin platform-cpu-x86 platform-word-size-32) syscalls::kdebug_trace 180 () ) +(define-syscall (logior platform-os-darwin platform-cpu-x86 platform-word-size-32) syscalls::setegid 182 () ) +(define-syscall (logior platform-os-darwin platform-cpu-x86 platform-word-size-32) syscalls::seteuid 183 () ) +(define-syscall (logior platform-os-darwin platform-cpu-x86 platform-word-size-32) syscalls::lfs_bmapv 184 () ) +(define-syscall (logior platform-os-darwin platform-cpu-x86 platform-word-size-32) syscalls::lfs_markv 185 () ) +(define-syscall (logior platform-os-darwin platform-cpu-x86 platform-word-size-32) syscalls::lfs_segclean 186 () ) +(define-syscall (logior platform-os-darwin platform-cpu-x86 platform-word-size-32) syscalls::lfs_segwait 187 () ) +(define-syscall (logior platform-os-darwin platform-cpu-x86 platform-word-size-32) syscalls::pathconf 191 () ) +(define-syscall (logior platform-os-darwin platform-cpu-x86 platform-word-size-32) syscalls::fpathconf 192 () ) +(define-syscall (logior platform-os-darwin platform-cpu-x86 platform-word-size-32) syscalls::getrlimit 194 () ) +(define-syscall (logior platform-os-darwin platform-cpu-x86 platform-word-size-32) syscalls::setrlimit 195 () ) +(define-syscall (logior platform-os-darwin platform-cpu-x86 platform-word-size-32) syscalls::getdirentries 196 () ) +(define-syscall (logior platform-os-darwin platform-cpu-x86 platform-word-size-32) syscalls::mmap 197 () ) +(define-syscall (logior platform-os-darwin platform-cpu-x86 platform-word-size-32) syscalls::__syscall 198 () ) +(define-syscall (logior platform-os-darwin platform-cpu-x86 platform-word-size-32) syscalls::__sysctl 202 () ) +(define-syscall (logior platform-os-darwin platform-cpu-x86 platform-word-size-32) syscalls::mlock 203 () ) +(define-syscall (logior platform-os-darwin platform-cpu-x86 platform-word-size-32) syscalls::munlock 204 () ) +(define-syscall (logior platform-os-darwin platform-cpu-x86 platform-word-size-32) syscalls::undelete 205 () ) +(define-syscall (logior platform-os-darwin platform-cpu-x86 platform-word-size-32) syscalls::ATsocket 206 () ) +(define-syscall (logior platform-os-darwin platform-cpu-x86 platform-word-size-32) syscalls::ATgetmsg 207 () ) +(define-syscall (logior platform-os-darwin platform-cpu-x86 platform-word-size-32) syscalls::ATputmsg 208 () ) +(define-syscall (logior platform-os-darwin platform-cpu-x86 platform-word-size-32) syscalls::ATPsndreq 209 () ) +(define-syscall (logior platform-os-darwin platform-cpu-x86 platform-word-size-32) syscalls::ATPsndrsp 210 () ) +(define-syscall (logior platform-os-darwin platform-cpu-x86 platform-word-size-32) syscalls::ATPgetreq 211 () ) +(define-syscall (logior platform-os-darwin platform-cpu-x86 platform-word-size-32) syscalls::ATPgetrsp 212 () ) + ; 213-215 are reserved for AppleTalk +(define-syscall (logior platform-os-darwin platform-cpu-x86 platform-word-size-32) syscalls::mkcomplex 216 () ) +(define-syscall (logior platform-os-darwin platform-cpu-x86 platform-word-size-32) syscalls::statv 217 () ) +(define-syscall (logior platform-os-darwin platform-cpu-x86 platform-word-size-32) syscalls::lstatv 218 () ) +(define-syscall (logior platform-os-darwin platform-cpu-x86 platform-word-size-32) syscalls::fstatv 219 () ) +(define-syscall (logior platform-os-darwin platform-cpu-x86 platform-word-size-32) syscalls::getattrlist 220 () ) +(define-syscall (logior platform-os-darwin platform-cpu-x86 platform-word-size-32) syscalls::setattrlist 221 () ) +(define-syscall (logior platform-os-darwin platform-cpu-x86 platform-word-size-32) syscalls::getdirentriesattr 222 () ) +(define-syscall (logior platform-os-darwin platform-cpu-x86 platform-word-size-32) syscalls::exchangedata 223 () ) +(define-syscall (logior platform-os-darwin platform-cpu-x86 platform-word-size-32) syscalls::checkuseraccess 224 () ) +(define-syscall (logior platform-os-darwin platform-cpu-x86 platform-word-size-32) syscalls::searchfs 225 () ) + + ; 226 - 230 are reserved for HFS expansion + ; 231 - 249 are reserved +(define-syscall (logior platform-os-darwin platform-cpu-x86 platform-word-size-32) syscalls::minherit 250 () ) +(define-syscall (logior platform-os-darwin platform-cpu-x86 platform-word-size-32) syscalls::semsys 251 () ) +(define-syscall (logior platform-os-darwin platform-cpu-x86 platform-word-size-32) syscalls::msgsys 252 () ) +(define-syscall (logior platform-os-darwin platform-cpu-x86 platform-word-size-32) syscalls::shmsys 253 () ) +(define-syscall (logior platform-os-darwin platform-cpu-x86 platform-word-size-32) syscalls::semctl 254 () ) +(define-syscall (logior platform-os-darwin platform-cpu-x86 platform-word-size-32) syscalls::semget 255 () ) +(define-syscall (logior platform-os-darwin platform-cpu-x86 platform-word-size-32) syscalls::semop 256 () ) +(define-syscall (logior platform-os-darwin platform-cpu-x86 platform-word-size-32) syscalls::semconfig 257 () ) +(define-syscall (logior platform-os-darwin platform-cpu-x86 platform-word-size-32) syscalls::msgctl 258 () ) +(define-syscall (logior platform-os-darwin platform-cpu-x86 platform-word-size-32) syscalls::msgget 259 () ) +(define-syscall (logior platform-os-darwin platform-cpu-x86 platform-word-size-32) syscalls::msgsnd 260 () ) +(define-syscall (logior platform-os-darwin platform-cpu-x86 platform-word-size-32) syscalls::msgrcv 261 () ) +(define-syscall (logior platform-os-darwin platform-cpu-x86 platform-word-size-32) syscalls::shmat 262 () ) +(define-syscall (logior platform-os-darwin platform-cpu-x86 platform-word-size-32) syscalls::shmctl 263 () ) +(define-syscall (logior platform-os-darwin platform-cpu-x86 platform-word-size-32) syscalls::shmdt 264 () ) +(define-syscall (logior platform-os-darwin platform-cpu-x86 platform-word-size-32) syscalls::shmget 265 () ) +(define-syscall (logior platform-os-darwin platform-cpu-x86 platform-word-size-32) syscalls::shm_open 266 () ) +(define-syscall (logior platform-os-darwin platform-cpu-x86 platform-word-size-32) syscalls::shm_unlink 267 () ) +(define-syscall (logior platform-os-darwin platform-cpu-x86 platform-word-size-32) syscalls::sem_open 268 () ) +(define-syscall (logior platform-os-darwin platform-cpu-x86 platform-word-size-32) syscalls::sem_close 269 () ) +(define-syscall (logior platform-os-darwin platform-cpu-x86 platform-word-size-32) syscalls::sem_unlink 270 () ) +(define-syscall (logior platform-os-darwin platform-cpu-x86 platform-word-size-32) syscalls::sem_wait 271 () ) +(define-syscall (logior platform-os-darwin platform-cpu-x86 platform-word-size-32) syscalls::sem_trywait 272 () ) +(define-syscall (logior platform-os-darwin platform-cpu-x86 platform-word-size-32) syscalls::sem_post 273 () ) +(define-syscall (logior platform-os-darwin platform-cpu-x86 platform-word-size-32) syscalls::sem_getvalue 274 () ) +(define-syscall (logior platform-os-darwin platform-cpu-x86 platform-word-size-32) syscalls::sem_init 275 () ) +(define-syscall (logior platform-os-darwin platform-cpu-x86 platform-word-size-32) syscalls::sem_destroy 276 () ) + ; 277 - 295 are reserved +(define-syscall (logior platform-os-darwin platform-cpu-x86 platform-word-size-32) syscalls::load_shared_file 296 () ) +(define-syscall (logior platform-os-darwin platform-cpu-x86 platform-word-size-32) syscalls::reset_shared_file 297 () ) + ; 298 - 323 are reserved +(define-syscall (logior platform-os-darwin platform-cpu-x86 platform-word-size-32) syscalls::mlockall 324 () ) +(define-syscall (logior platform-os-darwin platform-cpu-x86 platform-word-size-32) syscalls::munlockall 325 () ) + ; 326 is reserved +(define-syscall (logior platform-os-darwin platform-cpu-x86 platform-word-size-32) syscalls::issetugid 327 () ) +) + + Index: /branches/new-random/library/darwinx8664-syscalls.lisp =================================================================== --- /branches/new-random/library/darwinx8664-syscalls.lisp (revision 13309) +++ /branches/new-random/library/darwinx8664-syscalls.lisp (revision 13309) @@ -0,0 +1,297 @@ +;;;-*-Mode: LISP; Package: CCL -*- +;;; +;;; Copyright (C) 2001-2009 Clozure Associates +;;; This file is part of Clozure CL. +;;; +;;; Clozure CL is licensed under the terms of the Lisp Lesser GNU Public +;;; License , known as the LLGPL and distributed with Clozure CL as the +;;; file "LICENSE". The LLGPL consists of a preamble and the LGPL, +;;; which is distributed with Clozure CL as the file "LGPL". Where these +;;; conflict, the preamble takes precedence. +;;; +;;; Clozure CL is referenced in the preamble as the "LIBRARY." +;;; +;;; The LLGPL is also available online at +;;; http://opensource.franz.com/preamble.html + +(in-package "CCL") + + +(eval-when (:compile-toplevel :load-toplevel :execute) + (require "SYSCALL") + (defconstant darwinx8664-unix-syscall-mask #x2000000)) + +(define-syscall (logior platform-os-darwin platform-cpu-x86 platform-word-size-64) syscalls::exit (logior darwinx8664-unix-syscall-mask 1) (:int) :void ) +(define-syscall (logior platform-os-darwin platform-cpu-x86 platform-word-size-64) syscalls::fork (logior darwinx8664-unix-syscall-mask 2) () :void) +(define-syscall (logior platform-os-darwin platform-cpu-x86 platform-word-size-64) syscalls::read (logior darwinx8664-unix-syscall-mask 3) (:unsigned-fullword :address :unsigned-long) + :signed-long ) +(define-syscall (logior platform-os-darwin platform-cpu-x86 platform-word-size-64) syscalls::write (logior darwinx8664-unix-syscall-mask 4) (:unsigned-fullword :address :unsigned-long) + :signed-long ) +(define-syscall (logior platform-os-darwin platform-cpu-x86 platform-word-size-64) syscalls::open (logior darwinx8664-unix-syscall-mask 5) (:address :unsigned-fullword :unsigned-fullword) :signed-fullword :min-args 2 ) +(define-syscall (logior platform-os-darwin platform-cpu-x86 platform-word-size-64) syscalls::close (logior darwinx8664-unix-syscall-mask 6) (:unsigned-fullword) :signed-fullword ) +(define-syscall (logior platform-os-darwin platform-cpu-x86 platform-word-size-64) syscalls::wait4 (logior darwinx8664-unix-syscall-mask 7) (:unsigned-fullword :address :signed-fullword :address) :unsigned-fullword ) + ; 8 is old creat +(define-syscall (logior platform-os-darwin platform-cpu-x86 platform-word-size-64) syscalls::link (logior darwinx8664-unix-syscall-mask 9) (:address :address) :signed-fullword ) +(define-syscall (logior platform-os-darwin platform-cpu-x86 platform-word-size-64) syscalls::unlink (logior darwinx8664-unix-syscall-mask 10) (:address) :signed-fullword ) + ; 11 is obsolete execv +(define-syscall (logior platform-os-darwin platform-cpu-x86 platform-word-size-64) syscalls::chdir (logior darwinx8664-unix-syscall-mask 12) (:address) :signed-fullword ) +(define-syscall (logior platform-os-darwin platform-cpu-x86 platform-word-size-64) syscalls::fchdir (logior darwinx8664-unix-syscall-mask 13) (:unsigned-fullword) :signed-fullword ) +(define-syscall (logior platform-os-darwin platform-cpu-x86 platform-word-size-64) syscalls::mknod (logior darwinx8664-unix-syscall-mask 14) (:address :unsigned-fullword :unsigned-fullword) + :signed-fullword ) +(define-syscall (logior platform-os-darwin platform-cpu-x86 platform-word-size-64) syscalls::chmod (logior darwinx8664-unix-syscall-mask 15) (:address :unsigned-fullword) :signed-fullword ) +(define-syscall (logior platform-os-darwin platform-cpu-x86 platform-word-size-64) syscalls::lchown (logior darwinx8664-unix-syscall-mask 16) (:address :unsigned-fullword :unsigned-fullword) + :signed-fullword) +(define-syscall (logior platform-os-darwin platform-cpu-x86 platform-word-size-64) syscalls::getpid (logior darwinx8664-unix-syscall-mask 20) () :signed-fullword ) +(define-syscall (logior platform-os-darwin platform-cpu-x86 platform-word-size-64) syscalls::setuid (logior darwinx8664-unix-syscall-mask 23) (:unsigned-fullword) :signed-fullword ) +(define-syscall (logior platform-os-darwin platform-cpu-x86 platform-word-size-64) syscalls::getuid (logior darwinx8664-unix-syscall-mask 24) () :unsigned-fullword ) +(define-syscall (logior platform-os-darwin platform-cpu-x86 platform-word-size-64) syscalls::geteuid (logior darwinx8664-unix-syscall-mask 25) () :unsigned-fullword ) +(define-syscall (logior platform-os-darwin platform-cpu-x86 platform-word-size-64) syscalls::recvmsg (logior darwinx8664-unix-syscall-mask 27) (:unsigned-fullword :address :unsigned-fullword):signed-fullword ) +(define-syscall (logior platform-os-darwin platform-cpu-x86 platform-word-size-64) syscalls::sendmsg (logior darwinx8664-unix-syscall-mask 28) (:unsigned-fullword :address :unsigned-fullword):signed-fullword ) +(define-syscall (logior platform-os-darwin platform-cpu-x86 platform-word-size-64) syscalls::recvfrom (logior darwinx8664-unix-syscall-mask 29) (:unsigned-fullword :address :unsigned-long :unsigned-fullword :address :address) :signed-fullword ) +(define-syscall (logior platform-os-darwin platform-cpu-x86 platform-word-size-64) syscalls::accept (logior darwinx8664-unix-syscall-mask 30) (:unsigned-fullword :address :address) :signed-fullword ) +(define-syscall (logior platform-os-darwin platform-cpu-x86 platform-word-size-64) syscalls::getpeername (logior darwinx8664-unix-syscall-mask 31) (:unsigned-fullword :address :address) :signed-fullword ) +(define-syscall (logior platform-os-darwin platform-cpu-x86 platform-word-size-64) syscalls::getsockname (logior darwinx8664-unix-syscall-mask 32) (:unsigned-fullword :address :address) :signed-fullword ) +(define-syscall (logior platform-os-darwin platform-cpu-x86 platform-word-size-64) syscalls::kill (logior darwinx8664-unix-syscall-mask 37) (:signed-fullword :unsigned-fullword) :signed-fullword ) +(define-syscall (logior platform-os-darwin platform-cpu-x86 platform-word-size-64) syscalls::sync (logior darwinx8664-unix-syscall-mask 36) () :unsigned-fullword ) + ; 38 is old stat +(define-syscall (logior platform-os-darwin platform-cpu-x86 platform-word-size-64) syscalls::getppid (logior darwinx8664-unix-syscall-mask 39) () :unsigned-fullword) +(define-syscall (logior platform-os-darwin platform-cpu-x86 platform-word-size-64) syscalls::dup (logior darwinx8664-unix-syscall-mask 41) (:unsigned-fullword) :signed-fullword ) +(define-syscall (logior platform-os-darwin platform-cpu-x86 platform-word-size-64) syscalls::pipe (logior darwinx8664-unix-syscall-mask 42) () :signed-doubleword ) +(define-syscall (logior platform-os-darwin platform-cpu-x86 platform-word-size-64) syscalls::getgid (logior darwinx8664-unix-syscall-mask 47) () :unsigned-fullword) +(define-syscall (logior platform-os-darwin platform-cpu-x86 platform-word-size-64) syscalls::ioctl (logior darwinx8664-unix-syscall-mask 54) (:unsigned-fullword :signed-fullword :address) :signed-fullword :min-args 2 ) +(define-syscall (logior platform-os-darwin platform-cpu-x86 platform-word-size-64) syscalls::dup2 (logior darwinx8664-unix-syscall-mask 90) (:unsigned-fullword :unsigned-fullword) :signed-fullword ) +(define-syscall (logior platform-os-darwin platform-cpu-x86 platform-word-size-64) syscalls::fcntl (logior darwinx8664-unix-syscall-mask 92) (:unsigned-fullword :signed-fullword :signed-fullword) :signed-fullword :min-args 2 ) +(define-syscall (logior platform-os-darwin platform-cpu-x86 platform-word-size-64) syscalls::select (logior darwinx8664-unix-syscall-mask 93) (:unsigned-fullword :address :address + :address :address) + :signed-fullword) +(define-syscall (logior platform-os-darwin platform-cpu-x86 platform-word-size-64) syscalls::fsync (logior darwinx8664-unix-syscall-mask 95) (:unsigned-fullword) :signed-fullword ) +(define-syscall (logior platform-os-darwin platform-cpu-x86 platform-word-size-64) syscalls::socket (logior darwinx8664-unix-syscall-mask 97) (:unsigned-fullword :unsigned-fullword :unsigned-fullword) :signed-fullword ) +(define-syscall (logior platform-os-darwin platform-cpu-x86 platform-word-size-64) syscalls::connect (logior darwinx8664-unix-syscall-mask 98) (:unsigned-fullword :address :unsigned-fullword) :signed-fullword) +(define-syscall (logior platform-os-darwin platform-cpu-x86 platform-word-size-64) syscalls::bind (logior darwinx8664-unix-syscall-mask 104) (:unsigned-fullword :address :unsigned-fullword) :signed-fullword ) +(define-syscall (logior platform-os-darwin platform-cpu-x86 platform-word-size-64) syscalls::setsockopt (logior darwinx8664-unix-syscall-mask 105) (:unsigned-fullword :signed-fullword :signed-fullword :address :unsigned-fullword) :signed-fullword ) +(define-syscall (logior platform-os-darwin platform-cpu-x86 platform-word-size-64) syscalls::listen (logior darwinx8664-unix-syscall-mask 106) (:unsigned-fullword :unsigned-fullword) :signed-fullword ) +(define-syscall (logior platform-os-darwin platform-cpu-x86 platform-word-size-64) syscalls::gettimeofday (logior darwinx8664-unix-syscall-mask 116) (:address :address) :signed-fullword ) +(define-syscall (logior platform-os-darwin platform-cpu-x86 platform-word-size-64) syscalls::getrusage (logior darwinx8664-unix-syscall-mask 117) (:signed-fullword :address) :signed-fullword ) +(define-syscall (logior platform-os-darwin platform-cpu-x86 platform-word-size-64) syscalls::getsockopt (logior darwinx8664-unix-syscall-mask 118) (:unsigned-fullword :signed-fullword :unsigned-fullword :address :address) :signed-fullword ) +(define-syscall (logior platform-os-darwin platform-cpu-x86 platform-word-size-64) syscalls::fchmod (logior darwinx8664-unix-syscall-mask 124) (:unsigned-fullword :unsigned-fullword) :signed-fullword ) +(define-syscall (logior platform-os-darwin platform-cpu-x86 platform-word-size-64) syscalls::rename (logior darwinx8664-unix-syscall-mask 128) (:address :address) :signed-fullword) + ; 129 is old truncate + ; 130 is old ftruncate +(define-syscall (logior platform-os-darwin platform-cpu-x86 platform-word-size-64) syscalls::sendto (logior darwinx8664-unix-syscall-mask 133) (:unsigned-fullword :address :unsigned-fullword :unsigned-fullword :address :unsigned-fullword) :signed-fullword ) + +(define-syscall (logior platform-os-darwin platform-cpu-x86 platform-word-size-64) syscalls::shutdown (logior darwinx8664-unix-syscall-mask 134) (:unsigned-fullword :unsigned-fullword) :signed-fullword ) +(define-syscall (logior platform-os-darwin platform-cpu-x86 platform-word-size-64) syscalls::socketpair (logior darwinx8664-unix-syscall-mask 135) (:unsigned-fullword :unsigned-fullword :unsigned-fullword :address) :signed-fullword ) + +(define-syscall (logior platform-os-darwin platform-cpu-x86 platform-word-size-64) syscalls::mkdir (logior darwinx8664-unix-syscall-mask 136) (:address :unsigned-fullword) :signed-fullword) +(define-syscall (logior platform-os-darwin platform-cpu-x86 platform-word-size-64) syscalls::rmdir (logior darwinx8664-unix-syscall-mask 137) (:address) :signed-fullword ) +(define-syscall (logior platform-os-darwin platform-cpu-x86 platform-word-size-64) syscalls::mount (logior darwinx8664-unix-syscall-mask 167) (:address :address :unsigned-fullword :address) :signed-fullword ) +(define-syscall (logior platform-os-darwin platform-cpu-x86 platform-word-size-64) syscalls::setgid (logior darwinx8664-unix-syscall-mask 181) (:unsigned-fullword) :signed-fullword ) +(define-syscall (logior platform-os-darwin platform-cpu-x86 platform-word-size-64) syscalls::stat (logior darwinx8664-unix-syscall-mask 188) (:address :address) :signed-fullword ) +(define-syscall (logior platform-os-darwin platform-cpu-x86 platform-word-size-64) syscalls::fstat (logior darwinx8664-unix-syscall-mask 189) (:unsigned-fullword :address) :signed-fullword ) +(define-syscall (logior platform-os-darwin platform-cpu-x86 platform-word-size-64) syscalls::lstat (logior darwinx8664-unix-syscall-mask 190) (:address :address) :signed-fullword ) +(define-syscall (logior platform-os-darwin platform-cpu-x86 platform-word-size-64) syscalls::lseek (logior darwinx8664-unix-syscall-mask 199) (:unsigned-fullword :signed-doubleword :unsigned-fullword) :signed-doubleword ) +(define-syscall (logior platform-os-darwin platform-cpu-x86 platform-word-size-64) syscalls::truncate (logior darwinx8664-unix-syscall-mask 200) (:address :unsigned-doubleword) :signed-fullword ) +(define-syscall (logior platform-os-darwin platform-cpu-x86 platform-word-size-64) syscalls::ftruncate (logior darwinx8664-unix-syscall-mask 201) (:unsigned-fullword :unsigned-doubleword) :signed-fullword ) +(define-syscall (logior platform-os-darwin platform-cpu-x86 platform-word-size-64) syscalls::poll (logior darwinx8664-unix-syscall-mask 230) ((:* (:struct :pollfd)) :int :int) :int) +#+notdefinedyet +(progn + ; 17 is obsolete sbreak + ; 18 is old getfsstat + ; 19 is old lseek + ; 21 is obsolete mount + ; 22 is obsolete umount +(define-syscall (logior platform-os-darwin platform-cpu-x86 platform-word-size-64) syscalls::ptrace (logior darwinx8664-unix-syscall-mask 26) () ) +(define-syscall (logior platform-os-darwin platform-cpu-x86 platform-word-size-64) syscalls::access (logior darwinx8664-unix-syscall-mask 33) () ) +(define-syscall (logior platform-os-darwin platform-cpu-x86 platform-word-size-64) syscalls::chflags (logior darwinx8664-unix-syscall-mask 34) () ) +(define-syscall (logior platform-os-darwin platform-cpu-x86 platform-word-size-64) syscalls::fchflags (logior darwinx8664-unix-syscall-mask 35) () ) + ; 40 is old lstat +(define-syscall (logior platform-os-darwin platform-cpu-x86 platform-word-size-64) syscalls::getegid (logior darwinx8664-unix-syscall-mask 43) () ) +(define-syscall (logior platform-os-darwin platform-cpu-x86 platform-word-size-64) syscalls::profil (logior darwinx8664-unix-syscall-mask 44) () ) +(define-syscall (logior platform-os-darwin platform-cpu-x86 platform-word-size-64) syscalls::ktrace (logior darwinx8664-unix-syscall-mask 45) () ) +(define-syscall (logior platform-os-darwin platform-cpu-x86 platform-word-size-64) syscalls::sigaction (logior darwinx8664-unix-syscall-mask 46) () ) +(define-syscall (logior platform-os-darwin platform-cpu-x86 platform-word-size-64) syscalls::sigprocmask (logior darwinx8664-unix-syscall-mask 48) () ) +(define-syscall (logior platform-os-darwin platform-cpu-x86 platform-word-size-64) syscalls::getlogin (logior darwinx8664-unix-syscall-mask 49) () ) +(define-syscall (logior platform-os-darwin platform-cpu-x86 platform-word-size-64) syscalls::setlogin (logior darwinx8664-unix-syscall-mask 50) () ) +(define-syscall (logior platform-os-darwin platform-cpu-x86 platform-word-size-64) syscalls::acct (logior darwinx8664-unix-syscall-mask 51) () ) +(define-syscall (logior platform-os-darwin platform-cpu-x86 platform-word-size-64) syscalls::sigpending (logior darwinx8664-unix-syscall-mask 52) () ) +(define-syscall (logior platform-os-darwin platform-cpu-x86 platform-word-size-64) syscalls::sigaltstack (logior darwinx8664-unix-syscall-mask 53) () ) +(define-syscall (logior platform-os-darwin platform-cpu-x86 platform-word-size-64) syscalls::reboot (logior darwinx8664-unix-syscall-mask 55) () ) +(define-syscall (logior platform-os-darwin platform-cpu-x86 platform-word-size-64) syscalls::revoke (logior darwinx8664-unix-syscall-mask 56) () ) +(define-syscall (logior platform-os-darwin platform-cpu-x86 platform-word-size-64) syscalls::symlink (logior darwinx8664-unix-syscall-mask 57) () ) +(define-syscall (logior platform-os-darwin platform-cpu-x86 platform-word-size-64) syscalls::readlink (logior darwinx8664-unix-syscall-mask 58) () ) +(define-syscall (logior platform-os-darwin platform-cpu-x86 platform-word-size-64) syscalls::execve (logior darwinx8664-unix-syscall-mask 59) () ) +(define-syscall (logior platform-os-darwin platform-cpu-x86 platform-word-size-64) syscalls::umask (logior darwinx8664-unix-syscall-mask 60) () ) +(define-syscall (logior platform-os-darwin platform-cpu-x86 platform-word-size-64) syscalls::chroot (logior darwinx8664-unix-syscall-mask 61) () ) + ; 62 is old fstat + ; 63 is unused + ; 64 is old getpagesize +(define-syscall (logior platform-os-darwin platform-cpu-x86 platform-word-size-64) syscalls::msync (logior darwinx8664-unix-syscall-mask 65) () ) +(define-syscall (logior platform-os-darwin platform-cpu-x86 platform-word-size-64) syscalls::vfork (logior darwinx8664-unix-syscall-mask 66) () ) + ; 67 is obsolete vread + ; 68 is obsolete vwrite +(define-syscall (logior platform-os-darwin platform-cpu-x86 platform-word-size-64) syscalls::sbrk (logior darwinx8664-unix-syscall-mask 69) () ) +(define-syscall (logior platform-os-darwin platform-cpu-x86 platform-word-size-64) syscalls::sstk (logior darwinx8664-unix-syscall-mask 70) () ) + ; 71 is old mmap + ; 72 is obsolete vadvise +(define-syscall (logior platform-os-darwin platform-cpu-x86 platform-word-size-64) syscalls::munmap (logior darwinx8664-unix-syscall-mask 73) () ) +(define-syscall (logior platform-os-darwin platform-cpu-x86 platform-word-size-64) syscalls::mprotect (logior darwinx8664-unix-syscall-mask 74) () ) +(define-syscall (logior platform-os-darwin platform-cpu-x86 platform-word-size-64) syscalls::madvise (logior darwinx8664-unix-syscall-mask 75) () ) + ; 76 is obsolete vhangup + ; 77 is obsolete vlimit +(define-syscall (logior platform-os-darwin platform-cpu-x86 platform-word-size-64) syscalls::mincore (logior darwinx8664-unix-syscall-mask 78) () ) +(define-syscall (logior platform-os-darwin platform-cpu-x86 platform-word-size-64) syscalls::getgroups (logior darwinx8664-unix-syscall-mask 79) () ) +(define-syscall (logior platform-os-darwin platform-cpu-x86 platform-word-size-64) syscalls::setgroups (logior darwinx8664-unix-syscall-mask 80) () ) +(define-syscall (logior platform-os-darwin platform-cpu-x86 platform-word-size-64) syscalls::getpgrp (logior darwinx8664-unix-syscall-mask 81) () ) +(define-syscall (logior platform-os-darwin platform-cpu-x86 platform-word-size-64) syscalls::setpgid (logior darwinx8664-unix-syscall-mask 82) () ) +(define-syscall (logior platform-os-darwin platform-cpu-x86 platform-word-size-64) syscalls::setitimer (logior darwinx8664-unix-syscall-mask 83) () ) + ; 84 is old wait +(define-syscall (logior platform-os-darwin platform-cpu-x86 platform-word-size-64) syscalls::swapon (logior darwinx8664-unix-syscall-mask 85) () ) +(define-syscall (logior platform-os-darwin platform-cpu-x86 platform-word-size-64) syscalls::getitimer (logior darwinx8664-unix-syscall-mask 86) () ) + ; 87 is old gethostname + ; 88 is old sethostname +(define-syscall (logior platform-os-darwin platform-cpu-x86 platform-word-size-64) syscalls::getdtablesize (logior darwinx8664-unix-syscall-mask 89) () ) + + + ; 94 is obsolete setdopt +(define-syscall (logior platform-os-darwin platform-cpu-x86 platform-word-size-64) syscalls::setpriority (logior darwinx8664-unix-syscall-mask 96) () ) + ; 99 is old accept +(define-syscall (logior platform-os-darwin platform-cpu-x86 platform-word-size-64) syscalls::getpriority (logior darwinx8664-unix-syscall-mask 100) () ) + ; 101 is old send + ; 102 is old recv +(define-syscall (logior platform-os-darwin platform-cpu-x86 platform-word-size-64) syscalls::sigreturn (logior darwinx8664-unix-syscall-mask 103) () ) + ; 107 is obsolete vtimes + ; 108 is old sigvec + ; 109 is old sigblock + ; 110 is old sigsetmask +(define-syscall (logior platform-os-darwin platform-cpu-x86 platform-word-size-64) syscalls::sigsuspend (logior darwinx8664-unix-syscall-mask 111) () ) + ; 112 is old sigstack + ; 113 is old recvmsg + ; 114 is old sendmsg + ; 115 is obsolete vtrace + ; 119 is obsolete resuba +(define-syscall (logior platform-os-darwin platform-cpu-x86 platform-word-size-64) syscalls::readv (logior darwinx8664-unix-syscall-mask 120) () ) +(define-syscall (logior platform-os-darwin platform-cpu-x86 platform-word-size-64) syscalls::writev (logior darwinx8664-unix-syscall-mask 121) () ) +(define-syscall (logior platform-os-darwin platform-cpu-x86 platform-word-size-64) syscalls::settimeofday (logior darwinx8664-unix-syscall-mask 122) () ) +(define-syscall (logior platform-os-darwin platform-cpu-x86 platform-word-size-64) syscalls::fchown (logior darwinx8664-unix-syscall-mask 123) () ) + ; 125 is old recvfrom + ; 126 is old setreuid + ; 127 is old setregid +(define-syscall (logior platform-os-darwin platform-cpu-x86 platform-word-size-64) syscalls::flock (logior darwinx8664-unix-syscall-mask 131) () ) +(define-syscall (logior platform-os-darwin platform-cpu-x86 platform-word-size-64) syscalls::mkfifo (logior darwinx8664-unix-syscall-mask 132) () ) +(define-syscall (logior platform-os-darwin platform-cpu-x86 platform-word-size-64) syscalls::utimes (logior darwinx8664-unix-syscall-mask 138) () ) + ; 139 is unused +(define-syscall (logior platform-os-darwin platform-cpu-x86 platform-word-size-64) syscalls::adjtime (logior darwinx8664-unix-syscall-mask 140) () ) + ; 141 is old getpeername + ; 142 is old gethostid + ; 143 is old sethostid + ; 144 is old getrlimit + ; 145 is old setrlimit + ; 146 is old killpg +(define-syscall (logior platform-os-darwin platform-cpu-x86 platform-word-size-64) syscalls::setsid (logior darwinx8664-unix-syscall-mask 147) () ) + ; 148 is obsolete setquota + ; 149 is obsolete quota + ; 150 is old getsockname + ; 151 is reserved +(define-syscall (logior platform-os-darwin platform-cpu-x86 platform-word-size-64) syscalls::setprivexec (logior darwinx8664-unix-syscall-mask 152) () ) + ; 153 is reserved + ; 154 is reserved +(define-syscall (logior platform-os-darwin platform-cpu-x86 platform-word-size-64) syscalls::nfssvc (logior darwinx8664-unix-syscall-mask 155) () ) + ; 156 is old getdirentries +(define-syscall (logior platform-os-darwin platform-cpu-x86 platform-word-size-64) syscalls::statfs (logior darwinx8664-unix-syscall-mask 157) () ) +(define-syscall (logior platform-os-darwin platform-cpu-x86 platform-word-size-64) syscalls::fstatfs (logior darwinx8664-unix-syscall-mask 158) () ) +(define-syscall (logior platform-os-darwin platform-cpu-x86 platform-word-size-64) syscalls::unmount (logior darwinx8664-unix-syscall-mask 159) () ) + ; 160 is obsolete async_daemon +(define-syscall (logior platform-os-darwin platform-cpu-x86 platform-word-size-64) syscalls::getfh (logior darwinx8664-unix-syscall-mask 161) () ) + ; 162 is old getdomainname + ; 163 is old setdomainname + ; 164 is obsolete pcfs_mount +(define-syscall (logior platform-os-darwin platform-cpu-x86 platform-word-size-64) syscalls::quotactl (logior darwinx8664-unix-syscall-mask 165) () ) + ; 166 is obsolete exportfs + + ; 168 is obsolete ustat + ; 169 is unused +(define-syscall (logior platform-os-darwin platform-cpu-x86 platform-word-size-64) syscalls::table (logior darwinx8664-unix-syscall-mask 170) () ) + ; 171 is old wait_3 + ; 172 is obsolete rpause + ; 173 is unused + ; 174 is obsolete getdents +(define-syscall (logior platform-os-darwin platform-cpu-x86 platform-word-size-64) syscalls::gc_control (logior darwinx8664-unix-syscall-mask 175) () ) +(define-syscall (logior platform-os-darwin platform-cpu-x86 platform-word-size-64) syscalls::add_profil (logior darwinx8664-unix-syscall-mask 176) () ) + ; 177 is unused + ; 178 is unused + ; 179 is unused +(define-syscall (logior platform-os-darwin platform-cpu-x86 platform-word-size-64) syscalls::kdebug_trace (logior darwinx8664-unix-syscall-mask 180) () ) +(define-syscall (logior platform-os-darwin platform-cpu-x86 platform-word-size-64) syscalls::setegid (logior darwinx8664-unix-syscall-mask 182) () ) +(define-syscall (logior platform-os-darwin platform-cpu-x86 platform-word-size-64) syscalls::seteuid (logior darwinx8664-unix-syscall-mask 183) () ) +(define-syscall (logior platform-os-darwin platform-cpu-x86 platform-word-size-64) syscalls::lfs_bmapv (logior darwinx8664-unix-syscall-mask 184) () ) +(define-syscall (logior platform-os-darwin platform-cpu-x86 platform-word-size-64) syscalls::lfs_markv (logior darwinx8664-unix-syscall-mask 185) () ) +(define-syscall (logior platform-os-darwin platform-cpu-x86 platform-word-size-64) syscalls::lfs_segclean (logior darwinx8664-unix-syscall-mask 186) () ) +(define-syscall (logior platform-os-darwin platform-cpu-x86 platform-word-size-64) syscalls::lfs_segwait (logior darwinx8664-unix-syscall-mask 187) () ) +(define-syscall (logior platform-os-darwin platform-cpu-x86 platform-word-size-64) syscalls::pathconf (logior darwinx8664-unix-syscall-mask 191) () ) +(define-syscall (logior platform-os-darwin platform-cpu-x86 platform-word-size-64) syscalls::fpathconf (logior darwinx8664-unix-syscall-mask 192) () ) +(define-syscall (logior platform-os-darwin platform-cpu-x86 platform-word-size-64) syscalls::getrlimit (logior darwinx8664-unix-syscall-mask 194) () ) +(define-syscall (logior platform-os-darwin platform-cpu-x86 platform-word-size-64) syscalls::setrlimit (logior darwinx8664-unix-syscall-mask 195) () ) +(define-syscall (logior platform-os-darwin platform-cpu-x86 platform-word-size-64) syscalls::getdirentries (logior darwinx8664-unix-syscall-mask 196) () ) +(define-syscall (logior platform-os-darwin platform-cpu-x86 platform-word-size-64) syscalls::mmap (logior darwinx8664-unix-syscall-mask 197) () ) +(define-syscall (logior platform-os-darwin platform-cpu-x86 platform-word-size-64) syscalls::__syscall (logior darwinx8664-unix-syscall-mask 198) () ) +(define-syscall (logior platform-os-darwin platform-cpu-x86 platform-word-size-64) syscalls::__sysctl (logior darwinx8664-unix-syscall-mask 202) () ) +(define-syscall (logior platform-os-darwin platform-cpu-x86 platform-word-size-64) syscalls::mlock (logior darwinx8664-unix-syscall-mask 203) () ) +(define-syscall (logior platform-os-darwin platform-cpu-x86 platform-word-size-64) syscalls::munlock (logior darwinx8664-unix-syscall-mask 204) () ) +(define-syscall (logior platform-os-darwin platform-cpu-x86 platform-word-size-64) syscalls::undelete (logior darwinx8664-unix-syscall-mask 205) () ) +(define-syscall (logior platform-os-darwin platform-cpu-x86 platform-word-size-64) syscalls::ATsocket (logior darwinx8664-unix-syscall-mask 206) () ) +(define-syscall (logior platform-os-darwin platform-cpu-x86 platform-word-size-64) syscalls::ATgetmsg (logior darwinx8664-unix-syscall-mask 207) () ) +(define-syscall (logior platform-os-darwin platform-cpu-x86 platform-word-size-64) syscalls::ATputmsg (logior darwinx8664-unix-syscall-mask 208) () ) +(define-syscall (logior platform-os-darwin platform-cpu-x86 platform-word-size-64) syscalls::ATPsndreq (logior darwinx8664-unix-syscall-mask 209) () ) +(define-syscall (logior platform-os-darwin platform-cpu-x86 platform-word-size-64) syscalls::ATPsndrsp (logior darwinx8664-unix-syscall-mask 210) () ) +(define-syscall (logior platform-os-darwin platform-cpu-x86 platform-word-size-64) syscalls::ATPgetreq (logior darwinx8664-unix-syscall-mask 211) () ) +(define-syscall (logior platform-os-darwin platform-cpu-x86 platform-word-size-64) syscalls::ATPgetrsp (logior darwinx8664-unix-syscall-mask 212) () ) + ; 213-215 are reserved for AppleTalk +(define-syscall (logior platform-os-darwin platform-cpu-x86 platform-word-size-64) syscalls::mkcomplex (logior darwinx8664-unix-syscall-mask 216) () ) +(define-syscall (logior platform-os-darwin platform-cpu-x86 platform-word-size-64) syscalls::statv (logior darwinx8664-unix-syscall-mask 217) () ) +(define-syscall (logior platform-os-darwin platform-cpu-x86 platform-word-size-64) syscalls::lstatv (logior darwinx8664-unix-syscall-mask 218) () ) +(define-syscall (logior platform-os-darwin platform-cpu-x86 platform-word-size-64) syscalls::fstatv (logior darwinx8664-unix-syscall-mask 219) () ) +(define-syscall (logior platform-os-darwin platform-cpu-x86 platform-word-size-64) syscalls::getattrlist (logior darwinx8664-unix-syscall-mask 220) () ) +(define-syscall (logior platform-os-darwin platform-cpu-x86 platform-word-size-64) syscalls::setattrlist (logior darwinx8664-unix-syscall-mask 221) () ) +(define-syscall (logior platform-os-darwin platform-cpu-x86 platform-word-size-64) syscalls::getdirentriesattr (logior darwinx8664-unix-syscall-mask 222) () ) +(define-syscall (logior platform-os-darwin platform-cpu-x86 platform-word-size-64) syscalls::exchangedata (logior darwinx8664-unix-syscall-mask 223) () ) +(define-syscall (logior platform-os-darwin platform-cpu-x86 platform-word-size-64) syscalls::checkuseraccess (logior darwinx8664-unix-syscall-mask 224) () ) +(define-syscall (logior platform-os-darwin platform-cpu-x86 platform-word-size-64) syscalls::searchfs (logior darwinx8664-unix-syscall-mask 225) () ) + + ; 226 - 230 are reserved for HFS expansion + ; 231 - 249 are reserved +(define-syscall (logior platform-os-darwin platform-cpu-x86 platform-word-size-64) syscalls::minherit (logior darwinx8664-unix-syscall-mask 250) () ) +(define-syscall (logior platform-os-darwin platform-cpu-x86 platform-word-size-64) syscalls::semsys (logior darwinx8664-unix-syscall-mask 251) () ) +(define-syscall (logior platform-os-darwin platform-cpu-x86 platform-word-size-64) syscalls::msgsys (logior darwinx8664-unix-syscall-mask 252) () ) +(define-syscall (logior platform-os-darwin platform-cpu-x86 platform-word-size-64) syscalls::shmsys (logior darwinx8664-unix-syscall-mask 253) () ) +(define-syscall (logior platform-os-darwin platform-cpu-x86 platform-word-size-64) syscalls::semctl (logior darwinx8664-unix-syscall-mask 254) () ) +(define-syscall (logior platform-os-darwin platform-cpu-x86 platform-word-size-64) syscalls::semget (logior darwinx8664-unix-syscall-mask 255) () ) +(define-syscall (logior platform-os-darwin platform-cpu-x86 platform-word-size-64) syscalls::semop (logior darwinx8664-unix-syscall-mask 256) () ) +(define-syscall (logior platform-os-darwin platform-cpu-x86 platform-word-size-64) syscalls::semconfig (logior darwinx8664-unix-syscall-mask 257) () ) +(define-syscall (logior platform-os-darwin platform-cpu-x86 platform-word-size-64) syscalls::msgctl (logior darwinx8664-unix-syscall-mask 258) () ) +(define-syscall (logior platform-os-darwin platform-cpu-x86 platform-word-size-64) syscalls::msgget (logior darwinx8664-unix-syscall-mask 259) () ) +(define-syscall (logior platform-os-darwin platform-cpu-x86 platform-word-size-64) syscalls::msgsnd (logior darwinx8664-unix-syscall-mask 260) () ) +(define-syscall (logior platform-os-darwin platform-cpu-x86 platform-word-size-64) syscalls::msgrcv (logior darwinx8664-unix-syscall-mask 261) () ) +(define-syscall (logior platform-os-darwin platform-cpu-x86 platform-word-size-64) syscalls::shmat (logior darwinx8664-unix-syscall-mask 262) () ) +(define-syscall (logior platform-os-darwin platform-cpu-x86 platform-word-size-64) syscalls::shmctl (logior darwinx8664-unix-syscall-mask 263) () ) +(define-syscall (logior platform-os-darwin platform-cpu-x86 platform-word-size-64) syscalls::shmdt (logior darwinx8664-unix-syscall-mask 264) () ) +(define-syscall (logior platform-os-darwin platform-cpu-x86 platform-word-size-64) syscalls::shmget (logior darwinx8664-unix-syscall-mask 265) () ) +(define-syscall (logior platform-os-darwin platform-cpu-x86 platform-word-size-64) syscalls::shm_open (logior darwinx8664-unix-syscall-mask 266) () ) +(define-syscall (logior platform-os-darwin platform-cpu-x86 platform-word-size-64) syscalls::shm_unlink (logior darwinx8664-unix-syscall-mask 267) () ) +(define-syscall (logior platform-os-darwin platform-cpu-x86 platform-word-size-64) syscalls::sem_open (logior darwinx8664-unix-syscall-mask 268) () ) +(define-syscall (logior platform-os-darwin platform-cpu-x86 platform-word-size-64) syscalls::sem_close (logior darwinx8664-unix-syscall-mask 269) () ) +(define-syscall (logior platform-os-darwin platform-cpu-x86 platform-word-size-64) syscalls::sem_unlink (logior darwinx8664-unix-syscall-mask 270) () ) +(define-syscall (logior platform-os-darwin platform-cpu-x86 platform-word-size-64) syscalls::sem_wait (logior darwinx8664-unix-syscall-mask 271) () ) +(define-syscall (logior platform-os-darwin platform-cpu-x86 platform-word-size-64) syscalls::sem_trywait (logior darwinx8664-unix-syscall-mask 272) () ) +(define-syscall (logior platform-os-darwin platform-cpu-x86 platform-word-size-64) syscalls::sem_post (logior darwinx8664-unix-syscall-mask 273) () ) +(define-syscall (logior platform-os-darwin platform-cpu-x86 platform-word-size-64) syscalls::sem_getvalue (logior darwinx8664-unix-syscall-mask 274) () ) +(define-syscall (logior platform-os-darwin platform-cpu-x86 platform-word-size-64) syscalls::sem_init (logior darwinx8664-unix-syscall-mask 275) () ) +(define-syscall (logior platform-os-darwin platform-cpu-x86 platform-word-size-64) syscalls::sem_destroy (logior darwinx8664-unix-syscall-mask 276) () ) + ; 277 - 295 are reserved +(define-syscall (logior platform-os-darwin platform-cpu-x86 platform-word-size-64) syscalls::load_shared_file (logior darwinx8664-unix-syscall-mask 296) () ) +(define-syscall (logior platform-os-darwin platform-cpu-x86 platform-word-size-64) syscalls::reset_shared_file (logior darwinx8664-unix-syscall-mask 297) () ) + ; 298 - 323 are reserved +(define-syscall (logior platform-os-darwin platform-cpu-x86 platform-word-size-64) syscalls::mlockall (logior darwinx8664-unix-syscall-mask 324) () ) +(define-syscall (logior platform-os-darwin platform-cpu-x86 platform-word-size-64) syscalls::munlockall (logior darwinx8664-unix-syscall-mask 325) () ) + ; 326 is reserved +(define-syscall (logior platform-os-darwin platform-cpu-x86 platform-word-size-64) syscalls::issetugid (logior darwinx8664-unix-syscall-mask 327) () ) +) Index: /branches/new-random/library/elf.lisp =================================================================== --- /branches/new-random/library/elf.lisp (revision 13309) +++ /branches/new-random/library/elf.lisp (revision 13309) @@ -0,0 +1,408 @@ +;;; Copyright 2009 Clozure Associates +;;; This file is part of Clozure CL. +;;; +;;; Clozure CL is licensed under the terms of the Lisp Lesser GNU +;;; Public License , known as the LLGPL and distributed with Clozure +;;; CL as the file "LICENSE". The LLGPL consists of a preamble and +;;; the LGPL, which is distributed with Clozure CL as the file "LGPL". +;;; Where these conflict, the preamble takes precedence. +;;; +;;; Clozure CL is referenced in the preamble as the "LIBRARY." +;;; +;;; The LLGPL is also available online at +;;; http://opensource.franz.com/preamble.html + +(in-package "CCL") + +(eval-when (:compile-toplevel :execute) + (use-interface-dir :elf)) + + +(defloadvar *readonly-area* + (do-consing-areas (a) + (when (eql (%fixnum-ref a target::area.code) + ccl::area-readonly) + (return a)))) + +;;; String tables: used both for symbol names and for section names. +(defstruct elf-string-table + (hash (make-hash-table :test #'equal)) + (string (make-array 100 :element-type '(unsigned-byte 8) :fill-pointer 1 :adjustable t))) + +;;; Collect info about Elf symbols. +(defstruct elf-symbol-table + (strings (make-elf-string-table)) + data ; foreign pointer + nsyms + ) + +;;; Wrapper around libelf's "elf" pointer +(defstruct elf-object + libelf-pointer + fd + pathname + ) + + +;;; Is libelf thread-safe ? Who knows, there's no +;;; documentation ... +(defun libelf-error-string (&optional (errnum -1)) + (let* ((p (#_elf_errmsg errnum))) + (if (%null-ptr-p p) + (format nil "ELF error ~d" errnum) + (%get-cstring p)))) + +(defloadvar *checked-libelf-version* nil) + +(defun check-libelf-version () + (or *checked-libelf-version* + (progn + (open-shared-library "libelf.so") + (let* ((version (#_elf_version #$EV_CURRENT))) + (if (eql #$EV_NONE version) + (error "ELF library initialization failed: ~a" (libelf-error-string))) + (setq *checked-libelf-version* version))))) + + +;;; Prepate to create an ELF object file at PATHNAME, overwriting +;;; whatever might have been there. +(defun create-elf-object (pathname) + (let* ((namestring (native-translated-namestring pathname)) + (fd (ccl::fd-open namestring + (logior #$O_RDWR #$O_CREAT #$O_TRUNC) + #o755))) + (if (< fd 0) + (signal-file-error fd pathname) + (progn + (check-libelf-version) + (let* ((ptr (#_elf_begin fd #$ELF_C_WRITE +null-ptr+))) + (if (%null-ptr-p ptr) + (error "Can't initialize libelf object for ~s: ~a" + pathname (libelf-error-string)) + (make-elf-object :libelf-pointer (assert-pointer-type ptr :lf) + :fd fd + :pathname pathname))))))) + +(defun elf-end (object) + (#_elf_end (elf-object-libelf-pointer object)) + (setf (elf-object-libelf-pointer object) nil + (elf-object-fd object) nil)) + +(defun new-elf-file-header (object format type machine) + (let* ((ehdr (#+64-bit-target #_elf64_newehdr #+32-bit-target #_elf32_newehdr (elf-object-libelf-pointer object)))) + (if (%null-ptr-p ehdr) + (error "Can't create ELF file header for ~s: ~a" + (elf-object-pathname object) + (libelf-error-string)) + (progn + (setf (paref (pref ehdr + #+64-bit-target :lf64_hdr.e_ident + #+32-bit-target :lf32_hdr.e_ident) (:* :unsigned-char) #$EI_DATA) format + (pref ehdr + #+64-bit-target :lf64_hdr.e_machine + #+32-bit-target :lf32_hdr.e_machine) machine + (pref ehdr + #+64-bit-target :lf64_hdr.e_type + #+32-bit-target :lf32_hdr.e_type) type + (pref ehdr + #+64-bit-target :lf64_hdr.e_version + #+32-bit-target :lf32_hdr.e_version) *checked-libelf-version*) + (assert-pointer-type ehdr + #+64-bit-target :lf64_hdr + #+32-bit-target :lf32_hdr))))) + +(defun new-elf-program-header (object &optional (count 1)) + (let* ((phdr (#+64-bit-target #_elf64_newphdr #+32-bit-target #_elf32_newphdr (elf-object-libelf-pointer object) count))) + (if (%null-ptr-p phdr) + (error "Can't create ELF program header for ~s: ~a" + (elf-object-pathname object) + (libelf-error-string)) + (assert-pointer-type phdr + #+64-bit-target :lf64_
hdr + #+32-bit-target :lf32_
hdr)))) + +(defun new-elf-section (object) + (let* ((scn (#_elf_newscn (elf-object-libelf-pointer object)))) + (if (%null-ptr-p scn) + (error "Can' create ELF section for ~s: ~a" + (elf-object-pathname object) + (libelf-error-string)) + (assert-pointer-type scn :lf_cn)))) + +(defun elf-section-header-for-section (object section) + (let* ((shdr (#+64-bit-target #_elf64_getshdr #+32-bit-target #_elf32_getshdr section))) + (if (%null-ptr-p shdr) + (error "Can' obtain ELF section header for ~s: ~a" + (elf-object-pathname object) + (libelf-error-string)) + (assert-pointer-type shdr + #+64-bit-target :lf64_hdr + #+32-bit-target :lf32_hdr)))) + +(defun elf-data-pointer-for-section (object section) + (let* ((data (#_elf_newdata section))) + (if (%null-ptr-p data) + (error "Can' obtain ELF data pointer for ~s: ~a" + (elf-object-pathname object) + (libelf-error-string)) + (assert-pointer-type data :lf_ata)))) + + +(defun elf-register-string (string table) + (let* ((hash (elf-string-table-hash table)) + (s (elf-string-table-string table))) + (when (gethash string hash) + (format t "~& duplicate: ~s" string)) + (or (gethash string hash) + (setf (gethash string hash) + (let* ((n (length s))) + (dotimes (i (length string) (progn (vector-push-extend 0 s) n)) + (let* ((code (char-code (char string i)))) + (declare (type (mod #x110000) code)) + (if (> code 255) + (vector-push-extend (char-code #\sub) s) + (vector-push-extend code s))))))))) + + +(defun elf-lisp-function-name (f) + (let* ((name (format nil "~s" f))) + (subseq (nsubstitute #\0 #\# (nsubstitute #\. #\Space name)) 1))) + + + +(defun collect-elf-static-functions () + (collect ((functions)) + (purify) + (block walk + (%map-areas (lambda (o) + (when (typep o + #+x8664-target 'function-vector + #-x8664-target 'function) + (functions (function-vector-to-function o)))) + ccl::area-readonly + ccl::area-readonly + )) + (functions))) + +(defun register-elf-functions (section-number) + (let* ((functions (collect-elf-static-functions)) + (n (length functions)) + (data (#_calloc (1+ n) (record-length #+64-bit-target :lf64_ym + #+32-bit-target :lf32_ym))) + (string-table (make-elf-string-table))) + (declare (fixnum n)) + (do* ((i 0 (1+ i)) + (p (%inc-ptr data + (record-length #+64-bit-target :lf64_ym + #+32-bit-target :lf32_ym)) + (progn (%incf-ptr p + (record-length #+64-bit-target :lf64_ym + #+32-bit-target :lf32_ym)) + p)) + (f (pop functions) (pop functions))) + ((= i n) + (make-elf-symbol-table :strings string-table :data data :nsyms n)) + (declare (fixnum n)) + (setf (pref p + #+64-bit-target :lf64_ym.st_name + #+32-bit-target :lf32_ym.st_name) + (elf-register-string (elf-lisp-function-name f) string-table) + (pref p + #+64-bit-target :lf64_ym.st_info + #+32-bit-target :lf32_ym.st_info) + (logior (ash #$STB_GLOBAL 4) #$STT_FUNC) + (pref p + #+64-bit-target :lf64_ym.st_shndx + #+32-bit-target :lf32_ym.st_shndx) section-number + (pref p + #+64-bit-target :lf64_ym.st_value + #+32-bit-target :lf32_ym.st_value) (%address-of f) + (pref p + #+64-bit-target :lf64_ym.st_size + #+32-bit-target :lf32_ym.st_size) (1+ (ash (1- (%function-code-words f)) target::word-shift)))))) + +(defun elf-section-index (section) + (#_elf_ndxscn section)) + +(defun elf-set-shstrab-section (object scn) + #+freebsd-target + (#_elf_setshstrndx (elf-object-libelf-pointer object) (elf-section-index scn)) + #-freebsd-target + (declare (ignore object scn))) + + +(defun elf-init-section-data-from-string-table (object section string-table) + (let* ((strings-data (elf-data-pointer-for-section object section)) + (s (elf-string-table-string string-table)) + (bytes (array-data-and-offset s)) + (n (length s)) + (buf (#_malloc n))) + (%copy-ivector-to-ptr bytes 0 buf 0 n) + (setf (pref strings-data :lf_ata.d_align) 1 + (pref strings-data :lf_ata.d_off) 0 + (pref strings-data :lf_ata.d_type) #$ELF_T_BYTE + (pref strings-data :lf_ata.d_version) #$EV_CURRENT + (pref strings-data :lf_ata.d_size) n + (pref strings-data :lf_ata.d_buf) buf) + n)) + +(defun elf-init-symbol-section-from-symbol-table (object section symbols) + (let* ((symbols-data (elf-data-pointer-for-section object section)) + (buf (elf-symbol-table-data symbols)) + (nsyms (elf-symbol-table-nsyms symbols) ) + (n (* (1+ nsyms) (record-length #+64-bit-target :lf64_ym + #+32-bit-target :lf32_ym)))) + (setf (pref symbols-data :lf_ata.d_align) 8 + (pref symbols-data :lf_ata.d_off) 0 + (pref symbols-data :lf_ata.d_type) #$ELF_T_SYM + (pref symbols-data :lf_ata.d_version) #$EV_CURRENT + (pref symbols-data :lf_ata.d_size) n + (pref symbols-data :lf_ata.d_buf) buf) + nsyms)) + +(defun elf-make-empty-data-for-section (object section &optional (size 0)) + (let* ((data (elf-data-pointer-for-section object section)) + (buf +null-ptr+)) + (setf (pref data :lf_ata.d_align) 0 + (pref data :lf_ata.d_off) 0 + (pref data :lf_ata.d_type) #$ELF_T_BYTE + (pref data :lf_ata.d_version) #$EV_CURRENT + (pref data :lf_ata.d_size) size + (pref data :lf_ata.d_buf) buf) + 0)) + + +(defun elf-flag-phdr (object cmd flags) + (#_elf_flagphdr (elf-object-libelf-pointer object) cmd flags)) + +(defun elf-update (object cmd) + (let* ((size (#_elf_update (elf-object-libelf-pointer object) cmd))) + (if (< size 0) + (error "elf_update failed for for ~s: ~a" + (elf-object-pathname object) + (libelf-error-string)) + size))) + +(defun fixup-lisp-section-offset (fd eof sectnum) + (fd-lseek fd 0 #$SEEK_SET) + (rlet ((fhdr #+64-bit-target :lf64_hdr + #+32-bit-target :lf32_hdr) + (shdr #+64-bit-target :lf64_hdr + #+32-bit-target :lf32_hdr)) + (fd-read fd fhdr (record-length #+64-bit-target :lf64_hdr + #+32-bit-target :lf32_hdr)) + (let* ((pos (+ (pref fhdr #+64-bit-target :lf64_hdr.e_shoff + #+32-bit-target :lf32_hdr.e_shoff) + (* sectnum (pref fhdr #+64-bit-target :lf64_hdr.e_shentsize + #+32-bit-target :lf32_hdr.e_shentsize))))) + (fd-lseek fd pos #$SEEK_SET) + (fd-read fd shdr (record-length #+64-bit-target :lf64_hdr + #+32-bit-target :lf32_hdr)) + ;; On 64-bit platforms, the section data precedes the image + ;; header; on 32-bit platforms, the image header and image + ;; section table precede the image data for the first (static) + ;; section. With alignment, the header/section headers are + ;; one 4K page, and the static section size is 8K ... + (setf (pref shdr #+64-bit-target :lf64_hdr.sh_offset + #+32-bit-target :lf32_hdr.sh_offset) + (+ #+32-bit-target #x1000 #+64-bit-target 0 #x2000 (logandc2 (+ eof 4095) 4095))) + (setf (pref shdr #+64-bit-target :lf64_hdr.sh_type + #+32-bit-target :lf32_hdr.sh_type) + #$SHT_PROGBITS) + (fd-lseek fd pos #$SEEK_SET) + (fd-write fd shdr (record-length #+64-bit-target :lf64_hdr + #+32-bit-target :lf32_hdr)) + t))) + +(defun write-elf-symbols-to-file (pathname) + (let* ((object (create-elf-object pathname)) + (file-header (new-elf-file-header object + #+little-endian-target #$ELFDATA2LSB + #+big-endian-target #$ELFDATA2MSB + #$ET_DYN + #+x8664-target #$EM_X86_64 + #+x8632-target #$EM_386 + #+ppc32-target #$EM_PPC + #+ppc64-target #$EM_PPC64 + )) + (program-header (new-elf-program-header object)) + (lisp-section (new-elf-section object)) + (symbols-section (new-elf-section object)) + (strings-section (new-elf-section object)) + (shstrtab-section (new-elf-section object)) + (section-names (make-elf-string-table)) + (lisp-section-index (elf-section-index lisp-section)) + (symbols (register-elf-functions lisp-section-index)) + (lisp-section-header (elf-section-header-for-section object lisp-section)) + (symbols-section-header (elf-section-header-for-section object symbols-section)) + (strings-section-header (elf-section-header-for-section object strings-section)) + (shstrtab-section-header (elf-section-header-for-section object shstrtab-section))) + + (setf (pref file-header #+64-bit-target :lf64_hdr.e_shstrndx + #+32-bit-target :lf32_hdr.e_shstrndx) (elf-section-index shstrtab-section)) + (setf (pref lisp-section-header #+64-bit-target :lf64_hdr.sh_name + #+32-bit-target :lf32_hdr.sh_name) (elf-register-string ".lisp" section-names) + (pref lisp-section-header #+64-bit-target :lf64_hdr.sh_type + #+32-bit-target :lf32_hdr.sh_type) #$SHT_NOBITS + (pref lisp-section-header #+64-bit-target :lf64_hdr.sh_flags + #+32-bit-target :lf32_hdr.sh_flags) (logior #$SHF_WRITE #$SHF_ALLOC #$SHF_EXECINSTR) + (pref lisp-section-header #+64-bit-target :lf64_hdr.sh_addr + #+32-bit-target :lf32_hdr.sh_addr) (ash (%fixnum-ref *readonly-area* target::area.low) target::fixnumshift) + (pref lisp-section-header #+64-bit-target :lf64_hdr.sh_size + #+32-bit-target :lf32_hdr.sh_size) (ash (- (%fixnum-ref *readonly-area* target::area.active) (%fixnum-ref *readonly-area* target::area.low) )target::fixnumshift) + (pref lisp-section-header #+64-bit-target :lf64_hdr.sh_offset + #+32-bit-target :lf32_hdr.sh_offset) 0 + (pref lisp-section-header #+64-bit-target :lf64_hdr.sh_addralign + #+32-bit-target :lf32_hdr.sh_addralign) 1) + (setf (pref symbols-section-header #+64-bit-target :lf64_hdr.sh_name + #+32-bit-target :lf32_hdr.sh_name) (elf-register-string ".symtab" section-names) + (pref symbols-section-header #+64-bit-target :lf64_hdr.sh_type + #+32-bit-target :lf32_hdr.sh_type) #$SHT_SYMTAB + (pref symbols-section-header #+64-bit-target :lf64_hdr.sh_entsize + #+32-bit-target :lf32_hdr.sh_entsize) (record-length #+64-bit-target :lf64_ym + #+32-bit-target :lf32_ym) + (pref symbols-section-header #+64-bit-target :lf64_hdr.sh_link + #+32-bit-target :lf32_hdr.sh_link) (elf-section-index strings-section)) + (setf (pref strings-section-header #+64-bit-target :lf64_hdr.sh_name + #+32-bit-target :lf32_hdr.sh_name) (elf-register-string ".strtab" section-names) + (pref strings-section-header #+64-bit-target :lf64_hdr.sh_type + #+32-bit-target :lf32_hdr.sh_type) #$SHT_STRTAB + (pref strings-section-header #+64-bit-target :lf64_hdr.sh_flags + #+32-bit-target :lf32_hdr.sh_flags) (logior #$SHF_STRINGS #$SHF_ALLOC)) + (setf (pref shstrtab-section-header #+64-bit-target :lf64_hdr.sh_name + #+32-bit-target :lf32_hdr.sh_name) (elf-register-string ".shstrtab" section-names) + (pref shstrtab-section-header #+64-bit-target :lf64_hdr.sh_type + #+32-bit-target :lf32_hdr.sh_type) #$SHT_STRTAB + (pref shstrtab-section-header #+64-bit-target :lf64_hdr.sh_flags + #+32-bit-target :lf32_hdr.sh_flags) (logior #$SHF_STRINGS #$SHF_ALLOC)) + (elf-make-empty-data-for-section object lisp-section (ash (- (%fixnum-ref *readonly-area* target::area.active) (%fixnum-ref *readonly-area* target::area.low) )target::fixnumshift)) + (elf-init-section-data-from-string-table object strings-section (elf-symbol-table-strings symbols)) + (elf-init-section-data-from-string-table object shstrtab-section section-names) + (elf-init-symbol-section-from-symbol-table object symbols-section symbols) + ;; Prepare in-memory data structures. + (elf-update object #$ELF_C_NULL) + ;; Fix up the program header. + (setf (pref program-header + #+64-bit-target :lf64_
~~hdr.p_type + #+32-bit-target :lf32_~~
~~hdr.p_type) #$PT_PHDR + (pref program-header #+64-bit-target :lf64_~~
~~hdr.p_offset + #+32-bit-target :lf32_~~
hdr.p_offset) + (pref file-header + #+64-bit-target :lf64_hdr.e_phoff + #+32-bit-target :lf32_hdr.e_phoff) + (pref program-header + #+64-bit-target :lf64_
~~hdr.p_filesz + #+32-bit-target :lf32_~~
hdr.p_filesz) + (#+64-bit-target #_elf64_fsize #+32-bit-target #_elf32_fsize #$ELF_T_PHDR 1 #$EV_CURRENT)) + ;; Mark the program header as being dirty. + (elf-flag-phdr object #$ELF_C_SET #$ELF_F_DIRTY) + (let* ((eof (elf-update object #$ELF_C_WRITE)) + (fd (elf-object-fd object))) + (elf-end object) + (fixup-lisp-section-offset fd eof lisp-section-index) + (fd-close fd)) + pathname)) + + + + Index: /branches/new-random/library/jp-encode.lisp =================================================================== --- /branches/new-random/library/jp-encode.lisp (revision 13309) +++ /branches/new-random/library/jp-encode.lisp (revision 13309) @@ -0,0 +1,17945 @@ +;;;-*- Mode: Lisp; Package: CCL -*- +;;; +;;; Copyright (C) 2007-2009 Clozure Associates and contributors +;;; This file is part of Clozure CL. +;;; +;;; Clozure CL is licensed under the terms of the Lisp Lesser GNU Public +;;; License , known as the LLGPL and distributed with Clozure CL as the +;;; file "LICENSE". The LLGPL consists of a preamble and the LGPL, +;;; which is distributed with Clozure CL as the file "LGPL". Where these +;;; conflict, the preamble takes precedence. +;;; +;;; Clozure CL is referenced in the preamble as the "LIBRARY." +;;; +;;; The LLGPL is also available online at +;;; http://opensource.franz.com/preamble.html + +(in-package "CCL") + +;;;; helper functions +(defvar *eucjp-to-ucs-hash* (make-hash-table)) +(defvar *ucs-to-eucjp-hash* (make-hash-table)) +(defvar *cp932-to-ucs-hash* (make-hash-table)) +(defvar *ucs-to-cp932-hash* (make-hash-table)) + +(let* ((cp932-only '((#xFC4B #x9ED1) + (#xFC4A #x9E19) + (#xFC49 #xFA2D) + (#xFC48 #x9D6B) + (#xFC47 #x9D70) + (#xFC46 #x9C00) + (#xFC45 #x9BBB) + (#xFC44 #x9BB1) + (#xFC43 #x9B8F) + (#xFC42 #x9B72) + (#xFC41 #x9B75) + (#xFC40 #x9ADC) + (#xFBFC #x9AD9) + (#xFBFB #x9A4E) + (#xFBFA #x999E) + (#xFBF9 #xFA2C) + (#xFBF8 #x9927) + (#xFBF7 #xFA2B) + (#xFBF6 #xFA2A) + (#xFBF5 #x9865) + (#xFBF4 #x9857) + (#xFBF3 #x9755) + (#xFBF2 #x9751) + (#xFBF1 #x974F) + (#xFBF0 #x974D) + (#xFBEF #x9743) + (#xFBEE #x973B) + (#xFBED #x9733) + (#xFBEC #x96AF) + (#xFBEB #x969D) + (#xFBEA #xFA29) + (#xFBE9 #xF9DC) + (#xFBE8 #x9592) + (#xFBE7 #x9448) + (#xFBE6 #x9445) + (#xFBE5 #x9431) + (#xFBE4 #x93F8) + (#xFBE3 #x93DE) + (#xFBE2 #x93C6) + (#xFBE1 #x93A4) + (#xFBE0 #x9357) + (#xFBDF #x9370) + (#xFBDE #x9302) + (#xFBDD #x931D) + (#xFBDC #x92FF) + (#xFBDB #x931E) + (#xFBDA #xFA28) + (#xFBD9 #x92FB) + (#xFBD8 #x9321) + (#xFBD7 #x9325) + (#xFBD6 #x92D3) + (#xFBD5 #x92E0) + (#xFBD4 #x92D5) + (#xFBD3 #xFA27) + (#xFBD2 #x92D0) + (#xFBD1 #x92D9) + (#xFBD0 #x92D7) + (#xFBCF #x92E7) + (#xFBCE #x9278) + (#xFBCD #x9277) + (#xFBCC #x92A7) + (#xFBCB #x9267) + (#xFBCA #x9239) + (#xFBC9 #x9251) + (#xFBC8 #x9259) + (#xFBC7 #x924E) + (#xFBC6 #x923C) + (#xFBC5 #x9240) + (#xFBC4 #x923A) + (#xFBC3 #x920A) + (#xFBC2 #x9210) + (#xFBC1 #x9206) + (#xFBC0 #x91E5) + (#xFBBF #x91E4) + (#xFBBE #x91EE) + (#xFBBD #x91ED) + (#xFBBC #x91DE) + (#xFBBB #x91D7) + (#xFBBA #x91DA) + (#xFBB9 #x9127) + (#xFBB8 #x9115) + (#xFBB7 #xFA26) + (#xFBB6 #x90DE) + (#xFBB5 #x9067) + (#xFBB4 #xFA25) + (#xFBB3 #xFA24) + (#xFBB2 #x8ECF) + (#xFBB1 #xFA23) + (#xFBB0 #x8D76) + (#xFBAF #x8D12) + (#xFBAE #x8CF4) + (#xFBAD #x8CF0) + (#xFBAC #x8B7F) + (#xFBAB #x8B53) + (#xFBAA #x8AF6) + (#xFBA9 #xFA22) + (#xFBA8 #x8ADF) + (#xFBA7 #x8ABE) + (#xFBA6 #x8AA7) + (#xFBA5 #x8A79) + (#xFBA4 #x8A37) + (#xFBA3 #x8A12) + (#xFBA2 #x88F5) + (#xFBA1 #x8807) + (#xFBA0 #xFA21) + (#xFB9F #xFA20) + (#xFB9E #x85B0) + (#xFB9D #xFA1F) + (#xFB9C #x856B) + (#xFB9B #x8559) + (#xFB9A #x8553) + (#xFB99 #x84B4) + (#xFB98 #x8448) + (#xFB97 #x83F6) + (#xFB96 #x83C7) + (#xFB95 #x837F) + (#xFB94 #x8362) + (#xFB93 #x8301) + (#xFB92 #xFA1E) + (#xFB91 #x7FA1) + (#xFB90 #x7F47) + (#xFB8F #x7E52) + (#xFB8E #x7DD6) + (#xFB8D #x7DA0) + (#xFB8C #x7DB7) + (#xFB8B #x7D5C) + (#xFB8A #x7D48) + (#xFB89 #xFA1D) + (#xFB88 #x7B9E) + (#xFB87 #x7AEB) + (#xFB86 #xFA1C) + (#xFB85 #x7AE7) + (#xFB84 #x7AD1) + (#xFB83 #x799B) + (#xFB82 #xFA1B) + (#xFB81 #x7994) + (#xFB80 #xFA1A) + (#xFB7E #xFA19) + (#xFB7D #xFA18) + (#xFB7C #x7930) + (#xFB7B #x787A) + (#xFB7A #x7864) + (#xFB79 #x784E) + (#xFB78 #x7821) + (#xFB77 #x52AF) + (#xFB76 #x7746) + (#xFB75 #xFA17) + (#xFB74 #x76A6) + (#xFB73 #x769B) + (#xFB72 #x769E) + (#xFB71 #x769C) + (#xFB70 #x7682) + (#xFB6F #x756F) + (#xFB6E #x7501) + (#xFB6D #x749F) + (#xFB6C #x7489) + (#xFB6B #x7462) + (#xFB6A #x742E) + (#xFB69 #x7429) + (#xFB68 #x742A) + (#xFB67 #x7426) + (#xFB66 #x73F5) + (#xFB65 #x7407) + (#xFB64 #x73D2) + (#xFB63 #x73E3) + (#xFB62 #x73D6) + (#xFB61 #x73C9) + (#xFB60 #x73BD) + (#xFB5F #x7377) + (#xFB5E #xFA16) + (#xFB5D #x7324) + (#xFB5C #x72BE) + (#xFB5B #x72B1) + (#xFB5A #x71FE) + (#xFB59 #x71C1) + (#xFB58 #xFA15) + (#xFB57 #x7147) + (#xFB56 #x7146) + (#xFB55 #x715C) + (#xFB54 #x7104) + (#xFB53 #x710F) + (#xFB52 #x70AB) + (#xFB51 #x7085) + (#xFB50 #x7028) + (#xFB4F #x7007) + (#xFB4E #x7005) + (#xFB4D #x6FF5) + (#xFB4C #x6FB5) + (#xFB4B #x6F88) + (#xFB4A #x6EBF) + (#xFB49 #x6E3C) + (#xFB48 #x6E27) + (#xFB47 #x6E5C) + (#xFB46 #x6E39) + (#xFB45 #x6DFC) + (#xFB44 #x6DF2) + (#xFB43 #x6DF8) + (#xFB42 #x6DCF) + (#xFB41 #x6DAC) + (#xFB40 #x6D96) + (#xFAFC #x6D6F) + (#xFAFB #x6D87) + (#xFAFA #x6D04) + (#xFAF9 #x6CDA) + (#xFAF8 #x6C6F) + (#xFAF7 #x6C86) + (#xFAF6 #x6C5C) + (#xFAF5 #x6C3F) + (#xFAF4 #x6BD6) + (#xFAF3 #x6AE4) + (#xFAF2 #x6AE2) + (#xFAF1 #x6A7E) + (#xFAF0 #x6A73) + (#xFAEF #x6A46) + (#xFAEE #x6A6B) + (#xFAED #x6A30) + (#xFAEC #x69E2) + (#xFAEB #x6998) + (#xFAEA #xFA14) + (#xFAE9 #x6968) + (#xFAE8 #xFA13) + (#xFAE7 #x68CF) + (#xFAE6 #x6844) + (#xFAE5 #x6801) + (#xFAE4 #x67C0) + (#xFAE3 #x6852) + (#xFAE2 #x67BB) + (#xFAE1 #x6766) + (#xFAE0 #xF929) + (#xFADF #x670E) + (#xFADE #x66FA) + (#xFADD #x66BF) + (#xFADC #x66B2) + (#xFADB #x66A0) + (#xFADA #x6699) + (#xFAD9 #x6673) + (#xFAD8 #xFA12) + (#xFAD7 #x6659) + (#xFAD6 #x6657) + (#xFAD5 #x6665) + (#xFAD4 #x6624) + (#xFAD3 #x661E) + (#xFAD2 #x662E) + (#xFAD1 #x6609) + (#xFAD0 #x663B) + (#xFACF #x6615) + (#xFACE #x6600) + (#xFACD #x654E) + (#xFACC #x64CE) + (#xFACB #x649D) + (#xFACA #x6460) + (#xFAC9 #x63F5) + (#xFAC8 #x62A6) + (#xFAC7 #x6213) + (#xFAC6 #x6198) + (#xFAC5 #x6130) + (#xFAC4 #x6137) + (#xFAC3 #x6111) + (#xFAC2 #x60F2) + (#xFAC1 #x6120) + (#xFAC0 #x60D5) + (#xFABF #x60DE) + (#xFABE #x608A) + (#xFABD #x6085) + (#xFABC #x605D) + (#xFABB #x5FDE) + (#xFABA #x5FB7) + (#xFAB9 #x5F67) + (#xFAB8 #x5F34) + (#xFAB7 #x5F21) + (#xFAB6 #x5DD0) + (#xFAB5 #x5DB9) + (#xFAB4 #x5DB8) + (#xFAB3 #x5D6D) + (#xFAB2 #x5D42) + (#xFAB1 #xFA11) + (#xFAB0 #x5D53) + (#xFAAF #x5D27) + (#xFAAE #x5CF5) + (#xFAAD #x5CBA) + (#xFAAC #x5CA6) + (#xFAAB #x5C1E) + (#xFAAA #x5BEC) + (#xFAA9 #x5BD8) + (#xFAA8 #x752F) + (#xFAA7 #x5BC0) + (#xFAA6 #x5B56) + (#xFAA5 #x59BA) + (#xFAA4 #x59A4) + (#xFAA3 #x5963) + (#xFAA2 #x595D) + (#xFAA1 #x595B) + (#xFAA0 #x5953) + (#xFA9F #x590B) + (#xFA9E #x58B2) + (#xFA9D #x589E) + (#xFA9C #xFA10) + (#xFA9B #xFA0F) + (#xFA9A #x57C7) + (#xFA99 #x57C8) + (#xFA98 #x57AC) + (#xFA97 #x5765) + (#xFA96 #x5759) + (#xFA95 #x5586) + (#xFA94 #x54FF) + (#xFA93 #x54A9) + (#xFA92 #x548A) + (#xFA91 #x549C) + (#xFA90 #xFA0E) + (#xFA8F #x53DD) + (#xFA8E #x53B2) + (#xFA8D #x5393) + (#xFA8C #x5372) + (#xFA8B #x5324) + (#xFA8A #x5307) + (#xFA89 #x5300) + (#xFA88 #x52DB) + (#xFA87 #x52C0) + (#xFA86 #x52A6) + (#xFA85 #x529C) + (#xFA84 #x5215) + (#xFA83 #x51EC) + (#xFA82 #x51BE) + (#xFA81 #x519D) + (#xFA80 #x5164) + (#xFA7E #x514A) + (#xFA7D #x50D8) + (#xFA7C #x50F4) + (#xFA7B #x5094) + (#xFA7A #x5042) + (#xFA79 #x5070) + (#xFA78 #x5046) + (#xFA77 #x501E) + (#xFA76 #x4FFF) + (#xFA75 #x5022) + (#xFA74 #x5040) + (#xFA73 #x4FCD) + (#xFA72 #x4F94) + (#xFA71 #x4F9A) + (#xFA70 #x4F8A) + (#xFA6F #x4F92) + (#xFA6E #x4F56) + (#xFA6D #x4F39) + (#xFA6C #x4F03) + (#xFA6B #x4F00) + (#xFA6A #x4EFC) + (#xFA69 #x4EE1) + (#xFA68 #x4E28) + (#xFA67 #x5F45) + (#xFA66 #x66FB) + (#xFA65 #x92F9) + (#xFA64 #x68C8) + (#xFA63 #x6631) + (#xFA62 #x70BB) + (#xFA61 #x4FC9) + (#xFA60 #x84DC) + (#xFA5F #x9288) + (#xFA5E #x9348) + (#xFA5D #x891C) + (#xFA5C #x7E8A) + (#xFA5B #x2235) + (#xFA5A #x2121) + (#xFA59 #x2116) + (#xFA58 #x3231) + (#xFA57 #xFF02) + (#xFA56 #xFF07) + (#xFA55 #xFFE4) + (#xFA54 #xFFE2) + (#xFA53 #x2169) + (#xFA52 #x2168) + (#xFA51 #x2167) + (#xFA50 #x2166) + (#xFA4F #x2165) + (#xFA4E #x2164) + (#xFA4D #x2163) + (#xFA4C #x2162) + (#xFA4B #x2161) + (#xFA4A #x2160) + (#xFA49 #x2179) + (#xFA48 #x2178) + (#xFA47 #x2177) + (#xFA46 #x2176) + (#xFA45 #x2175) + (#xFA44 #x2174) + (#xFA43 #x2173) + (#xFA42 #x2172) + (#xFA41 #x2171) + (#xFA40 #x2170) + (#xF9FC #xE757) + (#xF9FB #xE756) + (#xF9FA #xE755) + (#xF9F9 #xE754) + (#xF9F8 #xE753) + (#xF9F7 #xE752) + (#xF9F6 #xE751) + (#xF9F5 #xE750) + (#xF9F4 #xE74F) + (#xF9F3 #xE74E) + (#xF9F2 #xE74D) + (#xF9F1 #xE74C) + (#xF9F0 #xE74B) + (#xF9EF #xE74A) + (#xF9EE #xE749) + (#xF9ED #xE748) + (#xF9EC #xE747) + (#xF9EB #xE746) + (#xF9EA #xE745) + (#xF9E9 #xE744) + (#xF9E8 #xE743) + (#xF9E7 #xE742) + (#xF9E6 #xE741) + (#xF9E5 #xE740) + (#xF9E4 #xE73F) + (#xF9E3 #xE73E) + (#xF9E2 #xE73D) + (#xF9E1 #xE73C) + (#xF9E0 #xE73B) + (#xF9DF #xE73A) + (#xF9DE #xE739) + (#xF9DD #xE738) + (#xF9DC #xE737) + (#xF9DB #xE736) + (#xF9DA #xE735) + (#xF9D9 #xE734) + (#xF9D8 #xE733) + (#xF9D7 #xE732) + (#xF9D6 #xE731) + (#xF9D5 #xE730) + (#xF9D4 #xE72F) + (#xF9D3 #xE72E) + (#xF9D2 #xE72D) + (#xF9D1 #xE72C) + (#xF9D0 #xE72B) + (#xF9CF #xE72A) + (#xF9CE #xE729) + (#xF9CD #xE728) + (#xF9CC #xE727) + (#xF9CB #xE726) + (#xF9CA #xE725) + (#xF9C9 #xE724) + (#xF9C8 #xE723) + (#xF9C7 #xE722) + (#xF9C6 #xE721) + (#xF9C5 #xE720) + (#xF9C4 #xE71F) + (#xF9C3 #xE71E) + (#xF9C2 #xE71D) + (#xF9C1 #xE71C) + (#xF9C0 #xE71B) + (#xF9BF #xE71A) + (#xF9BE #xE719) + (#xF9BD #xE718) + (#xF9BC #xE717) + (#xF9BB #xE716) + (#xF9BA #xE715) + (#xF9B9 #xE714) + (#xF9B8 #xE713) + (#xF9B7 #xE712) + (#xF9B6 #xE711) + (#xF9B5 #xE710) + (#xF9B4 #xE70F) + (#xF9B3 #xE70E) + (#xF9B2 #xE70D) + (#xF9B1 #xE70C) + (#xF9B0 #xE70B) + (#xF9AF #xE70A) + (#xF9AE #xE709) + (#xF9AD #xE708) + (#xF9AC #xE707) + (#xF9AB #xE706) + (#xF9AA #xE705) + (#xF9A9 #xE704) + (#xF9A8 #xE703) + (#xF9A7 #xE702) + (#xF9A6 #xE701) + (#xF9A5 #xE700) + (#xF9A4 #xE6FF) + (#xF9A3 #xE6FE) + (#xF9A2 #xE6FD) + (#xF9A1 #xE6FC) + (#xF9A0 #xE6FB) + (#xF99F #xE6FA) + (#xF99E #xE6F9) + (#xF99D #xE6F8) + (#xF99C #xE6F7) + (#xF99B #xE6F6) + (#xF99A #xE6F5) + (#xF999 #xE6F4) + (#xF998 #xE6F3) + (#xF997 #xE6F2) + (#xF996 #xE6F1) + (#xF995 #xE6F0) + (#xF994 #xE6EF) + (#xF993 #xE6EE) + (#xF992 #xE6ED) + (#xF991 #xE6EC) + (#xF990 #xE6EB) + (#xF98F #xE6EA) + (#xF98E #xE6E9) + (#xF98D #xE6E8) + (#xF98C #xE6E7) + (#xF98B #xE6E6) + (#xF98A #xE6E5) + (#xF989 #xE6E4) + (#xF988 #xE6E3) + (#xF987 #xE6E2) + (#xF986 #xE6E1) + (#xF985 #xE6E0) + (#xF984 #xE6DF) + (#xF983 #xE6DE) + (#xF982 #xE6DD) + (#xF981 #xE6DC) + (#xF980 #xE6DB) + (#xF97E #xE6DA) + (#xF97D #xE6D9) + (#xF97C #xE6D8) + (#xF97B #xE6D7) + (#xF97A #xE6D6) + (#xF979 #xE6D5) + (#xF978 #xE6D4) + (#xF977 #xE6D3) + (#xF976 #xE6D2) + (#xF975 #xE6D1) + (#xF974 #xE6D0) + (#xF973 #xE6CF) + (#xF972 #xE6CE) + (#xF971 #xE6CD) + (#xF970 #xE6CC) + (#xF96F #xE6CB) + (#xF96E #xE6CA) + (#xF96D #xE6C9) + (#xF96C #xE6C8) + (#xF96B #xE6C7) + (#xF96A #xE6C6) + (#xF969 #xE6C5) + (#xF968 #xE6C4) + (#xF967 #xE6C3) + (#xF966 #xE6C2) + (#xF965 #xE6C1) + (#xF964 #xE6C0) + (#xF963 #xE6BF) + (#xF962 #xE6BE) + (#xF961 #xE6BD) + (#xF960 #xE6BC) + (#xF95F #xE6BB) + (#xF95E #xE6BA) + (#xF95D #xE6B9) + (#xF95C #xE6B8) + (#xF95B #xE6B7) + (#xF95A #xE6B6) + (#xF959 #xE6B5) + (#xF958 #xE6B4) + (#xF957 #xE6B3) + (#xF956 #xE6B2) + (#xF955 #xE6B1) + (#xF954 #xE6B0) + (#xF953 #xE6AF) + (#xF952 #xE6AE) + (#xF951 #xE6AD) + (#xF950 #xE6AC) + (#xF94F #xE6AB) + (#xF94E #xE6AA) + (#xF94D #xE6A9) + (#xF94C #xE6A8) + (#xF94B #xE6A7) + (#xF94A #xE6A6) + (#xF949 #xE6A5) + (#xF948 #xE6A4) + (#xF947 #xE6A3) + (#xF946 #xE6A2) + (#xF945 #xE6A1) + (#xF944 #xE6A0) + (#xF943 #xE69F) + (#xF942 #xE69E) + (#xF941 #xE69D) + (#xF940 #xE69C) + (#xF8FC #xE69B) + (#xF8FB #xE69A) + (#xF8FA #xE699) + (#xF8F9 #xE698) + (#xF8F8 #xE697) + (#xF8F7 #xE696) + (#xF8F6 #xE695) + (#xF8F5 #xE694) + (#xF8F4 #xE693) + (#xF8F3 #xE692) + (#xF8F2 #xE691) + (#xF8F1 #xE690) + (#xF8F0 #xE68F) + (#xF8EF #xE68E) + (#xF8EE #xE68D) + (#xF8ED #xE68C) + (#xF8EC #xE68B) + (#xF8EB #xE68A) + (#xF8EA #xE689) + (#xF8E9 #xE688) + (#xF8E8 #xE687) + (#xF8E7 #xE686) + (#xF8E6 #xE685) + (#xF8E5 #xE684) + (#xF8E4 #xE683) + (#xF8E3 #xE682) + (#xF8E2 #xE681) + (#xF8E1 #xE680) + (#xF8E0 #xE67F) + (#xF8DF #xE67E) + (#xF8DE #xE67D) + (#xF8DD #xE67C) + (#xF8DC #xE67B) + (#xF8DB #xE67A) + (#xF8DA #xE679) + (#xF8D9 #xE678) + (#xF8D8 #xE677) + (#xF8D7 #xE676) + (#xF8D6 #xE675) + (#xF8D5 #xE674) + (#xF8D4 #xE673) + (#xF8D3 #xE672) + (#xF8D2 #xE671) + (#xF8D1 #xE670) + (#xF8D0 #xE66F) + (#xF8CF #xE66E) + (#xF8CE #xE66D) + (#xF8CD #xE66C) + (#xF8CC #xE66B) + (#xF8CB #xE66A) + (#xF8CA #xE669) + (#xF8C9 #xE668) + (#xF8C8 #xE667) + (#xF8C7 #xE666) + (#xF8C6 #xE665) + (#xF8C5 #xE664) + (#xF8C4 #xE663) + (#xF8C3 #xE662) + (#xF8C2 #xE661) + (#xF8C1 #xE660) + (#xF8C0 #xE65F) + (#xF8BF #xE65E) + (#xF8BE #xE65D) + (#xF8BD #xE65C) + (#xF8BC #xE65B) + (#xF8BB #xE65A) + (#xF8BA #xE659) + (#xF8B9 #xE658) + (#xF8B8 #xE657) + (#xF8B7 #xE656) + (#xF8B6 #xE655) + (#xF8B5 #xE654) + (#xF8B4 #xE653) + (#xF8B3 #xE652) + (#xF8B2 #xE651) + (#xF8B1 #xE650) + (#xF8B0 #xE64F) + (#xF8AF #xE64E) + (#xF8AE #xE64D) + (#xF8AD #xE64C) + (#xF8AC #xE64B) + (#xF8AB #xE64A) + (#xF8AA #xE649) + (#xF8A9 #xE648) + (#xF8A8 #xE647) + (#xF8A7 #xE646) + (#xF8A6 #xE645) + (#xF8A5 #xE644) + (#xF8A4 #xE643) + (#xF8A3 #xE642) + (#xF8A2 #xE641) + (#xF8A1 #xE640) + (#xF8A0 #xE63F) + (#xF89F #xE63E) + (#xF89E #xE63D) + (#xF89D #xE63C) + (#xF89C #xE63B) + (#xF89B #xE63A) + (#xF89A #xE639) + (#xF899 #xE638) + (#xF898 #xE637) + (#xF897 #xE636) + (#xF896 #xE635) + (#xF895 #xE634) + (#xF894 #xE633) + (#xF893 #xE632) + (#xF892 #xE631) + (#xF891 #xE630) + (#xF890 #xE62F) + (#xF88F #xE62E) + (#xF88E #xE62D) + (#xF88D #xE62C) + (#xF88C #xE62B) + (#xF88B #xE62A) + (#xF88A #xE629) + (#xF889 #xE628) + (#xF888 #xE627) + (#xF887 #xE626) + (#xF886 #xE625) + (#xF885 #xE624) + (#xF884 #xE623) + (#xF883 #xE622) + (#xF882 #xE621) + (#xF881 #xE620) + (#xF880 #xE61F) + (#xF87E #xE61E) + (#xF87D #xE61D) + (#xF87C #xE61C) + (#xF87B #xE61B) + (#xF87A #xE61A) + (#xF879 #xE619) + (#xF878 #xE618) + (#xF877 #xE617) + (#xF876 #xE616) + (#xF875 #xE615) + (#xF874 #xE614) + (#xF873 #xE613) + (#xF872 #xE612) + (#xF871 #xE611) + (#xF870 #xE610) + (#xF86F #xE60F) + (#xF86E #xE60E) + (#xF86D #xE60D) + (#xF86C #xE60C) + (#xF86B #xE60B) + (#xF86A #xE60A) + (#xF869 #xE609) + (#xF868 #xE608) + (#xF867 #xE607) + (#xF866 #xE606) + (#xF865 #xE605) + (#xF864 #xE604) + (#xF863 #xE603) + (#xF862 #xE602) + (#xF861 #xE601) + (#xF860 #xE600) + (#xF85F #xE5FF) + (#xF85E #xE5FE) + (#xF85D #xE5FD) + (#xF85C #xE5FC) + (#xF85B #xE5FB) + (#xF85A #xE5FA) + (#xF859 #xE5F9) + (#xF858 #xE5F8) + (#xF857 #xE5F7) + (#xF856 #xE5F6) + (#xF855 #xE5F5) + (#xF854 #xE5F4) + (#xF853 #xE5F3) + (#xF852 #xE5F2) + (#xF851 #xE5F1) + (#xF850 #xE5F0) + (#xF84F #xE5EF) + (#xF84E #xE5EE) + (#xF84D #xE5ED) + (#xF84C #xE5EC) + (#xF84B #xE5EB) + (#xF84A #xE5EA) + (#xF849 #xE5E9) + (#xF848 #xE5E8) + (#xF847 #xE5E7) + (#xF846 #xE5E6) + (#xF845 #xE5E5) + (#xF844 #xE5E4) + (#xF843 #xE5E3) + (#xF842 #xE5E2) + (#xF841 #xE5E1) + (#xF840 #xE5E0) + (#xF7FC #xE5DF) + (#xF7FB #xE5DE) + (#xF7FA #xE5DD) + (#xF7F9 #xE5DC) + (#xF7F8 #xE5DB) + (#xF7F7 #xE5DA) + (#xF7F6 #xE5D9) + (#xF7F5 #xE5D8) + (#xF7F4 #xE5D7) + (#xF7F3 #xE5D6) + (#xF7F2 #xE5D5) + (#xF7F1 #xE5D4) + (#xF7F0 #xE5D3) + (#xF7EF #xE5D2) + (#xF7EE #xE5D1) + (#xF7ED #xE5D0) + (#xF7EC #xE5CF) + (#xF7EB #xE5CE) + (#xF7EA #xE5CD) + (#xF7E9 #xE5CC) + (#xF7E8 #xE5CB) + (#xF7E7 #xE5CA) + (#xF7E6 #xE5C9) + (#xF7E5 #xE5C8) + (#xF7E4 #xE5C7) + (#xF7E3 #xE5C6) + (#xF7E2 #xE5C5) + (#xF7E1 #xE5C4) + (#xF7E0 #xE5C3) + (#xF7DF #xE5C2) + (#xF7DE #xE5C1) + (#xF7DD #xE5C0) + (#xF7DC #xE5BF) + (#xF7DB #xE5BE) + (#xF7DA #xE5BD) + (#xF7D9 #xE5BC) + (#xF7D8 #xE5BB) + (#xF7D7 #xE5BA) + (#xF7D6 #xE5B9) + (#xF7D5 #xE5B8) + (#xF7D4 #xE5B7) + (#xF7D3 #xE5B6) + (#xF7D2 #xE5B5) + (#xF7D1 #xE5B4) + (#xF7D0 #xE5B3) + (#xF7CF #xE5B2) + (#xF7CE #xE5B1) + (#xF7CD #xE5B0) + (#xF7CC #xE5AF) + (#xF7CB #xE5AE) + (#xF7CA #xE5AD) + (#xF7C9 #xE5AC) + (#xF7C8 #xE5AB) + (#xF7C7 #xE5AA) + (#xF7C6 #xE5A9) + (#xF7C5 #xE5A8) + (#xF7C4 #xE5A7) + (#xF7C3 #xE5A6) + (#xF7C2 #xE5A5) + (#xF7C1 #xE5A4) + (#xF7C0 #xE5A3) + (#xF7BF #xE5A2) + (#xF7BE #xE5A1) + (#xF7BD #xE5A0) + (#xF7BC #xE59F) + (#xF7BB #xE59E) + (#xF7BA #xE59D) + (#xF7B9 #xE59C) + (#xF7B8 #xE59B) + (#xF7B7 #xE59A) + (#xF7B6 #xE599) + (#xF7B5 #xE598) + (#xF7B4 #xE597) + (#xF7B3 #xE596) + (#xF7B2 #xE595) + (#xF7B1 #xE594) + (#xF7B0 #xE593) + (#xF7AF #xE592) + (#xF7AE #xE591) + (#xF7AD #xE590) + (#xF7AC #xE58F) + (#xF7AB #xE58E) + (#xF7AA #xE58D) + (#xF7A9 #xE58C) + (#xF7A8 #xE58B) + (#xF7A7 #xE58A) + (#xF7A6 #xE589) + (#xF7A5 #xE588) + (#xF7A4 #xE587) + (#xF7A3 #xE586) + (#xF7A2 #xE585) + (#xF7A1 #xE584) + (#xF7A0 #xE583) + (#xF79F #xE582) + (#xF79E #xE581) + (#xF79D #xE580) + (#xF79C #xE57F) + (#xF79B #xE57E) + (#xF79A #xE57D) + (#xF799 #xE57C) + (#xF798 #xE57B) + (#xF797 #xE57A) + (#xF796 #xE579) + (#xF795 #xE578) + (#xF794 #xE577) + (#xF793 #xE576) + (#xF792 #xE575) + (#xF791 #xE574) + (#xF790 #xE573) + (#xF78F #xE572) + (#xF78E #xE571) + (#xF78D #xE570) + (#xF78C #xE56F) + (#xF78B #xE56E) + (#xF78A #xE56D) + (#xF789 #xE56C) + (#xF788 #xE56B) + (#xF787 #xE56A) + (#xF786 #xE569) + (#xF785 #xE568) + (#xF784 #xE567) + (#xF783 #xE566) + (#xF782 #xE565) + (#xF781 #xE564) + (#xF780 #xE563) + (#xF77E #xE562) + (#xF77D #xE561) + (#xF77C #xE560) + (#xF77B #xE55F) + (#xF77A #xE55E) + (#xF779 #xE55D) + (#xF778 #xE55C) + (#xF777 #xE55B) + (#xF776 #xE55A) + (#xF775 #xE559) + (#xF774 #xE558) + (#xF773 #xE557) + (#xF772 #xE556) + (#xF771 #xE555) + (#xF770 #xE554) + (#xF76F #xE553) + (#xF76E #xE552) + (#xF76D #xE551) + (#xF76C #xE550) + (#xF76B #xE54F) + (#xF76A #xE54E) + (#xF769 #xE54D) + (#xF768 #xE54C) + (#xF767 #xE54B) + (#xF766 #xE54A) + (#xF765 #xE549) + (#xF764 #xE548) + (#xF763 #xE547) + (#xF762 #xE546) + (#xF761 #xE545) + (#xF760 #xE544) + (#xF75F #xE543) + (#xF75E #xE542) + (#xF75D #xE541) + (#xF75C #xE540) + (#xF75B #xE53F) + (#xF75A #xE53E) + (#xF759 #xE53D) + (#xF758 #xE53C) + (#xF757 #xE53B) + (#xF756 #xE53A) + (#xF755 #xE539) + (#xF754 #xE538) + (#xF753 #xE537) + (#xF752 #xE536) + (#xF751 #xE535) + (#xF750 #xE534) + (#xF74F #xE533) + (#xF74E #xE532) + (#xF74D #xE531) + (#xF74C #xE530) + (#xF74B #xE52F) + (#xF74A #xE52E) + (#xF749 #xE52D) + (#xF748 #xE52C) + (#xF747 #xE52B) + (#xF746 #xE52A) + (#xF745 #xE529) + (#xF744 #xE528) + (#xF743 #xE527) + (#xF742 #xE526) + (#xF741 #xE525) + (#xF740 #xE524) + (#xF6FC #xE523) + (#xF6FB #xE522) + (#xF6FA #xE521) + (#xF6F9 #xE520) + (#xF6F8 #xE51F) + (#xF6F7 #xE51E) + (#xF6F6 #xE51D) + (#xF6F5 #xE51C) + (#xF6F4 #xE51B) + (#xF6F3 #xE51A) + (#xF6F2 #xE519) + (#xF6F1 #xE518) + (#xF6F0 #xE517) + (#xF6EF #xE516) + (#xF6EE #xE515) + (#xF6ED #xE514) + (#xF6EC #xE513) + (#xF6EB #xE512) + (#xF6EA #xE511) + (#xF6E9 #xE510) + (#xF6E8 #xE50F) + (#xF6E7 #xE50E) + (#xF6E6 #xE50D) + (#xF6E5 #xE50C) + (#xF6E4 #xE50B) + (#xF6E3 #xE50A) + (#xF6E2 #xE509) + (#xF6E1 #xE508) + (#xF6E0 #xE507) + (#xF6DF #xE506) + (#xF6DE #xE505) + (#xF6DD #xE504) + (#xF6DC #xE503) + (#xF6DB #xE502) + (#xF6DA #xE501) + (#xF6D9 #xE500) + (#xF6D8 #xE4FF) + (#xF6D7 #xE4FE) + (#xF6D6 #xE4FD) + (#xF6D5 #xE4FC) + (#xF6D4 #xE4FB) + (#xF6D3 #xE4FA) + (#xF6D2 #xE4F9) + (#xF6D1 #xE4F8) + (#xF6D0 #xE4F7) + (#xF6CF #xE4F6) + (#xF6CE #xE4F5) + (#xF6CD #xE4F4) + (#xF6CC #xE4F3) + (#xF6CB #xE4F2) + (#xF6CA #xE4F1) + (#xF6C9 #xE4F0) + (#xF6C8 #xE4EF) + (#xF6C7 #xE4EE) + (#xF6C6 #xE4ED) + (#xF6C5 #xE4EC) + (#xF6C4 #xE4EB) + (#xF6C3 #xE4EA) + (#xF6C2 #xE4E9) + (#xF6C1 #xE4E8) + (#xF6C0 #xE4E7) + (#xF6BF #xE4E6) + (#xF6BE #xE4E5) + (#xF6BD #xE4E4) + (#xF6BC #xE4E3) + (#xF6BB #xE4E2) + (#xF6BA #xE4E1) + (#xF6B9 #xE4E0) + (#xF6B8 #xE4DF) + (#xF6B7 #xE4DE) + (#xF6B6 #xE4DD) + (#xF6B5 #xE4DC) + (#xF6B4 #xE4DB) + (#xF6B3 #xE4DA) + (#xF6B2 #xE4D9) + (#xF6B1 #xE4D8) + (#xF6B0 #xE4D7) + (#xF6AF #xE4D6) + (#xF6AE #xE4D5) + (#xF6AD #xE4D4) + (#xF6AC #xE4D3) + (#xF6AB #xE4D2) + (#xF6AA #xE4D1) + (#xF6A9 #xE4D0) + (#xF6A8 #xE4CF) + (#xF6A7 #xE4CE) + (#xF6A6 #xE4CD) + (#xF6A5 #xE4CC) + (#xF6A4 #xE4CB) + (#xF6A3 #xE4CA) + (#xF6A2 #xE4C9) + (#xF6A1 #xE4C8) + (#xF6A0 #xE4C7) + (#xF69F #xE4C6) + (#xF69E #xE4C5) + (#xF69D #xE4C4) + (#xF69C #xE4C3) + (#xF69B #xE4C2) + (#xF69A #xE4C1) + (#xF699 #xE4C0) + (#xF698 #xE4BF) + (#xF697 #xE4BE) + (#xF696 #xE4BD) + (#xF695 #xE4BC) + (#xF694 #xE4BB) + (#xF693 #xE4BA) + (#xF692 #xE4B9) + (#xF691 #xE4B8) + (#xF690 #xE4B7) + (#xF68F #xE4B6) + (#xF68E #xE4B5) + (#xF68D #xE4B4) + (#xF68C #xE4B3) + (#xF68B #xE4B2) + (#xF68A #xE4B1) + (#xF689 #xE4B0) + (#xF688 #xE4AF) + (#xF687 #xE4AE) + (#xF686 #xE4AD) + (#xF685 #xE4AC) + (#xF684 #xE4AB) + (#xF683 #xE4AA) + (#xF682 #xE4A9) + (#xF681 #xE4A8) + (#xF680 #xE4A7) + (#xF67E #xE4A6) + (#xF67D #xE4A5) + (#xF67C #xE4A4) + (#xF67B #xE4A3) + (#xF67A #xE4A2) + (#xF679 #xE4A1) + (#xF678 #xE4A0) + (#xF677 #xE49F) + (#xF676 #xE49E) + (#xF675 #xE49D) + (#xF674 #xE49C) + (#xF673 #xE49B) + (#xF672 #xE49A) + (#xF671 #xE499) + (#xF670 #xE498) + (#xF66F #xE497) + (#xF66E #xE496) + (#xF66D #xE495) + (#xF66C #xE494) + (#xF66B #xE493) + (#xF66A #xE492) + (#xF669 #xE491) + (#xF668 #xE490) + (#xF667 #xE48F) + (#xF666 #xE48E) + (#xF665 #xE48D) + (#xF664 #xE48C) + (#xF663 #xE48B) + (#xF662 #xE48A) + (#xF661 #xE489) + (#xF660 #xE488) + (#xF65F #xE487) + (#xF65E #xE486) + (#xF65D #xE485) + (#xF65C #xE484) + (#xF65B #xE483) + (#xF65A #xE482) + (#xF659 #xE481) + (#xF658 #xE480) + (#xF657 #xE47F) + (#xF656 #xE47E) + (#xF655 #xE47D) + (#xF654 #xE47C) + (#xF653 #xE47B) + (#xF652 #xE47A) + (#xF651 #xE479) + (#xF650 #xE478) + (#xF64F #xE477) + (#xF64E #xE476) + (#xF64D #xE475) + (#xF64C #xE474) + (#xF64B #xE473) + (#xF64A #xE472) + (#xF649 #xE471) + (#xF648 #xE470) + (#xF647 #xE46F) + (#xF646 #xE46E) + (#xF645 #xE46D) + (#xF644 #xE46C) + (#xF643 #xE46B) + (#xF642 #xE46A) + (#xF641 #xE469) + (#xF640 #xE468) + (#xF5FC #xE467) + (#xF5FB #xE466) + (#xF5FA #xE465) + (#xF5F9 #xE464) + (#xF5F8 #xE463) + (#xF5F7 #xE462) + (#xF5F6 #xE461) + (#xF5F5 #xE460) + (#xF5F4 #xE45F) + (#xF5F3 #xE45E) + (#xF5F2 #xE45D) + (#xF5F1 #xE45C) + (#xF5F0 #xE45B) + (#xF5EF #xE45A) + (#xF5EE #xE459) + (#xF5ED #xE458) + (#xF5EC #xE457) + (#xF5EB #xE456) + (#xF5EA #xE455) + (#xF5E9 #xE454) + (#xF5E8 #xE453) + (#xF5E7 #xE452) + (#xF5E6 #xE451) + (#xF5E5 #xE450) + (#xF5E4 #xE44F) + (#xF5E3 #xE44E) + (#xF5E2 #xE44D) + (#xF5E1 #xE44C) + (#xF5E0 #xE44B) + (#xF5DF #xE44A) + (#xF5DE #xE449) + (#xF5DD #xE448) + (#xF5DC #xE447) + (#xF5DB #xE446) + (#xF5DA #xE445) + (#xF5D9 #xE444) + (#xF5D8 #xE443) + (#xF5D7 #xE442) + (#xF5D6 #xE441) + (#xF5D5 #xE440) + (#xF5D4 #xE43F) + (#xF5D3 #xE43E) + (#xF5D2 #xE43D) + (#xF5D1 #xE43C) + (#xF5D0 #xE43B) + (#xF5CF #xE43A) + (#xF5CE #xE439) + (#xF5CD #xE438) + (#xF5CC #xE437) + (#xF5CB #xE436) + (#xF5CA #xE435) + (#xF5C9 #xE434) + (#xF5C8 #xE433) + (#xF5C7 #xE432) + (#xF5C6 #xE431) + (#xF5C5 #xE430) + (#xF5C4 #xE42F) + (#xF5C3 #xE42E) + (#xF5C2 #xE42D) + (#xF5C1 #xE42C) + (#xF5C0 #xE42B) + (#xF5BF #xE42A) + (#xF5BE #xE429) + (#xF5BD #xE428) + (#xF5BC #xE427) + (#xF5BB #xE426) + (#xF5BA #xE425) + (#xF5B9 #xE424) + (#xF5B8 #xE423) + (#xF5B7 #xE422) + (#xF5B6 #xE421) + (#xF5B5 #xE420) + (#xF5B4 #xE41F) + (#xF5B3 #xE41E) + (#xF5B2 #xE41D) + (#xF5B1 #xE41C) + (#xF5B0 #xE41B) + (#xF5AF #xE41A) + (#xF5AE #xE419) + (#xF5AD #xE418) + (#xF5AC #xE417) + (#xF5AB #xE416) + (#xF5AA #xE415) + (#xF5A9 #xE414) + (#xF5A8 #xE413) + (#xF5A7 #xE412) + (#xF5A6 #xE411) + (#xF5A5 #xE410) + (#xF5A4 #xE40F) + (#xF5A3 #xE40E) + (#xF5A2 #xE40D) + (#xF5A1 #xE40C) + (#xF5A0 #xE40B) + (#xF59F #xE40A) + (#xF59E #xE409) + (#xF59D #xE408) + (#xF59C #xE407) + (#xF59B #xE406) + (#xF59A #xE405) + (#xF599 #xE404) + (#xF598 #xE403) + (#xF597 #xE402) + (#xF596 #xE401) + (#xF595 #xE400) + (#xF594 #xE3FF) + (#xF593 #xE3FE) + (#xF592 #xE3FD) + (#xF591 #xE3FC) + (#xF590 #xE3FB) + (#xF58F #xE3FA) + (#xF58E #xE3F9) + (#xF58D #xE3F8) + (#xF58C #xE3F7) + (#xF58B #xE3F6) + (#xF58A #xE3F5) + (#xF589 #xE3F4) + (#xF588 #xE3F3) + (#xF587 #xE3F2) + (#xF586 #xE3F1) + (#xF585 #xE3F0) + (#xF584 #xE3EF) + (#xF583 #xE3EE) + (#xF582 #xE3ED) + (#xF581 #xE3EC) + (#xF580 #xE3EB) + (#xF57E #xE3EA) + (#xF57D #xE3E9) + (#xF57C #xE3E8) + (#xF57B #xE3E7) + (#xF57A #xE3E6) + (#xF579 #xE3E5) + (#xF578 #xE3E4) + (#xF577 #xE3E3) + (#xF576 #xE3E2) + (#xF575 #xE3E1) + (#xF574 #xE3E0) + (#xF573 #xE3DF) + (#xF572 #xE3DE) + (#xF571 #xE3DD) + (#xF570 #xE3DC) + (#xF56F #xE3DB) + (#xF56E #xE3DA) + (#xF56D #xE3D9) + (#xF56C #xE3D8) + (#xF56B #xE3D7) + (#xF56A #xE3D6) + (#xF569 #xE3D5) + (#xF568 #xE3D4) + (#xF567 #xE3D3) + (#xF566 #xE3D2) + (#xF565 #xE3D1) + (#xF564 #xE3D0) + (#xF563 #xE3CF) + (#xF562 #xE3CE) + (#xF561 #xE3CD) + (#xF560 #xE3CC) + (#xF55F #xE3CB) + (#xF55E #xE3CA) + (#xF55D #xE3C9) + (#xF55C #xE3C8) + (#xF55B #xE3C7) + (#xF55A #xE3C6) + (#xF559 #xE3C5) + (#xF558 #xE3C4) + (#xF557 #xE3C3) + (#xF556 #xE3C2) + (#xF555 #xE3C1) + (#xF554 #xE3C0) + (#xF553 #xE3BF) + (#xF552 #xE3BE) + (#xF551 #xE3BD) + (#xF550 #xE3BC) + (#xF54F #xE3BB) + (#xF54E #xE3BA) + (#xF54D #xE3B9) + (#xF54C #xE3B8) + (#xF54B #xE3B7) + (#xF54A #xE3B6) + (#xF549 #xE3B5) + (#xF548 #xE3B4) + (#xF547 #xE3B3) + (#xF546 #xE3B2) + (#xF545 #xE3B1) + (#xF544 #xE3B0) + (#xF543 #xE3AF) + (#xF542 #xE3AE) + (#xF541 #xE3AD) + (#xF540 #xE3AC) + (#xF4FC #xE3AB) + (#xF4FB #xE3AA) + (#xF4FA #xE3A9) + (#xF4F9 #xE3A8) + (#xF4F8 #xE3A7) + (#xF4F7 #xE3A6) + (#xF4F6 #xE3A5) + (#xF4F5 #xE3A4) + (#xF4F4 #xE3A3) + (#xF4F3 #xE3A2) + (#xF4F2 #xE3A1) + (#xF4F1 #xE3A0) + (#xF4F0 #xE39F) + (#xF4EF #xE39E) + (#xF4EE #xE39D) + (#xF4ED #xE39C) + (#xF4EC #xE39B) + (#xF4EB #xE39A) + (#xF4EA #xE399) + (#xF4E9 #xE398) + (#xF4E8 #xE397) + (#xF4E7 #xE396) + (#xF4E6 #xE395) + (#xF4E5 #xE394) + (#xF4E4 #xE393) + (#xF4E3 #xE392) + (#xF4E2 #xE391) + (#xF4E1 #xE390) + (#xF4E0 #xE38F) + (#xF4DF #xE38E) + (#xF4DE #xE38D) + (#xF4DD #xE38C) + (#xF4DC #xE38B) + (#xF4DB #xE38A) + (#xF4DA #xE389) + (#xF4D9 #xE388) + (#xF4D8 #xE387) + (#xF4D7 #xE386) + (#xF4D6 #xE385) + (#xF4D5 #xE384) + (#xF4D4 #xE383) + (#xF4D3 #xE382) + (#xF4D2 #xE381) + (#xF4D1 #xE380) + (#xF4D0 #xE37F) + (#xF4CF #xE37E) + (#xF4CE #xE37D) + (#xF4CD #xE37C) + (#xF4CC #xE37B) + (#xF4CB #xE37A) + (#xF4CA #xE379) + (#xF4C9 #xE378) + (#xF4C8 #xE377) + (#xF4C7 #xE376) + (#xF4C6 #xE375) + (#xF4C5 #xE374) + (#xF4C4 #xE373) + (#xF4C3 #xE372) + (#xF4C2 #xE371) + (#xF4C1 #xE370) + (#xF4C0 #xE36F) + (#xF4BF #xE36E) + (#xF4BE #xE36D) + (#xF4BD #xE36C) + (#xF4BC #xE36B) + (#xF4BB #xE36A) + (#xF4BA #xE369) + (#xF4B9 #xE368) + (#xF4B8 #xE367) + (#xF4B7 #xE366) + (#xF4B6 #xE365) + (#xF4B5 #xE364) + (#xF4B4 #xE363) + (#xF4B3 #xE362) + (#xF4B2 #xE361) + (#xF4B1 #xE360) + (#xF4B0 #xE35F) + (#xF4AF #xE35E) + (#xF4AE #xE35D) + (#xF4AD #xE35C) + (#xF4AC #xE35B) + (#xF4AB #xE35A) + (#xF4AA #xE359) + (#xF4A9 #xE358) + (#xF4A8 #xE357) + (#xF4A7 #xE356) + (#xF4A6 #xE355) + (#xF4A5 #xE354) + (#xF4A4 #xE353) + (#xF4A3 #xE352) + (#xF4A2 #xE351) + (#xF4A1 #xE350) + (#xF4A0 #xE34F) + (#xF49F #xE34E) + (#xF49E #xE34D) + (#xF49D #xE34C) + (#xF49C #xE34B) + (#xF49B #xE34A) + (#xF49A #xE349) + (#xF499 #xE348) + (#xF498 #xE347) + (#xF497 #xE346) + (#xF496 #xE345) + (#xF495 #xE344) + (#xF494 #xE343) + (#xF493 #xE342) + (#xF492 #xE341) + (#xF491 #xE340) + (#xF490 #xE33F) + (#xF48F #xE33E) + (#xF48E #xE33D) + (#xF48D #xE33C) + (#xF48C #xE33B) + (#xF48B #xE33A) + (#xF48A #xE339) + (#xF489 #xE338) + (#xF488 #xE337) + (#xF487 #xE336) + (#xF486 #xE335) + (#xF485 #xE334) + (#xF484 #xE333) + (#xF483 #xE332) + (#xF482 #xE331) + (#xF481 #xE330) + (#xF480 #xE32F) + (#xF47E #xE32E) + (#xF47D #xE32D) + (#xF47C #xE32C) + (#xF47B #xE32B) + (#xF47A #xE32A) + (#xF479 #xE329) + (#xF478 #xE328) + (#xF477 #xE327) + (#xF476 #xE326) + (#xF475 #xE325) + (#xF474 #xE324) + (#xF473 #xE323) + (#xF472 #xE322) + (#xF471 #xE321) + (#xF470 #xE320) + (#xF46F #xE31F) + (#xF46E #xE31E) + (#xF46D #xE31D) + (#xF46C #xE31C) + (#xF46B #xE31B) + (#xF46A #xE31A) + (#xF469 #xE319) + (#xF468 #xE318) + (#xF467 #xE317) + (#xF466 #xE316) + (#xF465 #xE315) + (#xF464 #xE314) + (#xF463 #xE313) + (#xF462 #xE312) + (#xF461 #xE311) + (#xF460 #xE310) + (#xF45F #xE30F) + (#xF45E #xE30E) + (#xF45D #xE30D) + (#xF45C #xE30C) + (#xF45B #xE30B) + (#xF45A #xE30A) + (#xF459 #xE309) + (#xF458 #xE308) + (#xF457 #xE307) + (#xF456 #xE306) + (#xF455 #xE305) + (#xF454 #xE304) + (#xF453 #xE303) + (#xF452 #xE302) + (#xF451 #xE301) + (#xF450 #xE300) + (#xF44F #xE2FF) + (#xF44E #xE2FE) + (#xF44D #xE2FD) + (#xF44C #xE2FC) + (#xF44B #xE2FB) + (#xF44A #xE2FA) + (#xF449 #xE2F9) + (#xF448 #xE2F8) + (#xF447 #xE2F7) + (#xF446 #xE2F6) + (#xF445 #xE2F5) + (#xF444 #xE2F4) + (#xF443 #xE2F3) + (#xF442 #xE2F2) + (#xF441 #xE2F1) + (#xF440 #xE2F0) + (#xF3FC #xE2EF) + (#xF3FB #xE2EE) + (#xF3FA #xE2ED) + (#xF3F9 #xE2EC) + (#xF3F8 #xE2EB) + (#xF3F7 #xE2EA) + (#xF3F6 #xE2E9) + (#xF3F5 #xE2E8) + (#xF3F4 #xE2E7) + (#xF3F3 #xE2E6) + (#xF3F2 #xE2E5) + (#xF3F1 #xE2E4) + (#xF3F0 #xE2E3) + (#xF3EF #xE2E2) + (#xF3EE #xE2E1) + (#xF3ED #xE2E0) + (#xF3EC #xE2DF) + (#xF3EB #xE2DE) + (#xF3EA #xE2DD) + (#xF3E9 #xE2DC) + (#xF3E8 #xE2DB) + (#xF3E7 #xE2DA) + (#xF3E6 #xE2D9) + (#xF3E5 #xE2D8) + (#xF3E4 #xE2D7) + (#xF3E3 #xE2D6) + (#xF3E2 #xE2D5) + (#xF3E1 #xE2D4) + (#xF3E0 #xE2D3) + (#xF3DF #xE2D2) + (#xF3DE #xE2D1) + (#xF3DD #xE2D0) + (#xF3DC #xE2CF) + (#xF3DB #xE2CE) + (#xF3DA #xE2CD) + (#xF3D9 #xE2CC) + (#xF3D8 #xE2CB) + (#xF3D7 #xE2CA) + (#xF3D6 #xE2C9) + (#xF3D5 #xE2C8) + (#xF3D4 #xE2C7) + (#xF3D3 #xE2C6) + (#xF3D2 #xE2C5) + (#xF3D1 #xE2C4) + (#xF3D0 #xE2C3) + (#xF3CF #xE2C2) + (#xF3CE #xE2C1) + (#xF3CD #xE2C0) + (#xF3CC #xE2BF) + (#xF3CB #xE2BE) + (#xF3CA #xE2BD) + (#xF3C9 #xE2BC) + (#xF3C8 #xE2BB) + (#xF3C7 #xE2BA) + (#xF3C6 #xE2B9) + (#xF3C5 #xE2B8) + (#xF3C4 #xE2B7) + (#xF3C3 #xE2B6) + (#xF3C2 #xE2B5) + (#xF3C1 #xE2B4) + (#xF3C0 #xE2B3) + (#xF3BF #xE2B2) + (#xF3BE #xE2B1) + (#xF3BD #xE2B0) + (#xF3BC #xE2AF) + (#xF3BB #xE2AE) + (#xF3BA #xE2AD) + (#xF3B9 #xE2AC) + (#xF3B8 #xE2AB) + (#xF3B7 #xE2AA) + (#xF3B6 #xE2A9) + (#xF3B5 #xE2A8) + (#xF3B4 #xE2A7) + (#xF3B3 #xE2A6) + (#xF3B2 #xE2A5) + (#xF3B1 #xE2A4) + (#xF3B0 #xE2A3) + (#xF3AF #xE2A2) + (#xF3AE #xE2A1) + (#xF3AD #xE2A0) + (#xF3AC #xE29F) + (#xF3AB #xE29E) + (#xF3AA #xE29D) + (#xF3A9 #xE29C) + (#xF3A8 #xE29B) + (#xF3A7 #xE29A) + (#xF3A6 #xE299) + (#xF3A5 #xE298) + (#xF3A4 #xE297) + (#xF3A3 #xE296) + (#xF3A2 #xE295) + (#xF3A1 #xE294) + (#xF3A0 #xE293) + (#xF39F #xE292) + (#xF39E #xE291) + (#xF39D #xE290) + (#xF39C #xE28F) + (#xF39B #xE28E) + (#xF39A #xE28D) + (#xF399 #xE28C) + (#xF398 #xE28B) + (#xF397 #xE28A) + (#xF396 #xE289) + (#xF395 #xE288) + (#xF394 #xE287) + (#xF393 #xE286) + (#xF392 #xE285) + (#xF391 #xE284) + (#xF390 #xE283) + (#xF38F #xE282) + (#xF38E #xE281) + (#xF38D #xE280) + (#xF38C #xE27F) + (#xF38B #xE27E) + (#xF38A #xE27D) + (#xF389 #xE27C) + (#xF388 #xE27B) + (#xF387 #xE27A) + (#xF386 #xE279) + (#xF385 #xE278) + (#xF384 #xE277) + (#xF383 #xE276) + (#xF382 #xE275) + (#xF381 #xE274) + (#xF380 #xE273) + (#xF37E #xE272) + (#xF37D #xE271) + (#xF37C #xE270) + (#xF37B #xE26F) + (#xF37A #xE26E) + (#xF379 #xE26D) + (#xF378 #xE26C) + (#xF377 #xE26B) + (#xF376 #xE26A) + (#xF375 #xE269) + (#xF374 #xE268) + (#xF373 #xE267) + (#xF372 #xE266) + (#xF371 #xE265) + (#xF370 #xE264) + (#xF36F #xE263) + (#xF36E #xE262) + (#xF36D #xE261) + (#xF36C #xE260) + (#xF36B #xE25F) + (#xF36A #xE25E) + (#xF369 #xE25D) + (#xF368 #xE25C) + (#xF367 #xE25B) + (#xF366 #xE25A) + (#xF365 #xE259) + (#xF364 #xE258) + (#xF363 #xE257) + (#xF362 #xE256) + (#xF361 #xE255) + (#xF360 #xE254) + (#xF35F #xE253) + (#xF35E #xE252) + (#xF35D #xE251) + (#xF35C #xE250) + (#xF35B #xE24F) + (#xF35A #xE24E) + (#xF359 #xE24D) + (#xF358 #xE24C) + (#xF357 #xE24B) + (#xF356 #xE24A) + (#xF355 #xE249) + (#xF354 #xE248) + (#xF353 #xE247) + (#xF352 #xE246) + (#xF351 #xE245) + (#xF350 #xE244) + (#xF34F #xE243) + (#xF34E #xE242) + (#xF34D #xE241) + (#xF34C #xE240) + (#xF34B #xE23F) + (#xF34A #xE23E) + (#xF349 #xE23D) + (#xF348 #xE23C) + (#xF347 #xE23B) + (#xF346 #xE23A) + (#xF345 #xE239) + (#xF344 #xE238) + (#xF343 #xE237) + (#xF342 #xE236) + (#xF341 #xE235) + (#xF340 #xE234) + (#xF2FC #xE233) + (#xF2FB #xE232) + (#xF2FA #xE231) + (#xF2F9 #xE230) + (#xF2F8 #xE22F) + (#xF2F7 #xE22E) + (#xF2F6 #xE22D) + (#xF2F5 #xE22C) + (#xF2F4 #xE22B) + (#xF2F3 #xE22A) + (#xF2F2 #xE229) + (#xF2F1 #xE228) + (#xF2F0 #xE227) + (#xF2EF #xE226) + (#xF2EE #xE225) + (#xF2ED #xE224) + (#xF2EC #xE223) + (#xF2EB #xE222) + (#xF2EA #xE221) + (#xF2E9 #xE220) + (#xF2E8 #xE21F) + (#xF2E7 #xE21E) + (#xF2E6 #xE21D) + (#xF2E5 #xE21C) + (#xF2E4 #xE21B) + (#xF2E3 #xE21A) + (#xF2E2 #xE219) + (#xF2E1 #xE218) + (#xF2E0 #xE217) + (#xF2DF #xE216) + (#xF2DE #xE215) + (#xF2DD #xE214) + (#xF2DC #xE213) + (#xF2DB #xE212) + (#xF2DA #xE211) + (#xF2D9 #xE210) + (#xF2D8 #xE20F) + (#xF2D7 #xE20E) + (#xF2D6 #xE20D) + (#xF2D5 #xE20C) + (#xF2D4 #xE20B) + (#xF2D3 #xE20A) + (#xF2D2 #xE209) + (#xF2D1 #xE208) + (#xF2D0 #xE207) + (#xF2CF #xE206) + (#xF2CE #xE205) + (#xF2CD #xE204) + (#xF2CC #xE203) + (#xF2CB #xE202) + (#xF2CA #xE201) + (#xF2C9 #xE200) + (#xF2C8 #xE1FF) + (#xF2C7 #xE1FE) + (#xF2C6 #xE1FD) + (#xF2C5 #xE1FC) + (#xF2C4 #xE1FB) + (#xF2C3 #xE1FA) + (#xF2C2 #xE1F9) + (#xF2C1 #xE1F8) + (#xF2C0 #xE1F7) + (#xF2BF #xE1F6) + (#xF2BE #xE1F5) + (#xF2BD #xE1F4) + (#xF2BC #xE1F3) + (#xF2BB #xE1F2) + (#xF2BA #xE1F1) + (#xF2B9 #xE1F0) + (#xF2B8 #xE1EF) + (#xF2B7 #xE1EE) + (#xF2B6 #xE1ED) + (#xF2B5 #xE1EC) + (#xF2B4 #xE1EB) + (#xF2B3 #xE1EA) + (#xF2B2 #xE1E9) + (#xF2B1 #xE1E8) + (#xF2B0 #xE1E7) + (#xF2AF #xE1E6) + (#xF2AE #xE1E5) + (#xF2AD #xE1E4) + (#xF2AC #xE1E3) + (#xF2AB #xE1E2) + (#xF2AA #xE1E1) + (#xF2A9 #xE1E0) + (#xF2A8 #xE1DF) + (#xF2A7 #xE1DE) + (#xF2A6 #xE1DD) + (#xF2A5 #xE1DC) + (#xF2A4 #xE1DB) + (#xF2A3 #xE1DA) + (#xF2A2 #xE1D9) + (#xF2A1 #xE1D8) + (#xF2A0 #xE1D7) + (#xF29F #xE1D6) + (#xF29E #xE1D5) + (#xF29D #xE1D4) + (#xF29C #xE1D3) + (#xF29B #xE1D2) + (#xF29A #xE1D1) + (#xF299 #xE1D0) + (#xF298 #xE1CF) + (#xF297 #xE1CE) + (#xF296 #xE1CD) + (#xF295 #xE1CC) + (#xF294 #xE1CB) + (#xF293 #xE1CA) + (#xF292 #xE1C9) + (#xF291 #xE1C8) + (#xF290 #xE1C7) + (#xF28F #xE1C6) + (#xF28E #xE1C5) + (#xF28D #xE1C4) + (#xF28C #xE1C3) + (#xF28B #xE1C2) + (#xF28A #xE1C1) + (#xF289 #xE1C0) + (#xF288 #xE1BF) + (#xF287 #xE1BE) + (#xF286 #xE1BD) + (#xF285 #xE1BC) + (#xF284 #xE1BB) + (#xF283 #xE1BA) + (#xF282 #xE1B9) + (#xF281 #xE1B8) + (#xF280 #xE1B7) + (#xF27E #xE1B6) + (#xF27D #xE1B5) + (#xF27C #xE1B4) + (#xF27B #xE1B3) + (#xF27A #xE1B2) + (#xF279 #xE1B1) + (#xF278 #xE1B0) + (#xF277 #xE1AF) + (#xF276 #xE1AE) + (#xF275 #xE1AD) + (#xF274 #xE1AC) + (#xF273 #xE1AB) + (#xF272 #xE1AA) + (#xF271 #xE1A9) + (#xF270 #xE1A8) + (#xF26F #xE1A7) + (#xF26E #xE1A6) + (#xF26D #xE1A5) + (#xF26C #xE1A4) + (#xF26B #xE1A3) + (#xF26A #xE1A2) + (#xF269 #xE1A1) + (#xF268 #xE1A0) + (#xF267 #xE19F) + (#xF266 #xE19E) + (#xF265 #xE19D) + (#xF264 #xE19C) + (#xF263 #xE19B) + (#xF262 #xE19A) + (#xF261 #xE199) + (#xF260 #xE198) + (#xF25F #xE197) + (#xF25E #xE196) + (#xF25D #xE195) + (#xF25C #xE194) + (#xF25B #xE193) + (#xF25A #xE192) + (#xF259 #xE191) + (#xF258 #xE190) + (#xF257 #xE18F) + (#xF256 #xE18E) + (#xF255 #xE18D) + (#xF254 #xE18C) + (#xF253 #xE18B) + (#xF252 #xE18A) + (#xF251 #xE189) + (#xF250 #xE188) + (#xF24F #xE187) + (#xF24E #xE186) + (#xF24D #xE185) + (#xF24C #xE184) + (#xF24B #xE183) + (#xF24A #xE182) + (#xF249 #xE181) + (#xF248 #xE180) + (#xF247 #xE17F) + (#xF246 #xE17E) + (#xF245 #xE17D) + (#xF244 #xE17C) + (#xF243 #xE17B) + (#xF242 #xE17A) + (#xF241 #xE179) + (#xF240 #xE178) + (#xF1FC #xE177) + (#xF1FB #xE176) + (#xF1FA #xE175) + (#xF1F9 #xE174) + (#xF1F8 #xE173) + (#xF1F7 #xE172) + (#xF1F6 #xE171) + (#xF1F5 #xE170) + (#xF1F4 #xE16F) + (#xF1F3 #xE16E) + (#xF1F2 #xE16D) + (#xF1F1 #xE16C) + (#xF1F0 #xE16B) + (#xF1EF #xE16A) + (#xF1EE #xE169) + (#xF1ED #xE168) + (#xF1EC #xE167) + (#xF1EB #xE166) + (#xF1EA #xE165) + (#xF1E9 #xE164) + (#xF1E8 #xE163) + (#xF1E7 #xE162) + (#xF1E6 #xE161) + (#xF1E5 #xE160) + (#xF1E4 #xE15F) + (#xF1E3 #xE15E) + (#xF1E2 #xE15D) + (#xF1E1 #xE15C) + (#xF1E0 #xE15B) + (#xF1DF #xE15A) + (#xF1DE #xE159) + (#xF1DD #xE158) + (#xF1DC #xE157) + (#xF1DB #xE156) + (#xF1DA #xE155) + (#xF1D9 #xE154) + (#xF1D8 #xE153) + (#xF1D7 #xE152) + (#xF1D6 #xE151) + (#xF1D5 #xE150) + (#xF1D4 #xE14F) + (#xF1D3 #xE14E) + (#xF1D2 #xE14D) + (#xF1D1 #xE14C) + (#xF1D0 #xE14B) + (#xF1CF #xE14A) + (#xF1CE #xE149) + (#xF1CD #xE148) + (#xF1CC #xE147) + (#xF1CB #xE146) + (#xF1CA #xE145) + (#xF1C9 #xE144) + (#xF1C8 #xE143) + (#xF1C7 #xE142) + (#xF1C6 #xE141) + (#xF1C5 #xE140) + (#xF1C4 #xE13F) + (#xF1C3 #xE13E) + (#xF1C2 #xE13D) + (#xF1C1 #xE13C) + (#xF1C0 #xE13B) + (#xF1BF #xE13A) + (#xF1BE #xE139) + (#xF1BD #xE138) + (#xF1BC #xE137) + (#xF1BB #xE136) + (#xF1BA #xE135) + (#xF1B9 #xE134) + (#xF1B8 #xE133) + (#xF1B7 #xE132) + (#xF1B6 #xE131) + (#xF1B5 #xE130) + (#xF1B4 #xE12F) + (#xF1B3 #xE12E) + (#xF1B2 #xE12D) + (#xF1B1 #xE12C) + (#xF1B0 #xE12B) + (#xF1AF #xE12A) + (#xF1AE #xE129) + (#xF1AD #xE128) + (#xF1AC #xE127) + (#xF1AB #xE126) + (#xF1AA #xE125) + (#xF1A9 #xE124) + (#xF1A8 #xE123) + (#xF1A7 #xE122) + (#xF1A6 #xE121) + (#xF1A5 #xE120) + (#xF1A4 #xE11F) + (#xF1A3 #xE11E) + (#xF1A2 #xE11D) + (#xF1A1 #xE11C) + (#xF1A0 #xE11B) + (#xF19F #xE11A) + (#xF19E #xE119) + (#xF19D #xE118) + (#xF19C #xE117) + (#xF19B #xE116) + (#xF19A #xE115) + (#xF199 #xE114) + (#xF198 #xE113) + (#xF197 #xE112) + (#xF196 #xE111) + (#xF195 #xE110) + (#xF194 #xE10F) + (#xF193 #xE10E) + (#xF192 #xE10D) + (#xF191 #xE10C) + (#xF190 #xE10B) + (#xF18F #xE10A) + (#xF18E #xE109) + (#xF18D #xE108) + (#xF18C #xE107) + (#xF18B #xE106) + (#xF18A #xE105) + (#xF189 #xE104) + (#xF188 #xE103) + (#xF187 #xE102) + (#xF186 #xE101) + (#xF185 #xE100) + (#xF184 #xE0FF) + (#xF183 #xE0FE) + (#xF182 #xE0FD) + (#xF181 #xE0FC) + (#xF180 #xE0FB) + (#xF17E #xE0FA) + (#xF17D #xE0F9) + (#xF17C #xE0F8) + (#xF17B #xE0F7) + (#xF17A #xE0F6) + (#xF179 #xE0F5) + (#xF178 #xE0F4) + (#xF177 #xE0F3) + (#xF176 #xE0F2) + (#xF175 #xE0F1) + (#xF174 #xE0F0) + (#xF173 #xE0EF) + (#xF172 #xE0EE) + (#xF171 #xE0ED) + (#xF170 #xE0EC) + (#xF16F #xE0EB) + (#xF16E #xE0EA) + (#xF16D #xE0E9) + (#xF16C #xE0E8) + (#xF16B #xE0E7) + (#xF16A #xE0E6) + (#xF169 #xE0E5) + (#xF168 #xE0E4) + (#xF167 #xE0E3) + (#xF166 #xE0E2) + (#xF165 #xE0E1) + (#xF164 #xE0E0) + (#xF163 #xE0DF) + (#xF162 #xE0DE) + (#xF161 #xE0DD) + (#xF160 #xE0DC) + (#xF15F #xE0DB) + (#xF15E #xE0DA) + (#xF15D #xE0D9) + (#xF15C #xE0D8) + (#xF15B #xE0D7) + (#xF15A #xE0D6) + (#xF159 #xE0D5) + (#xF158 #xE0D4) + (#xF157 #xE0D3) + (#xF156 #xE0D2) + (#xF155 #xE0D1) + (#xF154 #xE0D0) + (#xF153 #xE0CF) + (#xF152 #xE0CE) + (#xF151 #xE0CD) + (#xF150 #xE0CC) + (#xF14F #xE0CB) + (#xF14E #xE0CA) + (#xF14D #xE0C9) + (#xF14C #xE0C8) + (#xF14B #xE0C7) + (#xF14A #xE0C6) + (#xF149 #xE0C5) + (#xF148 #xE0C4) + (#xF147 #xE0C3) + (#xF146 #xE0C2) + (#xF145 #xE0C1) + (#xF144 #xE0C0) + (#xF143 #xE0BF) + (#xF142 #xE0BE) + (#xF141 #xE0BD) + (#xF140 #xE0BC) + (#xF0FC #xE0BB) + (#xF0FB #xE0BA) + (#xF0FA #xE0B9) + (#xF0F9 #xE0B8) + (#xF0F8 #xE0B7) + (#xF0F7 #xE0B6) + (#xF0F6 #xE0B5) + (#xF0F5 #xE0B4) + (#xF0F4 #xE0B3) + (#xF0F3 #xE0B2) + (#xF0F2 #xE0B1) + (#xF0F1 #xE0B0) + (#xF0F0 #xE0AF) + (#xF0EF #xE0AE) + (#xF0EE #xE0AD) + (#xF0ED #xE0AC) + (#xF0EC #xE0AB) + (#xF0EB #xE0AA) + (#xF0EA #xE0A9) + (#xF0E9 #xE0A8) + (#xF0E8 #xE0A7) + (#xF0E7 #xE0A6) + (#xF0E6 #xE0A5) + (#xF0E5 #xE0A4) + (#xF0E4 #xE0A3) + (#xF0E3 #xE0A2) + (#xF0E2 #xE0A1) + (#xF0E1 #xE0A0) + (#xF0E0 #xE09F) + (#xF0DF #xE09E) + (#xF0DE #xE09D) + (#xF0DD #xE09C) + (#xF0DC #xE09B) + (#xF0DB #xE09A) + (#xF0DA #xE099) + (#xF0D9 #xE098) + (#xF0D8 #xE097) + (#xF0D7 #xE096) + (#xF0D6 #xE095) + (#xF0D5 #xE094) + (#xF0D4 #xE093) + (#xF0D3 #xE092) + (#xF0D2 #xE091) + (#xF0D1 #xE090) + (#xF0D0 #xE08F) + (#xF0CF #xE08E) + (#xF0CE #xE08D) + (#xF0CD #xE08C) + (#xF0CC #xE08B) + (#xF0CB #xE08A) + (#xF0CA #xE089) + (#xF0C9 #xE088) + (#xF0C8 #xE087) + (#xF0C7 #xE086) + (#xF0C6 #xE085) + (#xF0C5 #xE084) + (#xF0C4 #xE083) + (#xF0C3 #xE082) + (#xF0C2 #xE081) + (#xF0C1 #xE080) + (#xF0C0 #xE07F) + (#xF0BF #xE07E) + (#xF0BE #xE07D) + (#xF0BD #xE07C) + (#xF0BC #xE07B) + (#xF0BB #xE07A) + (#xF0BA #xE079) + (#xF0B9 #xE078) + (#xF0B8 #xE077) + (#xF0B7 #xE076) + (#xF0B6 #xE075) + (#xF0B5 #xE074) + (#xF0B4 #xE073) + (#xF0B3 #xE072) + (#xF0B2 #xE071) + (#xF0B1 #xE070) + (#xF0B0 #xE06F) + (#xF0AF #xE06E) + (#xF0AE #xE06D) + (#xF0AD #xE06C) + (#xF0AC #xE06B) + (#xF0AB #xE06A) + (#xF0AA #xE069) + (#xF0A9 #xE068) + (#xF0A8 #xE067) + (#xF0A7 #xE066) + (#xF0A6 #xE065) + (#xF0A5 #xE064) + (#xF0A4 #xE063) + (#xF0A3 #xE062) + (#xF0A2 #xE061) + (#xF0A1 #xE060) + (#xF0A0 #xE05F) + (#xF09F #xE05E) + (#xF09E #xE05D) + (#xF09D #xE05C) + (#xF09C #xE05B) + (#xF09B #xE05A) + (#xF09A #xE059) + (#xF099 #xE058) + (#xF098 #xE057) + (#xF097 #xE056) + (#xF096 #xE055) + (#xF095 #xE054) + (#xF094 #xE053) + (#xF093 #xE052) + (#xF092 #xE051) + (#xF091 #xE050) + (#xF090 #xE04F) + (#xF08F #xE04E) + (#xF08E #xE04D) + (#xF08D #xE04C) + (#xF08C #xE04B) + (#xF08B #xE04A) + (#xF08A #xE049) + (#xF089 #xE048) + (#xF088 #xE047) + (#xF087 #xE046) + (#xF086 #xE045) + (#xF085 #xE044) + (#xF084 #xE043) + (#xF083 #xE042) + (#xF082 #xE041) + (#xF081 #xE040) + (#xF080 #xE03F) + (#xF07E #xE03E) + (#xF07D #xE03D) + (#xF07C #xE03C) + (#xF07B #xE03B) + (#xF07A #xE03A) + (#xF079 #xE039) + (#xF078 #xE038) + (#xF077 #xE037) + (#xF076 #xE036) + (#xF075 #xE035) + (#xF074 #xE034) + (#xF073 #xE033) + (#xF072 #xE032) + (#xF071 #xE031) + (#xF070 #xE030) + (#xF06F #xE02F) + (#xF06E #xE02E) + (#xF06D #xE02D) + (#xF06C #xE02C) + (#xF06B #xE02B) + (#xF06A #xE02A) + (#xF069 #xE029) + (#xF068 #xE028) + (#xF067 #xE027) + (#xF066 #xE026) + (#xF065 #xE025) + (#xF064 #xE024) + (#xF063 #xE023) + (#xF062 #xE022) + (#xF061 #xE021) + (#xF060 #xE020) + (#xF05F #xE01F) + (#xF05E #xE01E) + (#xF05D #xE01D) + (#xF05C #xE01C) + (#xF05B #xE01B) + (#xF05A #xE01A) + (#xF059 #xE019) + (#xF058 #xE018) + (#xF057 #xE017) + (#xF056 #xE016) + (#xF055 #xE015) + (#xF054 #xE014) + (#xF053 #xE013) + (#xF052 #xE012) + (#xF051 #xE011) + (#xF050 #xE010) + (#xF04F #xE00F) + (#xF04E #xE00E) + (#xF04D #xE00D) + (#xF04C #xE00C) + (#xF04B #xE00B) + (#xF04A #xE00A) + (#xF049 #xE009) + (#xF048 #xE008) + (#xF047 #xE007) + (#xF046 #xE006) + (#xF045 #xE005) + (#xF044 #xE004) + (#xF043 #xE003) + (#xF042 #xE002) + (#xF041 #xE001) + (#xF040 #xE000) + (#xEEFC #xFF02) + (#xEEFB #xFF07) + (#xEEFA #xFFE4) + (#xEEF9 #xFFE2) + (#xEEF8 #x2179) + (#xEEF7 #x2178) + (#xEEF6 #x2177) + (#xEEF5 #x2176) + (#xEEF4 #x2175) + (#xEEF3 #x2174) + (#xEEF2 #x2173) + (#xEEF1 #x2172) + (#xEEF0 #x2171) + (#xEEEF #x2170) + (#xEEEC #x9ED1) + (#xEEEB #x9E19) + (#xEEEA #xFA2D) + (#xEEE9 #x9D6B) + (#xEEE8 #x9D70) + (#xEEE7 #x9C00) + (#xEEE6 #x9BBB) + (#xEEE5 #x9BB1) + (#xEEE4 #x9B8F) + (#xEEE3 #x9B72) + (#xEEE2 #x9B75) + (#xEEE1 #x9ADC) + (#xEEE0 #x9AD9) + (#xEEDF #x9A4E) + (#xEEDE #x999E) + (#xEEDD #xFA2C) + (#xEEDC #x9927) + (#xEEDB #xFA2B) + (#xEEDA #xFA2A) + (#xEED9 #x9865) + (#xEED8 #x9857) + (#xEED7 #x9755) + (#xEED6 #x9751) + (#xEED5 #x974F) + (#xEED4 #x974D) + (#xEED3 #x9743) + (#xEED2 #x973B) + (#xEED1 #x9733) + (#xEED0 #x96AF) + (#xEECF #x969D) + (#xEECE #xFA29) + (#xEECD #xF9DC) + (#xEECC #x9592) + (#xEECB #x9448) + (#xEECA #x9445) + (#xEEC9 #x9431) + (#xEEC8 #x93F8) + (#xEEC7 #x93DE) + (#xEEC6 #x93C6) + (#xEEC5 #x93A4) + (#xEEC4 #x9357) + (#xEEC3 #x9370) + (#xEEC2 #x9302) + (#xEEC1 #x931D) + (#xEEC0 #x92FF) + (#xEEBF #x931E) + (#xEEBE #xFA28) + (#xEEBD #x92FB) + (#xEEBC #x9321) + (#xEEBB #x9325) + (#xEEBA #x92D3) + (#xEEB9 #x92E0) + (#xEEB8 #x92D5) + (#xEEB7 #xFA27) + (#xEEB6 #x92D0) + (#xEEB5 #x92D9) + (#xEEB4 #x92D7) + (#xEEB3 #x92E7) + (#xEEB2 #x9278) + (#xEEB1 #x9277) + (#xEEB0 #x92A7) + (#xEEAF #x9267) + (#xEEAE #x9239) + (#xEEAD #x9251) + (#xEEAC #x9259) + (#xEEAB #x924E) + (#xEEAA #x923C) + (#xEEA9 #x9240) + (#xEEA8 #x923A) + (#xEEA7 #x920A) + (#xEEA6 #x9210) + (#xEEA5 #x9206) + (#xEEA4 #x91E5) + (#xEEA3 #x91E4) + (#xEEA2 #x91EE) + (#xEEA1 #x91ED) + (#xEEA0 #x91DE) + (#xEE9F #x91D7) + (#xEE9E #x91DA) + (#xEE9D #x9127) + (#xEE9C #x9115) + (#xEE9B #xFA26) + (#xEE9A #x90DE) + (#xEE99 #x9067) + (#xEE98 #xFA25) + (#xEE97 #xFA24) + (#xEE96 #x8ECF) + (#xEE95 #xFA23) + (#xEE94 #x8D76) + (#xEE93 #x8D12) + (#xEE92 #x8CF4) + (#xEE91 #x8CF0) + (#xEE90 #x8B7F) + (#xEE8F #x8B53) + (#xEE8E #x8AF6) + (#xEE8D #xFA22) + (#xEE8C #x8ADF) + (#xEE8B #x8ABE) + (#xEE8A #x8AA7) + (#xEE89 #x8A79) + (#xEE88 #x8A37) + (#xEE87 #x8A12) + (#xEE86 #x88F5) + (#xEE85 #x8807) + (#xEE84 #xFA21) + (#xEE83 #xFA20) + (#xEE82 #x85B0) + (#xEE81 #xFA1F) + (#xEE80 #x856B) + (#xEE7E #x8559) + (#xEE7D #x8553) + (#xEE7C #x84B4) + (#xEE7B #x8448) + (#xEE7A #x83F6) + (#xEE79 #x83C7) + (#xEE78 #x837F) + (#xEE77 #x8362) + (#xEE76 #x8301) + (#xEE75 #xFA1E) + (#xEE74 #x7FA1) + (#xEE73 #x7F47) + (#xEE72 #x7E52) + (#xEE71 #x7DD6) + (#xEE70 #x7DA0) + (#xEE6F #x7DB7) + (#xEE6E #x7D5C) + (#xEE6D #x7D48) + (#xEE6C #xFA1D) + (#xEE6B #x7B9E) + (#xEE6A #x7AEB) + (#xEE69 #xFA1C) + (#xEE68 #x7AE7) + (#xEE67 #x7AD1) + (#xEE66 #x799B) + (#xEE65 #xFA1B) + (#xEE64 #x7994) + (#xEE63 #xFA1A) + (#xEE62 #xFA19) + (#xEE61 #xFA18) + (#xEE60 #x7930) + (#xEE5F #x787A) + (#xEE5E #x7864) + (#xEE5D #x784E) + (#xEE5C #x7821) + (#xEE5B #x52AF) + (#xEE5A #x7746) + (#xEE59 #xFA17) + (#xEE58 #x76A6) + (#xEE57 #x769B) + (#xEE56 #x769E) + (#xEE55 #x769C) + (#xEE54 #x7682) + (#xEE53 #x756F) + (#xEE52 #x7501) + (#xEE51 #x749F) + (#xEE50 #x7489) + (#xEE4F #x7462) + (#xEE4E #x742E) + (#xEE4D #x7429) + (#xEE4C #x742A) + (#xEE4B #x7426) + (#xEE4A #x73F5) + (#xEE49 #x7407) + (#xEE48 #x73D2) + (#xEE47 #x73E3) + (#xEE46 #x73D6) + (#xEE45 #x73C9) + (#xEE44 #x73BD) + (#xEE43 #x7377) + (#xEE42 #xFA16) + (#xEE41 #x7324) + (#xEE40 #x72BE) + (#xEDFC #x72B1) + (#xEDFB #x71FE) + (#xEDFA #x71C1) + (#xEDF9 #xFA15) + (#xEDF8 #x7147) + (#xEDF7 #x7146) + (#xEDF6 #x715C) + (#xEDF5 #x7104) + (#xEDF4 #x710F) + (#xEDF3 #x70AB) + (#xEDF2 #x7085) + (#xEDF1 #x7028) + (#xEDF0 #x7007) + (#xEDEF #x7005) + (#xEDEE #x6FF5) + (#xEDED #x6FB5) + (#xEDEC #x6F88) + (#xEDEB #x6EBF) + (#xEDEA #x6E3C) + (#xEDE9 #x6E27) + (#xEDE8 #x6E5C) + (#xEDE7 #x6E39) + (#xEDE6 #x6DFC) + (#xEDE5 #x6DF2) + (#xEDE4 #x6DF8) + (#xEDE3 #x6DCF) + (#xEDE2 #x6DAC) + (#xEDE1 #x6D96) + (#xEDE0 #x6D6F) + (#xEDDF #x6D87) + (#xEDDE #x6D04) + (#xEDDD #x6CDA) + (#xEDDC #x6C6F) + (#xEDDB #x6C86) + (#xEDDA #x6C5C) + (#xEDD9 #x6C3F) + (#xEDD8 #x6BD6) + (#xEDD7 #x6AE4) + (#xEDD6 #x6AE2) + (#xEDD5 #x6A7E) + (#xEDD4 #x6A73) + (#xEDD3 #x6A46) + (#xEDD2 #x6A6B) + (#xEDD1 #x6A30) + (#xEDD0 #x69E2) + (#xEDCF #x6998) + (#xEDCE #xFA14) + (#xEDCD #x6968) + (#xEDCC #xFA13) + (#xEDCB #x68CF) + (#xEDCA #x6844) + (#xEDC9 #x6801) + (#xEDC8 #x67C0) + (#xEDC7 #x6852) + (#xEDC6 #x67BB) + (#xEDC5 #x6766) + (#xEDC4 #xF929) + (#xEDC3 #x670E) + (#xEDC2 #x66FA) + (#xEDC1 #x66BF) + (#xEDC0 #x66B2) + (#xEDBF #x66A0) + (#xEDBE #x6699) + (#xEDBD #x6673) + (#xEDBC #xFA12) + (#xEDBB #x6659) + (#xEDBA #x6657) + (#xEDB9 #x6665) + (#xEDB8 #x6624) + (#xEDB7 #x661E) + (#xEDB6 #x662E) + (#xEDB5 #x6609) + (#xEDB4 #x663B) + (#xEDB3 #x6615) + (#xEDB2 #x6600) + (#xEDB1 #x654E) + (#xEDB0 #x64CE) + (#xEDAF #x649D) + (#xEDAE #x6460) + (#xEDAD #x63F5) + (#xEDAC #x62A6) + (#xEDAB #x6213) + (#xEDAA #x6198) + (#xEDA9 #x6130) + (#xEDA8 #x6137) + (#xEDA7 #x6111) + (#xEDA6 #x60F2) + (#xEDA5 #x6120) + (#xEDA4 #x60D5) + (#xEDA3 #x60DE) + (#xEDA2 #x608A) + (#xEDA1 #x6085) + (#xEDA0 #x605D) + (#xED9F #x5FDE) + (#xED9E #x5FB7) + (#xED9D #x5F67) + (#xED9C #x5F34) + (#xED9B #x5F21) + (#xED9A #x5DD0) + (#xED99 #x5DB9) + (#xED98 #x5DB8) + (#xED97 #x5D6D) + (#xED96 #x5D42) + (#xED95 #xFA11) + (#xED94 #x5D53) + (#xED93 #x5D27) + (#xED92 #x5CF5) + (#xED91 #x5CBA) + (#xED90 #x5CA6) + (#xED8F #x5C1E) + (#xED8E #x5BEC) + (#xED8D #x5BD8) + (#xED8C #x752F) + (#xED8B #x5BC0) + (#xED8A #x5B56) + (#xED89 #x59BA) + (#xED88 #x59A4) + (#xED87 #x5963) + (#xED86 #x595D) + (#xED85 #x595B) + (#xED84 #x5953) + (#xED83 #x590B) + (#xED82 #x58B2) + (#xED81 #x589E) + (#xED80 #xFA10) + (#xED7E #xFA0F) + (#xED7D #x57C7) + (#xED7C #x57C8) + (#xED7B #x57AC) + (#xED7A #x5765) + (#xED79 #x5759) + (#xED78 #x5586) + (#xED77 #x54FF) + (#xED76 #x54A9) + (#xED75 #x548A) + (#xED74 #x549C) + (#xED73 #xFA0E) + (#xED72 #x53DD) + (#xED71 #x53B2) + (#xED70 #x5393) + (#xED6F #x5372) + (#xED6E #x5324) + (#xED6D #x5307) + (#xED6C #x5300) + (#xED6B #x52DB) + (#xED6A #x52C0) + (#xED69 #x52A6) + (#xED68 #x529C) + (#xED67 #x5215) + (#xED66 #x51EC) + (#xED65 #x51BE) + (#xED64 #x519D) + (#xED63 #x5164) + (#xED62 #x514A) + (#xED61 #x50D8) + (#xED60 #x50F4) + (#xED5F #x5094) + (#xED5E #x5042) + (#xED5D #x5070) + (#xED5C #x5046) + (#xED5B #x501E) + (#xED5A #x4FFF) + (#xED59 #x5022) + (#xED58 #x5040) + (#xED57 #x4FCD) + (#xED56 #x4F94) + (#xED55 #x4F9A) + (#xED54 #x4F8A) + (#xED53 #x4F92) + (#xED52 #x4F56) + (#xED51 #x4F39) + (#xED50 #x4F03) + (#xED4F #x4F00) + (#xED4E #x4EFC) + (#xED4D #x4EE1) + (#xED4C #x4E28) + (#xED4B #x5F45) + (#xED4A #x66FB) + (#xED49 #x92F9) + (#xED48 #x68C8) + (#xED47 #x6631) + (#xED46 #x70BB) + (#xED45 #x4FC9) + (#xED44 #x84DC) + (#xED43 #x9288) + (#xED42 #x9348) + (#xED41 #x891C) + (#xED40 #x7E8A) + (#xEA9E #x9FA0) + (#xEA40 #x9D5D) + (#xE99E #x9AF7) + (#xE940 #x9871) + (#xE89E #x965E) + (#xE840 #x9319) + (#xE79E #x8FF8) + (#xE740 #x8E47) + (#xE69E #x8B6B) + (#xE640 #x8966) + (#xE59E #x8759) + (#xE540 #x8541) + (#xE49E #x82D9) + (#xE440 #x968B) + (#xE39E #x7F3A) + (#xE340 #x7D02) + (#xE29E #x7B50) + (#xE240 #x78E7) + (#xE19E #x7670) + (#xE140 #x74E0) + (#xE09E #x71FC) + (#xE040 #x6F3E) + (#x9F9E #x6CBE) + (#x9F40 #x6A97) + (#x9E9E #x68CD) + (#x9E40 #x66C4) + (#x9D9E #x64BC) + (#x9D40 #x621E) + (#x9C9E #x609A) + (#x9C40 #x5ED6) + (#x9B9E #x5C53) + (#x9B40 #x5978) + (#x9A9E #x5709) + (#x9A40 #x54AB) + (#x999E #x8FA8) + (#x9940 #x50C9) + (#x9840 #x84EE) + (#x979E #x7483) + (#x9740 #x8AED) + (#x969E #x6E80) + (#x9640 #x6CD5) + (#x959E #x670D) + (#x9540 #x9F3B) + (#x949E #x9EA6) + (#x9440 #x5982) + (#x939E #x5230) + (#x9340 #x90B8) + (#x929E #x5BF5) + (#x9240 #x53E9) + (#x919E #x618E) + (#x9140 #x7E4A) + (#x909E #x88FE) + (#x9040 #x62ED) + (#x8F9E #x511F) + (#x8F40 #x5B97) + (#x8E9E #x6642) + (#x8E40 #x5BDF) + (#x8D9E #x8FBC) + (#x8D40 #x540E) + (#x8C9E #x6372) + (#x8C40 #x6398) + (#x8B9E #x4EAC) + (#x8B40 #x6A5F) + (#x8A9E #x8431) + (#x8A40 #x9B41) + (#x899E #x5FDC) + (#x8940 #x9662) + (#x879C #x222A) + (#x879B #x2229) + (#x879A #x2235) + (#x8799 #x22BF) + (#x8798 #x221F) + (#x8797 #x2220) + (#x8796 #x22A5) + (#x8795 #x221A) + (#x8794 #x2211) + (#x8793 #x222E) + (#x8792 #x222B) + (#x8791 #x2261) + (#x8790 #x2252) + (#x878F #x337C) + (#x878E #x337D) + (#x878D #x337E) + (#x878C #x3239) + (#x878B #x3232) + (#x878A #x3231) + (#x8789 #x32A8) + (#x8788 #x32A7) + (#x8787 #x32A6) + (#x8786 #x32A5) + (#x8785 #x32A4) + (#x8784 #x2121) + (#x8783 #x33CD) + (#x8782 #x2116) + (#x8781 #x301F) + (#x8780 #x301D) + (#x877E #x337B) + (#x8775 #x33A1) + (#x8774 #x33C4) + (#x8773 #x338F) + (#x8772 #x338E) + (#x8771 #x339E) + (#x8770 #x339D) + (#x876F #x339C) + (#x876E #x333B) + (#x876D #x334A) + (#x876C #x332B) + (#x876B #x3323) + (#x876A #x3326) + (#x8769 #x330D) + (#x8768 #x3357) + (#x8767 #x3351) + (#x8766 #x3336) + (#x8765 #x3303) + (#x8764 #x3327) + (#x8763 #x3318) + (#x8762 #x334D) + (#x8761 #x3322) + (#x8760 #x3314) + (#x875F #x3349) + (#x875D #x2169) + (#x875C #x2168) + (#x875B #x2167) + (#x875A #x2166) + (#x8759 #x2165) + (#x8758 #x2164) + (#x8757 #x2163) + (#x8756 #x2162) + (#x8755 #x2161) + (#x8754 #x2160) + (#x8753 #x2473) + (#x8752 #x2472) + (#x8751 #x2471) + (#x8750 #x2470) + (#x874F #x246F) + (#x874E #x246E) + (#x874D #x246D) + (#x874C #x246C) + (#x874B #x246B) + (#x874A #x246A) + (#x8749 #x2469) + (#x8748 #x2468) + (#x8747 #x2467) + (#x8746 #x2466) + (#x8745 #x2465) + (#x8744 #x2464) + (#x8743 #x2463) + (#x8742 #x2462) + (#x8741 #x2461) + (#x8740 #x2460) + (#x8440 #x410) + (#x8340 #x30A1) + (#x819E #x25C7) + (#x8140 #x3000) + )) + (eucjp-only '((#xFEFE #xE3AB) + (#xFEFD #xE3AA) + (#xFEFC #xE3A9) + (#xFEFB #xE3A8) + (#xFEFA #xE3A7) + (#xFEF9 #xE3A6) + (#xFEF8 #xE3A5) + (#xFEF7 #xE3A4) + (#xFEF6 #xE3A3) + (#xFEF5 #xE3A2) + (#xFEF4 #xE3A1) + (#xFEF3 #xE3A0) + (#xFEF2 #xE39F) + (#xFEF1 #xE39E) + (#xFEF0 #xE39D) + (#xFEEF #xE39C) + (#xFEEE #xE39B) + (#xFEED #xE39A) + (#xFEEC #xE399) + (#xFEEB #xE398) + (#xFEEA #xE397) + (#xFEE9 #xE396) + (#xFEE8 #xE395) + (#xFEE7 #xE394) + (#xFEE6 #xE393) + (#xFEE5 #xE392) + (#xFEE4 #xE391) + (#xFEE3 #xE390) + (#xFEE2 #xE38F) + (#xFEE1 #xE38E) + (#xFEE0 #xE38D) + (#xFEDF #xE38C) + (#xFEDE #xE38B) + (#xFEDD #xE38A) + (#xFEDC #xE389) + (#xFEDB #xE388) + (#xFEDA #xE387) + (#xFED9 #xE386) + (#xFED8 #xE385) + (#xFED7 #xE384) + (#xFED6 #xE383) + (#xFED5 #xE382) + (#xFED4 #xE381) + (#xFED3 #xE380) + (#xFED2 #xE37F) + (#xFED1 #xE37E) + (#xFED0 #xE37D) + (#xFECF #xE37C) + (#xFECE #xE37B) + (#xFECD #xE37A) + (#xFECC #xE379) + (#xFECB #xE378) + (#xFECA #xE377) + (#xFEC9 #xE376) + (#xFEC8 #xE375) + (#xFEC7 #xE374) + (#xFEC6 #xE373) + (#xFEC5 #xE372) + (#xFEC4 #xE371) + (#xFEC3 #xE370) + (#xFEC2 #xE36F) + (#xFEC1 #xE36E) + (#xFEC0 #xE36D) + (#xFEBF #xE36C) + (#xFEBE #xE36B) + (#xFEBD #xE36A) + (#xFEBC #xE369) + (#xFEBB #xE368) + (#xFEBA #xE367) + (#xFEB9 #xE366) + (#xFEB8 #xE365) + (#xFEB7 #xE364) + (#xFEB6 #xE363) + (#xFEB5 #xE362) + (#xFEB4 #xE361) + (#xFEB3 #xE360) + (#xFEB2 #xE35F) + (#xFEB1 #xE35E) + (#xFEB0 #xE35D) + (#xFEAF #xE35C) + (#xFEAE #xE35B) + (#xFEAD #xE35A) + (#xFEAC #xE359) + (#xFEAB #xE358) + (#xFEAA #xE357) + (#xFEA9 #xE356) + (#xFEA8 #xE355) + (#xFEA7 #xE354) + (#xFEA6 #xE353) + (#xFEA5 #xE352) + (#xFEA4 #xE351) + (#xFEA3 #xE350) + (#xFEA2 #xE34F) + (#xFEA1 #xE34E) + (#xFDFE #xE34D) + (#xFDFD #xE34C) + (#xFDFC #xE34B) + (#xFDFB #xE34A) + (#xFDFA #xE349) + (#xFDF9 #xE348) + (#xFDF8 #xE347) + (#xFDF7 #xE346) + (#xFDF6 #xE345) + (#xFDF5 #xE344) + (#xFDF4 #xE343) + (#xFDF3 #xE342) + (#xFDF2 #xE341) + (#xFDF1 #xE340) + (#xFDF0 #xE33F) + (#xFDEF #xE33E) + (#xFDEE #xE33D) + (#xFDED #xE33C) + (#xFDEC #xE33B) + (#xFDEB #xE33A) + (#xFDEA #xE339) + (#xFDE9 #xE338) + (#xFDE8 #xE337) + (#xFDE7 #xE336) + (#xFDE6 #xE335) + (#xFDE5 #xE334) + (#xFDE4 #xE333) + (#xFDE3 #xE332) + (#xFDE2 #xE331) + (#xFDE1 #xE330) + (#xFDE0 #xE32F) + (#xFDDF #xE32E) + (#xFDDE #xE32D) + (#xFDDD #xE32C) + (#xFDDC #xE32B) + (#xFDDB #xE32A) + (#xFDDA #xE329) + (#xFDD9 #xE328) + (#xFDD8 #xE327) + (#xFDD7 #xE326) + (#xFDD6 #xE325) + (#xFDD5 #xE324) + (#xFDD4 #xE323) + (#xFDD3 #xE322) + (#xFDD2 #xE321) + (#xFDD1 #xE320) + (#xFDD0 #xE31F) + (#xFDCF #xE31E) + (#xFDCE #xE31D) + (#xFDCD #xE31C) + (#xFDCC #xE31B) + (#xFDCB #xE31A) + (#xFDCA #xE319) + (#xFDC9 #xE318) + (#xFDC8 #xE317) + (#xFDC7 #xE316) + (#xFDC6 #xE315) + (#xFDC5 #xE314) + (#xFDC4 #xE313) + (#xFDC3 #xE312) + (#xFDC2 #xE311) + (#xFDC1 #xE310) + (#xFDC0 #xE30F) + (#xFDBF #xE30E) + (#xFDBE #xE30D) + (#xFDBD #xE30C) + (#xFDBC #xE30B) + (#xFDBB #xE30A) + (#xFDBA #xE309) + (#xFDB9 #xE308) + (#xFDB8 #xE307) + (#xFDB7 #xE306) + (#xFDB6 #xE305) + (#xFDB5 #xE304) + (#xFDB4 #xE303) + (#xFDB3 #xE302) + (#xFDB2 #xE301) + (#xFDB1 #xE300) + (#xFDB0 #xE2FF) + (#xFDAF #xE2FE) + (#xFDAE #xE2FD) + (#xFDAD #xE2FC) + (#xFDAC #xE2FB) + (#xFDAB #xE2FA) + (#xFDAA #xE2F9) + (#xFDA9 #xE2F8) + (#xFDA8 #xE2F7) + (#xFDA7 #xE2F6) + (#xFDA6 #xE2F5) + (#xFDA5 #xE2F4) + (#xFDA4 #xE2F3) + (#xFDA3 #xE2F2) + (#xFDA2 #xE2F1) + (#xFDA1 #xE2F0) + (#xFCFE #xE2EF) + (#xFCFD #xE2EE) + (#xFCFC #xE2ED) + (#xFCFB #xE2EC) + (#xFCFA #xE2EB) + (#xFCF9 #xE2EA) + (#xFCF8 #xE2E9) + (#xFCF7 #xE2E8) + (#xFCF6 #xE2E7) + (#xFCF5 #xE2E6) + (#xFCF4 #xE2E5) + (#xFCF3 #xE2E4) + (#xFCF2 #xE2E3) + (#xFCF1 #xE2E2) + (#xFCF0 #xE2E1) + (#xFCEF #xE2E0) + (#xFCEE #xE2DF) + (#xFCED #xE2DE) + (#xFCEC #xE2DD) + (#xFCEB #xE2DC) + (#xFCEA #xE2DB) + (#xFCE9 #xE2DA) + (#xFCE8 #xE2D9) + (#xFCE7 #xE2D8) + (#xFCE6 #xE2D7) + (#xFCE5 #xE2D6) + (#xFCE4 #xE2D5) + (#xFCE3 #xE2D4) + (#xFCE2 #xE2D3) + (#xFCE1 #xE2D2) + (#xFCE0 #xE2D1) + (#xFCDF #xE2D0) + (#xFCDE #xE2CF) + (#xFCDD #xE2CE) + (#xFCDC #xE2CD) + (#xFCDB #xE2CC) + (#xFCDA #xE2CB) + (#xFCD9 #xE2CA) + (#xFCD8 #xE2C9) + (#xFCD7 #xE2C8) + (#xFCD6 #xE2C7) + (#xFCD5 #xE2C6) + (#xFCD4 #xE2C5) + (#xFCD3 #xE2C4) + (#xFCD2 #xE2C3) + (#xFCD1 #xE2C2) + (#xFCD0 #xE2C1) + (#xFCCF #xE2C0) + (#xFCCE #xE2BF) + (#xFCCD #xE2BE) + (#xFCCC #xE2BD) + (#xFCCB #xE2BC) + (#xFCCA #xE2BB) + (#xFCC9 #xE2BA) + (#xFCC8 #xE2B9) + (#xFCC7 #xE2B8) + (#xFCC6 #xE2B7) + (#xFCC5 #xE2B6) + (#xFCC4 #xE2B5) + (#xFCC3 #xE2B4) + (#xFCC2 #xE2B3) + (#xFCC1 #xE2B2) + (#xFCC0 #xE2B1) + (#xFCBF #xE2B0) + (#xFCBE #xE2AF) + (#xFCBD #xE2AE) + (#xFCBC #xE2AD) + (#xFCBB #xE2AC) + (#xFCBA #xE2AB) + (#xFCB9 #xE2AA) + (#xFCB8 #xE2A9) + (#xFCB7 #xE2A8) + (#xFCB6 #xE2A7) + (#xFCB5 #xE2A6) + (#xFCB4 #xE2A5) + (#xFCB3 #xE2A4) + (#xFCB2 #xE2A3) + (#xFCB1 #xE2A2) + (#xFCB0 #xE2A1) + (#xFCAF #xE2A0) + (#xFCAE #xE29F) + (#xFCAD #xE29E) + (#xFCAC #xE29D) + (#xFCAB #xE29C) + (#xFCAA #xE29B) + (#xFCA9 #xE29A) + (#xFCA8 #xE299) + (#xFCA7 #xE298) + (#xFCA6 #xE297) + (#xFCA5 #xE296) + (#xFCA4 #xE295) + (#xFCA3 #xE294) + (#xFCA2 #xE293) + (#xFCA1 #xE292) + (#xFBFE #xE291) + (#xFBFD #xE290) + (#xFBFC #xE28F) + (#xFBFB #xE28E) + (#xFBFA #xE28D) + (#xFBF9 #xE28C) + (#xFBF8 #xE28B) + (#xFBF7 #xE28A) + (#xFBF6 #xE289) + (#xFBF5 #xE288) + (#xFBF4 #xE287) + (#xFBF3 #xE286) + (#xFBF2 #xE285) + (#xFBF1 #xE284) + (#xFBF0 #xE283) + (#xFBEF #xE282) + (#xFBEE #xE281) + (#xFBED #xE280) + (#xFBEC #xE27F) + (#xFBEB #xE27E) + (#xFBEA #xE27D) + (#xFBE9 #xE27C) + (#xFBE8 #xE27B) + (#xFBE7 #xE27A) + (#xFBE6 #xE279) + (#xFBE5 #xE278) + (#xFBE4 #xE277) + (#xFBE3 #xE276) + (#xFBE2 #xE275) + (#xFBE1 #xE274) + (#xFBE0 #xE273) + (#xFBDF #xE272) + (#xFBDE #xE271) + (#xFBDD #xE270) + (#xFBDC #xE26F) + (#xFBDB #xE26E) + (#xFBDA #xE26D) + (#xFBD9 #xE26C) + (#xFBD8 #xE26B) + (#xFBD7 #xE26A) + (#xFBD6 #xE269) + (#xFBD5 #xE268) + (#xFBD4 #xE267) + (#xFBD3 #xE266) + (#xFBD2 #xE265) + (#xFBD1 #xE264) + (#xFBD0 #xE263) + (#xFBCF #xE262) + (#xFBCE #xE261) + (#xFBCD #xE260) + (#xFBCC #xE25F) + (#xFBCB #xE25E) + (#xFBCA #xE25D) + (#xFBC9 #xE25C) + (#xFBC8 #xE25B) + (#xFBC7 #xE25A) + (#xFBC6 #xE259) + (#xFBC5 #xE258) + (#xFBC4 #xE257) + (#xFBC3 #xE256) + (#xFBC2 #xE255) + (#xFBC1 #xE254) + (#xFBC0 #xE253) + (#xFBBF #xE252) + (#xFBBE #xE251) + (#xFBBD #xE250) + (#xFBBC #xE24F) + (#xFBBB #xE24E) + (#xFBBA #xE24D) + (#xFBB9 #xE24C) + (#xFBB8 #xE24B) + (#xFBB7 #xE24A) + (#xFBB6 #xE249) + (#xFBB5 #xE248) + (#xFBB4 #xE247) + (#xFBB3 #xE246) + (#xFBB2 #xE245) + (#xFBB1 #xE244) + (#xFBB0 #xE243) + (#xFBAF #xE242) + (#xFBAE #xE241) + (#xFBAD #xE240) + (#xFBAC #xE23F) + (#xFBAB #xE23E) + (#xFBAA #xE23D) + (#xFBA9 #xE23C) + (#xFBA8 #xE23B) + (#xFBA7 #xE23A) + (#xFBA6 #xE239) + (#xFBA5 #xE238) + (#xFBA4 #xE237) + (#xFBA3 #xE236) + (#xFBA2 #xE235) + (#xFBA1 #xE234) + (#xFAFE #xE233) + (#xFAFD #xE232) + (#xFAFC #xE231) + (#xFAFB #xE230) + (#xFAFA #xE22F) + (#xFAF9 #xE22E) + (#xFAF8 #xE22D) + (#xFAF7 #xE22C) + (#xFAF6 #xE22B) + (#xFAF5 #xE22A) + (#xFAF4 #xE229) + (#xFAF3 #xE228) + (#xFAF2 #xE227) + (#xFAF1 #xE226) + (#xFAF0 #xE225) + (#xFAEF #xE224) + (#xFAEE #xE223) + (#xFAED #xE222) + (#xFAEC #xE221) + (#xFAEB #xE220) + (#xFAEA #xE21F) + (#xFAE9 #xE21E) + (#xFAE8 #xE21D) + (#xFAE7 #xE21C) + (#xFAE6 #xE21B) + (#xFAE5 #xE21A) + (#xFAE4 #xE219) + (#xFAE3 #xE218) + (#xFAE2 #xE217) + (#xFAE1 #xE216) + (#xFAE0 #xE215) + (#xFADF #xE214) + (#xFADE #xE213) + (#xFADD #xE212) + (#xFADC #xE211) + (#xFADB #xE210) + (#xFADA #xE20F) + (#xFAD9 #xE20E) + (#xFAD8 #xE20D) + (#xFAD7 #xE20C) + (#xFAD6 #xE20B) + (#xFAD5 #xE20A) + (#xFAD4 #xE209) + (#xFAD3 #xE208) + (#xFAD2 #xE207) + (#xFAD1 #xE206) + (#xFAD0 #xE205) + (#xFACF #xE204) + (#xFACE #xE203) + (#xFACD #xE202) + (#xFACC #xE201) + (#xFACB #xE200) + (#xFACA #xE1FF) + (#xFAC9 #xE1FE) + (#xFAC8 #xE1FD) + (#xFAC7 #xE1FC) + (#xFAC6 #xE1FB) + (#xFAC5 #xE1FA) + (#xFAC4 #xE1F9) + (#xFAC3 #xE1F8) + (#xFAC2 #xE1F7) + (#xFAC1 #xE1F6) + (#xFAC0 #xE1F5) + (#xFABF #xE1F4) + (#xFABE #xE1F3) + (#xFABD #xE1F2) + (#xFABC #xE1F1) + (#xFABB #xE1F0) + (#xFABA #xE1EF) + (#xFAB9 #xE1EE) + (#xFAB8 #xE1ED) + (#xFAB7 #xE1EC) + (#xFAB6 #xE1EB) + (#xFAB5 #xE1EA) + (#xFAB4 #xE1E9) + (#xFAB3 #xE1E8) + (#xFAB2 #xE1E7) + (#xFAB1 #xE1E6) + (#xFAB0 #xE1E5) + (#xFAAF #xE1E4) + (#xFAAE #xE1E3) + (#xFAAD #xE1E2) + (#xFAAC #xE1E1) + (#xFAAB #xE1E0) + (#xFAAA #xE1DF) + (#xFAA9 #xE1DE) + (#xFAA8 #xE1DD) + (#xFAA7 #xE1DC) + (#xFAA6 #xE1DB) + (#xFAA5 #xE1DA) + (#xFAA4 #xE1D9) + (#xFAA3 #xE1D8) + (#xFAA2 #xE1D7) + (#xFAA1 #xE1D6) + (#xF9FE #xE1D5) + (#xF9FD #xE1D4) + (#xF9FC #xE1D3) + (#xF9FB #xE1D2) + (#xF9FA #xE1D1) + (#xF9F9 #xE1D0) + (#xF9F8 #xE1CF) + (#xF9F7 #xE1CE) + (#xF9F6 #xE1CD) + (#xF9F5 #xE1CC) + (#xF9F4 #xE1CB) + (#xF9F3 #xE1CA) + (#xF9F2 #xE1C9) + (#xF9F1 #xE1C8) + (#xF9F0 #xE1C7) + (#xF9EF #xE1C6) + (#xF9EE #xE1C5) + (#xF9ED #xE1C4) + (#xF9EC #xE1C3) + (#xF9EB #xE1C2) + (#xF9EA #xE1C1) + (#xF9E9 #xE1C0) + (#xF9E8 #xE1BF) + (#xF9E7 #xE1BE) + (#xF9E6 #xE1BD) + (#xF9E5 #xE1BC) + (#xF9E4 #xE1BB) + (#xF9E3 #xE1BA) + (#xF9E2 #xE1B9) + (#xF9E1 #xE1B8) + (#xF9E0 #xE1B7) + (#xF9DF #xE1B6) + (#xF9DE #xE1B5) + (#xF9DD #xE1B4) + (#xF9DC #xE1B3) + (#xF9DB #xE1B2) + (#xF9DA #xE1B1) + (#xF9D9 #xE1B0) + (#xF9D8 #xE1AF) + (#xF9D7 #xE1AE) + (#xF9D6 #xE1AD) + (#xF9D5 #xE1AC) + (#xF9D4 #xE1AB) + (#xF9D3 #xE1AA) + (#xF9D2 #xE1A9) + (#xF9D1 #xE1A8) + (#xF9D0 #xE1A7) + (#xF9CF #xE1A6) + (#xF9CE #xE1A5) + (#xF9CD #xE1A4) + (#xF9CC #xE1A3) + (#xF9CB #xE1A2) + (#xF9CA #xE1A1) + (#xF9C9 #xE1A0) + (#xF9C8 #xE19F) + (#xF9C7 #xE19E) + (#xF9C6 #xE19D) + (#xF9C5 #xE19C) + (#xF9C4 #xE19B) + (#xF9C3 #xE19A) + (#xF9C2 #xE199) + (#xF9C1 #xE198) + (#xF9C0 #xE197) + (#xF9BF #xE196) + (#xF9BE #xE195) + (#xF9BD #xE194) + (#xF9BC #xE193) + (#xF9BB #xE192) + (#xF9BA #xE191) + (#xF9B9 #xE190) + (#xF9B8 #xE18F) + (#xF9B7 #xE18E) + (#xF9B6 #xE18D) + (#xF9B5 #xE18C) + (#xF9B4 #xE18B) + (#xF9B3 #xE18A) + (#xF9B2 #xE189) + (#xF9B1 #xE188) + (#xF9B0 #xE187) + (#xF9AF #xE186) + (#xF9AE #xE185) + (#xF9AD #xE184) + (#xF9AC #xE183) + (#xF9AB #xE182) + (#xF9AA #xE181) + (#xF9A9 #xE180) + (#xF9A8 #xE17F) + (#xF9A7 #xE17E) + (#xF9A6 #xE17D) + (#xF9A5 #xE17C) + (#xF9A4 #xE17B) + (#xF9A3 #xE17A) + (#xF9A2 #xE179) + (#xF9A1 #xE178) + (#xF8FE #xE177) + (#xF8FD #xE176) + (#xF8FC #xE175) + (#xF8FB #xE174) + (#xF8FA #xE173) + (#xF8F9 #xE172) + (#xF8F8 #xE171) + (#xF8F7 #xE170) + (#xF8F6 #xE16F) + (#xF8F5 #xE16E) + (#xF8F4 #xE16D) + (#xF8F3 #xE16C) + (#xF8F2 #xE16B) + (#xF8F1 #xE16A) + (#xF8F0 #xE169) + (#xF8EF #xE168) + (#xF8EE #xE167) + (#xF8ED #xE166) + (#xF8EC #xE165) + (#xF8EB #xE164) + (#xF8EA #xE163) + (#xF8E9 #xE162) + (#xF8E8 #xE161) + (#xF8E7 #xE160) + (#xF8E6 #xE15F) + (#xF8E5 #xE15E) + (#xF8E4 #xE15D) + (#xF8E3 #xE15C) + (#xF8E2 #xE15B) + (#xF8E1 #xE15A) + (#xF8E0 #xE159) + (#xF8DF #xE158) + (#xF8DE #xE157) + (#xF8DD #xE156) + (#xF8DC #xE155) + (#xF8DB #xE154) + (#xF8DA #xE153) + (#xF8D9 #xE152) + (#xF8D8 #xE151) + (#xF8D7 #xE150) + (#xF8D6 #xE14F) + (#xF8D5 #xE14E) + (#xF8D4 #xE14D) + (#xF8D3 #xE14C) + (#xF8D2 #xE14B) + (#xF8D1 #xE14A) + (#xF8D0 #xE149) + (#xF8CF #xE148) + (#xF8CE #xE147) + (#xF8CD #xE146) + (#xF8CC #xE145) + (#xF8CB #xE144) + (#xF8CA #xE143) + (#xF8C9 #xE142) + (#xF8C8 #xE141) + (#xF8C7 #xE140) + (#xF8C6 #xE13F) + (#xF8C5 #xE13E) + (#xF8C4 #xE13D) + (#xF8C3 #xE13C) + (#xF8C2 #xE13B) + (#xF8C1 #xE13A) + (#xF8C0 #xE139) + (#xF8BF #xE138) + (#xF8BE #xE137) + (#xF8BD #xE136) + (#xF8BC #xE135) + (#xF8BB #xE134) + (#xF8BA #xE133) + (#xF8B9 #xE132) + (#xF8B8 #xE131) + (#xF8B7 #xE130) + (#xF8B6 #xE12F) + (#xF8B5 #xE12E) + (#xF8B4 #xE12D) + (#xF8B3 #xE12C) + (#xF8B2 #xE12B) + (#xF8B1 #xE12A) + (#xF8B0 #xE129) + (#xF8AF #xE128) + (#xF8AE #xE127) + (#xF8AD #xE126) + (#xF8AC #xE125) + (#xF8AB #xE124) + (#xF8AA #xE123) + (#xF8A9 #xE122) + (#xF8A8 #xE121) + (#xF8A7 #xE120) + (#xF8A6 #xE11F) + (#xF8A5 #xE11E) + (#xF8A4 #xE11D) + (#xF8A3 #xE11C) + (#xF8A2 #xE11B) + (#xF8A1 #xE11A) + (#xF7FE #xE119) + (#xF7FD #xE118) + (#xF7FC #xE117) + (#xF7FB #xE116) + (#xF7FA #xE115) + (#xF7F9 #xE114) + (#xF7F8 #xE113) + (#xF7F7 #xE112) + (#xF7F6 #xE111) + (#xF7F5 #xE110) + (#xF7F4 #xE10F) + (#xF7F3 #xE10E) + (#xF7F2 #xE10D) + (#xF7F1 #xE10C) + (#xF7F0 #xE10B) + (#xF7EF #xE10A) + (#xF7EE #xE109) + (#xF7ED #xE108) + (#xF7EC #xE107) + (#xF7EB #xE106) + (#xF7EA #xE105) + (#xF7E9 #xE104) + (#xF7E8 #xE103) + (#xF7E7 #xE102) + (#xF7E6 #xE101) + (#xF7E5 #xE100) + (#xF7E4 #xE0FF) + (#xF7E3 #xE0FE) + (#xF7E2 #xE0FD) + (#xF7E1 #xE0FC) + (#xF7E0 #xE0FB) + (#xF7DF #xE0FA) + (#xF7DE #xE0F9) + (#xF7DD #xE0F8) + (#xF7DC #xE0F7) + (#xF7DB #xE0F6) + (#xF7DA #xE0F5) + (#xF7D9 #xE0F4) + (#xF7D8 #xE0F3) + (#xF7D7 #xE0F2) + (#xF7D6 #xE0F1) + (#xF7D5 #xE0F0) + (#xF7D4 #xE0EF) + (#xF7D3 #xE0EE) + (#xF7D2 #xE0ED) + (#xF7D1 #xE0EC) + (#xF7D0 #xE0EB) + (#xF7CF #xE0EA) + (#xF7CE #xE0E9) + (#xF7CD #xE0E8) + (#xF7CC #xE0E7) + (#xF7CB #xE0E6) + (#xF7CA #xE0E5) + (#xF7C9 #xE0E4) + (#xF7C8 #xE0E3) + (#xF7C7 #xE0E2) + (#xF7C6 #xE0E1) + (#xF7C5 #xE0E0) + (#xF7C4 #xE0DF) + (#xF7C3 #xE0DE) + (#xF7C2 #xE0DD) + (#xF7C1 #xE0DC) + (#xF7C0 #xE0DB) + (#xF7BF #xE0DA) + (#xF7BE #xE0D9) + (#xF7BD #xE0D8) + (#xF7BC #xE0D7) + (#xF7BB #xE0D6) + (#xF7BA #xE0D5) + (#xF7B9 #xE0D4) + (#xF7B8 #xE0D3) + (#xF7B7 #xE0D2) + (#xF7B6 #xE0D1) + (#xF7B5 #xE0D0) + (#xF7B4 #xE0CF) + (#xF7B3 #xE0CE) + (#xF7B2 #xE0CD) + (#xF7B1 #xE0CC) + (#xF7B0 #xE0CB) + (#xF7AF #xE0CA) + (#xF7AE #xE0C9) + (#xF7AD #xE0C8) + (#xF7AC #xE0C7) + (#xF7AB #xE0C6) + (#xF7AA #xE0C5) + (#xF7A9 #xE0C4) + (#xF7A8 #xE0C3) + (#xF7A7 #xE0C2) + (#xF7A6 #xE0C1) + (#xF7A5 #xE0C0) + (#xF7A4 #xE0BF) + (#xF7A3 #xE0BE) + (#xF7A2 #xE0BD) + (#xF7A1 #xE0BC) + (#xF6FE #xE0BB) + (#xF6FD #xE0BA) + (#xF6FC #xE0B9) + (#xF6FB #xE0B8) + (#xF6FA #xE0B7) + (#xF6F9 #xE0B6) + (#xF6F8 #xE0B5) + (#xF6F7 #xE0B4) + (#xF6F6 #xE0B3) + (#xF6F5 #xE0B2) + (#xF6F4 #xE0B1) + (#xF6F3 #xE0B0) + (#xF6F2 #xE0AF) + (#xF6F1 #xE0AE) + (#xF6F0 #xE0AD) + (#xF6EF #xE0AC) + (#xF6EE #xE0AB) + (#xF6ED #xE0AA) + (#xF6EC #xE0A9) + (#xF6EB #xE0A8) + (#xF6EA #xE0A7) + (#xF6E9 #xE0A6) + (#xF6E8 #xE0A5) + (#xF6E7 #xE0A4) + (#xF6E6 #xE0A3) + (#xF6E5 #xE0A2) + (#xF6E4 #xE0A1) + (#xF6E3 #xE0A0) + (#xF6E2 #xE09F) + (#xF6E1 #xE09E) + (#xF6E0 #xE09D) + (#xF6DF #xE09C) + (#xF6DE #xE09B) + (#xF6DD #xE09A) + (#xF6DC #xE099) + (#xF6DB #xE098) + (#xF6DA #xE097) + (#xF6D9 #xE096) + (#xF6D8 #xE095) + (#xF6D7 #xE094) + (#xF6D6 #xE093) + (#xF6D5 #xE092) + (#xF6D4 #xE091) + (#xF6D3 #xE090) + (#xF6D2 #xE08F) + (#xF6D1 #xE08E) + (#xF6D0 #xE08D) + (#xF6CF #xE08C) + (#xF6CE #xE08B) + (#xF6CD #xE08A) + (#xF6CC #xE089) + (#xF6CB #xE088) + (#xF6CA #xE087) + (#xF6C9 #xE086) + (#xF6C8 #xE085) + (#xF6C7 #xE084) + (#xF6C6 #xE083) + (#xF6C5 #xE082) + (#xF6C4 #xE081) + (#xF6C3 #xE080) + (#xF6C2 #xE07F) + (#xF6C1 #xE07E) + (#xF6C0 #xE07D) + (#xF6BF #xE07C) + (#xF6BE #xE07B) + (#xF6BD #xE07A) + (#xF6BC #xE079) + (#xF6BB #xE078) + (#xF6BA #xE077) + (#xF6B9 #xE076) + (#xF6B8 #xE075) + (#xF6B7 #xE074) + (#xF6B6 #xE073) + (#xF6B5 #xE072) + (#xF6B4 #xE071) + (#xF6B3 #xE070) + (#xF6B2 #xE06F) + (#xF6B1 #xE06E) + (#xF6B0 #xE06D) + (#xF6AF #xE06C) + (#xF6AE #xE06B) + (#xF6AD #xE06A) + (#xF6AC #xE069) + (#xF6AB #xE068) + (#xF6AA #xE067) + (#xF6A9 #xE066) + (#xF6A8 #xE065) + (#xF6A7 #xE064) + (#xF6A6 #xE063) + (#xF6A5 #xE062) + (#xF6A4 #xE061) + (#xF6A3 #xE060) + (#xF6A2 #xE05F) + (#xF6A1 #xE05E) + (#xF5FE #xE05D) + (#xF5FD #xE05C) + (#xF5FC #xE05B) + (#xF5FB #xE05A) + (#xF5FA #xE059) + (#xF5F9 #xE058) + (#xF5F8 #xE057) + (#xF5F7 #xE056) + (#xF5F6 #xE055) + (#xF5F5 #xE054) + (#xF5F4 #xE053) + (#xF5F3 #xE052) + (#xF5F2 #xE051) + (#xF5F1 #xE050) + (#xF5F0 #xE04F) + (#xF5EF #xE04E) + (#xF5EE #xE04D) + (#xF5ED #xE04C) + (#xF5EC #xE04B) + (#xF5EB #xE04A) + (#xF5EA #xE049) + (#xF5E9 #xE048) + (#xF5E8 #xE047) + (#xF5E7 #xE046) + (#xF5E6 #xE045) + (#xF5E5 #xE044) + (#xF5E4 #xE043) + (#xF5E3 #xE042) + (#xF5E2 #xE041) + (#xF5E1 #xE040) + (#xF5E0 #xE03F) + (#xF5DF #xE03E) + (#xF5DE #xE03D) + (#xF5DD #xE03C) + (#xF5DC #xE03B) + (#xF5DB #xE03A) + (#xF5DA #xE039) + (#xF5D9 #xE038) + (#xF5D8 #xE037) + (#xF5D7 #xE036) + (#xF5D6 #xE035) + (#xF5D5 #xE034) + (#xF5D4 #xE033) + (#xF5D3 #xE032) + (#xF5D2 #xE031) + (#xF5D1 #xE030) + (#xF5D0 #xE02F) + (#xF5CF #xE02E) + (#xF5CE #xE02D) + (#xF5CD #xE02C) + (#xF5CC #xE02B) + (#xF5CB #xE02A) + (#xF5CA #xE029) + (#xF5C9 #xE028) + (#xF5C8 #xE027) + (#xF5C7 #xE026) + (#xF5C6 #xE025) + (#xF5C5 #xE024) + (#xF5C4 #xE023) + (#xF5C3 #xE022) + (#xF5C2 #xE021) + (#xF5C1 #xE020) + (#xF5C0 #xE01F) + (#xF5BF #xE01E) + (#xF5BE #xE01D) + (#xF5BD #xE01C) + (#xF5BC #xE01B) + (#xF5BB #xE01A) + (#xF5BA #xE019) + (#xF5B9 #xE018) + (#xF5B8 #xE017) + (#xF5B7 #xE016) + (#xF5B6 #xE015) + (#xF5B5 #xE014) + (#xF5B4 #xE013) + (#xF5B3 #xE012) + (#xF5B2 #xE011) + (#xF5B1 #xE010) + (#xF5B0 #xE00F) + (#xF5AF #xE00E) + (#xF5AE #xE00D) + (#xF5AD #xE00C) + (#xF5AC #xE00B) + (#xF5AB #xE00A) + (#xF5AA #xE009) + (#xF5A9 #xE008) + (#xF5A8 #xE007) + (#xF5A7 #xE006) + (#xF5A6 #xE005) + (#xF5A5 #xE004) + (#xF5A4 #xE003) + (#xF5A3 #xE002) + (#xF5A2 #xE001) + (#xF5A1 #xE000) + )) + (eucjp '((#x8FA2AF #x2D8) + (#x8FA2B0 #x2C7) + (#x8FA2B1 #xB8) + (#x8FA2B2 #x2D9) + (#x8FA2B3 #x2DD) + (#x8FA2B4 #xAF) + (#x8FA2B5 #x2DB) + (#x8FA2B6 #x2DA) + (#x8FA2B7 #xFF5E) + (#x8FA2B8 #x384) + (#x8FA2B9 #x385) + (#x8FA2C2 #xA1) + (#x8FA2C3 #xA6) + (#x8FA2C4 #xBF) + (#x8FA2EB #xBA) + (#x8FA2EC #xAA) + (#x8FA2ED #xA9) + (#x8FA2EE #xAE) + (#x8FA2EF #x2122) + (#x8FA2F0 #xA4) + (#x8FA2F1 #x2116) + (#x8FA6E1 #x386) + (#x8FA6E2 #x388) + (#x8FA6E3 #x389) + (#x8FA6E4 #x38A) + (#x8FA6E5 #x3AA) + (#x8FA6E7 #x38C) + (#x8FA6E9 #x38E) + (#x8FA6EA #x3AB) + (#x8FA6EC #x38F) + (#x8FA6F1 #x3AC) + (#x8FA6F2 #x3AD) + (#x8FA6F3 #x3AE) + (#x8FA6F4 #x3AF) + (#x8FA6F5 #x3CA) + (#x8FA6F6 #x390) + (#x8FA6F7 #x3CC) + (#x8FA6F8 #x3C2) + (#x8FA6F9 #x3CD) + (#x8FA6FA #x3CB) + (#x8FA6FB #x3B0) + (#x8FA6FC #x3CE) + (#x8FA7C2 #x402) + (#x8FA7C3 #x403) + (#x8FA7C4 #x404) + (#x8FA7C5 #x405) + (#x8FA7C6 #x406) + (#x8FA7C7 #x407) + (#x8FA7C8 #x408) + (#x8FA7C9 #x409) + (#x8FA7CA #x40A) + (#x8FA7CB #x40B) + (#x8FA7CC #x40C) + (#x8FA7CD #x40E) + (#x8FA7CE #x40F) + (#x8FA7F2 #x452) + (#x8FA7F3 #x453) + (#x8FA7F4 #x454) + (#x8FA7F5 #x455) + (#x8FA7F6 #x456) + (#x8FA7F7 #x457) + (#x8FA7F8 #x458) + (#x8FA7F9 #x459) + (#x8FA7FA #x45A) + (#x8FA7FB #x45B) + (#x8FA7FC #x45C) + (#x8FA7FD #x45E) + (#x8FA7FE #x45F) + (#x8FA9A1 #xC6) + (#x8FA9A2 #x110) + (#x8FA9A4 #x126) + (#x8FA9A6 #x132) + (#x8FA9A8 #x141) + (#x8FA9A9 #x13F) + (#x8FA9AB #x14A) + (#x8FA9AC #xD8) + (#x8FA9AD #x152) + (#x8FA9AF #x166) + (#x8FA9B0 #xDE) + (#x8FA9C1 #xE6) + (#x8FA9C2 #x111) + (#x8FA9C3 #xF0) + (#x8FA9C4 #x127) + (#x8FA9C5 #x131) + (#x8FA9C6 #x133) + (#x8FA9C7 #x138) + (#x8FA9C8 #x142) + (#x8FA9C9 #x140) + (#x8FA9CA #x149) + (#x8FA9CB #x14B) + (#x8FA9CC #xF8) + (#x8FA9CD #x153) + (#x8FA9CE #xDF) + (#x8FA9CF #x167) + (#x8FA9D0 #xFE) + (#x8FAAA1 #xC1) + (#x8FAAA2 #xC0) + (#x8FAAA3 #xC4) + (#x8FAAA4 #xC2) + (#x8FAAA5 #x102) + (#x8FAAA6 #x1CD) + (#x8FAAA7 #x100) + (#x8FAAA8 #x104) + (#x8FAAA9 #xC5) + (#x8FAAAA #xC3) + (#x8FAAAB #x106) + (#x8FAAAC #x108) + (#x8FAAAD #x10C) + (#x8FAAAE #xC7) + (#x8FAAAF #x10A) + (#x8FAAB0 #x10E) + (#x8FAAB1 #xC9) + (#x8FAAB2 #xC8) + (#x8FAAB3 #xCB) + (#x8FAAB4 #xCA) + (#x8FAAB5 #x11A) + (#x8FAAB6 #x116) + (#x8FAAB7 #x112) + (#x8FAAB8 #x118) + (#x8FAABA #x11C) + (#x8FAABB #x11E) + (#x8FAABC #x122) + (#x8FAABD #x120) + (#x8FAABE #x124) + (#x8FAABF #xCD) + (#x8FAAC0 #xCC) + (#x8FAAC1 #xCF) + (#x8FAAC2 #xCE) + (#x8FAAC3 #x1CF) + (#x8FAAC4 #x130) + (#x8FAAC5 #x12A) + (#x8FAAC6 #x12E) + (#x8FAAC7 #x128) + (#x8FAAC8 #x134) + (#x8FAAC9 #x136) + (#x8FAACA #x139) + (#x8FAACB #x13D) + (#x8FAACC #x13B) + (#x8FAACD #x143) + (#x8FAACE #x147) + (#x8FAACF #x145) + (#x8FAAD0 #xD1) + (#x8FAAD1 #xD3) + (#x8FAAD2 #xD2) + (#x8FAAD3 #xD6) + (#x8FAAD4 #xD4) + (#x8FAAD5 #x1D1) + (#x8FAAD6 #x150) + (#x8FAAD7 #x14C) + (#x8FAAD8 #xD5) + (#x8FAAD9 #x154) + (#x8FAADA #x158) + (#x8FAADB #x156) + (#x8FAADC #x15A) + (#x8FAADD #x15C) + (#x8FAADE #x160) + (#x8FAADF #x15E) + (#x8FAAE0 #x164) + (#x8FAAE1 #x162) + (#x8FAAE2 #xDA) + (#x8FAAE3 #xD9) + (#x8FAAE4 #xDC) + (#x8FAAE5 #xDB) + (#x8FAAE6 #x16C) + (#x8FAAE7 #x1D3) + (#x8FAAE8 #x170) + (#x8FAAE9 #x16A) + (#x8FAAEA #x172) + (#x8FAAEB #x16E) + (#x8FAAEC #x168) + (#x8FAAED #x1D7) + (#x8FAAEE #x1DB) + (#x8FAAEF #x1D9) + (#x8FAAF0 #x1D5) + (#x8FAAF1 #x174) + (#x8FAAF2 #xDD) + (#x8FAAF3 #x178) + (#x8FAAF4 #x176) + (#x8FAAF5 #x179) + (#x8FAAF6 #x17D) + (#x8FAAF7 #x17B) + (#x8FABA1 #xE1) + (#x8FABA2 #xE0) + (#x8FABA3 #xE4) + (#x8FABA4 #xE2) + (#x8FABA5 #x103) + (#x8FABA6 #x1CE) + (#x8FABA7 #x101) + (#x8FABA8 #x105) + (#x8FABA9 #xE5) + (#x8FABAA #xE3) + (#x8FABAB #x107) + (#x8FABAC #x109) + (#x8FABAD #x10D) + (#x8FABAE #xE7) + (#x8FABAF #x10B) + (#x8FABB0 #x10F) + (#x8FABB1 #xE9) + (#x8FABB2 #xE8) + (#x8FABB3 #xEB) + (#x8FABB4 #xEA) + (#x8FABB5 #x11B) + (#x8FABB6 #x117) + (#x8FABB7 #x113) + (#x8FABB8 #x119) + (#x8FABB9 #x1F5) + (#x8FABBA #x11D) + (#x8FABBB #x11F) + (#x8FABBD #x121) + (#x8FABBE #x125) + (#x8FABBF #xED) + (#x8FABC0 #xEC) + (#x8FABC1 #xEF) + (#x8FABC2 #xEE) + (#x8FABC3 #x1D0) + (#x8FABC5 #x12B) + (#x8FABC6 #x12F) + (#x8FABC7 #x129) + (#x8FABC8 #x135) + (#x8FABC9 #x137) + (#x8FABCA #x13A) + (#x8FABCB #x13E) + (#x8FABCC #x13C) + (#x8FABCD #x144) + (#x8FABCE #x148) + (#x8FABCF #x146) + (#x8FABD0 #xF1) + (#x8FABD1 #xF3) + (#x8FABD2 #xF2) + (#x8FABD3 #xF6) + (#x8FABD4 #xF4) + (#x8FABD5 #x1D2) + (#x8FABD6 #x151) + (#x8FABD7 #x14D) + (#x8FABD8 #xF5) + (#x8FABD9 #x155) + (#x8FABDA #x159) + (#x8FABDB #x157) + (#x8FABDC #x15B) + (#x8FABDD #x15D) + (#x8FABDE #x161) + (#x8FABDF #x15F) + (#x8FABE0 #x165) + (#x8FABE1 #x163) + (#x8FABE2 #xFA) + (#x8FABE3 #xF9) + (#x8FABE4 #xFC) + (#x8FABE5 #xFB) + (#x8FABE6 #x16D) + (#x8FABE7 #x1D4) + (#x8FABE8 #x171) + (#x8FABE9 #x16B) + (#x8FABEA #x173) + (#x8FABEB #x16F) + (#x8FABEC #x169) + (#x8FABED #x1D8) + (#x8FABEE #x1DC) + (#x8FABEF #x1DA) + (#x8FABF0 #x1D6) + (#x8FABF1 #x175) + (#x8FABF2 #xFD) + (#x8FABF3 #xFF) + (#x8FABF4 #x177) + (#x8FABF5 #x17A) + (#x8FABF6 #x17E) + (#x8FABF7 #x17C) + (#x8FB0A1 #x4E02) + (#x8FB0A2 #x4E04) + (#x8FB0A3 #x4E05) + (#x8FB0A4 #x4E0C) + (#x8FB0A5 #x4E12) + (#x8FB0A6 #x4E1F) + (#x8FB0A7 #x4E23) + (#x8FB0A8 #x4E24) + (#x8FB0A9 #x4E28) + (#x8FB0AA #x4E2B) + (#x8FB0AB #x4E2E) + (#x8FB0AC #x4E2F) + (#x8FB0AD #x4E30) + (#x8FB0AE #x4E35) + (#x8FB0AF #x4E40) + (#x8FB0B0 #x4E41) + (#x8FB0B1 #x4E44) + (#x8FB0B2 #x4E47) + (#x8FB0B3 #x4E51) + (#x8FB0B4 #x4E5A) + (#x8FB0B5 #x4E5C) + (#x8FB0B6 #x4E63) + (#x8FB0B7 #x4E68) + (#x8FB0B8 #x4E69) + (#x8FB0B9 #x4E74) + (#x8FB0BA #x4E75) + (#x8FB0BB #x4E79) + (#x8FB0BC #x4E7F) + (#x8FB0BD #x4E8D) + (#x8FB0BE #x4E96) + (#x8FB0BF #x4E97) + (#x8FB0C0 #x4E9D) + (#x8FB0C1 #x4EAF) + (#x8FB0C2 #x4EB9) + (#x8FB0C3 #x4EC3) + (#x8FB0C4 #x4ED0) + (#x8FB0C5 #x4EDA) + (#x8FB0C6 #x4EDB) + (#x8FB0C7 #x4EE0) + (#x8FB0C8 #x4EE1) + (#x8FB0C9 #x4EE2) + (#x8FB0CA #x4EE8) + (#x8FB0CB #x4EEF) + (#x8FB0CC #x4EF1) + (#x8FB0CD #x4EF3) + (#x8FB0CE #x4EF5) + (#x8FB0CF #x4EFD) + (#x8FB0D0 #x4EFE) + (#x8FB0D1 #x4EFF) + (#x8FB0D2 #x4F00) + (#x8FB0D3 #x4F02) + (#x8FB0D4 #x4F03) + (#x8FB0D5 #x4F08) + (#x8FB0D6 #x4F0B) + (#x8FB0D7 #x4F0C) + (#x8FB0D8 #x4F12) + (#x8FB0D9 #x4F15) + (#x8FB0DA #x4F16) + (#x8FB0DB #x4F17) + (#x8FB0DC #x4F19) + (#x8FB0DD #x4F2E) + (#x8FB0DE #x4F31) + (#x8FB0DF #x4F60) + (#x8FB0E0 #x4F33) + (#x8FB0E1 #x4F35) + (#x8FB0E2 #x4F37) + (#x8FB0E3 #x4F39) + (#x8FB0E4 #x4F3B) + (#x8FB0E5 #x4F3E) + (#x8FB0E6 #x4F40) + (#x8FB0E7 #x4F42) + (#x8FB0E8 #x4F48) + (#x8FB0E9 #x4F49) + (#x8FB0EA #x4F4B) + (#x8FB0EB #x4F4C) + (#x8FB0EC #x4F52) + (#x8FB0ED #x4F54) + (#x8FB0EE #x4F56) + (#x8FB0EF #x4F58) + (#x8FB0F0 #x4F5F) + (#x8FB0F1 #x4F63) + (#x8FB0F2 #x4F6A) + (#x8FB0F3 #x4F6C) + (#x8FB0F4 #x4F6E) + (#x8FB0F5 #x4F71) + (#x8FB0F6 #x4F77) + (#x8FB0F7 #x4F78) + (#x8FB0F8 #x4F79) + (#x8FB0F9 #x4F7A) + (#x8FB0FA #x4F7D) + (#x8FB0FB #x4F7E) + (#x8FB0FC #x4F81) + (#x8FB0FD #x4F82) + (#x8FB0FE #x4F84) + (#x8FB1A1 #x4F85) + (#x8FB1A2 #x4F89) + (#x8FB1A3 #x4F8A) + (#x8FB1A4 #x4F8C) + (#x8FB1A5 #x4F8E) + (#x8FB1A6 #x4F90) + (#x8FB1A7 #x4F92) + (#x8FB1A8 #x4F93) + (#x8FB1A9 #x4F94) + (#x8FB1AA #x4F97) + (#x8FB1AB #x4F99) + (#x8FB1AC #x4F9A) + (#x8FB1AD #x4F9E) + (#x8FB1AE #x4F9F) + (#x8FB1AF #x4FB2) + (#x8FB1B0 #x4FB7) + (#x8FB1B1 #x4FB9) + (#x8FB1B2 #x4FBB) + (#x8FB1B3 #x4FBC) + (#x8FB1B4 #x4FBD) + (#x8FB1B5 #x4FBE) + (#x8FB1B6 #x4FC0) + (#x8FB1B7 #x4FC1) + (#x8FB1B8 #x4FC5) + (#x8FB1B9 #x4FC6) + (#x8FB1BA #x4FC8) + (#x8FB1BB #x4FC9) + (#x8FB1BC #x4FCB) + (#x8FB1BD #x4FCC) + (#x8FB1BE #x4FCD) + (#x8FB1BF #x4FCF) + (#x8FB1C0 #x4FD2) + (#x8FB1C1 #x4FDC) + (#x8FB1C2 #x4FE0) + (#x8FB1C3 #x4FE2) + (#x8FB1C4 #x4FF0) + (#x8FB1C5 #x4FF2) + (#x8FB1C6 #x4FFC) + (#x8FB1C7 #x4FFD) + (#x8FB1C8 #x4FFF) + (#x8FB1C9 #x5000) + (#x8FB1CA #x5001) + (#x8FB1CB #x5004) + (#x8FB1CC #x5007) + (#x8FB1CD #x500A) + (#x8FB1CE #x500C) + (#x8FB1CF #x500E) + (#x8FB1D0 #x5010) + (#x8FB1D1 #x5013) + (#x8FB1D2 #x5017) + (#x8FB1D3 #x5018) + (#x8FB1D4 #x501B) + (#x8FB1D5 #x501C) + (#x8FB1D6 #x501D) + (#x8FB1D7 #x501E) + (#x8FB1D8 #x5022) + (#x8FB1D9 #x5027) + (#x8FB1DA #x502E) + (#x8FB1DB #x5030) + (#x8FB1DC #x5032) + (#x8FB1DD #x5033) + (#x8FB1DE #x5035) + (#x8FB1DF #x5040) + (#x8FB1E0 #x5041) + (#x8FB1E1 #x5042) + (#x8FB1E2 #x5045) + (#x8FB1E3 #x5046) + (#x8FB1E4 #x504A) + (#x8FB1E5 #x504C) + (#x8FB1E6 #x504E) + (#x8FB1E7 #x5051) + (#x8FB1E8 #x5052) + (#x8FB1E9 #x5053) + (#x8FB1EA #x5057) + (#x8FB1EB #x5059) + (#x8FB1EC #x505F) + (#x8FB1ED #x5060) + (#x8FB1EE #x5062) + (#x8FB1EF #x5063) + (#x8FB1F0 #x5066) + (#x8FB1F1 #x5067) + (#x8FB1F2 #x506A) + (#x8FB1F3 #x506D) + (#x8FB1F4 #x5070) + (#x8FB1F5 #x5071) + (#x8FB1F6 #x503B) + (#x8FB1F7 #x5081) + (#x8FB1F8 #x5083) + (#x8FB1F9 #x5084) + (#x8FB1FA #x5086) + (#x8FB1FB #x508A) + (#x8FB1FC #x508E) + (#x8FB1FD #x508F) + (#x8FB1FE #x5090) + (#x8FB2A1 #x5092) + (#x8FB2A2 #x5093) + (#x8FB2A3 #x5094) + (#x8FB2A4 #x5096) + (#x8FB2A5 #x509B) + (#x8FB2A6 #x509C) + (#x8FB2A7 #x509E) + (#x8FB2A8 #x509F) + (#x8FB2A9 #x50A0) + (#x8FB2AA #x50A1) + (#x8FB2AB #x50A2) + (#x8FB2AC #x50AA) + (#x8FB2AD #x50AF) + (#x8FB2AE #x50B0) + (#x8FB2AF #x50B9) + (#x8FB2B0 #x50BA) + (#x8FB2B1 #x50BD) + (#x8FB2B2 #x50C0) + (#x8FB2B3 #x50C3) + (#x8FB2B4 #x50C4) + (#x8FB2B5 #x50C7) + (#x8FB2B6 #x50CC) + (#x8FB2B7 #x50CE) + (#x8FB2B8 #x50D0) + (#x8FB2B9 #x50D3) + (#x8FB2BA #x50D4) + (#x8FB2BB #x50D8) + (#x8FB2BC #x50DC) + (#x8FB2BD #x50DD) + (#x8FB2BE #x50DF) + (#x8FB2BF #x50E2) + (#x8FB2C0 #x50E4) + (#x8FB2C1 #x50E6) + (#x8FB2C2 #x50E8) + (#x8FB2C3 #x50E9) + (#x8FB2C4 #x50EF) + (#x8FB2C5 #x50F1) + (#x8FB2C6 #x50F6) + (#x8FB2C7 #x50FA) + (#x8FB2C8 #x50FE) + (#x8FB2C9 #x5103) + (#x8FB2CA #x5106) + (#x8FB2CB #x5107) + (#x8FB2CC #x5108) + (#x8FB2CD #x510B) + (#x8FB2CE #x510C) + (#x8FB2CF #x510D) + (#x8FB2D0 #x510E) + (#x8FB2D1 #x50F2) + (#x8FB2D2 #x5110) + (#x8FB2D3 #x5117) + (#x8FB2D4 #x5119) + (#x8FB2D5 #x511B) + (#x8FB2D6 #x511C) + (#x8FB2D7 #x511D) + (#x8FB2D8 #x511E) + (#x8FB2D9 #x5123) + (#x8FB2DA #x5127) + (#x8FB2DB #x5128) + (#x8FB2DC #x512C) + (#x8FB2DD #x512D) + (#x8FB2DE #x512F) + (#x8FB2DF #x5131) + (#x8FB2E0 #x5133) + (#x8FB2E1 #x5134) + (#x8FB2E2 #x5135) + (#x8FB2E3 #x5138) + (#x8FB2E4 #x5139) + (#x8FB2E5 #x5142) + (#x8FB2E6 #x514A) + (#x8FB2E7 #x514F) + (#x8FB2E8 #x5153) + (#x8FB2E9 #x5155) + (#x8FB2EA #x5157) + (#x8FB2EB #x5158) + (#x8FB2EC #x515F) + (#x8FB2ED #x5164) + (#x8FB2EE #x5166) + (#x8FB2EF #x517E) + (#x8FB2F0 #x5183) + (#x8FB2F1 #x5184) + (#x8FB2F2 #x518B) + (#x8FB2F3 #x518E) + (#x8FB2F4 #x5198) + (#x8FB2F5 #x519D) + (#x8FB2F6 #x51A1) + (#x8FB2F7 #x51A3) + (#x8FB2F8 #x51AD) + (#x8FB2F9 #x51B8) + (#x8FB2FA #x51BA) + (#x8FB2FB #x51BC) + (#x8FB2FC #x51BE) + (#x8FB2FD #x51BF) + (#x8FB2FE #x51C2) + (#x8FB3A1 #x51C8) + (#x8FB3A2 #x51CF) + (#x8FB3A3 #x51D1) + (#x8FB3A4 #x51D2) + (#x8FB3A5 #x51D3) + (#x8FB3A6 #x51D5) + (#x8FB3A7 #x51D8) + (#x8FB3A8 #x51DE) + (#x8FB3A9 #x51E2) + (#x8FB3AA #x51E5) + (#x8FB3AB #x51EE) + (#x8FB3AC #x51F2) + (#x8FB3AD #x51F3) + (#x8FB3AE #x51F4) + (#x8FB3AF #x51F7) + (#x8FB3B0 #x5201) + (#x8FB3B1 #x5202) + (#x8FB3B2 #x5205) + (#x8FB3B3 #x5212) + (#x8FB3B4 #x5213) + (#x8FB3B5 #x5215) + (#x8FB3B6 #x5216) + (#x8FB3B7 #x5218) + (#x8FB3B8 #x5222) + (#x8FB3B9 #x5228) + (#x8FB3BA #x5231) + (#x8FB3BB #x5232) + (#x8FB3BC #x5235) + (#x8FB3BD #x523C) + (#x8FB3BE #x5245) + (#x8FB3BF #x5249) + (#x8FB3C0 #x5255) + (#x8FB3C1 #x5257) + (#x8FB3C2 #x5258) + (#x8FB3C3 #x525A) + (#x8FB3C4 #x525C) + (#x8FB3C5 #x525F) + (#x8FB3C6 #x5260) + (#x8FB3C7 #x5261) + (#x8FB3C8 #x5266) + (#x8FB3C9 #x526E) + (#x8FB3CA #x5277) + (#x8FB3CB #x5278) + (#x8FB3CC #x5279) + (#x8FB3CD #x5280) + (#x8FB3CE #x5282) + (#x8FB3CF #x5285) + (#x8FB3D0 #x528A) + (#x8FB3D1 #x528C) + (#x8FB3D2 #x5293) + (#x8FB3D3 #x5295) + (#x8FB3D4 #x5296) + (#x8FB3D5 #x5297) + (#x8FB3D6 #x5298) + (#x8FB3D7 #x529A) + (#x8FB3D8 #x529C) + (#x8FB3D9 #x52A4) + (#x8FB3DA #x52A5) + (#x8FB3DB #x52A6) + (#x8FB3DC #x52A7) + (#x8FB3DD #x52AF) + (#x8FB3DE #x52B0) + (#x8FB3DF #x52B6) + (#x8FB3E0 #x52B7) + (#x8FB3E1 #x52B8) + (#x8FB3E2 #x52BA) + (#x8FB3E3 #x52BB) + (#x8FB3E4 #x52BD) + (#x8FB3E5 #x52C0) + (#x8FB3E6 #x52C4) + (#x8FB3E7 #x52C6) + (#x8FB3E8 #x52C8) + (#x8FB3E9 #x52CC) + (#x8FB3EA #x52CF) + (#x8FB3EB #x52D1) + (#x8FB3EC #x52D4) + (#x8FB3ED #x52D6) + (#x8FB3EE #x52DB) + (#x8FB3EF #x52DC) + (#x8FB3F0 #x52E1) + (#x8FB3F1 #x52E5) + (#x8FB3F2 #x52E8) + (#x8FB3F3 #x52E9) + (#x8FB3F4 #x52EA) + (#x8FB3F5 #x52EC) + (#x8FB3F6 #x52F0) + (#x8FB3F7 #x52F1) + (#x8FB3F8 #x52F4) + (#x8FB3F9 #x52F6) + (#x8FB3FA #x52F7) + (#x8FB3FB #x5300) + (#x8FB3FC #x5303) + (#x8FB3FD #x530A) + (#x8FB3FE #x530B) + (#x8FB4A1 #x530C) + (#x8FB4A2 #x5311) + (#x8FB4A3 #x5313) + (#x8FB4A4 #x5318) + (#x8FB4A5 #x531B) + (#x8FB4A6 #x531C) + (#x8FB4A7 #x531E) + (#x8FB4A8 #x531F) + (#x8FB4A9 #x5325) + (#x8FB4AA #x5327) + (#x8FB4AB #x5328) + (#x8FB4AC #x5329) + (#x8FB4AD #x532B) + (#x8FB4AE #x532C) + (#x8FB4AF #x532D) + (#x8FB4B0 #x5330) + (#x8FB4B1 #x5332) + (#x8FB4B2 #x5335) + (#x8FB4B3 #x533C) + (#x8FB4B4 #x533D) + (#x8FB4B5 #x533E) + (#x8FB4B6 #x5342) + (#x8FB4B7 #x534C) + (#x8FB4B8 #x534B) + (#x8FB4B9 #x5359) + (#x8FB4BA #x535B) + (#x8FB4BB #x5361) + (#x8FB4BC #x5363) + (#x8FB4BD #x5365) + (#x8FB4BE #x536C) + (#x8FB4BF #x536D) + (#x8FB4C0 #x5372) + (#x8FB4C1 #x5379) + (#x8FB4C2 #x537E) + (#x8FB4C3 #x5383) + (#x8FB4C4 #x5387) + (#x8FB4C5 #x5388) + (#x8FB4C6 #x538E) + (#x8FB4C7 #x5393) + (#x8FB4C8 #x5394) + (#x8FB4C9 #x5399) + (#x8FB4CA #x539D) + (#x8FB4CB #x53A1) + (#x8FB4CC #x53A4) + (#x8FB4CD #x53AA) + (#x8FB4CE #x53AB) + (#x8FB4CF #x53AF) + (#x8FB4D0 #x53B2) + (#x8FB4D1 #x53B4) + (#x8FB4D2 #x53B5) + (#x8FB4D3 #x53B7) + (#x8FB4D4 #x53B8) + (#x8FB4D5 #x53BA) + (#x8FB4D6 #x53BD) + (#x8FB4D7 #x53C0) + (#x8FB4D8 #x53C5) + (#x8FB4D9 #x53CF) + (#x8FB4DA #x53D2) + (#x8FB4DB #x53D3) + (#x8FB4DC #x53D5) + (#x8FB4DD #x53DA) + (#x8FB4DE #x53DD) + (#x8FB4DF #x53DE) + (#x8FB4E0 #x53E0) + (#x8FB4E1 #x53E6) + (#x8FB4E2 #x53E7) + (#x8FB4E3 #x53F5) + (#x8FB4E4 #x5402) + (#x8FB4E5 #x5413) + (#x8FB4E6 #x541A) + (#x8FB4E7 #x5421) + (#x8FB4E8 #x5427) + (#x8FB4E9 #x5428) + (#x8FB4EA #x542A) + (#x8FB4EB #x542F) + (#x8FB4EC #x5431) + (#x8FB4ED #x5434) + (#x8FB4EE #x5435) + (#x8FB4EF #x5443) + (#x8FB4F0 #x5444) + (#x8FB4F1 #x5447) + (#x8FB4F2 #x544D) + (#x8FB4F3 #x544F) + (#x8FB4F4 #x545E) + (#x8FB4F5 #x5462) + (#x8FB4F6 #x5464) + (#x8FB4F7 #x5466) + (#x8FB4F8 #x5467) + (#x8FB4F9 #x5469) + (#x8FB4FA #x546B) + (#x8FB4FB #x546D) + (#x8FB4FC #x546E) + (#x8FB4FD #x5474) + (#x8FB4FE #x547F) + (#x8FB5A1 #x5481) + (#x8FB5A2 #x5483) + (#x8FB5A3 #x5485) + (#x8FB5A4 #x5488) + (#x8FB5A5 #x5489) + (#x8FB5A6 #x548D) + (#x8FB5A7 #x5491) + (#x8FB5A8 #x5495) + (#x8FB5A9 #x5496) + (#x8FB5AA #x549C) + (#x8FB5AB #x549F) + (#x8FB5AC #x54A1) + (#x8FB5AD #x54A6) + (#x8FB5AE #x54A7) + (#x8FB5AF #x54A9) + (#x8FB5B0 #x54AA) + (#x8FB5B1 #x54AD) + (#x8FB5B2 #x54AE) + (#x8FB5B3 #x54B1) + (#x8FB5B4 #x54B7) + (#x8FB5B5 #x54B9) + (#x8FB5B6 #x54BA) + (#x8FB5B7 #x54BB) + (#x8FB5B8 #x54BF) + (#x8FB5B9 #x54C6) + (#x8FB5BA #x54CA) + (#x8FB5BB #x54CD) + (#x8FB5BC #x54CE) + (#x8FB5BD #x54E0) + (#x8FB5BE #x54EA) + (#x8FB5BF #x54EC) + (#x8FB5C0 #x54EF) + (#x8FB5C1 #x54F6) + (#x8FB5C2 #x54FC) + (#x8FB5C3 #x54FE) + (#x8FB5C4 #x54FF) + (#x8FB5C5 #x5500) + (#x8FB5C6 #x5501) + (#x8FB5C7 #x5505) + (#x8FB5C8 #x5508) + (#x8FB5C9 #x5509) + (#x8FB5CA #x550C) + (#x8FB5CB #x550D) + (#x8FB5CC #x550E) + (#x8FB5CD #x5515) + (#x8FB5CE #x552A) + (#x8FB5CF #x552B) + (#x8FB5D0 #x5532) + (#x8FB5D1 #x5535) + (#x8FB5D2 #x5536) + (#x8FB5D3 #x553B) + (#x8FB5D4 #x553C) + (#x8FB5D5 #x553D) + (#x8FB5D6 #x5541) + (#x8FB5D7 #x5547) + (#x8FB5D8 #x5549) + (#x8FB5D9 #x554A) + (#x8FB5DA #x554D) + (#x8FB5DB #x5550) + (#x8FB5DC #x5551) + (#x8FB5DD #x5558) + (#x8FB5DE #x555A) + (#x8FB5DF #x555B) + (#x8FB5E0 #x555E) + (#x8FB5E1 #x5560) + (#x8FB5E2 #x5561) + (#x8FB5E3 #x5564) + (#x8FB5E4 #x5566) + (#x8FB5E5 #x557F) + (#x8FB5E6 #x5581) + (#x8FB5E7 #x5582) + (#x8FB5E8 #x5586) + (#x8FB5E9 #x5588) + (#x8FB5EA #x558E) + (#x8FB5EB #x558F) + (#x8FB5EC #x5591) + (#x8FB5ED #x5592) + (#x8FB5EE #x5593) + (#x8FB5EF #x5594) + (#x8FB5F0 #x5597) + (#x8FB5F1 #x55A3) + (#x8FB5F2 #x55A4) + (#x8FB5F3 #x55AD) + (#x8FB5F4 #x55B2) + (#x8FB5F5 #x55BF) + (#x8FB5F6 #x55C1) + (#x8FB5F7 #x55C3) + (#x8FB5F8 #x55C6) + (#x8FB5F9 #x55C9) + (#x8FB5FA #x55CB) + (#x8FB5FB #x55CC) + (#x8FB5FC #x55CE) + (#x8FB5FD #x55D1) + (#x8FB5FE #x55D2) + (#x8FB6A1 #x55D3) + (#x8FB6A2 #x55D7) + (#x8FB6A3 #x55D8) + (#x8FB6A4 #x55DB) + (#x8FB6A5 #x55DE) + (#x8FB6A6 #x55E2) + (#x8FB6A7 #x55E9) + (#x8FB6A8 #x55F6) + (#x8FB6A9 #x55FF) + (#x8FB6AA #x5605) + (#x8FB6AB #x5608) + (#x8FB6AC #x560A) + (#x8FB6AD #x560D) + (#x8FB6AE #x560E) + (#x8FB6AF #x560F) + (#x8FB6B0 #x5610) + (#x8FB6B1 #x5611) + (#x8FB6B2 #x5612) + (#x8FB6B3 #x5619) + (#x8FB6B4 #x562C) + (#x8FB6B5 #x5630) + (#x8FB6B6 #x5633) + (#x8FB6B7 #x5635) + (#x8FB6B8 #x5637) + (#x8FB6B9 #x5639) + (#x8FB6BA #x563B) + (#x8FB6BB #x563C) + (#x8FB6BC #x563D) + (#x8FB6BD #x563F) + (#x8FB6BE #x5640) + (#x8FB6BF #x5641) + (#x8FB6C0 #x5643) + (#x8FB6C1 #x5644) + (#x8FB6C2 #x5646) + (#x8FB6C3 #x5649) + (#x8FB6C4 #x564B) + (#x8FB6C5 #x564D) + (#x8FB6C6 #x564F) + (#x8FB6C7 #x5654) + (#x8FB6C8 #x565E) + (#x8FB6C9 #x5660) + (#x8FB6CA #x5661) + (#x8FB6CB #x5662) + (#x8FB6CC #x5663) + (#x8FB6CD #x5666) + (#x8FB6CE #x5669) + (#x8FB6CF #x566D) + (#x8FB6D0 #x566F) + (#x8FB6D1 #x5671) + (#x8FB6D2 #x5672) + (#x8FB6D3 #x5675) + (#x8FB6D4 #x5684) + (#x8FB6D5 #x5685) + (#x8FB6D6 #x5688) + (#x8FB6D7 #x568B) + (#x8FB6D8 #x568C) + (#x8FB6D9 #x5695) + (#x8FB6DA #x5699) + (#x8FB6DB #x569A) + (#x8FB6DC #x569D) + (#x8FB6DD #x569E) + (#x8FB6DE #x569F) + (#x8FB6DF #x56A6) + (#x8FB6E0 #x56A7) + (#x8FB6E1 #x56A8) + (#x8FB6E2 #x56A9) + (#x8FB6E3 #x56AB) + (#x8FB6E4 #x56AC) + (#x8FB6E5 #x56AD) + (#x8FB6E6 #x56B1) + (#x8FB6E7 #x56B3) + (#x8FB6E8 #x56B7) + (#x8FB6E9 #x56BE) + (#x8FB6EA #x56C5) + (#x8FB6EB #x56C9) + (#x8FB6EC #x56CA) + (#x8FB6ED #x56CB) + (#x8FB6EE #x56CF) + (#x8FB6EF #x56D0) + (#x8FB6F0 #x56CC) + (#x8FB6F1 #x56CD) + (#x8FB6F2 #x56D9) + (#x8FB6F3 #x56DC) + (#x8FB6F4 #x56DD) + (#x8FB6F5 #x56DF) + (#x8FB6F6 #x56E1) + (#x8FB6F7 #x56E4) + (#x8FB6F8 #x56E5) + (#x8FB6F9 #x56E6) + (#x8FB6FA #x56E7) + (#x8FB6FB #x56E8) + (#x8FB6FC #x56F1) + (#x8FB6FD #x56EB) + (#x8FB6FE #x56ED) + (#x8FB7A1 #x56F6) + (#x8FB7A2 #x56F7) + (#x8FB7A3 #x5701) + (#x8FB7A4 #x5702) + (#x8FB7A5 #x5707) + (#x8FB7A6 #x570A) + (#x8FB7A7 #x570C) + (#x8FB7A8 #x5711) + (#x8FB7A9 #x5715) + (#x8FB7AA #x571A) + (#x8FB7AB #x571B) + (#x8FB7AC #x571D) + (#x8FB7AD #x5720) + (#x8FB7AE #x5722) + (#x8FB7AF #x5723) + (#x8FB7B0 #x5724) + (#x8FB7B1 #x5725) + (#x8FB7B2 #x5729) + (#x8FB7B3 #x572A) + (#x8FB7B4 #x572C) + (#x8FB7B5 #x572E) + (#x8FB7B6 #x572F) + (#x8FB7B7 #x5733) + (#x8FB7B8 #x5734) + (#x8FB7B9 #x573D) + (#x8FB7BA #x573E) + (#x8FB7BB #x573F) + (#x8FB7BC #x5745) + (#x8FB7BD #x5746) + (#x8FB7BE #x574C) + (#x8FB7BF #x574D) + (#x8FB7C0 #x5752) + (#x8FB7C1 #x5762) + (#x8FB7C2 #x5765) + (#x8FB7C3 #x5767) + (#x8FB7C4 #x5768) + (#x8FB7C5 #x576B) + (#x8FB7C6 #x576D) + (#x8FB7C7 #x576E) + (#x8FB7C8 #x576F) + (#x8FB7C9 #x5770) + (#x8FB7CA #x5771) + (#x8FB7CB #x5773) + (#x8FB7CC #x5774) + (#x8FB7CD #x5775) + (#x8FB7CE #x5777) + (#x8FB7CF #x5779) + (#x8FB7D0 #x577A) + (#x8FB7D1 #x577B) + (#x8FB7D2 #x577C) + (#x8FB7D3 #x577E) + (#x8FB7D4 #x5781) + (#x8FB7D5 #x5783) + (#x8FB7D6 #x578C) + (#x8FB7D7 #x5794) + (#x8FB7D8 #x5797) + (#x8FB7D9 #x5799) + (#x8FB7DA #x579A) + (#x8FB7DB #x579C) + (#x8FB7DC #x579D) + (#x8FB7DD #x579E) + (#x8FB7DE #x579F) + (#x8FB7DF #x57A1) + (#x8FB7E0 #x5795) + (#x8FB7E1 #x57A7) + (#x8FB7E2 #x57A8) + (#x8FB7E3 #x57A9) + (#x8FB7E4 #x57AC) + (#x8FB7E5 #x57B8) + (#x8FB7E6 #x57BD) + (#x8FB7E7 #x57C7) + (#x8FB7E8 #x57C8) + (#x8FB7E9 #x57CC) + (#x8FB7EA #x57CF) + (#x8FB7EB #x57D5) + (#x8FB7EC #x57DD) + (#x8FB7ED #x57DE) + (#x8FB7EE #x57E4) + (#x8FB7EF #x57E6) + (#x8FB7F0 #x57E7) + (#x8FB7F1 #x57E9) + (#x8FB7F2 #x57ED) + (#x8FB7F3 #x57F0) + (#x8FB7F4 #x57F5) + (#x8FB7F5 #x57F6) + (#x8FB7F6 #x57F8) + (#x8FB7F7 #x57FD) + (#x8FB7F8 #x57FE) + (#x8FB7F9 #x57FF) + (#x8FB7FA #x5803) + (#x8FB7FB #x5804) + (#x8FB7FC #x5808) + (#x8FB7FD #x5809) + (#x8FB7FE #x57E1) + (#x8FB8A1 #x580C) + (#x8FB8A2 #x580D) + (#x8FB8A3 #x581B) + (#x8FB8A4 #x581E) + (#x8FB8A5 #x581F) + (#x8FB8A6 #x5820) + (#x8FB8A7 #x5826) + (#x8FB8A8 #x5827) + (#x8FB8A9 #x582D) + (#x8FB8AA #x5832) + (#x8FB8AB #x5839) + (#x8FB8AC #x583F) + (#x8FB8AD #x5849) + (#x8FB8AE #x584C) + (#x8FB8AF #x584D) + (#x8FB8B0 #x584F) + (#x8FB8B1 #x5850) + (#x8FB8B2 #x5855) + (#x8FB8B3 #x585F) + (#x8FB8B4 #x5861) + (#x8FB8B5 #x5864) + (#x8FB8B6 #x5867) + (#x8FB8B7 #x5868) + (#x8FB8B8 #x5878) + (#x8FB8B9 #x587C) + (#x8FB8BA #x587F) + (#x8FB8BB #x5880) + (#x8FB8BC #x5881) + (#x8FB8BD #x5887) + (#x8FB8BE #x5888) + (#x8FB8BF #x5889) + (#x8FB8C0 #x588A) + (#x8FB8C1 #x588C) + (#x8FB8C2 #x588D) + (#x8FB8C3 #x588F) + (#x8FB8C4 #x5890) + (#x8FB8C5 #x5894) + (#x8FB8C6 #x5896) + (#x8FB8C7 #x589D) + (#x8FB8C8 #x58A0) + (#x8FB8C9 #x58A1) + (#x8FB8CA #x58A2) + (#x8FB8CB #x58A6) + (#x8FB8CC #x58A9) + (#x8FB8CD #x58B1) + (#x8FB8CE #x58B2) + (#x8FB8CF #x58C4) + (#x8FB8D0 #x58BC) + (#x8FB8D1 #x58C2) + (#x8FB8D2 #x58C8) + (#x8FB8D3 #x58CD) + (#x8FB8D4 #x58CE) + (#x8FB8D5 #x58D0) + (#x8FB8D6 #x58D2) + (#x8FB8D7 #x58D4) + (#x8FB8D8 #x58D6) + (#x8FB8D9 #x58DA) + (#x8FB8DA #x58DD) + (#x8FB8DB #x58E1) + (#x8FB8DC #x58E2) + (#x8FB8DD #x58E9) + (#x8FB8DE #x58F3) + (#x8FB8DF #x5905) + (#x8FB8E0 #x5906) + (#x8FB8E1 #x590B) + (#x8FB8E2 #x590C) + (#x8FB8E3 #x5912) + (#x8FB8E4 #x5913) + (#x8FB8E5 #x5914) + (#x8FB8E6 #x8641) + (#x8FB8E7 #x591D) + (#x8FB8E8 #x5921) + (#x8FB8E9 #x5923) + (#x8FB8EA #x5924) + (#x8FB8EB #x5928) + (#x8FB8EC #x592F) + (#x8FB8ED #x5930) + (#x8FB8EE #x5933) + (#x8FB8EF #x5935) + (#x8FB8F0 #x5936) + (#x8FB8F1 #x593F) + (#x8FB8F2 #x5943) + (#x8FB8F3 #x5946) + (#x8FB8F4 #x5952) + (#x8FB8F5 #x5953) + (#x8FB8F6 #x5959) + (#x8FB8F7 #x595B) + (#x8FB8F8 #x595D) + (#x8FB8F9 #x595E) + (#x8FB8FA #x595F) + (#x8FB8FB #x5961) + (#x8FB8FC #x5963) + (#x8FB8FD #x596B) + (#x8FB8FE #x596D) + (#x8FB9A1 #x596F) + (#x8FB9A2 #x5972) + (#x8FB9A3 #x5975) + (#x8FB9A4 #x5976) + (#x8FB9A5 #x5979) + (#x8FB9A6 #x597B) + (#x8FB9A7 #x597C) + (#x8FB9A8 #x598B) + (#x8FB9A9 #x598C) + (#x8FB9AA #x598E) + (#x8FB9AB #x5992) + (#x8FB9AC #x5995) + (#x8FB9AD #x5997) + (#x8FB9AE #x599F) + (#x8FB9AF #x59A4) + (#x8FB9B0 #x59A7) + (#x8FB9B1 #x59AD) + (#x8FB9B2 #x59AE) + (#x8FB9B3 #x59AF) + (#x8FB9B4 #x59B0) + (#x8FB9B5 #x59B3) + (#x8FB9B6 #x59B7) + (#x8FB9B7 #x59BA) + (#x8FB9B8 #x59BC) + (#x8FB9B9 #x59C1) + (#x8FB9BA #x59C3) + (#x8FB9BB #x59C4) + (#x8FB9BC #x59C8) + (#x8FB9BD #x59CA) + (#x8FB9BE #x59CD) + (#x8FB9BF #x59D2) + (#x8FB9C0 #x59DD) + (#x8FB9C1 #x59DE) + (#x8FB9C2 #x59DF) + (#x8FB9C3 #x59E3) + (#x8FB9C4 #x59E4) + (#x8FB9C5 #x59E7) + (#x8FB9C6 #x59EE) + (#x8FB9C7 #x59EF) + (#x8FB9C8 #x59F1) + (#x8FB9C9 #x59F2) + (#x8FB9CA #x59F4) + (#x8FB9CB #x59F7) + (#x8FB9CC #x5A00) + (#x8FB9CD #x5A04) + (#x8FB9CE #x5A0C) + (#x8FB9CF #x5A0D) + (#x8FB9D0 #x5A0E) + (#x8FB9D1 #x5A12) + (#x8FB9D2 #x5A13) + (#x8FB9D3 #x5A1E) + (#x8FB9D4 #x5A23) + (#x8FB9D5 #x5A24) + (#x8FB9D6 #x5A27) + (#x8FB9D7 #x5A28) + (#x8FB9D8 #x5A2A) + (#x8FB9D9 #x5A2D) + (#x8FB9DA #x5A30) + (#x8FB9DB #x5A44) + (#x8FB9DC #x5A45) + (#x8FB9DD #x5A47) + (#x8FB9DE #x5A48) + (#x8FB9DF #x5A4C) + (#x8FB9E0 #x5A50) + (#x8FB9E1 #x5A55) + (#x8FB9E2 #x5A5E) + (#x8FB9E3 #x5A63) + (#x8FB9E4 #x5A65) + (#x8FB9E5 #x5A67) + (#x8FB9E6 #x5A6D) + (#x8FB9E7 #x5A77) + (#x8FB9E8 #x5A7A) + (#x8FB9E9 #x5A7B) + (#x8FB9EA #x5A7E) + (#x8FB9EB #x5A8B) + (#x8FB9EC #x5A90) + (#x8FB9ED #x5A93) + (#x8FB9EE #x5A96) + (#x8FB9EF #x5A99) + (#x8FB9F0 #x5A9C) + (#x8FB9F1 #x5A9E) + (#x8FB9F2 #x5A9F) + (#x8FB9F3 #x5AA0) + (#x8FB9F4 #x5AA2) + (#x8FB9F5 #x5AA7) + (#x8FB9F6 #x5AAC) + (#x8FB9F7 #x5AB1) + (#x8FB9F8 #x5AB2) + (#x8FB9F9 #x5AB3) + (#x8FB9FA #x5AB5) + (#x8FB9FB #x5AB8) + (#x8FB9FC #x5ABA) + (#x8FB9FD #x5ABB) + (#x8FB9FE #x5ABF) + (#x8FBAA1 #x5AC4) + (#x8FBAA2 #x5AC6) + (#x8FBAA3 #x5AC8) + (#x8FBAA4 #x5ACF) + (#x8FBAA5 #x5ADA) + (#x8FBAA6 #x5ADC) + (#x8FBAA7 #x5AE0) + (#x8FBAA8 #x5AE5) + (#x8FBAA9 #x5AEA) + (#x8FBAAA #x5AEE) + (#x8FBAAB #x5AF5) + (#x8FBAAC #x5AF6) + (#x8FBAAD #x5AFD) + (#x8FBAAE #x5B00) + (#x8FBAAF #x5B01) + (#x8FBAB0 #x5B08) + (#x8FBAB1 #x5B17) + (#x8FBAB2 #x5B34) + (#x8FBAB3 #x5B19) + (#x8FBAB4 #x5B1B) + (#x8FBAB5 #x5B1D) + (#x8FBAB6 #x5B21) + (#x8FBAB7 #x5B25) + (#x8FBAB8 #x5B2D) + (#x8FBAB9 #x5B38) + (#x8FBABA #x5B41) + (#x8FBABB #x5B4B) + (#x8FBABC #x5B4C) + (#x8FBABD #x5B52) + (#x8FBABE #x5B56) + (#x8FBABF #x5B5E) + (#x8FBAC0 #x5B68) + (#x8FBAC1 #x5B6E) + (#x8FBAC2 #x5B6F) + (#x8FBAC3 #x5B7C) + (#x8FBAC4 #x5B7D) + (#x8FBAC5 #x5B7E) + (#x8FBAC6 #x5B7F) + (#x8FBAC7 #x5B81) + (#x8FBAC8 #x5B84) + (#x8FBAC9 #x5B86) + (#x8FBACA #x5B8A) + (#x8FBACB #x5B8E) + (#x8FBACC #x5B90) + (#x8FBACD #x5B91) + (#x8FBACE #x5B93) + (#x8FBACF #x5B94) + (#x8FBAD0 #x5B96) + (#x8FBAD1 #x5BA8) + (#x8FBAD2 #x5BA9) + (#x8FBAD3 #x5BAC) + (#x8FBAD4 #x5BAD) + (#x8FBAD5 #x5BAF) + (#x8FBAD6 #x5BB1) + (#x8FBAD7 #x5BB2) + (#x8FBAD8 #x5BB7) + (#x8FBAD9 #x5BBA) + (#x8FBADA #x5BBC) + (#x8FBADB #x5BC0) + (#x8FBADC #x5BC1) + (#x8FBADD #x5BCD) + (#x8FBADE #x5BCF) + (#x8FBADF #x5BD6) + (#x8FBAE0 #x5BD7) + (#x8FBAE1 #x5BD8) + (#x8FBAE2 #x5BD9) + (#x8FBAE3 #x5BDA) + (#x8FBAE4 #x5BE0) + (#x8FBAE5 #x5BEF) + (#x8FBAE6 #x5BF1) + (#x8FBAE7 #x5BF4) + (#x8FBAE8 #x5BFD) + (#x8FBAE9 #x5C0C) + (#x8FBAEA #x5C17) + (#x8FBAEB #x5C1E) + (#x8FBAEC #x5C1F) + (#x8FBAED #x5C23) + (#x8FBAEE #x5C26) + (#x8FBAEF #x5C29) + (#x8FBAF0 #x5C2B) + (#x8FBAF1 #x5C2C) + (#x8FBAF2 #x5C2E) + (#x8FBAF3 #x5C30) + (#x8FBAF4 #x5C32) + (#x8FBAF5 #x5C35) + (#x8FBAF6 #x5C36) + (#x8FBAF7 #x5C59) + (#x8FBAF8 #x5C5A) + (#x8FBAF9 #x5C5C) + (#x8FBAFA #x5C62) + (#x8FBAFB #x5C63) + (#x8FBAFC #x5C67) + (#x8FBAFD #x5C68) + (#x8FBAFE #x5C69) + (#x8FBBA1 #x5C6D) + (#x8FBBA2 #x5C70) + (#x8FBBA3 #x5C74) + (#x8FBBA4 #x5C75) + (#x8FBBA5 #x5C7A) + (#x8FBBA6 #x5C7B) + (#x8FBBA7 #x5C7C) + (#x8FBBA8 #x5C7D) + (#x8FBBA9 #x5C87) + (#x8FBBAA #x5C88) + (#x8FBBAB #x5C8A) + (#x8FBBAC #x5C8F) + (#x8FBBAD #x5C92) + (#x8FBBAE #x5C9D) + (#x8FBBAF #x5C9F) + (#x8FBBB0 #x5CA0) + (#x8FBBB1 #x5CA2) + (#x8FBBB2 #x5CA3) + (#x8FBBB3 #x5CA6) + (#x8FBBB4 #x5CAA) + (#x8FBBB5 #x5CB2) + (#x8FBBB6 #x5CB4) + (#x8FBBB7 #x5CB5) + (#x8FBBB8 #x5CBA) + (#x8FBBB9 #x5CC9) + (#x8FBBBA #x5CCB) + (#x8FBBBB #x5CD2) + (#x8FBBBC #x5CDD) + (#x8FBBBD #x5CD7) + (#x8FBBBE #x5CEE) + (#x8FBBBF #x5CF1) + (#x8FBBC0 #x5CF2) + (#x8FBBC1 #x5CF4) + (#x8FBBC2 #x5D01) + (#x8FBBC3 #x5D06) + (#x8FBBC4 #x5D0D) + (#x8FBBC5 #x5D12) + (#x8FBBC6 #x5D2B) + (#x8FBBC7 #x5D23) + (#x8FBBC8 #x5D24) + (#x8FBBC9 #x5D26) + (#x8FBBCA #x5D27) + (#x8FBBCB #x5D31) + (#x8FBBCC #x5D34) + (#x8FBBCD #x5D39) + (#x8FBBCE #x5D3D) + (#x8FBBCF #x5D3F) + (#x8FBBD0 #x5D42) + (#x8FBBD1 #x5D43) + (#x8FBBD2 #x5D46) + (#x8FBBD3 #x5D48) + (#x8FBBD4 #x5D55) + (#x8FBBD5 #x5D51) + (#x8FBBD6 #x5D59) + (#x8FBBD7 #x5D4A) + (#x8FBBD8 #x5D5F) + (#x8FBBD9 #x5D60) + (#x8FBBDA #x5D61) + (#x8FBBDB #x5D62) + (#x8FBBDC #x5D64) + (#x8FBBDD #x5D6A) + (#x8FBBDE #x5D6D) + (#x8FBBDF #x5D70) + (#x8FBBE0 #x5D79) + (#x8FBBE1 #x5D7A) + (#x8FBBE2 #x5D7E) + (#x8FBBE3 #x5D7F) + (#x8FBBE4 #x5D81) + (#x8FBBE5 #x5D83) + (#x8FBBE6 #x5D88) + (#x8FBBE7 #x5D8A) + (#x8FBBE8 #x5D92) + (#x8FBBE9 #x5D93) + (#x8FBBEA #x5D94) + (#x8FBBEB #x5D95) + (#x8FBBEC #x5D99) + (#x8FBBED #x5D9B) + (#x8FBBEE #x5D9F) + (#x8FBBEF #x5DA0) + (#x8FBBF0 #x5DA7) + (#x8FBBF1 #x5DAB) + (#x8FBBF2 #x5DB0) + (#x8FBBF3 #x5DB4) + (#x8FBBF4 #x5DB8) + (#x8FBBF5 #x5DB9) + (#x8FBBF6 #x5DC3) + (#x8FBBF7 #x5DC7) + (#x8FBBF8 #x5DCB) + (#x8FBBF9 #x5DD0) + (#x8FBBFA #x5DCE) + (#x8FBBFB #x5DD8) + (#x8FBBFC #x5DD9) + (#x8FBBFD #x5DE0) + (#x8FBBFE #x5DE4) + (#x8FBCA1 #x5DE9) + (#x8FBCA2 #x5DF8) + (#x8FBCA3 #x5DF9) + (#x8FBCA4 #x5E00) + (#x8FBCA5 #x5E07) + (#x8FBCA6 #x5E0D) + (#x8FBCA7 #x5E12) + (#x8FBCA8 #x5E14) + (#x8FBCA9 #x5E15) + (#x8FBCAA #x5E18) + (#x8FBCAB #x5E1F) + (#x8FBCAC #x5E20) + (#x8FBCAD #x5E2E) + (#x8FBCAE #x5E28) + (#x8FBCAF #x5E32) + (#x8FBCB0 #x5E35) + (#x8FBCB1 #x5E3E) + (#x8FBCB2 #x5E4B) + (#x8FBCB3 #x5E50) + (#x8FBCB4 #x5E49) + (#x8FBCB5 #x5E51) + (#x8FBCB6 #x5E56) + (#x8FBCB7 #x5E58) + (#x8FBCB8 #x5E5B) + (#x8FBCB9 #x5E5C) + (#x8FBCBA #x5E5E) + (#x8FBCBB #x5E68) + (#x8FBCBC #x5E6A) + (#x8FBCBD #x5E6B) + (#x8FBCBE #x5E6C) + (#x8FBCBF #x5E6D) + (#x8FBCC0 #x5E6E) + (#x8FBCC1 #x5E70) + (#x8FBCC2 #x5E80) + (#x8FBCC3 #x5E8B) + (#x8FBCC4 #x5E8E) + (#x8FBCC5 #x5EA2) + (#x8FBCC6 #x5EA4) + (#x8FBCC7 #x5EA5) + (#x8FBCC8 #x5EA8) + (#x8FBCC9 #x5EAA) + (#x8FBCCA #x5EAC) + (#x8FBCCB #x5EB1) + (#x8FBCCC #x5EB3) + (#x8FBCCD #x5EBD) + (#x8FBCCE #x5EBE) + (#x8FBCCF #x5EBF) + (#x8FBCD0 #x5EC6) + (#x8FBCD1 #x5ECC) + (#x8FBCD2 #x5ECB) + (#x8FBCD3 #x5ECE) + (#x8FBCD4 #x5ED1) + (#x8FBCD5 #x5ED2) + (#x8FBCD6 #x5ED4) + (#x8FBCD7 #x5ED5) + (#x8FBCD8 #x5EDC) + (#x8FBCD9 #x5EDE) + (#x8FBCDA #x5EE5) + (#x8FBCDB #x5EEB) + (#x8FBCDC #x5F02) + (#x8FBCDD #x5F06) + (#x8FBCDE #x5F07) + (#x8FBCDF #x5F08) + (#x8FBCE0 #x5F0E) + (#x8FBCE1 #x5F19) + (#x8FBCE2 #x5F1C) + (#x8FBCE3 #x5F1D) + (#x8FBCE4 #x5F21) + (#x8FBCE5 #x5F22) + (#x8FBCE6 #x5F23) + (#x8FBCE7 #x5F24) + (#x8FBCE8 #x5F28) + (#x8FBCE9 #x5F2B) + (#x8FBCEA #x5F2C) + (#x8FBCEB #x5F2E) + (#x8FBCEC #x5F30) + (#x8FBCED #x5F34) + (#x8FBCEE #x5F36) + (#x8FBCEF #x5F3B) + (#x8FBCF0 #x5F3D) + (#x8FBCF1 #x5F3F) + (#x8FBCF2 #x5F40) + (#x8FBCF3 #x5F44) + (#x8FBCF4 #x5F45) + (#x8FBCF5 #x5F47) + (#x8FBCF6 #x5F4D) + (#x8FBCF7 #x5F50) + (#x8FBCF8 #x5F54) + (#x8FBCF9 #x5F58) + (#x8FBCFA #x5F5B) + (#x8FBCFB #x5F60) + (#x8FBCFC #x5F63) + (#x8FBCFD #x5F64) + (#x8FBCFE #x5F67) + (#x8FBDA1 #x5F6F) + (#x8FBDA2 #x5F72) + (#x8FBDA3 #x5F74) + (#x8FBDA4 #x5F75) + (#x8FBDA5 #x5F78) + (#x8FBDA6 #x5F7A) + (#x8FBDA7 #x5F7D) + (#x8FBDA8 #x5F7E) + (#x8FBDA9 #x5F89) + (#x8FBDAA #x5F8D) + (#x8FBDAB #x5F8F) + (#x8FBDAC #x5F96) + (#x8FBDAD #x5F9C) + (#x8FBDAE #x5F9D) + (#x8FBDAF #x5FA2) + (#x8FBDB0 #x5FA7) + (#x8FBDB1 #x5FAB) + (#x8FBDB2 #x5FA4) + (#x8FBDB3 #x5FAC) + (#x8FBDB4 #x5FAF) + (#x8FBDB5 #x5FB0) + (#x8FBDB6 #x5FB1) + (#x8FBDB7 #x5FB8) + (#x8FBDB8 #x5FC4) + (#x8FBDB9 #x5FC7) + (#x8FBDBA #x5FC8) + (#x8FBDBB #x5FC9) + (#x8FBDBC #x5FCB) + (#x8FBDBD #x5FD0) + (#x8FBDBE #x5FD1) + (#x8FBDBF #x5FD2) + (#x8FBDC0 #x5FD3) + (#x8FBDC1 #x5FD4) + (#x8FBDC2 #x5FDE) + (#x8FBDC3 #x5FE1) + (#x8FBDC4 #x5FE2) + (#x8FBDC5 #x5FE8) + (#x8FBDC6 #x5FE9) + (#x8FBDC7 #x5FEA) + (#x8FBDC8 #x5FEC) + (#x8FBDC9 #x5FED) + (#x8FBDCA #x5FEE) + (#x8FBDCB #x5FEF) + (#x8FBDCC #x5FF2) + (#x8FBDCD #x5FF3) + (#x8FBDCE #x5FF6) + (#x8FBDCF #x5FFA) + (#x8FBDD0 #x5FFC) + (#x8FBDD1 #x6007) + (#x8FBDD2 #x600A) + (#x8FBDD3 #x600D) + (#x8FBDD4 #x6013) + (#x8FBDD5 #x6014) + (#x8FBDD6 #x6017) + (#x8FBDD7 #x6018) + (#x8FBDD8 #x601A) + (#x8FBDD9 #x601F) + (#x8FBDDA #x6024) + (#x8FBDDB #x602D) + (#x8FBDDC #x6033) + (#x8FBDDD #x6035) + (#x8FBDDE #x6040) + (#x8FBDDF #x6047) + (#x8FBDE0 #x6048) + (#x8FBDE1 #x6049) + (#x8FBDE2 #x604C) + (#x8FBDE3 #x6051) + (#x8FBDE4 #x6054) + (#x8FBDE5 #x6056) + (#x8FBDE6 #x6057) + (#x8FBDE7 #x605D) + (#x8FBDE8 #x6061) + (#x8FBDE9 #x6067) + (#x8FBDEA #x6071) + (#x8FBDEB #x607E) + (#x8FBDEC #x607F) + (#x8FBDED #x6082) + (#x8FBDEE #x6086) + (#x8FBDEF #x6088) + (#x8FBDF0 #x608A) + (#x8FBDF1 #x608E) + (#x8FBDF2 #x6091) + (#x8FBDF3 #x6093) + (#x8FBDF4 #x6095) + (#x8FBDF5 #x6098) + (#x8FBDF6 #x609D) + (#x8FBDF7 #x609E) + (#x8FBDF8 #x60A2) + (#x8FBDF9 #x60A4) + (#x8FBDFA #x60A5) + (#x8FBDFB #x60A8) + (#x8FBDFC #x60B0) + (#x8FBDFD #x60B1) + (#x8FBDFE #x60B7) + (#x8FBEA1 #x60BB) + (#x8FBEA2 #x60BE) + (#x8FBEA3 #x60C2) + (#x8FBEA4 #x60C4) + (#x8FBEA5 #x60C8) + (#x8FBEA6 #x60C9) + (#x8FBEA7 #x60CA) + (#x8FBEA8 #x60CB) + (#x8FBEA9 #x60CE) + (#x8FBEAA #x60CF) + (#x8FBEAB #x60D4) + (#x8FBEAC #x60D5) + (#x8FBEAD #x60D9) + (#x8FBEAE #x60DB) + (#x8FBEAF #x60DD) + (#x8FBEB0 #x60DE) + (#x8FBEB1 #x60E2) + (#x8FBEB2 #x60E5) + (#x8FBEB3 #x60F2) + (#x8FBEB4 #x60F5) + (#x8FBEB5 #x60F8) + (#x8FBEB6 #x60FC) + (#x8FBEB7 #x60FD) + (#x8FBEB8 #x6102) + (#x8FBEB9 #x6107) + (#x8FBEBA #x610A) + (#x8FBEBB #x610C) + (#x8FBEBC #x6110) + (#x8FBEBD #x6111) + (#x8FBEBE #x6112) + (#x8FBEBF #x6113) + (#x8FBEC0 #x6114) + (#x8FBEC1 #x6116) + (#x8FBEC2 #x6117) + (#x8FBEC3 #x6119) + (#x8FBEC4 #x611C) + (#x8FBEC5 #x611E) + (#x8FBEC6 #x6122) + (#x8FBEC7 #x612A) + (#x8FBEC8 #x612B) + (#x8FBEC9 #x6130) + (#x8FBECA #x6131) + (#x8FBECB #x6135) + (#x8FBECC #x6136) + (#x8FBECD #x6137) + (#x8FBECE #x6139) + (#x8FBECF #x6141) + (#x8FBED0 #x6145) + (#x8FBED1 #x6146) + (#x8FBED2 #x6149) + (#x8FBED3 #x615E) + (#x8FBED4 #x6160) + (#x8FBED5 #x616C) + (#x8FBED6 #x6172) + (#x8FBED7 #x6178) + (#x8FBED8 #x617B) + (#x8FBED9 #x617C) + (#x8FBEDA #x617F) + (#x8FBEDB #x6180) + (#x8FBEDC #x6181) + (#x8FBEDD #x6183) + (#x8FBEDE #x6184) + (#x8FBEDF #x618B) + (#x8FBEE0 #x618D) + (#x8FBEE1 #x6192) + (#x8FBEE2 #x6193) + (#x8FBEE3 #x6197) + (#x8FBEE4 #x6198) + (#x8FBEE5 #x619C) + (#x8FBEE6 #x619D) + (#x8FBEE7 #x619F) + (#x8FBEE8 #x61A0) + (#x8FBEE9 #x61A5) + (#x8FBEEA #x61A8) + (#x8FBEEB #x61AA) + (#x8FBEEC #x61AD) + (#x8FBEED #x61B8) + (#x8FBEEE #x61B9) + (#x8FBEEF #x61BC) + (#x8FBEF0 #x61C0) + (#x8FBEF1 #x61C1) + (#x8FBEF2 #x61C2) + (#x8FBEF3 #x61CE) + (#x8FBEF4 #x61CF) + (#x8FBEF5 #x61D5) + (#x8FBEF6 #x61DC) + (#x8FBEF7 #x61DD) + (#x8FBEF8 #x61DE) + (#x8FBEF9 #x61DF) + (#x8FBEFA #x61E1) + (#x8FBEFB #x61E2) + (#x8FBEFC #x61E7) + (#x8FBEFD #x61E9) + (#x8FBEFE #x61E5) + (#x8FBFA1 #x61EC) + (#x8FBFA2 #x61ED) + (#x8FBFA3 #x61EF) + (#x8FBFA4 #x6201) + (#x8FBFA5 #x6203) + (#x8FBFA6 #x6204) + (#x8FBFA7 #x6207) + (#x8FBFA8 #x6213) + (#x8FBFA9 #x6215) + (#x8FBFAA #x621C) + (#x8FBFAB #x6220) + (#x8FBFAC #x6222) + (#x8FBFAD #x6223) + (#x8FBFAE #x6227) + (#x8FBFAF #x6229) + (#x8FBFB0 #x622B) + (#x8FBFB1 #x6239) + (#x8FBFB2 #x623D) + (#x8FBFB3 #x6242) + (#x8FBFB4 #x6243) + (#x8FBFB5 #x6244) + (#x8FBFB6 #x6246) + (#x8FBFB7 #x624C) + (#x8FBFB8 #x6250) + (#x8FBFB9 #x6251) + (#x8FBFBA #x6252) + (#x8FBFBB #x6254) + (#x8FBFBC #x6256) + (#x8FBFBD #x625A) + (#x8FBFBE #x625C) + (#x8FBFBF #x6264) + (#x8FBFC0 #x626D) + (#x8FBFC1 #x626F) + (#x8FBFC2 #x6273) + (#x8FBFC3 #x627A) + (#x8FBFC4 #x627D) + (#x8FBFC5 #x628D) + (#x8FBFC6 #x628E) + (#x8FBFC7 #x628F) + (#x8FBFC8 #x6290) + (#x8FBFC9 #x62A6) + (#x8FBFCA #x62A8) + (#x8FBFCB #x62B3) + (#x8FBFCC #x62B6) + (#x8FBFCD #x62B7) + (#x8FBFCE #x62BA) + (#x8FBFCF #x62BE) + (#x8FBFD0 #x62BF) + (#x8FBFD1 #x62C4) + (#x8FBFD2 #x62CE) + (#x8FBFD3 #x62D5) + (#x8FBFD4 #x62D6) + (#x8FBFD5 #x62DA) + (#x8FBFD6 #x62EA) + (#x8FBFD7 #x62F2) + (#x8FBFD8 #x62F4) + (#x8FBFD9 #x62FC) + (#x8FBFDA #x62FD) + (#x8FBFDB #x6303) + (#x8FBFDC #x6304) + (#x8FBFDD #x630A) + (#x8FBFDE #x630B) + (#x8FBFDF #x630D) + (#x8FBFE0 #x6310) + (#x8FBFE1 #x6313) + (#x8FBFE2 #x6316) + (#x8FBFE3 #x6318) + (#x8FBFE4 #x6329) + (#x8FBFE5 #x632A) + (#x8FBFE6 #x632D) + (#x8FBFE7 #x6335) + (#x8FBFE8 #x6336) + (#x8FBFE9 #x6339) + (#x8FBFEA #x633C) + (#x8FBFEB #x6341) + (#x8FBFEC #x6342) + (#x8FBFED #x6343) + (#x8FBFEE #x6344) + (#x8FBFEF #x6346) + (#x8FBFF0 #x634A) + (#x8FBFF1 #x634B) + (#x8FBFF2 #x634E) + (#x8FBFF3 #x6352) + (#x8FBFF4 #x6353) + (#x8FBFF5 #x6354) + (#x8FBFF6 #x6358) + (#x8FBFF7 #x635B) + (#x8FBFF8 #x6365) + (#x8FBFF9 #x6366) + (#x8FBFFA #x636C) + (#x8FBFFB #x636D) + (#x8FBFFC #x6371) + (#x8FBFFD #x6374) + (#x8FBFFE #x6375) + (#x8FC0A1 #x6378) + (#x8FC0A2 #x637C) + (#x8FC0A3 #x637D) + (#x8FC0A4 #x637F) + (#x8FC0A5 #x6382) + (#x8FC0A6 #x6384) + (#x8FC0A7 #x6387) + (#x8FC0A8 #x638A) + (#x8FC0A9 #x6390) + (#x8FC0AA #x6394) + (#x8FC0AB #x6395) + (#x8FC0AC #x6399) + (#x8FC0AD #x639A) + (#x8FC0AE #x639E) + (#x8FC0AF #x63A4) + (#x8FC0B0 #x63A6) + (#x8FC0B1 #x63AD) + (#x8FC0B2 #x63AE) + (#x8FC0B3 #x63AF) + (#x8FC0B4 #x63BD) + (#x8FC0B5 #x63C1) + (#x8FC0B6 #x63C5) + (#x8FC0B7 #x63C8) + (#x8FC0B8 #x63CE) + (#x8FC0B9 #x63D1) + (#x8FC0BA #x63D3) + (#x8FC0BB #x63D4) + (#x8FC0BC #x63D5) + (#x8FC0BD #x63DC) + (#x8FC0BE #x63E0) + (#x8FC0BF #x63E5) + (#x8FC0C0 #x63EA) + (#x8FC0C1 #x63EC) + (#x8FC0C2 #x63F2) + (#x8FC0C3 #x63F3) + (#x8FC0C4 #x63F5) + (#x8FC0C5 #x63F8) + (#x8FC0C6 #x63F9) + (#x8FC0C7 #x6409) + (#x8FC0C8 #x640A) + (#x8FC0C9 #x6410) + (#x8FC0CA #x6412) + (#x8FC0CB #x6414) + (#x8FC0CC #x6418) + (#x8FC0CD #x641E) + (#x8FC0CE #x6420) + (#x8FC0CF #x6422) + (#x8FC0D0 #x6424) + (#x8FC0D1 #x6425) + (#x8FC0D2 #x6429) + (#x8FC0D3 #x642A) + (#x8FC0D4 #x642F) + (#x8FC0D5 #x6430) + (#x8FC0D6 #x6435) + (#x8FC0D7 #x643D) + (#x8FC0D8 #x643F) + (#x8FC0D9 #x644B) + (#x8FC0DA #x644F) + (#x8FC0DB #x6451) + (#x8FC0DC #x6452) + (#x8FC0DD #x6453) + (#x8FC0DE #x6454) + (#x8FC0DF #x645A) + (#x8FC0E0 #x645B) + (#x8FC0E1 #x645C) + (#x8FC0E2 #x645D) + (#x8FC0E3 #x645F) + (#x8FC0E4 #x6460) + (#x8FC0E5 #x6461) + (#x8FC0E6 #x6463) + (#x8FC0E7 #x646D) + (#x8FC0E8 #x6473) + (#x8FC0E9 #x6474) + (#x8FC0EA #x647B) + (#x8FC0EB #x647D) + (#x8FC0EC #x6485) + (#x8FC0ED #x6487) + (#x8FC0EE #x648F) + (#x8FC0EF #x6490) + (#x8FC0F0 #x6491) + (#x8FC0F1 #x6498) + (#x8FC0F2 #x6499) + (#x8FC0F3 #x649B) + (#x8FC0F4 #x649D) + (#x8FC0F5 #x649F) + (#x8FC0F6 #x64A1) + (#x8FC0F7 #x64A3) + (#x8FC0F8 #x64A6) + (#x8FC0F9 #x64A8) + (#x8FC0FA #x64AC) + (#x8FC0FB #x64B3) + (#x8FC0FC #x64BD) + (#x8FC0FD #x64BE) + (#x8FC0FE #x64BF) + (#x8FC1A1 #x64C4) + (#x8FC1A2 #x64C9) + (#x8FC1A3 #x64CA) + (#x8FC1A4 #x64CB) + (#x8FC1A5 #x64CC) + (#x8FC1A6 #x64CE) + (#x8FC1A7 #x64D0) + (#x8FC1A8 #x64D1) + (#x8FC1A9 #x64D5) + (#x8FC1AA #x64D7) + (#x8FC1AB #x64E4) + (#x8FC1AC #x64E5) + (#x8FC1AD #x64E9) + (#x8FC1AE #x64EA) + (#x8FC1AF #x64ED) + (#x8FC1B0 #x64F0) + (#x8FC1B1 #x64F5) + (#x8FC1B2 #x64F7) + (#x8FC1B3 #x64FB) + (#x8FC1B4 #x64FF) + (#x8FC1B5 #x6501) + (#x8FC1B6 #x6504) + (#x8FC1B7 #x6508) + (#x8FC1B8 #x6509) + (#x8FC1B9 #x650A) + (#x8FC1BA #x650F) + (#x8FC1BB #x6513) + (#x8FC1BC #x6514) + (#x8FC1BD #x6516) + (#x8FC1BE #x6519) + (#x8FC1BF #x651B) + (#x8FC1C0 #x651E) + (#x8FC1C1 #x651F) + (#x8FC1C2 #x6522) + (#x8FC1C3 #x6526) + (#x8FC1C4 #x6529) + (#x8FC1C5 #x652E) + (#x8FC1C6 #x6531) + (#x8FC1C7 #x653A) + (#x8FC1C8 #x653C) + (#x8FC1C9 #x653D) + (#x8FC1CA #x6543) + (#x8FC1CB #x6547) + (#x8FC1CC #x6549) + (#x8FC1CD #x6550) + (#x8FC1CE #x6552) + (#x8FC1CF #x6554) + (#x8FC1D0 #x655F) + (#x8FC1D1 #x6560) + (#x8FC1D2 #x6567) + (#x8FC1D3 #x656B) + (#x8FC1D4 #x657A) + (#x8FC1D5 #x657D) + (#x8FC1D6 #x6581) + (#x8FC1D7 #x6585) + (#x8FC1D8 #x658A) + (#x8FC1D9 #x6592) + (#x8FC1DA #x6595) + (#x8FC1DB #x6598) + (#x8FC1DC #x659D) + (#x8FC1DD #x65A0) + (#x8FC1DE #x65A3) + (#x8FC1DF #x65A6) + (#x8FC1E0 #x65AE) + (#x8FC1E1 #x65B2) + (#x8FC1E2 #x65B3) + (#x8FC1E3 #x65B4) + (#x8FC1E4 #x65BF) + (#x8FC1E5 #x65C2) + (#x8FC1E6 #x65C8) + (#x8FC1E7 #x65C9) + (#x8FC1E8 #x65CE) + (#x8FC1E9 #x65D0) + (#x8FC1EA #x65D4) + (#x8FC1EB #x65D6) + (#x8FC1EC #x65D8) + (#x8FC1ED #x65DF) + (#x8FC1EE #x65F0) + (#x8FC1EF #x65F2) + (#x8FC1F0 #x65F4) + (#x8FC1F1 #x65F5) + (#x8FC1F2 #x65F9) + (#x8FC1F3 #x65FE) + (#x8FC1F4 #x65FF) + (#x8FC1F5 #x6600) + (#x8FC1F6 #x6604) + (#x8FC1F7 #x6608) + (#x8FC1F8 #x6609) + (#x8FC1F9 #x660D) + (#x8FC1FA #x6611) + (#x8FC1FB #x6612) + (#x8FC1FC #x6615) + (#x8FC1FD #x6616) + (#x8FC1FE #x661D) + (#x8FC2A1 #x661E) + (#x8FC2A2 #x6621) + (#x8FC2A3 #x6622) + (#x8FC2A4 #x6623) + (#x8FC2A5 #x6624) + (#x8FC2A6 #x6626) + (#x8FC2A7 #x6629) + (#x8FC2A8 #x662A) + (#x8FC2A9 #x662B) + (#x8FC2AA #x662C) + (#x8FC2AB #x662E) + (#x8FC2AC #x6630) + (#x8FC2AD #x6631) + (#x8FC2AE #x6633) + (#x8FC2AF #x6639) + (#x8FC2B0 #x6637) + (#x8FC2B1 #x6640) + (#x8FC2B2 #x6645) + (#x8FC2B3 #x6646) + (#x8FC2B4 #x664A) + (#x8FC2B5 #x664C) + (#x8FC2B6 #x6651) + (#x8FC2B7 #x664E) + (#x8FC2B8 #x6657) + (#x8FC2B9 #x6658) + (#x8FC2BA #x6659) + (#x8FC2BB #x665B) + (#x8FC2BC #x665C) + (#x8FC2BD #x6660) + (#x8FC2BE #x6661) + (#x8FC2BF #x66FB) + (#x8FC2C0 #x666A) + (#x8FC2C1 #x666B) + (#x8FC2C2 #x666C) + (#x8FC2C3 #x667E) + (#x8FC2C4 #x6673) + (#x8FC2C5 #x6675) + (#x8FC2C6 #x667F) + (#x8FC2C7 #x6677) + (#x8FC2C8 #x6678) + (#x8FC2C9 #x6679) + (#x8FC2CA #x667B) + (#x8FC2CB #x6680) + (#x8FC2CC #x667C) + (#x8FC2CD #x668B) + (#x8FC2CE #x668C) + (#x8FC2CF #x668D) + (#x8FC2D0 #x6690) + (#x8FC2D1 #x6692) + (#x8FC2D2 #x6699) + (#x8FC2D3 #x669A) + (#x8FC2D4 #x669B) + (#x8FC2D5 #x669C) + (#x8FC2D6 #x669F) + (#x8FC2D7 #x66A0) + (#x8FC2D8 #x66A4) + (#x8FC2D9 #x66AD) + (#x8FC2DA #x66B1) + (#x8FC2DB #x66B2) + (#x8FC2DC #x66B5) + (#x8FC2DD #x66BB) + (#x8FC2DE #x66BF) + (#x8FC2DF #x66C0) + (#x8FC2E0 #x66C2) + (#x8FC2E1 #x66C3) + (#x8FC2E2 #x66C8) + (#x8FC2E3 #x66CC) + (#x8FC2E4 #x66CE) + (#x8FC2E5 #x66CF) + (#x8FC2E6 #x66D4) + (#x8FC2E7 #x66DB) + (#x8FC2E8 #x66DF) + (#x8FC2E9 #x66E8) + (#x8FC2EA #x66EB) + (#x8FC2EB #x66EC) + (#x8FC2EC #x66EE) + (#x8FC2ED #x66FA) + (#x8FC2EE #x6705) + (#x8FC2EF #x6707) + (#x8FC2F0 #x670E) + (#x8FC2F1 #x6713) + (#x8FC2F2 #x6719) + (#x8FC2F3 #x671C) + (#x8FC2F4 #x6720) + (#x8FC2F5 #x6722) + (#x8FC2F6 #x6733) + (#x8FC2F7 #x673E) + (#x8FC2F8 #x6745) + (#x8FC2F9 #x6747) + (#x8FC2FA #x6748) + (#x8FC2FB #x674C) + (#x8FC2FC #x6754) + (#x8FC2FD #x6755) + (#x8FC2FE #x675D) + (#x8FC3A1 #x6766) + (#x8FC3A2 #x676C) + (#x8FC3A3 #x676E) + (#x8FC3A4 #x6774) + (#x8FC3A5 #x6776) + (#x8FC3A6 #x677B) + (#x8FC3A7 #x6781) + (#x8FC3A8 #x6784) + (#x8FC3A9 #x678E) + (#x8FC3AA #x678F) + (#x8FC3AB #x6791) + (#x8FC3AC #x6793) + (#x8FC3AD #x6796) + (#x8FC3AE #x6798) + (#x8FC3AF #x6799) + (#x8FC3B0 #x679B) + (#x8FC3B1 #x67B0) + (#x8FC3B2 #x67B1) + (#x8FC3B3 #x67B2) + (#x8FC3B4 #x67B5) + (#x8FC3B5 #x67BB) + (#x8FC3B6 #x67BC) + (#x8FC3B7 #x67BD) + (#x8FC3B8 #x67F9) + (#x8FC3B9 #x67C0) + (#x8FC3BA #x67C2) + (#x8FC3BB #x67C3) + (#x8FC3BC #x67C5) + (#x8FC3BD #x67C8) + (#x8FC3BE #x67C9) + (#x8FC3BF #x67D2) + (#x8FC3C0 #x67D7) + (#x8FC3C1 #x67D9) + (#x8FC3C2 #x67DC) + (#x8FC3C3 #x67E1) + (#x8FC3C4 #x67E6) + (#x8FC3C5 #x67F0) + (#x8FC3C6 #x67F2) + (#x8FC3C7 #x67F6) + (#x8FC3C8 #x67F7) + (#x8FC3C9 #x6852) + (#x8FC3CA #x6814) + (#x8FC3CB #x6819) + (#x8FC3CC #x681D) + (#x8FC3CD #x681F) + (#x8FC3CE #x6828) + (#x8FC3CF #x6827) + (#x8FC3D0 #x682C) + (#x8FC3D1 #x682D) + (#x8FC3D2 #x682F) + (#x8FC3D3 #x6830) + (#x8FC3D4 #x6831) + (#x8FC3D5 #x6833) + (#x8FC3D6 #x683B) + (#x8FC3D7 #x683F) + (#x8FC3D8 #x6844) + (#x8FC3D9 #x6845) + (#x8FC3DA #x684A) + (#x8FC3DB #x684C) + (#x8FC3DC #x6855) + (#x8FC3DD #x6857) + (#x8FC3DE #x6858) + (#x8FC3DF #x685B) + (#x8FC3E0 #x686B) + (#x8FC3E1 #x686E) + (#x8FC3E2 #x686F) + (#x8FC3E3 #x6870) + (#x8FC3E4 #x6871) + (#x8FC3E5 #x6872) + (#x8FC3E6 #x6875) + (#x8FC3E7 #x6879) + (#x8FC3E8 #x687A) + (#x8FC3E9 #x687B) + (#x8FC3EA #x687C) + (#x8FC3EB #x6882) + (#x8FC3EC #x6884) + (#x8FC3ED #x6886) + (#x8FC3EE #x6888) + (#x8FC3EF #x6896) + (#x8FC3F0 #x6898) + (#x8FC3F1 #x689A) + (#x8FC3F2 #x689C) + (#x8FC3F3 #x68A1) + (#x8FC3F4 #x68A3) + (#x8FC3F5 #x68A5) + (#x8FC3F6 #x68A9) + (#x8FC3F7 #x68AA) + (#x8FC3F8 #x68AE) + (#x8FC3F9 #x68B2) + (#x8FC3FA #x68BB) + (#x8FC3FB #x68C5) + (#x8FC3FC #x68C8) + (#x8FC3FD #x68CC) + (#x8FC3FE #x68CF) + (#x8FC4A1 #x68D0) + (#x8FC4A2 #x68D1) + (#x8FC4A3 #x68D3) + (#x8FC4A4 #x68D6) + (#x8FC4A5 #x68D9) + (#x8FC4A6 #x68DC) + (#x8FC4A7 #x68DD) + (#x8FC4A8 #x68E5) + (#x8FC4A9 #x68E8) + (#x8FC4AA #x68EA) + (#x8FC4AB #x68EB) + (#x8FC4AC #x68EC) + (#x8FC4AD #x68ED) + (#x8FC4AE #x68F0) + (#x8FC4AF #x68F1) + (#x8FC4B0 #x68F5) + (#x8FC4B1 #x68F6) + (#x8FC4B2 #x68FB) + (#x8FC4B3 #x68FC) + (#x8FC4B4 #x68FD) + (#x8FC4B5 #x6906) + (#x8FC4B6 #x6909) + (#x8FC4B7 #x690A) + (#x8FC4B8 #x6910) + (#x8FC4B9 #x6911) + (#x8FC4BA #x6913) + (#x8FC4BB #x6916) + (#x8FC4BC #x6917) + (#x8FC4BD #x6931) + (#x8FC4BE #x6933) + (#x8FC4BF #x6935) + (#x8FC4C0 #x6938) + (#x8FC4C1 #x693B) + (#x8FC4C2 #x6942) + (#x8FC4C3 #x6945) + (#x8FC4C4 #x6949) + (#x8FC4C5 #x694E) + (#x8FC4C6 #x6957) + (#x8FC4C7 #x695B) + (#x8FC4C8 #x6963) + (#x8FC4C9 #x6964) + (#x8FC4CA #x6965) + (#x8FC4CB #x6966) + (#x8FC4CC #x6968) + (#x8FC4CD #x6969) + (#x8FC4CE #x696C) + (#x8FC4CF #x6970) + (#x8FC4D0 #x6971) + (#x8FC4D1 #x6972) + (#x8FC4D2 #x697A) + (#x8FC4D3 #x697B) + (#x8FC4D4 #x697F) + (#x8FC4D5 #x6980) + (#x8FC4D6 #x698D) + (#x8FC4D7 #x6992) + (#x8FC4D8 #x6996) + (#x8FC4D9 #x6998) + (#x8FC4DA #x69A1) + (#x8FC4DB #x69A5) + (#x8FC4DC #x69A6) + (#x8FC4DD #x69A8) + (#x8FC4DE #x69AB) + (#x8FC4DF #x69AD) + (#x8FC4E0 #x69AF) + (#x8FC4E1 #x69B7) + (#x8FC4E2 #x69B8) + (#x8FC4E3 #x69BA) + (#x8FC4E4 #x69BC) + (#x8FC4E5 #x69C5) + (#x8FC4E6 #x69C8) + (#x8FC4E7 #x69D1) + (#x8FC4E8 #x69D6) + (#x8FC4E9 #x69D7) + (#x8FC4EA #x69E2) + (#x8FC4EB #x69E5) + (#x8FC4EC #x69EE) + (#x8FC4ED #x69EF) + (#x8FC4EE #x69F1) + (#x8FC4EF #x69F3) + (#x8FC4F0 #x69F5) + (#x8FC4F1 #x69FE) + (#x8FC4F2 #x6A00) + (#x8FC4F3 #x6A01) + (#x8FC4F4 #x6A03) + (#x8FC4F5 #x6A0F) + (#x8FC4F6 #x6A11) + (#x8FC4F7 #x6A15) + (#x8FC4F8 #x6A1A) + (#x8FC4F9 #x6A1D) + (#x8FC4FA #x6A20) + (#x8FC4FB #x6A24) + (#x8FC4FC #x6A28) + (#x8FC4FD #x6A30) + (#x8FC4FE #x6A32) + (#x8FC5A1 #x6A34) + (#x8FC5A2 #x6A37) + (#x8FC5A3 #x6A3B) + (#x8FC5A4 #x6A3E) + (#x8FC5A5 #x6A3F) + (#x8FC5A6 #x6A45) + (#x8FC5A7 #x6A46) + (#x8FC5A8 #x6A49) + (#x8FC5A9 #x6A4A) + (#x8FC5AA #x6A4E) + (#x8FC5AB #x6A50) + (#x8FC5AC #x6A51) + (#x8FC5AD #x6A52) + (#x8FC5AE #x6A55) + (#x8FC5AF #x6A56) + (#x8FC5B0 #x6A5B) + (#x8FC5B1 #x6A64) + (#x8FC5B2 #x6A67) + (#x8FC5B3 #x6A6A) + (#x8FC5B4 #x6A71) + (#x8FC5B5 #x6A73) + (#x8FC5B6 #x6A7E) + (#x8FC5B7 #x6A81) + (#x8FC5B8 #x6A83) + (#x8FC5B9 #x6A86) + (#x8FC5BA #x6A87) + (#x8FC5BB #x6A89) + (#x8FC5BC #x6A8B) + (#x8FC5BD #x6A91) + (#x8FC5BE #x6A9B) + (#x8FC5BF #x6A9D) + (#x8FC5C0 #x6A9E) + (#x8FC5C1 #x6A9F) + (#x8FC5C2 #x6AA5) + (#x8FC5C3 #x6AAB) + (#x8FC5C4 #x6AAF) + (#x8FC5C5 #x6AB0) + (#x8FC5C6 #x6AB1) + (#x8FC5C7 #x6AB4) + (#x8FC5C8 #x6ABD) + (#x8FC5C9 #x6ABE) + (#x8FC5CA #x6ABF) + (#x8FC5CB #x6AC6) + (#x8FC5CC #x6AC9) + (#x8FC5CD #x6AC8) + (#x8FC5CE #x6ACC) + (#x8FC5CF #x6AD0) + (#x8FC5D0 #x6AD4) + (#x8FC5D1 #x6AD5) + (#x8FC5D2 #x6AD6) + (#x8FC5D3 #x6ADC) + (#x8FC5D4 #x6ADD) + (#x8FC5D5 #x6AE4) + (#x8FC5D6 #x6AE7) + (#x8FC5D7 #x6AEC) + (#x8FC5D8 #x6AF0) + (#x8FC5D9 #x6AF1) + (#x8FC5DA #x6AF2) + (#x8FC5DB #x6AFC) + (#x8FC5DC #x6AFD) + (#x8FC5DD #x6B02) + (#x8FC5DE #x6B03) + (#x8FC5DF #x6B06) + (#x8FC5E0 #x6B07) + (#x8FC5E1 #x6B09) + (#x8FC5E2 #x6B0F) + (#x8FC5E3 #x6B10) + (#x8FC5E4 #x6B11) + (#x8FC5E5 #x6B17) + (#x8FC5E6 #x6B1B) + (#x8FC5E7 #x6B1E) + (#x8FC5E8 #x6B24) + (#x8FC5E9 #x6B28) + (#x8FC5EA #x6B2B) + (#x8FC5EB #x6B2C) + (#x8FC5EC #x6B2F) + (#x8FC5ED #x6B35) + (#x8FC5EE #x6B36) + (#x8FC5EF #x6B3B) + (#x8FC5F0 #x6B3F) + (#x8FC5F1 #x6B46) + (#x8FC5F2 #x6B4A) + (#x8FC5F3 #x6B4D) + (#x8FC5F4 #x6B52) + (#x8FC5F5 #x6B56) + (#x8FC5F6 #x6B58) + (#x8FC5F7 #x6B5D) + (#x8FC5F8 #x6B60) + (#x8FC5F9 #x6B67) + (#x8FC5FA #x6B6B) + (#x8FC5FB #x6B6E) + (#x8FC5FC #x6B70) + (#x8FC5FD #x6B75) + (#x8FC5FE #x6B7D) + (#x8FC6A1 #x6B7E) + (#x8FC6A2 #x6B82) + (#x8FC6A3 #x6B85) + (#x8FC6A4 #x6B97) + (#x8FC6A5 #x6B9B) + (#x8FC6A6 #x6B9F) + (#x8FC6A7 #x6BA0) + (#x8FC6A8 #x6BA2) + (#x8FC6A9 #x6BA3) + (#x8FC6AA #x6BA8) + (#x8FC6AB #x6BA9) + (#x8FC6AC #x6BAC) + (#x8FC6AD #x6BAD) + (#x8FC6AE #x6BAE) + (#x8FC6AF #x6BB0) + (#x8FC6B0 #x6BB8) + (#x8FC6B1 #x6BB9) + (#x8FC6B2 #x6BBD) + (#x8FC6B3 #x6BBE) + (#x8FC6B4 #x6BC3) + (#x8FC6B5 #x6BC4) + (#x8FC6B6 #x6BC9) + (#x8FC6B7 #x6BCC) + (#x8FC6B8 #x6BD6) + (#x8FC6B9 #x6BDA) + (#x8FC6BA #x6BE1) + (#x8FC6BB #x6BE3) + (#x8FC6BC #x6BE6) + (#x8FC6BD #x6BE7) + (#x8FC6BE #x6BEE) + (#x8FC6BF #x6BF1) + (#x8FC6C0 #x6BF7) + (#x8FC6C1 #x6BF9) + (#x8FC6C2 #x6BFF) + (#x8FC6C3 #x6C02) + (#x8FC6C4 #x6C04) + (#x8FC6C5 #x6C05) + (#x8FC6C6 #x6C09) + (#x8FC6C7 #x6C0D) + (#x8FC6C8 #x6C0E) + (#x8FC6C9 #x6C10) + (#x8FC6CA #x6C12) + (#x8FC6CB #x6C19) + (#x8FC6CC #x6C1F) + (#x8FC6CD #x6C26) + (#x8FC6CE #x6C27) + (#x8FC6CF #x6C28) + (#x8FC6D0 #x6C2C) + (#x8FC6D1 #x6C2E) + (#x8FC6D2 #x6C33) + (#x8FC6D3 #x6C35) + (#x8FC6D4 #x6C36) + (#x8FC6D5 #x6C3A) + (#x8FC6D6 #x6C3B) + (#x8FC6D7 #x6C3F) + (#x8FC6D8 #x6C4A) + (#x8FC6D9 #x6C4B) + (#x8FC6DA #x6C4D) + (#x8FC6DB #x6C4F) + (#x8FC6DC #x6C52) + (#x8FC6DD #x6C54) + (#x8FC6DE #x6C59) + (#x8FC6DF #x6C5B) + (#x8FC6E0 #x6C5C) + (#x8FC6E1 #x6C6B) + (#x8FC6E2 #x6C6D) + (#x8FC6E3 #x6C6F) + (#x8FC6E4 #x6C74) + (#x8FC6E5 #x6C76) + (#x8FC6E6 #x6C78) + (#x8FC6E7 #x6C79) + (#x8FC6E8 #x6C7B) + (#x8FC6E9 #x6C85) + (#x8FC6EA #x6C86) + (#x8FC6EB #x6C87) + (#x8FC6EC #x6C89) + (#x8FC6ED #x6C94) + (#x8FC6EE #x6C95) + (#x8FC6EF #x6C97) + (#x8FC6F0 #x6C98) + (#x8FC6F1 #x6C9C) + (#x8FC6F2 #x6C9F) + (#x8FC6F3 #x6CB0) + (#x8FC6F4 #x6CB2) + (#x8FC6F5 #x6CB4) + (#x8FC6F6 #x6CC2) + (#x8FC6F7 #x6CC6) + (#x8FC6F8 #x6CCD) + (#x8FC6F9 #x6CCF) + (#x8FC6FA #x6CD0) + (#x8FC6FB #x6CD1) + (#x8FC6FC #x6CD2) + (#x8FC6FD #x6CD4) + (#x8FC6FE #x6CD6) + (#x8FC7A1 #x6CDA) + (#x8FC7A2 #x6CDC) + (#x8FC7A3 #x6CE0) + (#x8FC7A4 #x6CE7) + (#x8FC7A5 #x6CE9) + (#x8FC7A6 #x6CEB) + (#x8FC7A7 #x6CEC) + (#x8FC7A8 #x6CEE) + (#x8FC7A9 #x6CF2) + (#x8FC7AA #x6CF4) + (#x8FC7AB #x6D04) + (#x8FC7AC #x6D07) + (#x8FC7AD #x6D0A) + (#x8FC7AE #x6D0E) + (#x8FC7AF #x6D0F) + (#x8FC7B0 #x6D11) + (#x8FC7B1 #x6D13) + (#x8FC7B2 #x6D1A) + (#x8FC7B3 #x6D26) + (#x8FC7B4 #x6D27) + (#x8FC7B5 #x6D28) + (#x8FC7B6 #x6C67) + (#x8FC7B7 #x6D2E) + (#x8FC7B8 #x6D2F) + (#x8FC7B9 #x6D31) + (#x8FC7BA #x6D39) + (#x8FC7BB #x6D3C) + (#x8FC7BC #x6D3F) + (#x8FC7BD #x6D57) + (#x8FC7BE #x6D5E) + (#x8FC7BF #x6D5F) + (#x8FC7C0 #x6D61) + (#x8FC7C1 #x6D65) + (#x8FC7C2 #x6D67) + (#x8FC7C3 #x6D6F) + (#x8FC7C4 #x6D70) + (#x8FC7C5 #x6D7C) + (#x8FC7C6 #x6D82) + (#x8FC7C7 #x6D87) + (#x8FC7C8 #x6D91) + (#x8FC7C9 #x6D92) + (#x8FC7CA #x6D94) + (#x8FC7CB #x6D96) + (#x8FC7CC #x6D97) + (#x8FC7CD #x6D98) + (#x8FC7CE #x6DAA) + (#x8FC7CF #x6DAC) + (#x8FC7D0 #x6DB4) + (#x8FC7D1 #x6DB7) + (#x8FC7D2 #x6DB9) + (#x8FC7D3 #x6DBD) + (#x8FC7D4 #x6DBF) + (#x8FC7D5 #x6DC4) + (#x8FC7D6 #x6DC8) + (#x8FC7D7 #x6DCA) + (#x8FC7D8 #x6DCE) + (#x8FC7D9 #x6DCF) + (#x8FC7DA #x6DD6) + (#x8FC7DB #x6DDB) + (#x8FC7DC #x6DDD) + (#x8FC7DD #x6DDF) + (#x8FC7DE #x6DE0) + (#x8FC7DF #x6DE2) + (#x8FC7E0 #x6DE5) + (#x8FC7E1 #x6DE9) + (#x8FC7E2 #x6DEF) + (#x8FC7E3 #x6DF0) + (#x8FC7E4 #x6DF4) + (#x8FC7E5 #x6DF6) + (#x8FC7E6 #x6DFC) + (#x8FC7E7 #x6E00) + (#x8FC7E8 #x6E04) + (#x8FC7E9 #x6E1E) + (#x8FC7EA #x6E22) + (#x8FC7EB #x6E27) + (#x8FC7EC #x6E32) + (#x8FC7ED #x6E36) + (#x8FC7EE #x6E39) + (#x8FC7EF #x6E3B) + (#x8FC7F0 #x6E3C) + (#x8FC7F1 #x6E44) + (#x8FC7F2 #x6E45) + (#x8FC7F3 #x6E48) + (#x8FC7F4 #x6E49) + (#x8FC7F5 #x6E4B) + (#x8FC7F6 #x6E4F) + (#x8FC7F7 #x6E51) + (#x8FC7F8 #x6E52) + (#x8FC7F9 #x6E53) + (#x8FC7FA #x6E54) + (#x8FC7FB #x6E57) + (#x8FC7FC #x6E5C) + (#x8FC7FD #x6E5D) + (#x8FC7FE #x6E5E) + (#x8FC8A1 #x6E62) + (#x8FC8A2 #x6E63) + (#x8FC8A3 #x6E68) + (#x8FC8A4 #x6E73) + (#x8FC8A5 #x6E7B) + (#x8FC8A6 #x6E7D) + (#x8FC8A7 #x6E8D) + (#x8FC8A8 #x6E93) + (#x8FC8A9 #x6E99) + (#x8FC8AA #x6EA0) + (#x8FC8AB #x6EA7) + (#x8FC8AC #x6EAD) + (#x8FC8AD #x6EAE) + (#x8FC8AE #x6EB1) + (#x8FC8AF #x6EB3) + (#x8FC8B0 #x6EBB) + (#x8FC8B1 #x6EBF) + (#x8FC8B2 #x6EC0) + (#x8FC8B3 #x6EC1) + (#x8FC8B4 #x6EC3) + (#x8FC8B5 #x6EC7) + (#x8FC8B6 #x6EC8) + (#x8FC8B7 #x6ECA) + (#x8FC8B8 #x6ECD) + (#x8FC8B9 #x6ECE) + (#x8FC8BA #x6ECF) + (#x8FC8BB #x6EEB) + (#x8FC8BC #x6EED) + (#x8FC8BD #x6EEE) + (#x8FC8BE #x6EF9) + (#x8FC8BF #x6EFB) + (#x8FC8C0 #x6EFD) + (#x8FC8C1 #x6F04) + (#x8FC8C2 #x6F08) + (#x8FC8C3 #x6F0A) + (#x8FC8C4 #x6F0C) + (#x8FC8C5 #x6F0D) + (#x8FC8C6 #x6F16) + (#x8FC8C7 #x6F18) + (#x8FC8C8 #x6F1A) + (#x8FC8C9 #x6F1B) + (#x8FC8CA #x6F26) + (#x8FC8CB #x6F29) + (#x8FC8CC #x6F2A) + (#x8FC8CD #x6F2F) + (#x8FC8CE #x6F30) + (#x8FC8CF #x6F33) + (#x8FC8D0 #x6F36) + (#x8FC8D1 #x6F3B) + (#x8FC8D2 #x6F3C) + (#x8FC8D3 #x6F2D) + (#x8FC8D4 #x6F4F) + (#x8FC8D5 #x6F51) + (#x8FC8D6 #x6F52) + (#x8FC8D7 #x6F53) + (#x8FC8D8 #x6F57) + (#x8FC8D9 #x6F59) + (#x8FC8DA #x6F5A) + (#x8FC8DB #x6F5D) + (#x8FC8DC #x6F5E) + (#x8FC8DD #x6F61) + (#x8FC8DE #x6F62) + (#x8FC8DF #x6F68) + (#x8FC8E0 #x6F6C) + (#x8FC8E1 #x6F7D) + (#x8FC8E2 #x6F7E) + (#x8FC8E3 #x6F83) + (#x8FC8E4 #x6F87) + (#x8FC8E5 #x6F88) + (#x8FC8E6 #x6F8B) + (#x8FC8E7 #x6F8C) + (#x8FC8E8 #x6F8D) + (#x8FC8E9 #x6F90) + (#x8FC8EA #x6F92) + (#x8FC8EB #x6F93) + (#x8FC8EC #x6F94) + (#x8FC8ED #x6F96) + (#x8FC8EE #x6F9A) + (#x8FC8EF #x6F9F) + (#x8FC8F0 #x6FA0) + (#x8FC8F1 #x6FA5) + (#x8FC8F2 #x6FA6) + (#x8FC8F3 #x6FA7) + (#x8FC8F4 #x6FA8) + (#x8FC8F5 #x6FAE) + (#x8FC8F6 #x6FAF) + (#x8FC8F7 #x6FB0) + (#x8FC8F8 #x6FB5) + (#x8FC8F9 #x6FB6) + (#x8FC8FA #x6FBC) + (#x8FC8FB #x6FC5) + (#x8FC8FC #x6FC7) + (#x8FC8FD #x6FC8) + (#x8FC8FE #x6FCA) + (#x8FC9A1 #x6FDA) + (#x8FC9A2 #x6FDE) + (#x8FC9A3 #x6FE8) + (#x8FC9A4 #x6FE9) + (#x8FC9A5 #x6FF0) + (#x8FC9A6 #x6FF5) + (#x8FC9A7 #x6FF9) + (#x8FC9A8 #x6FFC) + (#x8FC9A9 #x6FFD) + (#x8FC9AA #x7000) + (#x8FC9AB #x7005) + (#x8FC9AC #x7006) + (#x8FC9AD #x7007) + (#x8FC9AE #x700D) + (#x8FC9AF #x7017) + (#x8FC9B0 #x7020) + (#x8FC9B1 #x7023) + (#x8FC9B2 #x702F) + (#x8FC9B3 #x7034) + (#x8FC9B4 #x7037) + (#x8FC9B5 #x7039) + (#x8FC9B6 #x703C) + (#x8FC9B7 #x7043) + (#x8FC9B8 #x7044) + (#x8FC9B9 #x7048) + (#x8FC9BA #x7049) + (#x8FC9BB #x704A) + (#x8FC9BC #x704B) + (#x8FC9BD #x7054) + (#x8FC9BE #x7055) + (#x8FC9BF #x705D) + (#x8FC9C0 #x705E) + (#x8FC9C1 #x704E) + (#x8FC9C2 #x7064) + (#x8FC9C3 #x7065) + (#x8FC9C4 #x706C) + (#x8FC9C5 #x706E) + (#x8FC9C6 #x7075) + (#x8FC9C7 #x7076) + (#x8FC9C8 #x707E) + (#x8FC9C9 #x7081) + (#x8FC9CA #x7085) + (#x8FC9CB #x7086) + (#x8FC9CC #x7094) + (#x8FC9CD #x7095) + (#x8FC9CE #x7096) + (#x8FC9CF #x7097) + (#x8FC9D0 #x7098) + (#x8FC9D1 #x709B) + (#x8FC9D2 #x70A4) + (#x8FC9D3 #x70AB) + (#x8FC9D4 #x70B0) + (#x8FC9D5 #x70B1) + (#x8FC9D6 #x70B4) + (#x8FC9D7 #x70B7) + (#x8FC9D8 #x70CA) + (#x8FC9D9 #x70D1) + (#x8FC9DA #x70D3) + (#x8FC9DB #x70D4) + (#x8FC9DC #x70D5) + (#x8FC9DD #x70D6) + (#x8FC9DE #x70D8) + (#x8FC9DF #x70DC) + (#x8FC9E0 #x70E4) + (#x8FC9E1 #x70FA) + (#x8FC9E2 #x7103) + (#x8FC9E3 #x7104) + (#x8FC9E4 #x7105) + (#x8FC9E5 #x7106) + (#x8FC9E6 #x7107) + (#x8FC9E7 #x710B) + (#x8FC9E8 #x710C) + (#x8FC9E9 #x710F) + (#x8FC9EA #x711E) + (#x8FC9EB #x7120) + (#x8FC9EC #x712B) + (#x8FC9ED #x712D) + (#x8FC9EE #x712F) + (#x8FC9EF #x7130) + (#x8FC9F0 #x7131) + (#x8FC9F1 #x7138) + (#x8FC9F2 #x7141) + (#x8FC9F3 #x7145) + (#x8FC9F4 #x7146) + (#x8FC9F5 #x7147) + (#x8FC9F6 #x714A) + (#x8FC9F7 #x714B) + (#x8FC9F8 #x7150) + (#x8FC9F9 #x7152) + (#x8FC9FA #x7157) + (#x8FC9FB #x715A) + (#x8FC9FC #x715C) + (#x8FC9FD #x715E) + (#x8FC9FE #x7160) + (#x8FCAA1 #x7168) + (#x8FCAA2 #x7179) + (#x8FCAA3 #x7180) + (#x8FCAA4 #x7185) + (#x8FCAA5 #x7187) + (#x8FCAA6 #x718C) + (#x8FCAA7 #x7192) + (#x8FCAA8 #x719A) + (#x8FCAA9 #x719B) + (#x8FCAAA #x71A0) + (#x8FCAAB #x71A2) + (#x8FCAAC #x71AF) + (#x8FCAAD #x71B0) + (#x8FCAAE #x71B2) + (#x8FCAAF #x71B3) + (#x8FCAB0 #x71BA) + (#x8FCAB1 #x71BF) + (#x8FCAB2 #x71C0) + (#x8FCAB3 #x71C1) + (#x8FCAB4 #x71C4) + (#x8FCAB5 #x71CB) + (#x8FCAB6 #x71CC) + (#x8FCAB7 #x71D3) + (#x8FCAB8 #x71D6) + (#x8FCAB9 #x71D9) + (#x8FCABA #x71DA) + (#x8FCABB #x71DC) + (#x8FCABC #x71F8) + (#x8FCABD #x71FE) + (#x8FCABE #x7200) + (#x8FCABF #x7207) + (#x8FCAC0 #x7208) + (#x8FCAC1 #x7209) + (#x8FCAC2 #x7213) + (#x8FCAC3 #x7217) + (#x8FCAC4 #x721A) + (#x8FCAC5 #x721D) + (#x8FCAC6 #x721F) + (#x8FCAC7 #x7224) + (#x8FCAC8 #x722B) + (#x8FCAC9 #x722F) + (#x8FCACA #x7234) + (#x8FCACB #x7238) + (#x8FCACC #x7239) + (#x8FCACD #x7241) + (#x8FCACE #x7242) + (#x8FCACF #x7243) + (#x8FCAD0 #x7245) + (#x8FCAD1 #x724E) + (#x8FCAD2 #x724F) + (#x8FCAD3 #x7250) + (#x8FCAD4 #x7253) + (#x8FCAD5 #x7255) + (#x8FCAD6 #x7256) + (#x8FCAD7 #x725A) + (#x8FCAD8 #x725C) + (#x8FCAD9 #x725E) + (#x8FCADA #x7260) + (#x8FCADB #x7263) + (#x8FCADC #x7268) + (#x8FCADD #x726B) + (#x8FCADE #x726E) + (#x8FCADF #x726F) + (#x8FCAE0 #x7271) + (#x8FCAE1 #x7277) + (#x8FCAE2 #x7278) + (#x8FCAE3 #x727B) + (#x8FCAE4 #x727C) + (#x8FCAE5 #x727F) + (#x8FCAE6 #x7284) + (#x8FCAE7 #x7289) + (#x8FCAE8 #x728D) + (#x8FCAE9 #x728E) + (#x8FCAEA #x7293) + (#x8FCAEB #x729B) + (#x8FCAEC #x72A8) + (#x8FCAED #x72AD) + (#x8FCAEE #x72AE) + (#x8FCAEF #x72B1) + (#x8FCAF0 #x72B4) + (#x8FCAF1 #x72BE) + (#x8FCAF2 #x72C1) + (#x8FCAF3 #x72C7) + (#x8FCAF4 #x72C9) + (#x8FCAF5 #x72CC) + (#x8FCAF6 #x72D5) + (#x8FCAF7 #x72D6) + (#x8FCAF8 #x72D8) + (#x8FCAF9 #x72DF) + (#x8FCAFA #x72E5) + (#x8FCAFB #x72F3) + (#x8FCAFC #x72F4) + (#x8FCAFD #x72FA) + (#x8FCAFE #x72FB) + (#x8FCBA1 #x72FE) + (#x8FCBA2 #x7302) + (#x8FCBA3 #x7304) + (#x8FCBA4 #x7305) + (#x8FCBA5 #x7307) + (#x8FCBA6 #x730B) + (#x8FCBA7 #x730D) + (#x8FCBA8 #x7312) + (#x8FCBA9 #x7313) + (#x8FCBAA #x7318) + (#x8FCBAB #x7319) + (#x8FCBAC #x731E) + (#x8FCBAD #x7322) + (#x8FCBAE #x7324) + (#x8FCBAF #x7327) + (#x8FCBB0 #x7328) + (#x8FCBB1 #x732C) + (#x8FCBB2 #x7331) + (#x8FCBB3 #x7332) + (#x8FCBB4 #x7335) + (#x8FCBB5 #x733A) + (#x8FCBB6 #x733B) + (#x8FCBB7 #x733D) + (#x8FCBB8 #x7343) + (#x8FCBB9 #x734D) + (#x8FCBBA #x7350) + (#x8FCBBB #x7352) + (#x8FCBBC #x7356) + (#x8FCBBD #x7358) + (#x8FCBBE #x735D) + (#x8FCBBF #x735E) + (#x8FCBC0 #x735F) + (#x8FCBC1 #x7360) + (#x8FCBC2 #x7366) + (#x8FCBC3 #x7367) + (#x8FCBC4 #x7369) + (#x8FCBC5 #x736B) + (#x8FCBC6 #x736C) + (#x8FCBC7 #x736E) + (#x8FCBC8 #x736F) + (#x8FCBC9 #x7371) + (#x8FCBCA #x7377) + (#x8FCBCB #x7379) + (#x8FCBCC #x737C) + (#x8FCBCD #x7380) + (#x8FCBCE #x7381) + (#x8FCBCF #x7383) + (#x8FCBD0 #x7385) + (#x8FCBD1 #x7386) + (#x8FCBD2 #x738E) + (#x8FCBD3 #x7390) + (#x8FCBD4 #x7393) + (#x8FCBD5 #x7395) + (#x8FCBD6 #x7397) + (#x8FCBD7 #x7398) + (#x8FCBD8 #x739C) + (#x8FCBD9 #x739E) + (#x8FCBDA #x739F) + (#x8FCBDB #x73A0) + (#x8FCBDC #x73A2) + (#x8FCBDD #x73A5) + (#x8FCBDE #x73A6) + (#x8FCBDF #x73AA) + (#x8FCBE0 #x73AB) + (#x8FCBE1 #x73AD) + (#x8FCBE2 #x73B5) + (#x8FCBE3 #x73B7) + (#x8FCBE4 #x73B9) + (#x8FCBE5 #x73BC) + (#x8FCBE6 #x73BD) + (#x8FCBE7 #x73BF) + (#x8FCBE8 #x73C5) + (#x8FCBE9 #x73C6) + (#x8FCBEA #x73C9) + (#x8FCBEB #x73CB) + (#x8FCBEC #x73CC) + (#x8FCBED #x73CF) + (#x8FCBEE #x73D2) + (#x8FCBEF #x73D3) + (#x8FCBF0 #x73D6) + (#x8FCBF1 #x73D9) + (#x8FCBF2 #x73DD) + (#x8FCBF3 #x73E1) + (#x8FCBF4 #x73E3) + (#x8FCBF5 #x73E6) + (#x8FCBF6 #x73E7) + (#x8FCBF7 #x73E9) + (#x8FCBF8 #x73F4) + (#x8FCBF9 #x73F5) + (#x8FCBFA #x73F7) + (#x8FCBFB #x73F9) + (#x8FCBFC #x73FA) + (#x8FCBFD #x73FB) + (#x8FCBFE #x73FD) + (#x8FCCA1 #x73FF) + (#x8FCCA2 #x7400) + (#x8FCCA3 #x7401) + (#x8FCCA4 #x7404) + (#x8FCCA5 #x7407) + (#x8FCCA6 #x740A) + (#x8FCCA7 #x7411) + (#x8FCCA8 #x741A) + (#x8FCCA9 #x741B) + (#x8FCCAA #x7424) + (#x8FCCAB #x7426) + (#x8FCCAC #x7428) + (#x8FCCAD #x7429) + (#x8FCCAE #x742A) + (#x8FCCAF #x742B) + (#x8FCCB0 #x742C) + (#x8FCCB1 #x742D) + (#x8FCCB2 #x742E) + (#x8FCCB3 #x742F) + (#x8FCCB4 #x7430) + (#x8FCCB5 #x7431) + (#x8FCCB6 #x7439) + (#x8FCCB7 #x7440) + (#x8FCCB8 #x7443) + (#x8FCCB9 #x7444) + (#x8FCCBA #x7446) + (#x8FCCBB #x7447) + (#x8FCCBC #x744B) + (#x8FCCBD #x744D) + (#x8FCCBE #x7451) + (#x8FCCBF #x7452) + (#x8FCCC0 #x7457) + (#x8FCCC1 #x745D) + (#x8FCCC2 #x7462) + (#x8FCCC3 #x7466) + (#x8FCCC4 #x7467) + (#x8FCCC5 #x7468) + (#x8FCCC6 #x746B) + (#x8FCCC7 #x746D) + (#x8FCCC8 #x746E) + (#x8FCCC9 #x7471) + (#x8FCCCA #x7472) + (#x8FCCCB #x7480) + (#x8FCCCC #x7481) + (#x8FCCCD #x7485) + (#x8FCCCE #x7486) + (#x8FCCCF #x7487) + (#x8FCCD0 #x7489) + (#x8FCCD1 #x748F) + (#x8FCCD2 #x7490) + (#x8FCCD3 #x7491) + (#x8FCCD4 #x7492) + (#x8FCCD5 #x7498) + (#x8FCCD6 #x7499) + (#x8FCCD7 #x749A) + (#x8FCCD8 #x749C) + (#x8FCCD9 #x749F) + (#x8FCCDA #x74A0) + (#x8FCCDB #x74A1) + (#x8FCCDC #x74A3) + (#x8FCCDD #x74A6) + (#x8FCCDE #x74A8) + (#x8FCCDF #x74A9) + (#x8FCCE0 #x74AA) + (#x8FCCE1 #x74AB) + (#x8FCCE2 #x74AE) + (#x8FCCE3 #x74AF) + (#x8FCCE4 #x74B1) + (#x8FCCE5 #x74B2) + (#x8FCCE6 #x74B5) + (#x8FCCE7 #x74B9) + (#x8FCCE8 #x74BB) + (#x8FCCE9 #x74BF) + (#x8FCCEA #x74C8) + (#x8FCCEB #x74C9) + (#x8FCCEC #x74CC) + (#x8FCCED #x74D0) + (#x8FCCEE #x74D3) + (#x8FCCEF #x74D8) + (#x8FCCF0 #x74DA) + (#x8FCCF1 #x74DB) + (#x8FCCF2 #x74DE) + (#x8FCCF3 #x74DF) + (#x8FCCF4 #x74E4) + (#x8FCCF5 #x74E8) + (#x8FCCF6 #x74EA) + (#x8FCCF7 #x74EB) + (#x8FCCF8 #x74EF) + (#x8FCCF9 #x74F4) + (#x8FCCFA #x74FA) + (#x8FCCFB #x74FB) + (#x8FCCFC #x74FC) + (#x8FCCFD #x74FF) + (#x8FCCFE #x7506) + (#x8FCDA1 #x7512) + (#x8FCDA2 #x7516) + (#x8FCDA3 #x7517) + (#x8FCDA4 #x7520) + (#x8FCDA5 #x7521) + (#x8FCDA6 #x7524) + (#x8FCDA7 #x7527) + (#x8FCDA8 #x7529) + (#x8FCDA9 #x752A) + (#x8FCDAA #x752F) + (#x8FCDAB #x7536) + (#x8FCDAC #x7539) + (#x8FCDAD #x753D) + (#x8FCDAE #x753E) + (#x8FCDAF #x753F) + (#x8FCDB0 #x7540) + (#x8FCDB1 #x7543) + (#x8FCDB2 #x7547) + (#x8FCDB3 #x7548) + (#x8FCDB4 #x754E) + (#x8FCDB5 #x7550) + (#x8FCDB6 #x7552) + (#x8FCDB7 #x7557) + (#x8FCDB8 #x755E) + (#x8FCDB9 #x755F) + (#x8FCDBA #x7561) + (#x8FCDBB #x756F) + (#x8FCDBC #x7571) + (#x8FCDBD #x7579) + (#x8FCDBE #x757A) + (#x8FCDBF #x757B) + (#x8FCDC0 #x757C) + (#x8FCDC1 #x757D) + (#x8FCDC2 #x757E) + (#x8FCDC3 #x7581) + (#x8FCDC4 #x7585) + (#x8FCDC5 #x7590) + (#x8FCDC6 #x7592) + (#x8FCDC7 #x7593) + (#x8FCDC8 #x7595) + (#x8FCDC9 #x7599) + (#x8FCDCA #x759C) + (#x8FCDCB #x75A2) + (#x8FCDCC #x75A4) + (#x8FCDCD #x75B4) + (#x8FCDCE #x75BA) + (#x8FCDCF #x75BF) + (#x8FCDD0 #x75C0) + (#x8FCDD1 #x75C1) + (#x8FCDD2 #x75C4) + (#x8FCDD3 #x75C6) + (#x8FCDD4 #x75CC) + (#x8FCDD5 #x75CE) + (#x8FCDD6 #x75CF) + (#x8FCDD7 #x75D7) + (#x8FCDD8 #x75DC) + (#x8FCDD9 #x75DF) + (#x8FCDDA #x75E0) + (#x8FCDDB #x75E1) + (#x8FCDDC #x75E4) + (#x8FCDDD #x75E7) + (#x8FCDDE #x75EC) + (#x8FCDDF #x75EE) + (#x8FCDE0 #x75EF) + (#x8FCDE1 #x75F1) + (#x8FCDE2 #x75F9) + (#x8FCDE3 #x7600) + (#x8FCDE4 #x7602) + (#x8FCDE5 #x7603) + (#x8FCDE6 #x7604) + (#x8FCDE7 #x7607) + (#x8FCDE8 #x7608) + (#x8FCDE9 #x760A) + (#x8FCDEA #x760C) + (#x8FCDEB #x760F) + (#x8FCDEC #x7612) + (#x8FCDED #x7613) + (#x8FCDEE #x7615) + (#x8FCDEF #x7616) + (#x8FCDF0 #x7619) + (#x8FCDF1 #x761B) + (#x8FCDF2 #x761C) + (#x8FCDF3 #x761D) + (#x8FCDF4 #x761E) + (#x8FCDF5 #x7623) + (#x8FCDF6 #x7625) + (#x8FCDF7 #x7626) + (#x8FCDF8 #x7629) + (#x8FCDF9 #x762D) + (#x8FCDFA #x7632) + (#x8FCDFB #x7633) + (#x8FCDFC #x7635) + (#x8FCDFD #x7638) + (#x8FCDFE #x7639) + (#x8FCEA1 #x763A) + (#x8FCEA2 #x763C) + (#x8FCEA3 #x764A) + (#x8FCEA4 #x7640) + (#x8FCEA5 #x7641) + (#x8FCEA6 #x7643) + (#x8FCEA7 #x7644) + (#x8FCEA8 #x7645) + (#x8FCEA9 #x7649) + (#x8FCEAA #x764B) + (#x8FCEAB #x7655) + (#x8FCEAC #x7659) + (#x8FCEAD #x765F) + (#x8FCEAE #x7664) + (#x8FCEAF #x7665) + (#x8FCEB0 #x766D) + (#x8FCEB1 #x766E) + (#x8FCEB2 #x766F) + (#x8FCEB3 #x7671) + (#x8FCEB4 #x7674) + (#x8FCEB5 #x7681) + (#x8FCEB6 #x7685) + (#x8FCEB7 #x768C) + (#x8FCEB8 #x768D) + (#x8FCEB9 #x7695) + (#x8FCEBA #x769B) + (#x8FCEBB #x769C) + (#x8FCEBC #x769D) + (#x8FCEBD #x769F) + (#x8FCEBE #x76A0) + (#x8FCEBF #x76A2) + (#x8FCEC0 #x76A3) + (#x8FCEC1 #x76A4) + (#x8FCEC2 #x76A5) + (#x8FCEC3 #x76A6) + (#x8FCEC4 #x76A7) + (#x8FCEC5 #x76A8) + (#x8FCEC6 #x76AA) + (#x8FCEC7 #x76AD) + (#x8FCEC8 #x76BD) + (#x8FCEC9 #x76C1) + (#x8FCECA #x76C5) + (#x8FCECB #x76C9) + (#x8FCECC #x76CB) + (#x8FCECD #x76CC) + (#x8FCECE #x76CE) + (#x8FCECF #x76D4) + (#x8FCED0 #x76D9) + (#x8FCED1 #x76E0) + (#x8FCED2 #x76E6) + (#x8FCED3 #x76E8) + (#x8FCED4 #x76EC) + (#x8FCED5 #x76F0) + (#x8FCED6 #x76F1) + (#x8FCED7 #x76F6) + (#x8FCED8 #x76F9) + (#x8FCED9 #x76FC) + (#x8FCEDA #x7700) + (#x8FCEDB #x7706) + (#x8FCEDC #x770A) + (#x8FCEDD #x770E) + (#x8FCEDE #x7712) + (#x8FCEDF #x7714) + (#x8FCEE0 #x7715) + (#x8FCEE1 #x7717) + (#x8FCEE2 #x7719) + (#x8FCEE3 #x771A) + (#x8FCEE4 #x771C) + (#x8FCEE5 #x7722) + (#x8FCEE6 #x7728) + (#x8FCEE7 #x772D) + (#x8FCEE8 #x772E) + (#x8FCEE9 #x772F) + (#x8FCEEA #x7734) + (#x8FCEEB #x7735) + (#x8FCEEC #x7736) + (#x8FCEED #x7739) + (#x8FCEEE #x773D) + (#x8FCEEF #x773E) + (#x8FCEF0 #x7742) + (#x8FCEF1 #x7745) + (#x8FCEF2 #x7746) + (#x8FCEF3 #x774A) + (#x8FCEF4 #x774D) + (#x8FCEF5 #x774E) + (#x8FCEF6 #x774F) + (#x8FCEF7 #x7752) + (#x8FCEF8 #x7756) + (#x8FCEF9 #x7757) + (#x8FCEFA #x775C) + (#x8FCEFB #x775E) + (#x8FCEFC #x775F) + (#x8FCEFD #x7760) + (#x8FCEFE #x7762) + (#x8FCFA1 #x7764) + (#x8FCFA2 #x7767) + (#x8FCFA3 #x776A) + (#x8FCFA4 #x776C) + (#x8FCFA5 #x7770) + (#x8FCFA6 #x7772) + (#x8FCFA7 #x7773) + (#x8FCFA8 #x7774) + (#x8FCFA9 #x777A) + (#x8FCFAA #x777D) + (#x8FCFAB #x7780) + (#x8FCFAC #x7784) + (#x8FCFAD #x778C) + (#x8FCFAE #x778D) + (#x8FCFAF #x7794) + (#x8FCFB0 #x7795) + (#x8FCFB1 #x7796) + (#x8FCFB2 #x779A) + (#x8FCFB3 #x779F) + (#x8FCFB4 #x77A2) + (#x8FCFB5 #x77A7) + (#x8FCFB6 #x77AA) + (#x8FCFB7 #x77AE) + (#x8FCFB8 #x77AF) + (#x8FCFB9 #x77B1) + (#x8FCFBA #x77B5) + (#x8FCFBB #x77BE) + (#x8FCFBC #x77C3) + (#x8FCFBD #x77C9) + (#x8FCFBE #x77D1) + (#x8FCFBF #x77D2) + (#x8FCFC0 #x77D5) + (#x8FCFC1 #x77D9) + (#x8FCFC2 #x77DE) + (#x8FCFC3 #x77DF) + (#x8FCFC4 #x77E0) + (#x8FCFC5 #x77E4) + (#x8FCFC6 #x77E6) + (#x8FCFC7 #x77EA) + (#x8FCFC8 #x77EC) + (#x8FCFC9 #x77F0) + (#x8FCFCA #x77F1) + (#x8FCFCB #x77F4) + (#x8FCFCC #x77F8) + (#x8FCFCD #x77FB) + (#x8FCFCE #x7805) + (#x8FCFCF #x7806) + (#x8FCFD0 #x7809) + (#x8FCFD1 #x780D) + (#x8FCFD2 #x780E) + (#x8FCFD3 #x7811) + (#x8FCFD4 #x781D) + (#x8FCFD5 #x7821) + (#x8FCFD6 #x7822) + (#x8FCFD7 #x7823) + (#x8FCFD8 #x782D) + (#x8FCFD9 #x782E) + (#x8FCFDA #x7830) + (#x8FCFDB #x7835) + (#x8FCFDC #x7837) + (#x8FCFDD #x7843) + (#x8FCFDE #x7844) + (#x8FCFDF #x7847) + (#x8FCFE0 #x7848) + (#x8FCFE1 #x784C) + (#x8FCFE2 #x784E) + (#x8FCFE3 #x7852) + (#x8FCFE4 #x785C) + (#x8FCFE5 #x785E) + (#x8FCFE6 #x7860) + (#x8FCFE7 #x7861) + (#x8FCFE8 #x7863) + (#x8FCFE9 #x7864) + (#x8FCFEA #x7868) + (#x8FCFEB #x786A) + (#x8FCFEC #x786E) + (#x8FCFED #x787A) + (#x8FCFEE #x787E) + (#x8FCFEF #x788A) + (#x8FCFF0 #x788F) + (#x8FCFF1 #x7894) + (#x8FCFF2 #x7898) + (#x8FCFF3 #x78A1) + (#x8FCFF4 #x789D) + (#x8FCFF5 #x789E) + (#x8FCFF6 #x789F) + (#x8FCFF7 #x78A4) + (#x8FCFF8 #x78A8) + (#x8FCFF9 #x78AC) + (#x8FCFFA #x78AD) + (#x8FCFFB #x78B0) + (#x8FCFFC #x78B1) + (#x8FCFFD #x78B2) + (#x8FCFFE #x78B3) + (#x8FD0A1 #x78BB) + (#x8FD0A2 #x78BD) + (#x8FD0A3 #x78BF) + (#x8FD0A4 #x78C7) + (#x8FD0A5 #x78C8) + (#x8FD0A6 #x78C9) + (#x8FD0A7 #x78CC) + (#x8FD0A8 #x78CE) + (#x8FD0A9 #x78D2) + (#x8FD0AA #x78D3) + (#x8FD0AB #x78D5) + (#x8FD0AC #x78D6) + (#x8FD0AD #x78E4) + (#x8FD0AE #x78DB) + (#x8FD0AF #x78DF) + (#x8FD0B0 #x78E0) + (#x8FD0B1 #x78E1) + (#x8FD0B2 #x78E6) + (#x8FD0B3 #x78EA) + (#x8FD0B4 #x78F2) + (#x8FD0B5 #x78F3) + (#x8FD0B6 #x7900) + (#x8FD0B7 #x78F6) + (#x8FD0B8 #x78F7) + (#x8FD0B9 #x78FA) + (#x8FD0BA #x78FB) + (#x8FD0BB #x78FF) + (#x8FD0BC #x7906) + (#x8FD0BD #x790C) + (#x8FD0BE #x7910) + (#x8FD0BF #x791A) + (#x8FD0C0 #x791C) + (#x8FD0C1 #x791E) + (#x8FD0C2 #x791F) + (#x8FD0C3 #x7920) + (#x8FD0C4 #x7925) + (#x8FD0C5 #x7927) + (#x8FD0C6 #x7929) + (#x8FD0C7 #x792D) + (#x8FD0C8 #x7931) + (#x8FD0C9 #x7934) + (#x8FD0CA #x7935) + (#x8FD0CB #x793B) + (#x8FD0CC #x793D) + (#x8FD0CD #x793F) + (#x8FD0CE #x7944) + (#x8FD0CF #x7945) + (#x8FD0D0 #x7946) + (#x8FD0D1 #x794A) + (#x8FD0D2 #x794B) + (#x8FD0D3 #x794F) + (#x8FD0D4 #x7951) + (#x8FD0D5 #x7954) + (#x8FD0D6 #x7958) + (#x8FD0D7 #x795B) + (#x8FD0D8 #x795C) + (#x8FD0D9 #x7967) + (#x8FD0DA #x7969) + (#x8FD0DB #x796B) + (#x8FD0DC #x7972) + (#x8FD0DD #x7979) + (#x8FD0DE #x797B) + (#x8FD0DF #x797C) + (#x8FD0E0 #x797E) + (#x8FD0E1 #x798B) + (#x8FD0E2 #x798C) + (#x8FD0E3 #x7991) + (#x8FD0E4 #x7993) + (#x8FD0E5 #x7994) + (#x8FD0E6 #x7995) + (#x8FD0E7 #x7996) + (#x8FD0E8 #x7998) + (#x8FD0E9 #x799B) + (#x8FD0EA #x799C) + (#x8FD0EB #x79A1) + (#x8FD0EC #x79A8) + (#x8FD0ED #x79A9) + (#x8FD0EE #x79AB) + (#x8FD0EF #x79AF) + (#x8FD0F0 #x79B1) + (#x8FD0F1 #x79B4) + (#x8FD0F2 #x79B8) + (#x8FD0F3 #x79BB) + (#x8FD0F4 #x79C2) + (#x8FD0F5 #x79C4) + (#x8FD0F6 #x79C7) + (#x8FD0F7 #x79C8) + (#x8FD0F8 #x79CA) + (#x8FD0F9 #x79CF) + (#x8FD0FA #x79D4) + (#x8FD0FB #x79D6) + (#x8FD0FC #x79DA) + (#x8FD0FD #x79DD) + (#x8FD0FE #x79DE) + (#x8FD1A1 #x79E0) + (#x8FD1A2 #x79E2) + (#x8FD1A3 #x79E5) + (#x8FD1A4 #x79EA) + (#x8FD1A5 #x79EB) + (#x8FD1A6 #x79ED) + (#x8FD1A7 #x79F1) + (#x8FD1A8 #x79F8) + (#x8FD1A9 #x79FC) + (#x8FD1AA #x7A02) + (#x8FD1AB #x7A03) + (#x8FD1AC #x7A07) + (#x8FD1AD #x7A09) + (#x8FD1AE #x7A0A) + (#x8FD1AF #x7A0C) + (#x8FD1B0 #x7A11) + (#x8FD1B1 #x7A15) + (#x8FD1B2 #x7A1B) + (#x8FD1B3 #x7A1E) + (#x8FD1B4 #x7A21) + (#x8FD1B5 #x7A27) + (#x8FD1B6 #x7A2B) + (#x8FD1B7 #x7A2D) + (#x8FD1B8 #x7A2F) + (#x8FD1B9 #x7A30) + (#x8FD1BA #x7A34) + (#x8FD1BB #x7A35) + (#x8FD1BC #x7A38) + (#x8FD1BD #x7A39) + (#x8FD1BE #x7A3A) + (#x8FD1BF #x7A44) + (#x8FD1C0 #x7A45) + (#x8FD1C1 #x7A47) + (#x8FD1C2 #x7A48) + (#x8FD1C3 #x7A4C) + (#x8FD1C4 #x7A55) + (#x8FD1C5 #x7A56) + (#x8FD1C6 #x7A59) + (#x8FD1C7 #x7A5C) + (#x8FD1C8 #x7A5D) + (#x8FD1C9 #x7A5F) + (#x8FD1CA #x7A60) + (#x8FD1CB #x7A65) + (#x8FD1CC #x7A67) + (#x8FD1CD #x7A6A) + (#x8FD1CE #x7A6D) + (#x8FD1CF #x7A75) + (#x8FD1D0 #x7A78) + (#x8FD1D1 #x7A7E) + (#x8FD1D2 #x7A80) + (#x8FD1D3 #x7A82) + (#x8FD1D4 #x7A85) + (#x8FD1D5 #x7A86) + (#x8FD1D6 #x7A8A) + (#x8FD1D7 #x7A8B) + (#x8FD1D8 #x7A90) + (#x8FD1D9 #x7A91) + (#x8FD1DA #x7A94) + (#x8FD1DB #x7A9E) + (#x8FD1DC #x7AA0) + (#x8FD1DD #x7AA3) + (#x8FD1DE #x7AAC) + (#x8FD1DF #x7AB3) + (#x8FD1E0 #x7AB5) + (#x8FD1E1 #x7AB9) + (#x8FD1E2 #x7ABB) + (#x8FD1E3 #x7ABC) + (#x8FD1E4 #x7AC6) + (#x8FD1E5 #x7AC9) + (#x8FD1E6 #x7ACC) + (#x8FD1E7 #x7ACE) + (#x8FD1E8 #x7AD1) + (#x8FD1E9 #x7ADB) + (#x8FD1EA #x7AE8) + (#x8FD1EB #x7AE9) + (#x8FD1EC #x7AEB) + (#x8FD1ED #x7AEC) + (#x8FD1EE #x7AF1) + (#x8FD1EF #x7AF4) + (#x8FD1F0 #x7AFB) + (#x8FD1F1 #x7AFD) + (#x8FD1F2 #x7AFE) + (#x8FD1F3 #x7B07) + (#x8FD1F4 #x7B14) + (#x8FD1F5 #x7B1F) + (#x8FD1F6 #x7B23) + (#x8FD1F7 #x7B27) + (#x8FD1F8 #x7B29) + (#x8FD1F9 #x7B2A) + (#x8FD1FA #x7B2B) + (#x8FD1FB #x7B2D) + (#x8FD1FC #x7B2E) + (#x8FD1FD #x7B2F) + (#x8FD1FE #x7B30) + (#x8FD2A1 #x7B31) + (#x8FD2A2 #x7B34) + (#x8FD2A3 #x7B3D) + (#x8FD2A4 #x7B3F) + (#x8FD2A5 #x7B40) + (#x8FD2A6 #x7B41) + (#x8FD2A7 #x7B47) + (#x8FD2A8 #x7B4E) + (#x8FD2A9 #x7B55) + (#x8FD2AA #x7B60) + (#x8FD2AB #x7B64) + (#x8FD2AC #x7B66) + (#x8FD2AD #x7B69) + (#x8FD2AE #x7B6A) + (#x8FD2AF #x7B6D) + (#x8FD2B0 #x7B6F) + (#x8FD2B1 #x7B72) + (#x8FD2B2 #x7B73) + (#x8FD2B3 #x7B77) + (#x8FD2B4 #x7B84) + (#x8FD2B5 #x7B89) + (#x8FD2B6 #x7B8E) + (#x8FD2B7 #x7B90) + (#x8FD2B8 #x7B91) + (#x8FD2B9 #x7B96) + (#x8FD2BA #x7B9B) + (#x8FD2BB #x7B9E) + (#x8FD2BC #x7BA0) + (#x8FD2BD #x7BA5) + (#x8FD2BE #x7BAC) + (#x8FD2BF #x7BAF) + (#x8FD2C0 #x7BB0) + (#x8FD2C1 #x7BB2) + (#x8FD2C2 #x7BB5) + (#x8FD2C3 #x7BB6) + (#x8FD2C4 #x7BBA) + (#x8FD2C5 #x7BBB) + (#x8FD2C6 #x7BBC) + (#x8FD2C7 #x7BBD) + (#x8FD2C8 #x7BC2) + (#x8FD2C9 #x7BC5) + (#x8FD2CA #x7BC8) + (#x8FD2CB #x7BCA) + (#x8FD2CC #x7BD4) + (#x8FD2CD #x7BD6) + (#x8FD2CE #x7BD7) + (#x8FD2CF #x7BD9) + (#x8FD2D0 #x7BDA) + (#x8FD2D1 #x7BDB) + (#x8FD2D2 #x7BE8) + (#x8FD2D3 #x7BEA) + (#x8FD2D4 #x7BF2) + (#x8FD2D5 #x7BF4) + (#x8FD2D6 #x7BF5) + (#x8FD2D7 #x7BF8) + (#x8FD2D8 #x7BF9) + (#x8FD2D9 #x7BFA) + (#x8FD2DA #x7BFC) + (#x8FD2DB #x7BFE) + (#x8FD2DC #x7C01) + (#x8FD2DD #x7C02) + (#x8FD2DE #x7C03) + (#x8FD2DF #x7C04) + (#x8FD2E0 #x7C06) + (#x8FD2E1 #x7C09) + (#x8FD2E2 #x7C0B) + (#x8FD2E3 #x7C0C) + (#x8FD2E4 #x7C0E) + (#x8FD2E5 #x7C0F) + (#x8FD2E6 #x7C19) + (#x8FD2E7 #x7C1B) + (#x8FD2E8 #x7C20) + (#x8FD2E9 #x7C25) + (#x8FD2EA #x7C26) + (#x8FD2EB #x7C28) + (#x8FD2EC #x7C2C) + (#x8FD2ED #x7C31) + (#x8FD2EE #x7C33) + (#x8FD2EF #x7C34) + (#x8FD2F0 #x7C36) + (#x8FD2F1 #x7C39) + (#x8FD2F2 #x7C3A) + (#x8FD2F3 #x7C46) + (#x8FD2F4 #x7C4A) + (#x8FD2F5 #x7C55) + (#x8FD2F6 #x7C51) + (#x8FD2F7 #x7C52) + (#x8FD2F8 #x7C53) + (#x8FD2F9 #x7C59) + (#x8FD2FA #x7C5A) + (#x8FD2FB #x7C5B) + (#x8FD2FC #x7C5C) + (#x8FD2FD #x7C5D) + (#x8FD2FE #x7C5E) + (#x8FD3A1 #x7C61) + (#x8FD3A2 #x7C63) + (#x8FD3A3 #x7C67) + (#x8FD3A4 #x7C69) + (#x8FD3A5 #x7C6D) + (#x8FD3A6 #x7C6E) + (#x8FD3A7 #x7C70) + (#x8FD3A8 #x7C72) + (#x8FD3A9 #x7C79) + (#x8FD3AA #x7C7C) + (#x8FD3AB #x7C7D) + (#x8FD3AC #x7C86) + (#x8FD3AD #x7C87) + (#x8FD3AE #x7C8F) + (#x8FD3AF #x7C94) + (#x8FD3B0 #x7C9E) + (#x8FD3B1 #x7CA0) + (#x8FD3B2 #x7CA6) + (#x8FD3B3 #x7CB0) + (#x8FD3B4 #x7CB6) + (#x8FD3B5 #x7CB7) + (#x8FD3B6 #x7CBA) + (#x8FD3B7 #x7CBB) + (#x8FD3B8 #x7CBC) + (#x8FD3B9 #x7CBF) + (#x8FD3BA #x7CC4) + (#x8FD3BB #x7CC7) + (#x8FD3BC #x7CC8) + (#x8FD3BD #x7CC9) + (#x8FD3BE #x7CCD) + (#x8FD3BF #x7CCF) + (#x8FD3C0 #x7CD3) + (#x8FD3C1 #x7CD4) + (#x8FD3C2 #x7CD5) + (#x8FD3C3 #x7CD7) + (#x8FD3C4 #x7CD9) + (#x8FD3C5 #x7CDA) + (#x8FD3C6 #x7CDD) + (#x8FD3C7 #x7CE6) + (#x8FD3C8 #x7CE9) + (#x8FD3C9 #x7CEB) + (#x8FD3CA #x7CF5) + (#x8FD3CB #x7D03) + (#x8FD3CC #x7D07) + (#x8FD3CD #x7D08) + (#x8FD3CE #x7D09) + (#x8FD3CF #x7D0F) + (#x8FD3D0 #x7D11) + (#x8FD3D1 #x7D12) + (#x8FD3D2 #x7D13) + (#x8FD3D3 #x7D16) + (#x8FD3D4 #x7D1D) + (#x8FD3D5 #x7D1E) + (#x8FD3D6 #x7D23) + (#x8FD3D7 #x7D26) + (#x8FD3D8 #x7D2A) + (#x8FD3D9 #x7D2D) + (#x8FD3DA #x7D31) + (#x8FD3DB #x7D3C) + (#x8FD3DC #x7D3D) + (#x8FD3DD #x7D3E) + (#x8FD3DE #x7D40) + (#x8FD3DF #x7D41) + (#x8FD3E0 #x7D47) + (#x8FD3E1 #x7D48) + (#x8FD3E2 #x7D4D) + (#x8FD3E3 #x7D51) + (#x8FD3E4 #x7D53) + (#x8FD3E5 #x7D57) + (#x8FD3E6 #x7D59) + (#x8FD3E7 #x7D5A) + (#x8FD3E8 #x7D5C) + (#x8FD3E9 #x7D5D) + (#x8FD3EA #x7D65) + (#x8FD3EB #x7D67) + (#x8FD3EC #x7D6A) + (#x8FD3ED #x7D70) + (#x8FD3EE #x7D78) + (#x8FD3EF #x7D7A) + (#x8FD3F0 #x7D7B) + (#x8FD3F1 #x7D7F) + (#x8FD3F2 #x7D81) + (#x8FD3F3 #x7D82) + (#x8FD3F4 #x7D83) + (#x8FD3F5 #x7D85) + (#x8FD3F6 #x7D86) + (#x8FD3F7 #x7D88) + (#x8FD3F8 #x7D8B) + (#x8FD3F9 #x7D8C) + (#x8FD3FA #x7D8D) + (#x8FD3FB #x7D91) + (#x8FD3FC #x7D96) + (#x8FD3FD #x7D97) + (#x8FD3FE #x7D9D) + (#x8FD4A1 #x7D9E) + (#x8FD4A2 #x7DA6) + (#x8FD4A3 #x7DA7) + (#x8FD4A4 #x7DAA) + (#x8FD4A5 #x7DB3) + (#x8FD4A6 #x7DB6) + (#x8FD4A7 #x7DB7) + (#x8FD4A8 #x7DB9) + (#x8FD4A9 #x7DC2) + (#x8FD4AA #x7DC3) + (#x8FD4AB #x7DC4) + (#x8FD4AC #x7DC5) + (#x8FD4AD #x7DC6) + (#x8FD4AE #x7DCC) + (#x8FD4AF #x7DCD) + (#x8FD4B0 #x7DCE) + (#x8FD4B1 #x7DD7) + (#x8FD4B2 #x7DD9) + (#x8FD4B3 #x7E00) + (#x8FD4B4 #x7DE2) + (#x8FD4B5 #x7DE5) + (#x8FD4B6 #x7DE6) + (#x8FD4B7 #x7DEA) + (#x8FD4B8 #x7DEB) + (#x8FD4B9 #x7DED) + (#x8FD4BA #x7DF1) + (#x8FD4BB #x7DF5) + (#x8FD4BC #x7DF6) + (#x8FD4BD #x7DF9) + (#x8FD4BE #x7DFA) + (#x8FD4BF #x7E08) + (#x8FD4C0 #x7E10) + (#x8FD4C1 #x7E11) + (#x8FD4C2 #x7E15) + (#x8FD4C3 #x7E17) + (#x8FD4C4 #x7E1C) + (#x8FD4C5 #x7E1D) + (#x8FD4C6 #x7E20) + (#x8FD4C7 #x7E27) + (#x8FD4C8 #x7E28) + (#x8FD4C9 #x7E2C) + (#x8FD4CA #x7E2D) + (#x8FD4CB #x7E2F) + (#x8FD4CC #x7E33) + (#x8FD4CD #x7E36) + (#x8FD4CE #x7E3F) + (#x8FD4CF #x7E44) + (#x8FD4D0 #x7E45) + (#x8FD4D1 #x7E47) + (#x8FD4D2 #x7E4E) + (#x8FD4D3 #x7E50) + (#x8FD4D4 #x7E52) + (#x8FD4D5 #x7E58) + (#x8FD4D6 #x7E5F) + (#x8FD4D7 #x7E61) + (#x8FD4D8 #x7E62) + (#x8FD4D9 #x7E65) + (#x8FD4DA #x7E6B) + (#x8FD4DB #x7E6E) + (#x8FD4DC #x7E6F) + (#x8FD4DD #x7E73) + (#x8FD4DE #x7E78) + (#x8FD4DF #x7E7E) + (#x8FD4E0 #x7E81) + (#x8FD4E1 #x7E86) + (#x8FD4E2 #x7E87) + (#x8FD4E3 #x7E8A) + (#x8FD4E4 #x7E8D) + (#x8FD4E5 #x7E91) + (#x8FD4E6 #x7E95) + (#x8FD4E7 #x7E98) + (#x8FD4E8 #x7E9A) + (#x8FD4E9 #x7E9D) + (#x8FD4EA #x7E9E) + (#x8FD4EB #x7F3C) + (#x8FD4EC #x7F3B) + (#x8FD4ED #x7F3D) + (#x8FD4EE #x7F3E) + (#x8FD4EF #x7F3F) + (#x8FD4F0 #x7F43) + (#x8FD4F1 #x7F44) + (#x8FD4F2 #x7F47) + (#x8FD4F3 #x7F4F) + (#x8FD4F4 #x7F52) + (#x8FD4F5 #x7F53) + (#x8FD4F6 #x7F5B) + (#x8FD4F7 #x7F5C) + (#x8FD4F8 #x7F5D) + (#x8FD4F9 #x7F61) + (#x8FD4FA #x7F63) + (#x8FD4FB #x7F64) + (#x8FD4FC #x7F65) + (#x8FD4FD #x7F66) + (#x8FD4FE #x7F6D) + (#x8FD5A1 #x7F71) + (#x8FD5A2 #x7F7D) + (#x8FD5A3 #x7F7E) + (#x8FD5A4 #x7F7F) + (#x8FD5A5 #x7F80) + (#x8FD5A6 #x7F8B) + (#x8FD5A7 #x7F8D) + (#x8FD5A8 #x7F8F) + (#x8FD5A9 #x7F90) + (#x8FD5AA #x7F91) + (#x8FD5AB #x7F96) + (#x8FD5AC #x7F97) + (#x8FD5AD #x7F9C) + (#x8FD5AE #x7FA1) + (#x8FD5AF #x7FA2) + (#x8FD5B0 #x7FA6) + (#x8FD5B1 #x7FAA) + (#x8FD5B2 #x7FAD) + (#x8FD5B3 #x7FB4) + (#x8FD5B4 #x7FBC) + (#x8FD5B5 #x7FBF) + (#x8FD5B6 #x7FC0) + (#x8FD5B7 #x7FC3) + (#x8FD5B8 #x7FC8) + (#x8FD5B9 #x7FCE) + (#x8FD5BA #x7FCF) + (#x8FD5BB #x7FDB) + (#x8FD5BC #x7FDF) + (#x8FD5BD #x7FE3) + (#x8FD5BE #x7FE5) + (#x8FD5BF #x7FE8) + (#x8FD5C0 #x7FEC) + (#x8FD5C1 #x7FEE) + (#x8FD5C2 #x7FEF) + (#x8FD5C3 #x7FF2) + (#x8FD5C4 #x7FFA) + (#x8FD5C5 #x7FFD) + (#x8FD5C6 #x7FFE) + (#x8FD5C7 #x7FFF) + (#x8FD5C8 #x8007) + (#x8FD5C9 #x8008) + (#x8FD5CA #x800A) + (#x8FD5CB #x800D) + (#x8FD5CC #x800E) + (#x8FD5CD #x800F) + (#x8FD5CE #x8011) + (#x8FD5CF #x8013) + (#x8FD5D0 #x8014) + (#x8FD5D1 #x8016) + (#x8FD5D2 #x801D) + (#x8FD5D3 #x801E) + (#x8FD5D4 #x801F) + (#x8FD5D5 #x8020) + (#x8FD5D6 #x8024) + (#x8FD5D7 #x8026) + (#x8FD5D8 #x802C) + (#x8FD5D9 #x802E) + (#x8FD5DA #x8030) + (#x8FD5DB #x8034) + (#x8FD5DC #x8035) + (#x8FD5DD #x8037) + (#x8FD5DE #x8039) + (#x8FD5DF #x803A) + (#x8FD5E0 #x803C) + (#x8FD5E1 #x803E) + (#x8FD5E2 #x8040) + (#x8FD5E3 #x8044) + (#x8FD5E4 #x8060) + (#x8FD5E5 #x8064) + (#x8FD5E6 #x8066) + (#x8FD5E7 #x806D) + (#x8FD5E8 #x8071) + (#x8FD5E9 #x8075) + (#x8FD5EA #x8081) + (#x8FD5EB #x8088) + (#x8FD5EC #x808E) + (#x8FD5ED #x809C) + (#x8FD5EE #x809E) + (#x8FD5EF #x80A6) + (#x8FD5F0 #x80A7) + (#x8FD5F1 #x80AB) + (#x8FD5F2 #x80B8) + (#x8FD5F3 #x80B9) + (#x8FD5F4 #x80C8) + (#x8FD5F5 #x80CD) + (#x8FD5F6 #x80CF) + (#x8FD5F7 #x80D2) + (#x8FD5F8 #x80D4) + (#x8FD5F9 #x80D5) + (#x8FD5FA #x80D7) + (#x8FD5FB #x80D8) + (#x8FD5FC #x80E0) + (#x8FD5FD #x80ED) + (#x8FD5FE #x80EE) + (#x8FD6A1 #x80F0) + (#x8FD6A2 #x80F2) + (#x8FD6A3 #x80F3) + (#x8FD6A4 #x80F6) + (#x8FD6A5 #x80F9) + (#x8FD6A6 #x80FA) + (#x8FD6A7 #x80FE) + (#x8FD6A8 #x8103) + (#x8FD6A9 #x810B) + (#x8FD6AA #x8116) + (#x8FD6AB #x8117) + (#x8FD6AC #x8118) + (#x8FD6AD #x811C) + (#x8FD6AE #x811E) + (#x8FD6AF #x8120) + (#x8FD6B0 #x8124) + (#x8FD6B1 #x8127) + (#x8FD6B2 #x812C) + (#x8FD6B3 #x8130) + (#x8FD6B4 #x8135) + (#x8FD6B5 #x813A) + (#x8FD6B6 #x813C) + (#x8FD6B7 #x8145) + (#x8FD6B8 #x8147) + (#x8FD6B9 #x814A) + (#x8FD6BA #x814C) + (#x8FD6BB #x8152) + (#x8FD6BC #x8157) + (#x8FD6BD #x8160) + (#x8FD6BE #x8161) + (#x8FD6BF #x8167) + (#x8FD6C0 #x8168) + (#x8FD6C1 #x8169) + (#x8FD6C2 #x816D) + (#x8FD6C3 #x816F) + (#x8FD6C4 #x8177) + (#x8FD6C5 #x8181) + (#x8FD6C6 #x8190) + (#x8FD6C7 #x8184) + (#x8FD6C8 #x8185) + (#x8FD6C9 #x8186) + (#x8FD6CA #x818B) + (#x8FD6CB #x818E) + (#x8FD6CC #x8196) + (#x8FD6CD #x8198) + (#x8FD6CE #x819B) + (#x8FD6CF #x819E) + (#x8FD6D0 #x81A2) + (#x8FD6D1 #x81AE) + (#x8FD6D2 #x81B2) + (#x8FD6D3 #x81B4) + (#x8FD6D4 #x81BB) + (#x8FD6D5 #x81CB) + (#x8FD6D6 #x81C3) + (#x8FD6D7 #x81C5) + (#x8FD6D8 #x81CA) + (#x8FD6D9 #x81CE) + (#x8FD6DA #x81CF) + (#x8FD6DB #x81D5) + (#x8FD6DC #x81D7) + (#x8FD6DD #x81DB) + (#x8FD6DE #x81DD) + (#x8FD6DF #x81DE) + (#x8FD6E0 #x81E1) + (#x8FD6E1 #x81E4) + (#x8FD6E2 #x81EB) + (#x8FD6E3 #x81EC) + (#x8FD6E4 #x81F0) + (#x8FD6E5 #x81F1) + (#x8FD6E6 #x81F2) + (#x8FD6E7 #x81F5) + (#x8FD6E8 #x81F6) + (#x8FD6E9 #x81F8) + (#x8FD6EA #x81F9) + (#x8FD6EB #x81FD) + (#x8FD6EC #x81FF) + (#x8FD6ED #x8200) + (#x8FD6EE #x8203) + (#x8FD6EF #x820F) + (#x8FD6F0 #x8213) + (#x8FD6F1 #x8214) + (#x8FD6F2 #x8219) + (#x8FD6F3 #x821A) + (#x8FD6F4 #x821D) + (#x8FD6F5 #x8221) + (#x8FD6F6 #x8222) + (#x8FD6F7 #x8228) + (#x8FD6F8 #x8232) + (#x8FD6F9 #x8234) + (#x8FD6FA #x823A) + (#x8FD6FB #x8243) + (#x8FD6FC #x8244) + (#x8FD6FD #x8245) + (#x8FD6FE #x8246) + (#x8FD7A1 #x824B) + (#x8FD7A2 #x824E) + (#x8FD7A3 #x824F) + (#x8FD7A4 #x8251) + (#x8FD7A5 #x8256) + (#x8FD7A6 #x825C) + (#x8FD7A7 #x8260) + (#x8FD7A8 #x8263) + (#x8FD7A9 #x8267) + (#x8FD7AA #x826D) + (#x8FD7AB #x8274) + (#x8FD7AC #x827B) + (#x8FD7AD #x827D) + (#x8FD7AE #x827F) + (#x8FD7AF #x8280) + (#x8FD7B0 #x8281) + (#x8FD7B1 #x8283) + (#x8FD7B2 #x8284) + (#x8FD7B3 #x8287) + (#x8FD7B4 #x8289) + (#x8FD7B5 #x828A) + (#x8FD7B6 #x828E) + (#x8FD7B7 #x8291) + (#x8FD7B8 #x8294) + (#x8FD7B9 #x8296) + (#x8FD7BA #x8298) + (#x8FD7BB #x829A) + (#x8FD7BC #x829B) + (#x8FD7BD #x82A0) + (#x8FD7BE #x82A1) + (#x8FD7BF #x82A3) + (#x8FD7C0 #x82A4) + (#x8FD7C1 #x82A7) + (#x8FD7C2 #x82A8) + (#x8FD7C3 #x82A9) + (#x8FD7C4 #x82AA) + (#x8FD7C5 #x82AE) + (#x8FD7C6 #x82B0) + (#x8FD7C7 #x82B2) + (#x8FD7C8 #x82B4) + (#x8FD7C9 #x82B7) + (#x8FD7CA #x82BA) + (#x8FD7CB #x82BC) + (#x8FD7CC #x82BE) + (#x8FD7CD #x82BF) + (#x8FD7CE #x82C6) + (#x8FD7CF #x82D0) + (#x8FD7D0 #x82D5) + (#x8FD7D1 #x82DA) + (#x8FD7D2 #x82E0) + (#x8FD7D3 #x82E2) + (#x8FD7D4 #x82E4) + (#x8FD7D5 #x82E8) + (#x8FD7D6 #x82EA) + (#x8FD7D7 #x82ED) + (#x8FD7D8 #x82EF) + (#x8FD7D9 #x82F6) + (#x8FD7DA #x82F7) + (#x8FD7DB #x82FD) + (#x8FD7DC #x82FE) + (#x8FD7DD #x8300) + (#x8FD7DE #x8301) + (#x8FD7DF #x8307) + (#x8FD7E0 #x8308) + (#x8FD7E1 #x830A) + (#x8FD7E2 #x830B) + (#x8FD7E3 #x8354) + (#x8FD7E4 #x831B) + (#x8FD7E5 #x831D) + (#x8FD7E6 #x831E) + (#x8FD7E7 #x831F) + (#x8FD7E8 #x8321) + (#x8FD7E9 #x8322) + (#x8FD7EA #x832C) + (#x8FD7EB #x832D) + (#x8FD7EC #x832E) + (#x8FD7ED #x8330) + (#x8FD7EE #x8333) + (#x8FD7EF #x8337) + (#x8FD7F0 #x833A) + (#x8FD7F1 #x833C) + (#x8FD7F2 #x833D) + (#x8FD7F3 #x8342) + (#x8FD7F4 #x8343) + (#x8FD7F5 #x8344) + (#x8FD7F6 #x8347) + (#x8FD7F7 #x834D) + (#x8FD7F8 #x834E) + (#x8FD7F9 #x8351) + (#x8FD7FA #x8355) + (#x8FD7FB #x8356) + (#x8FD7FC #x8357) + (#x8FD7FD #x8370) + (#x8FD7FE #x8378) + (#x8FD8A1 #x837D) + (#x8FD8A2 #x837F) + (#x8FD8A3 #x8380) + (#x8FD8A4 #x8382) + (#x8FD8A5 #x8384) + (#x8FD8A6 #x8386) + (#x8FD8A7 #x838D) + (#x8FD8A8 #x8392) + (#x8FD8A9 #x8394) + (#x8FD8AA #x8395) + (#x8FD8AB #x8398) + (#x8FD8AC #x8399) + (#x8FD8AD #x839B) + (#x8FD8AE #x839C) + (#x8FD8AF #x839D) + (#x8FD8B0 #x83A6) + (#x8FD8B1 #x83A7) + (#x8FD8B2 #x83A9) + (#x8FD8B3 #x83AC) + (#x8FD8B4 #x83BE) + (#x8FD8B5 #x83BF) + (#x8FD8B6 #x83C0) + (#x8FD8B7 #x83C7) + (#x8FD8B8 #x83C9) + (#x8FD8B9 #x83CF) + (#x8FD8BA #x83D0) + (#x8FD8BB #x83D1) + (#x8FD8BC #x83D4) + (#x8FD8BD #x83DD) + (#x8FD8BE #x8353) + (#x8FD8BF #x83E8) + (#x8FD8C0 #x83EA) + (#x8FD8C1 #x83F6) + (#x8FD8C2 #x83F8) + (#x8FD8C3 #x83F9) + (#x8FD8C4 #x83FC) + (#x8FD8C5 #x8401) + (#x8FD8C6 #x8406) + (#x8FD8C7 #x840A) + (#x8FD8C8 #x840F) + (#x8FD8C9 #x8411) + (#x8FD8CA #x8415) + (#x8FD8CB #x8419) + (#x8FD8CC #x83AD) + (#x8FD8CD #x842F) + (#x8FD8CE #x8439) + (#x8FD8CF #x8445) + (#x8FD8D0 #x8447) + (#x8FD8D1 #x8448) + (#x8FD8D2 #x844A) + (#x8FD8D3 #x844D) + (#x8FD8D4 #x844F) + (#x8FD8D5 #x8451) + (#x8FD8D6 #x8452) + (#x8FD8D7 #x8456) + (#x8FD8D8 #x8458) + (#x8FD8D9 #x8459) + (#x8FD8DA #x845A) + (#x8FD8DB #x845C) + (#x8FD8DC #x8460) + (#x8FD8DD #x8464) + (#x8FD8DE #x8465) + (#x8FD8DF #x8467) + (#x8FD8E0 #x846A) + (#x8FD8E1 #x8470) + (#x8FD8E2 #x8473) + (#x8FD8E3 #x8474) + (#x8FD8E4 #x8476) + (#x8FD8E5 #x8478) + (#x8FD8E6 #x847C) + (#x8FD8E7 #x847D) + (#x8FD8E8 #x8481) + (#x8FD8E9 #x8485) + (#x8FD8EA #x8492) + (#x8FD8EB #x8493) + (#x8FD8EC #x8495) + (#x8FD8ED #x849E) + (#x8FD8EE #x84A6) + (#x8FD8EF #x84A8) + (#x8FD8F0 #x84A9) + (#x8FD8F1 #x84AA) + (#x8FD8F2 #x84AF) + (#x8FD8F3 #x84B1) + (#x8FD8F4 #x84B4) + (#x8FD8F5 #x84BA) + (#x8FD8F6 #x84BD) + (#x8FD8F7 #x84BE) + (#x8FD8F8 #x84C0) + (#x8FD8F9 #x84C2) + (#x8FD8FA #x84C7) + (#x8FD8FB #x84C8) + (#x8FD8FC #x84CC) + (#x8FD8FD #x84CF) + (#x8FD8FE #x84D3) + (#x8FD9A1 #x84DC) + (#x8FD9A2 #x84E7) + (#x8FD9A3 #x84EA) + (#x8FD9A4 #x84EF) + (#x8FD9A5 #x84F0) + (#x8FD9A6 #x84F1) + (#x8FD9A7 #x84F2) + (#x8FD9A8 #x84F7) + (#x8FD9A9 #x8532) + (#x8FD9AA #x84FA) + (#x8FD9AB #x84FB) + (#x8FD9AC #x84FD) + (#x8FD9AD #x8502) + (#x8FD9AE #x8503) + (#x8FD9AF #x8507) + (#x8FD9B0 #x850C) + (#x8FD9B1 #x850E) + (#x8FD9B2 #x8510) + (#x8FD9B3 #x851C) + (#x8FD9B4 #x851E) + (#x8FD9B5 #x8522) + (#x8FD9B6 #x8523) + (#x8FD9B7 #x8524) + (#x8FD9B8 #x8525) + (#x8FD9B9 #x8527) + (#x8FD9BA #x852A) + (#x8FD9BB #x852B) + (#x8FD9BC #x852F) + (#x8FD9BD #x8533) + (#x8FD9BE #x8534) + (#x8FD9BF #x8536) + (#x8FD9C0 #x853F) + (#x8FD9C1 #x8546) + (#x8FD9C2 #x854F) + (#x8FD9C3 #x8550) + (#x8FD9C4 #x8551) + (#x8FD9C5 #x8552) + (#x8FD9C6 #x8553) + (#x8FD9C7 #x8556) + (#x8FD9C8 #x8559) + (#x8FD9C9 #x855C) + (#x8FD9CA #x855D) + (#x8FD9CB #x855E) + (#x8FD9CC #x855F) + (#x8FD9CD #x8560) + (#x8FD9CE #x8561) + (#x8FD9CF #x8562) + (#x8FD9D0 #x8564) + (#x8FD9D1 #x856B) + (#x8FD9D2 #x856F) + (#x8FD9D3 #x8579) + (#x8FD9D4 #x857A) + (#x8FD9D5 #x857B) + (#x8FD9D6 #x857D) + (#x8FD9D7 #x857F) + (#x8FD9D8 #x8581) + (#x8FD9D9 #x8585) + (#x8FD9DA #x8586) + (#x8FD9DB #x8589) + (#x8FD9DC #x858B) + (#x8FD9DD #x858C) + (#x8FD9DE #x858F) + (#x8FD9DF #x8593) + (#x8FD9E0 #x8598) + (#x8FD9E1 #x859D) + (#x8FD9E2 #x859F) + (#x8FD9E3 #x85A0) + (#x8FD9E4 #x85A2) + (#x8FD9E5 #x85A5) + (#x8FD9E6 #x85A7) + (#x8FD9E7 #x85B4) + (#x8FD9E8 #x85B6) + (#x8FD9E9 #x85B7) + (#x8FD9EA #x85B8) + (#x8FD9EB #x85BC) + (#x8FD9EC #x85BD) + (#x8FD9ED #x85BE) + (#x8FD9EE #x85BF) + (#x8FD9EF #x85C2) + (#x8FD9F0 #x85C7) + (#x8FD9F1 #x85CA) + (#x8FD9F2 #x85CB) + (#x8FD9F3 #x85CE) + (#x8FD9F4 #x85AD) + (#x8FD9F5 #x85D8) + (#x8FD9F6 #x85DA) + (#x8FD9F7 #x85DF) + (#x8FD9F8 #x85E0) + (#x8FD9F9 #x85E6) + (#x8FD9FA #x85E8) + (#x8FD9FB #x85ED) + (#x8FD9FC #x85F3) + (#x8FD9FD #x85F6) + (#x8FD9FE #x85FC) + (#x8FDAA1 #x85FF) + (#x8FDAA2 #x8600) + (#x8FDAA3 #x8604) + (#x8FDAA4 #x8605) + (#x8FDAA5 #x860D) + (#x8FDAA6 #x860E) + (#x8FDAA7 #x8610) + (#x8FDAA8 #x8611) + (#x8FDAA9 #x8612) + (#x8FDAAA #x8618) + (#x8FDAAB #x8619) + (#x8FDAAC #x861B) + (#x8FDAAD #x861E) + (#x8FDAAE #x8621) + (#x8FDAAF #x8627) + (#x8FDAB0 #x8629) + (#x8FDAB1 #x8636) + (#x8FDAB2 #x8638) + (#x8FDAB3 #x863A) + (#x8FDAB4 #x863C) + (#x8FDAB5 #x863D) + (#x8FDAB6 #x8640) + (#x8FDAB7 #x8642) + (#x8FDAB8 #x8646) + (#x8FDAB9 #x8652) + (#x8FDABA #x8653) + (#x8FDABB #x8656) + (#x8FDABC #x8657) + (#x8FDABD #x8658) + (#x8FDABE #x8659) + (#x8FDABF #x865D) + (#x8FDAC0 #x8660) + (#x8FDAC1 #x8661) + (#x8FDAC2 #x8662) + (#x8FDAC3 #x8663) + (#x8FDAC4 #x8664) + (#x8FDAC5 #x8669) + (#x8FDAC6 #x866C) + (#x8FDAC7 #x866F) + (#x8FDAC8 #x8675) + (#x8FDAC9 #x8676) + (#x8FDACA #x8677) + (#x8FDACB #x867A) + (#x8FDACC #x868D) + (#x8FDACD #x8691) + (#x8FDACE #x8696) + (#x8FDACF #x8698) + (#x8FDAD0 #x869A) + (#x8FDAD1 #x869C) + (#x8FDAD2 #x86A1) + (#x8FDAD3 #x86A6) + (#x8FDAD4 #x86A7) + (#x8FDAD5 #x86A8) + (#x8FDAD6 #x86AD) + (#x8FDAD7 #x86B1) + (#x8FDAD8 #x86B3) + (#x8FDAD9 #x86B4) + (#x8FDADA #x86B5) + (#x8FDADB #x86B7) + (#x8FDADC #x86B8) + (#x8FDADD #x86B9) + (#x8FDADE #x86BF) + (#x8FDADF #x86C0) + (#x8FDAE0 #x86C1) + (#x8FDAE1 #x86C3) + (#x8FDAE2 #x86C5) + (#x8FDAE3 #x86D1) + (#x8FDAE4 #x86D2) + (#x8FDAE5 #x86D5) + (#x8FDAE6 #x86D7) + (#x8FDAE7 #x86DA) + (#x8FDAE8 #x86DC) + (#x8FDAE9 #x86E0) + (#x8FDAEA #x86E3) + (#x8FDAEB #x86E5) + (#x8FDAEC #x86E7) + (#x8FDAED #x8688) + (#x8FDAEE #x86FA) + (#x8FDAEF #x86FC) + (#x8FDAF0 #x86FD) + (#x8FDAF1 #x8704) + (#x8FDAF2 #x8705) + (#x8FDAF3 #x8707) + (#x8FDAF4 #x870B) + (#x8FDAF5 #x870E) + (#x8FDAF6 #x870F) + (#x8FDAF7 #x8710) + (#x8FDAF8 #x8713) + (#x8FDAF9 #x8714) + (#x8FDAFA #x8719) + (#x8FDAFB #x871E) + (#x8FDAFC #x871F) + (#x8FDAFD #x8721) + (#x8FDAFE #x8723) + (#x8FDBA1 #x8728) + (#x8FDBA2 #x872E) + (#x8FDBA3 #x872F) + (#x8FDBA4 #x8731) + (#x8FDBA5 #x8732) + (#x8FDBA6 #x8739) + (#x8FDBA7 #x873A) + (#x8FDBA8 #x873C) + (#x8FDBA9 #x873D) + (#x8FDBAA #x873E) + (#x8FDBAB #x8740) + (#x8FDBAC #x8743) + (#x8FDBAD #x8745) + (#x8FDBAE #x874D) + (#x8FDBAF #x8758) + (#x8FDBB0 #x875D) + (#x8FDBB1 #x8761) + (#x8FDBB2 #x8764) + (#x8FDBB3 #x8765) + (#x8FDBB4 #x876F) + (#x8FDBB5 #x8771) + (#x8FDBB6 #x8772) + (#x8FDBB7 #x877B) + (#x8FDBB8 #x8783) + (#x8FDBB9 #x8784) + (#x8FDBBA #x8785) + (#x8FDBBB #x8786) + (#x8FDBBC #x8787) + (#x8FDBBD #x8788) + (#x8FDBBE #x8789) + (#x8FDBBF #x878B) + (#x8FDBC0 #x878C) + (#x8FDBC1 #x8790) + (#x8FDBC2 #x8793) + (#x8FDBC3 #x8795) + (#x8FDBC4 #x8797) + (#x8FDBC5 #x8798) + (#x8FDBC6 #x8799) + (#x8FDBC7 #x879E) + (#x8FDBC8 #x87A0) + (#x8FDBC9 #x87A3) + (#x8FDBCA #x87A7) + (#x8FDBCB #x87AC) + (#x8FDBCC #x87AD) + (#x8FDBCD #x87AE) + (#x8FDBCE #x87B1) + (#x8FDBCF #x87B5) + (#x8FDBD0 #x87BE) + (#x8FDBD1 #x87BF) + (#x8FDBD2 #x87C1) + (#x8FDBD3 #x87C8) + (#x8FDBD4 #x87C9) + (#x8FDBD5 #x87CA) + (#x8FDBD6 #x87CE) + (#x8FDBD7 #x87D5) + (#x8FDBD8 #x87D6) + (#x8FDBD9 #x87D9) + (#x8FDBDA #x87DA) + (#x8FDBDB #x87DC) + (#x8FDBDC #x87DF) + (#x8FDBDD #x87E2) + (#x8FDBDE #x87E3) + (#x8FDBDF #x87E4) + (#x8FDBE0 #x87EA) + (#x8FDBE1 #x87EB) + (#x8FDBE2 #x87ED) + (#x8FDBE3 #x87F1) + (#x8FDBE4 #x87F3) + (#x8FDBE5 #x87F8) + (#x8FDBE6 #x87FA) + (#x8FDBE7 #x87FF) + (#x8FDBE8 #x8801) + (#x8FDBE9 #x8803) + (#x8FDBEA #x8806) + (#x8FDBEB #x8809) + (#x8FDBEC #x880A) + (#x8FDBED #x880B) + (#x8FDBEE #x8810) + (#x8FDBEF #x8819) + (#x8FDBF0 #x8812) + (#x8FDBF1 #x8813) + (#x8FDBF2 #x8814) + (#x8FDBF3 #x8818) + (#x8FDBF4 #x881A) + (#x8FDBF5 #x881B) + (#x8FDBF6 #x881C) + (#x8FDBF7 #x881E) + (#x8FDBF8 #x881F) + (#x8FDBF9 #x8828) + (#x8FDBFA #x882D) + (#x8FDBFB #x882E) + (#x8FDBFC #x8830) + (#x8FDBFD #x8832) + (#x8FDBFE #x8835) + (#x8FDCA1 #x883A) + (#x8FDCA2 #x883C) + (#x8FDCA3 #x8841) + (#x8FDCA4 #x8843) + (#x8FDCA5 #x8845) + (#x8FDCA6 #x8848) + (#x8FDCA7 #x8849) + (#x8FDCA8 #x884A) + (#x8FDCA9 #x884B) + (#x8FDCAA #x884E) + (#x8FDCAB #x8851) + (#x8FDCAC #x8855) + (#x8FDCAD #x8856) + (#x8FDCAE #x8858) + (#x8FDCAF #x885A) + (#x8FDCB0 #x885C) + (#x8FDCB1 #x885F) + (#x8FDCB2 #x8860) + (#x8FDCB3 #x8864) + (#x8FDCB4 #x8869) + (#x8FDCB5 #x8871) + (#x8FDCB6 #x8879) + (#x8FDCB7 #x887B) + (#x8FDCB8 #x8880) + (#x8FDCB9 #x8898) + (#x8FDCBA #x889A) + (#x8FDCBB #x889B) + (#x8FDCBC #x889C) + (#x8FDCBD #x889F) + (#x8FDCBE #x88A0) + (#x8FDCBF #x88A8) + (#x8FDCC0 #x88AA) + (#x8FDCC1 #x88BA) + (#x8FDCC2 #x88BD) + (#x8FDCC3 #x88BE) + (#x8FDCC4 #x88C0) + (#x8FDCC5 #x88CA) + (#x8FDCC6 #x88CB) + (#x8FDCC7 #x88CC) + (#x8FDCC8 #x88CD) + (#x8FDCC9 #x88CE) + (#x8FDCCA #x88D1) + (#x8FDCCB #x88D2) + (#x8FDCCC #x88D3) + (#x8FDCCD #x88DB) + (#x8FDCCE #x88DE) + (#x8FDCCF #x88E7) + (#x8FDCD0 #x88EF) + (#x8FDCD1 #x88F0) + (#x8FDCD2 #x88F1) + (#x8FDCD3 #x88F5) + (#x8FDCD4 #x88F7) + (#x8FDCD5 #x8901) + (#x8FDCD6 #x8906) + (#x8FDCD7 #x890D) + (#x8FDCD8 #x890E) + (#x8FDCD9 #x890F) + (#x8FDCDA #x8915) + (#x8FDCDB #x8916) + (#x8FDCDC #x8918) + (#x8FDCDD #x8919) + (#x8FDCDE #x891A) + (#x8FDCDF #x891C) + (#x8FDCE0 #x8920) + (#x8FDCE1 #x8926) + (#x8FDCE2 #x8927) + (#x8FDCE3 #x8928) + (#x8FDCE4 #x8930) + (#x8FDCE5 #x8931) + (#x8FDCE6 #x8932) + (#x8FDCE7 #x8935) + (#x8FDCE8 #x8939) + (#x8FDCE9 #x893A) + (#x8FDCEA #x893E) + (#x8FDCEB #x8940) + (#x8FDCEC #x8942) + (#x8FDCED #x8945) + (#x8FDCEE #x8946) + (#x8FDCEF #x8949) + (#x8FDCF0 #x894F) + (#x8FDCF1 #x8952) + (#x8FDCF2 #x8957) + (#x8FDCF3 #x895A) + (#x8FDCF4 #x895B) + (#x8FDCF5 #x895C) + (#x8FDCF6 #x8961) + (#x8FDCF7 #x8962) + (#x8FDCF8 #x8963) + (#x8FDCF9 #x896B) + (#x8FDCFA #x896E) + (#x8FDCFB #x8970) + (#x8FDCFC #x8973) + (#x8FDCFD #x8975) + (#x8FDCFE #x897A) + (#x8FDDA1 #x897B) + (#x8FDDA2 #x897C) + (#x8FDDA3 #x897D) + (#x8FDDA4 #x8989) + (#x8FDDA5 #x898D) + (#x8FDDA6 #x8990) + (#x8FDDA7 #x8994) + (#x8FDDA8 #x8995) + (#x8FDDA9 #x899B) + (#x8FDDAA #x899C) + (#x8FDDAB #x899F) + (#x8FDDAC #x89A0) + (#x8FDDAD #x89A5) + (#x8FDDAE #x89B0) + (#x8FDDAF #x89B4) + (#x8FDDB0 #x89B5) + (#x8FDDB1 #x89B6) + (#x8FDDB2 #x89B7) + (#x8FDDB3 #x89BC) + (#x8FDDB4 #x89D4) + (#x8FDDB5 #x89D5) + (#x8FDDB6 #x89D6) + (#x8FDDB7 #x89D7) + (#x8FDDB8 #x89D8) + (#x8FDDB9 #x89E5) + (#x8FDDBA #x89E9) + (#x8FDDBB #x89EB) + (#x8FDDBC #x89ED) + (#x8FDDBD #x89F1) + (#x8FDDBE #x89F3) + (#x8FDDBF #x89F6) + (#x8FDDC0 #x89F9) + (#x8FDDC1 #x89FD) + (#x8FDDC2 #x89FF) + (#x8FDDC3 #x8A04) + (#x8FDDC4 #x8A05) + (#x8FDDC5 #x8A07) + (#x8FDDC6 #x8A0F) + (#x8FDDC7 #x8A11) + (#x8FDDC8 #x8A12) + (#x8FDDC9 #x8A14) + (#x8FDDCA #x8A15) + (#x8FDDCB #x8A1E) + (#x8FDDCC #x8A20) + (#x8FDDCD #x8A22) + (#x8FDDCE #x8A24) + (#x8FDDCF #x8A26) + (#x8FDDD0 #x8A2B) + (#x8FDDD1 #x8A2C) + (#x8FDDD2 #x8A2F) + (#x8FDDD3 #x8A35) + (#x8FDDD4 #x8A37) + (#x8FDDD5 #x8A3D) + (#x8FDDD6 #x8A3E) + (#x8FDDD7 #x8A40) + (#x8FDDD8 #x8A43) + (#x8FDDD9 #x8A45) + (#x8FDDDA #x8A47) + (#x8FDDDB #x8A49) + (#x8FDDDC #x8A4D) + (#x8FDDDD #x8A4E) + (#x8FDDDE #x8A53) + (#x8FDDDF #x8A56) + (#x8FDDE0 #x8A57) + (#x8FDDE1 #x8A58) + (#x8FDDE2 #x8A5C) + (#x8FDDE3 #x8A5D) + (#x8FDDE4 #x8A61) + (#x8FDDE5 #x8A65) + (#x8FDDE6 #x8A67) + (#x8FDDE7 #x8A75) + (#x8FDDE8 #x8A76) + (#x8FDDE9 #x8A77) + (#x8FDDEA #x8A79) + (#x8FDDEB #x8A7A) + (#x8FDDEC #x8A7B) + (#x8FDDED #x8A7E) + (#x8FDDEE #x8A7F) + (#x8FDDEF #x8A80) + (#x8FDDF0 #x8A83) + (#x8FDDF1 #x8A86) + (#x8FDDF2 #x8A8B) + (#x8FDDF3 #x8A8F) + (#x8FDDF4 #x8A90) + (#x8FDDF5 #x8A92) + (#x8FDDF6 #x8A96) + (#x8FDDF7 #x8A97) + (#x8FDDF8 #x8A99) + (#x8FDDF9 #x8A9F) + (#x8FDDFA #x8AA7) + (#x8FDDFB #x8AA9) + (#x8FDDFC #x8AAE) + (#x8FDDFD #x8AAF) + (#x8FDDFE #x8AB3) + (#x8FDEA1 #x8AB6) + (#x8FDEA2 #x8AB7) + (#x8FDEA3 #x8ABB) + (#x8FDEA4 #x8ABE) + (#x8FDEA5 #x8AC3) + (#x8FDEA6 #x8AC6) + (#x8FDEA7 #x8AC8) + (#x8FDEA8 #x8AC9) + (#x8FDEA9 #x8ACA) + (#x8FDEAA #x8AD1) + (#x8FDEAB #x8AD3) + (#x8FDEAC #x8AD4) + (#x8FDEAD #x8AD5) + (#x8FDEAE #x8AD7) + (#x8FDEAF #x8ADD) + (#x8FDEB0 #x8ADF) + (#x8FDEB1 #x8AEC) + (#x8FDEB2 #x8AF0) + (#x8FDEB3 #x8AF4) + (#x8FDEB4 #x8AF5) + (#x8FDEB5 #x8AF6) + (#x8FDEB6 #x8AFC) + (#x8FDEB7 #x8AFF) + (#x8FDEB8 #x8B05) + (#x8FDEB9 #x8B06) + (#x8FDEBA #x8B0B) + (#x8FDEBB #x8B11) + (#x8FDEBC #x8B1C) + (#x8FDEBD #x8B1E) + (#x8FDEBE #x8B1F) + (#x8FDEBF #x8B0A) + (#x8FDEC0 #x8B2D) + (#x8FDEC1 #x8B30) + (#x8FDEC2 #x8B37) + (#x8FDEC3 #x8B3C) + (#x8FDEC4 #x8B42) + (#x8FDEC5 #x8B43) + (#x8FDEC6 #x8B44) + (#x8FDEC7 #x8B45) + (#x8FDEC8 #x8B46) + (#x8FDEC9 #x8B48) + (#x8FDECA #x8B52) + (#x8FDECB #x8B53) + (#x8FDECC #x8B54) + (#x8FDECD #x8B59) + (#x8FDECE #x8B4D) + (#x8FDECF #x8B5E) + (#x8FDED0 #x8B63) + (#x8FDED1 #x8B6D) + (#x8FDED2 #x8B76) + (#x8FDED3 #x8B78) + (#x8FDED4 #x8B79) + (#x8FDED5 #x8B7C) + (#x8FDED6 #x8B7E) + (#x8FDED7 #x8B81) + (#x8FDED8 #x8B84) + (#x8FDED9 #x8B85) + (#x8FDEDA #x8B8B) + (#x8FDEDB #x8B8D) + (#x8FDEDC #x8B8F) + (#x8FDEDD #x8B94) + (#x8FDEDE #x8B95) + (#x8FDEDF #x8B9C) + (#x8FDEE0 #x8B9E) + (#x8FDEE1 #x8B9F) + (#x8FDEE2 #x8C38) + (#x8FDEE3 #x8C39) + (#x8FDEE4 #x8C3D) + (#x8FDEE5 #x8C3E) + (#x8FDEE6 #x8C45) + (#x8FDEE7 #x8C47) + (#x8FDEE8 #x8C49) + (#x8FDEE9 #x8C4B) + (#x8FDEEA #x8C4F) + (#x8FDEEB #x8C51) + (#x8FDEEC #x8C53) + (#x8FDEED #x8C54) + (#x8FDEEE #x8C57) + (#x8FDEEF #x8C58) + (#x8FDEF0 #x8C5B) + (#x8FDEF1 #x8C5D) + (#x8FDEF2 #x8C59) + (#x8FDEF3 #x8C63) + (#x8FDEF4 #x8C64) + (#x8FDEF5 #x8C66) + (#x8FDEF6 #x8C68) + (#x8FDEF7 #x8C69) + (#x8FDEF8 #x8C6D) + (#x8FDEF9 #x8C73) + (#x8FDEFA #x8C75) + (#x8FDEFB #x8C76) + (#x8FDEFC #x8C7B) + (#x8FDEFD #x8C7E) + (#x8FDEFE #x8C86) + (#x8FDFA1 #x8C87) + (#x8FDFA2 #x8C8B) + (#x8FDFA3 #x8C90) + (#x8FDFA4 #x8C92) + (#x8FDFA5 #x8C93) + (#x8FDFA6 #x8C99) + (#x8FDFA7 #x8C9B) + (#x8FDFA8 #x8C9C) + (#x8FDFA9 #x8CA4) + (#x8FDFAA #x8CB9) + (#x8FDFAB #x8CBA) + (#x8FDFAC #x8CC5) + (#x8FDFAD #x8CC6) + (#x8FDFAE #x8CC9) + (#x8FDFAF #x8CCB) + (#x8FDFB0 #x8CCF) + (#x8FDFB1 #x8CD6) + (#x8FDFB2 #x8CD5) + (#x8FDFB3 #x8CD9) + (#x8FDFB4 #x8CDD) + (#x8FDFB5 #x8CE1) + (#x8FDFB6 #x8CE8) + (#x8FDFB7 #x8CEC) + (#x8FDFB8 #x8CEF) + (#x8FDFB9 #x8CF0) + (#x8FDFBA #x8CF2) + (#x8FDFBB #x8CF5) + (#x8FDFBC #x8CF7) + (#x8FDFBD #x8CF8) + (#x8FDFBE #x8CFE) + (#x8FDFBF #x8CFF) + (#x8FDFC0 #x8D01) + (#x8FDFC1 #x8D03) + (#x8FDFC2 #x8D09) + (#x8FDFC3 #x8D12) + (#x8FDFC4 #x8D17) + (#x8FDFC5 #x8D1B) + (#x8FDFC6 #x8D65) + (#x8FDFC7 #x8D69) + (#x8FDFC8 #x8D6C) + (#x8FDFC9 #x8D6E) + (#x8FDFCA #x8D7F) + (#x8FDFCB #x8D82) + (#x8FDFCC #x8D84) + (#x8FDFCD #x8D88) + (#x8FDFCE #x8D8D) + (#x8FDFCF #x8D90) + (#x8FDFD0 #x8D91) + (#x8FDFD1 #x8D95) + (#x8FDFD2 #x8D9E) + (#x8FDFD3 #x8D9F) + (#x8FDFD4 #x8DA0) + (#x8FDFD5 #x8DA6) + (#x8FDFD6 #x8DAB) + (#x8FDFD7 #x8DAC) + (#x8FDFD8 #x8DAF) + (#x8FDFD9 #x8DB2) + (#x8FDFDA #x8DB5) + (#x8FDFDB #x8DB7) + (#x8FDFDC #x8DB9) + (#x8FDFDD #x8DBB) + (#x8FDFDE #x8DC0) + (#x8FDFDF #x8DC5) + (#x8FDFE0 #x8DC6) + (#x8FDFE1 #x8DC7) + (#x8FDFE2 #x8DC8) + (#x8FDFE3 #x8DCA) + (#x8FDFE4 #x8DCE) + (#x8FDFE5 #x8DD1) + (#x8FDFE6 #x8DD4) + (#x8FDFE7 #x8DD5) + (#x8FDFE8 #x8DD7) + (#x8FDFE9 #x8DD9) + (#x8FDFEA #x8DE4) + (#x8FDFEB #x8DE5) + (#x8FDFEC #x8DE7) + (#x8FDFED #x8DEC) + (#x8FDFEE #x8DF0) + (#x8FDFEF #x8DBC) + (#x8FDFF0 #x8DF1) + (#x8FDFF1 #x8DF2) + (#x8FDFF2 #x8DF4) + (#x8FDFF3 #x8DFD) + (#x8FDFF4 #x8E01) + (#x8FDFF5 #x8E04) + (#x8FDFF6 #x8E05) + (#x8FDFF7 #x8E06) + (#x8FDFF8 #x8E0B) + (#x8FDFF9 #x8E11) + (#x8FDFFA #x8E14) + (#x8FDFFB #x8E16) + (#x8FDFFC #x8E20) + (#x8FDFFD #x8E21) + (#x8FDFFE #x8E22) + (#x8FE0A1 #x8E23) + (#x8FE0A2 #x8E26) + (#x8FE0A3 #x8E27) + (#x8FE0A4 #x8E31) + (#x8FE0A5 #x8E33) + (#x8FE0A6 #x8E36) + (#x8FE0A7 #x8E37) + (#x8FE0A8 #x8E38) + (#x8FE0A9 #x8E39) + (#x8FE0AA #x8E3D) + (#x8FE0AB #x8E40) + (#x8FE0AC #x8E41) + (#x8FE0AD #x8E4B) + (#x8FE0AE #x8E4D) + (#x8FE0AF #x8E4E) + (#x8FE0B0 #x8E4F) + (#x8FE0B1 #x8E54) + (#x8FE0B2 #x8E5B) + (#x8FE0B3 #x8E5C) + (#x8FE0B4 #x8E5D) + (#x8FE0B5 #x8E5E) + (#x8FE0B6 #x8E61) + (#x8FE0B7 #x8E62) + (#x8FE0B8 #x8E69) + (#x8FE0B9 #x8E6C) + (#x8FE0BA #x8E6D) + (#x8FE0BB #x8E6F) + (#x8FE0BC #x8E70) + (#x8FE0BD #x8E71) + (#x8FE0BE #x8E79) + (#x8FE0BF #x8E7A) + (#x8FE0C0 #x8E7B) + (#x8FE0C1 #x8E82) + (#x8FE0C2 #x8E83) + (#x8FE0C3 #x8E89) + (#x8FE0C4 #x8E90) + (#x8FE0C5 #x8E92) + (#x8FE0C6 #x8E95) + (#x8FE0C7 #x8E9A) + (#x8FE0C8 #x8E9B) + (#x8FE0C9 #x8E9D) + (#x8FE0CA #x8E9E) + (#x8FE0CB #x8EA2) + (#x8FE0CC #x8EA7) + (#x8FE0CD #x8EA9) + (#x8FE0CE #x8EAD) + (#x8FE0CF #x8EAE) + (#x8FE0D0 #x8EB3) + (#x8FE0D1 #x8EB5) + (#x8FE0D2 #x8EBA) + (#x8FE0D3 #x8EBB) + (#x8FE0D4 #x8EC0) + (#x8FE0D5 #x8EC1) + (#x8FE0D6 #x8EC3) + (#x8FE0D7 #x8EC4) + (#x8FE0D8 #x8EC7) + (#x8FE0D9 #x8ECF) + (#x8FE0DA #x8ED1) + (#x8FE0DB #x8ED4) + (#x8FE0DC #x8EDC) + (#x8FE0DD #x8EE8) + (#x8FE0DE #x8EEE) + (#x8FE0DF #x8EF0) + (#x8FE0E0 #x8EF1) + (#x8FE0E1 #x8EF7) + (#x8FE0E2 #x8EF9) + (#x8FE0E3 #x8EFA) + (#x8FE0E4 #x8EED) + (#x8FE0E5 #x8F00) + (#x8FE0E6 #x8F02) + (#x8FE0E7 #x8F07) + (#x8FE0E8 #x8F08) + (#x8FE0E9 #x8F0F) + (#x8FE0EA #x8F10) + (#x8FE0EB #x8F16) + (#x8FE0EC #x8F17) + (#x8FE0ED #x8F18) + (#x8FE0EE #x8F1E) + (#x8FE0EF #x8F20) + (#x8FE0F0 #x8F21) + (#x8FE0F1 #x8F23) + (#x8FE0F2 #x8F25) + (#x8FE0F3 #x8F27) + (#x8FE0F4 #x8F28) + (#x8FE0F5 #x8F2C) + (#x8FE0F6 #x8F2D) + (#x8FE0F7 #x8F2E) + (#x8FE0F8 #x8F34) + (#x8FE0F9 #x8F35) + (#x8FE0FA #x8F36) + (#x8FE0FB #x8F37) + (#x8FE0FC #x8F3A) + (#x8FE0FD #x8F40) + (#x8FE0FE #x8F41) + (#x8FE1A1 #x8F43) + (#x8FE1A2 #x8F47) + (#x8FE1A3 #x8F4F) + (#x8FE1A4 #x8F51) + (#x8FE1A5 #x8F52) + (#x8FE1A6 #x8F53) + (#x8FE1A7 #x8F54) + (#x8FE1A8 #x8F55) + (#x8FE1A9 #x8F58) + (#x8FE1AA #x8F5D) + (#x8FE1AB #x8F5E) + (#x8FE1AC #x8F65) + (#x8FE1AD #x8F9D) + (#x8FE1AE #x8FA0) + (#x8FE1AF #x8FA1) + (#x8FE1B0 #x8FA4) + (#x8FE1B1 #x8FA5) + (#x8FE1B2 #x8FA6) + (#x8FE1B3 #x8FB5) + (#x8FE1B4 #x8FB6) + (#x8FE1B5 #x8FB8) + (#x8FE1B6 #x8FBE) + (#x8FE1B7 #x8FC0) + (#x8FE1B8 #x8FC1) + (#x8FE1B9 #x8FC6) + (#x8FE1BA #x8FCA) + (#x8FE1BB #x8FCB) + (#x8FE1BC #x8FCD) + (#x8FE1BD #x8FD0) + (#x8FE1BE #x8FD2) + (#x8FE1BF #x8FD3) + (#x8FE1C0 #x8FD5) + (#x8FE1C1 #x8FE0) + (#x8FE1C2 #x8FE3) + (#x8FE1C3 #x8FE4) + (#x8FE1C4 #x8FE8) + (#x8FE1C5 #x8FEE) + (#x8FE1C6 #x8FF1) + (#x8FE1C7 #x8FF5) + (#x8FE1C8 #x8FF6) + (#x8FE1C9 #x8FFB) + (#x8FE1CA #x8FFE) + (#x8FE1CB #x9002) + (#x8FE1CC #x9004) + (#x8FE1CD #x9008) + (#x8FE1CE #x900C) + (#x8FE1CF #x9018) + (#x8FE1D0 #x901B) + (#x8FE1D1 #x9028) + (#x8FE1D2 #x9029) + (#x8FE1D3 #x902F) + (#x8FE1D4 #x902A) + (#x8FE1D5 #x902C) + (#x8FE1D6 #x902D) + (#x8FE1D7 #x9033) + (#x8FE1D8 #x9034) + (#x8FE1D9 #x9037) + (#x8FE1DA #x903F) + (#x8FE1DB #x9043) + (#x8FE1DC #x9044) + (#x8FE1DD #x904C) + (#x8FE1DE #x905B) + (#x8FE1DF #x905D) + (#x8FE1E0 #x9062) + (#x8FE1E1 #x9066) + (#x8FE1E2 #x9067) + (#x8FE1E3 #x906C) + (#x8FE1E4 #x9070) + (#x8FE1E5 #x9074) + (#x8FE1E6 #x9079) + (#x8FE1E7 #x9085) + (#x8FE1E8 #x9088) + (#x8FE1E9 #x908B) + (#x8FE1EA #x908C) + (#x8FE1EB #x908E) + (#x8FE1EC #x9090) + (#x8FE1ED #x9095) + (#x8FE1EE #x9097) + (#x8FE1EF #x9098) + (#x8FE1F0 #x9099) + (#x8FE1F1 #x909B) + (#x8FE1F2 #x90A0) + (#x8FE1F3 #x90A1) + (#x8FE1F4 #x90A2) + (#x8FE1F5 #x90A5) + (#x8FE1F6 #x90B0) + (#x8FE1F7 #x90B2) + (#x8FE1F8 #x90B3) + (#x8FE1F9 #x90B4) + (#x8FE1FA #x90B6) + (#x8FE1FB #x90BD) + (#x8FE1FC #x90CC) + (#x8FE1FD #x90BE) + (#x8FE1FE #x90C3) + (#x8FE2A1 #x90C4) + (#x8FE2A2 #x90C5) + (#x8FE2A3 #x90C7) + (#x8FE2A4 #x90C8) + (#x8FE2A5 #x90D5) + (#x8FE2A6 #x90D7) + (#x8FE2A7 #x90D8) + (#x8FE2A8 #x90D9) + (#x8FE2A9 #x90DC) + (#x8FE2AA #x90DD) + (#x8FE2AB #x90DF) + (#x8FE2AC #x90E5) + (#x8FE2AD #x90D2) + (#x8FE2AE #x90F6) + (#x8FE2AF #x90EB) + (#x8FE2B0 #x90EF) + (#x8FE2B1 #x90F0) + (#x8FE2B2 #x90F4) + (#x8FE2B3 #x90FE) + (#x8FE2B4 #x90FF) + (#x8FE2B5 #x9100) + (#x8FE2B6 #x9104) + (#x8FE2B7 #x9105) + (#x8FE2B8 #x9106) + (#x8FE2B9 #x9108) + (#x8FE2BA #x910D) + (#x8FE2BB #x9110) + (#x8FE2BC #x9114) + (#x8FE2BD #x9116) + (#x8FE2BE #x9117) + (#x8FE2BF #x9118) + (#x8FE2C0 #x911A) + (#x8FE2C1 #x911C) + (#x8FE2C2 #x911E) + (#x8FE2C3 #x9120) + (#x8FE2C4 #x9125) + (#x8FE2C5 #x9122) + (#x8FE2C6 #x9123) + (#x8FE2C7 #x9127) + (#x8FE2C8 #x9129) + (#x8FE2C9 #x912E) + (#x8FE2CA #x912F) + (#x8FE2CB #x9131) + (#x8FE2CC #x9134) + (#x8FE2CD #x9136) + (#x8FE2CE #x9137) + (#x8FE2CF #x9139) + (#x8FE2D0 #x913A) + (#x8FE2D1 #x913C) + (#x8FE2D2 #x913D) + (#x8FE2D3 #x9143) + (#x8FE2D4 #x9147) + (#x8FE2D5 #x9148) + (#x8FE2D6 #x914F) + (#x8FE2D7 #x9153) + (#x8FE2D8 #x9157) + (#x8FE2D9 #x9159) + (#x8FE2DA #x915A) + (#x8FE2DB #x915B) + (#x8FE2DC #x9161) + (#x8FE2DD #x9164) + (#x8FE2DE #x9167) + (#x8FE2DF #x916D) + (#x8FE2E0 #x9174) + (#x8FE2E1 #x9179) + (#x8FE2E2 #x917A) + (#x8FE2E3 #x917B) + (#x8FE2E4 #x9181) + (#x8FE2E5 #x9183) + (#x8FE2E6 #x9185) + (#x8FE2E7 #x9186) + (#x8FE2E8 #x918A) + (#x8FE2E9 #x918E) + (#x8FE2EA #x9191) + (#x8FE2EB #x9193) + (#x8FE2EC #x9194) + (#x8FE2ED #x9195) + (#x8FE2EE #x9198) + (#x8FE2EF #x919E) + (#x8FE2F0 #x91A1) + (#x8FE2F1 #x91A6) + (#x8FE2F2 #x91A8) + (#x8FE2F3 #x91AC) + (#x8FE2F4 #x91AD) + (#x8FE2F5 #x91AE) + (#x8FE2F6 #x91B0) + (#x8FE2F7 #x91B1) + (#x8FE2F8 #x91B2) + (#x8FE2F9 #x91B3) + (#x8FE2FA #x91B6) + (#x8FE2FB #x91BB) + (#x8FE2FC #x91BC) + (#x8FE2FD #x91BD) + (#x8FE2FE #x91BF) + (#x8FE3A1 #x91C2) + (#x8FE3A2 #x91C3) + (#x8FE3A3 #x91C5) + (#x8FE3A4 #x91D3) + (#x8FE3A5 #x91D4) + (#x8FE3A6 #x91D7) + (#x8FE3A7 #x91D9) + (#x8FE3A8 #x91DA) + (#x8FE3A9 #x91DE) + (#x8FE3AA #x91E4) + (#x8FE3AB #x91E5) + (#x8FE3AC #x91E9) + (#x8FE3AD #x91EA) + (#x8FE3AE #x91EC) + (#x8FE3AF #x91ED) + (#x8FE3B0 #x91EE) + (#x8FE3B1 #x91EF) + (#x8FE3B2 #x91F0) + (#x8FE3B3 #x91F1) + (#x8FE3B4 #x91F7) + (#x8FE3B5 #x91F9) + (#x8FE3B6 #x91FB) + (#x8FE3B7 #x91FD) + (#x8FE3B8 #x9200) + (#x8FE3B9 #x9201) + (#x8FE3BA #x9204) + (#x8FE3BB #x9205) + (#x8FE3BC #x9206) + (#x8FE3BD #x9207) + (#x8FE3BE #x9209) + (#x8FE3BF #x920A) + (#x8FE3C0 #x920C) + (#x8FE3C1 #x9210) + (#x8FE3C2 #x9212) + (#x8FE3C3 #x9213) + (#x8FE3C4 #x9216) + (#x8FE3C5 #x9218) + (#x8FE3C6 #x921C) + (#x8FE3C7 #x921D) + (#x8FE3C8 #x9223) + (#x8FE3C9 #x9224) + (#x8FE3CA #x9225) + (#x8FE3CB #x9226) + (#x8FE3CC #x9228) + (#x8FE3CD #x922E) + (#x8FE3CE #x922F) + (#x8FE3CF #x9230) + (#x8FE3D0 #x9233) + (#x8FE3D1 #x9235) + (#x8FE3D2 #x9236) + (#x8FE3D3 #x9238) + (#x8FE3D4 #x9239) + (#x8FE3D5 #x923A) + (#x8FE3D6 #x923C) + (#x8FE3D7 #x923E) + (#x8FE3D8 #x9240) + (#x8FE3D9 #x9242) + (#x8FE3DA #x9243) + (#x8FE3DB #x9246) + (#x8FE3DC #x9247) + (#x8FE3DD #x924A) + (#x8FE3DE #x924D) + (#x8FE3DF #x924E) + (#x8FE3E0 #x924F) + (#x8FE3E1 #x9251) + (#x8FE3E2 #x9258) + (#x8FE3E3 #x9259) + (#x8FE3E4 #x925C) + (#x8FE3E5 #x925D) + (#x8FE3E6 #x9260) + (#x8FE3E7 #x9261) + (#x8FE3E8 #x9265) + (#x8FE3E9 #x9267) + (#x8FE3EA #x9268) + (#x8FE3EB #x9269) + (#x8FE3EC #x926E) + (#x8FE3ED #x926F) + (#x8FE3EE #x9270) + (#x8FE3EF #x9275) + (#x8FE3F0 #x9276) + (#x8FE3F1 #x9277) + (#x8FE3F2 #x9278) + (#x8FE3F3 #x9279) + (#x8FE3F4 #x927B) + (#x8FE3F5 #x927C) + (#x8FE3F6 #x927D) + (#x8FE3F7 #x927F) + (#x8FE3F8 #x9288) + (#x8FE3F9 #x9289) + (#x8FE3FA #x928A) + (#x8FE3FB #x928D) + (#x8FE3FC #x928E) + (#x8FE3FD #x9292) + (#x8FE3FE #x9297) + (#x8FE4A1 #x9299) + (#x8FE4A2 #x929F) + (#x8FE4A3 #x92A0) + (#x8FE4A4 #x92A4) + (#x8FE4A5 #x92A5) + (#x8FE4A6 #x92A7) + (#x8FE4A7 #x92A8) + (#x8FE4A8 #x92AB) + (#x8FE4A9 #x92AF) + (#x8FE4AA #x92B2) + (#x8FE4AB #x92B6) + (#x8FE4AC #x92B8) + (#x8FE4AD #x92BA) + (#x8FE4AE #x92BB) + (#x8FE4AF #x92BC) + (#x8FE4B0 #x92BD) + (#x8FE4B1 #x92BF) + (#x8FE4B2 #x92C0) + (#x8FE4B3 #x92C1) + (#x8FE4B4 #x92C2) + (#x8FE4B5 #x92C3) + (#x8FE4B6 #x92C5) + (#x8FE4B7 #x92C6) + (#x8FE4B8 #x92C7) + (#x8FE4B9 #x92C8) + (#x8FE4BA #x92CB) + (#x8FE4BB #x92CC) + (#x8FE4BC #x92CD) + (#x8FE4BD #x92CE) + (#x8FE4BE #x92D0) + (#x8FE4BF #x92D3) + (#x8FE4C0 #x92D5) + (#x8FE4C1 #x92D7) + (#x8FE4C2 #x92D8) + (#x8FE4C3 #x92D9) + (#x8FE4C4 #x92DC) + (#x8FE4C5 #x92DD) + (#x8FE4C6 #x92DF) + (#x8FE4C7 #x92E0) + (#x8FE4C8 #x92E1) + (#x8FE4C9 #x92E3) + (#x8FE4CA #x92E5) + (#x8FE4CB #x92E7) + (#x8FE4CC #x92E8) + (#x8FE4CD #x92EC) + (#x8FE4CE #x92EE) + (#x8FE4CF #x92F0) + (#x8FE4D0 #x92F9) + (#x8FE4D1 #x92FB) + (#x8FE4D2 #x92FF) + (#x8FE4D3 #x9300) + (#x8FE4D4 #x9302) + (#x8FE4D5 #x9308) + (#x8FE4D6 #x930D) + (#x8FE4D7 #x9311) + (#x8FE4D8 #x9314) + (#x8FE4D9 #x9315) + (#x8FE4DA #x931C) + (#x8FE4DB #x931D) + (#x8FE4DC #x931E) + (#x8FE4DD #x931F) + (#x8FE4DE #x9321) + (#x8FE4DF #x9324) + (#x8FE4E0 #x9325) + (#x8FE4E1 #x9327) + (#x8FE4E2 #x9329) + (#x8FE4E3 #x932A) + (#x8FE4E4 #x9333) + (#x8FE4E5 #x9334) + (#x8FE4E6 #x9336) + (#x8FE4E7 #x9337) + (#x8FE4E8 #x9347) + (#x8FE4E9 #x9348) + (#x8FE4EA #x9349) + (#x8FE4EB #x9350) + (#x8FE4EC #x9351) + (#x8FE4ED #x9352) + (#x8FE4EE #x9355) + (#x8FE4EF #x9357) + (#x8FE4F0 #x9358) + (#x8FE4F1 #x935A) + (#x8FE4F2 #x935E) + (#x8FE4F3 #x9364) + (#x8FE4F4 #x9365) + (#x8FE4F5 #x9367) + (#x8FE4F6 #x9369) + (#x8FE4F7 #x936A) + (#x8FE4F8 #x936D) + (#x8FE4F9 #x936F) + (#x8FE4FA #x9370) + (#x8FE4FB #x9371) + (#x8FE4FC #x9373) + (#x8FE4FD #x9374) + (#x8FE4FE #x9376) + (#x8FE5A1 #x937A) + (#x8FE5A2 #x937D) + (#x8FE5A3 #x937F) + (#x8FE5A4 #x9380) + (#x8FE5A5 #x9381) + (#x8FE5A6 #x9382) + (#x8FE5A7 #x9388) + (#x8FE5A8 #x938A) + (#x8FE5A9 #x938B) + (#x8FE5AA #x938D) + (#x8FE5AB #x938F) + (#x8FE5AC #x9392) + (#x8FE5AD #x9395) + (#x8FE5AE #x9398) + (#x8FE5AF #x939B) + (#x8FE5B0 #x939E) + (#x8FE5B1 #x93A1) + (#x8FE5B2 #x93A3) + (#x8FE5B3 #x93A4) + (#x8FE5B4 #x93A6) + (#x8FE5B5 #x93A8) + (#x8FE5B6 #x93AB) + (#x8FE5B7 #x93B4) + (#x8FE5B8 #x93B5) + (#x8FE5B9 #x93B6) + (#x8FE5BA #x93BA) + (#x8FE5BB #x93A9) + (#x8FE5BC #x93C1) + (#x8FE5BD #x93C4) + (#x8FE5BE #x93C5) + (#x8FE5BF #x93C6) + (#x8FE5C0 #x93C7) + (#x8FE5C1 #x93C9) + (#x8FE5C2 #x93CA) + (#x8FE5C3 #x93CB) + (#x8FE5C4 #x93CC) + (#x8FE5C5 #x93CD) + (#x8FE5C6 #x93D3) + (#x8FE5C7 #x93D9) + (#x8FE5C8 #x93DC) + (#x8FE5C9 #x93DE) + (#x8FE5CA #x93DF) + (#x8FE5CB #x93E2) + (#x8FE5CC #x93E6) + (#x8FE5CD #x93E7) + (#x8FE5CE #x93F9) + (#x8FE5CF #x93F7) + (#x8FE5D0 #x93F8) + (#x8FE5D1 #x93FA) + (#x8FE5D2 #x93FB) + (#x8FE5D3 #x93FD) + (#x8FE5D4 #x9401) + (#x8FE5D5 #x9402) + (#x8FE5D6 #x9404) + (#x8FE5D7 #x9408) + (#x8FE5D8 #x9409) + (#x8FE5D9 #x940D) + (#x8FE5DA #x940E) + (#x8FE5DB #x940F) + (#x8FE5DC #x9415) + (#x8FE5DD #x9416) + (#x8FE5DE #x9417) + (#x8FE5DF #x941F) + (#x8FE5E0 #x942E) + (#x8FE5E1 #x942F) + (#x8FE5E2 #x9431) + (#x8FE5E3 #x9432) + (#x8FE5E4 #x9433) + (#x8FE5E5 #x9434) + (#x8FE5E6 #x943B) + (#x8FE5E7 #x943F) + (#x8FE5E8 #x943D) + (#x8FE5E9 #x9443) + (#x8FE5EA #x9445) + (#x8FE5EB #x9448) + (#x8FE5EC #x944A) + (#x8FE5ED #x944C) + (#x8FE5EE #x9455) + (#x8FE5EF #x9459) + (#x8FE5F0 #x945C) + (#x8FE5F1 #x945F) + (#x8FE5F2 #x9461) + (#x8FE5F3 #x9463) + (#x8FE5F4 #x9468) + (#x8FE5F5 #x946B) + (#x8FE5F6 #x946D) + (#x8FE5F7 #x946E) + (#x8FE5F8 #x946F) + (#x8FE5F9 #x9471) + (#x8FE5FA #x9472) + (#x8FE5FB #x9484) + (#x8FE5FC #x9483) + (#x8FE5FD #x9578) + (#x8FE5FE #x9579) + (#x8FE6A1 #x957E) + (#x8FE6A2 #x9584) + (#x8FE6A3 #x9588) + (#x8FE6A4 #x958C) + (#x8FE6A5 #x958D) + (#x8FE6A6 #x958E) + (#x8FE6A7 #x959D) + (#x8FE6A8 #x959E) + (#x8FE6A9 #x959F) + (#x8FE6AA #x95A1) + (#x8FE6AB #x95A6) + (#x8FE6AC #x95A9) + (#x8FE6AD #x95AB) + (#x8FE6AE #x95AC) + (#x8FE6AF #x95B4) + (#x8FE6B0 #x95B6) + (#x8FE6B1 #x95BA) + (#x8FE6B2 #x95BD) + (#x8FE6B3 #x95BF) + (#x8FE6B4 #x95C6) + (#x8FE6B5 #x95C8) + (#x8FE6B6 #x95C9) + (#x8FE6B7 #x95CB) + (#x8FE6B8 #x95D0) + (#x8FE6B9 #x95D1) + (#x8FE6BA #x95D2) + (#x8FE6BB #x95D3) + (#x8FE6BC #x95D9) + (#x8FE6BD #x95DA) + (#x8FE6BE #x95DD) + (#x8FE6BF #x95DE) + (#x8FE6C0 #x95DF) + (#x8FE6C1 #x95E0) + (#x8FE6C2 #x95E4) + (#x8FE6C3 #x95E6) + (#x8FE6C4 #x961D) + (#x8FE6C5 #x961E) + (#x8FE6C6 #x9622) + (#x8FE6C7 #x9624) + (#x8FE6C8 #x9625) + (#x8FE6C9 #x9626) + (#x8FE6CA #x962C) + (#x8FE6CB #x9631) + (#x8FE6CC #x9633) + (#x8FE6CD #x9637) + (#x8FE6CE #x9638) + (#x8FE6CF #x9639) + (#x8FE6D0 #x963A) + (#x8FE6D1 #x963C) + (#x8FE6D2 #x963D) + (#x8FE6D3 #x9641) + (#x8FE6D4 #x9652) + (#x8FE6D5 #x9654) + (#x8FE6D6 #x9656) + (#x8FE6D7 #x9657) + (#x8FE6D8 #x9658) + (#x8FE6D9 #x9661) + (#x8FE6DA #x966E) + (#x8FE6DB #x9674) + (#x8FE6DC #x967B) + (#x8FE6DD #x967C) + (#x8FE6DE #x967E) + (#x8FE6DF #x967F) + (#x8FE6E0 #x9681) + (#x8FE6E1 #x9682) + (#x8FE6E2 #x9683) + (#x8FE6E3 #x9684) + (#x8FE6E4 #x9689) + (#x8FE6E5 #x9691) + (#x8FE6E6 #x9696) + (#x8FE6E7 #x969A) + (#x8FE6E8 #x969D) + (#x8FE6E9 #x969F) + (#x8FE6EA #x96A4) + (#x8FE6EB #x96A5) + (#x8FE6EC #x96A6) + (#x8FE6ED #x96A9) + (#x8FE6EE #x96AE) + (#x8FE6EF #x96AF) + (#x8FE6F0 #x96B3) + (#x8FE6F1 #x96BA) + (#x8FE6F2 #x96CA) + (#x8FE6F3 #x96D2) + (#x8FE6F4 #x5DB2) + (#x8FE6F5 #x96D8) + (#x8FE6F6 #x96DA) + (#x8FE6F7 #x96DD) + (#x8FE6F8 #x96DE) + (#x8FE6F9 #x96DF) + (#x8FE6FA #x96E9) + (#x8FE6FB #x96EF) + (#x8FE6FC #x96F1) + (#x8FE6FD #x96FA) + (#x8FE6FE #x9702) + (#x8FE7A1 #x9703) + (#x8FE7A2 #x9705) + (#x8FE7A3 #x9709) + (#x8FE7A4 #x971A) + (#x8FE7A5 #x971B) + (#x8FE7A6 #x971D) + (#x8FE7A7 #x9721) + (#x8FE7A8 #x9722) + (#x8FE7A9 #x9723) + (#x8FE7AA #x9728) + (#x8FE7AB #x9731) + (#x8FE7AC #x9733) + (#x8FE7AD #x9741) + (#x8FE7AE #x9743) + (#x8FE7AF #x974A) + (#x8FE7B0 #x974E) + (#x8FE7B1 #x974F) + (#x8FE7B2 #x9755) + (#x8FE7B3 #x9757) + (#x8FE7B4 #x9758) + (#x8FE7B5 #x975A) + (#x8FE7B6 #x975B) + (#x8FE7B7 #x9763) + (#x8FE7B8 #x9767) + (#x8FE7B9 #x976A) + (#x8FE7BA #x976E) + (#x8FE7BB #x9773) + (#x8FE7BC #x9776) + (#x8FE7BD #x9777) + (#x8FE7BE #x9778) + (#x8FE7BF #x977B) + (#x8FE7C0 #x977D) + (#x8FE7C1 #x977F) + (#x8FE7C2 #x9780) + (#x8FE7C3 #x9789) + (#x8FE7C4 #x9795) + (#x8FE7C5 #x9796) + (#x8FE7C6 #x9797) + (#x8FE7C7 #x9799) + (#x8FE7C8 #x979A) + (#x8FE7C9 #x979E) + (#x8FE7CA #x979F) + (#x8FE7CB #x97A2) + (#x8FE7CC #x97AC) + (#x8FE7CD #x97AE) + (#x8FE7CE #x97B1) + (#x8FE7CF #x97B2) + (#x8FE7D0 #x97B5) + (#x8FE7D1 #x97B6) + (#x8FE7D2 #x97B8) + (#x8FE7D3 #x97B9) + (#x8FE7D4 #x97BA) + (#x8FE7D5 #x97BC) + (#x8FE7D6 #x97BE) + (#x8FE7D7 #x97BF) + (#x8FE7D8 #x97C1) + (#x8FE7D9 #x97C4) + (#x8FE7DA #x97C5) + (#x8FE7DB #x97C7) + (#x8FE7DC #x97C9) + (#x8FE7DD #x97CA) + (#x8FE7DE #x97CC) + (#x8FE7DF #x97CD) + (#x8FE7E0 #x97CE) + (#x8FE7E1 #x97D0) + (#x8FE7E2 #x97D1) + (#x8FE7E3 #x97D4) + (#x8FE7E4 #x97D7) + (#x8FE7E5 #x97D8) + (#x8FE7E6 #x97D9) + (#x8FE7E7 #x97DD) + (#x8FE7E8 #x97DE) + (#x8FE7E9 #x97E0) + (#x8FE7EA #x97DB) + (#x8FE7EB #x97E1) + (#x8FE7EC #x97E4) + (#x8FE7ED #x97EF) + (#x8FE7EE #x97F1) + (#x8FE7EF #x97F4) + (#x8FE7F0 #x97F7) + (#x8FE7F1 #x97F8) + (#x8FE7F2 #x97FA) + (#x8FE7F3 #x9807) + (#x8FE7F4 #x980A) + (#x8FE7F5 #x9819) + (#x8FE7F6 #x980D) + (#x8FE7F7 #x980E) + (#x8FE7F8 #x9814) + (#x8FE7F9 #x9816) + (#x8FE7FA #x981C) + (#x8FE7FB #x981E) + (#x8FE7FC #x9820) + (#x8FE7FD #x9823) + (#x8FE7FE #x9826) + (#x8FE8A1 #x982B) + (#x8FE8A2 #x982E) + (#x8FE8A3 #x982F) + (#x8FE8A4 #x9830) + (#x8FE8A5 #x9832) + (#x8FE8A6 #x9833) + (#x8FE8A7 #x9835) + (#x8FE8A8 #x9825) + (#x8FE8A9 #x983E) + (#x8FE8AA #x9844) + (#x8FE8AB #x9847) + (#x8FE8AC #x984A) + (#x8FE8AD #x9851) + (#x8FE8AE #x9852) + (#x8FE8AF #x9853) + (#x8FE8B0 #x9856) + (#x8FE8B1 #x9857) + (#x8FE8B2 #x9859) + (#x8FE8B3 #x985A) + (#x8FE8B4 #x9862) + (#x8FE8B5 #x9863) + (#x8FE8B6 #x9865) + (#x8FE8B7 #x9866) + (#x8FE8B8 #x986A) + (#x8FE8B9 #x986C) + (#x8FE8BA #x98AB) + (#x8FE8BB #x98AD) + (#x8FE8BC #x98AE) + (#x8FE8BD #x98B0) + (#x8FE8BE #x98B4) + (#x8FE8BF #x98B7) + (#x8FE8C0 #x98B8) + (#x8FE8C1 #x98BA) + (#x8FE8C2 #x98BB) + (#x8FE8C3 #x98BF) + (#x8FE8C4 #x98C2) + (#x8FE8C5 #x98C5) + (#x8FE8C6 #x98C8) + (#x8FE8C7 #x98CC) + (#x8FE8C8 #x98E1) + (#x8FE8C9 #x98E3) + (#x8FE8CA #x98E5) + (#x8FE8CB #x98E6) + (#x8FE8CC #x98E7) + (#x8FE8CD #x98EA) + (#x8FE8CE #x98F3) + (#x8FE8CF #x98F6) + (#x8FE8D0 #x9902) + (#x8FE8D1 #x9907) + (#x8FE8D2 #x9908) + (#x8FE8D3 #x9911) + (#x8FE8D4 #x9915) + (#x8FE8D5 #x9916) + (#x8FE8D6 #x9917) + (#x8FE8D7 #x991A) + (#x8FE8D8 #x991B) + (#x8FE8D9 #x991C) + (#x8FE8DA #x991F) + (#x8FE8DB #x9922) + (#x8FE8DC #x9926) + (#x8FE8DD #x9927) + (#x8FE8DE #x992B) + (#x8FE8DF #x9931) + (#x8FE8E0 #x9932) + (#x8FE8E1 #x9933) + (#x8FE8E2 #x9934) + (#x8FE8E3 #x9935) + (#x8FE8E4 #x9939) + (#x8FE8E5 #x993A) + (#x8FE8E6 #x993B) + (#x8FE8E7 #x993C) + (#x8FE8E8 #x9940) + (#x8FE8E9 #x9941) + (#x8FE8EA #x9946) + (#x8FE8EB #x9947) + (#x8FE8EC #x9948) + (#x8FE8ED #x994D) + (#x8FE8EE #x994E) + (#x8FE8EF #x9954) + (#x8FE8F0 #x9958) + (#x8FE8F1 #x9959) + (#x8FE8F2 #x995B) + (#x8FE8F3 #x995C) + (#x8FE8F4 #x995E) + (#x8FE8F5 #x995F) + (#x8FE8F6 #x9960) + (#x8FE8F7 #x999B) + (#x8FE8F8 #x999D) + (#x8FE8F9 #x999F) + (#x8FE8FA #x99A6) + (#x8FE8FB #x99B0) + (#x8FE8FC #x99B1) + (#x8FE8FD #x99B2) + (#x8FE8FE #x99B5) + (#x8FE9A1 #x99B9) + (#x8FE9A2 #x99BA) + (#x8FE9A3 #x99BD) + (#x8FE9A4 #x99BF) + (#x8FE9A5 #x99C3) + (#x8FE9A6 #x99C9) + (#x8FE9A7 #x99D3) + (#x8FE9A8 #x99D4) + (#x8FE9A9 #x99D9) + (#x8FE9AA #x99DA) + (#x8FE9AB #x99DC) + (#x8FE9AC #x99DE) + (#x8FE9AD #x99E7) + (#x8FE9AE #x99EA) + (#x8FE9AF #x99EB) + (#x8FE9B0 #x99EC) + (#x8FE9B1 #x99F0) + (#x8FE9B2 #x99F4) + (#x8FE9B3 #x99F5) + (#x8FE9B4 #x99F9) + (#x8FE9B5 #x99FD) + (#x8FE9B6 #x99FE) + (#x8FE9B7 #x9A02) + (#x8FE9B8 #x9A03) + (#x8FE9B9 #x9A04) + (#x8FE9BA #x9A0B) + (#x8FE9BB #x9A0C) + (#x8FE9BC #x9A10) + (#x8FE9BD #x9A11) + (#x8FE9BE #x9A16) + (#x8FE9BF #x9A1E) + (#x8FE9C0 #x9A20) + (#x8FE9C1 #x9A22) + (#x8FE9C2 #x9A23) + (#x8FE9C3 #x9A24) + (#x8FE9C4 #x9A27) + (#x8FE9C5 #x9A2D) + (#x8FE9C6 #x9A2E) + (#x8FE9C7 #x9A33) + (#x8FE9C8 #x9A35) + (#x8FE9C9 #x9A36) + (#x8FE9CA #x9A38) + (#x8FE9CB #x9A47) + (#x8FE9CC #x9A41) + (#x8FE9CD #x9A44) + (#x8FE9CE #x9A4A) + (#x8FE9CF #x9A4B) + (#x8FE9D0 #x9A4C) + (#x8FE9D1 #x9A4E) + (#x8FE9D2 #x9A51) + (#x8FE9D3 #x9A54) + (#x8FE9D4 #x9A56) + (#x8FE9D5 #x9A5D) + (#x8FE9D6 #x9AAA) + (#x8FE9D7 #x9AAC) + (#x8FE9D8 #x9AAE) + (#x8FE9D9 #x9AAF) + (#x8FE9DA #x9AB2) + (#x8FE9DB #x9AB4) + (#x8FE9DC #x9AB5) + (#x8FE9DD #x9AB6) + (#x8FE9DE #x9AB9) + (#x8FE9DF #x9ABB) + (#x8FE9E0 #x9ABE) + (#x8FE9E1 #x9ABF) + (#x8FE9E2 #x9AC1) + (#x8FE9E3 #x9AC3) + (#x8FE9E4 #x9AC6) + (#x8FE9E5 #x9AC8) + (#x8FE9E6 #x9ACE) + (#x8FE9E7 #x9AD0) + (#x8FE9E8 #x9AD2) + (#x8FE9E9 #x9AD5) + (#x8FE9EA #x9AD6) + (#x8FE9EB #x9AD7) + (#x8FE9EC #x9ADB) + (#x8FE9ED #x9ADC) + (#x8FE9EE #x9AE0) + (#x8FE9EF #x9AE4) + (#x8FE9F0 #x9AE5) + (#x8FE9F1 #x9AE7) + (#x8FE9F2 #x9AE9) + (#x8FE9F3 #x9AEC) + (#x8FE9F4 #x9AF2) + (#x8FE9F5 #x9AF3) + (#x8FE9F6 #x9AF5) + (#x8FE9F7 #x9AF9) + (#x8FE9F8 #x9AFA) + (#x8FE9F9 #x9AFD) + (#x8FE9FA #x9AFF) + (#x8FE9FB #x9B00) + (#x8FE9FC #x9B01) + (#x8FE9FD #x9B02) + (#x8FE9FE #x9B03) + (#x8FEAA1 #x9B04) + (#x8FEAA2 #x9B05) + (#x8FEAA3 #x9B08) + (#x8FEAA4 #x9B09) + (#x8FEAA5 #x9B0B) + (#x8FEAA6 #x9B0C) + (#x8FEAA7 #x9B0D) + (#x8FEAA8 #x9B0E) + (#x8FEAA9 #x9B10) + (#x8FEAAA #x9B12) + (#x8FEAAB #x9B16) + (#x8FEAAC #x9B19) + (#x8FEAAD #x9B1B) + (#x8FEAAE #x9B1C) + (#x8FEAAF #x9B20) + (#x8FEAB0 #x9B26) + (#x8FEAB1 #x9B2B) + (#x8FEAB2 #x9B2D) + (#x8FEAB3 #x9B33) + (#x8FEAB4 #x9B34) + (#x8FEAB5 #x9B35) + (#x8FEAB6 #x9B37) + (#x8FEAB7 #x9B39) + (#x8FEAB8 #x9B3A) + (#x8FEAB9 #x9B3D) + (#x8FEABA #x9B48) + (#x8FEABB #x9B4B) + (#x8FEABC #x9B4C) + (#x8FEABD #x9B55) + (#x8FEABE #x9B56) + (#x8FEABF #x9B57) + (#x8FEAC0 #x9B5B) + (#x8FEAC1 #x9B5E) + (#x8FEAC2 #x9B61) + (#x8FEAC3 #x9B63) + (#x8FEAC4 #x9B65) + (#x8FEAC5 #x9B66) + (#x8FEAC6 #x9B68) + (#x8FEAC7 #x9B6A) + (#x8FEAC8 #x9B6B) + (#x8FEAC9 #x9B6C) + (#x8FEACA #x9B6D) + (#x8FEACB #x9B6E) + (#x8FEACC #x9B73) + (#x8FEACD #x9B75) + (#x8FEACE #x9B77) + (#x8FEACF #x9B78) + (#x8FEAD0 #x9B79) + (#x8FEAD1 #x9B7F) + (#x8FEAD2 #x9B80) + (#x8FEAD3 #x9B84) + (#x8FEAD4 #x9B85) + (#x8FEAD5 #x9B86) + (#x8FEAD6 #x9B87) + (#x8FEAD7 #x9B89) + (#x8FEAD8 #x9B8A) + (#x8FEAD9 #x9B8B) + (#x8FEADA #x9B8D) + (#x8FEADB #x9B8F) + (#x8FEADC #x9B90) + (#x8FEADD #x9B94) + (#x8FEADE #x9B9A) + (#x8FEADF #x9B9D) + (#x8FEAE0 #x9B9E) + (#x8FEAE1 #x9BA6) + (#x8FEAE2 #x9BA7) + (#x8FEAE3 #x9BA9) + (#x8FEAE4 #x9BAC) + (#x8FEAE5 #x9BB0) + (#x8FEAE6 #x9BB1) + (#x8FEAE7 #x9BB2) + (#x8FEAE8 #x9BB7) + (#x8FEAE9 #x9BB8) + (#x8FEAEA #x9BBB) + (#x8FEAEB #x9BBC) + (#x8FEAEC #x9BBE) + (#x8FEAED #x9BBF) + (#x8FEAEE #x9BC1) + (#x8FEAEF #x9BC7) + (#x8FEAF0 #x9BC8) + (#x8FEAF1 #x9BCE) + (#x8FEAF2 #x9BD0) + (#x8FEAF3 #x9BD7) + (#x8FEAF4 #x9BD8) + (#x8FEAF5 #x9BDD) + (#x8FEAF6 #x9BDF) + (#x8FEAF7 #x9BE5) + (#x8FEAF8 #x9BE7) + (#x8FEAF9 #x9BEA) + (#x8FEAFA #x9BEB) + (#x8FEAFB #x9BEF) + (#x8FEAFC #x9BF3) + (#x8FEAFD #x9BF7) + (#x8FEAFE #x9BF8) + (#x8FEBA1 #x9BF9) + (#x8FEBA2 #x9BFA) + (#x8FEBA3 #x9BFD) + (#x8FEBA4 #x9BFF) + (#x8FEBA5 #x9C00) + (#x8FEBA6 #x9C02) + (#x8FEBA7 #x9C0B) + (#x8FEBA8 #x9C0F) + (#x8FEBA9 #x9C11) + (#x8FEBAA #x9C16) + (#x8FEBAB #x9C18) + (#x8FEBAC #x9C19) + (#x8FEBAD #x9C1A) + (#x8FEBAE #x9C1C) + (#x8FEBAF #x9C1E) + (#x8FEBB0 #x9C22) + (#x8FEBB1 #x9C23) + (#x8FEBB2 #x9C26) + (#x8FEBB3 #x9C27) + (#x8FEBB4 #x9C28) + (#x8FEBB5 #x9C29) + (#x8FEBB6 #x9C2A) + (#x8FEBB7 #x9C31) + (#x8FEBB8 #x9C35) + (#x8FEBB9 #x9C36) + (#x8FEBBA #x9C37) + (#x8FEBBB #x9C3D) + (#x8FEBBC #x9C41) + (#x8FEBBD #x9C43) + (#x8FEBBE #x9C44) + (#x8FEBBF #x9C45) + (#x8FEBC0 #x9C49) + (#x8FEBC1 #x9C4A) + (#x8FEBC2 #x9C4E) + (#x8FEBC3 #x9C4F) + (#x8FEBC4 #x9C50) + (#x8FEBC5 #x9C53) + (#x8FEBC6 #x9C54) + (#x8FEBC7 #x9C56) + (#x8FEBC8 #x9C58) + (#x8FEBC9 #x9C5B) + (#x8FEBCA #x9C5D) + (#x8FEBCB #x9C5E) + (#x8FEBCC #x9C5F) + (#x8FEBCD #x9C63) + (#x8FEBCE #x9C69) + (#x8FEBCF #x9C6A) + (#x8FEBD0 #x9C5C) + (#x8FEBD1 #x9C6B) + (#x8FEBD2 #x9C68) + (#x8FEBD3 #x9C6E) + (#x8FEBD4 #x9C70) + (#x8FEBD5 #x9C72) + (#x8FEBD6 #x9C75) + (#x8FEBD7 #x9C77) + (#x8FEBD8 #x9C7B) + (#x8FEBD9 #x9CE6) + (#x8FEBDA #x9CF2) + (#x8FEBDB #x9CF7) + (#x8FEBDC #x9CF9) + (#x8FEBDD #x9D0B) + (#x8FEBDE #x9D02) + (#x8FEBDF #x9D11) + (#x8FEBE0 #x9D17) + (#x8FEBE1 #x9D18) + (#x8FEBE2 #x9D1C) + (#x8FEBE3 #x9D1D) + (#x8FEBE4 #x9D1E) + (#x8FEBE5 #x9D2F) + (#x8FEBE6 #x9D30) + (#x8FEBE7 #x9D32) + (#x8FEBE8 #x9D33) + (#x8FEBE9 #x9D34) + (#x8FEBEA #x9D3A) + (#x8FEBEB #x9D3C) + (#x8FEBEC #x9D45) + (#x8FEBED #x9D3D) + (#x8FEBEE #x9D42) + (#x8FEBEF #x9D43) + (#x8FEBF0 #x9D47) + (#x8FEBF1 #x9D4A) + (#x8FEBF2 #x9D53) + (#x8FEBF3 #x9D54) + (#x8FEBF4 #x9D5F) + (#x8FEBF5 #x9D63) + (#x8FEBF6 #x9D62) + (#x8FEBF7 #x9D65) + (#x8FEBF8 #x9D69) + (#x8FEBF9 #x9D6A) + (#x8FEBFA #x9D6B) + (#x8FEBFB #x9D70) + (#x8FEBFC #x9D76) + (#x8FEBFD #x9D77) + (#x8FEBFE #x9D7B) + (#x8FECA1 #x9D7C) + (#x8FECA2 #x9D7E) + (#x8FECA3 #x9D83) + (#x8FECA4 #x9D84) + (#x8FECA5 #x9D86) + (#x8FECA6 #x9D8A) + (#x8FECA7 #x9D8D) + (#x8FECA8 #x9D8E) + (#x8FECA9 #x9D92) + (#x8FECAA #x9D93) + (#x8FECAB #x9D95) + (#x8FECAC #x9D96) + (#x8FECAD #x9D97) + (#x8FECAE #x9D98) + (#x8FECAF #x9DA1) + (#x8FECB0 #x9DAA) + (#x8FECB1 #x9DAC) + (#x8FECB2 #x9DAE) + (#x8FECB3 #x9DB1) + (#x8FECB4 #x9DB5) + (#x8FECB5 #x9DB9) + (#x8FECB6 #x9DBC) + (#x8FECB7 #x9DBF) + (#x8FECB8 #x9DC3) + (#x8FECB9 #x9DC7) + (#x8FECBA #x9DC9) + (#x8FECBB #x9DCA) + (#x8FECBC #x9DD4) + (#x8FECBD #x9DD5) + (#x8FECBE #x9DD6) + (#x8FECBF #x9DD7) + (#x8FECC0 #x9DDA) + (#x8FECC1 #x9DDE) + (#x8FECC2 #x9DDF) + (#x8FECC3 #x9DE0) + (#x8FECC4 #x9DE5) + (#x8FECC5 #x9DE7) + (#x8FECC6 #x9DE9) + (#x8FECC7 #x9DEB) + (#x8FECC8 #x9DEE) + (#x8FECC9 #x9DF0) + (#x8FECCA #x9DF3) + (#x8FECCB #x9DF4) + (#x8FECCC #x9DFE) + (#x8FECCD #x9E0A) + (#x8FECCE #x9E02) + (#x8FECCF #x9E07) + (#x8FECD0 #x9E0E) + (#x8FECD1 #x9E10) + (#x8FECD2 #x9E11) + (#x8FECD3 #x9E12) + (#x8FECD4 #x9E15) + (#x8FECD5 #x9E16) + (#x8FECD6 #x9E19) + (#x8FECD7 #x9E1C) + (#x8FECD8 #x9E1D) + (#x8FECD9 #x9E7A) + (#x8FECDA #x9E7B) + (#x8FECDB #x9E7C) + (#x8FECDC #x9E80) + (#x8FECDD #x9E82) + (#x8FECDE #x9E83) + (#x8FECDF #x9E84) + (#x8FECE0 #x9E85) + (#x8FECE1 #x9E87) + (#x8FECE2 #x9E8E) + (#x8FECE3 #x9E8F) + (#x8FECE4 #x9E96) + (#x8FECE5 #x9E98) + (#x8FECE6 #x9E9B) + (#x8FECE7 #x9E9E) + (#x8FECE8 #x9EA4) + (#x8FECE9 #x9EA8) + (#x8FECEA #x9EAC) + (#x8FECEB #x9EAE) + (#x8FECEC #x9EAF) + (#x8FECED #x9EB0) + (#x8FECEE #x9EB3) + (#x8FECEF #x9EB4) + (#x8FECF0 #x9EB5) + (#x8FECF1 #x9EC6) + (#x8FECF2 #x9EC8) + (#x8FECF3 #x9ECB) + (#x8FECF4 #x9ED5) + (#x8FECF5 #x9EDF) + (#x8FECF6 #x9EE4) + (#x8FECF7 #x9EE7) + (#x8FECF8 #x9EEC) + (#x8FECF9 #x9EED) + (#x8FECFA #x9EEE) + (#x8FECFB #x9EF0) + (#x8FECFC #x9EF1) + (#x8FECFD #x9EF2) + (#x8FECFE #x9EF5) + (#x8FEDA1 #x9EF8) + (#x8FEDA2 #x9EFF) + (#x8FEDA3 #x9F02) + (#x8FEDA4 #x9F03) + (#x8FEDA5 #x9F09) + (#x8FEDA6 #x9F0F) + (#x8FEDA7 #x9F10) + (#x8FEDA8 #x9F11) + (#x8FEDA9 #x9F12) + (#x8FEDAA #x9F14) + (#x8FEDAB #x9F16) + (#x8FEDAC #x9F17) + (#x8FEDAD #x9F19) + (#x8FEDAE #x9F1A) + (#x8FEDAF #x9F1B) + (#x8FEDB0 #x9F1F) + (#x8FEDB1 #x9F22) + (#x8FEDB2 #x9F26) + (#x8FEDB3 #x9F2A) + (#x8FEDB4 #x9F2B) + (#x8FEDB5 #x9F2F) + (#x8FEDB6 #x9F31) + (#x8FEDB7 #x9F32) + (#x8FEDB8 #x9F34) + (#x8FEDB9 #x9F37) + (#x8FEDBA #x9F39) + (#x8FEDBB #x9F3A) + (#x8FEDBC #x9F3C) + (#x8FEDBD #x9F3D) + (#x8FEDBE #x9F3F) + (#x8FEDBF #x9F41) + (#x8FEDC0 #x9F43) + (#x8FEDC1 #x9F44) + (#x8FEDC2 #x9F45) + (#x8FEDC3 #x9F46) + (#x8FEDC4 #x9F47) + (#x8FEDC5 #x9F53) + (#x8FEDC6 #x9F55) + (#x8FEDC7 #x9F56) + (#x8FEDC8 #x9F57) + (#x8FEDC9 #x9F58) + (#x8FEDCA #x9F5A) + (#x8FEDCB #x9F5D) + (#x8FEDCC #x9F5E) + (#x8FEDCD #x9F68) + (#x8FEDCE #x9F69) + (#x8FEDCF #x9F6D) + (#x8FEDD0 #x9F6E) + (#x8FEDD1 #x9F6F) + (#x8FEDD2 #x9F70) + (#x8FEDD3 #x9F71) + (#x8FEDD4 #x9F73) + (#x8FEDD5 #x9F75) + (#x8FEDD6 #x9F7A) + (#x8FEDD7 #x9F7D) + (#x8FEDD8 #x9F8F) + (#x8FEDD9 #x9F90) + (#x8FEDDA #x9F91) + (#x8FEDDB #x9F92) + (#x8FEDDC #x9F94) + (#x8FEDDD #x9F96) + (#x8FEDDE #x9F97) + (#x8FEDDF #x9F9E) + (#x8FEDE0 #x9FA1) + (#x8FEDE1 #x9FA2) + (#x8FEDE2 #x9FA3) + (#x8FEDE3 #x9FA5) + (#x8FF5A1 #xE3AC) + (#x8FF5A2 #xE3AD) + (#x8FF5A3 #xE3AE) + (#x8FF5A4 #xE3AF) + (#x8FF5A5 #xE3B0) + (#x8FF5A6 #xE3B1) + (#x8FF5A7 #xE3B2) + (#x8FF5A8 #xE3B3) + (#x8FF5A9 #xE3B4) + (#x8FF5AA #xE3B5) + (#x8FF5AB #xE3B6) + (#x8FF5AC #xE3B7) + (#x8FF5AD #xE3B8) + (#x8FF5AE #xE3B9) + (#x8FF5AF #xE3BA) + (#x8FF5B0 #xE3BB) + (#x8FF5B1 #xE3BC) + (#x8FF5B2 #xE3BD) + (#x8FF5B3 #xE3BE) + (#x8FF5B4 #xE3BF) + (#x8FF5B5 #xE3C0) + (#x8FF5B6 #xE3C1) + (#x8FF5B7 #xE3C2) + (#x8FF5B8 #xE3C3) + (#x8FF5B9 #xE3C4) + (#x8FF5BA #xE3C5) + (#x8FF5BB #xE3C6) + (#x8FF5BC #xE3C7) + (#x8FF5BD #xE3C8) + (#x8FF5BE #xE3C9) + (#x8FF5BF #xE3CA) + (#x8FF5C0 #xE3CB) + (#x8FF5C1 #xE3CC) + (#x8FF5C2 #xE3CD) + (#x8FF5C3 #xE3CE) + (#x8FF5C4 #xE3CF) + (#x8FF5C5 #xE3D0) + (#x8FF5C6 #xE3D1) + (#x8FF5C7 #xE3D2) + (#x8FF5C8 #xE3D3) + (#x8FF5C9 #xE3D4) + (#x8FF5CA #xE3D5) + (#x8FF5CB #xE3D6) + (#x8FF5CC #xE3D7) + (#x8FF5CD #xE3D8) + (#x8FF5CE #xE3D9) + (#x8FF5CF #xE3DA) + (#x8FF5D0 #xE3DB) + (#x8FF5D1 #xE3DC) + (#x8FF5D2 #xE3DD) + (#x8FF5D3 #xE3DE) + (#x8FF5D4 #xE3DF) + (#x8FF5D5 #xE3E0) + (#x8FF5D6 #xE3E1) + (#x8FF5D7 #xE3E2) + (#x8FF5D8 #xE3E3) + (#x8FF5D9 #xE3E4) + (#x8FF5DA #xE3E5) + (#x8FF5DB #xE3E6) + (#x8FF5DC #xE3E7) + (#x8FF5DD #xE3E8) + (#x8FF5DE #xE3E9) + (#x8FF5DF #xE3EA) + (#x8FF5E0 #xE3EB) + (#x8FF5E1 #xE3EC) + (#x8FF5E2 #xE3ED) + (#x8FF5E3 #xE3EE) + (#x8FF5E4 #xE3EF) + (#x8FF5E5 #xE3F0) + (#x8FF5E6 #xE3F1) + (#x8FF5E7 #xE3F2) + (#x8FF5E8 #xE3F3) + (#x8FF5E9 #xE3F4) + (#x8FF5EA #xE3F5) + (#x8FF5EB #xE3F6) + (#x8FF5EC #xE3F7) + (#x8FF5ED #xE3F8) + (#x8FF5EE #xE3F9) + (#x8FF5EF #xE3FA) + (#x8FF5F0 #xE3FB) + (#x8FF5F1 #xE3FC) + (#x8FF5F2 #xE3FD) + (#x8FF5F3 #xE3FE) + (#x8FF5F4 #xE3FF) + (#x8FF5F5 #xE400) + (#x8FF5F6 #xE401) + (#x8FF5F7 #xE402) + (#x8FF5F8 #xE403) + (#x8FF5F9 #xE404) + (#x8FF5FA #xE405) + (#x8FF5FB #xE406) + (#x8FF5FC #xE407) + (#x8FF5FD #xE408) + (#x8FF5FE #xE409) + (#x8FF6A1 #xE40A) + (#x8FF6A2 #xE40B) + (#x8FF6A3 #xE40C) + (#x8FF6A4 #xE40D) + (#x8FF6A5 #xE40E) + (#x8FF6A6 #xE40F) + (#x8FF6A7 #xE410) + (#x8FF6A8 #xE411) + (#x8FF6A9 #xE412) + (#x8FF6AA #xE413) + (#x8FF6AB #xE414) + (#x8FF6AC #xE415) + (#x8FF6AD #xE416) + (#x8FF6AE #xE417) + (#x8FF6AF #xE418) + (#x8FF6B0 #xE419) + (#x8FF6B1 #xE41A) + (#x8FF6B2 #xE41B) + (#x8FF6B3 #xE41C) + (#x8FF6B4 #xE41D) + (#x8FF6B5 #xE41E) + (#x8FF6B6 #xE41F) + (#x8FF6B7 #xE420) + (#x8FF6B8 #xE421) + (#x8FF6B9 #xE422) + (#x8FF6BA #xE423) + (#x8FF6BB #xE424) + (#x8FF6BC #xE425) + (#x8FF6BD #xE426) + (#x8FF6BE #xE427) + (#x8FF6BF #xE428) + (#x8FF6C0 #xE429) + (#x8FF6C1 #xE42A) + (#x8FF6C2 #xE42B) + (#x8FF6C3 #xE42C) + (#x8FF6C4 #xE42D) + (#x8FF6C5 #xE42E) + (#x8FF6C6 #xE42F) + (#x8FF6C7 #xE430) + (#x8FF6C8 #xE431) + (#x8FF6C9 #xE432) + (#x8FF6CA #xE433) + (#x8FF6CB #xE434) + (#x8FF6CC #xE435) + (#x8FF6CD #xE436) + (#x8FF6CE #xE437) + (#x8FF6CF #xE438) + (#x8FF6D0 #xE439) + (#x8FF6D1 #xE43A) + (#x8FF6D2 #xE43B) + (#x8FF6D3 #xE43C) + (#x8FF6D4 #xE43D) + (#x8FF6D5 #xE43E) + (#x8FF6D6 #xE43F) + (#x8FF6D7 #xE440) + (#x8FF6D8 #xE441) + (#x8FF6D9 #xE442) + (#x8FF6DA #xE443) + (#x8FF6DB #xE444) + (#x8FF6DC #xE445) + (#x8FF6DD #xE446) + (#x8FF6DE #xE447) + (#x8FF6DF #xE448) + (#x8FF6E0 #xE449) + (#x8FF6E1 #xE44A) + (#x8FF6E2 #xE44B) + (#x8FF6E3 #xE44C) + (#x8FF6E4 #xE44D) + (#x8FF6E5 #xE44E) + (#x8FF6E6 #xE44F) + (#x8FF6E7 #xE450) + (#x8FF6E8 #xE451) + (#x8FF6E9 #xE452) + (#x8FF6EA #xE453) + (#x8FF6EB #xE454) + (#x8FF6EC #xE455) + (#x8FF6ED #xE456) + (#x8FF6EE #xE457) + (#x8FF6EF #xE458) + (#x8FF6F0 #xE459) + (#x8FF6F1 #xE45A) + (#x8FF6F2 #xE45B) + (#x8FF6F3 #xE45C) + (#x8FF6F4 #xE45D) + (#x8FF6F5 #xE45E) + (#x8FF6F6 #xE45F) + (#x8FF6F7 #xE460) + (#x8FF6F8 #xE461) + (#x8FF6F9 #xE462) + (#x8FF6FA #xE463) + (#x8FF6FB #xE464) + (#x8FF6FC #xE465) + (#x8FF6FD #xE466) + (#x8FF6FE #xE467) + (#x8FF7A1 #xE468) + (#x8FF7A2 #xE469) + (#x8FF7A3 #xE46A) + (#x8FF7A4 #xE46B) + (#x8FF7A5 #xE46C) + (#x8FF7A6 #xE46D) + (#x8FF7A7 #xE46E) + (#x8FF7A8 #xE46F) + (#x8FF7A9 #xE470) + (#x8FF7AA #xE471) + (#x8FF7AB #xE472) + (#x8FF7AC #xE473) + (#x8FF7AD #xE474) + (#x8FF7AE #xE475) + (#x8FF7AF #xE476) + (#x8FF7B0 #xE477) + (#x8FF7B1 #xE478) + (#x8FF7B2 #xE479) + (#x8FF7B3 #xE47A) + (#x8FF7B4 #xE47B) + (#x8FF7B5 #xE47C) + (#x8FF7B6 #xE47D) + (#x8FF7B7 #xE47E) + (#x8FF7B8 #xE47F) + (#x8FF7B9 #xE480) + (#x8FF7BA #xE481) + (#x8FF7BB #xE482) + (#x8FF7BC #xE483) + (#x8FF7BD #xE484) + (#x8FF7BE #xE485) + (#x8FF7BF #xE486) + (#x8FF7C0 #xE487) + (#x8FF7C1 #xE488) + (#x8FF7C2 #xE489) + (#x8FF7C3 #xE48A) + (#x8FF7C4 #xE48B) + (#x8FF7C5 #xE48C) + (#x8FF7C6 #xE48D) + (#x8FF7C7 #xE48E) + (#x8FF7C8 #xE48F) + (#x8FF7C9 #xE490) + (#x8FF7CA #xE491) + (#x8FF7CB #xE492) + (#x8FF7CC #xE493) + (#x8FF7CD #xE494) + (#x8FF7CE #xE495) + (#x8FF7CF #xE496) + (#x8FF7D0 #xE497) + (#x8FF7D1 #xE498) + (#x8FF7D2 #xE499) + (#x8FF7D3 #xE49A) + (#x8FF7D4 #xE49B) + (#x8FF7D5 #xE49C) + (#x8FF7D6 #xE49D) + (#x8FF7D7 #xE49E) + (#x8FF7D8 #xE49F) + (#x8FF7D9 #xE4A0) + (#x8FF7DA #xE4A1) + (#x8FF7DB #xE4A2) + (#x8FF7DC #xE4A3) + (#x8FF7DD #xE4A4) + (#x8FF7DE #xE4A5) + (#x8FF7DF #xE4A6) + (#x8FF7E0 #xE4A7) + (#x8FF7E1 #xE4A8) + (#x8FF7E2 #xE4A9) + (#x8FF7E3 #xE4AA) + (#x8FF7E4 #xE4AB) + (#x8FF7E5 #xE4AC) + (#x8FF7E6 #xE4AD) + (#x8FF7E7 #xE4AE) + (#x8FF7E8 #xE4AF) + (#x8FF7E9 #xE4B0) + (#x8FF7EA #xE4B1) + (#x8FF7EB #xE4B2) + (#x8FF7EC #xE4B3) + (#x8FF7ED #xE4B4) + (#x8FF7EE #xE4B5) + (#x8FF7EF #xE4B6) + (#x8FF7F0 #xE4B7) + (#x8FF7F1 #xE4B8) + (#x8FF7F2 #xE4B9) + (#x8FF7F3 #xE4BA) + (#x8FF7F4 #xE4BB) + (#x8FF7F5 #xE4BC) + (#x8FF7F6 #xE4BD) + (#x8FF7F7 #xE4BE) + (#x8FF7F8 #xE4BF) + (#x8FF7F9 #xE4C0) + (#x8FF7FA #xE4C1) + (#x8FF7FB #xE4C2) + (#x8FF7FC #xE4C3) + (#x8FF7FD #xE4C4) + (#x8FF7FE #xE4C5) + (#x8FF8A1 #xE4C6) + (#x8FF8A2 #xE4C7) + (#x8FF8A3 #xE4C8) + (#x8FF8A4 #xE4C9) + (#x8FF8A5 #xE4CA) + (#x8FF8A6 #xE4CB) + (#x8FF8A7 #xE4CC) + (#x8FF8A8 #xE4CD) + (#x8FF8A9 #xE4CE) + (#x8FF8AA #xE4CF) + (#x8FF8AB #xE4D0) + (#x8FF8AC #xE4D1) + (#x8FF8AD #xE4D2) + (#x8FF8AE #xE4D3) + (#x8FF8AF #xE4D4) + (#x8FF8B0 #xE4D5) + (#x8FF8B1 #xE4D6) + (#x8FF8B2 #xE4D7) + (#x8FF8B3 #xE4D8) + (#x8FF8B4 #xE4D9) + (#x8FF8B5 #xE4DA) + (#x8FF8B6 #xE4DB) + (#x8FF8B7 #xE4DC) + (#x8FF8B8 #xE4DD) + (#x8FF8B9 #xE4DE) + (#x8FF8BA #xE4DF) + (#x8FF8BB #xE4E0) + (#x8FF8BC #xE4E1) + (#x8FF8BD #xE4E2) + (#x8FF8BE #xE4E3) + (#x8FF8BF #xE4E4) + (#x8FF8C0 #xE4E5) + (#x8FF8C1 #xE4E6) + (#x8FF8C2 #xE4E7) + (#x8FF8C3 #xE4E8) + (#x8FF8C4 #xE4E9) + (#x8FF8C5 #xE4EA) + (#x8FF8C6 #xE4EB) + (#x8FF8C7 #xE4EC) + (#x8FF8C8 #xE4ED) + (#x8FF8C9 #xE4EE) + (#x8FF8CA #xE4EF) + (#x8FF8CB #xE4F0) + (#x8FF8CC #xE4F1) + (#x8FF8CD #xE4F2) + (#x8FF8CE #xE4F3) + (#x8FF8CF #xE4F4) + (#x8FF8D0 #xE4F5) + (#x8FF8D1 #xE4F6) + (#x8FF8D2 #xE4F7) + (#x8FF8D3 #xE4F8) + (#x8FF8D4 #xE4F9) + (#x8FF8D5 #xE4FA) + (#x8FF8D6 #xE4FB) + (#x8FF8D7 #xE4FC) + (#x8FF8D8 #xE4FD) + (#x8FF8D9 #xE4FE) + (#x8FF8DA #xE4FF) + (#x8FF8DB #xE500) + (#x8FF8DC #xE501) + (#x8FF8DD #xE502) + (#x8FF8DE #xE503) + (#x8FF8DF #xE504) + (#x8FF8E0 #xE505) + (#x8FF8E1 #xE506) + (#x8FF8E2 #xE507) + (#x8FF8E3 #xE508) + (#x8FF8E4 #xE509) + (#x8FF8E5 #xE50A) + (#x8FF8E6 #xE50B) + (#x8FF8E7 #xE50C) + (#x8FF8E8 #xE50D) + (#x8FF8E9 #xE50E) + (#x8FF8EA #xE50F) + (#x8FF8EB #xE510) + (#x8FF8EC #xE511) + (#x8FF8ED #xE512) + (#x8FF8EE #xE513) + (#x8FF8EF #xE514) + (#x8FF8F0 #xE515) + (#x8FF8F1 #xE516) + (#x8FF8F2 #xE517) + (#x8FF8F3 #xE518) + (#x8FF8F4 #xE519) + (#x8FF8F5 #xE51A) + (#x8FF8F6 #xE51B) + (#x8FF8F7 #xE51C) + (#x8FF8F8 #xE51D) + (#x8FF8F9 #xE51E) + (#x8FF8FA #xE51F) + (#x8FF8FB #xE520) + (#x8FF8FC #xE521) + (#x8FF8FD #xE522) + (#x8FF8FE #xE523) + (#x8FF9A1 #xE524) + (#x8FF9A2 #xE525) + (#x8FF9A3 #xE526) + (#x8FF9A4 #xE527) + (#x8FF9A5 #xE528) + (#x8FF9A6 #xE529) + (#x8FF9A7 #xE52A) + (#x8FF9A8 #xE52B) + (#x8FF9A9 #xE52C) + (#x8FF9AA #xE52D) + (#x8FF9AB #xE52E) + (#x8FF9AC #xE52F) + (#x8FF9AD #xE530) + (#x8FF9AE #xE531) + (#x8FF9AF #xE532) + (#x8FF9B0 #xE533) + (#x8FF9B1 #xE534) + (#x8FF9B2 #xE535) + (#x8FF9B3 #xE536) + (#x8FF9B4 #xE537) + (#x8FF9B5 #xE538) + (#x8FF9B6 #xE539) + (#x8FF9B7 #xE53A) + (#x8FF9B8 #xE53B) + (#x8FF9B9 #xE53C) + (#x8FF9BA #xE53D) + (#x8FF9BB #xE53E) + (#x8FF9BC #xE53F) + (#x8FF9BD #xE540) + (#x8FF9BE #xE541) + (#x8FF9BF #xE542) + (#x8FF9C0 #xE543) + (#x8FF9C1 #xE544) + (#x8FF9C2 #xE545) + (#x8FF9C3 #xE546) + (#x8FF9C4 #xE547) + (#x8FF9C5 #xE548) + (#x8FF9C6 #xE549) + (#x8FF9C7 #xE54A) + (#x8FF9C8 #xE54B) + (#x8FF9C9 #xE54C) + (#x8FF9CA #xE54D) + (#x8FF9CB #xE54E) + (#x8FF9CC #xE54F) + (#x8FF9CD #xE550) + (#x8FF9CE #xE551) + (#x8FF9CF #xE552) + (#x8FF9D0 #xE553) + (#x8FF9D1 #xE554) + (#x8FF9D2 #xE555) + (#x8FF9D3 #xE556) + (#x8FF9D4 #xE557) + (#x8FF9D5 #xE558) + (#x8FF9D6 #xE559) + (#x8FF9D7 #xE55A) + (#x8FF9D8 #xE55B) + (#x8FF9D9 #xE55C) + (#x8FF9DA #xE55D) + (#x8FF9DB #xE55E) + (#x8FF9DC #xE55F) + (#x8FF9DD #xE560) + (#x8FF9DE #xE561) + (#x8FF9DF #xE562) + (#x8FF9E0 #xE563) + (#x8FF9E1 #xE564) + (#x8FF9E2 #xE565) + (#x8FF9E3 #xE566) + (#x8FF9E4 #xE567) + (#x8FF9E5 #xE568) + (#x8FF9E6 #xE569) + (#x8FF9E7 #xE56A) + (#x8FF9E8 #xE56B) + (#x8FF9E9 #xE56C) + (#x8FF9EA #xE56D) + (#x8FF9EB #xE56E) + (#x8FF9EC #xE56F) + (#x8FF9ED #xE570) + (#x8FF9EE #xE571) + (#x8FF9EF #xE572) + (#x8FF9F0 #xE573) + (#x8FF9F1 #xE574) + (#x8FF9F2 #xE575) + (#x8FF9F3 #xE576) + (#x8FF9F4 #xE577) + (#x8FF9F5 #xE578) + (#x8FF9F6 #xE579) + (#x8FF9F7 #xE57A) + (#x8FF9F8 #xE57B) + (#x8FF9F9 #xE57C) + (#x8FF9FA #xE57D) + (#x8FF9FB #xE57E) + (#x8FF9FC #xE57F) + (#x8FF9FD #xE580) + (#x8FF9FE #xE581) + (#x8FFAA1 #xE582) + (#x8FFAA2 #xE583) + (#x8FFAA3 #xE584) + (#x8FFAA4 #xE585) + (#x8FFAA5 #xE586) + (#x8FFAA6 #xE587) + (#x8FFAA7 #xE588) + (#x8FFAA8 #xE589) + (#x8FFAA9 #xE58A) + (#x8FFAAA #xE58B) + (#x8FFAAB #xE58C) + (#x8FFAAC #xE58D) + (#x8FFAAD #xE58E) + (#x8FFAAE #xE58F) + (#x8FFAAF #xE590) + (#x8FFAB0 #xE591) + (#x8FFAB1 #xE592) + (#x8FFAB2 #xE593) + (#x8FFAB3 #xE594) + (#x8FFAB4 #xE595) + (#x8FFAB5 #xE596) + (#x8FFAB6 #xE597) + (#x8FFAB7 #xE598) + (#x8FFAB8 #xE599) + (#x8FFAB9 #xE59A) + (#x8FFABA #xE59B) + (#x8FFABB #xE59C) + (#x8FFABC #xE59D) + (#x8FFABD #xE59E) + (#x8FFABE #xE59F) + (#x8FFABF #xE5A0) + (#x8FFAC0 #xE5A1) + (#x8FFAC1 #xE5A2) + (#x8FFAC2 #xE5A3) + (#x8FFAC3 #xE5A4) + (#x8FFAC4 #xE5A5) + (#x8FFAC5 #xE5A6) + (#x8FFAC6 #xE5A7) + (#x8FFAC7 #xE5A8) + (#x8FFAC8 #xE5A9) + (#x8FFAC9 #xE5AA) + (#x8FFACA #xE5AB) + (#x8FFACB #xE5AC) + (#x8FFACC #xE5AD) + (#x8FFACD #xE5AE) + (#x8FFACE #xE5AF) + (#x8FFACF #xE5B0) + (#x8FFAD0 #xE5B1) + (#x8FFAD1 #xE5B2) + (#x8FFAD2 #xE5B3) + (#x8FFAD3 #xE5B4) + (#x8FFAD4 #xE5B5) + (#x8FFAD5 #xE5B6) + (#x8FFAD6 #xE5B7) + (#x8FFAD7 #xE5B8) + (#x8FFAD8 #xE5B9) + (#x8FFAD9 #xE5BA) + (#x8FFADA #xE5BB) + (#x8FFADB #xE5BC) + (#x8FFADC #xE5BD) + (#x8FFADD #xE5BE) + (#x8FFADE #xE5BF) + (#x8FFADF #xE5C0) + (#x8FFAE0 #xE5C1) + (#x8FFAE1 #xE5C2) + (#x8FFAE2 #xE5C3) + (#x8FFAE3 #xE5C4) + (#x8FFAE4 #xE5C5) + (#x8FFAE5 #xE5C6) + (#x8FFAE6 #xE5C7) + (#x8FFAE7 #xE5C8) + (#x8FFAE8 #xE5C9) + (#x8FFAE9 #xE5CA) + (#x8FFAEA #xE5CB) + (#x8FFAEB #xE5CC) + (#x8FFAEC #xE5CD) + (#x8FFAED #xE5CE) + (#x8FFAEE #xE5CF) + (#x8FFAEF #xE5D0) + (#x8FFAF0 #xE5D1) + (#x8FFAF1 #xE5D2) + (#x8FFAF2 #xE5D3) + (#x8FFAF3 #xE5D4) + (#x8FFAF4 #xE5D5) + (#x8FFAF5 #xE5D6) + (#x8FFAF6 #xE5D7) + (#x8FFAF7 #xE5D8) + (#x8FFAF8 #xE5D9) + (#x8FFAF9 #xE5DA) + (#x8FFAFA #xE5DB) + (#x8FFAFB #xE5DC) + (#x8FFAFC #xE5DD) + (#x8FFAFD #xE5DE) + (#x8FFAFE #xE5DF) + (#x8FFBA1 #xE5E0) + (#x8FFBA2 #xE5E1) + (#x8FFBA3 #xE5E2) + (#x8FFBA4 #xE5E3) + (#x8FFBA5 #xE5E4) + (#x8FFBA6 #xE5E5) + (#x8FFBA7 #xE5E6) + (#x8FFBA8 #xE5E7) + (#x8FFBA9 #xE5E8) + (#x8FFBAA #xE5E9) + (#x8FFBAB #xE5EA) + (#x8FFBAC #xE5EB) + (#x8FFBAD #xE5EC) + (#x8FFBAE #xE5ED) + (#x8FFBAF #xE5EE) + (#x8FFBB0 #xE5EF) + (#x8FFBB1 #xE5F0) + (#x8FFBB2 #xE5F1) + (#x8FFBB3 #xE5F2) + (#x8FFBB4 #xE5F3) + (#x8FFBB5 #xE5F4) + (#x8FFBB6 #xE5F5) + (#x8FFBB7 #xE5F6) + (#x8FFBB8 #xE5F7) + (#x8FFBB9 #xE5F8) + (#x8FFBBA #xE5F9) + (#x8FFBBB #xE5FA) + (#x8FFBBC #xE5FB) + (#x8FFBBD #xE5FC) + (#x8FFBBE #xE5FD) + (#x8FFBBF #xE5FE) + (#x8FFBC0 #xE5FF) + (#x8FFBC1 #xE600) + (#x8FFBC2 #xE601) + (#x8FFBC3 #xE602) + (#x8FFBC4 #xE603) + (#x8FFBC5 #xE604) + (#x8FFBC6 #xE605) + (#x8FFBC7 #xE606) + (#x8FFBC8 #xE607) + (#x8FFBC9 #xE608) + (#x8FFBCA #xE609) + (#x8FFBCB #xE60A) + (#x8FFBCC #xE60B) + (#x8FFBCD #xE60C) + (#x8FFBCE #xE60D) + (#x8FFBCF #xE60E) + (#x8FFBD0 #xE60F) + (#x8FFBD1 #xE610) + (#x8FFBD2 #xE611) + (#x8FFBD3 #xE612) + (#x8FFBD4 #xE613) + (#x8FFBD5 #xE614) + (#x8FFBD6 #xE615) + (#x8FFBD7 #xE616) + (#x8FFBD8 #xE617) + (#x8FFBD9 #xE618) + (#x8FFBDA #xE619) + (#x8FFBDB #xE61A) + (#x8FFBDC #xE61B) + (#x8FFBDD #xE61C) + (#x8FFBDE #xE61D) + (#x8FFBDF #xE61E) + (#x8FFBE0 #xE61F) + (#x8FFBE1 #xE620) + (#x8FFBE2 #xE621) + (#x8FFBE3 #xE622) + (#x8FFBE4 #xE623) + (#x8FFBE5 #xE624) + (#x8FFBE6 #xE625) + (#x8FFBE7 #xE626) + (#x8FFBE8 #xE627) + (#x8FFBE9 #xE628) + (#x8FFBEA #xE629) + (#x8FFBEB #xE62A) + (#x8FFBEC #xE62B) + (#x8FFBED #xE62C) + (#x8FFBEE #xE62D) + (#x8FFBEF #xE62E) + (#x8FFBF0 #xE62F) + (#x8FFBF1 #xE630) + (#x8FFBF2 #xE631) + (#x8FFBF3 #xE632) + (#x8FFBF4 #xE633) + (#x8FFBF5 #xE634) + (#x8FFBF6 #xE635) + (#x8FFBF7 #xE636) + (#x8FFBF8 #xE637) + (#x8FFBF9 #xE638) + (#x8FFBFA #xE639) + (#x8FFBFB #xE63A) + (#x8FFBFC #xE63B) + (#x8FFBFD #xE63C) + (#x8FFBFE #xE63D) + (#x8FFCA1 #xE63E) + (#x8FFCA2 #xE63F) + (#x8FFCA3 #xE640) + (#x8FFCA4 #xE641) + (#x8FFCA5 #xE642) + (#x8FFCA6 #xE643) + (#x8FFCA7 #xE644) + (#x8FFCA8 #xE645) + (#x8FFCA9 #xE646) + (#x8FFCAA #xE647) + (#x8FFCAB #xE648) + (#x8FFCAC #xE649) + (#x8FFCAD #xE64A) + (#x8FFCAE #xE64B) + (#x8FFCAF #xE64C) + (#x8FFCB0 #xE64D) + (#x8FFCB1 #xE64E) + (#x8FFCB2 #xE64F) + (#x8FFCB3 #xE650) + (#x8FFCB4 #xE651) + (#x8FFCB5 #xE652) + (#x8FFCB6 #xE653) + (#x8FFCB7 #xE654) + (#x8FFCB8 #xE655) + (#x8FFCB9 #xE656) + (#x8FFCBA #xE657) + (#x8FFCBB #xE658) + (#x8FFCBC #xE659) + (#x8FFCBD #xE65A) + (#x8FFCBE #xE65B) + (#x8FFCBF #xE65C) + (#x8FFCC0 #xE65D) + (#x8FFCC1 #xE65E) + (#x8FFCC2 #xE65F) + (#x8FFCC3 #xE660) + (#x8FFCC4 #xE661) + (#x8FFCC5 #xE662) + (#x8FFCC6 #xE663) + (#x8FFCC7 #xE664) + (#x8FFCC8 #xE665) + (#x8FFCC9 #xE666) + (#x8FFCCA #xE667) + (#x8FFCCB #xE668) + (#x8FFCCC #xE669) + (#x8FFCCD #xE66A) + (#x8FFCCE #xE66B) + (#x8FFCCF #xE66C) + (#x8FFCD0 #xE66D) + (#x8FFCD1 #xE66E) + (#x8FFCD2 #xE66F) + (#x8FFCD3 #xE670) + (#x8FFCD4 #xE671) + (#x8FFCD5 #xE672) + (#x8FFCD6 #xE673) + (#x8FFCD7 #xE674) + (#x8FFCD8 #xE675) + (#x8FFCD9 #xE676) + (#x8FFCDA #xE677) + (#x8FFCDB #xE678) + (#x8FFCDC #xE679) + (#x8FFCDD #xE67A) + (#x8FFCDE #xE67B) + (#x8FFCDF #xE67C) + (#x8FFCE0 #xE67D) + (#x8FFCE1 #xE67E) + (#x8FFCE2 #xE67F) + (#x8FFCE3 #xE680) + (#x8FFCE4 #xE681) + (#x8FFCE5 #xE682) + (#x8FFCE6 #xE683) + (#x8FFCE7 #xE684) + (#x8FFCE8 #xE685) + (#x8FFCE9 #xE686) + (#x8FFCEA #xE687) + (#x8FFCEB #xE688) + (#x8FFCEC #xE689) + (#x8FFCED #xE68A) + (#x8FFCEE #xE68B) + (#x8FFCEF #xE68C) + (#x8FFCF0 #xE68D) + (#x8FFCF1 #xE68E) + (#x8FFCF2 #xE68F) + (#x8FFCF3 #xE690) + (#x8FFCF4 #xE691) + (#x8FFCF5 #xE692) + (#x8FFCF6 #xE693) + (#x8FFCF7 #xE694) + (#x8FFCF8 #xE695) + (#x8FFCF9 #xE696) + (#x8FFCFA #xE697) + (#x8FFCFB #xE698) + (#x8FFCFC #xE699) + (#x8FFCFD #xE69A) + (#x8FFCFE #xE69B) + (#x8FFDA1 #xE69C) + (#x8FFDA2 #xE69D) + (#x8FFDA3 #xE69E) + (#x8FFDA4 #xE69F) + (#x8FFDA5 #xE6A0) + (#x8FFDA6 #xE6A1) + (#x8FFDA7 #xE6A2) + (#x8FFDA8 #xE6A3) + (#x8FFDA9 #xE6A4) + (#x8FFDAA #xE6A5) + (#x8FFDAB #xE6A6) + (#x8FFDAC #xE6A7) + (#x8FFDAD #xE6A8) + (#x8FFDAE #xE6A9) + (#x8FFDAF #xE6AA) + (#x8FFDB0 #xE6AB) + (#x8FFDB1 #xE6AC) + (#x8FFDB2 #xE6AD) + (#x8FFDB3 #xE6AE) + (#x8FFDB4 #xE6AF) + (#x8FFDB5 #xE6B0) + (#x8FFDB6 #xE6B1) + (#x8FFDB7 #xE6B2) + (#x8FFDB8 #xE6B3) + (#x8FFDB9 #xE6B4) + (#x8FFDBA #xE6B5) + (#x8FFDBB #xE6B6) + (#x8FFDBC #xE6B7) + (#x8FFDBD #xE6B8) + (#x8FFDBE #xE6B9) + (#x8FFDBF #xE6BA) + (#x8FFDC0 #xE6BB) + (#x8FFDC1 #xE6BC) + (#x8FFDC2 #xE6BD) + (#x8FFDC3 #xE6BE) + (#x8FFDC4 #xE6BF) + (#x8FFDC5 #xE6C0) + (#x8FFDC6 #xE6C1) + (#x8FFDC7 #xE6C2) + (#x8FFDC8 #xE6C3) + (#x8FFDC9 #xE6C4) + (#x8FFDCA #xE6C5) + (#x8FFDCB #xE6C6) + (#x8FFDCC #xE6C7) + (#x8FFDCD #xE6C8) + (#x8FFDCE #xE6C9) + (#x8FFDCF #xE6CA) + (#x8FFDD0 #xE6CB) + (#x8FFDD1 #xE6CC) + (#x8FFDD2 #xE6CD) + (#x8FFDD3 #xE6CE) + (#x8FFDD4 #xE6CF) + (#x8FFDD5 #xE6D0) + (#x8FFDD6 #xE6D1) + (#x8FFDD7 #xE6D2) + (#x8FFDD8 #xE6D3) + (#x8FFDD9 #xE6D4) + (#x8FFDDA #xE6D5) + (#x8FFDDB #xE6D6) + (#x8FFDDC #xE6D7) + (#x8FFDDD #xE6D8) + (#x8FFDDE #xE6D9) + (#x8FFDDF #xE6DA) + (#x8FFDE0 #xE6DB) + (#x8FFDE1 #xE6DC) + (#x8FFDE2 #xE6DD) + (#x8FFDE3 #xE6DE) + (#x8FFDE4 #xE6DF) + (#x8FFDE5 #xE6E0) + (#x8FFDE6 #xE6E1) + (#x8FFDE7 #xE6E2) + (#x8FFDE8 #xE6E3) + (#x8FFDE9 #xE6E4) + (#x8FFDEA #xE6E5) + (#x8FFDEB #xE6E6) + (#x8FFDEC #xE6E7) + (#x8FFDED #xE6E8) + (#x8FFDEE #xE6E9) + (#x8FFDEF #xE6EA) + (#x8FFDF0 #xE6EB) + (#x8FFDF1 #xE6EC) + (#x8FFDF2 #xE6ED) + (#x8FFDF3 #xE6EE) + (#x8FFDF4 #xE6EF) + (#x8FFDF5 #xE6F0) + (#x8FFDF6 #xE6F1) + (#x8FFDF7 #xE6F2) + (#x8FFDF8 #xE6F3) + (#x8FFDF9 #xE6F4) + (#x8FFDFA #xE6F5) + (#x8FFDFB #xE6F6) + (#x8FFDFC #xE6F7) + (#x8FFDFD #xE6F8) + (#x8FFDFE #xE6F9) + (#x8FFEA1 #xE6FA) + (#x8FFEA2 #xE6FB) + (#x8FFEA3 #xE6FC) + (#x8FFEA4 #xE6FD) + (#x8FFEA5 #xE6FE) + (#x8FFEA6 #xE6FF) + (#x8FFEA7 #xE700) + (#x8FFEA8 #xE701) + (#x8FFEA9 #xE702) + (#x8FFEAA #xE703) + (#x8FFEAB #xE704) + (#x8FFEAC #xE705) + (#x8FFEAD #xE706) + (#x8FFEAE #xE707) + (#x8FFEAF #xE708) + (#x8FFEB0 #xE709) + (#x8FFEB1 #xE70A) + (#x8FFEB2 #xE70B) + (#x8FFEB3 #xE70C) + (#x8FFEB4 #xE70D) + (#x8FFEB5 #xE70E) + (#x8FFEB6 #xE70F) + (#x8FFEB7 #xE710) + (#x8FFEB8 #xE711) + (#x8FFEB9 #xE712) + (#x8FFEBA #xE713) + (#x8FFEBB #xE714) + (#x8FFEBC #xE715) + (#x8FFEBD #xE716) + (#x8FFEBE #xE717) + (#x8FFEBF #xE718) + (#x8FFEC0 #xE719) + (#x8FFEC1 #xE71A) + (#x8FFEC2 #xE71B) + (#x8FFEC3 #xE71C) + (#x8FFEC4 #xE71D) + (#x8FFEC5 #xE71E) + (#x8FFEC6 #xE71F) + (#x8FFEC7 #xE720) + (#x8FFEC8 #xE721) + (#x8FFEC9 #xE722) + (#x8FFECA #xE723) + (#x8FFECB #xE724) + (#x8FFECC #xE725) + (#x8FFECD #xE726) + (#x8FFECE #xE727) + (#x8FFECF #xE728) + (#x8FFED0 #xE729) + (#x8FFED1 #xE72A) + (#x8FFED2 #xE72B) + (#x8FFED3 #xE72C) + (#x8FFED4 #xE72D) + (#x8FFED5 #xE72E) + (#x8FFED6 #xE72F) + (#x8FFED7 #xE730) + (#x8FFED8 #xE731) + (#x8FFED9 #xE732) + (#x8FFEDA #xE733) + (#x8FFEDB #xE734) + (#x8FFEDC #xE735) + (#x8FFEDD #xE736) + (#x8FFEDE #xE737) + (#x8FFEDF #xE738) + (#x8FFEE0 #xE739) + (#x8FFEE1 #xE73A) + (#x8FFEE2 #xE73B) + (#x8FFEE3 #xE73C) + (#x8FFEE4 #xE73D) + (#x8FFEE5 #xE73E) + (#x8FFEE6 #xE73F) + (#x8FFEE7 #xE740) + (#x8FFEE8 #xE741) + (#x8FFEE9 #xE742) + (#x8FFEEA #xE743) + (#x8FFEEB #xE744) + (#x8FFEEC #xE745) + (#x8FFEED #xE746) + (#x8FFEEE #xE747) + (#x8FFEEF #xE748) + (#x8FFEF0 #xE749) + (#x8FFEF1 #xE74A) + (#x8FFEF2 #xE74B) + (#x8FFEF3 #xE74C) + (#x8FFEF4 #xE74D) + (#x8FFEF5 #xE74E) + (#x8FFEF6 #xE74F) + (#x8FFEF7 #xE750) + (#x8FFEF8 #xE751) + (#x8FFEF9 #xE752) + (#x8FFEFA #xE753) + (#x8FFEFB #xE754) + (#x8FFEFC #xE755) + (#x8FFEFD #xE756) + (#x8FFEFE #xE757) + (#xA1A1 #x3000) + (#xA1A2 #x3001) + (#xA1A3 #x3002) + (#xA1A4 #xFF0C) + (#xA1A5 #xFF0E) + (#xA1A6 #x30FB) + (#xA1A7 #xFF1A) + (#xA1A8 #xFF1B) + (#xA1A9 #xFF1F) + (#xA1AA #xFF01) + (#xA1AB #x309B) + (#xA1AC #x309C) + (#xA1AD #xB4) + (#xA1AE #xFF40) + (#xA1AF #xA8) + (#xA1B0 #xFF3E) + (#xA1B1 #xFFE3) + (#xA1B2 #xFF3F) + (#xA1B3 #x30FD) + (#xA1B4 #x30FE) + (#xA1B5 #x309D) + (#xA1B6 #x309E) + (#xA1B7 #x3003) + (#xA1B8 #x4EDD) + (#xA1B9 #x3005) + (#xA1BA #x3006) + (#xA1BB #x3007) + (#xA1BC #x30FC) + (#xA1BD #x2015) + (#xA1BE #x2010) + (#xA1BF #xFF0F) + (#xA1C0 #xFF3C) + (#xA1C1 #x301C) + (#xA1C2 #x2016) + (#xA1C3 #xFF5C) + (#xA1C4 #x2026) + (#xA1C5 #x2025) + (#xA1C6 #x2018) + (#xA1C7 #x2019) + (#xA1C8 #x201C) + (#xA1C9 #x201D) + (#xA1CA #xFF08) + (#xA1CB #xFF09) + (#xA1CC #x3014) + (#xA1CD #x3015) + (#xA1CE #xFF3B) + (#xA1CF #xFF3D) + (#xA1D0 #xFF5B) + (#xA1D1 #xFF5D) + (#xA1D2 #x3008) + (#xA1D3 #x3009) + (#xA1D4 #x300A) + (#xA1D5 #x300B) + (#xA1D6 #x300C) + (#xA1D7 #x300D) + (#xA1D8 #x300E) + (#xA1D9 #x300F) + (#xA1DA #x3010) + (#xA1DB #x3011) + (#xA1DC #xFF0B) + (#xA1DD #x2212) + (#xA1DE #xB1) + (#xA1DF #xD7) + (#xA1E0 #xF7) + (#xA1E1 #xFF1D) + (#xA1E2 #x2260) + (#xA1E3 #xFF1C) + (#xA1E4 #xFF1E) + (#xA1E5 #x2266) + (#xA1E6 #x2267) + (#xA1E7 #x221E) + (#xA1E8 #x2234) + (#xA1E9 #x2642) + (#xA1EA #x2640) + (#xA1EB #xB0) + (#xA1EC #x2032) + (#xA1ED #x2033) + (#xA1EE #x2103) + (#xA1EF #xFFE5) + (#xA1F0 #xFF04) + (#xA1F1 #xA2) + (#xA1F2 #xA3) + (#xA1F3 #xFF05) + (#xA1F4 #xFF03) + (#xA1F5 #xFF06) + (#xA1F6 #xFF0A) + (#xA1F7 #xFF20) + (#xA1F8 #xA7) + (#xA1F9 #x2606) + (#xA1FA #x2605) + (#xA1FB #x25CB) + (#xA1FC #x25CF) + (#xA1FD #x25CE) + (#xA1FE #x25C7) + (#xA2A1 #x25C6) + (#xA2A2 #x25A1) + (#xA2A3 #x25A0) + (#xA2A4 #x25B3) + (#xA2A5 #x25B2) + (#xA2A6 #x25BD) + (#xA2A7 #x25BC) + (#xA2A8 #x203B) + (#xA2A9 #x3012) + (#xA2AA #x2192) + (#xA2AB #x2190) + (#xA2AC #x2191) + (#xA2AD #x2193) + (#xA2AE #x3013) + (#xA2BA #x2208) + (#xA2BB #x220B) + (#xA2BC #x2286) + (#xA2BD #x2287) + (#xA2BE #x2282) + (#xA2BF #x2283) + (#xA2C0 #x222A) + (#xA2C1 #x2229) + (#xA2CA #x2227) + (#xA2CB #x2228) + (#xA2CC #xAC) + (#xA2CD #x21D2) + (#xA2CE #x21D4) + (#xA2CF #x2200) + (#xA2D0 #x2203) + (#xA2DC #x2220) + (#xA2DD #x22A5) + (#xA2DE #x2312) + (#xA2DF #x2202) + (#xA2E0 #x2207) + (#xA2E1 #x2261) + (#xA2E2 #x2252) + (#xA2E3 #x226A) + (#xA2E4 #x226B) + (#xA2E5 #x221A) + (#xA2E6 #x223D) + (#xA2E7 #x221D) + (#xA2E8 #x2235) + (#xA2E9 #x222B) + (#xA2EA #x222C) + (#xA2F2 #x212B) + (#xA2F3 #x2030) + (#xA2F4 #x266F) + (#xA2F5 #x266D) + (#xA2F6 #x266A) + (#xA2F7 #x2020) + (#xA2F8 #x2021) + (#xA2F9 #xB6) + (#xA2FE #x25EF) + (#xA3B0 #xFF10) + (#xA3B1 #xFF11) + (#xA3B2 #xFF12) + (#xA3B3 #xFF13) + (#xA3B4 #xFF14) + (#xA3B5 #xFF15) + (#xA3B6 #xFF16) + (#xA3B7 #xFF17) + (#xA3B8 #xFF18) + (#xA3B9 #xFF19) + (#xA3C1 #xFF21) + (#xA3C2 #xFF22) + (#xA3C3 #xFF23) + (#xA3C4 #xFF24) + (#xA3C5 #xFF25) + (#xA3C6 #xFF26) + (#xA3C7 #xFF27) + (#xA3C8 #xFF28) + (#xA3C9 #xFF29) + (#xA3CA #xFF2A) + (#xA3CB #xFF2B) + (#xA3CC #xFF2C) + (#xA3CD #xFF2D) + (#xA3CE #xFF2E) + (#xA3CF #xFF2F) + (#xA3D0 #xFF30) + (#xA3D1 #xFF31) + (#xA3D2 #xFF32) + (#xA3D3 #xFF33) + (#xA3D4 #xFF34) + (#xA3D5 #xFF35) + (#xA3D6 #xFF36) + (#xA3D7 #xFF37) + (#xA3D8 #xFF38) + (#xA3D9 #xFF39) + (#xA3DA #xFF3A) + (#xA3E1 #xFF41) + (#xA3E2 #xFF42) + (#xA3E3 #xFF43) + (#xA3E4 #xFF44) + (#xA3E5 #xFF45) + (#xA3E6 #xFF46) + (#xA3E7 #xFF47) + (#xA3E8 #xFF48) + (#xA3E9 #xFF49) + (#xA3EA #xFF4A) + (#xA3EB #xFF4B) + (#xA3EC #xFF4C) + (#xA3ED #xFF4D) + (#xA3EE #xFF4E) + (#xA3EF #xFF4F) + (#xA3F0 #xFF50) + (#xA3F1 #xFF51) + (#xA3F2 #xFF52) + (#xA3F3 #xFF53) + (#xA3F4 #xFF54) + (#xA3F5 #xFF55) + (#xA3F6 #xFF56) + (#xA3F7 #xFF57) + (#xA3F8 #xFF58) + (#xA3F9 #xFF59) + (#xA3FA #xFF5A) + (#xA4A1 #x3041) + (#xA4A2 #x3042) + (#xA4A3 #x3043) + (#xA4A4 #x3044) + (#xA4A5 #x3045) + (#xA4A6 #x3046) + (#xA4A7 #x3047) + (#xA4A8 #x3048) + (#xA4A9 #x3049) + (#xA4AA #x304A) + (#xA4AB #x304B) + (#xA4AC #x304C) + (#xA4AD #x304D) + (#xA4AE #x304E) + (#xA4AF #x304F) + (#xA4B0 #x3050) + (#xA4B1 #x3051) + (#xA4B2 #x3052) + (#xA4B3 #x3053) + (#xA4B4 #x3054) + (#xA4B5 #x3055) + (#xA4B6 #x3056) + (#xA4B7 #x3057) + (#xA4B8 #x3058) + (#xA4B9 #x3059) + (#xA4BA #x305A) + (#xA4BB #x305B) + (#xA4BC #x305C) + (#xA4BD #x305D) + (#xA4BE #x305E) + (#xA4BF #x305F) + (#xA4C0 #x3060) + (#xA4C1 #x3061) + (#xA4C2 #x3062) + (#xA4C3 #x3063) + (#xA4C4 #x3064) + (#xA4C5 #x3065) + (#xA4C6 #x3066) + (#xA4C7 #x3067) + (#xA4C8 #x3068) + (#xA4C9 #x3069) + (#xA4CA #x306A) + (#xA4CB #x306B) + (#xA4CC #x306C) + (#xA4CD #x306D) + (#xA4CE #x306E) + (#xA4CF #x306F) + (#xA4D0 #x3070) + (#xA4D1 #x3071) + (#xA4D2 #x3072) + (#xA4D3 #x3073) + (#xA4D4 #x3074) + (#xA4D5 #x3075) + (#xA4D6 #x3076) + (#xA4D7 #x3077) + (#xA4D8 #x3078) + (#xA4D9 #x3079) + (#xA4DA #x307A) + (#xA4DB #x307B) + (#xA4DC #x307C) + (#xA4DD #x307D) + (#xA4DE #x307E) + (#xA4DF #x307F) + (#xA4E0 #x3080) + (#xA4E1 #x3081) + (#xA4E2 #x3082) + (#xA4E3 #x3083) + (#xA4E4 #x3084) + (#xA4E5 #x3085) + (#xA4E6 #x3086) + (#xA4E7 #x3087) + (#xA4E8 #x3088) + (#xA4E9 #x3089) + (#xA4EA #x308A) + (#xA4EB #x308B) + (#xA4EC #x308C) + (#xA4ED #x308D) + (#xA4EE #x308E) + (#xA4EF #x308F) + (#xA4F0 #x3090) + (#xA4F1 #x3091) + (#xA4F2 #x3092) + (#xA4F3 #x3093) + (#xA5A1 #x30A1) + (#xA5A2 #x30A2) + (#xA5A3 #x30A3) + (#xA5A4 #x30A4) + (#xA5A5 #x30A5) + (#xA5A6 #x30A6) + (#xA5A7 #x30A7) + (#xA5A8 #x30A8) + (#xA5A9 #x30A9) + (#xA5AA #x30AA) + (#xA5AB #x30AB) + (#xA5AC #x30AC) + (#xA5AD #x30AD) + (#xA5AE #x30AE) + (#xA5AF #x30AF) + (#xA5B0 #x30B0) + (#xA5B1 #x30B1) + (#xA5B2 #x30B2) + (#xA5B3 #x30B3) + (#xA5B4 #x30B4) + (#xA5B5 #x30B5) + (#xA5B6 #x30B6) + (#xA5B7 #x30B7) + (#xA5B8 #x30B8) + (#xA5B9 #x30B9) + (#xA5BA #x30BA) + (#xA5BB #x30BB) + (#xA5BC #x30BC) + (#xA5BD #x30BD) + (#xA5BE #x30BE) + (#xA5BF #x30BF) + (#xA5C0 #x30C0) + (#xA5C1 #x30C1) + (#xA5C2 #x30C2) + (#xA5C3 #x30C3) + (#xA5C4 #x30C4) + (#xA5C5 #x30C5) + (#xA5C6 #x30C6) + (#xA5C7 #x30C7) + (#xA5C8 #x30C8) + (#xA5C9 #x30C9) + (#xA5CA #x30CA) + (#xA5CB #x30CB) + (#xA5CC #x30CC) + (#xA5CD #x30CD) + (#xA5CE #x30CE) + (#xA5CF #x30CF) + (#xA5D0 #x30D0) + (#xA5D1 #x30D1) + (#xA5D2 #x30D2) + (#xA5D3 #x30D3) + (#xA5D4 #x30D4) + (#xA5D5 #x30D5) + (#xA5D6 #x30D6) + (#xA5D7 #x30D7) + (#xA5D8 #x30D8) + (#xA5D9 #x30D9) + (#xA5DA #x30DA) + (#xA5DB #x30DB) + (#xA5DC #x30DC) + (#xA5DD #x30DD) + (#xA5DE #x30DE) + (#xA5DF #x30DF) + (#xA5E0 #x30E0) + (#xA5E1 #x30E1) + (#xA5E2 #x30E2) + (#xA5E3 #x30E3) + (#xA5E4 #x30E4) + (#xA5E5 #x30E5) + (#xA5E6 #x30E6) + (#xA5E7 #x30E7) + (#xA5E8 #x30E8) + (#xA5E9 #x30E9) + (#xA5EA #x30EA) + (#xA5EB #x30EB) + (#xA5EC #x30EC) + (#xA5ED #x30ED) + (#xA5EE #x30EE) + (#xA5EF #x30EF) + (#xA5F0 #x30F0) + (#xA5F1 #x30F1) + (#xA5F2 #x30F2) + (#xA5F3 #x30F3) + (#xA5F4 #x30F4) + (#xA5F5 #x30F5) + (#xA5F6 #x30F6) + (#xA6A1 #x391) + (#xA6A2 #x392) + (#xA6A3 #x393) + (#xA6A4 #x394) + (#xA6A5 #x395) + (#xA6A6 #x396) + (#xA6A7 #x397) + (#xA6A8 #x398) + (#xA6A9 #x399) + (#xA6AA #x39A) + (#xA6AB #x39B) + (#xA6AC #x39C) + (#xA6AD #x39D) + (#xA6AE #x39E) + (#xA6AF #x39F) + (#xA6B0 #x3A0) + (#xA6B1 #x3A1) + (#xA6B2 #x3A3) + (#xA6B3 #x3A4) + (#xA6B4 #x3A5) + (#xA6B5 #x3A6) + (#xA6B6 #x3A7) + (#xA6B7 #x3A8) + (#xA6B8 #x3A9) + (#xA6C1 #x3B1) + (#xA6C2 #x3B2) + (#xA6C3 #x3B3) + (#xA6C4 #x3B4) + (#xA6C5 #x3B5) + (#xA6C6 #x3B6) + (#xA6C7 #x3B7) + (#xA6C8 #x3B8) + (#xA6C9 #x3B9) + (#xA6CA #x3BA) + (#xA6CB #x3BB) + (#xA6CC #x3BC) + (#xA6CD #x3BD) + (#xA6CE #x3BE) + (#xA6CF #x3BF) + (#xA6D0 #x3C0) + (#xA6D1 #x3C1) + (#xA6D2 #x3C3) + (#xA6D3 #x3C4) + (#xA6D4 #x3C5) + (#xA6D5 #x3C6) + (#xA6D6 #x3C7) + (#xA6D7 #x3C8) + (#xA6D8 #x3C9) + (#xA7A1 #x410) + (#xA7A2 #x411) + (#xA7A3 #x412) + (#xA7A4 #x413) + (#xA7A5 #x414) + (#xA7A6 #x415) + (#xA7A7 #x401) + (#xA7A8 #x416) + (#xA7A9 #x417) + (#xA7AA #x418) + (#xA7AB #x419) + (#xA7AC #x41A) + (#xA7AD #x41B) + (#xA7AE #x41C) + (#xA7AF #x41D) + (#xA7B0 #x41E) + (#xA7B1 #x41F) + (#xA7B2 #x420) + (#xA7B3 #x421) + (#xA7B4 #x422) + (#xA7B5 #x423) + (#xA7B6 #x424) + (#xA7B7 #x425) + (#xA7B8 #x426) + (#xA7B9 #x427) + (#xA7BA #x428) + (#xA7BB #x429) + (#xA7BC #x42A) + (#xA7BD #x42B) + (#xA7BE #x42C) + (#xA7BF #x42D) + (#xA7C0 #x42E) + (#xA7C1 #x42F) + (#xA7D1 #x430) + (#xA7D2 #x431) + (#xA7D3 #x432) + (#xA7D4 #x433) + (#xA7D5 #x434) + (#xA7D6 #x435) + (#xA7D7 #x451) + (#xA7D8 #x436) + (#xA7D9 #x437) + (#xA7DA #x438) + (#xA7DB #x439) + (#xA7DC #x43A) + (#xA7DD #x43B) + (#xA7DE #x43C) + (#xA7DF #x43D) + (#xA7E0 #x43E) + (#xA7E1 #x43F) + (#xA7E2 #x440) + (#xA7E3 #x441) + (#xA7E4 #x442) + (#xA7E5 #x443) + (#xA7E6 #x444) + (#xA7E7 #x445) + (#xA7E8 #x446) + (#xA7E9 #x447) + (#xA7EA #x448) + (#xA7EB #x449) + (#xA7EC #x44A) + (#xA7ED #x44B) + (#xA7EE #x44C) + (#xA7EF #x44D) + (#xA7F0 #x44E) + (#xA7F1 #x44F) + (#xA8A1 #x2500) + (#xA8A2 #x2502) + (#xA8A3 #x250C) + (#xA8A4 #x2510) + (#xA8A5 #x2518) + (#xA8A6 #x2514) + (#xA8A7 #x251C) + (#xA8A8 #x252C) + (#xA8A9 #x2524) + (#xA8AA #x2534) + (#xA8AB #x253C) + (#xA8AC #x2501) + (#xA8AD #x2503) + (#xA8AE #x250F) + (#xA8AF #x2513) + (#xA8B0 #x251B) + (#xA8B1 #x2517) + (#xA8B2 #x2523) + (#xA8B3 #x2533) + (#xA8B4 #x252B) + (#xA8B5 #x253B) + (#xA8B6 #x254B) + (#xA8B7 #x2520) + (#xA8B8 #x252F) + (#xA8B9 #x2528) + (#xA8BA #x2537) + (#xA8BB #x253F) + (#xA8BC #x251D) + (#xA8BD #x2530) + (#xA8BE #x2525) + (#xA8BF #x2538) + (#xA8C0 #x2542) + (#xB0A1 #x4E9C) + (#xB0A2 #x5516) + (#xB0A3 #x5A03) + (#xB0A4 #x963F) + (#xB0A5 #x54C0) + (#xB0A6 #x611B) + (#xB0A7 #x6328) + (#xB0A8 #x59F6) + (#xB0A9 #x9022) + (#xB0AA #x8475) + (#xB0AB #x831C) + (#xB0AC #x7A50) + (#xB0AD #x60AA) + (#xB0AE #x63E1) + (#xB0AF #x6E25) + (#xB0B0 #x65ED) + (#xB0B1 #x8466) + (#xB0B2 #x82A6) + (#xB0B3 #x9BF5) + (#xB0B4 #x6893) + (#xB0B5 #x5727) + (#xB0B6 #x65A1) + (#xB0B7 #x6271) + (#xB0B8 #x5B9B) + (#xB0B9 #x59D0) + (#xB0BA #x867B) + (#xB0BB #x98F4) + (#xB0BC #x7D62) + (#xB0BD #x7DBE) + (#xB0BE #x9B8E) + (#xB0BF #x6216) + (#xB0C0 #x7C9F) + (#xB0C1 #x88B7) + (#xB0C2 #x5B89) + (#xB0C3 #x5EB5) + (#xB0C4 #x6309) + (#xB0C5 #x6697) + (#xB0C6 #x6848) + (#xB0C7 #x95C7) + (#xB0C8 #x978D) + (#xB0C9 #x674F) + (#xB0CA #x4EE5) + (#xB0CB #x4F0A) + (#xB0CC #x4F4D) + (#xB0CD #x4F9D) + (#xB0CE #x5049) + (#xB0CF #x56F2) + (#xB0D0 #x5937) + (#xB0D1 #x59D4) + (#xB0D2 #x5A01) + (#xB0D3 #x5C09) + (#xB0D4 #x60DF) + (#xB0D5 #x610F) + (#xB0D6 #x6170) + (#xB0D7 #x6613) + (#xB0D8 #x6905) + (#xB0D9 #x70BA) + (#xB0DA #x754F) + (#xB0DB #x7570) + (#xB0DC #x79FB) + (#xB0DD #x7DAD) + (#xB0DE #x7DEF) + (#xB0DF #x80C3) + (#xB0E0 #x840E) + (#xB0E1 #x8863) + (#xB0E2 #x8B02) + (#xB0E3 #x9055) + (#xB0E4 #x907A) + (#xB0E5 #x533B) + (#xB0E6 #x4E95) + (#xB0E7 #x4EA5) + (#xB0E8 #x57DF) + (#xB0E9 #x80B2) + (#xB0EA #x90C1) + (#xB0EB #x78EF) + (#xB0EC #x4E00) + (#xB0ED #x58F1) + (#xB0EE #x6EA2) + (#xB0EF #x9038) + (#xB0F0 #x7A32) + (#xB0F1 #x8328) + (#xB0F2 #x828B) + (#xB0F3 #x9C2F) + (#xB0F4 #x5141) + (#xB0F5 #x5370) + (#xB0F6 #x54BD) + (#xB0F7 #x54E1) + (#xB0F8 #x56E0) + (#xB0F9 #x59FB) + (#xB0FA #x5F15) + (#xB0FB #x98F2) + (#xB0FC #x6DEB) + (#xB0FD #x80E4) + (#xB0FE #x852D) + (#xB1A1 #x9662) + (#xB1A2 #x9670) + (#xB1A3 #x96A0) + (#xB1A4 #x97FB) + (#xB1A5 #x540B) + (#xB1A6 #x53F3) + (#xB1A7 #x5B87) + (#xB1A8 #x70CF) + (#xB1A9 #x7FBD) + (#xB1AA #x8FC2) + (#xB1AB #x96E8) + (#xB1AC #x536F) + (#xB1AD #x9D5C) + (#xB1AE #x7ABA) + (#xB1AF #x4E11) + (#xB1B0 #x7893) + (#xB1B1 #x81FC) + (#xB1B2 #x6E26) + (#xB1B3 #x5618) + (#xB1B4 #x5504) + (#xB1B5 #x6B1D) + (#xB1B6 #x851A) + (#xB1B7 #x9C3B) + (#xB1B8 #x59E5) + (#xB1B9 #x53A9) + (#xB1BA #x6D66) + (#xB1BB #x74DC) + (#xB1BC #x958F) + (#xB1BD #x5642) + (#xB1BE #x4E91) + (#xB1BF #x904B) + (#xB1C0 #x96F2) + (#xB1C1 #x834F) + (#xB1C2 #x990C) + (#xB1C3 #x53E1) + (#xB1C4 #x55B6) + (#xB1C5 #x5B30) + (#xB1C6 #x5F71) + (#xB1C7 #x6620) + (#xB1C8 #x66F3) + (#xB1C9 #x6804) + (#xB1CA #x6C38) + (#xB1CB #x6CF3) + (#xB1CC #x6D29) + (#xB1CD #x745B) + (#xB1CE #x76C8) + (#xB1CF #x7A4E) + (#xB1D0 #x9834) + (#xB1D1 #x82F1) + (#xB1D2 #x885B) + (#xB1D3 #x8A60) + (#xB1D4 #x92ED) + (#xB1D5 #x6DB2) + (#xB1D6 #x75AB) + (#xB1D7 #x76CA) + (#xB1D8 #x99C5) + (#xB1D9 #x60A6) + (#xB1DA #x8B01) + (#xB1DB #x8D8A) + (#xB1DC #x95B2) + (#xB1DD #x698E) + (#xB1DE #x53AD) + (#xB1DF #x5186) + (#xB1E0 #x5712) + (#xB1E1 #x5830) + (#xB1E2 #x5944) + (#xB1E3 #x5BB4) + (#xB1E4 #x5EF6) + (#xB1E5 #x6028) + (#xB1E6 #x63A9) + (#xB1E7 #x63F4) + (#xB1E8 #x6CBF) + (#xB1E9 #x6F14) + (#xB1EA #x708E) + (#xB1EB #x7114) + (#xB1EC #x7159) + (#xB1ED #x71D5) + (#xB1EE #x733F) + (#xB1EF #x7E01) + (#xB1F0 #x8276) + (#xB1F1 #x82D1) + (#xB1F2 #x8597) + (#xB1F3 #x9060) + (#xB1F4 #x925B) + (#xB1F5 #x9D1B) + (#xB1F6 #x5869) + (#xB1F7 #x65BC) + (#xB1F8 #x6C5A) + (#xB1F9 #x7525) + (#xB1FA #x51F9) + (#xB1FB #x592E) + (#xB1FC #x5965) + (#xB1FD #x5F80) + (#xB1FE #x5FDC) + (#xB2A1 #x62BC) + (#xB2A2 #x65FA) + (#xB2A3 #x6A2A) + (#xB2A4 #x6B27) + (#xB2A5 #x6BB4) + (#xB2A6 #x738B) + (#xB2A7 #x7FC1) + (#xB2A8 #x8956) + (#xB2A9 #x9D2C) + (#xB2AA #x9D0E) + (#xB2AB #x9EC4) + (#xB2AC #x5CA1) + (#xB2AD #x6C96) + (#xB2AE #x837B) + (#xB2AF #x5104) + (#xB2B0 #x5C4B) + (#xB2B1 #x61B6) + (#xB2B2 #x81C6) + (#xB2B3 #x6876) + (#xB2B4 #x7261) + (#xB2B5 #x4E59) + (#xB2B6 #x4FFA) + (#xB2B7 #x5378) + (#xB2B8 #x6069) + (#xB2B9 #x6E29) + (#xB2BA #x7A4F) + (#xB2BB #x97F3) + (#xB2BC #x4E0B) + (#xB2BD #x5316) + (#xB2BE #x4EEE) + (#xB2BF #x4F55) + (#xB2C0 #x4F3D) + (#xB2C1 #x4FA1) + (#xB2C2 #x4F73) + (#xB2C3 #x52A0) + (#xB2C4 #x53EF) + (#xB2C5 #x5609) + (#xB2C6 #x590F) + (#xB2C7 #x5AC1) + (#xB2C8 #x5BB6) + (#xB2C9 #x5BE1) + (#xB2CA #x79D1) + (#xB2CB #x6687) + (#xB2CC #x679C) + (#xB2CD #x67B6) + (#xB2CE #x6B4C) + (#xB2CF #x6CB3) + (#xB2D0 #x706B) + (#xB2D1 #x73C2) + (#xB2D2 #x798D) + (#xB2D3 #x79BE) + (#xB2D4 #x7A3C) + (#xB2D5 #x7B87) + (#xB2D6 #x82B1) + (#xB2D7 #x82DB) + (#xB2D8 #x8304) + (#xB2D9 #x8377) + (#xB2DA #x83EF) + (#xB2DB #x83D3) + (#xB2DC #x8766) + (#xB2DD #x8AB2) + (#xB2DE #x5629) + (#xB2DF #x8CA8) + (#xB2E0 #x8FE6) + (#xB2E1 #x904E) + (#xB2E2 #x971E) + (#xB2E3 #x868A) + (#xB2E4 #x4FC4) + (#xB2E5 #x5CE8) + (#xB2E6 #x6211) + (#xB2E7 #x7259) + (#xB2E8 #x753B) + (#xB2E9 #x81E5) + (#xB2EA #x82BD) + (#xB2EB #x86FE) + (#xB2EC #x8CC0) + (#xB2ED #x96C5) + (#xB2EE #x9913) + (#xB2EF #x99D5) + (#xB2F0 #x4ECB) + (#xB2F1 #x4F1A) + (#xB2F2 #x89E3) + (#xB2F3 #x56DE) + (#xB2F4 #x584A) + (#xB2F5 #x58CA) + (#xB2F6 #x5EFB) + (#xB2F7 #x5FEB) + (#xB2F8 #x602A) + (#xB2F9 #x6094) + (#xB2FA #x6062) + (#xB2FB #x61D0) + (#xB2FC #x6212) + (#xB2FD #x62D0) + (#xB2FE #x6539) + (#xB3A1 #x9B41) + (#xB3A2 #x6666) + (#xB3A3 #x68B0) + (#xB3A4 #x6D77) + (#xB3A5 #x7070) + (#xB3A6 #x754C) + (#xB3A7 #x7686) + (#xB3A8 #x7D75) + (#xB3A9 #x82A5) + (#xB3AA #x87F9) + (#xB3AB #x958B) + (#xB3AC #x968E) + (#xB3AD #x8C9D) + (#xB3AE #x51F1) + (#xB3AF #x52BE) + (#xB3B0 #x5916) + (#xB3B1 #x54B3) + (#xB3B2 #x5BB3) + (#xB3B3 #x5D16) + (#xB3B4 #x6168) + (#xB3B5 #x6982) + (#xB3B6 #x6DAF) + (#xB3B7 #x788D) + (#xB3B8 #x84CB) + (#xB3B9 #x8857) + (#xB3BA #x8A72) + (#xB3BB #x93A7) + (#xB3BC #x9AB8) + (#xB3BD #x6D6C) + (#xB3BE #x99A8) + (#xB3BF #x86D9) + (#xB3C0 #x57A3) + (#xB3C1 #x67FF) + (#xB3C2 #x86CE) + (#xB3C3 #x920E) + (#xB3C4 #x5283) + (#xB3C5 #x5687) + (#xB3C6 #x5404) + (#xB3C7 #x5ED3) + (#xB3C8 #x62E1) + (#xB3C9 #x64B9) + (#xB3CA #x683C) + (#xB3CB #x6838) + (#xB3CC #x6BBB) + (#xB3CD #x7372) + (#xB3CE #x78BA) + (#xB3CF #x7A6B) + (#xB3D0 #x899A) + (#xB3D1 #x89D2) + (#xB3D2 #x8D6B) + (#xB3D3 #x8F03) + (#xB3D4 #x90ED) + (#xB3D5 #x95A3) + (#xB3D6 #x9694) + (#xB3D7 #x9769) + (#xB3D8 #x5B66) + (#xB3D9 #x5CB3) + (#xB3DA #x697D) + (#xB3DB #x984D) + (#xB3DC #x984E) + (#xB3DD #x639B) + (#xB3DE #x7B20) + (#xB3DF #x6A2B) + (#xB3E0 #x6A7F) + (#xB3E1 #x68B6) + (#xB3E2 #x9C0D) + (#xB3E3 #x6F5F) + (#xB3E4 #x5272) + (#xB3E5 #x559D) + (#xB3E6 #x6070) + (#xB3E7 #x62EC) + (#xB3E8 #x6D3B) + (#xB3E9 #x6E07) + (#xB3EA #x6ED1) + (#xB3EB #x845B) + (#xB3EC #x8910) + (#xB3ED #x8F44) + (#xB3EE #x4E14) + (#xB3EF #x9C39) + (#xB3F0 #x53F6) + (#xB3F1 #x691B) + (#xB3F2 #x6A3A) + (#xB3F3 #x9784) + (#xB3F4 #x682A) + (#xB3F5 #x515C) + (#xB3F6 #x7AC3) + (#xB3F7 #x84B2) + (#xB3F8 #x91DC) + (#xB3F9 #x938C) + (#xB3FA #x565B) + (#xB3FB #x9D28) + (#xB3FC #x6822) + (#xB3FD #x8305) + (#xB3FE #x8431) + (#xB4A1 #x7CA5) + (#xB4A2 #x5208) + (#xB4A3 #x82C5) + (#xB4A4 #x74E6) + (#xB4A5 #x4E7E) + (#xB4A6 #x4F83) + (#xB4A7 #x51A0) + (#xB4A8 #x5BD2) + (#xB4A9 #x520A) + (#xB4AA #x52D8) + (#xB4AB #x52E7) + (#xB4AC #x5DFB) + (#xB4AD #x559A) + (#xB4AE #x582A) + (#xB4AF #x59E6) + (#xB4B0 #x5B8C) + (#xB4B1 #x5B98) + (#xB4B2 #x5BDB) + (#xB4B3 #x5E72) + (#xB4B4 #x5E79) + (#xB4B5 #x60A3) + (#xB4B6 #x611F) + (#xB4B7 #x6163) + (#xB4B8 #x61BE) + (#xB4B9 #x63DB) + (#xB4BA #x6562) + (#xB4BB #x67D1) + (#xB4BC #x6853) + (#xB4BD #x68FA) + (#xB4BE #x6B3E) + (#xB4BF #x6B53) + (#xB4C0 #x6C57) + (#xB4C1 #x6F22) + (#xB4C2 #x6F97) + (#xB4C3 #x6F45) + (#xB4C4 #x74B0) + (#xB4C5 #x7518) + (#xB4C6 #x76E3) + (#xB4C7 #x770B) + (#xB4C8 #x7AFF) + (#xB4C9 #x7BA1) + (#xB4CA #x7C21) + (#xB4CB #x7DE9) + (#xB4CC #x7F36) + (#xB4CD #x7FF0) + (#xB4CE #x809D) + (#xB4CF #x8266) + (#xB4D0 #x839E) + (#xB4D1 #x89B3) + (#xB4D2 #x8ACC) + (#xB4D3 #x8CAB) + (#xB4D4 #x9084) + (#xB4D5 #x9451) + (#xB4D6 #x9593) + (#xB4D7 #x9591) + (#xB4D8 #x95A2) + (#xB4D9 #x9665) + (#xB4DA #x97D3) + (#xB4DB #x9928) + (#xB4DC #x8218) + (#xB4DD #x4E38) + (#xB4DE #x542B) + (#xB4DF #x5CB8) + (#xB4E0 #x5DCC) + (#xB4E1 #x73A9) + (#xB4E2 #x764C) + (#xB4E3 #x773C) + (#xB4E4 #x5CA9) + (#xB4E5 #x7FEB) + (#xB4E6 #x8D0B) + (#xB4E7 #x96C1) + (#xB4E8 #x9811) + (#xB4E9 #x9854) + (#xB4EA #x9858) + (#xB4EB #x4F01) + (#xB4EC #x4F0E) + (#xB4ED #x5371) + (#xB4EE #x559C) + (#xB4EF #x5668) + (#xB4F0 #x57FA) + (#xB4F1 #x5947) + (#xB4F2 #x5B09) + (#xB4F3 #x5BC4) + (#xB4F4 #x5C90) + (#xB4F5 #x5E0C) + (#xB4F6 #x5E7E) + (#xB4F7 #x5FCC) + (#xB4F8 #x63EE) + (#xB4F9 #x673A) + (#xB4FA #x65D7) + (#xB4FB #x65E2) + (#xB4FC #x671F) + (#xB4FD #x68CB) + (#xB4FE #x68C4) + (#xB5A1 #x6A5F) + (#xB5A2 #x5E30) + (#xB5A3 #x6BC5) + (#xB5A4 #x6C17) + (#xB5A5 #x6C7D) + (#xB5A6 #x757F) + (#xB5A7 #x7948) + (#xB5A8 #x5B63) + (#xB5A9 #x7A00) + (#xB5AA #x7D00) + (#xB5AB #x5FBD) + (#xB5AC #x898F) + (#xB5AD #x8A18) + (#xB5AE #x8CB4) + (#xB5AF #x8D77) + (#xB5B0 #x8ECC) + (#xB5B1 #x8F1D) + (#xB5B2 #x98E2) + (#xB5B3 #x9A0E) + (#xB5B4 #x9B3C) + (#xB5B5 #x4E80) + (#xB5B6 #x507D) + (#xB5B7 #x5100) + (#xB5B8 #x5993) + (#xB5B9 #x5B9C) + (#xB5BA #x622F) + (#xB5BB #x6280) + (#xB5BC #x64EC) + (#xB5BD #x6B3A) + (#xB5BE #x72A0) + (#xB5BF #x7591) + (#xB5C0 #x7947) + (#xB5C1 #x7FA9) + (#xB5C2 #x87FB) + (#xB5C3 #x8ABC) + (#xB5C4 #x8B70) + (#xB5C5 #x63AC) + (#xB5C6 #x83CA) + (#xB5C7 #x97A0) + (#xB5C8 #x5409) + (#xB5C9 #x5403) + (#xB5CA #x55AB) + (#xB5CB #x6854) + (#xB5CC #x6A58) + (#xB5CD #x8A70) + (#xB5CE #x7827) + (#xB5CF #x6775) + (#xB5D0 #x9ECD) + (#xB5D1 #x5374) + (#xB5D2 #x5BA2) + (#xB5D3 #x811A) + (#xB5D4 #x8650) + (#xB5D5 #x9006) + (#xB5D6 #x4E18) + (#xB5D7 #x4E45) + (#xB5D8 #x4EC7) + (#xB5D9 #x4F11) + (#xB5DA #x53CA) + (#xB5DB #x5438) + (#xB5DC #x5BAE) + (#xB5DD #x5F13) + (#xB5DE #x6025) + (#xB5DF #x6551) + (#xB5E0 #x673D) + (#xB5E1 #x6C42) + (#xB5E2 #x6C72) + (#xB5E3 #x6CE3) + (#xB5E4 #x7078) + (#xB5E5 #x7403) + (#xB5E6 #x7A76) + (#xB5E7 #x7AAE) + (#xB5E8 #x7B08) + (#xB5E9 #x7D1A) + (#xB5EA #x7CFE) + (#xB5EB #x7D66) + (#xB5EC #x65E7) + (#xB5ED #x725B) + (#xB5EE #x53BB) + (#xB5EF #x5C45) + (#xB5F0 #x5DE8) + (#xB5F1 #x62D2) + (#xB5F2 #x62E0) + (#xB5F3 #x6319) + (#xB5F4 #x6E20) + (#xB5F5 #x865A) + (#xB5F6 #x8A31) + (#xB5F7 #x8DDD) + (#xB5F8 #x92F8) + (#xB5F9 #x6F01) + (#xB5FA #x79A6) + (#xB5FB #x9B5A) + (#xB5FC #x4EA8) + (#xB5FD #x4EAB) + (#xB5FE #x4EAC) + (#xB6A1 #x4F9B) + (#xB6A2 #x4FA0) + (#xB6A3 #x50D1) + (#xB6A4 #x5147) + (#xB6A5 #x7AF6) + (#xB6A6 #x5171) + (#xB6A7 #x51F6) + (#xB6A8 #x5354) + (#xB6A9 #x5321) + (#xB6AA #x537F) + (#xB6AB #x53EB) + (#xB6AC #x55AC) + (#xB6AD #x5883) + (#xB6AE #x5CE1) + (#xB6AF #x5F37) + (#xB6B0 #x5F4A) + (#xB6B1 #x602F) + (#xB6B2 #x6050) + (#xB6B3 #x606D) + (#xB6B4 #x631F) + (#xB6B5 #x6559) + (#xB6B6 #x6A4B) + (#xB6B7 #x6CC1) + (#xB6B8 #x72C2) + (#xB6B9 #x72ED) + (#xB6BA #x77EF) + (#xB6BB #x80F8) + (#xB6BC #x8105) + (#xB6BD #x8208) + (#xB6BE #x854E) + (#xB6BF #x90F7) + (#xB6C0 #x93E1) + (#xB6C1 #x97FF) + (#xB6C2 #x9957) + (#xB6C3 #x9A5A) + (#xB6C4 #x4EF0) + (#xB6C5 #x51DD) + (#xB6C6 #x5C2D) + (#xB6C7 #x6681) + (#xB6C8 #x696D) + (#xB6C9 #x5C40) + (#xB6CA #x66F2) + (#xB6CB #x6975) + (#xB6CC #x7389) + (#xB6CD #x6850) + (#xB6CE #x7C81) + (#xB6CF #x50C5) + (#xB6D0 #x52E4) + (#xB6D1 #x5747) + (#xB6D2 #x5DFE) + (#xB6D3 #x9326) + (#xB6D4 #x65A4) + (#xB6D5 #x6B23) + (#xB6D6 #x6B3D) + (#xB6D7 #x7434) + (#xB6D8 #x7981) + (#xB6D9 #x79BD) + (#xB6DA #x7B4B) + (#xB6DB #x7DCA) + (#xB6DC #x82B9) + (#xB6DD #x83CC) + (#xB6DE #x887F) + (#xB6DF #x895F) + (#xB6E0 #x8B39) + (#xB6E1 #x8FD1) + (#xB6E2 #x91D1) + (#xB6E3 #x541F) + (#xB6E4 #x9280) + (#xB6E5 #x4E5D) + (#xB6E6 #x5036) + (#xB6E7 #x53E5) + (#xB6E8 #x533A) + (#xB6E9 #x72D7) + (#xB6EA #x7396) + (#xB6EB #x77E9) + (#xB6EC #x82E6) + (#xB6ED #x8EAF) + (#xB6EE #x99C6) + (#xB6EF #x99C8) + (#xB6F0 #x99D2) + (#xB6F1 #x5177) + (#xB6F2 #x611A) + (#xB6F3 #x865E) + (#xB6F4 #x55B0) + (#xB6F5 #x7A7A) + (#xB6F6 #x5076) + (#xB6F7 #x5BD3) + (#xB6F8 #x9047) + (#xB6F9 #x9685) + (#xB6FA #x4E32) + (#xB6FB #x6ADB) + (#xB6FC #x91E7) + (#xB6FD #x5C51) + (#xB6FE #x5C48) + (#xB7A1 #x6398) + (#xB7A2 #x7A9F) + (#xB7A3 #x6C93) + (#xB7A4 #x9774) + (#xB7A5 #x8F61) + (#xB7A6 #x7AAA) + (#xB7A7 #x718A) + (#xB7A8 #x9688) + (#xB7A9 #x7C82) + (#xB7AA #x6817) + (#xB7AB #x7E70) + (#xB7AC #x6851) + (#xB7AD #x936C) + (#xB7AE #x52F2) + (#xB7AF #x541B) + (#xB7B0 #x85AB) + (#xB7B1 #x8A13) + (#xB7B2 #x7FA4) + (#xB7B3 #x8ECD) + (#xB7B4 #x90E1) + (#xB7B5 #x5366) + (#xB7B6 #x8888) + (#xB7B7 #x7941) + (#xB7B8 #x4FC2) + (#xB7B9 #x50BE) + (#xB7BA #x5211) + (#xB7BB #x5144) + (#xB7BC #x5553) + (#xB7BD #x572D) + (#xB7BE #x73EA) + (#xB7BF #x578B) + (#xB7C0 #x5951) + (#xB7C1 #x5F62) + (#xB7C2 #x5F84) + (#xB7C3 #x6075) + (#xB7C4 #x6176) + (#xB7C5 #x6167) + (#xB7C6 #x61A9) + (#xB7C7 #x63B2) + (#xB7C8 #x643A) + (#xB7C9 #x656C) + (#xB7CA #x666F) + (#xB7CB #x6842) + (#xB7CC #x6E13) + (#xB7CD #x7566) + (#xB7CE #x7A3D) + (#xB7CF #x7CFB) + (#xB7D0 #x7D4C) + (#xB7D1 #x7D99) + (#xB7D2 #x7E4B) + (#xB7D3 #x7F6B) + (#xB7D4 #x830E) + (#xB7D5 #x834A) + (#xB7D6 #x86CD) + (#xB7D7 #x8A08) + (#xB7D8 #x8A63) + (#xB7D9 #x8B66) + (#xB7DA #x8EFD) + (#xB7DB #x981A) + (#xB7DC #x9D8F) + (#xB7DD #x82B8) + (#xB7DE #x8FCE) + (#xB7DF #x9BE8) + (#xB7E0 #x5287) + (#xB7E1 #x621F) + (#xB7E2 #x6483) + (#xB7E3 #x6FC0) + (#xB7E4 #x9699) + (#xB7E5 #x6841) + (#xB7E6 #x5091) + (#xB7E7 #x6B20) + (#xB7E8 #x6C7A) + (#xB7E9 #x6F54) + (#xB7EA #x7A74) + (#xB7EB #x7D50) + (#xB7EC #x8840) + (#xB7ED #x8A23) + (#xB7EE #x6708) + (#xB7EF #x4EF6) + (#xB7F0 #x5039) + (#xB7F1 #x5026) + (#xB7F2 #x5065) + (#xB7F3 #x517C) + (#xB7F4 #x5238) + (#xB7F5 #x5263) + (#xB7F6 #x55A7) + (#xB7F7 #x570F) + (#xB7F8 #x5805) + (#xB7F9 #x5ACC) + (#xB7FA #x5EFA) + (#xB7FB #x61B2) + (#xB7FC #x61F8) + (#xB7FD #x62F3) + (#xB7FE #x6372) + (#xB8A1 #x691C) + (#xB8A2 #x6A29) + (#xB8A3 #x727D) + (#xB8A4 #x72AC) + (#xB8A5 #x732E) + (#xB8A6 #x7814) + (#xB8A7 #x786F) + (#xB8A8 #x7D79) + (#xB8A9 #x770C) + (#xB8AA #x80A9) + (#xB8AB #x898B) + (#xB8AC #x8B19) + (#xB8AD #x8CE2) + (#xB8AE #x8ED2) + (#xB8AF #x9063) + (#xB8B0 #x9375) + (#xB8B1 #x967A) + (#xB8B2 #x9855) + (#xB8B3 #x9A13) + (#xB8B4 #x9E78) + (#xB8B5 #x5143) + (#xB8B6 #x539F) + (#xB8B7 #x53B3) + (#xB8B8 #x5E7B) + (#xB8B9 #x5F26) + (#xB8BA #x6E1B) + (#xB8BB #x6E90) + (#xB8BC #x7384) + (#xB8BD #x73FE) + (#xB8BE #x7D43) + (#xB8BF #x8237) + (#xB8C0 #x8A00) + (#xB8C1 #x8AFA) + (#xB8C2 #x9650) + (#xB8C3 #x4E4E) + (#xB8C4 #x500B) + (#xB8C5 #x53E4) + (#xB8C6 #x547C) + (#xB8C7 #x56FA) + (#xB8C8 #x59D1) + (#xB8C9 #x5B64) + (#xB8CA #x5DF1) + (#xB8CB #x5EAB) + (#xB8CC #x5F27) + (#xB8CD #x6238) + (#xB8CE #x6545) + (#xB8CF #x67AF) + (#xB8D0 #x6E56) + (#xB8D1 #x72D0) + (#xB8D2 #x7CCA) + (#xB8D3 #x88B4) + (#xB8D4 #x80A1) + (#xB8D5 #x80E1) + (#xB8D6 #x83F0) + (#xB8D7 #x864E) + (#xB8D8 #x8A87) + (#xB8D9 #x8DE8) + (#xB8DA #x9237) + (#xB8DB #x96C7) + (#xB8DC #x9867) + (#xB8DD #x9F13) + (#xB8DE #x4E94) + (#xB8DF #x4E92) + (#xB8E0 #x4F0D) + (#xB8E1 #x5348) + (#xB8E2 #x5449) + (#xB8E3 #x543E) + (#xB8E4 #x5A2F) + (#xB8E5 #x5F8C) + (#xB8E6 #x5FA1) + (#xB8E7 #x609F) + (#xB8E8 #x68A7) + (#xB8E9 #x6A8E) + (#xB8EA #x745A) + (#xB8EB #x7881) + (#xB8EC #x8A9E) + (#xB8ED #x8AA4) + (#xB8EE #x8B77) + (#xB8EF #x9190) + (#xB8F0 #x4E5E) + (#xB8F1 #x9BC9) + (#xB8F2 #x4EA4) + (#xB8F3 #x4F7C) + (#xB8F4 #x4FAF) + (#xB8F5 #x5019) + (#xB8F6 #x5016) + (#xB8F7 #x5149) + (#xB8F8 #x516C) + (#xB8F9 #x529F) + (#xB8FA #x52B9) + (#xB8FB #x52FE) + (#xB8FC #x539A) + (#xB8FD #x53E3) + (#xB8FE #x5411) + (#xB9A1 #x540E) + (#xB9A2 #x5589) + (#xB9A3 #x5751) + (#xB9A4 #x57A2) + (#xB9A5 #x597D) + (#xB9A6 #x5B54) + (#xB9A7 #x5B5D) + (#xB9A8 #x5B8F) + (#xB9A9 #x5DE5) + (#xB9AA #x5DE7) + (#xB9AB #x5DF7) + (#xB9AC #x5E78) + (#xB9AD #x5E83) + (#xB9AE #x5E9A) + (#xB9AF #x5EB7) + (#xB9B0 #x5F18) + (#xB9B1 #x6052) + (#xB9B2 #x614C) + (#xB9B3 #x6297) + (#xB9B4 #x62D8) + (#xB9B5 #x63A7) + (#xB9B6 #x653B) + (#xB9B7 #x6602) + (#xB9B8 #x6643) + (#xB9B9 #x66F4) + (#xB9BA #x676D) + (#xB9BB #x6821) + (#xB9BC #x6897) + (#xB9BD #x69CB) + (#xB9BE #x6C5F) + (#xB9BF #x6D2A) + (#xB9C0 #x6D69) + (#xB9C1 #x6E2F) + (#xB9C2 #x6E9D) + (#xB9C3 #x7532) + (#xB9C4 #x7687) + (#xB9C5 #x786C) + (#xB9C6 #x7A3F) + (#xB9C7 #x7CE0) + (#xB9C8 #x7D05) + (#xB9C9 #x7D18) + (#xB9CA #x7D5E) + (#xB9CB #x7DB1) + (#xB9CC #x8015) + (#xB9CD #x8003) + (#xB9CE #x80AF) + (#xB9CF #x80B1) + (#xB9D0 #x8154) + (#xB9D1 #x818F) + (#xB9D2 #x822A) + (#xB9D3 #x8352) + (#xB9D4 #x884C) + (#xB9D5 #x8861) + (#xB9D6 #x8B1B) + (#xB9D7 #x8CA2) + (#xB9D8 #x8CFC) + (#xB9D9 #x90CA) + (#xB9DA #x9175) + (#xB9DB #x9271) + (#xB9DC #x783F) + (#xB9DD #x92FC) + (#xB9DE #x95A4) + (#xB9DF #x964D) + (#xB9E0 #x9805) + (#xB9E1 #x9999) + (#xB9E2 #x9AD8) + (#xB9E3 #x9D3B) + (#xB9E4 #x525B) + (#xB9E5 #x52AB) + (#xB9E6 #x53F7) + (#xB9E7 #x5408) + (#xB9E8 #x58D5) + (#xB9E9 #x62F7) + (#xB9EA #x6FE0) + (#xB9EB #x8C6A) + (#xB9EC #x8F5F) + (#xB9ED #x9EB9) + (#xB9EE #x514B) + (#xB9EF #x523B) + (#xB9F0 #x544A) + (#xB9F1 #x56FD) + (#xB9F2 #x7A40) + (#xB9F3 #x9177) + (#xB9F4 #x9D60) + (#xB9F5 #x9ED2) + (#xB9F6 #x7344) + (#xB9F7 #x6F09) + (#xB9F8 #x8170) + (#xB9F9 #x7511) + (#xB9FA #x5FFD) + (#xB9FB #x60DA) + (#xB9FC #x9AA8) + (#xB9FD #x72DB) + (#xB9FE #x8FBC) + (#xBAA1 #x6B64) + (#xBAA2 #x9803) + (#xBAA3 #x4ECA) + (#xBAA4 #x56F0) + (#xBAA5 #x5764) + (#xBAA6 #x58BE) + (#xBAA7 #x5A5A) + (#xBAA8 #x6068) + (#xBAA9 #x61C7) + (#xBAAA #x660F) + (#xBAAB #x6606) + (#xBAAC #x6839) + (#xBAAD #x68B1) + (#xBAAE #x6DF7) + (#xBAAF #x75D5) + (#xBAB0 #x7D3A) + (#xBAB1 #x826E) + (#xBAB2 #x9B42) + (#xBAB3 #x4E9B) + (#xBAB4 #x4F50) + (#xBAB5 #x53C9) + (#xBAB6 #x5506) + (#xBAB7 #x5D6F) + (#xBAB8 #x5DE6) + (#xBAB9 #x5DEE) + (#xBABA #x67FB) + (#xBABB #x6C99) + (#xBABC #x7473) + (#xBABD #x7802) + (#xBABE #x8A50) + (#xBABF #x9396) + (#xBAC0 #x88DF) + (#xBAC1 #x5750) + (#xBAC2 #x5EA7) + (#xBAC3 #x632B) + (#xBAC4 #x50B5) + (#xBAC5 #x50AC) + (#xBAC6 #x518D) + (#xBAC7 #x6700) + (#xBAC8 #x54C9) + (#xBAC9 #x585E) + (#xBACA #x59BB) + (#xBACB #x5BB0) + (#xBACC #x5F69) + (#xBACD #x624D) + (#xBACE #x63A1) + (#xBACF #x683D) + (#xBAD0 #x6B73) + (#xBAD1 #x6E08) + (#xBAD2 #x707D) + (#xBAD3 #x91C7) + (#xBAD4 #x7280) + (#xBAD5 #x7815) + (#xBAD6 #x7826) + (#xBAD7 #x796D) + (#xBAD8 #x658E) + (#xBAD9 #x7D30) + (#xBADA #x83DC) + (#xBADB #x88C1) + (#xBADC #x8F09) + (#xBADD #x969B) + (#xBADE #x5264) + (#xBADF #x5728) + (#xBAE0 #x6750) + (#xBAE1 #x7F6A) + (#xBAE2 #x8CA1) + (#xBAE3 #x51B4) + (#xBAE4 #x5742) + (#xBAE5 #x962A) + (#xBAE6 #x583A) + (#xBAE7 #x698A) + (#xBAE8 #x80B4) + (#xBAE9 #x54B2) + (#xBAEA #x5D0E) + (#xBAEB #x57FC) + (#xBAEC #x7895) + (#xBAED #x9DFA) + (#xBAEE #x4F5C) + (#xBAEF #x524A) + (#xBAF0 #x548B) + (#xBAF1 #x643E) + (#xBAF2 #x6628) + (#xBAF3 #x6714) + (#xBAF4 #x67F5) + (#xBAF5 #x7A84) + (#xBAF6 #x7B56) + (#xBAF7 #x7D22) + (#xBAF8 #x932F) + (#xBAF9 #x685C) + (#xBAFA #x9BAD) + (#xBAFB #x7B39) + (#xBAFC #x5319) + (#xBAFD #x518A) + (#xBAFE #x5237) + (#xBBA1 #x5BDF) + (#xBBA2 #x62F6) + (#xBBA3 #x64AE) + (#xBBA4 #x64E6) + (#xBBA5 #x672D) + (#xBBA6 #x6BBA) + (#xBBA7 #x85A9) + (#xBBA8 #x96D1) + (#xBBA9 #x7690) + (#xBBAA #x9BD6) + (#xBBAB #x634C) + (#xBBAC #x9306) + (#xBBAD #x9BAB) + (#xBBAE #x76BF) + (#xBBAF #x6652) + (#xBBB0 #x4E09) + (#xBBB1 #x5098) + (#xBBB2 #x53C2) + (#xBBB3 #x5C71) + (#xBBB4 #x60E8) + (#xBBB5 #x6492) + (#xBBB6 #x6563) + (#xBBB7 #x685F) + (#xBBB8 #x71E6) + (#xBBB9 #x73CA) + (#xBBBA #x7523) + (#xBBBB #x7B97) + (#xBBBC #x7E82) + (#xBBBD #x8695) + (#xBBBE #x8B83) + (#xBBBF #x8CDB) + (#xBBC0 #x9178) + (#xBBC1 #x9910) + (#xBBC2 #x65AC) + (#xBBC3 #x66AB) + (#xBBC4 #x6B8B) + (#xBBC5 #x4ED5) + (#xBBC6 #x4ED4) + (#xBBC7 #x4F3A) + (#xBBC8 #x4F7F) + (#xBBC9 #x523A) + (#xBBCA #x53F8) + (#xBBCB #x53F2) + (#xBBCC #x55E3) + (#xBBCD #x56DB) + (#xBBCE #x58EB) + (#xBBCF #x59CB) + (#xBBD0 #x59C9) + (#xBBD1 #x59FF) + (#xBBD2 #x5B50) + (#xBBD3 #x5C4D) + (#xBBD4 #x5E02) + (#xBBD5 #x5E2B) + (#xBBD6 #x5FD7) + (#xBBD7 #x601D) + (#xBBD8 #x6307) + (#xBBD9 #x652F) + (#xBBDA #x5B5C) + (#xBBDB #x65AF) + (#xBBDC #x65BD) + (#xBBDD #x65E8) + (#xBBDE #x679D) + (#xBBDF #x6B62) + (#xBBE0 #x6B7B) + (#xBBE1 #x6C0F) + (#xBBE2 #x7345) + (#xBBE3 #x7949) + (#xBBE4 #x79C1) + (#xBBE5 #x7CF8) + (#xBBE6 #x7D19) + (#xBBE7 #x7D2B) + (#xBBE8 #x80A2) + (#xBBE9 #x8102) + (#xBBEA #x81F3) + (#xBBEB #x8996) + (#xBBEC #x8A5E) + (#xBBED #x8A69) + (#xBBEE #x8A66) + (#xBBEF #x8A8C) + (#xBBF0 #x8AEE) + (#xBBF1 #x8CC7) + (#xBBF2 #x8CDC) + (#xBBF3 #x96CC) + (#xBBF4 #x98FC) + (#xBBF5 #x6B6F) + (#xBBF6 #x4E8B) + (#xBBF7 #x4F3C) + (#xBBF8 #x4F8D) + (#xBBF9 #x5150) + (#xBBFA #x5B57) + (#xBBFB #x5BFA) + (#xBBFC #x6148) + (#xBBFD #x6301) + (#xBBFE #x6642) + (#xBCA1 #x6B21) + (#xBCA2 #x6ECB) + (#xBCA3 #x6CBB) + (#xBCA4 #x723E) + (#xBCA5 #x74BD) + (#xBCA6 #x75D4) + (#xBCA7 #x78C1) + (#xBCA8 #x793A) + (#xBCA9 #x800C) + (#xBCAA #x8033) + (#xBCAB #x81EA) + (#xBCAC #x8494) + (#xBCAD #x8F9E) + (#xBCAE #x6C50) + (#xBCAF #x9E7F) + (#xBCB0 #x5F0F) + (#xBCB1 #x8B58) + (#xBCB2 #x9D2B) + (#xBCB3 #x7AFA) + (#xBCB4 #x8EF8) + (#xBCB5 #x5B8D) + (#xBCB6 #x96EB) + (#xBCB7 #x4E03) + (#xBCB8 #x53F1) + (#xBCB9 #x57F7) + (#xBCBA #x5931) + (#xBCBB #x5AC9) + (#xBCBC #x5BA4) + (#xBCBD #x6089) + (#xBCBE #x6E7F) + (#xBCBF #x6F06) + (#xBCC0 #x75BE) + (#xBCC1 #x8CEA) + (#xBCC2 #x5B9F) + (#xBCC3 #x8500) + (#xBCC4 #x7BE0) + (#xBCC5 #x5072) + (#xBCC6 #x67F4) + (#xBCC7 #x829D) + (#xBCC8 #x5C61) + (#xBCC9 #x854A) + (#xBCCA #x7E1E) + (#xBCCB #x820E) + (#xBCCC #x5199) + (#xBCCD #x5C04) + (#xBCCE #x6368) + (#xBCCF #x8D66) + (#xBCD0 #x659C) + (#xBCD1 #x716E) + (#xBCD2 #x793E) + (#xBCD3 #x7D17) + (#xBCD4 #x8005) + (#xBCD5 #x8B1D) + (#xBCD6 #x8ECA) + (#xBCD7 #x906E) + (#xBCD8 #x86C7) + (#xBCD9 #x90AA) + (#xBCDA #x501F) + (#xBCDB #x52FA) + (#xBCDC #x5C3A) + (#xBCDD #x6753) + (#xBCDE #x707C) + (#xBCDF #x7235) + (#xBCE0 #x914C) + (#xBCE1 #x91C8) + (#xBCE2 #x932B) + (#xBCE3 #x82E5) + (#xBCE4 #x5BC2) + (#xBCE5 #x5F31) + (#xBCE6 #x60F9) + (#xBCE7 #x4E3B) + (#xBCE8 #x53D6) + (#xBCE9 #x5B88) + (#xBCEA #x624B) + (#xBCEB #x6731) + (#xBCEC #x6B8A) + (#xBCED #x72E9) + (#xBCEE #x73E0) + (#xBCEF #x7A2E) + (#xBCF0 #x816B) + (#xBCF1 #x8DA3) + (#xBCF2 #x9152) + (#xBCF3 #x9996) + (#xBCF4 #x5112) + (#xBCF5 #x53D7) + (#xBCF6 #x546A) + (#xBCF7 #x5BFF) + (#xBCF8 #x6388) + (#xBCF9 #x6A39) + (#xBCFA #x7DAC) + (#xBCFB #x9700) + (#xBCFC #x56DA) + (#xBCFD #x53CE) + (#xBCFE #x5468) + (#xBDA1 #x5B97) + (#xBDA2 #x5C31) + (#xBDA3 #x5DDE) + (#xBDA4 #x4FEE) + (#xBDA5 #x6101) + (#xBDA6 #x62FE) + (#xBDA7 #x6D32) + (#xBDA8 #x79C0) + (#xBDA9 #x79CB) + (#xBDAA #x7D42) + (#xBDAB #x7E4D) + (#xBDAC #x7FD2) + (#xBDAD #x81ED) + (#xBDAE #x821F) + (#xBDAF #x8490) + (#xBDB0 #x8846) + (#xBDB1 #x8972) + (#xBDB2 #x8B90) + (#xBDB3 #x8E74) + (#xBDB4 #x8F2F) + (#xBDB5 #x9031) + (#xBDB6 #x914B) + (#xBDB7 #x916C) + (#xBDB8 #x96C6) + (#xBDB9 #x919C) + (#xBDBA #x4EC0) + (#xBDBB #x4F4F) + (#xBDBC #x5145) + (#xBDBD #x5341) + (#xBDBE #x5F93) + (#xBDBF #x620E) + (#xBDC0 #x67D4) + (#xBDC1 #x6C41) + (#xBDC2 #x6E0B) + (#xBDC3 #x7363) + (#xBDC4 #x7E26) + (#xBDC5 #x91CD) + (#xBDC6 #x9283) + (#xBDC7 #x53D4) + (#xBDC8 #x5919) + (#xBDC9 #x5BBF) + (#xBDCA #x6DD1) + (#xBDCB #x795D) + (#xBDCC #x7E2E) + (#xBDCD #x7C9B) + (#xBDCE #x587E) + (#xBDCF #x719F) + (#xBDD0 #x51FA) + (#xBDD1 #x8853) + (#xBDD2 #x8FF0) + (#xBDD3 #x4FCA) + (#xBDD4 #x5CFB) + (#xBDD5 #x6625) + (#xBDD6 #x77AC) + (#xBDD7 #x7AE3) + (#xBDD8 #x821C) + (#xBDD9 #x99FF) + (#xBDDA #x51C6) + (#xBDDB #x5FAA) + (#xBDDC #x65EC) + (#xBDDD #x696F) + (#xBDDE #x6B89) + (#xBDDF #x6DF3) + (#xBDE0 #x6E96) + (#xBDE1 #x6F64) + (#xBDE2 #x76FE) + (#xBDE3 #x7D14) + (#xBDE4 #x5DE1) + (#xBDE5 #x9075) + (#xBDE6 #x9187) + (#xBDE7 #x9806) + (#xBDE8 #x51E6) + (#xBDE9 #x521D) + (#xBDEA #x6240) + (#xBDEB #x6691) + (#xBDEC #x66D9) + (#xBDED #x6E1A) + (#xBDEE #x5EB6) + (#xBDEF #x7DD2) + (#xBDF0 #x7F72) + (#xBDF1 #x66F8) + (#xBDF2 #x85AF) + (#xBDF3 #x85F7) + (#xBDF4 #x8AF8) + (#xBDF5 #x52A9) + (#xBDF6 #x53D9) + (#xBDF7 #x5973) + (#xBDF8 #x5E8F) + (#xBDF9 #x5F90) + (#xBDFA #x6055) + (#xBDFB #x92E4) + (#xBDFC #x9664) + (#xBDFD #x50B7) + (#xBDFE #x511F) + (#xBEA1 #x52DD) + (#xBEA2 #x5320) + (#xBEA3 #x5347) + (#xBEA4 #x53EC) + (#xBEA5 #x54E8) + (#xBEA6 #x5546) + (#xBEA7 #x5531) + (#xBEA8 #x5617) + (#xBEA9 #x5968) + (#xBEAA #x59BE) + (#xBEAB #x5A3C) + (#xBEAC #x5BB5) + (#xBEAD #x5C06) + (#xBEAE #x5C0F) + (#xBEAF #x5C11) + (#xBEB0 #x5C1A) + (#xBEB1 #x5E84) + (#xBEB2 #x5E8A) + (#xBEB3 #x5EE0) + (#xBEB4 #x5F70) + (#xBEB5 #x627F) + (#xBEB6 #x6284) + (#xBEB7 #x62DB) + (#xBEB8 #x638C) + (#xBEB9 #x6377) + (#xBEBA #x6607) + (#xBEBB #x660C) + (#xBEBC #x662D) + (#xBEBD #x6676) + (#xBEBE #x677E) + (#xBEBF #x68A2) + (#xBEC0 #x6A1F) + (#xBEC1 #x6A35) + (#xBEC2 #x6CBC) + (#xBEC3 #x6D88) + (#xBEC4 #x6E09) + (#xBEC5 #x6E58) + (#xBEC6 #x713C) + (#xBEC7 #x7126) + (#xBEC8 #x7167) + (#xBEC9 #x75C7) + (#xBECA #x7701) + (#xBECB #x785D) + (#xBECC #x7901) + (#xBECD #x7965) + (#xBECE #x79F0) + (#xBECF #x7AE0) + (#xBED0 #x7B11) + (#xBED1 #x7CA7) + (#xBED2 #x7D39) + (#xBED3 #x8096) + (#xBED4 #x83D6) + (#xBED5 #x848B) + (#xBED6 #x8549) + (#xBED7 #x885D) + (#xBED8 #x88F3) + (#xBED9 #x8A1F) + (#xBEDA #x8A3C) + (#xBEDB #x8A54) + (#xBEDC #x8A73) + (#xBEDD #x8C61) + (#xBEDE #x8CDE) + (#xBEDF #x91A4) + (#xBEE0 #x9266) + (#xBEE1 #x937E) + (#xBEE2 #x9418) + (#xBEE3 #x969C) + (#xBEE4 #x9798) + (#xBEE5 #x4E0A) + (#xBEE6 #x4E08) + (#xBEE7 #x4E1E) + (#xBEE8 #x4E57) + (#xBEE9 #x5197) + (#xBEEA #x5270) + (#xBEEB #x57CE) + (#xBEEC #x5834) + (#xBEED #x58CC) + (#xBEEE #x5B22) + (#xBEEF #x5E38) + (#xBEF0 #x60C5) + (#xBEF1 #x64FE) + (#xBEF2 #x6761) + (#xBEF3 #x6756) + (#xBEF4 #x6D44) + (#xBEF5 #x72B6) + (#xBEF6 #x7573) + (#xBEF7 #x7A63) + (#xBEF8 #x84B8) + (#xBEF9 #x8B72) + (#xBEFA #x91B8) + (#xBEFB #x9320) + (#xBEFC #x5631) + (#xBEFD #x57F4) + (#xBEFE #x98FE) + (#xBFA1 #x62ED) + (#xBFA2 #x690D) + (#xBFA3 #x6B96) + (#xBFA4 #x71ED) + (#xBFA5 #x7E54) + (#xBFA6 #x8077) + (#xBFA7 #x8272) + (#xBFA8 #x89E6) + (#xBFA9 #x98DF) + (#xBFAA #x8755) + (#xBFAB #x8FB1) + (#xBFAC #x5C3B) + (#xBFAD #x4F38) + (#xBFAE #x4FE1) + (#xBFAF #x4FB5) + (#xBFB0 #x5507) + (#xBFB1 #x5A20) + (#xBFB2 #x5BDD) + (#xBFB3 #x5BE9) + (#xBFB4 #x5FC3) + (#xBFB5 #x614E) + (#xBFB6 #x632F) + (#xBFB7 #x65B0) + (#xBFB8 #x664B) + (#xBFB9 #x68EE) + (#xBFBA #x699B) + (#xBFBB #x6D78) + (#xBFBC #x6DF1) + (#xBFBD #x7533) + (#xBFBE #x75B9) + (#xBFBF #x771F) + (#xBFC0 #x795E) + (#xBFC1 #x79E6) + (#xBFC2 #x7D33) + (#xBFC3 #x81E3) + (#xBFC4 #x82AF) + (#xBFC5 #x85AA) + (#xBFC6 #x89AA) + (#xBFC7 #x8A3A) + (#xBFC8 #x8EAB) + (#xBFC9 #x8F9B) + (#xBFCA #x9032) + (#xBFCB #x91DD) + (#xBFCC #x9707) + (#xBFCD #x4EBA) + (#xBFCE #x4EC1) + (#xBFCF #x5203) + (#xBFD0 #x5875) + (#xBFD1 #x58EC) + (#xBFD2 #x5C0B) + (#xBFD3 #x751A) + (#xBFD4 #x5C3D) + (#xBFD5 #x814E) + (#xBFD6 #x8A0A) + (#xBFD7 #x8FC5) + (#xBFD8 #x9663) + (#xBFD9 #x976D) + (#xBFDA #x7B25) + (#xBFDB #x8ACF) + (#xBFDC #x9808) + (#xBFDD #x9162) + (#xBFDE #x56F3) + (#xBFDF #x53A8) + (#xBFE0 #x9017) + (#xBFE1 #x5439) + (#xBFE2 #x5782) + (#xBFE3 #x5E25) + (#xBFE4 #x63A8) + (#xBFE5 #x6C34) + (#xBFE6 #x708A) + (#xBFE7 #x7761) + (#xBFE8 #x7C8B) + (#xBFE9 #x7FE0) + (#xBFEA #x8870) + (#xBFEB #x9042) + (#xBFEC #x9154) + (#xBFED #x9310) + (#xBFEE #x9318) + (#xBFEF #x968F) + (#xBFF0 #x745E) + (#xBFF1 #x9AC4) + (#xBFF2 #x5D07) + (#xBFF3 #x5D69) + (#xBFF4 #x6570) + (#xBFF5 #x67A2) + (#xBFF6 #x8DA8) + (#xBFF7 #x96DB) + (#xBFF8 #x636E) + (#xBFF9 #x6749) + (#xBFFA #x6919) + (#xBFFB #x83C5) + (#xBFFC #x9817) + (#xBFFD #x96C0) + (#xBFFE #x88FE) + (#xC0A1 #x6F84) + (#xC0A2 #x647A) + (#xC0A3 #x5BF8) + (#xC0A4 #x4E16) + (#xC0A5 #x702C) + (#xC0A6 #x755D) + (#xC0A7 #x662F) + (#xC0A8 #x51C4) + (#xC0A9 #x5236) + (#xC0AA #x52E2) + (#xC0AB #x59D3) + (#xC0AC #x5F81) + (#xC0AD #x6027) + (#xC0AE #x6210) + (#xC0AF #x653F) + (#xC0B0 #x6574) + (#xC0B1 #x661F) + (#xC0B2 #x6674) + (#xC0B3 #x68F2) + (#xC0B4 #x6816) + (#xC0B5 #x6B63) + (#xC0B6 #x6E05) + (#xC0B7 #x7272) + (#xC0B8 #x751F) + (#xC0B9 #x76DB) + (#xC0BA #x7CBE) + (#xC0BB #x8056) + (#xC0BC #x58F0) + (#xC0BD #x88FD) + (#xC0BE #x897F) + (#xC0BF #x8AA0) + (#xC0C0 #x8A93) + (#xC0C1 #x8ACB) + (#xC0C2 #x901D) + (#xC0C3 #x9192) + (#xC0C4 #x9752) + (#xC0C5 #x9759) + (#xC0C6 #x6589) + (#xC0C7 #x7A0E) + (#xC0C8 #x8106) + (#xC0C9 #x96BB) + (#xC0CA #x5E2D) + (#xC0CB #x60DC) + (#xC0CC #x621A) + (#xC0CD #x65A5) + (#xC0CE #x6614) + (#xC0CF #x6790) + (#xC0D0 #x77F3) + (#xC0D1 #x7A4D) + (#xC0D2 #x7C4D) + (#xC0D3 #x7E3E) + (#xC0D4 #x810A) + (#xC0D5 #x8CAC) + (#xC0D6 #x8D64) + (#xC0D7 #x8DE1) + (#xC0D8 #x8E5F) + (#xC0D9 #x78A9) + (#xC0DA #x5207) + (#xC0DB #x62D9) + (#xC0DC #x63A5) + (#xC0DD #x6442) + (#xC0DE #x6298) + (#xC0DF #x8A2D) + (#xC0E0 #x7A83) + (#xC0E1 #x7BC0) + (#xC0E2 #x8AAC) + (#xC0E3 #x96EA) + (#xC0E4 #x7D76) + (#xC0E5 #x820C) + (#xC0E6 #x8749) + (#xC0E7 #x4ED9) + (#xC0E8 #x5148) + (#xC0E9 #x5343) + (#xC0EA #x5360) + (#xC0EB #x5BA3) + (#xC0EC #x5C02) + (#xC0ED #x5C16) + (#xC0EE #x5DDD) + (#xC0EF #x6226) + (#xC0F0 #x6247) + (#xC0F1 #x64B0) + (#xC0F2 #x6813) + (#xC0F3 #x6834) + (#xC0F4 #x6CC9) + (#xC0F5 #x6D45) + (#xC0F6 #x6D17) + (#xC0F7 #x67D3) + (#xC0F8 #x6F5C) + (#xC0F9 #x714E) + (#xC0FA #x717D) + (#xC0FB #x65CB) + (#xC0FC #x7A7F) + (#xC0FD #x7BAD) + (#xC0FE #x7DDA) + (#xC1A1 #x7E4A) + (#xC1A2 #x7FA8) + (#xC1A3 #x817A) + (#xC1A4 #x821B) + (#xC1A5 #x8239) + (#xC1A6 #x85A6) + (#xC1A7 #x8A6E) + (#xC1A8 #x8CCE) + (#xC1A9 #x8DF5) + (#xC1AA #x9078) + (#xC1AB #x9077) + (#xC1AC #x92AD) + (#xC1AD #x9291) + (#xC1AE #x9583) + (#xC1AF #x9BAE) + (#xC1B0 #x524D) + (#xC1B1 #x5584) + (#xC1B2 #x6F38) + (#xC1B3 #x7136) + (#xC1B4 #x5168) + (#xC1B5 #x7985) + (#xC1B6 #x7E55) + (#xC1B7 #x81B3) + (#xC1B8 #x7CCE) + (#xC1B9 #x564C) + (#xC1BA #x5851) + (#xC1BB #x5CA8) + (#xC1BC #x63AA) + (#xC1BD #x66FE) + (#xC1BE #x66FD) + (#xC1BF #x695A) + (#xC1C0 #x72D9) + (#xC1C1 #x758F) + (#xC1C2 #x758E) + (#xC1C3 #x790E) + (#xC1C4 #x7956) + (#xC1C5 #x79DF) + (#xC1C6 #x7C97) + (#xC1C7 #x7D20) + (#xC1C8 #x7D44) + (#xC1C9 #x8607) + (#xC1CA #x8A34) + (#xC1CB #x963B) + (#xC1CC #x9061) + (#xC1CD #x9F20) + (#xC1CE #x50E7) + (#xC1CF #x5275) + (#xC1D0 #x53CC) + (#xC1D1 #x53E2) + (#xC1D2 #x5009) + (#xC1D3 #x55AA) + (#xC1D4 #x58EE) + (#xC1D5 #x594F) + (#xC1D6 #x723D) + (#xC1D7 #x5B8B) + (#xC1D8 #x5C64) + (#xC1D9 #x531D) + (#xC1DA #x60E3) + (#xC1DB #x60F3) + (#xC1DC #x635C) + (#xC1DD #x6383) + (#xC1DE #x633F) + (#xC1DF #x63BB) + (#xC1E0 #x64CD) + (#xC1E1 #x65E9) + (#xC1E2 #x66F9) + (#xC1E3 #x5DE3) + (#xC1E4 #x69CD) + (#xC1E5 #x69FD) + (#xC1E6 #x6F15) + (#xC1E7 #x71E5) + (#xC1E8 #x4E89) + (#xC1E9 #x75E9) + (#xC1EA #x76F8) + (#xC1EB #x7A93) + (#xC1EC #x7CDF) + (#xC1ED #x7DCF) + (#xC1EE #x7D9C) + (#xC1EF #x8061) + (#xC1F0 #x8349) + (#xC1F1 #x8358) + (#xC1F2 #x846C) + (#xC1F3 #x84BC) + (#xC1F4 #x85FB) + (#xC1F5 #x88C5) + (#xC1F6 #x8D70) + (#xC1F7 #x9001) + (#xC1F8 #x906D) + (#xC1F9 #x9397) + (#xC1FA #x971C) + (#xC1FB #x9A12) + (#xC1FC #x50CF) + (#xC1FD #x5897) + (#xC1FE #x618E) + (#xC2A1 #x81D3) + (#xC2A2 #x8535) + (#xC2A3 #x8D08) + (#xC2A4 #x9020) + (#xC2A5 #x4FC3) + (#xC2A6 #x5074) + (#xC2A7 #x5247) + (#xC2A8 #x5373) + (#xC2A9 #x606F) + (#xC2AA #x6349) + (#xC2AB #x675F) + (#xC2AC #x6E2C) + (#xC2AD #x8DB3) + (#xC2AE #x901F) + (#xC2AF #x4FD7) + (#xC2B0 #x5C5E) + (#xC2B1 #x8CCA) + (#xC2B2 #x65CF) + (#xC2B3 #x7D9A) + (#xC2B4 #x5352) + (#xC2B5 #x8896) + (#xC2B6 #x5176) + (#xC2B7 #x63C3) + (#xC2B8 #x5B58) + (#xC2B9 #x5B6B) + (#xC2BA #x5C0A) + (#xC2BB #x640D) + (#xC2BC #x6751) + (#xC2BD #x905C) + (#xC2BE #x4ED6) + (#xC2BF #x591A) + (#xC2C0 #x592A) + (#xC2C1 #x6C70) + (#xC2C2 #x8A51) + (#xC2C3 #x553E) + (#xC2C4 #x5815) + (#xC2C5 #x59A5) + (#xC2C6 #x60F0) + (#xC2C7 #x6253) + (#xC2C8 #x67C1) + (#xC2C9 #x8235) + (#xC2CA #x6955) + (#xC2CB #x9640) + (#xC2CC #x99C4) + (#xC2CD #x9A28) + (#xC2CE #x4F53) + (#xC2CF #x5806) + (#xC2D0 #x5BFE) + (#xC2D1 #x8010) + (#xC2D2 #x5CB1) + (#xC2D3 #x5E2F) + (#xC2D4 #x5F85) + (#xC2D5 #x6020) + (#xC2D6 #x614B) + (#xC2D7 #x6234) + (#xC2D8 #x66FF) + (#xC2D9 #x6CF0) + (#xC2DA #x6EDE) + (#xC2DB #x80CE) + (#xC2DC #x817F) + (#xC2DD #x82D4) + (#xC2DE #x888B) + (#xC2DF #x8CB8) + (#xC2E0 #x9000) + (#xC2E1 #x902E) + (#xC2E2 #x968A) + (#xC2E3 #x9EDB) + (#xC2E4 #x9BDB) + (#xC2E5 #x4EE3) + (#xC2E6 #x53F0) + (#xC2E7 #x5927) + (#xC2E8 #x7B2C) + (#xC2E9 #x918D) + (#xC2EA #x984C) + (#xC2EB #x9DF9) + (#xC2EC #x6EDD) + (#xC2ED #x7027) + (#xC2EE #x5353) + (#xC2EF #x5544) + (#xC2F0 #x5B85) + (#xC2F1 #x6258) + (#xC2F2 #x629E) + (#xC2F3 #x62D3) + (#xC2F4 #x6CA2) + (#xC2F5 #x6FEF) + (#xC2F6 #x7422) + (#xC2F7 #x8A17) + (#xC2F8 #x9438) + (#xC2F9 #x6FC1) + (#xC2FA #x8AFE) + (#xC2FB #x8338) + (#xC2FC #x51E7) + (#xC2FD #x86F8) + (#xC2FE #x53EA) + (#xC3A1 #x53E9) + (#xC3A2 #x4F46) + (#xC3A3 #x9054) + (#xC3A4 #x8FB0) + (#xC3A5 #x596A) + (#xC3A6 #x8131) + (#xC3A7 #x5DFD) + (#xC3A8 #x7AEA) + (#xC3A9 #x8FBF) + (#xC3AA #x68DA) + (#xC3AB #x8C37) + (#xC3AC #x72F8) + (#xC3AD #x9C48) + (#xC3AE #x6A3D) + (#xC3AF #x8AB0) + (#xC3B0 #x4E39) + (#xC3B1 #x5358) + (#xC3B2 #x5606) + (#xC3B3 #x5766) + (#xC3B4 #x62C5) + (#xC3B5 #x63A2) + (#xC3B6 #x65E6) + (#xC3B7 #x6B4E) + (#xC3B8 #x6DE1) + (#xC3B9 #x6E5B) + (#xC3BA #x70AD) + (#xC3BB #x77ED) + (#xC3BC #x7AEF) + (#xC3BD #x7BAA) + (#xC3BE #x7DBB) + (#xC3BF #x803D) + (#xC3C0 #x80C6) + (#xC3C1 #x86CB) + (#xC3C2 #x8A95) + (#xC3C3 #x935B) + (#xC3C4 #x56E3) + (#xC3C5 #x58C7) + (#xC3C6 #x5F3E) + (#xC3C7 #x65AD) + (#xC3C8 #x6696) + (#xC3C9 #x6A80) + (#xC3CA #x6BB5) + (#xC3CB #x7537) + (#xC3CC #x8AC7) + (#xC3CD #x5024) + (#xC3CE #x77E5) + (#xC3CF #x5730) + (#xC3D0 #x5F1B) + (#xC3D1 #x6065) + (#xC3D2 #x667A) + (#xC3D3 #x6C60) + (#xC3D4 #x75F4) + (#xC3D5 #x7A1A) + (#xC3D6 #x7F6E) + (#xC3D7 #x81F4) + (#xC3D8 #x8718) + (#xC3D9 #x9045) + (#xC3DA #x99B3) + (#xC3DB #x7BC9) + (#xC3DC #x755C) + (#xC3DD #x7AF9) + (#xC3DE #x7B51) + (#xC3DF #x84C4) + (#xC3E0 #x9010) + (#xC3E1 #x79E9) + (#xC3E2 #x7A92) + (#xC3E3 #x8336) + (#xC3E4 #x5AE1) + (#xC3E5 #x7740) + (#xC3E6 #x4E2D) + (#xC3E7 #x4EF2) + (#xC3E8 #x5B99) + (#xC3E9 #x5FE0) + (#xC3EA #x62BD) + (#xC3EB #x663C) + (#xC3EC #x67F1) + (#xC3ED #x6CE8) + (#xC3EE #x866B) + (#xC3EF #x8877) + (#xC3F0 #x8A3B) + (#xC3F1 #x914E) + (#xC3F2 #x92F3) + (#xC3F3 #x99D0) + (#xC3F4 #x6A17) + (#xC3F5 #x7026) + (#xC3F6 #x732A) + (#xC3F7 #x82E7) + (#xC3F8 #x8457) + (#xC3F9 #x8CAF) + (#xC3FA #x4E01) + (#xC3FB #x5146) + (#xC3FC #x51CB) + (#xC3FD #x558B) + (#xC3FE #x5BF5) + (#xC4A1 #x5E16) + (#xC4A2 #x5E33) + (#xC4A3 #x5E81) + (#xC4A4 #x5F14) + (#xC4A5 #x5F35) + (#xC4A6 #x5F6B) + (#xC4A7 #x5FB4) + (#xC4A8 #x61F2) + (#xC4A9 #x6311) + (#xC4AA #x66A2) + (#xC4AB #x671D) + (#xC4AC #x6F6E) + (#xC4AD #x7252) + (#xC4AE #x753A) + (#xC4AF #x773A) + (#xC4B0 #x8074) + (#xC4B1 #x8139) + (#xC4B2 #x8178) + (#xC4B3 #x8776) + (#xC4B4 #x8ABF) + (#xC4B5 #x8ADC) + (#xC4B6 #x8D85) + (#xC4B7 #x8DF3) + (#xC4B8 #x929A) + (#xC4B9 #x9577) + (#xC4BA #x9802) + (#xC4BB #x9CE5) + (#xC4BC #x52C5) + (#xC4BD #x6357) + (#xC4BE #x76F4) + (#xC4BF #x6715) + (#xC4C0 #x6C88) + (#xC4C1 #x73CD) + (#xC4C2 #x8CC3) + (#xC4C3 #x93AE) + (#xC4C4 #x9673) + (#xC4C5 #x6D25) + (#xC4C6 #x589C) + (#xC4C7 #x690E) + (#xC4C8 #x69CC) + (#xC4C9 #x8FFD) + (#xC4CA #x939A) + (#xC4CB #x75DB) + (#xC4CC #x901A) + (#xC4CD #x585A) + (#xC4CE #x6802) + (#xC4CF #x63B4) + (#xC4D0 #x69FB) + (#xC4D1 #x4F43) + (#xC4D2 #x6F2C) + (#xC4D3 #x67D8) + (#xC4D4 #x8FBB) + (#xC4D5 #x8526) + (#xC4D6 #x7DB4) + (#xC4D7 #x9354) + (#xC4D8 #x693F) + (#xC4D9 #x6F70) + (#xC4DA #x576A) + (#xC4DB #x58F7) + (#xC4DC #x5B2C) + (#xC4DD #x7D2C) + (#xC4DE #x722A) + (#xC4DF #x540A) + (#xC4E0 #x91E3) + (#xC4E1 #x9DB4) + (#xC4E2 #x4EAD) + (#xC4E3 #x4F4E) + (#xC4E4 #x505C) + (#xC4E5 #x5075) + (#xC4E6 #x5243) + (#xC4E7 #x8C9E) + (#xC4E8 #x5448) + (#xC4E9 #x5824) + (#xC4EA #x5B9A) + (#xC4EB #x5E1D) + (#xC4EC #x5E95) + (#xC4ED #x5EAD) + (#xC4EE #x5EF7) + (#xC4EF #x5F1F) + (#xC4F0 #x608C) + (#xC4F1 #x62B5) + (#xC4F2 #x633A) + (#xC4F3 #x63D0) + (#xC4F4 #x68AF) + (#xC4F5 #x6C40) + (#xC4F6 #x7887) + (#xC4F7 #x798E) + (#xC4F8 #x7A0B) + (#xC4F9 #x7DE0) + (#xC4FA #x8247) + (#xC4FB #x8A02) + (#xC4FC #x8AE6) + (#xC4FD #x8E44) + (#xC4FE #x9013) + (#xC5A1 #x90B8) + (#xC5A2 #x912D) + (#xC5A3 #x91D8) + (#xC5A4 #x9F0E) + (#xC5A5 #x6CE5) + (#xC5A6 #x6458) + (#xC5A7 #x64E2) + (#xC5A8 #x6575) + (#xC5A9 #x6EF4) + (#xC5AA #x7684) + (#xC5AB #x7B1B) + (#xC5AC #x9069) + (#xC5AD #x93D1) + (#xC5AE #x6EBA) + (#xC5AF #x54F2) + (#xC5B0 #x5FB9) + (#xC5B1 #x64A4) + (#xC5B2 #x8F4D) + (#xC5B3 #x8FED) + (#xC5B4 #x9244) + (#xC5B5 #x5178) + (#xC5B6 #x586B) + (#xC5B7 #x5929) + (#xC5B8 #x5C55) + (#xC5B9 #x5E97) + (#xC5BA #x6DFB) + (#xC5BB #x7E8F) + (#xC5BC #x751C) + (#xC5BD #x8CBC) + (#xC5BE #x8EE2) + (#xC5BF #x985B) + (#xC5C0 #x70B9) + (#xC5C1 #x4F1D) + (#xC5C2 #x6BBF) + (#xC5C3 #x6FB1) + (#xC5C4 #x7530) + (#xC5C5 #x96FB) + (#xC5C6 #x514E) + (#xC5C7 #x5410) + (#xC5C8 #x5835) + (#xC5C9 #x5857) + (#xC5CA #x59AC) + (#xC5CB #x5C60) + (#xC5CC #x5F92) + (#xC5CD #x6597) + (#xC5CE #x675C) + (#xC5CF #x6E21) + (#xC5D0 #x767B) + (#xC5D1 #x83DF) + (#xC5D2 #x8CED) + (#xC5D3 #x9014) + (#xC5D4 #x90FD) + (#xC5D5 #x934D) + (#xC5D6 #x7825) + (#xC5D7 #x783A) + (#xC5D8 #x52AA) + (#xC5D9 #x5EA6) + (#xC5DA #x571F) + (#xC5DB #x5974) + (#xC5DC #x6012) + (#xC5DD #x5012) + (#xC5DE #x515A) + (#xC5DF #x51AC) + (#xC5E0 #x51CD) + (#xC5E1 #x5200) + (#xC5E2 #x5510) + (#xC5E3 #x5854) + (#xC5E4 #x5858) + (#xC5E5 #x5957) + (#xC5E6 #x5B95) + (#xC5E7 #x5CF6) + (#xC5E8 #x5D8B) + (#xC5E9 #x60BC) + (#xC5EA #x6295) + (#xC5EB #x642D) + (#xC5EC #x6771) + (#xC5ED #x6843) + (#xC5EE #x68BC) + (#xC5EF #x68DF) + (#xC5F0 #x76D7) + (#xC5F1 #x6DD8) + (#xC5F2 #x6E6F) + (#xC5F3 #x6D9B) + (#xC5F4 #x706F) + (#xC5F5 #x71C8) + (#xC5F6 #x5F53) + (#xC5F7 #x75D8) + (#xC5F8 #x7977) + (#xC5F9 #x7B49) + (#xC5FA #x7B54) + (#xC5FB #x7B52) + (#xC5FC #x7CD6) + (#xC5FD #x7D71) + (#xC5FE #x5230) + (#xC6A1 #x8463) + (#xC6A2 #x8569) + (#xC6A3 #x85E4) + (#xC6A4 #x8A0E) + (#xC6A5 #x8B04) + (#xC6A6 #x8C46) + (#xC6A7 #x8E0F) + (#xC6A8 #x9003) + (#xC6A9 #x900F) + (#xC6AA #x9419) + (#xC6AB #x9676) + (#xC6AC #x982D) + (#xC6AD #x9A30) + (#xC6AE #x95D8) + (#xC6AF #x50CD) + (#xC6B0 #x52D5) + (#xC6B1 #x540C) + (#xC6B2 #x5802) + (#xC6B3 #x5C0E) + (#xC6B4 #x61A7) + (#xC6B5 #x649E) + (#xC6B6 #x6D1E) + (#xC6B7 #x77B3) + (#xC6B8 #x7AE5) + (#xC6B9 #x80F4) + (#xC6BA #x8404) + (#xC6BB #x9053) + (#xC6BC #x9285) + (#xC6BD #x5CE0) + (#xC6BE #x9D07) + (#xC6BF #x533F) + (#xC6C0 #x5F97) + (#xC6C1 #x5FB3) + (#xC6C2 #x6D9C) + (#xC6C3 #x7279) + (#xC6C4 #x7763) + (#xC6C5 #x79BF) + (#xC6C6 #x7BE4) + (#xC6C7 #x6BD2) + (#xC6C8 #x72EC) + (#xC6C9 #x8AAD) + (#xC6CA #x6803) + (#xC6CB #x6A61) + (#xC6CC #x51F8) + (#xC6CD #x7A81) + (#xC6CE #x6934) + (#xC6CF #x5C4A) + (#xC6D0 #x9CF6) + (#xC6D1 #x82EB) + (#xC6D2 #x5BC5) + (#xC6D3 #x9149) + (#xC6D4 #x701E) + (#xC6D5 #x5678) + (#xC6D6 #x5C6F) + (#xC6D7 #x60C7) + (#xC6D8 #x6566) + (#xC6D9 #x6C8C) + (#xC6DA #x8C5A) + (#xC6DB #x9041) + (#xC6DC #x9813) + (#xC6DD #x5451) + (#xC6DE #x66C7) + (#xC6DF #x920D) + (#xC6E0 #x5948) + (#xC6E1 #x90A3) + (#xC6E2 #x5185) + (#xC6E3 #x4E4D) + (#xC6E4 #x51EA) + (#xC6E5 #x8599) + (#xC6E6 #x8B0E) + (#xC6E7 #x7058) + (#xC6E8 #x637A) + (#xC6E9 #x934B) + (#xC6EA #x6962) + (#xC6EB #x99B4) + (#xC6EC #x7E04) + (#xC6ED #x7577) + (#xC6EE #x5357) + (#xC6EF #x6960) + (#xC6F0 #x8EDF) + (#xC6F1 #x96E3) + (#xC6F2 #x6C5D) + (#xC6F3 #x4E8C) + (#xC6F4 #x5C3C) + (#xC6F5 #x5F10) + (#xC6F6 #x8FE9) + (#xC6F7 #x5302) + (#xC6F8 #x8CD1) + (#xC6F9 #x8089) + (#xC6FA #x8679) + (#xC6FB #x5EFF) + (#xC6FC #x65E5) + (#xC6FD #x4E73) + (#xC6FE #x5165) + (#xC7A1 #x5982) + (#xC7A2 #x5C3F) + (#xC7A3 #x97EE) + (#xC7A4 #x4EFB) + (#xC7A5 #x598A) + (#xC7A6 #x5FCD) + (#xC7A7 #x8A8D) + (#xC7A8 #x6FE1) + (#xC7A9 #x79B0) + (#xC7AA #x7962) + (#xC7AB #x5BE7) + (#xC7AC #x8471) + (#xC7AD #x732B) + (#xC7AE #x71B1) + (#xC7AF #x5E74) + (#xC7B0 #x5FF5) + (#xC7B1 #x637B) + (#xC7B2 #x649A) + (#xC7B3 #x71C3) + (#xC7B4 #x7C98) + (#xC7B5 #x4E43) + (#xC7B6 #x5EFC) + (#xC7B7 #x4E4B) + (#xC7B8 #x57DC) + (#xC7B9 #x56A2) + (#xC7BA #x60A9) + (#xC7BB #x6FC3) + (#xC7BC #x7D0D) + (#xC7BD #x80FD) + (#xC7BE #x8133) + (#xC7BF #x81BF) + (#xC7C0 #x8FB2) + (#xC7C1 #x8997) + (#xC7C2 #x86A4) + (#xC7C3 #x5DF4) + (#xC7C4 #x628A) + (#xC7C5 #x64AD) + (#xC7C6 #x8987) + (#xC7C7 #x6777) + (#xC7C8 #x6CE2) + (#xC7C9 #x6D3E) + (#xC7CA #x7436) + (#xC7CB #x7834) + (#xC7CC #x5A46) + (#xC7CD #x7F75) + (#xC7CE #x82AD) + (#xC7CF #x99AC) + (#xC7D0 #x4FF3) + (#xC7D1 #x5EC3) + (#xC7D2 #x62DD) + (#xC7D3 #x6392) + (#xC7D4 #x6557) + (#xC7D5 #x676F) + (#xC7D6 #x76C3) + (#xC7D7 #x724C) + (#xC7D8 #x80CC) + (#xC7D9 #x80BA) + (#xC7DA #x8F29) + (#xC7DB #x914D) + (#xC7DC #x500D) + (#xC7DD #x57F9) + (#xC7DE #x5A92) + (#xC7DF #x6885) + (#xC7E0 #x6973) + (#xC7E1 #x7164) + (#xC7E2 #x72FD) + (#xC7E3 #x8CB7) + (#xC7E4 #x58F2) + (#xC7E5 #x8CE0) + (#xC7E6 #x966A) + (#xC7E7 #x9019) + (#xC7E8 #x877F) + (#xC7E9 #x79E4) + (#xC7EA #x77E7) + (#xC7EB #x8429) + (#xC7EC #x4F2F) + (#xC7ED #x5265) + (#xC7EE #x535A) + (#xC7EF #x62CD) + (#xC7F0 #x67CF) + (#xC7F1 #x6CCA) + (#xC7F2 #x767D) + (#xC7F3 #x7B94) + (#xC7F4 #x7C95) + (#xC7F5 #x8236) + (#xC7F6 #x8584) + (#xC7F7 #x8FEB) + (#xC7F8 #x66DD) + (#xC7F9 #x6F20) + (#xC7FA #x7206) + (#xC7FB #x7E1B) + (#xC7FC #x83AB) + (#xC7FD #x99C1) + (#xC7FE #x9EA6) + (#xC8A1 #x51FD) + (#xC8A2 #x7BB1) + (#xC8A3 #x7872) + (#xC8A4 #x7BB8) + (#xC8A5 #x8087) + (#xC8A6 #x7B48) + (#xC8A7 #x6AE8) + (#xC8A8 #x5E61) + (#xC8A9 #x808C) + (#xC8AA #x7551) + (#xC8AB #x7560) + (#xC8AC #x516B) + (#xC8AD #x9262) + (#xC8AE #x6E8C) + (#xC8AF #x767A) + (#xC8B0 #x9197) + (#xC8B1 #x9AEA) + (#xC8B2 #x4F10) + (#xC8B3 #x7F70) + (#xC8B4 #x629C) + (#xC8B5 #x7B4F) + (#xC8B6 #x95A5) + (#xC8B7 #x9CE9) + (#xC8B8 #x567A) + (#xC8B9 #x5859) + (#xC8BA #x86E4) + (#xC8BB #x96BC) + (#xC8BC #x4F34) + (#xC8BD #x5224) + (#xC8BE #x534A) + (#xC8BF #x53CD) + (#xC8C0 #x53DB) + (#xC8C1 #x5E06) + (#xC8C2 #x642C) + (#xC8C3 #x6591) + (#xC8C4 #x677F) + (#xC8C5 #x6C3E) + (#xC8C6 #x6C4E) + (#xC8C7 #x7248) + (#xC8C8 #x72AF) + (#xC8C9 #x73ED) + (#xC8CA #x7554) + (#xC8CB #x7E41) + (#xC8CC #x822C) + (#xC8CD #x85E9) + (#xC8CE #x8CA9) + (#xC8CF #x7BC4) + (#xC8D0 #x91C6) + (#xC8D1 #x7169) + (#xC8D2 #x9812) + (#xC8D3 #x98EF) + (#xC8D4 #x633D) + (#xC8D5 #x6669) + (#xC8D6 #x756A) + (#xC8D7 #x76E4) + (#xC8D8 #x78D0) + (#xC8D9 #x8543) + (#xC8DA #x86EE) + (#xC8DB #x532A) + (#xC8DC #x5351) + (#xC8DD #x5426) + (#xC8DE #x5983) + (#xC8DF #x5E87) + (#xC8E0 #x5F7C) + (#xC8E1 #x60B2) + (#xC8E2 #x6249) + (#xC8E3 #x6279) + (#xC8E4 #x62AB) + (#xC8E5 #x6590) + (#xC8E6 #x6BD4) + (#xC8E7 #x6CCC) + (#xC8E8 #x75B2) + (#xC8E9 #x76AE) + (#xC8EA #x7891) + (#xC8EB #x79D8) + (#xC8EC #x7DCB) + (#xC8ED #x7F77) + (#xC8EE #x80A5) + (#xC8EF #x88AB) + (#xC8F0 #x8AB9) + (#xC8F1 #x8CBB) + (#xC8F2 #x907F) + (#xC8F3 #x975E) + (#xC8F4 #x98DB) + (#xC8F5 #x6A0B) + (#xC8F6 #x7C38) + (#xC8F7 #x5099) + (#xC8F8 #x5C3E) + (#xC8F9 #x5FAE) + (#xC8FA #x6787) + (#xC8FB #x6BD8) + (#xC8FC #x7435) + (#xC8FD #x7709) + (#xC8FE #x7F8E) + (#xC9A1 #x9F3B) + (#xC9A2 #x67CA) + (#xC9A3 #x7A17) + (#xC9A4 #x5339) + (#xC9A5 #x758B) + (#xC9A6 #x9AED) + (#xC9A7 #x5F66) + (#xC9A8 #x819D) + (#xC9A9 #x83F1) + (#xC9AA #x8098) + (#xC9AB #x5F3C) + (#xC9AC #x5FC5) + (#xC9AD #x7562) + (#xC9AE #x7B46) + (#xC9AF #x903C) + (#xC9B0 #x6867) + (#xC9B1 #x59EB) + (#xC9B2 #x5A9B) + (#xC9B3 #x7D10) + (#xC9B4 #x767E) + (#xC9B5 #x8B2C) + (#xC9B6 #x4FF5) + (#xC9B7 #x5F6A) + (#xC9B8 #x6A19) + (#xC9B9 #x6C37) + (#xC9BA #x6F02) + (#xC9BB #x74E2) + (#xC9BC #x7968) + (#xC9BD #x8868) + (#xC9BE #x8A55) + (#xC9BF #x8C79) + (#xC9C0 #x5EDF) + (#xC9C1 #x63CF) + (#xC9C2 #x75C5) + (#xC9C3 #x79D2) + (#xC9C4 #x82D7) + (#xC9C5 #x9328) + (#xC9C6 #x92F2) + (#xC9C7 #x849C) + (#xC9C8 #x86ED) + (#xC9C9 #x9C2D) + (#xC9CA #x54C1) + (#xC9CB #x5F6C) + (#xC9CC #x658C) + (#xC9CD #x6D5C) + (#xC9CE #x7015) + (#xC9CF #x8CA7) + (#xC9D0 #x8CD3) + (#xC9D1 #x983B) + (#xC9D2 #x654F) + (#xC9D3 #x74F6) + (#xC9D4 #x4E0D) + (#xC9D5 #x4ED8) + (#xC9D6 #x57E0) + (#xC9D7 #x592B) + (#xC9D8 #x5A66) + (#xC9D9 #x5BCC) + (#xC9DA #x51A8) + (#xC9DB #x5E03) + (#xC9DC #x5E9C) + (#xC9DD #x6016) + (#xC9DE #x6276) + (#xC9DF #x6577) + (#xC9E0 #x65A7) + (#xC9E1 #x666E) + (#xC9E2 #x6D6E) + (#xC9E3 #x7236) + (#xC9E4 #x7B26) + (#xC9E5 #x8150) + (#xC9E6 #x819A) + (#xC9E7 #x8299) + (#xC9E8 #x8B5C) + (#xC9E9 #x8CA0) + (#xC9EA #x8CE6) + (#xC9EB #x8D74) + (#xC9EC #x961C) + (#xC9ED #x9644) + (#xC9EE #x4FAE) + (#xC9EF #x64AB) + (#xC9F0 #x6B66) + (#xC9F1 #x821E) + (#xC9F2 #x8461) + (#xC9F3 #x856A) + (#xC9F4 #x90E8) + (#xC9F5 #x5C01) + (#xC9F6 #x6953) + (#xC9F7 #x98A8) + (#xC9F8 #x847A) + (#xC9F9 #x8557) + (#xC9FA #x4F0F) + (#xC9FB #x526F) + (#xC9FC #x5FA9) + (#xC9FD #x5E45) + (#xC9FE #x670D) + (#xCAA1 #x798F) + (#xCAA2 #x8179) + (#xCAA3 #x8907) + (#xCAA4 #x8986) + (#xCAA5 #x6DF5) + (#xCAA6 #x5F17) + (#xCAA7 #x6255) + (#xCAA8 #x6CB8) + (#xCAA9 #x4ECF) + (#xCAAA #x7269) + (#xCAAB #x9B92) + (#xCAAC #x5206) + (#xCAAD #x543B) + (#xCAAE #x5674) + (#xCAAF #x58B3) + (#xCAB0 #x61A4) + (#xCAB1 #x626E) + (#xCAB2 #x711A) + (#xCAB3 #x596E) + (#xCAB4 #x7C89) + (#xCAB5 #x7CDE) + (#xCAB6 #x7D1B) + (#xCAB7 #x96F0) + (#xCAB8 #x6587) + (#xCAB9 #x805E) + (#xCABA #x4E19) + (#xCABB #x4F75) + (#xCABC #x5175) + (#xCABD #x5840) + (#xCABE #x5E63) + (#xCABF #x5E73) + (#xCAC0 #x5F0A) + (#xCAC1 #x67C4) + (#xCAC2 #x4E26) + (#xCAC3 #x853D) + (#xCAC4 #x9589) + (#xCAC5 #x965B) + (#xCAC6 #x7C73) + (#xCAC7 #x9801) + (#xCAC8 #x50FB) + (#xCAC9 #x58C1) + (#xCACA #x7656) + (#xCACB #x78A7) + (#xCACC #x5225) + (#xCACD #x77A5) + (#xCACE #x8511) + (#xCACF #x7B86) + (#xCAD0 #x504F) + (#xCAD1 #x5909) + (#xCAD2 #x7247) + (#xCAD3 #x7BC7) + (#xCAD4 #x7DE8) + (#xCAD5 #x8FBA) + (#xCAD6 #x8FD4) + (#xCAD7 #x904D) + (#xCAD8 #x4FBF) + (#xCAD9 #x52C9) + (#xCADA #x5A29) + (#xCADB #x5F01) + (#xCADC #x97AD) + (#xCADD #x4FDD) + (#xCADE #x8217) + (#xCADF #x92EA) + (#xCAE0 #x5703) + (#xCAE1 #x6355) + (#xCAE2 #x6B69) + (#xCAE3 #x752B) + (#xCAE4 #x88DC) + (#xCAE5 #x8F14) + (#xCAE6 #x7A42) + (#xCAE7 #x52DF) + (#xCAE8 #x5893) + (#xCAE9 #x6155) + (#xCAEA #x620A) + (#xCAEB #x66AE) + (#xCAEC #x6BCD) + (#xCAED #x7C3F) + (#xCAEE #x83E9) + (#xCAEF #x5023) + (#xCAF0 #x4FF8) + (#xCAF1 #x5305) + (#xCAF2 #x5446) + (#xCAF3 #x5831) + (#xCAF4 #x5949) + (#xCAF5 #x5B9D) + (#xCAF6 #x5CF0) + (#xCAF7 #x5CEF) + (#xCAF8 #x5D29) + (#xCAF9 #x5E96) + (#xCAFA #x62B1) + (#xCAFB #x6367) + (#xCAFC #x653E) + (#xCAFD #x65B9) + (#xCAFE #x670B) + (#xCBA1 #x6CD5) + (#xCBA2 #x6CE1) + (#xCBA3 #x70F9) + (#xCBA4 #x7832) + (#xCBA5 #x7E2B) + (#xCBA6 #x80DE) + (#xCBA7 #x82B3) + (#xCBA8 #x840C) + (#xCBA9 #x84EC) + (#xCBAA #x8702) + (#xCBAB #x8912) + (#xCBAC #x8A2A) + (#xCBAD #x8C4A) + (#xCBAE #x90A6) + (#xCBAF #x92D2) + (#xCBB0 #x98FD) + (#xCBB1 #x9CF3) + (#xCBB2 #x9D6C) + (#xCBB3 #x4E4F) + (#xCBB4 #x4EA1) + (#xCBB5 #x508D) + (#xCBB6 #x5256) + (#xCBB7 #x574A) + (#xCBB8 #x59A8) + (#xCBB9 #x5E3D) + (#xCBBA #x5FD8) + (#xCBBB #x5FD9) + (#xCBBC #x623F) + (#xCBBD #x66B4) + (#xCBBE #x671B) + (#xCBBF #x67D0) + (#xCBC0 #x68D2) + (#xCBC1 #x5192) + (#xCBC2 #x7D21) + (#xCBC3 #x80AA) + (#xCBC4 #x81A8) + (#xCBC5 #x8B00) + (#xCBC6 #x8C8C) + (#xCBC7 #x8CBF) + (#xCBC8 #x927E) + (#xCBC9 #x9632) + (#xCBCA #x5420) + (#xCBCB #x982C) + (#xCBCC #x5317) + (#xCBCD #x50D5) + (#xCBCE #x535C) + (#xCBCF #x58A8) + (#xCBD0 #x64B2) + (#xCBD1 #x6734) + (#xCBD2 #x7267) + (#xCBD3 #x7766) + (#xCBD4 #x7A46) + (#xCBD5 #x91E6) + (#xCBD6 #x52C3) + (#xCBD7 #x6CA1) + (#xCBD8 #x6B86) + (#xCBD9 #x5800) + (#xCBDA #x5E4C) + (#xCBDB #x5954) + (#xCBDC #x672C) + (#xCBDD #x7FFB) + (#xCBDE #x51E1) + (#xCBDF #x76C6) + (#xCBE0 #x6469) + (#xCBE1 #x78E8) + (#xCBE2 #x9B54) + (#xCBE3 #x9EBB) + (#xCBE4 #x57CB) + (#xCBE5 #x59B9) + (#xCBE6 #x6627) + (#xCBE7 #x679A) + (#xCBE8 #x6BCE) + (#xCBE9 #x54E9) + (#xCBEA #x69D9) + (#xCBEB #x5E55) + (#xCBEC #x819C) + (#xCBED #x6795) + (#xCBEE #x9BAA) + (#xCBEF #x67FE) + (#xCBF0 #x9C52) + (#xCBF1 #x685D) + (#xCBF2 #x4EA6) + (#xCBF3 #x4FE3) + (#xCBF4 #x53C8) + (#xCBF5 #x62B9) + (#xCBF6 #x672B) + (#xCBF7 #x6CAB) + (#xCBF8 #x8FC4) + (#xCBF9 #x4FAD) + (#xCBFA #x7E6D) + (#xCBFB #x9EBF) + (#xCBFC #x4E07) + (#xCBFD #x6162) + (#xCBFE #x6E80) + (#xCCA1 #x6F2B) + (#xCCA2 #x8513) + (#xCCA3 #x5473) + (#xCCA4 #x672A) + (#xCCA5 #x9B45) + (#xCCA6 #x5DF3) + (#xCCA7 #x7B95) + (#xCCA8 #x5CAC) + (#xCCA9 #x5BC6) + (#xCCAA #x871C) + (#xCCAB #x6E4A) + (#xCCAC #x84D1) + (#xCCAD #x7A14) + (#xCCAE #x8108) + (#xCCAF #x5999) + (#xCCB0 #x7C8D) + (#xCCB1 #x6C11) + (#xCCB2 #x7720) + (#xCCB3 #x52D9) + (#xCCB4 #x5922) + (#xCCB5 #x7121) + (#xCCB6 #x725F) + (#xCCB7 #x77DB) + (#xCCB8 #x9727) + (#xCCB9 #x9D61) + (#xCCBA #x690B) + (#xCCBB #x5A7F) + (#xCCBC #x5A18) + (#xCCBD #x51A5) + (#xCCBE #x540D) + (#xCCBF #x547D) + (#xCCC0 #x660E) + (#xCCC1 #x76DF) + (#xCCC2 #x8FF7) + (#xCCC3 #x9298) + (#xCCC4 #x9CF4) + (#xCCC5 #x59EA) + (#xCCC6 #x725D) + (#xCCC7 #x6EC5) + (#xCCC8 #x514D) + (#xCCC9 #x68C9) + (#xCCCA #x7DBF) + (#xCCCB #x7DEC) + (#xCCCC #x9762) + (#xCCCD #x9EBA) + (#xCCCE #x6478) + (#xCCCF #x6A21) + (#xCCD0 #x8302) + (#xCCD1 #x5984) + (#xCCD2 #x5B5F) + (#xCCD3 #x6BDB) + (#xCCD4 #x731B) + (#xCCD5 #x76F2) + (#xCCD6 #x7DB2) + (#xCCD7 #x8017) + (#xCCD8 #x8499) + (#xCCD9 #x5132) + (#xCCDA #x6728) + (#xCCDB #x9ED9) + (#xCCDC #x76EE) + (#xCCDD #x6762) + (#xCCDE #x52FF) + (#xCCDF #x9905) + (#xCCE0 #x5C24) + (#xCCE1 #x623B) + (#xCCE2 #x7C7E) + (#xCCE3 #x8CB0) + (#xCCE4 #x554F) + (#xCCE5 #x60B6) + (#xCCE6 #x7D0B) + (#xCCE7 #x9580) + (#xCCE8 #x5301) + (#xCCE9 #x4E5F) + (#xCCEA #x51B6) + (#xCCEB #x591C) + (#xCCEC #x723A) + (#xCCED #x8036) + (#xCCEE #x91CE) + (#xCCEF #x5F25) + (#xCCF0 #x77E2) + (#xCCF1 #x5384) + (#xCCF2 #x5F79) + (#xCCF3 #x7D04) + (#xCCF4 #x85AC) + (#xCCF5 #x8A33) + (#xCCF6 #x8E8D) + (#xCCF7 #x9756) + (#xCCF8 #x67F3) + (#xCCF9 #x85AE) + (#xCCFA #x9453) + (#xCCFB #x6109) + (#xCCFC #x6108) + (#xCCFD #x6CB9) + (#xCCFE #x7652) + (#xCDA1 #x8AED) + (#xCDA2 #x8F38) + (#xCDA3 #x552F) + (#xCDA4 #x4F51) + (#xCDA5 #x512A) + (#xCDA6 #x52C7) + (#xCDA7 #x53CB) + (#xCDA8 #x5BA5) + (#xCDA9 #x5E7D) + (#xCDAA #x60A0) + (#xCDAB #x6182) + (#xCDAC #x63D6) + (#xCDAD #x6709) + (#xCDAE #x67DA) + (#xCDAF #x6E67) + (#xCDB0 #x6D8C) + (#xCDB1 #x7336) + (#xCDB2 #x7337) + (#xCDB3 #x7531) + (#xCDB4 #x7950) + (#xCDB5 #x88D5) + (#xCDB6 #x8A98) + (#xCDB7 #x904A) + (#xCDB8 #x9091) + (#xCDB9 #x90F5) + (#xCDBA #x96C4) + (#xCDBB #x878D) + (#xCDBC #x5915) + (#xCDBD #x4E88) + (#xCDBE #x4F59) + (#xCDBF #x4E0E) + (#xCDC0 #x8A89) + (#xCDC1 #x8F3F) + (#xCDC2 #x9810) + (#xCDC3 #x50AD) + (#xCDC4 #x5E7C) + (#xCDC5 #x5996) + (#xCDC6 #x5BB9) + (#xCDC7 #x5EB8) + (#xCDC8 #x63DA) + (#xCDC9 #x63FA) + (#xCDCA #x64C1) + (#xCDCB #x66DC) + (#xCDCC #x694A) + (#xCDCD #x69D8) + (#xCDCE #x6D0B) + (#xCDCF #x6EB6) + (#xCDD0 #x7194) + (#xCDD1 #x7528) + (#xCDD2 #x7AAF) + (#xCDD3 #x7F8A) + (#xCDD4 #x8000) + (#xCDD5 #x8449) + (#xCDD6 #x84C9) + (#xCDD7 #x8981) + (#xCDD8 #x8B21) + (#xCDD9 #x8E0A) + (#xCDDA #x9065) + (#xCDDB #x967D) + (#xCDDC #x990A) + (#xCDDD #x617E) + (#xCDDE #x6291) + (#xCDDF #x6B32) + (#xCDE0 #x6C83) + (#xCDE1 #x6D74) + (#xCDE2 #x7FCC) + (#xCDE3 #x7FFC) + (#xCDE4 #x6DC0) + (#xCDE5 #x7F85) + (#xCDE6 #x87BA) + (#xCDE7 #x88F8) + (#xCDE8 #x6765) + (#xCDE9 #x83B1) + (#xCDEA #x983C) + (#xCDEB #x96F7) + (#xCDEC #x6D1B) + (#xCDED #x7D61) + (#xCDEE #x843D) + (#xCDEF #x916A) + (#xCDF0 #x4E71) + (#xCDF1 #x5375) + (#xCDF2 #x5D50) + (#xCDF3 #x6B04) + (#xCDF4 #x6FEB) + (#xCDF5 #x85CD) + (#xCDF6 #x862D) + (#xCDF7 #x89A7) + (#xCDF8 #x5229) + (#xCDF9 #x540F) + (#xCDFA #x5C65) + (#xCDFB #x674E) + (#xCDFC #x68A8) + (#xCDFD #x7406) + (#xCDFE #x7483) + (#xCEA1 #x75E2) + (#xCEA2 #x88CF) + (#xCEA3 #x88E1) + (#xCEA4 #x91CC) + (#xCEA5 #x96E2) + (#xCEA6 #x9678) + (#xCEA7 #x5F8B) + (#xCEA8 #x7387) + (#xCEA9 #x7ACB) + (#xCEAA #x844E) + (#xCEAB #x63A0) + (#xCEAC #x7565) + (#xCEAD #x5289) + (#xCEAE #x6D41) + (#xCEAF #x6E9C) + (#xCEB0 #x7409) + (#xCEB1 #x7559) + (#xCEB2 #x786B) + (#xCEB3 #x7C92) + (#xCEB4 #x9686) + (#xCEB5 #x7ADC) + (#xCEB6 #x9F8D) + (#xCEB7 #x4FB6) + (#xCEB8 #x616E) + (#xCEB9 #x65C5) + (#xCEBA #x865C) + (#xCEBB #x4E86) + (#xCEBC #x4EAE) + (#xCEBD #x50DA) + (#xCEBE #x4E21) + (#xCEBF #x51CC) + (#xCEC0 #x5BEE) + (#xCEC1 #x6599) + (#xCEC2 #x6881) + (#xCEC3 #x6DBC) + (#xCEC4 #x731F) + (#xCEC5 #x7642) + (#xCEC6 #x77AD) + (#xCEC7 #x7A1C) + (#xCEC8 #x7CE7) + (#xCEC9 #x826F) + (#xCECA #x8AD2) + (#xCECB #x907C) + (#xCECC #x91CF) + (#xCECD #x9675) + (#xCECE #x9818) + (#xCECF #x529B) + (#xCED0 #x7DD1) + (#xCED1 #x502B) + (#xCED2 #x5398) + (#xCED3 #x6797) + (#xCED4 #x6DCB) + (#xCED5 #x71D0) + (#xCED6 #x7433) + (#xCED7 #x81E8) + (#xCED8 #x8F2A) + (#xCED9 #x96A3) + (#xCEDA #x9C57) + (#xCEDB #x9E9F) + (#xCEDC #x7460) + (#xCEDD #x5841) + (#xCEDE #x6D99) + (#xCEDF #x7D2F) + (#xCEE0 #x985E) + (#xCEE1 #x4EE4) + (#xCEE2 #x4F36) + (#xCEE3 #x4F8B) + (#xCEE4 #x51B7) + (#xCEE5 #x52B1) + (#xCEE6 #x5DBA) + (#xCEE7 #x601C) + (#xCEE8 #x73B2) + (#xCEE9 #x793C) + (#xCEEA #x82D3) + (#xCEEB #x9234) + (#xCEEC #x96B7) + (#xCEED #x96F6) + (#xCEEE #x970A) + (#xCEEF #x9E97) + (#xCEF0 #x9F62) + (#xCEF1 #x66A6) + (#xCEF2 #x6B74) + (#xCEF3 #x5217) + (#xCEF4 #x52A3) + (#xCEF5 #x70C8) + (#xCEF6 #x88C2) + (#xCEF7 #x5EC9) + (#xCEF8 #x604B) + (#xCEF9 #x6190) + (#xCEFA #x6F23) + (#xCEFB #x7149) + (#xCEFC #x7C3E) + (#xCEFD #x7DF4) + (#xCEFE #x806F) + (#xCFA1 #x84EE) + (#xCFA2 #x9023) + (#xCFA3 #x932C) + (#xCFA4 #x5442) + (#xCFA5 #x9B6F) + (#xCFA6 #x6AD3) + (#xCFA7 #x7089) + (#xCFA8 #x8CC2) + (#xCFA9 #x8DEF) + (#xCFAA #x9732) + (#xCFAB #x52B4) + (#xCFAC #x5A41) + (#xCFAD #x5ECA) + (#xCFAE #x5F04) + (#xCFAF #x6717) + (#xCFB0 #x697C) + (#xCFB1 #x6994) + (#xCFB2 #x6D6A) + (#xCFB3 #x6F0F) + (#xCFB4 #x7262) + (#xCFB5 #x72FC) + (#xCFB6 #x7BED) + (#xCFB7 #x8001) + (#xCFB8 #x807E) + (#xCFB9 #x874B) + (#xCFBA #x90CE) + (#xCFBB #x516D) + (#xCFBC #x9E93) + (#xCFBD #x7984) + (#xCFBE #x808B) + (#xCFBF #x9332) + (#xCFC0 #x8AD6) + (#xCFC1 #x502D) + (#xCFC2 #x548C) + (#xCFC3 #x8A71) + (#xCFC4 #x6B6A) + (#xCFC5 #x8CC4) + (#xCFC6 #x8107) + (#xCFC7 #x60D1) + (#xCFC8 #x67A0) + (#xCFC9 #x9DF2) + (#xCFCA #x4E99) + (#xCFCB #x4E98) + (#xCFCC #x9C10) + (#xCFCD #x8A6B) + (#xCFCE #x85C1) + (#xCFCF #x8568) + (#xCFD0 #x6900) + (#xCFD1 #x6E7E) + (#xCFD2 #x7897) + (#xCFD3 #x8155) + (#xD0A1 #x5F0C) + (#xD0A2 #x4E10) + (#xD0A3 #x4E15) + (#xD0A4 #x4E2A) + (#xD0A5 #x4E31) + (#xD0A6 #x4E36) + (#xD0A7 #x4E3C) + (#xD0A8 #x4E3F) + (#xD0A9 #x4E42) + (#xD0AA #x4E56) + (#xD0AB #x4E58) + (#xD0AC #x4E82) + (#xD0AD #x4E85) + (#xD0AE #x8C6B) + (#xD0AF #x4E8A) + (#xD0B0 #x8212) + (#xD0B1 #x5F0D) + (#xD0B2 #x4E8E) + (#xD0B3 #x4E9E) + (#xD0B4 #x4E9F) + (#xD0B5 #x4EA0) + (#xD0B6 #x4EA2) + (#xD0B7 #x4EB0) + (#xD0B8 #x4EB3) + (#xD0B9 #x4EB6) + (#xD0BA #x4ECE) + (#xD0BB #x4ECD) + (#xD0BC #x4EC4) + (#xD0BD #x4EC6) + (#xD0BE #x4EC2) + (#xD0BF #x4ED7) + (#xD0C0 #x4EDE) + (#xD0C1 #x4EED) + (#xD0C2 #x4EDF) + (#xD0C3 #x4EF7) + (#xD0C4 #x4F09) + (#xD0C5 #x4F5A) + (#xD0C6 #x4F30) + (#xD0C7 #x4F5B) + (#xD0C8 #x4F5D) + (#xD0C9 #x4F57) + (#xD0CA #x4F47) + (#xD0CB #x4F76) + (#xD0CC #x4F88) + (#xD0CD #x4F8F) + (#xD0CE #x4F98) + (#xD0CF #x4F7B) + (#xD0D0 #x4F69) + (#xD0D1 #x4F70) + (#xD0D2 #x4F91) + (#xD0D3 #x4F6F) + (#xD0D4 #x4F86) + (#xD0D5 #x4F96) + (#xD0D6 #x5118) + (#xD0D7 #x4FD4) + (#xD0D8 #x4FDF) + (#xD0D9 #x4FCE) + (#xD0DA #x4FD8) + (#xD0DB #x4FDB) + (#xD0DC #x4FD1) + (#xD0DD #x4FDA) + (#xD0DE #x4FD0) + (#xD0DF #x4FE4) + (#xD0E0 #x4FE5) + (#xD0E1 #x501A) + (#xD0E2 #x5028) + (#xD0E3 #x5014) + (#xD0E4 #x502A) + (#xD0E5 #x5025) + (#xD0E6 #x5005) + (#xD0E7 #x4F1C) + (#xD0E8 #x4FF6) + (#xD0E9 #x5021) + (#xD0EA #x5029) + (#xD0EB #x502C) + (#xD0EC #x4FFE) + (#xD0ED #x4FEF) + (#xD0EE #x5011) + (#xD0EF #x5006) + (#xD0F0 #x5043) + (#xD0F1 #x5047) + (#xD0F2 #x6703) + (#xD0F3 #x5055) + (#xD0F4 #x5050) + (#xD0F5 #x5048) + (#xD0F6 #x505A) + (#xD0F7 #x5056) + (#xD0F8 #x506C) + (#xD0F9 #x5078) + (#xD0FA #x5080) + (#xD0FB #x509A) + (#xD0FC #x5085) + (#xD0FD #x50B4) + (#xD0FE #x50B2) + (#xD1A1 #x50C9) + (#xD1A2 #x50CA) + (#xD1A3 #x50B3) + (#xD1A4 #x50C2) + (#xD1A5 #x50D6) + (#xD1A6 #x50DE) + (#xD1A7 #x50E5) + (#xD1A8 #x50ED) + (#xD1A9 #x50E3) + (#xD1AA #x50EE) + (#xD1AB #x50F9) + (#xD1AC #x50F5) + (#xD1AD #x5109) + (#xD1AE #x5101) + (#xD1AF #x5102) + (#xD1B0 #x5116) + (#xD1B1 #x5115) + (#xD1B2 #x5114) + (#xD1B3 #x511A) + (#xD1B4 #x5121) + (#xD1B5 #x513A) + (#xD1B6 #x5137) + (#xD1B7 #x513C) + (#xD1B8 #x513B) + (#xD1B9 #x513F) + (#xD1BA #x5140) + (#xD1BB #x5152) + (#xD1BC #x514C) + (#xD1BD #x5154) + (#xD1BE #x5162) + (#xD1BF #x7AF8) + (#xD1C0 #x5169) + (#xD1C1 #x516A) + (#xD1C2 #x516E) + (#xD1C3 #x5180) + (#xD1C4 #x5182) + (#xD1C5 #x56D8) + (#xD1C6 #x518C) + (#xD1C7 #x5189) + (#xD1C8 #x518F) + (#xD1C9 #x5191) + (#xD1CA #x5193) + (#xD1CB #x5195) + (#xD1CC #x5196) + (#xD1CD #x51A4) + (#xD1CE #x51A6) + (#xD1CF #x51A2) + (#xD1D0 #x51A9) + (#xD1D1 #x51AA) + (#xD1D2 #x51AB) + (#xD1D3 #x51B3) + (#xD1D4 #x51B1) + (#xD1D5 #x51B2) + (#xD1D6 #x51B0) + (#xD1D7 #x51B5) + (#xD1D8 #x51BD) + (#xD1D9 #x51C5) + (#xD1DA #x51C9) + (#xD1DB #x51DB) + (#xD1DC #x51E0) + (#xD1DD #x8655) + (#xD1DE #x51E9) + (#xD1DF #x51ED) + (#xD1E0 #x51F0) + (#xD1E1 #x51F5) + (#xD1E2 #x51FE) + (#xD1E3 #x5204) + (#xD1E4 #x520B) + (#xD1E5 #x5214) + (#xD1E6 #x520E) + (#xD1E7 #x5227) + (#xD1E8 #x522A) + (#xD1E9 #x522E) + (#xD1EA #x5233) + (#xD1EB #x5239) + (#xD1EC #x524F) + (#xD1ED #x5244) + (#xD1EE #x524B) + (#xD1EF #x524C) + (#xD1F0 #x525E) + (#xD1F1 #x5254) + (#xD1F2 #x526A) + (#xD1F3 #x5274) + (#xD1F4 #x5269) + (#xD1F5 #x5273) + (#xD1F6 #x527F) + (#xD1F7 #x527D) + (#xD1F8 #x528D) + (#xD1F9 #x5294) + (#xD1FA #x5292) + (#xD1FB #x5271) + (#xD1FC #x5288) + (#xD1FD #x5291) + (#xD1FE #x8FA8) + (#xD2A1 #x8FA7) + (#xD2A2 #x52AC) + (#xD2A3 #x52AD) + (#xD2A4 #x52BC) + (#xD2A5 #x52B5) + (#xD2A6 #x52C1) + (#xD2A7 #x52CD) + (#xD2A8 #x52D7) + (#xD2A9 #x52DE) + (#xD2AA #x52E3) + (#xD2AB #x52E6) + (#xD2AC #x98ED) + (#xD2AD #x52E0) + (#xD2AE #x52F3) + (#xD2AF #x52F5) + (#xD2B0 #x52F8) + (#xD2B1 #x52F9) + (#xD2B2 #x5306) + (#xD2B3 #x5308) + (#xD2B4 #x7538) + (#xD2B5 #x530D) + (#xD2B6 #x5310) + (#xD2B7 #x530F) + (#xD2B8 #x5315) + (#xD2B9 #x531A) + (#xD2BA #x5323) + (#xD2BB #x532F) + (#xD2BC #x5331) + (#xD2BD #x5333) + (#xD2BE #x5338) + (#xD2BF #x5340) + (#xD2C0 #x5346) + (#xD2C1 #x5345) + (#xD2C2 #x4E17) + (#xD2C3 #x5349) + (#xD2C4 #x534D) + (#xD2C5 #x51D6) + (#xD2C6 #x535E) + (#xD2C7 #x5369) + (#xD2C8 #x536E) + (#xD2C9 #x5918) + (#xD2CA #x537B) + (#xD2CB #x5377) + (#xD2CC #x5382) + (#xD2CD #x5396) + (#xD2CE #x53A0) + (#xD2CF #x53A6) + (#xD2D0 #x53A5) + (#xD2D1 #x53AE) + (#xD2D2 #x53B0) + (#xD2D3 #x53B6) + (#xD2D4 #x53C3) + (#xD2D5 #x7C12) + (#xD2D6 #x96D9) + (#xD2D7 #x53DF) + (#xD2D8 #x66FC) + (#xD2D9 #x71EE) + (#xD2DA #x53EE) + (#xD2DB #x53E8) + (#xD2DC #x53ED) + (#xD2DD #x53FA) + (#xD2DE #x5401) + (#xD2DF #x543D) + (#xD2E0 #x5440) + (#xD2E1 #x542C) + (#xD2E2 #x542D) + (#xD2E3 #x543C) + (#xD2E4 #x542E) + (#xD2E5 #x5436) + (#xD2E6 #x5429) + (#xD2E7 #x541D) + (#xD2E8 #x544E) + (#xD2E9 #x548F) + (#xD2EA #x5475) + (#xD2EB #x548E) + (#xD2EC #x545F) + (#xD2ED #x5471) + (#xD2EE #x5477) + (#xD2EF #x5470) + (#xD2F0 #x5492) + (#xD2F1 #x547B) + (#xD2F2 #x5480) + (#xD2F3 #x5476) + (#xD2F4 #x5484) + (#xD2F5 #x5490) + (#xD2F6 #x5486) + (#xD2F7 #x54C7) + (#xD2F8 #x54A2) + (#xD2F9 #x54B8) + (#xD2FA #x54A5) + (#xD2FB #x54AC) + (#xD2FC #x54C4) + (#xD2FD #x54C8) + (#xD2FE #x54A8) + (#xD3A1 #x54AB) + (#xD3A2 #x54C2) + (#xD3A3 #x54A4) + (#xD3A4 #x54BE) + (#xD3A5 #x54BC) + (#xD3A6 #x54D8) + (#xD3A7 #x54E5) + (#xD3A8 #x54E6) + (#xD3A9 #x550F) + (#xD3AA #x5514) + (#xD3AB #x54FD) + (#xD3AC #x54EE) + (#xD3AD #x54ED) + (#xD3AE #x54FA) + (#xD3AF #x54E2) + (#xD3B0 #x5539) + (#xD3B1 #x5540) + (#xD3B2 #x5563) + (#xD3B3 #x554C) + (#xD3B4 #x552E) + (#xD3B5 #x555C) + (#xD3B6 #x5545) + (#xD3B7 #x5556) + (#xD3B8 #x5557) + (#xD3B9 #x5538) + (#xD3BA #x5533) + (#xD3BB #x555D) + (#xD3BC #x5599) + (#xD3BD #x5580) + (#xD3BE #x54AF) + (#xD3BF #x558A) + (#xD3C0 #x559F) + (#xD3C1 #x557B) + (#xD3C2 #x557E) + (#xD3C3 #x5598) + (#xD3C4 #x559E) + (#xD3C5 #x55AE) + (#xD3C6 #x557C) + (#xD3C7 #x5583) + (#xD3C8 #x55A9) + (#xD3C9 #x5587) + (#xD3CA #x55A8) + (#xD3CB #x55DA) + (#xD3CC #x55C5) + (#xD3CD #x55DF) + (#xD3CE #x55C4) + (#xD3CF #x55DC) + (#xD3D0 #x55E4) + (#xD3D1 #x55D4) + (#xD3D2 #x5614) + (#xD3D3 #x55F7) + (#xD3D4 #x5616) + (#xD3D5 #x55FE) + (#xD3D6 #x55FD) + (#xD3D7 #x561B) + (#xD3D8 #x55F9) + (#xD3D9 #x564E) + (#xD3DA #x5650) + (#xD3DB #x71DF) + (#xD3DC #x5634) + (#xD3DD #x5636) + (#xD3DE #x5632) + (#xD3DF #x5638) + (#xD3E0 #x566B) + (#xD3E1 #x5664) + (#xD3E2 #x562F) + (#xD3E3 #x566C) + (#xD3E4 #x566A) + (#xD3E5 #x5686) + (#xD3E6 #x5680) + (#xD3E7 #x568A) + (#xD3E8 #x56A0) + (#xD3E9 #x5694) + (#xD3EA #x568F) + (#xD3EB #x56A5) + (#xD3EC #x56AE) + (#xD3ED #x56B6) + (#xD3EE #x56B4) + (#xD3EF #x56C2) + (#xD3F0 #x56BC) + (#xD3F1 #x56C1) + (#xD3F2 #x56C3) + (#xD3F3 #x56C0) + (#xD3F4 #x56C8) + (#xD3F5 #x56CE) + (#xD3F6 #x56D1) + (#xD3F7 #x56D3) + (#xD3F8 #x56D7) + (#xD3F9 #x56EE) + (#xD3FA #x56F9) + (#xD3FB #x5700) + (#xD3FC #x56FF) + (#xD3FD #x5704) + (#xD3FE #x5709) + (#xD4A1 #x5708) + (#xD4A2 #x570B) + (#xD4A3 #x570D) + (#xD4A4 #x5713) + (#xD4A5 #x5718) + (#xD4A6 #x5716) + (#xD4A7 #x55C7) + (#xD4A8 #x571C) + (#xD4A9 #x5726) + (#xD4AA #x5737) + (#xD4AB #x5738) + (#xD4AC #x574E) + (#xD4AD #x573B) + (#xD4AE #x5740) + (#xD4AF #x574F) + (#xD4B0 #x5769) + (#xD4B1 #x57C0) + (#xD4B2 #x5788) + (#xD4B3 #x5761) + (#xD4B4 #x577F) + (#xD4B5 #x5789) + (#xD4B6 #x5793) + (#xD4B7 #x57A0) + (#xD4B8 #x57B3) + (#xD4B9 #x57A4) + (#xD4BA #x57AA) + (#xD4BB #x57B0) + (#xD4BC #x57C3) + (#xD4BD #x57C6) + (#xD4BE #x57D4) + (#xD4BF #x57D2) + (#xD4C0 #x57D3) + (#xD4C1 #x580A) + (#xD4C2 #x57D6) + (#xD4C3 #x57E3) + (#xD4C4 #x580B) + (#xD4C5 #x5819) + (#xD4C6 #x581D) + (#xD4C7 #x5872) + (#xD4C8 #x5821) + (#xD4C9 #x5862) + (#xD4CA #x584B) + (#xD4CB #x5870) + (#xD4CC #x6BC0) + (#xD4CD #x5852) + (#xD4CE #x583D) + (#xD4CF #x5879) + (#xD4D0 #x5885) + (#xD4D1 #x58B9) + (#xD4D2 #x589F) + (#xD4D3 #x58AB) + (#xD4D4 #x58BA) + (#xD4D5 #x58DE) + (#xD4D6 #x58BB) + (#xD4D7 #x58B8) + (#xD4D8 #x58AE) + (#xD4D9 #x58C5) + (#xD4DA #x58D3) + (#xD4DB #x58D1) + (#xD4DC #x58D7) + (#xD4DD #x58D9) + (#xD4DE #x58D8) + (#xD4DF #x58E5) + (#xD4E0 #x58DC) + (#xD4E1 #x58E4) + (#xD4E2 #x58DF) + (#xD4E3 #x58EF) + (#xD4E4 #x58FA) + (#xD4E5 #x58F9) + (#xD4E6 #x58FB) + (#xD4E7 #x58FC) + (#xD4E8 #x58FD) + (#xD4E9 #x5902) + (#xD4EA #x590A) + (#xD4EB #x5910) + (#xD4EC #x591B) + (#xD4ED #x68A6) + (#xD4EE #x5925) + (#xD4EF #x592C) + (#xD4F0 #x592D) + (#xD4F1 #x5932) + (#xD4F2 #x5938) + (#xD4F3 #x593E) + (#xD4F4 #x7AD2) + (#xD4F5 #x5955) + (#xD4F6 #x5950) + (#xD4F7 #x594E) + (#xD4F8 #x595A) + (#xD4F9 #x5958) + (#xD4FA #x5962) + (#xD4FB #x5960) + (#xD4FC #x5967) + (#xD4FD #x596C) + (#xD4FE #x5969) + (#xD5A1 #x5978) + (#xD5A2 #x5981) + (#xD5A3 #x599D) + (#xD5A4 #x4F5E) + (#xD5A5 #x4FAB) + (#xD5A6 #x59A3) + (#xD5A7 #x59B2) + (#xD5A8 #x59C6) + (#xD5A9 #x59E8) + (#xD5AA #x59DC) + (#xD5AB #x598D) + (#xD5AC #x59D9) + (#xD5AD #x59DA) + (#xD5AE #x5A25) + (#xD5AF #x5A1F) + (#xD5B0 #x5A11) + (#xD5B1 #x5A1C) + (#xD5B2 #x5A09) + (#xD5B3 #x5A1A) + (#xD5B4 #x5A40) + (#xD5B5 #x5A6C) + (#xD5B6 #x5A49) + (#xD5B7 #x5A35) + (#xD5B8 #x5A36) + (#xD5B9 #x5A62) + (#xD5BA #x5A6A) + (#xD5BB #x5A9A) + (#xD5BC #x5ABC) + (#xD5BD #x5ABE) + (#xD5BE #x5ACB) + (#xD5BF #x5AC2) + (#xD5C0 #x5ABD) + (#xD5C1 #x5AE3) + (#xD5C2 #x5AD7) + (#xD5C3 #x5AE6) + (#xD5C4 #x5AE9) + (#xD5C5 #x5AD6) + (#xD5C6 #x5AFA) + (#xD5C7 #x5AFB) + (#xD5C8 #x5B0C) + (#xD5C9 #x5B0B) + (#xD5CA #x5B16) + (#xD5CB #x5B32) + (#xD5CC #x5AD0) + (#xD5CD #x5B2A) + (#xD5CE #x5B36) + (#xD5CF #x5B3E) + (#xD5D0 #x5B43) + (#xD5D1 #x5B45) + (#xD5D2 #x5B40) + (#xD5D3 #x5B51) + (#xD5D4 #x5B55) + (#xD5D5 #x5B5A) + (#xD5D6 #x5B5B) + (#xD5D7 #x5B65) + (#xD5D8 #x5B69) + (#xD5D9 #x5B70) + (#xD5DA #x5B73) + (#xD5DB #x5B75) + (#xD5DC #x5B78) + (#xD5DD #x6588) + (#xD5DE #x5B7A) + (#xD5DF #x5B80) + (#xD5E0 #x5B83) + (#xD5E1 #x5BA6) + (#xD5E2 #x5BB8) + (#xD5E3 #x5BC3) + (#xD5E4 #x5BC7) + (#xD5E5 #x5BC9) + (#xD5E6 #x5BD4) + (#xD5E7 #x5BD0) + (#xD5E8 #x5BE4) + (#xD5E9 #x5BE6) + (#xD5EA #x5BE2) + (#xD5EB #x5BDE) + (#xD5EC #x5BE5) + (#xD5ED #x5BEB) + (#xD5EE #x5BF0) + (#xD5EF #x5BF6) + (#xD5F0 #x5BF3) + (#xD5F1 #x5C05) + (#xD5F2 #x5C07) + (#xD5F3 #x5C08) + (#xD5F4 #x5C0D) + (#xD5F5 #x5C13) + (#xD5F6 #x5C20) + (#xD5F7 #x5C22) + (#xD5F8 #x5C28) + (#xD5F9 #x5C38) + (#xD5FA #x5C39) + (#xD5FB #x5C41) + (#xD5FC #x5C46) + (#xD5FD #x5C4E) + (#xD5FE #x5C53) + (#xD6A1 #x5C50) + (#xD6A2 #x5C4F) + (#xD6A3 #x5B71) + (#xD6A4 #x5C6C) + (#xD6A5 #x5C6E) + (#xD6A6 #x4E62) + (#xD6A7 #x5C76) + (#xD6A8 #x5C79) + (#xD6A9 #x5C8C) + (#xD6AA #x5C91) + (#xD6AB #x5C94) + (#xD6AC #x599B) + (#xD6AD #x5CAB) + (#xD6AE #x5CBB) + (#xD6AF #x5CB6) + (#xD6B0 #x5CBC) + (#xD6B1 #x5CB7) + (#xD6B2 #x5CC5) + (#xD6B3 #x5CBE) + (#xD6B4 #x5CC7) + (#xD6B5 #x5CD9) + (#xD6B6 #x5CE9) + (#xD6B7 #x5CFD) + (#xD6B8 #x5CFA) + (#xD6B9 #x5CED) + (#xD6BA #x5D8C) + (#xD6BB #x5CEA) + (#xD6BC #x5D0B) + (#xD6BD #x5D15) + (#xD6BE #x5D17) + (#xD6BF #x5D5C) + (#xD6C0 #x5D1F) + (#xD6C1 #x5D1B) + (#xD6C2 #x5D11) + (#xD6C3 #x5D14) + (#xD6C4 #x5D22) + (#xD6C5 #x5D1A) + (#xD6C6 #x5D19) + (#xD6C7 #x5D18) + (#xD6C8 #x5D4C) + (#xD6C9 #x5D52) + (#xD6CA #x5D4E) + (#xD6CB #x5D4B) + (#xD6CC #x5D6C) + (#xD6CD #x5D73) + (#xD6CE #x5D76) + (#xD6CF #x5D87) + (#xD6D0 #x5D84) + (#xD6D1 #x5D82) + (#xD6D2 #x5DA2) + (#xD6D3 #x5D9D) + (#xD6D4 #x5DAC) + (#xD6D5 #x5DAE) + (#xD6D6 #x5DBD) + (#xD6D7 #x5D90) + (#xD6D8 #x5DB7) + (#xD6D9 #x5DBC) + (#xD6DA #x5DC9) + (#xD6DB #x5DCD) + (#xD6DC #x5DD3) + (#xD6DD #x5DD2) + (#xD6DE #x5DD6) + (#xD6DF #x5DDB) + (#xD6E0 #x5DEB) + (#xD6E1 #x5DF2) + (#xD6E2 #x5DF5) + (#xD6E3 #x5E0B) + (#xD6E4 #x5E1A) + (#xD6E5 #x5E19) + (#xD6E6 #x5E11) + (#xD6E7 #x5E1B) + (#xD6E8 #x5E36) + (#xD6E9 #x5E37) + (#xD6EA #x5E44) + (#xD6EB #x5E43) + (#xD6EC #x5E40) + (#xD6ED #x5E4E) + (#xD6EE #x5E57) + (#xD6EF #x5E54) + (#xD6F0 #x5E5F) + (#xD6F1 #x5E62) + (#xD6F2 #x5E64) + (#xD6F3 #x5E47) + (#xD6F4 #x5E75) + (#xD6F5 #x5E76) + (#xD6F6 #x5E7A) + (#xD6F7 #x9EBC) + (#xD6F8 #x5E7F) + (#xD6F9 #x5EA0) + (#xD6FA #x5EC1) + (#xD6FB #x5EC2) + (#xD6FC #x5EC8) + (#xD6FD #x5ED0) + (#xD6FE #x5ECF) + (#xD7A1 #x5ED6) + (#xD7A2 #x5EE3) + (#xD7A3 #x5EDD) + (#xD7A4 #x5EDA) + (#xD7A5 #x5EDB) + (#xD7A6 #x5EE2) + (#xD7A7 #x5EE1) + (#xD7A8 #x5EE8) + (#xD7A9 #x5EE9) + (#xD7AA #x5EEC) + (#xD7AB #x5EF1) + (#xD7AC #x5EF3) + (#xD7AD #x5EF0) + (#xD7AE #x5EF4) + (#xD7AF #x5EF8) + (#xD7B0 #x5EFE) + (#xD7B1 #x5F03) + (#xD7B2 #x5F09) + (#xD7B3 #x5F5D) + (#xD7B4 #x5F5C) + (#xD7B5 #x5F0B) + (#xD7B6 #x5F11) + (#xD7B7 #x5F16) + (#xD7B8 #x5F29) + (#xD7B9 #x5F2D) + (#xD7BA #x5F38) + (#xD7BB #x5F41) + (#xD7BC #x5F48) + (#xD7BD #x5F4C) + (#xD7BE #x5F4E) + (#xD7BF #x5F2F) + (#xD7C0 #x5F51) + (#xD7C1 #x5F56) + (#xD7C2 #x5F57) + (#xD7C3 #x5F59) + (#xD7C4 #x5F61) + (#xD7C5 #x5F6D) + (#xD7C6 #x5F73) + (#xD7C7 #x5F77) + (#xD7C8 #x5F83) + (#xD7C9 #x5F82) + (#xD7CA #x5F7F) + (#xD7CB #x5F8A) + (#xD7CC #x5F88) + (#xD7CD #x5F91) + (#xD7CE #x5F87) + (#xD7CF #x5F9E) + (#xD7D0 #x5F99) + (#xD7D1 #x5F98) + (#xD7D2 #x5FA0) + (#xD7D3 #x5FA8) + (#xD7D4 #x5FAD) + (#xD7D5 #x5FBC) + (#xD7D6 #x5FD6) + (#xD7D7 #x5FFB) + (#xD7D8 #x5FE4) + (#xD7D9 #x5FF8) + (#xD7DA #x5FF1) + (#xD7DB #x5FDD) + (#xD7DC #x60B3) + (#xD7DD #x5FFF) + (#xD7DE #x6021) + (#xD7DF #x6060) + (#xD7E0 #x6019) + (#xD7E1 #x6010) + (#xD7E2 #x6029) + (#xD7E3 #x600E) + (#xD7E4 #x6031) + (#xD7E5 #x601B) + (#xD7E6 #x6015) + (#xD7E7 #x602B) + (#xD7E8 #x6026) + (#xD7E9 #x600F) + (#xD7EA #x603A) + (#xD7EB #x605A) + (#xD7EC #x6041) + (#xD7ED #x606A) + (#xD7EE #x6077) + (#xD7EF #x605F) + (#xD7F0 #x604A) + (#xD7F1 #x6046) + (#xD7F2 #x604D) + (#xD7F3 #x6063) + (#xD7F4 #x6043) + (#xD7F5 #x6064) + (#xD7F6 #x6042) + (#xD7F7 #x606C) + (#xD7F8 #x606B) + (#xD7F9 #x6059) + (#xD7FA #x6081) + (#xD7FB #x608D) + (#xD7FC #x60E7) + (#xD7FD #x6083) + (#xD7FE #x609A) + (#xD8A1 #x6084) + (#xD8A2 #x609B) + (#xD8A3 #x6096) + (#xD8A4 #x6097) + (#xD8A5 #x6092) + (#xD8A6 #x60A7) + (#xD8A7 #x608B) + (#xD8A8 #x60E1) + (#xD8A9 #x60B8) + (#xD8AA #x60E0) + (#xD8AB #x60D3) + (#xD8AC #x60B4) + (#xD8AD #x5FF0) + (#xD8AE #x60BD) + (#xD8AF #x60C6) + (#xD8B0 #x60B5) + (#xD8B1 #x60D8) + (#xD8B2 #x614D) + (#xD8B3 #x6115) + (#xD8B4 #x6106) + (#xD8B5 #x60F6) + (#xD8B6 #x60F7) + (#xD8B7 #x6100) + (#xD8B8 #x60F4) + (#xD8B9 #x60FA) + (#xD8BA #x6103) + (#xD8BB #x6121) + (#xD8BC #x60FB) + (#xD8BD #x60F1) + (#xD8BE #x610D) + (#xD8BF #x610E) + (#xD8C0 #x6147) + (#xD8C1 #x613E) + (#xD8C2 #x6128) + (#xD8C3 #x6127) + (#xD8C4 #x614A) + (#xD8C5 #x613F) + (#xD8C6 #x613C) + (#xD8C7 #x612C) + (#xD8C8 #x6134) + (#xD8C9 #x613D) + (#xD8CA #x6142) + (#xD8CB #x6144) + (#xD8CC #x6173) + (#xD8CD #x6177) + (#xD8CE #x6158) + (#xD8CF #x6159) + (#xD8D0 #x615A) + (#xD8D1 #x616B) + (#xD8D2 #x6174) + (#xD8D3 #x616F) + (#xD8D4 #x6165) + (#xD8D5 #x6171) + (#xD8D6 #x615F) + (#xD8D7 #x615D) + (#xD8D8 #x6153) + (#xD8D9 #x6175) + (#xD8DA #x6199) + (#xD8DB #x6196) + (#xD8DC #x6187) + (#xD8DD #x61AC) + (#xD8DE #x6194) + (#xD8DF #x619A) + (#xD8E0 #x618A) + (#xD8E1 #x6191) + (#xD8E2 #x61AB) + (#xD8E3 #x61AE) + (#xD8E4 #x61CC) + (#xD8E5 #x61CA) + (#xD8E6 #x61C9) + (#xD8E7 #x61F7) + (#xD8E8 #x61C8) + (#xD8E9 #x61C3) + (#xD8EA #x61C6) + (#xD8EB #x61BA) + (#xD8EC #x61CB) + (#xD8ED #x7F79) + (#xD8EE #x61CD) + (#xD8EF #x61E6) + (#xD8F0 #x61E3) + (#xD8F1 #x61F6) + (#xD8F2 #x61FA) + (#xD8F3 #x61F4) + (#xD8F4 #x61FF) + (#xD8F5 #x61FD) + (#xD8F6 #x61FC) + (#xD8F7 #x61FE) + (#xD8F8 #x6200) + (#xD8F9 #x6208) + (#xD8FA #x6209) + (#xD8FB #x620D) + (#xD8FC #x620C) + (#xD8FD #x6214) + (#xD8FE #x621B) + (#xD9A1 #x621E) + (#xD9A2 #x6221) + (#xD9A3 #x622A) + (#xD9A4 #x622E) + (#xD9A5 #x6230) + (#xD9A6 #x6232) + (#xD9A7 #x6233) + (#xD9A8 #x6241) + (#xD9A9 #x624E) + (#xD9AA #x625E) + (#xD9AB #x6263) + (#xD9AC #x625B) + (#xD9AD #x6260) + (#xD9AE #x6268) + (#xD9AF #x627C) + (#xD9B0 #x6282) + (#xD9B1 #x6289) + (#xD9B2 #x627E) + (#xD9B3 #x6292) + (#xD9B4 #x6293) + (#xD9B5 #x6296) + (#xD9B6 #x62D4) + (#xD9B7 #x6283) + (#xD9B8 #x6294) + (#xD9B9 #x62D7) + (#xD9BA #x62D1) + (#xD9BB #x62BB) + (#xD9BC #x62CF) + (#xD9BD #x62FF) + (#xD9BE #x62C6) + (#xD9BF #x64D4) + (#xD9C0 #x62C8) + (#xD9C1 #x62DC) + (#xD9C2 #x62CC) + (#xD9C3 #x62CA) + (#xD9C4 #x62C2) + (#xD9C5 #x62C7) + (#xD9C6 #x629B) + (#xD9C7 #x62C9) + (#xD9C8 #x630C) + (#xD9C9 #x62EE) + (#xD9CA #x62F1) + (#xD9CB #x6327) + (#xD9CC #x6302) + (#xD9CD #x6308) + (#xD9CE #x62EF) + (#xD9CF #x62F5) + (#xD9D0 #x6350) + (#xD9D1 #x633E) + (#xD9D2 #x634D) + (#xD9D3 #x641C) + (#xD9D4 #x634F) + (#xD9D5 #x6396) + (#xD9D6 #x638E) + (#xD9D7 #x6380) + (#xD9D8 #x63AB) + (#xD9D9 #x6376) + (#xD9DA #x63A3) + (#xD9DB #x638F) + (#xD9DC #x6389) + (#xD9DD #x639F) + (#xD9DE #x63B5) + (#xD9DF #x636B) + (#xD9E0 #x6369) + (#xD9E1 #x63BE) + (#xD9E2 #x63E9) + (#xD9E3 #x63C0) + (#xD9E4 #x63C6) + (#xD9E5 #x63E3) + (#xD9E6 #x63C9) + (#xD9E7 #x63D2) + (#xD9E8 #x63F6) + (#xD9E9 #x63C4) + (#xD9EA #x6416) + (#xD9EB #x6434) + (#xD9EC #x6406) + (#xD9ED #x6413) + (#xD9EE #x6426) + (#xD9EF #x6436) + (#xD9F0 #x651D) + (#xD9F1 #x6417) + (#xD9F2 #x6428) + (#xD9F3 #x640F) + (#xD9F4 #x6467) + (#xD9F5 #x646F) + (#xD9F6 #x6476) + (#xD9F7 #x644E) + (#xD9F8 #x652A) + (#xD9F9 #x6495) + (#xD9FA #x6493) + (#xD9FB #x64A5) + (#xD9FC #x64A9) + (#xD9FD #x6488) + (#xD9FE #x64BC) + (#xDAA1 #x64DA) + (#xDAA2 #x64D2) + (#xDAA3 #x64C5) + (#xDAA4 #x64C7) + (#xDAA5 #x64BB) + (#xDAA6 #x64D8) + (#xDAA7 #x64C2) + (#xDAA8 #x64F1) + (#xDAA9 #x64E7) + (#xDAAA #x8209) + (#xDAAB #x64E0) + (#xDAAC #x64E1) + (#xDAAD #x62AC) + (#xDAAE #x64E3) + (#xDAAF #x64EF) + (#xDAB0 #x652C) + (#xDAB1 #x64F6) + (#xDAB2 #x64F4) + (#xDAB3 #x64F2) + (#xDAB4 #x64FA) + (#xDAB5 #x6500) + (#xDAB6 #x64FD) + (#xDAB7 #x6518) + (#xDAB8 #x651C) + (#xDAB9 #x6505) + (#xDABA #x6524) + (#xDABB #x6523) + (#xDABC #x652B) + (#xDABD #x6534) + (#xDABE #x6535) + (#xDABF #x6537) + (#xDAC0 #x6536) + (#xDAC1 #x6538) + (#xDAC2 #x754B) + (#xDAC3 #x6548) + (#xDAC4 #x6556) + (#xDAC5 #x6555) + (#xDAC6 #x654D) + (#xDAC7 #x6558) + (#xDAC8 #x655E) + (#xDAC9 #x655D) + (#xDACA #x6572) + (#xDACB #x6578) + (#xDACC #x6582) + (#xDACD #x6583) + (#xDACE #x8B8A) + (#xDACF #x659B) + (#xDAD0 #x659F) + (#xDAD1 #x65AB) + (#xDAD2 #x65B7) + (#xDAD3 #x65C3) + (#xDAD4 #x65C6) + (#xDAD5 #x65C1) + (#xDAD6 #x65C4) + (#xDAD7 #x65CC) + (#xDAD8 #x65D2) + (#xDAD9 #x65DB) + (#xDADA #x65D9) + (#xDADB #x65E0) + (#xDADC #x65E1) + (#xDADD #x65F1) + (#xDADE #x6772) + (#xDADF #x660A) + (#xDAE0 #x6603) + (#xDAE1 #x65FB) + (#xDAE2 #x6773) + (#xDAE3 #x6635) + (#xDAE4 #x6636) + (#xDAE5 #x6634) + (#xDAE6 #x661C) + (#xDAE7 #x664F) + (#xDAE8 #x6644) + (#xDAE9 #x6649) + (#xDAEA #x6641) + (#xDAEB #x665E) + (#xDAEC #x665D) + (#xDAED #x6664) + (#xDAEE #x6667) + (#xDAEF #x6668) + (#xDAF0 #x665F) + (#xDAF1 #x6662) + (#xDAF2 #x6670) + (#xDAF3 #x6683) + (#xDAF4 #x6688) + (#xDAF5 #x668E) + (#xDAF6 #x6689) + (#xDAF7 #x6684) + (#xDAF8 #x6698) + (#xDAF9 #x669D) + (#xDAFA #x66C1) + (#xDAFB #x66B9) + (#xDAFC #x66C9) + (#xDAFD #x66BE) + (#xDAFE #x66BC) + (#xDBA1 #x66C4) + (#xDBA2 #x66B8) + (#xDBA3 #x66D6) + (#xDBA4 #x66DA) + (#xDBA5 #x66E0) + (#xDBA6 #x663F) + (#xDBA7 #x66E6) + (#xDBA8 #x66E9) + (#xDBA9 #x66F0) + (#xDBAA #x66F5) + (#xDBAB #x66F7) + (#xDBAC #x670F) + (#xDBAD #x6716) + (#xDBAE #x671E) + (#xDBAF #x6726) + (#xDBB0 #x6727) + (#xDBB1 #x9738) + (#xDBB2 #x672E) + (#xDBB3 #x673F) + (#xDBB4 #x6736) + (#xDBB5 #x6741) + (#xDBB6 #x6738) + (#xDBB7 #x6737) + (#xDBB8 #x6746) + (#xDBB9 #x675E) + (#xDBBA #x6760) + (#xDBBB #x6759) + (#xDBBC #x6763) + (#xDBBD #x6764) + (#xDBBE #x6789) + (#xDBBF #x6770) + (#xDBC0 #x67A9) + (#xDBC1 #x677C) + (#xDBC2 #x676A) + (#xDBC3 #x678C) + (#xDBC4 #x678B) + (#xDBC5 #x67A6) + (#xDBC6 #x67A1) + (#xDBC7 #x6785) + (#xDBC8 #x67B7) + (#xDBC9 #x67EF) + (#xDBCA #x67B4) + (#xDBCB #x67EC) + (#xDBCC #x67B3) + (#xDBCD #x67E9) + (#xDBCE #x67B8) + (#xDBCF #x67E4) + (#xDBD0 #x67DE) + (#xDBD1 #x67DD) + (#xDBD2 #x67E2) + (#xDBD3 #x67EE) + (#xDBD4 #x67B9) + (#xDBD5 #x67CE) + (#xDBD6 #x67C6) + (#xDBD7 #x67E7) + (#xDBD8 #x6A9C) + (#xDBD9 #x681E) + (#xDBDA #x6846) + (#xDBDB #x6829) + (#xDBDC #x6840) + (#xDBDD #x684D) + (#xDBDE #x6832) + (#xDBDF #x684E) + (#xDBE0 #x68B3) + (#xDBE1 #x682B) + (#xDBE2 #x6859) + (#xDBE3 #x6863) + (#xDBE4 #x6877) + (#xDBE5 #x687F) + (#xDBE6 #x689F) + (#xDBE7 #x688F) + (#xDBE8 #x68AD) + (#xDBE9 #x6894) + (#xDBEA #x689D) + (#xDBEB #x689B) + (#xDBEC #x6883) + (#xDBED #x6AAE) + (#xDBEE #x68B9) + (#xDBEF #x6874) + (#xDBF0 #x68B5) + (#xDBF1 #x68A0) + (#xDBF2 #x68BA) + (#xDBF3 #x690F) + (#xDBF4 #x688D) + (#xDBF5 #x687E) + (#xDBF6 #x6901) + (#xDBF7 #x68CA) + (#xDBF8 #x6908) + (#xDBF9 #x68D8) + (#xDBFA #x6922) + (#xDBFB #x6926) + (#xDBFC #x68E1) + (#xDBFD #x690C) + (#xDBFE #x68CD) + (#xDCA1 #x68D4) + (#xDCA2 #x68E7) + (#xDCA3 #x68D5) + (#xDCA4 #x6936) + (#xDCA5 #x6912) + (#xDCA6 #x6904) + (#xDCA7 #x68D7) + (#xDCA8 #x68E3) + (#xDCA9 #x6925) + (#xDCAA #x68F9) + (#xDCAB #x68E0) + (#xDCAC #x68EF) + (#xDCAD #x6928) + (#xDCAE #x692A) + (#xDCAF #x691A) + (#xDCB0 #x6923) + (#xDCB1 #x6921) + (#xDCB2 #x68C6) + (#xDCB3 #x6979) + (#xDCB4 #x6977) + (#xDCB5 #x695C) + (#xDCB6 #x6978) + (#xDCB7 #x696B) + (#xDCB8 #x6954) + (#xDCB9 #x697E) + (#xDCBA #x696E) + (#xDCBB #x6939) + (#xDCBC #x6974) + (#xDCBD #x693D) + (#xDCBE #x6959) + (#xDCBF #x6930) + (#xDCC0 #x6961) + (#xDCC1 #x695E) + (#xDCC2 #x695D) + (#xDCC3 #x6981) + (#xDCC4 #x696A) + (#xDCC5 #x69B2) + (#xDCC6 #x69AE) + (#xDCC7 #x69D0) + (#xDCC8 #x69BF) + (#xDCC9 #x69C1) + (#xDCCA #x69D3) + (#xDCCB #x69BE) + (#xDCCC #x69CE) + (#xDCCD #x5BE8) + (#xDCCE #x69CA) + (#xDCCF #x69DD) + (#xDCD0 #x69BB) + (#xDCD1 #x69C3) + (#xDCD2 #x69A7) + (#xDCD3 #x6A2E) + (#xDCD4 #x6991) + (#xDCD5 #x69A0) + (#xDCD6 #x699C) + (#xDCD7 #x6995) + (#xDCD8 #x69B4) + (#xDCD9 #x69DE) + (#xDCDA #x69E8) + (#xDCDB #x6A02) + (#xDCDC #x6A1B) + (#xDCDD #x69FF) + (#xDCDE #x6B0A) + (#xDCDF #x69F9) + (#xDCE0 #x69F2) + (#xDCE1 #x69E7) + (#xDCE2 #x6A05) + (#xDCE3 #x69B1) + (#xDCE4 #x6A1E) + (#xDCE5 #x69ED) + (#xDCE6 #x6A14) + (#xDCE7 #x69EB) + (#xDCE8 #x6A0A) + (#xDCE9 #x6A12) + (#xDCEA #x6AC1) + (#xDCEB #x6A23) + (#xDCEC #x6A13) + (#xDCED #x6A44) + (#xDCEE #x6A0C) + (#xDCEF #x6A72) + (#xDCF0 #x6A36) + (#xDCF1 #x6A78) + (#xDCF2 #x6A47) + (#xDCF3 #x6A62) + (#xDCF4 #x6A59) + (#xDCF5 #x6A66) + (#xDCF6 #x6A48) + (#xDCF7 #x6A38) + (#xDCF8 #x6A22) + (#xDCF9 #x6A90) + (#xDCFA #x6A8D) + (#xDCFB #x6AA0) + (#xDCFC #x6A84) + (#xDCFD #x6AA2) + (#xDCFE #x6AA3) + (#xDDA1 #x6A97) + (#xDDA2 #x8617) + (#xDDA3 #x6ABB) + (#xDDA4 #x6AC3) + (#xDDA5 #x6AC2) + (#xDDA6 #x6AB8) + (#xDDA7 #x6AB3) + (#xDDA8 #x6AAC) + (#xDDA9 #x6ADE) + (#xDDAA #x6AD1) + (#xDDAB #x6ADF) + (#xDDAC #x6AAA) + (#xDDAD #x6ADA) + (#xDDAE #x6AEA) + (#xDDAF #x6AFB) + (#xDDB0 #x6B05) + (#xDDB1 #x8616) + (#xDDB2 #x6AFA) + (#xDDB3 #x6B12) + (#xDDB4 #x6B16) + (#xDDB5 #x9B31) + (#xDDB6 #x6B1F) + (#xDDB7 #x6B38) + (#xDDB8 #x6B37) + (#xDDB9 #x76DC) + (#xDDBA #x6B39) + (#xDDBB #x98EE) + (#xDDBC #x6B47) + (#xDDBD #x6B43) + (#xDDBE #x6B49) + (#xDDBF #x6B50) + (#xDDC0 #x6B59) + (#xDDC1 #x6B54) + (#xDDC2 #x6B5B) + (#xDDC3 #x6B5F) + (#xDDC4 #x6B61) + (#xDDC5 #x6B78) + (#xDDC6 #x6B79) + (#xDDC7 #x6B7F) + (#xDDC8 #x6B80) + (#xDDC9 #x6B84) + (#xDDCA #x6B83) + (#xDDCB #x6B8D) + (#xDDCC #x6B98) + (#xDDCD #x6B95) + (#xDDCE #x6B9E) + (#xDDCF #x6BA4) + (#xDDD0 #x6BAA) + (#xDDD1 #x6BAB) + (#xDDD2 #x6BAF) + (#xDDD3 #x6BB2) + (#xDDD4 #x6BB1) + (#xDDD5 #x6BB3) + (#xDDD6 #x6BB7) + (#xDDD7 #x6BBC) + (#xDDD8 #x6BC6) + (#xDDD9 #x6BCB) + (#xDDDA #x6BD3) + (#xDDDB #x6BDF) + (#xDDDC #x6BEC) + (#xDDDD #x6BEB) + (#xDDDE #x6BF3) + (#xDDDF #x6BEF) + (#xDDE0 #x9EBE) + (#xDDE1 #x6C08) + (#xDDE2 #x6C13) + (#xDDE3 #x6C14) + (#xDDE4 #x6C1B) + (#xDDE5 #x6C24) + (#xDDE6 #x6C23) + (#xDDE7 #x6C5E) + (#xDDE8 #x6C55) + (#xDDE9 #x6C62) + (#xDDEA #x6C6A) + (#xDDEB #x6C82) + (#xDDEC #x6C8D) + (#xDDED #x6C9A) + (#xDDEE #x6C81) + (#xDDEF #x6C9B) + (#xDDF0 #x6C7E) + (#xDDF1 #x6C68) + (#xDDF2 #x6C73) + (#xDDF3 #x6C92) + (#xDDF4 #x6C90) + (#xDDF5 #x6CC4) + (#xDDF6 #x6CF1) + (#xDDF7 #x6CD3) + (#xDDF8 #x6CBD) + (#xDDF9 #x6CD7) + (#xDDFA #x6CC5) + (#xDDFB #x6CDD) + (#xDDFC #x6CAE) + (#xDDFD #x6CB1) + (#xDDFE #x6CBE) + (#xDEA1 #x6CBA) + (#xDEA2 #x6CDB) + (#xDEA3 #x6CEF) + (#xDEA4 #x6CD9) + (#xDEA5 #x6CEA) + (#xDEA6 #x6D1F) + (#xDEA7 #x884D) + (#xDEA8 #x6D36) + (#xDEA9 #x6D2B) + (#xDEAA #x6D3D) + (#xDEAB #x6D38) + (#xDEAC #x6D19) + (#xDEAD #x6D35) + (#xDEAE #x6D33) + (#xDEAF #x6D12) + (#xDEB0 #x6D0C) + (#xDEB1 #x6D63) + (#xDEB2 #x6D93) + (#xDEB3 #x6D64) + (#xDEB4 #x6D5A) + (#xDEB5 #x6D79) + (#xDEB6 #x6D59) + (#xDEB7 #x6D8E) + (#xDEB8 #x6D95) + (#xDEB9 #x6FE4) + (#xDEBA #x6D85) + (#xDEBB #x6DF9) + (#xDEBC #x6E15) + (#xDEBD #x6E0A) + (#xDEBE #x6DB5) + (#xDEBF #x6DC7) + (#xDEC0 #x6DE6) + (#xDEC1 #x6DB8) + (#xDEC2 #x6DC6) + (#xDEC3 #x6DEC) + (#xDEC4 #x6DDE) + (#xDEC5 #x6DCC) + (#xDEC6 #x6DE8) + (#xDEC7 #x6DD2) + (#xDEC8 #x6DC5) + (#xDEC9 #x6DFA) + (#xDECA #x6DD9) + (#xDECB #x6DE4) + (#xDECC #x6DD5) + (#xDECD #x6DEA) + (#xDECE #x6DEE) + (#xDECF #x6E2D) + (#xDED0 #x6E6E) + (#xDED1 #x6E2E) + (#xDED2 #x6E19) + (#xDED3 #x6E72) + (#xDED4 #x6E5F) + (#xDED5 #x6E3E) + (#xDED6 #x6E23) + (#xDED7 #x6E6B) + (#xDED8 #x6E2B) + (#xDED9 #x6E76) + (#xDEDA #x6E4D) + (#xDEDB #x6E1F) + (#xDEDC #x6E43) + (#xDEDD #x6E3A) + (#xDEDE #x6E4E) + (#xDEDF #x6E24) + (#xDEE0 #x6EFF) + (#xDEE1 #x6E1D) + (#xDEE2 #x6E38) + (#xDEE3 #x6E82) + (#xDEE4 #x6EAA) + (#xDEE5 #x6E98) + (#xDEE6 #x6EC9) + (#xDEE7 #x6EB7) + (#xDEE8 #x6ED3) + (#xDEE9 #x6EBD) + (#xDEEA #x6EAF) + (#xDEEB #x6EC4) + (#xDEEC #x6EB2) + (#xDEED #x6ED4) + (#xDEEE #x6ED5) + (#xDEEF #x6E8F) + (#xDEF0 #x6EA5) + (#xDEF1 #x6EC2) + (#xDEF2 #x6E9F) + (#xDEF3 #x6F41) + (#xDEF4 #x6F11) + (#xDEF5 #x704C) + (#xDEF6 #x6EEC) + (#xDEF7 #x6EF8) + (#xDEF8 #x6EFE) + (#xDEF9 #x6F3F) + (#xDEFA #x6EF2) + (#xDEFB #x6F31) + (#xDEFC #x6EEF) + (#xDEFD #x6F32) + (#xDEFE #x6ECC) + (#xDFA1 #x6F3E) + (#xDFA2 #x6F13) + (#xDFA3 #x6EF7) + (#xDFA4 #x6F86) + (#xDFA5 #x6F7A) + (#xDFA6 #x6F78) + (#xDFA7 #x6F81) + (#xDFA8 #x6F80) + (#xDFA9 #x6F6F) + (#xDFAA #x6F5B) + (#xDFAB #x6FF3) + (#xDFAC #x6F6D) + (#xDFAD #x6F82) + (#xDFAE #x6F7C) + (#xDFAF #x6F58) + (#xDFB0 #x6F8E) + (#xDFB1 #x6F91) + (#xDFB2 #x6FC2) + (#xDFB3 #x6F66) + (#xDFB4 #x6FB3) + (#xDFB5 #x6FA3) + (#xDFB6 #x6FA1) + (#xDFB7 #x6FA4) + (#xDFB8 #x6FB9) + (#xDFB9 #x6FC6) + (#xDFBA #x6FAA) + (#xDFBB #x6FDF) + (#xDFBC #x6FD5) + (#xDFBD #x6FEC) + (#xDFBE #x6FD4) + (#xDFBF #x6FD8) + (#xDFC0 #x6FF1) + (#xDFC1 #x6FEE) + (#xDFC2 #x6FDB) + (#xDFC3 #x7009) + (#xDFC4 #x700B) + (#xDFC5 #x6FFA) + (#xDFC6 #x7011) + (#xDFC7 #x7001) + (#xDFC8 #x700F) + (#xDFC9 #x6FFE) + (#xDFCA #x701B) + (#xDFCB #x701A) + (#xDFCC #x6F74) + (#xDFCD #x701D) + (#xDFCE #x7018) + (#xDFCF #x701F) + (#xDFD0 #x7030) + (#xDFD1 #x703E) + (#xDFD2 #x7032) + (#xDFD3 #x7051) + (#xDFD4 #x7063) + (#xDFD5 #x7099) + (#xDFD6 #x7092) + (#xDFD7 #x70AF) + (#xDFD8 #x70F1) + (#xDFD9 #x70AC) + (#xDFDA #x70B8) + (#xDFDB #x70B3) + (#xDFDC #x70AE) + (#xDFDD #x70DF) + (#xDFDE #x70CB) + (#xDFDF #x70DD) + (#xDFE0 #x70D9) + (#xDFE1 #x7109) + (#xDFE2 #x70FD) + (#xDFE3 #x711C) + (#xDFE4 #x7119) + (#xDFE5 #x7165) + (#xDFE6 #x7155) + (#xDFE7 #x7188) + (#xDFE8 #x7166) + (#xDFE9 #x7162) + (#xDFEA #x714C) + (#xDFEB #x7156) + (#xDFEC #x716C) + (#xDFED #x718F) + (#xDFEE #x71FB) + (#xDFEF #x7184) + (#xDFF0 #x7195) + (#xDFF1 #x71A8) + (#xDFF2 #x71AC) + (#xDFF3 #x71D7) + (#xDFF4 #x71B9) + (#xDFF5 #x71BE) + (#xDFF6 #x71D2) + (#xDFF7 #x71C9) + (#xDFF8 #x71D4) + (#xDFF9 #x71CE) + (#xDFFA #x71E0) + (#xDFFB #x71EC) + (#xDFFC #x71E7) + (#xDFFD #x71F5) + (#xDFFE #x71FC) + (#xE0A1 #x71F9) + (#xE0A2 #x71FF) + (#xE0A3 #x720D) + (#xE0A4 #x7210) + (#xE0A5 #x721B) + (#xE0A6 #x7228) + (#xE0A7 #x722D) + (#xE0A8 #x722C) + (#xE0A9 #x7230) + (#xE0AA #x7232) + (#xE0AB #x723B) + (#xE0AC #x723C) + (#xE0AD #x723F) + (#xE0AE #x7240) + (#xE0AF #x7246) + (#xE0B0 #x724B) + (#xE0B1 #x7258) + (#xE0B2 #x7274) + (#xE0B3 #x727E) + (#xE0B4 #x7282) + (#xE0B5 #x7281) + (#xE0B6 #x7287) + (#xE0B7 #x7292) + (#xE0B8 #x7296) + (#xE0B9 #x72A2) + (#xE0BA #x72A7) + (#xE0BB #x72B9) + (#xE0BC #x72B2) + (#xE0BD #x72C3) + (#xE0BE #x72C6) + (#xE0BF #x72C4) + (#xE0C0 #x72CE) + (#xE0C1 #x72D2) + (#xE0C2 #x72E2) + (#xE0C3 #x72E0) + (#xE0C4 #x72E1) + (#xE0C5 #x72F9) + (#xE0C6 #x72F7) + (#xE0C7 #x500F) + (#xE0C8 #x7317) + (#xE0C9 #x730A) + (#xE0CA #x731C) + (#xE0CB #x7316) + (#xE0CC #x731D) + (#xE0CD #x7334) + (#xE0CE #x732F) + (#xE0CF #x7329) + (#xE0D0 #x7325) + (#xE0D1 #x733E) + (#xE0D2 #x734E) + (#xE0D3 #x734F) + (#xE0D4 #x9ED8) + (#xE0D5 #x7357) + (#xE0D6 #x736A) + (#xE0D7 #x7368) + (#xE0D8 #x7370) + (#xE0D9 #x7378) + (#xE0DA #x7375) + (#xE0DB #x737B) + (#xE0DC #x737A) + (#xE0DD #x73C8) + (#xE0DE #x73B3) + (#xE0DF #x73CE) + (#xE0E0 #x73BB) + (#xE0E1 #x73C0) + (#xE0E2 #x73E5) + (#xE0E3 #x73EE) + (#xE0E4 #x73DE) + (#xE0E5 #x74A2) + (#xE0E6 #x7405) + (#xE0E7 #x746F) + (#xE0E8 #x7425) + (#xE0E9 #x73F8) + (#xE0EA #x7432) + (#xE0EB #x743A) + (#xE0EC #x7455) + (#xE0ED #x743F) + (#xE0EE #x745F) + (#xE0EF #x7459) + (#xE0F0 #x7441) + (#xE0F1 #x745C) + (#xE0F2 #x7469) + (#xE0F3 #x7470) + (#xE0F4 #x7463) + (#xE0F5 #x746A) + (#xE0F6 #x7476) + (#xE0F7 #x747E) + (#xE0F8 #x748B) + (#xE0F9 #x749E) + (#xE0FA #x74A7) + (#xE0FB #x74CA) + (#xE0FC #x74CF) + (#xE0FD #x74D4) + (#xE0FE #x73F1) + (#xE1A1 #x74E0) + (#xE1A2 #x74E3) + (#xE1A3 #x74E7) + (#xE1A4 #x74E9) + (#xE1A5 #x74EE) + (#xE1A6 #x74F2) + (#xE1A7 #x74F0) + (#xE1A8 #x74F1) + (#xE1A9 #x74F8) + (#xE1AA #x74F7) + (#xE1AB #x7504) + (#xE1AC #x7503) + (#xE1AD #x7505) + (#xE1AE #x750C) + (#xE1AF #x750E) + (#xE1B0 #x750D) + (#xE1B1 #x7515) + (#xE1B2 #x7513) + (#xE1B3 #x751E) + (#xE1B4 #x7526) + (#xE1B5 #x752C) + (#xE1B6 #x753C) + (#xE1B7 #x7544) + (#xE1B8 #x754D) + (#xE1B9 #x754A) + (#xE1BA #x7549) + (#xE1BB #x755B) + (#xE1BC #x7546) + (#xE1BD #x755A) + (#xE1BE #x7569) + (#xE1BF #x7564) + (#xE1C0 #x7567) + (#xE1C1 #x756B) + (#xE1C2 #x756D) + (#xE1C3 #x7578) + (#xE1C4 #x7576) + (#xE1C5 #x7586) + (#xE1C6 #x7587) + (#xE1C7 #x7574) + (#xE1C8 #x758A) + (#xE1C9 #x7589) + (#xE1CA #x7582) + (#xE1CB #x7594) + (#xE1CC #x759A) + (#xE1CD #x759D) + (#xE1CE #x75A5) + (#xE1CF #x75A3) + (#xE1D0 #x75C2) + (#xE1D1 #x75B3) + (#xE1D2 #x75C3) + (#xE1D3 #x75B5) + (#xE1D4 #x75BD) + (#xE1D5 #x75B8) + (#xE1D6 #x75BC) + (#xE1D7 #x75B1) + (#xE1D8 #x75CD) + (#xE1D9 #x75CA) + (#xE1DA #x75D2) + (#xE1DB #x75D9) + (#xE1DC #x75E3) + (#xE1DD #x75DE) + (#xE1DE #x75FE) + (#xE1DF #x75FF) + (#xE1E0 #x75FC) + (#xE1E1 #x7601) + (#xE1E2 #x75F0) + (#xE1E3 #x75FA) + (#xE1E4 #x75F2) + (#xE1E5 #x75F3) + (#xE1E6 #x760B) + (#xE1E7 #x760D) + (#xE1E8 #x7609) + (#xE1E9 #x761F) + (#xE1EA #x7627) + (#xE1EB #x7620) + (#xE1EC #x7621) + (#xE1ED #x7622) + (#xE1EE #x7624) + (#xE1EF #x7634) + (#xE1F0 #x7630) + (#xE1F1 #x763B) + (#xE1F2 #x7647) + (#xE1F3 #x7648) + (#xE1F4 #x7646) + (#xE1F5 #x765C) + (#xE1F6 #x7658) + (#xE1F7 #x7661) + (#xE1F8 #x7662) + (#xE1F9 #x7668) + (#xE1FA #x7669) + (#xE1FB #x766A) + (#xE1FC #x7667) + (#xE1FD #x766C) + (#xE1FE #x7670) + (#xE2A1 #x7672) + (#xE2A2 #x7676) + (#xE2A3 #x7678) + (#xE2A4 #x767C) + (#xE2A5 #x7680) + (#xE2A6 #x7683) + (#xE2A7 #x7688) + (#xE2A8 #x768B) + (#xE2A9 #x768E) + (#xE2AA #x7696) + (#xE2AB #x7693) + (#xE2AC #x7699) + (#xE2AD #x769A) + (#xE2AE #x76B0) + (#xE2AF #x76B4) + (#xE2B0 #x76B8) + (#xE2B1 #x76B9) + (#xE2B2 #x76BA) + (#xE2B3 #x76C2) + (#xE2B4 #x76CD) + (#xE2B5 #x76D6) + (#xE2B6 #x76D2) + (#xE2B7 #x76DE) + (#xE2B8 #x76E1) + (#xE2B9 #x76E5) + (#xE2BA #x76E7) + (#xE2BB #x76EA) + (#xE2BC #x862F) + (#xE2BD #x76FB) + (#xE2BE #x7708) + (#xE2BF #x7707) + (#xE2C0 #x7704) + (#xE2C1 #x7729) + (#xE2C2 #x7724) + (#xE2C3 #x771E) + (#xE2C4 #x7725) + (#xE2C5 #x7726) + (#xE2C6 #x771B) + (#xE2C7 #x7737) + (#xE2C8 #x7738) + (#xE2C9 #x7747) + (#xE2CA #x775A) + (#xE2CB #x7768) + (#xE2CC #x776B) + (#xE2CD #x775B) + (#xE2CE #x7765) + (#xE2CF #x777F) + (#xE2D0 #x777E) + (#xE2D1 #x7779) + (#xE2D2 #x778E) + (#xE2D3 #x778B) + (#xE2D4 #x7791) + (#xE2D5 #x77A0) + (#xE2D6 #x779E) + (#xE2D7 #x77B0) + (#xE2D8 #x77B6) + (#xE2D9 #x77B9) + (#xE2DA #x77BF) + (#xE2DB #x77BC) + (#xE2DC #x77BD) + (#xE2DD #x77BB) + (#xE2DE #x77C7) + (#xE2DF #x77CD) + (#xE2E0 #x77D7) + (#xE2E1 #x77DA) + (#xE2E2 #x77DC) + (#xE2E3 #x77E3) + (#xE2E4 #x77EE) + (#xE2E5 #x77FC) + (#xE2E6 #x780C) + (#xE2E7 #x7812) + (#xE2E8 #x7926) + (#xE2E9 #x7820) + (#xE2EA #x792A) + (#xE2EB #x7845) + (#xE2EC #x788E) + (#xE2ED #x7874) + (#xE2EE #x7886) + (#xE2EF #x787C) + (#xE2F0 #x789A) + (#xE2F1 #x788C) + (#xE2F2 #x78A3) + (#xE2F3 #x78B5) + (#xE2F4 #x78AA) + (#xE2F5 #x78AF) + (#xE2F6 #x78D1) + (#xE2F7 #x78C6) + (#xE2F8 #x78CB) + (#xE2F9 #x78D4) + (#xE2FA #x78BE) + (#xE2FB #x78BC) + (#xE2FC #x78C5) + (#xE2FD #x78CA) + (#xE2FE #x78EC) + (#xE3A1 #x78E7) + (#xE3A2 #x78DA) + (#xE3A3 #x78FD) + (#xE3A4 #x78F4) + (#xE3A5 #x7907) + (#xE3A6 #x7912) + (#xE3A7 #x7911) + (#xE3A8 #x7919) + (#xE3A9 #x792C) + (#xE3AA #x792B) + (#xE3AB #x7940) + (#xE3AC #x7960) + (#xE3AD #x7957) + (#xE3AE #x795F) + (#xE3AF #x795A) + (#xE3B0 #x7955) + (#xE3B1 #x7953) + (#xE3B2 #x797A) + (#xE3B3 #x797F) + (#xE3B4 #x798A) + (#xE3B5 #x799D) + (#xE3B6 #x79A7) + (#xE3B7 #x9F4B) + (#xE3B8 #x79AA) + (#xE3B9 #x79AE) + (#xE3BA #x79B3) + (#xE3BB #x79B9) + (#xE3BC #x79BA) + (#xE3BD #x79C9) + (#xE3BE #x79D5) + (#xE3BF #x79E7) + (#xE3C0 #x79EC) + (#xE3C1 #x79E1) + (#xE3C2 #x79E3) + (#xE3C3 #x7A08) + (#xE3C4 #x7A0D) + (#xE3C5 #x7A18) + (#xE3C6 #x7A19) + (#xE3C7 #x7A20) + (#xE3C8 #x7A1F) + (#xE3C9 #x7980) + (#xE3CA #x7A31) + (#xE3CB #x7A3B) + (#xE3CC #x7A3E) + (#xE3CD #x7A37) + (#xE3CE #x7A43) + (#xE3CF #x7A57) + (#xE3D0 #x7A49) + (#xE3D1 #x7A61) + (#xE3D2 #x7A62) + (#xE3D3 #x7A69) + (#xE3D4 #x9F9D) + (#xE3D5 #x7A70) + (#xE3D6 #x7A79) + (#xE3D7 #x7A7D) + (#xE3D8 #x7A88) + (#xE3D9 #x7A97) + (#xE3DA #x7A95) + (#xE3DB #x7A98) + (#xE3DC #x7A96) + (#xE3DD #x7AA9) + (#xE3DE #x7AC8) + (#xE3DF #x7AB0) + (#xE3E0 #x7AB6) + (#xE3E1 #x7AC5) + (#xE3E2 #x7AC4) + (#xE3E3 #x7ABF) + (#xE3E4 #x9083) + (#xE3E5 #x7AC7) + (#xE3E6 #x7ACA) + (#xE3E7 #x7ACD) + (#xE3E8 #x7ACF) + (#xE3E9 #x7AD5) + (#xE3EA #x7AD3) + (#xE3EB #x7AD9) + (#xE3EC #x7ADA) + (#xE3ED #x7ADD) + (#xE3EE #x7AE1) + (#xE3EF #x7AE2) + (#xE3F0 #x7AE6) + (#xE3F1 #x7AED) + (#xE3F2 #x7AF0) + (#xE3F3 #x7B02) + (#xE3F4 #x7B0F) + (#xE3F5 #x7B0A) + (#xE3F6 #x7B06) + (#xE3F7 #x7B33) + (#xE3F8 #x7B18) + (#xE3F9 #x7B19) + (#xE3FA #x7B1E) + (#xE3FB #x7B35) + (#xE3FC #x7B28) + (#xE3FD #x7B36) + (#xE3FE #x7B50) + (#xE4A1 #x7B7A) + (#xE4A2 #x7B04) + (#xE4A3 #x7B4D) + (#xE4A4 #x7B0B) + (#xE4A5 #x7B4C) + (#xE4A6 #x7B45) + (#xE4A7 #x7B75) + (#xE4A8 #x7B65) + (#xE4A9 #x7B74) + (#xE4AA #x7B67) + (#xE4AB #x7B70) + (#xE4AC #x7B71) + (#xE4AD #x7B6C) + (#xE4AE #x7B6E) + (#xE4AF #x7B9D) + (#xE4B0 #x7B98) + (#xE4B1 #x7B9F) + (#xE4B2 #x7B8D) + (#xE4B3 #x7B9C) + (#xE4B4 #x7B9A) + (#xE4B5 #x7B8B) + (#xE4B6 #x7B92) + (#xE4B7 #x7B8F) + (#xE4B8 #x7B5D) + (#xE4B9 #x7B99) + (#xE4BA #x7BCB) + (#xE4BB #x7BC1) + (#xE4BC #x7BCC) + (#xE4BD #x7BCF) + (#xE4BE #x7BB4) + (#xE4BF #x7BC6) + (#xE4C0 #x7BDD) + (#xE4C1 #x7BE9) + (#xE4C2 #x7C11) + (#xE4C3 #x7C14) + (#xE4C4 #x7BE6) + (#xE4C5 #x7BE5) + (#xE4C6 #x7C60) + (#xE4C7 #x7C00) + (#xE4C8 #x7C07) + (#xE4C9 #x7C13) + (#xE4CA #x7BF3) + (#xE4CB #x7BF7) + (#xE4CC #x7C17) + (#xE4CD #x7C0D) + (#xE4CE #x7BF6) + (#xE4CF #x7C23) + (#xE4D0 #x7C27) + (#xE4D1 #x7C2A) + (#xE4D2 #x7C1F) + (#xE4D3 #x7C37) + (#xE4D4 #x7C2B) + (#xE4D5 #x7C3D) + (#xE4D6 #x7C4C) + (#xE4D7 #x7C43) + (#xE4D8 #x7C54) + (#xE4D9 #x7C4F) + (#xE4DA #x7C40) + (#xE4DB #x7C50) + (#xE4DC #x7C58) + (#xE4DD #x7C5F) + (#xE4DE #x7C64) + (#xE4DF #x7C56) + (#xE4E0 #x7C65) + (#xE4E1 #x7C6C) + (#xE4E2 #x7C75) + (#xE4E3 #x7C83) + (#xE4E4 #x7C90) + (#xE4E5 #x7CA4) + (#xE4E6 #x7CAD) + (#xE4E7 #x7CA2) + (#xE4E8 #x7CAB) + (#xE4E9 #x7CA1) + (#xE4EA #x7CA8) + (#xE4EB #x7CB3) + (#xE4EC #x7CB2) + (#xE4ED #x7CB1) + (#xE4EE #x7CAE) + (#xE4EF #x7CB9) + (#xE4F0 #x7CBD) + (#xE4F1 #x7CC0) + (#xE4F2 #x7CC5) + (#xE4F3 #x7CC2) + (#xE4F4 #x7CD8) + (#xE4F5 #x7CD2) + (#xE4F6 #x7CDC) + (#xE4F7 #x7CE2) + (#xE4F8 #x9B3B) + (#xE4F9 #x7CEF) + (#xE4FA #x7CF2) + (#xE4FB #x7CF4) + (#xE4FC #x7CF6) + (#xE4FD #x7CFA) + (#xE4FE #x7D06) + (#xE5A1 #x7D02) + (#xE5A2 #x7D1C) + (#xE5A3 #x7D15) + (#xE5A4 #x7D0A) + (#xE5A5 #x7D45) + (#xE5A6 #x7D4B) + (#xE5A7 #x7D2E) + (#xE5A8 #x7D32) + (#xE5A9 #x7D3F) + (#xE5AA #x7D35) + (#xE5AB #x7D46) + (#xE5AC #x7D73) + (#xE5AD #x7D56) + (#xE5AE #x7D4E) + (#xE5AF #x7D72) + (#xE5B0 #x7D68) + (#xE5B1 #x7D6E) + (#xE5B2 #x7D4F) + (#xE5B3 #x7D63) + (#xE5B4 #x7D93) + (#xE5B5 #x7D89) + (#xE5B6 #x7D5B) + (#xE5B7 #x7D8F) + (#xE5B8 #x7D7D) + (#xE5B9 #x7D9B) + (#xE5BA #x7DBA) + (#xE5BB #x7DAE) + (#xE5BC #x7DA3) + (#xE5BD #x7DB5) + (#xE5BE #x7DC7) + (#xE5BF #x7DBD) + (#xE5C0 #x7DAB) + (#xE5C1 #x7E3D) + (#xE5C2 #x7DA2) + (#xE5C3 #x7DAF) + (#xE5C4 #x7DDC) + (#xE5C5 #x7DB8) + (#xE5C6 #x7D9F) + (#xE5C7 #x7DB0) + (#xE5C8 #x7DD8) + (#xE5C9 #x7DDD) + (#xE5CA #x7DE4) + (#xE5CB #x7DDE) + (#xE5CC #x7DFB) + (#xE5CD #x7DF2) + (#xE5CE #x7DE1) + (#xE5CF #x7E05) + (#xE5D0 #x7E0A) + (#xE5D1 #x7E23) + (#xE5D2 #x7E21) + (#xE5D3 #x7E12) + (#xE5D4 #x7E31) + (#xE5D5 #x7E1F) + (#xE5D6 #x7E09) + (#xE5D7 #x7E0B) + (#xE5D8 #x7E22) + (#xE5D9 #x7E46) + (#xE5DA #x7E66) + (#xE5DB #x7E3B) + (#xE5DC #x7E35) + (#xE5DD #x7E39) + (#xE5DE #x7E43) + (#xE5DF #x7E37) + (#xE5E0 #x7E32) + (#xE5E1 #x7E3A) + (#xE5E2 #x7E67) + (#xE5E3 #x7E5D) + (#xE5E4 #x7E56) + (#xE5E5 #x7E5E) + (#xE5E6 #x7E59) + (#xE5E7 #x7E5A) + (#xE5E8 #x7E79) + (#xE5E9 #x7E6A) + (#xE5EA #x7E69) + (#xE5EB #x7E7C) + (#xE5EC #x7E7B) + (#xE5ED #x7E83) + (#xE5EE #x7DD5) + (#xE5EF #x7E7D) + (#xE5F0 #x8FAE) + (#xE5F1 #x7E7F) + (#xE5F2 #x7E88) + (#xE5F3 #x7E89) + (#xE5F4 #x7E8C) + (#xE5F5 #x7E92) + (#xE5F6 #x7E90) + (#xE5F7 #x7E93) + (#xE5F8 #x7E94) + (#xE5F9 #x7E96) + (#xE5FA #x7E8E) + (#xE5FB #x7E9B) + (#xE5FC #x7E9C) + (#xE5FD #x7F38) + (#xE5FE #x7F3A) + (#xE6A1 #x7F45) + (#xE6A2 #x7F4C) + (#xE6A3 #x7F4D) + (#xE6A4 #x7F4E) + (#xE6A5 #x7F50) + (#xE6A6 #x7F51) + (#xE6A7 #x7F55) + (#xE6A8 #x7F54) + (#xE6A9 #x7F58) + (#xE6AA #x7F5F) + (#xE6AB #x7F60) + (#xE6AC #x7F68) + (#xE6AD #x7F69) + (#xE6AE #x7F67) + (#xE6AF #x7F78) + (#xE6B0 #x7F82) + (#xE6B1 #x7F86) + (#xE6B2 #x7F83) + (#xE6B3 #x7F88) + (#xE6B4 #x7F87) + (#xE6B5 #x7F8C) + (#xE6B6 #x7F94) + (#xE6B7 #x7F9E) + (#xE6B8 #x7F9D) + (#xE6B9 #x7F9A) + (#xE6BA #x7FA3) + (#xE6BB #x7FAF) + (#xE6BC #x7FB2) + (#xE6BD #x7FB9) + (#xE6BE #x7FAE) + (#xE6BF #x7FB6) + (#xE6C0 #x7FB8) + (#xE6C1 #x8B71) + (#xE6C2 #x7FC5) + (#xE6C3 #x7FC6) + (#xE6C4 #x7FCA) + (#xE6C5 #x7FD5) + (#xE6C6 #x7FD4) + (#xE6C7 #x7FE1) + (#xE6C8 #x7FE6) + (#xE6C9 #x7FE9) + (#xE6CA #x7FF3) + (#xE6CB #x7FF9) + (#xE6CC #x98DC) + (#xE6CD #x8006) + (#xE6CE #x8004) + (#xE6CF #x800B) + (#xE6D0 #x8012) + (#xE6D1 #x8018) + (#xE6D2 #x8019) + (#xE6D3 #x801C) + (#xE6D4 #x8021) + (#xE6D5 #x8028) + (#xE6D6 #x803F) + (#xE6D7 #x803B) + (#xE6D8 #x804A) + (#xE6D9 #x8046) + (#xE6DA #x8052) + (#xE6DB #x8058) + (#xE6DC #x805A) + (#xE6DD #x805F) + (#xE6DE #x8062) + (#xE6DF #x8068) + (#xE6E0 #x8073) + (#xE6E1 #x8072) + (#xE6E2 #x8070) + (#xE6E3 #x8076) + (#xE6E4 #x8079) + (#xE6E5 #x807D) + (#xE6E6 #x807F) + (#xE6E7 #x8084) + (#xE6E8 #x8086) + (#xE6E9 #x8085) + (#xE6EA #x809B) + (#xE6EB #x8093) + (#xE6EC #x809A) + (#xE6ED #x80AD) + (#xE6EE #x5190) + (#xE6EF #x80AC) + (#xE6F0 #x80DB) + (#xE6F1 #x80E5) + (#xE6F2 #x80D9) + (#xE6F3 #x80DD) + (#xE6F4 #x80C4) + (#xE6F5 #x80DA) + (#xE6F6 #x80D6) + (#xE6F7 #x8109) + (#xE6F8 #x80EF) + (#xE6F9 #x80F1) + (#xE6FA #x811B) + (#xE6FB #x8129) + (#xE6FC #x8123) + (#xE6FD #x812F) + (#xE6FE #x814B) + (#xE7A1 #x968B) + (#xE7A2 #x8146) + (#xE7A3 #x813E) + (#xE7A4 #x8153) + (#xE7A5 #x8151) + (#xE7A6 #x80FC) + (#xE7A7 #x8171) + (#xE7A8 #x816E) + (#xE7A9 #x8165) + (#xE7AA #x8166) + (#xE7AB #x8174) + (#xE7AC #x8183) + (#xE7AD #x8188) + (#xE7AE #x818A) + (#xE7AF #x8180) + (#xE7B0 #x8182) + (#xE7B1 #x81A0) + (#xE7B2 #x8195) + (#xE7B3 #x81A4) + (#xE7B4 #x81A3) + (#xE7B5 #x815F) + (#xE7B6 #x8193) + (#xE7B7 #x81A9) + (#xE7B8 #x81B0) + (#xE7B9 #x81B5) + (#xE7BA #x81BE) + (#xE7BB #x81B8) + (#xE7BC #x81BD) + (#xE7BD #x81C0) + (#xE7BE #x81C2) + (#xE7BF #x81BA) + (#xE7C0 #x81C9) + (#xE7C1 #x81CD) + (#xE7C2 #x81D1) + (#xE7C3 #x81D9) + (#xE7C4 #x81D8) + (#xE7C5 #x81C8) + (#xE7C6 #x81DA) + (#xE7C7 #x81DF) + (#xE7C8 #x81E0) + (#xE7C9 #x81E7) + (#xE7CA #x81FA) + (#xE7CB #x81FB) + (#xE7CC #x81FE) + (#xE7CD #x8201) + (#xE7CE #x8202) + (#xE7CF #x8205) + (#xE7D0 #x8207) + (#xE7D1 #x820A) + (#xE7D2 #x820D) + (#xE7D3 #x8210) + (#xE7D4 #x8216) + (#xE7D5 #x8229) + (#xE7D6 #x822B) + (#xE7D7 #x8238) + (#xE7D8 #x8233) + (#xE7D9 #x8240) + (#xE7DA #x8259) + (#xE7DB #x8258) + (#xE7DC #x825D) + (#xE7DD #x825A) + (#xE7DE #x825F) + (#xE7DF #x8264) + (#xE7E0 #x8262) + (#xE7E1 #x8268) + (#xE7E2 #x826A) + (#xE7E3 #x826B) + (#xE7E4 #x822E) + (#xE7E5 #x8271) + (#xE7E6 #x8277) + (#xE7E7 #x8278) + (#xE7E8 #x827E) + (#xE7E9 #x828D) + (#xE7EA #x8292) + (#xE7EB #x82AB) + (#xE7EC #x829F) + (#xE7ED #x82BB) + (#xE7EE #x82AC) + (#xE7EF #x82E1) + (#xE7F0 #x82E3) + (#xE7F1 #x82DF) + (#xE7F2 #x82D2) + (#xE7F3 #x82F4) + (#xE7F4 #x82F3) + (#xE7F5 #x82FA) + (#xE7F6 #x8393) + (#xE7F7 #x8303) + (#xE7F8 #x82FB) + (#xE7F9 #x82F9) + (#xE7FA #x82DE) + (#xE7FB #x8306) + (#xE7FC #x82DC) + (#xE7FD #x8309) + (#xE7FE #x82D9) + (#xE8A1 #x8335) + (#xE8A2 #x8334) + (#xE8A3 #x8316) + (#xE8A4 #x8332) + (#xE8A5 #x8331) + (#xE8A6 #x8340) + (#xE8A7 #x8339) + (#xE8A8 #x8350) + (#xE8A9 #x8345) + (#xE8AA #x832F) + (#xE8AB #x832B) + (#xE8AC #x8317) + (#xE8AD #x8318) + (#xE8AE #x8385) + (#xE8AF #x839A) + (#xE8B0 #x83AA) + (#xE8B1 #x839F) + (#xE8B2 #x83A2) + (#xE8B3 #x8396) + (#xE8B4 #x8323) + (#xE8B5 #x838E) + (#xE8B6 #x8387) + (#xE8B7 #x838A) + (#xE8B8 #x837C) + (#xE8B9 #x83B5) + (#xE8BA #x8373) + (#xE8BB #x8375) + (#xE8BC #x83A0) + (#xE8BD #x8389) + (#xE8BE #x83A8) + (#xE8BF #x83F4) + (#xE8C0 #x8413) + (#xE8C1 #x83EB) + (#xE8C2 #x83CE) + (#xE8C3 #x83FD) + (#xE8C4 #x8403) + (#xE8C5 #x83D8) + (#xE8C6 #x840B) + (#xE8C7 #x83C1) + (#xE8C8 #x83F7) + (#xE8C9 #x8407) + (#xE8CA #x83E0) + (#xE8CB #x83F2) + (#xE8CC #x840D) + (#xE8CD #x8422) + (#xE8CE #x8420) + (#xE8CF #x83BD) + (#xE8D0 #x8438) + (#xE8D1 #x8506) + (#xE8D2 #x83FB) + (#xE8D3 #x846D) + (#xE8D4 #x842A) + (#xE8D5 #x843C) + (#xE8D6 #x855A) + (#xE8D7 #x8484) + (#xE8D8 #x8477) + (#xE8D9 #x846B) + (#xE8DA #x84AD) + (#xE8DB #x846E) + (#xE8DC #x8482) + (#xE8DD #x8469) + (#xE8DE #x8446) + (#xE8DF #x842C) + (#xE8E0 #x846F) + (#xE8E1 #x8479) + (#xE8E2 #x8435) + (#xE8E3 #x84CA) + (#xE8E4 #x8462) + (#xE8E5 #x84B9) + (#xE8E6 #x84BF) + (#xE8E7 #x849F) + (#xE8E8 #x84D9) + (#xE8E9 #x84CD) + (#xE8EA #x84BB) + (#xE8EB #x84DA) + (#xE8EC #x84D0) + (#xE8ED #x84C1) + (#xE8EE #x84C6) + (#xE8EF #x84D6) + (#xE8F0 #x84A1) + (#xE8F1 #x8521) + (#xE8F2 #x84FF) + (#xE8F3 #x84F4) + (#xE8F4 #x8517) + (#xE8F5 #x8518) + (#xE8F6 #x852C) + (#xE8F7 #x851F) + (#xE8F8 #x8515) + (#xE8F9 #x8514) + (#xE8FA #x84FC) + (#xE8FB #x8540) + (#xE8FC #x8563) + (#xE8FD #x8558) + (#xE8FE #x8548) + (#xE9A1 #x8541) + (#xE9A2 #x8602) + (#xE9A3 #x854B) + (#xE9A4 #x8555) + (#xE9A5 #x8580) + (#xE9A6 #x85A4) + (#xE9A7 #x8588) + (#xE9A8 #x8591) + (#xE9A9 #x858A) + (#xE9AA #x85A8) + (#xE9AB #x856D) + (#xE9AC #x8594) + (#xE9AD #x859B) + (#xE9AE #x85EA) + (#xE9AF #x8587) + (#xE9B0 #x859C) + (#xE9B1 #x8577) + (#xE9B2 #x857E) + (#xE9B3 #x8590) + (#xE9B4 #x85C9) + (#xE9B5 #x85BA) + (#xE9B6 #x85CF) + (#xE9B7 #x85B9) + (#xE9B8 #x85D0) + (#xE9B9 #x85D5) + (#xE9BA #x85DD) + (#xE9BB #x85E5) + (#xE9BC #x85DC) + (#xE9BD #x85F9) + (#xE9BE #x860A) + (#xE9BF #x8613) + (#xE9C0 #x860B) + (#xE9C1 #x85FE) + (#xE9C2 #x85FA) + (#xE9C3 #x8606) + (#xE9C4 #x8622) + (#xE9C5 #x861A) + (#xE9C6 #x8630) + (#xE9C7 #x863F) + (#xE9C8 #x864D) + (#xE9C9 #x4E55) + (#xE9CA #x8654) + (#xE9CB #x865F) + (#xE9CC #x8667) + (#xE9CD #x8671) + (#xE9CE #x8693) + (#xE9CF #x86A3) + (#xE9D0 #x86A9) + (#xE9D1 #x86AA) + (#xE9D2 #x868B) + (#xE9D3 #x868C) + (#xE9D4 #x86B6) + (#xE9D5 #x86AF) + (#xE9D6 #x86C4) + (#xE9D7 #x86C6) + (#xE9D8 #x86B0) + (#xE9D9 #x86C9) + (#xE9DA #x8823) + (#xE9DB #x86AB) + (#xE9DC #x86D4) + (#xE9DD #x86DE) + (#xE9DE #x86E9) + (#xE9DF #x86EC) + (#xE9E0 #x86DF) + (#xE9E1 #x86DB) + (#xE9E2 #x86EF) + (#xE9E3 #x8712) + (#xE9E4 #x8706) + (#xE9E5 #x8708) + (#xE9E6 #x8700) + (#xE9E7 #x8703) + (#xE9E8 #x86FB) + (#xE9E9 #x8711) + (#xE9EA #x8709) + (#xE9EB #x870D) + (#xE9EC #x86F9) + (#xE9ED #x870A) + (#xE9EE #x8734) + (#xE9EF #x873F) + (#xE9F0 #x8737) + (#xE9F1 #x873B) + (#xE9F2 #x8725) + (#xE9F3 #x8729) + (#xE9F4 #x871A) + (#xE9F5 #x8760) + (#xE9F6 #x875F) + (#xE9F7 #x8778) + (#xE9F8 #x874C) + (#xE9F9 #x874E) + (#xE9FA #x8774) + (#xE9FB #x8757) + (#xE9FC #x8768) + (#xE9FD #x876E) + (#xE9FE #x8759) + (#xEAA1 #x8753) + (#xEAA2 #x8763) + (#xEAA3 #x876A) + (#xEAA4 #x8805) + (#xEAA5 #x87A2) + (#xEAA6 #x879F) + (#xEAA7 #x8782) + (#xEAA8 #x87AF) + (#xEAA9 #x87CB) + (#xEAAA #x87BD) + (#xEAAB #x87C0) + (#xEAAC #x87D0) + (#xEAAD #x96D6) + (#xEAAE #x87AB) + (#xEAAF #x87C4) + (#xEAB0 #x87B3) + (#xEAB1 #x87C7) + (#xEAB2 #x87C6) + (#xEAB3 #x87BB) + (#xEAB4 #x87EF) + (#xEAB5 #x87F2) + (#xEAB6 #x87E0) + (#xEAB7 #x880F) + (#xEAB8 #x880D) + (#xEAB9 #x87FE) + (#xEABA #x87F6) + (#xEABB #x87F7) + (#xEABC #x880E) + (#xEABD #x87D2) + (#xEABE #x8811) + (#xEABF #x8816) + (#xEAC0 #x8815) + (#xEAC1 #x8822) + (#xEAC2 #x8821) + (#xEAC3 #x8831) + (#xEAC4 #x8836) + (#xEAC5 #x8839) + (#xEAC6 #x8827) + (#xEAC7 #x883B) + (#xEAC8 #x8844) + (#xEAC9 #x8842) + (#xEACA #x8852) + (#xEACB #x8859) + (#xEACC #x885E) + (#xEACD #x8862) + (#xEACE #x886B) + (#xEACF #x8881) + (#xEAD0 #x887E) + (#xEAD1 #x889E) + (#xEAD2 #x8875) + (#xEAD3 #x887D) + (#xEAD4 #x88B5) + (#xEAD5 #x8872) + (#xEAD6 #x8882) + (#xEAD7 #x8897) + (#xEAD8 #x8892) + (#xEAD9 #x88AE) + (#xEADA #x8899) + (#xEADB #x88A2) + (#xEADC #x888D) + (#xEADD #x88A4) + (#xEADE #x88B0) + (#xEADF #x88BF) + (#xEAE0 #x88B1) + (#xEAE1 #x88C3) + (#xEAE2 #x88C4) + (#xEAE3 #x88D4) + (#xEAE4 #x88D8) + (#xEAE5 #x88D9) + (#xEAE6 #x88DD) + (#xEAE7 #x88F9) + (#xEAE8 #x8902) + (#xEAE9 #x88FC) + (#xEAEA #x88F4) + (#xEAEB #x88E8) + (#xEAEC #x88F2) + (#xEAED #x8904) + (#xEAEE #x890C) + (#xEAEF #x890A) + (#xEAF0 #x8913) + (#xEAF1 #x8943) + (#xEAF2 #x891E) + (#xEAF3 #x8925) + (#xEAF4 #x892A) + (#xEAF5 #x892B) + (#xEAF6 #x8941) + (#xEAF7 #x8944) + (#xEAF8 #x893B) + (#xEAF9 #x8936) + (#xEAFA #x8938) + (#xEAFB #x894C) + (#xEAFC #x891D) + (#xEAFD #x8960) + (#xEAFE #x895E) + (#xEBA1 #x8966) + (#xEBA2 #x8964) + (#xEBA3 #x896D) + (#xEBA4 #x896A) + (#xEBA5 #x896F) + (#xEBA6 #x8974) + (#xEBA7 #x8977) + (#xEBA8 #x897E) + (#xEBA9 #x8983) + (#xEBAA #x8988) + (#xEBAB #x898A) + (#xEBAC #x8993) + (#xEBAD #x8998) + (#xEBAE #x89A1) + (#xEBAF #x89A9) + (#xEBB0 #x89A6) + (#xEBB1 #x89AC) + (#xEBB2 #x89AF) + (#xEBB3 #x89B2) + (#xEBB4 #x89BA) + (#xEBB5 #x89BD) + (#xEBB6 #x89BF) + (#xEBB7 #x89C0) + (#xEBB8 #x89DA) + (#xEBB9 #x89DC) + (#xEBBA #x89DD) + (#xEBBB #x89E7) + (#xEBBC #x89F4) + (#xEBBD #x89F8) + (#xEBBE #x8A03) + (#xEBBF #x8A16) + (#xEBC0 #x8A10) + (#xEBC1 #x8A0C) + (#xEBC2 #x8A1B) + (#xEBC3 #x8A1D) + (#xEBC4 #x8A25) + (#xEBC5 #x8A36) + (#xEBC6 #x8A41) + (#xEBC7 #x8A5B) + (#xEBC8 #x8A52) + (#xEBC9 #x8A46) + (#xEBCA #x8A48) + (#xEBCB #x8A7C) + (#xEBCC #x8A6D) + (#xEBCD #x8A6C) + (#xEBCE #x8A62) + (#xEBCF #x8A85) + (#xEBD0 #x8A82) + (#xEBD1 #x8A84) + (#xEBD2 #x8AA8) + (#xEBD3 #x8AA1) + (#xEBD4 #x8A91) + (#xEBD5 #x8AA5) + (#xEBD6 #x8AA6) + (#xEBD7 #x8A9A) + (#xEBD8 #x8AA3) + (#xEBD9 #x8AC4) + (#xEBDA #x8ACD) + (#xEBDB #x8AC2) + (#xEBDC #x8ADA) + (#xEBDD #x8AEB) + (#xEBDE #x8AF3) + (#xEBDF #x8AE7) + (#xEBE0 #x8AE4) + (#xEBE1 #x8AF1) + (#xEBE2 #x8B14) + (#xEBE3 #x8AE0) + (#xEBE4 #x8AE2) + (#xEBE5 #x8AF7) + (#xEBE6 #x8ADE) + (#xEBE7 #x8ADB) + (#xEBE8 #x8B0C) + (#xEBE9 #x8B07) + (#xEBEA #x8B1A) + (#xEBEB #x8AE1) + (#xEBEC #x8B16) + (#xEBED #x8B10) + (#xEBEE #x8B17) + (#xEBEF #x8B20) + (#xEBF0 #x8B33) + (#xEBF1 #x97AB) + (#xEBF2 #x8B26) + (#xEBF3 #x8B2B) + (#xEBF4 #x8B3E) + (#xEBF5 #x8B28) + (#xEBF6 #x8B41) + (#xEBF7 #x8B4C) + (#xEBF8 #x8B4F) + (#xEBF9 #x8B4E) + (#xEBFA #x8B49) + (#xEBFB #x8B56) + (#xEBFC #x8B5B) + (#xEBFD #x8B5A) + (#xEBFE #x8B6B) + (#xECA1 #x8B5F) + (#xECA2 #x8B6C) + (#xECA3 #x8B6F) + (#xECA4 #x8B74) + (#xECA5 #x8B7D) + (#xECA6 #x8B80) + (#xECA7 #x8B8C) + (#xECA8 #x8B8E) + (#xECA9 #x8B92) + (#xECAA #x8B93) + (#xECAB #x8B96) + (#xECAC #x8B99) + (#xECAD #x8B9A) + (#xECAE #x8C3A) + (#xECAF #x8C41) + (#xECB0 #x8C3F) + (#xECB1 #x8C48) + (#xECB2 #x8C4C) + (#xECB3 #x8C4E) + (#xECB4 #x8C50) + (#xECB5 #x8C55) + (#xECB6 #x8C62) + (#xECB7 #x8C6C) + (#xECB8 #x8C78) + (#xECB9 #x8C7A) + (#xECBA #x8C82) + (#xECBB #x8C89) + (#xECBC #x8C85) + (#xECBD #x8C8A) + (#xECBE #x8C8D) + (#xECBF #x8C8E) + (#xECC0 #x8C94) + (#xECC1 #x8C7C) + (#xECC2 #x8C98) + (#xECC3 #x621D) + (#xECC4 #x8CAD) + (#xECC5 #x8CAA) + (#xECC6 #x8CBD) + (#xECC7 #x8CB2) + (#xECC8 #x8CB3) + (#xECC9 #x8CAE) + (#xECCA #x8CB6) + (#xECCB #x8CC8) + (#xECCC #x8CC1) + (#xECCD #x8CE4) + (#xECCE #x8CE3) + (#xECCF #x8CDA) + (#xECD0 #x8CFD) + (#xECD1 #x8CFA) + (#xECD2 #x8CFB) + (#xECD3 #x8D04) + (#xECD4 #x8D05) + (#xECD5 #x8D0A) + (#xECD6 #x8D07) + (#xECD7 #x8D0F) + (#xECD8 #x8D0D) + (#xECD9 #x8D10) + (#xECDA #x9F4E) + (#xECDB #x8D13) + (#xECDC #x8CCD) + (#xECDD #x8D14) + (#xECDE #x8D16) + (#xECDF #x8D67) + (#xECE0 #x8D6D) + (#xECE1 #x8D71) + (#xECE2 #x8D73) + (#xECE3 #x8D81) + (#xECE4 #x8D99) + (#xECE5 #x8DC2) + (#xECE6 #x8DBE) + (#xECE7 #x8DBA) + (#xECE8 #x8DCF) + (#xECE9 #x8DDA) + (#xECEA #x8DD6) + (#xECEB #x8DCC) + (#xECEC #x8DDB) + (#xECED #x8DCB) + (#xECEE #x8DEA) + (#xECEF #x8DEB) + (#xECF0 #x8DDF) + (#xECF1 #x8DE3) + (#xECF2 #x8DFC) + (#xECF3 #x8E08) + (#xECF4 #x8E09) + (#xECF5 #x8DFF) + (#xECF6 #x8E1D) + (#xECF7 #x8E1E) + (#xECF8 #x8E10) + (#xECF9 #x8E1F) + (#xECFA #x8E42) + (#xECFB #x8E35) + (#xECFC #x8E30) + (#xECFD #x8E34) + (#xECFE #x8E4A) + (#xEDA1 #x8E47) + (#xEDA2 #x8E49) + (#xEDA3 #x8E4C) + (#xEDA4 #x8E50) + (#xEDA5 #x8E48) + (#xEDA6 #x8E59) + (#xEDA7 #x8E64) + (#xEDA8 #x8E60) + (#xEDA9 #x8E2A) + (#xEDAA #x8E63) + (#xEDAB #x8E55) + (#xEDAC #x8E76) + (#xEDAD #x8E72) + (#xEDAE #x8E7C) + (#xEDAF #x8E81) + (#xEDB0 #x8E87) + (#xEDB1 #x8E85) + (#xEDB2 #x8E84) + (#xEDB3 #x8E8B) + (#xEDB4 #x8E8A) + (#xEDB5 #x8E93) + (#xEDB6 #x8E91) + (#xEDB7 #x8E94) + (#xEDB8 #x8E99) + (#xEDB9 #x8EAA) + (#xEDBA #x8EA1) + (#xEDBB #x8EAC) + (#xEDBC #x8EB0) + (#xEDBD #x8EC6) + (#xEDBE #x8EB1) + (#xEDBF #x8EBE) + (#xEDC0 #x8EC5) + (#xEDC1 #x8EC8) + (#xEDC2 #x8ECB) + (#xEDC3 #x8EDB) + (#xEDC4 #x8EE3) + (#xEDC5 #x8EFC) + (#xEDC6 #x8EFB) + (#xEDC7 #x8EEB) + (#xEDC8 #x8EFE) + (#xEDC9 #x8F0A) + (#xEDCA #x8F05) + (#xEDCB #x8F15) + (#xEDCC #x8F12) + (#xEDCD #x8F19) + (#xEDCE #x8F13) + (#xEDCF #x8F1C) + (#xEDD0 #x8F1F) + (#xEDD1 #x8F1B) + (#xEDD2 #x8F0C) + (#xEDD3 #x8F26) + (#xEDD4 #x8F33) + (#xEDD5 #x8F3B) + (#xEDD6 #x8F39) + (#xEDD7 #x8F45) + (#xEDD8 #x8F42) + (#xEDD9 #x8F3E) + (#xEDDA #x8F4C) + (#xEDDB #x8F49) + (#xEDDC #x8F46) + (#xEDDD #x8F4E) + (#xEDDE #x8F57) + (#xEDDF #x8F5C) + (#xEDE0 #x8F62) + (#xEDE1 #x8F63) + (#xEDE2 #x8F64) + (#xEDE3 #x8F9C) + (#xEDE4 #x8F9F) + (#xEDE5 #x8FA3) + (#xEDE6 #x8FAD) + (#xEDE7 #x8FAF) + (#xEDE8 #x8FB7) + (#xEDE9 #x8FDA) + (#xEDEA #x8FE5) + (#xEDEB #x8FE2) + (#xEDEC #x8FEA) + (#xEDED #x8FEF) + (#xEDEE #x9087) + (#xEDEF #x8FF4) + (#xEDF0 #x9005) + (#xEDF1 #x8FF9) + (#xEDF2 #x8FFA) + (#xEDF3 #x9011) + (#xEDF4 #x9015) + (#xEDF5 #x9021) + (#xEDF6 #x900D) + (#xEDF7 #x901E) + (#xEDF8 #x9016) + (#xEDF9 #x900B) + (#xEDFA #x9027) + (#xEDFB #x9036) + (#xEDFC #x9035) + (#xEDFD #x9039) + (#xEDFE #x8FF8) + (#xEEA1 #x904F) + (#xEEA2 #x9050) + (#xEEA3 #x9051) + (#xEEA4 #x9052) + (#xEEA5 #x900E) + (#xEEA6 #x9049) + (#xEEA7 #x903E) + (#xEEA8 #x9056) + (#xEEA9 #x9058) + (#xEEAA #x905E) + (#xEEAB #x9068) + (#xEEAC #x906F) + (#xEEAD #x9076) + (#xEEAE #x96A8) + (#xEEAF #x9072) + (#xEEB0 #x9082) + (#xEEB1 #x907D) + (#xEEB2 #x9081) + (#xEEB3 #x9080) + (#xEEB4 #x908A) + (#xEEB5 #x9089) + (#xEEB6 #x908F) + (#xEEB7 #x90A8) + (#xEEB8 #x90AF) + (#xEEB9 #x90B1) + (#xEEBA #x90B5) + (#xEEBB #x90E2) + (#xEEBC #x90E4) + (#xEEBD #x6248) + (#xEEBE #x90DB) + (#xEEBF #x9102) + (#xEEC0 #x9112) + (#xEEC1 #x9119) + (#xEEC2 #x9132) + (#xEEC3 #x9130) + (#xEEC4 #x914A) + (#xEEC5 #x9156) + (#xEEC6 #x9158) + (#xEEC7 #x9163) + (#xEEC8 #x9165) + (#xEEC9 #x9169) + (#xEECA #x9173) + (#xEECB #x9172) + (#xEECC #x918B) + (#xEECD #x9189) + (#xEECE #x9182) + (#xEECF #x91A2) + (#xEED0 #x91AB) + (#xEED1 #x91AF) + (#xEED2 #x91AA) + (#xEED3 #x91B5) + (#xEED4 #x91B4) + (#xEED5 #x91BA) + (#xEED6 #x91C0) + (#xEED7 #x91C1) + (#xEED8 #x91C9) + (#xEED9 #x91CB) + (#xEEDA #x91D0) + (#xEEDB #x91D6) + (#xEEDC #x91DF) + (#xEEDD #x91E1) + (#xEEDE #x91DB) + (#xEEDF #x91FC) + (#xEEE0 #x91F5) + (#xEEE1 #x91F6) + (#xEEE2 #x921E) + (#xEEE3 #x91FF) + (#xEEE4 #x9214) + (#xEEE5 #x922C) + (#xEEE6 #x9215) + (#xEEE7 #x9211) + (#xEEE8 #x925E) + (#xEEE9 #x9257) + (#xEEEA #x9245) + (#xEEEB #x9249) + (#xEEEC #x9264) + (#xEEED #x9248) + (#xEEEE #x9295) + (#xEEEF #x923F) + (#xEEF0 #x924B) + (#xEEF1 #x9250) + (#xEEF2 #x929C) + (#xEEF3 #x9296) + (#xEEF4 #x9293) + (#xEEF5 #x929B) + (#xEEF6 #x925A) + (#xEEF7 #x92CF) + (#xEEF8 #x92B9) + (#xEEF9 #x92B7) + (#xEEFA #x92E9) + (#xEEFB #x930F) + (#xEEFC #x92FA) + (#xEEFD #x9344) + (#xEEFE #x932E) + (#xEFA1 #x9319) + (#xEFA2 #x9322) + (#xEFA3 #x931A) + (#xEFA4 #x9323) + (#xEFA5 #x933A) + (#xEFA6 #x9335) + (#xEFA7 #x933B) + (#xEFA8 #x935C) + (#xEFA9 #x9360) + (#xEFAA #x937C) + (#xEFAB #x936E) + (#xEFAC #x9356) + (#xEFAD #x93B0) + (#xEFAE #x93AC) + (#xEFAF #x93AD) + (#xEFB0 #x9394) + (#xEFB1 #x93B9) + (#xEFB2 #x93D6) + (#xEFB3 #x93D7) + (#xEFB4 #x93E8) + (#xEFB5 #x93E5) + (#xEFB6 #x93D8) + (#xEFB7 #x93C3) + (#xEFB8 #x93DD) + (#xEFB9 #x93D0) + (#xEFBA #x93C8) + (#xEFBB #x93E4) + (#xEFBC #x941A) + (#xEFBD #x9414) + (#xEFBE #x9413) + (#xEFBF #x9403) + (#xEFC0 #x9407) + (#xEFC1 #x9410) + (#xEFC2 #x9436) + (#xEFC3 #x942B) + (#xEFC4 #x9435) + (#xEFC5 #x9421) + (#xEFC6 #x943A) + (#xEFC7 #x9441) + (#xEFC8 #x9452) + (#xEFC9 #x9444) + (#xEFCA #x945B) + (#xEFCB #x9460) + (#xEFCC #x9462) + (#xEFCD #x945E) + (#xEFCE #x946A) + (#xEFCF #x9229) + (#xEFD0 #x9470) + (#xEFD1 #x9475) + (#xEFD2 #x9477) + (#xEFD3 #x947D) + (#xEFD4 #x945A) + (#xEFD5 #x947C) + (#xEFD6 #x947E) + (#xEFD7 #x9481) + (#xEFD8 #x947F) + (#xEFD9 #x9582) + (#xEFDA #x9587) + (#xEFDB #x958A) + (#xEFDC #x9594) + (#xEFDD #x9596) + (#xEFDE #x9598) + (#xEFDF #x9599) + (#xEFE0 #x95A0) + (#xEFE1 #x95A8) + (#xEFE2 #x95A7) + (#xEFE3 #x95AD) + (#xEFE4 #x95BC) + (#xEFE5 #x95BB) + (#xEFE6 #x95B9) + (#xEFE7 #x95BE) + (#xEFE8 #x95CA) + (#xEFE9 #x6FF6) + (#xEFEA #x95C3) + (#xEFEB #x95CD) + (#xEFEC #x95CC) + (#xEFED #x95D5) + (#xEFEE #x95D4) + (#xEFEF #x95D6) + (#xEFF0 #x95DC) + (#xEFF1 #x95E1) + (#xEFF2 #x95E5) + (#xEFF3 #x95E2) + (#xEFF4 #x9621) + (#xEFF5 #x9628) + (#xEFF6 #x962E) + (#xEFF7 #x962F) + (#xEFF8 #x9642) + (#xEFF9 #x964C) + (#xEFFA #x964F) + (#xEFFB #x964B) + (#xEFFC #x9677) + (#xEFFD #x965C) + (#xEFFE #x965E) + (#xF0A1 #x965D) + (#xF0A2 #x965F) + (#xF0A3 #x9666) + (#xF0A4 #x9672) + (#xF0A5 #x966C) + (#xF0A6 #x968D) + (#xF0A7 #x9698) + (#xF0A8 #x9695) + (#xF0A9 #x9697) + (#xF0AA #x96AA) + (#xF0AB #x96A7) + (#xF0AC #x96B1) + (#xF0AD #x96B2) + (#xF0AE #x96B0) + (#xF0AF #x96B4) + (#xF0B0 #x96B6) + (#xF0B1 #x96B8) + (#xF0B2 #x96B9) + (#xF0B3 #x96CE) + (#xF0B4 #x96CB) + (#xF0B5 #x96C9) + (#xF0B6 #x96CD) + (#xF0B7 #x894D) + (#xF0B8 #x96DC) + (#xF0B9 #x970D) + (#xF0BA #x96D5) + (#xF0BB #x96F9) + (#xF0BC #x9704) + (#xF0BD #x9706) + (#xF0BE #x9708) + (#xF0BF #x9713) + (#xF0C0 #x970E) + (#xF0C1 #x9711) + (#xF0C2 #x970F) + (#xF0C3 #x9716) + (#xF0C4 #x9719) + (#xF0C5 #x9724) + (#xF0C6 #x972A) + (#xF0C7 #x9730) + (#xF0C8 #x9739) + (#xF0C9 #x973D) + (#xF0CA #x973E) + (#xF0CB #x9744) + (#xF0CC #x9746) + (#xF0CD #x9748) + (#xF0CE #x9742) + (#xF0CF #x9749) + (#xF0D0 #x975C) + (#xF0D1 #x9760) + (#xF0D2 #x9764) + (#xF0D3 #x9766) + (#xF0D4 #x9768) + (#xF0D5 #x52D2) + (#xF0D6 #x976B) + (#xF0D7 #x9771) + (#xF0D8 #x9779) + (#xF0D9 #x9785) + (#xF0DA #x977C) + (#xF0DB #x9781) + (#xF0DC #x977A) + (#xF0DD #x9786) + (#xF0DE #x978B) + (#xF0DF #x978F) + (#xF0E0 #x9790) + (#xF0E1 #x979C) + (#xF0E2 #x97A8) + (#xF0E3 #x97A6) + (#xF0E4 #x97A3) + (#xF0E5 #x97B3) + (#xF0E6 #x97B4) + (#xF0E7 #x97C3) + (#xF0E8 #x97C6) + (#xF0E9 #x97C8) + (#xF0EA #x97CB) + (#xF0EB #x97DC) + (#xF0EC #x97ED) + (#xF0ED #x9F4F) + (#xF0EE #x97F2) + (#xF0EF #x7ADF) + (#xF0F0 #x97F6) + (#xF0F1 #x97F5) + (#xF0F2 #x980F) + (#xF0F3 #x980C) + (#xF0F4 #x9838) + (#xF0F5 #x9824) + (#xF0F6 #x9821) + (#xF0F7 #x9837) + (#xF0F8 #x983D) + (#xF0F9 #x9846) + (#xF0FA #x984F) + (#xF0FB #x984B) + (#xF0FC #x986B) + (#xF0FD #x986F) + (#xF0FE #x9870) + (#xF1A1 #x9871) + (#xF1A2 #x9874) + (#xF1A3 #x9873) + (#xF1A4 #x98AA) + (#xF1A5 #x98AF) + (#xF1A6 #x98B1) + (#xF1A7 #x98B6) + (#xF1A8 #x98C4) + (#xF1A9 #x98C3) + (#xF1AA #x98C6) + (#xF1AB #x98E9) + (#xF1AC #x98EB) + (#xF1AD #x9903) + (#xF1AE #x9909) + (#xF1AF #x9912) + (#xF1B0 #x9914) + (#xF1B1 #x9918) + (#xF1B2 #x9921) + (#xF1B3 #x991D) + (#xF1B4 #x991E) + (#xF1B5 #x9924) + (#xF1B6 #x9920) + (#xF1B7 #x992C) + (#xF1B8 #x992E) + (#xF1B9 #x993D) + (#xF1BA #x993E) + (#xF1BB #x9942) + (#xF1BC #x9949) + (#xF1BD #x9945) + (#xF1BE #x9950) + (#xF1BF #x994B) + (#xF1C0 #x9951) + (#xF1C1 #x9952) + (#xF1C2 #x994C) + (#xF1C3 #x9955) + (#xF1C4 #x9997) + (#xF1C5 #x9998) + (#xF1C6 #x99A5) + (#xF1C7 #x99AD) + (#xF1C8 #x99AE) + (#xF1C9 #x99BC) + (#xF1CA #x99DF) + (#xF1CB #x99DB) + (#xF1CC #x99DD) + (#xF1CD #x99D8) + (#xF1CE #x99D1) + (#xF1CF #x99ED) + (#xF1D0 #x99EE) + (#xF1D1 #x99F1) + (#xF1D2 #x99F2) + (#xF1D3 #x99FB) + (#xF1D4 #x99F8) + (#xF1D5 #x9A01) + (#xF1D6 #x9A0F) + (#xF1D7 #x9A05) + (#xF1D8 #x99E2) + (#xF1D9 #x9A19) + (#xF1DA #x9A2B) + (#xF1DB #x9A37) + (#xF1DC #x9A45) + (#xF1DD #x9A42) + (#xF1DE #x9A40) + (#xF1DF #x9A43) + (#xF1E0 #x9A3E) + (#xF1E1 #x9A55) + (#xF1E2 #x9A4D) + (#xF1E3 #x9A5B) + (#xF1E4 #x9A57) + (#xF1E5 #x9A5F) + (#xF1E6 #x9A62) + (#xF1E7 #x9A65) + (#xF1E8 #x9A64) + (#xF1E9 #x9A69) + (#xF1EA #x9A6B) + (#xF1EB #x9A6A) + (#xF1EC #x9AAD) + (#xF1ED #x9AB0) + (#xF1EE #x9ABC) + (#xF1EF #x9AC0) + (#xF1F0 #x9ACF) + (#xF1F1 #x9AD1) + (#xF1F2 #x9AD3) + (#xF1F3 #x9AD4) + (#xF1F4 #x9ADE) + (#xF1F5 #x9ADF) + (#xF1F6 #x9AE2) + (#xF1F7 #x9AE3) + (#xF1F8 #x9AE6) + (#xF1F9 #x9AEF) + (#xF1FA #x9AEB) + (#xF1FB #x9AEE) + (#xF1FC #x9AF4) + (#xF1FD #x9AF1) + (#xF1FE #x9AF7) + (#xF2A1 #x9AFB) + (#xF2A2 #x9B06) + (#xF2A3 #x9B18) + (#xF2A4 #x9B1A) + (#xF2A5 #x9B1F) + (#xF2A6 #x9B22) + (#xF2A7 #x9B23) + (#xF2A8 #x9B25) + (#xF2A9 #x9B27) + (#xF2AA #x9B28) + (#xF2AB #x9B29) + (#xF2AC #x9B2A) + (#xF2AD #x9B2E) + (#xF2AE #x9B2F) + (#xF2AF #x9B32) + (#xF2B0 #x9B44) + (#xF2B1 #x9B43) + (#xF2B2 #x9B4F) + (#xF2B3 #x9B4D) + (#xF2B4 #x9B4E) + (#xF2B5 #x9B51) + (#xF2B6 #x9B58) + (#xF2B7 #x9B74) + (#xF2B8 #x9B93) + (#xF2B9 #x9B83) + (#xF2BA #x9B91) + (#xF2BB #x9B96) + (#xF2BC #x9B97) + (#xF2BD #x9B9F) + (#xF2BE #x9BA0) + (#xF2BF #x9BA8) + (#xF2C0 #x9BB4) + (#xF2C1 #x9BC0) + (#xF2C2 #x9BCA) + (#xF2C3 #x9BB9) + (#xF2C4 #x9BC6) + (#xF2C5 #x9BCF) + (#xF2C6 #x9BD1) + (#xF2C7 #x9BD2) + (#xF2C8 #x9BE3) + (#xF2C9 #x9BE2) + (#xF2CA #x9BE4) + (#xF2CB #x9BD4) + (#xF2CC #x9BE1) + (#xF2CD #x9C3A) + (#xF2CE #x9BF2) + (#xF2CF #x9BF1) + (#xF2D0 #x9BF0) + (#xF2D1 #x9C15) + (#xF2D2 #x9C14) + (#xF2D3 #x9C09) + (#xF2D4 #x9C13) + (#xF2D5 #x9C0C) + (#xF2D6 #x9C06) + (#xF2D7 #x9C08) + (#xF2D8 #x9C12) + (#xF2D9 #x9C0A) + (#xF2DA #x9C04) + (#xF2DB #x9C2E) + (#xF2DC #x9C1B) + (#xF2DD #x9C25) + (#xF2DE #x9C24) + (#xF2DF #x9C21) + (#xF2E0 #x9C30) + (#xF2E1 #x9C47) + (#xF2E2 #x9C32) + (#xF2E3 #x9C46) + (#xF2E4 #x9C3E) + (#xF2E5 #x9C5A) + (#xF2E6 #x9C60) + (#xF2E7 #x9C67) + (#xF2E8 #x9C76) + (#xF2E9 #x9C78) + (#xF2EA #x9CE7) + (#xF2EB #x9CEC) + (#xF2EC #x9CF0) + (#xF2ED #x9D09) + (#xF2EE #x9D08) + (#xF2EF #x9CEB) + (#xF2F0 #x9D03) + (#xF2F1 #x9D06) + (#xF2F2 #x9D2A) + (#xF2F3 #x9D26) + (#xF2F4 #x9DAF) + (#xF2F5 #x9D23) + (#xF2F6 #x9D1F) + (#xF2F7 #x9D44) + (#xF2F8 #x9D15) + (#xF2F9 #x9D12) + (#xF2FA #x9D41) + (#xF2FB #x9D3F) + (#xF2FC #x9D3E) + (#xF2FD #x9D46) + (#xF2FE #x9D48) + (#xF3A1 #x9D5D) + (#xF3A2 #x9D5E) + (#xF3A3 #x9D64) + (#xF3A4 #x9D51) + (#xF3A5 #x9D50) + (#xF3A6 #x9D59) + (#xF3A7 #x9D72) + (#xF3A8 #x9D89) + (#xF3A9 #x9D87) + (#xF3AA #x9DAB) + (#xF3AB #x9D6F) + (#xF3AC #x9D7A) + (#xF3AD #x9D9A) + (#xF3AE #x9DA4) + (#xF3AF #x9DA9) + (#xF3B0 #x9DB2) + (#xF3B1 #x9DC4) + (#xF3B2 #x9DC1) + (#xF3B3 #x9DBB) + (#xF3B4 #x9DB8) + (#xF3B5 #x9DBA) + (#xF3B6 #x9DC6) + (#xF3B7 #x9DCF) + (#xF3B8 #x9DC2) + (#xF3B9 #x9DD9) + (#xF3BA #x9DD3) + (#xF3BB #x9DF8) + (#xF3BC #x9DE6) + (#xF3BD #x9DED) + (#xF3BE #x9DEF) + (#xF3BF #x9DFD) + (#xF3C0 #x9E1A) + (#xF3C1 #x9E1B) + (#xF3C2 #x9E1E) + (#xF3C3 #x9E75) + (#xF3C4 #x9E79) + (#xF3C5 #x9E7D) + (#xF3C6 #x9E81) + (#xF3C7 #x9E88) + (#xF3C8 #x9E8B) + (#xF3C9 #x9E8C) + (#xF3CA #x9E92) + (#xF3CB #x9E95) + (#xF3CC #x9E91) + (#xF3CD #x9E9D) + (#xF3CE #x9EA5) + (#xF3CF #x9EA9) + (#xF3D0 #x9EB8) + (#xF3D1 #x9EAA) + (#xF3D2 #x9EAD) + (#xF3D3 #x9761) + (#xF3D4 #x9ECC) + (#xF3D5 #x9ECE) + (#xF3D6 #x9ECF) + (#xF3D7 #x9ED0) + (#xF3D8 #x9ED4) + (#xF3D9 #x9EDC) + (#xF3DA #x9EDE) + (#xF3DB #x9EDD) + (#xF3DC #x9EE0) + (#xF3DD #x9EE5) + (#xF3DE #x9EE8) + (#xF3DF #x9EEF) + (#xF3E0 #x9EF4) + (#xF3E1 #x9EF6) + (#xF3E2 #x9EF7) + (#xF3E3 #x9EF9) + (#xF3E4 #x9EFB) + (#xF3E5 #x9EFC) + (#xF3E6 #x9EFD) + (#xF3E7 #x9F07) + (#xF3E8 #x9F08) + (#xF3E9 #x76B7) + (#xF3EA #x9F15) + (#xF3EB #x9F21) + (#xF3EC #x9F2C) + (#xF3ED #x9F3E) + (#xF3EE #x9F4A) + (#xF3EF #x9F52) + (#xF3F0 #x9F54) + (#xF3F1 #x9F63) + (#xF3F2 #x9F5F) + (#xF3F3 #x9F60) + (#xF3F4 #x9F61) + (#xF3F5 #x9F66) + (#xF3F6 #x9F67) + (#xF3F7 #x9F6C) + (#xF3F8 #x9F6A) + (#xF3F9 #x9F77) + (#xF3FA #x9F72) + (#xF3FB #x9F76) + (#xF3FC #x9F95) + (#xF3FD #x9F9C) + (#xF3FE #x9FA0) + (#xF4A1 #x582F) + (#xF4A2 #x69C7) + (#xF4A3 #x9059) + (#xF4A4 #x7464) + (#xF4A5 #x51DC) + (#xF4A6 #x7199) + ))) + + (dolist (i `((,cp932-only + ,*cp932-to-ucs-hash* + ,*ucs-to-cp932-hash*) + (,eucjp-only + ,*eucjp-to-ucs-hash* + ,*ucs-to-eucjp-hash*) + (,eucjp + ,*eucjp-to-ucs-hash* + ,*ucs-to-eucjp-hash*))) + (dolist (j (first i)) + (setf (gethash (car j) (second i)) (cadr j)) + (setf (gethash (cadr j) (third i)) (car j)))) + + (flet ((euc-cp932 (x) + (let ((high (ash x -16)) + (mid (logand (ash x -8) 255)) + (low (logand x 255))) + (cond ((not (zerop high)) + nil) + ((= mid #x8e) + (logand x 255)) + ((zerop mid) + x) + ((decf mid #xa1) + (decf low #x80) + (incf low (if (zerop (logand mid 1)) #x1f #x7e)) + (incf low (if (<= #x7f low #x9d) 1 0)) + (setq mid (ash mid -1)) + (incf mid (if (<= mid #x1e) #x81 #xc1)) + (+ (ash mid 8) low)))))) + (dolist (i eucjp) + (let ((cp932 (euc-cp932 (first i)))) + (setf (gethash cp932 *cp932-to-ucs-hash*) (second i)) + (setf (gethash (second i) *ucs-to-cp932-hash*) cp932)))) + +;; ascii + (loop for i from #x00 to #x7f + do + (setf (gethash i *cp932-to-ucs-hash*) i) + (setf (gethash i *eucjp-to-ucs-hash*) i) + (setf (gethash i *ucs-to-eucjp-hash*) i) + (setf (gethash i *ucs-to-cp932-hash*) i)) + +;; half-width katakana + (loop for i from #xa1 to #xdf + do + (setf (gethash i *cp932-to-ucs-hash*) (+ #xff61 #x-a1 i)) + (setf (gethash (+ #xff61 #x-a1 i) *ucs-to-cp932-hash*) i) + (setf (gethash (+ #x8e00 i) *eucjp-to-ucs-hash*) (+ #xff61 #x-a1 i)) + (setf (gethash (+ #xff61 #x-a1 i) *ucs-to-eucjp-hash*) (+ #x8e00 i)))) + +(defun eucjp-to-ucs (code) + (values (gethash code *eucjp-to-ucs-hash*))) + +(defun ucs-to-eucjp (code) + (values (gethash code *ucs-to-eucjp-hash*))) + +(defun cp932-to-ucs (code) + (values (gethash code *cp932-to-ucs-hash*))) + +(defun ucs-to-cp932 (code) + (values (gethash code *ucs-to-cp932-hash*))) + + +(defmacro define-jp-encoding (name docstring aliases max-units-per-char + from-ucs + to-ucs + length-by-code + length-by-1st-unit) + `(define-character-encoding ,name + ,docstring + :aliases ,aliases + :native-endianness nil + :max-units-per-char ,max-units-per-char + :stream-encode-function + (lambda (char write-function stream) + (let ((code (,from-ucs (char-code char)))) + (cond ((null code) + (funcall write-function stream #.(char-code #\?)) + 1) + ((< code #x100) + (funcall write-function stream code) + 1) + ((< code #x10000) + (funcall write-function stream (logand #xff (ash code -8))) + (funcall write-function stream (logand code #xff)) + 2) + (t + (funcall write-function stream (logand #xff (ash code -16))) + (funcall write-function stream (logand #xff (ash code -8))) + (funcall write-function stream (logand code #xff)) + 3)))) + :stream-decode-function + (lambda (1st-unit next-unit-function stream) + (declare (type (unsigned-byte 8) 1st-unit)) + (let ((code + (case ,length-by-1st-unit + (3 (let ((2nd-unit (funcall next-unit-function stream))) + (if (eq 2nd-unit :eof) + :eof + (let ((3rd-unit (funcall next-unit-function stream))) + (if (eq 3rd-unit :eof) + :eof + (logior #x8f0000 + (ash 2nd-unit 8) + 3rd-unit)))))) + (2 (let ((2nd-unit (funcall next-unit-function stream))) + (if (eq 2nd-unit :eof) + :eof + (logior (ash 1st-unit 8) + 2nd-unit)))) + (1 1st-unit)))) + (if (eq code :eof) + :eof + (let ((ucs (,to-ucs code))) + (if ucs + (code-char ucs) + #\?))))) + :vector-encode-function + (lambda (string vector idx start end) + (declare (type (simple-array (unsigned-byte 8) (*)) vector) + (fixnum idx)) + (do* ((i start (1+ i))) + ((>= i end) idx) + (let* ((char (schar string i)) + (code (,from-ucs (char-code char)))) + (cond ((null code) + (setf (aref vector idx) #.(char-code #\?)) + (incf idx)) + ((< code #x100) + (setf (aref vector idx) code) + (incf idx)) + ((< code #x10000) + (setf (aref vector idx) (logand #xff (ash code -8))) + (setf (aref vector (the fixnum (1+ idx))) (logand code #xff)) + (incf idx 2)) + (t + (setf (aref vector idx) (logand #xff (ash code -16))) + (setf (aref vector (the fixnum (1+ idx))) + (logand #xff (ash code -8))) + (setf (aref vector (the fixnum (+ idx 2))) (logand code #xff)) + (incf idx 3)))))) + :vector-decode-function + (lambda (vector idx noctets string) + (declare (type (simple-array (unsigned-byte 8) (*)) vector) + (type index idx)) + (do* ((i 0 (1+ i)) + (end (+ idx noctets)) + (index idx (1+ index))) + ((= index end) index) + (let* ((1st-unit (aref vector index))) + (declare (type (unsigned-byte 8) 1st-unit)) + (let* ((code (,to-ucs + (case ,length-by-1st-unit + (3 (logior + #x8f0000 + (ash (aref vector (incf index)) 8) + (aref vector (incf index)))) + (2 (logior + (ash 1st-unit 8) + (aref vector (incf index)))) + (1 1st-unit)))) + (char (and code (code-char code)))) + (setf (schar string i) (or char #\?)))))) + :memory-encode-function + (lambda (string pointer idx start end) + (declare (fixnum idx)) + (do* ((i start (1+ i))) + ((>= i end) idx) + (let* ((code (,from-ucs (char-code (schar string i))))) + (cond ((null code) + (setf (%get-unsigned-byte pointer idx) #.(char-code #\?)) + (incf idx)) + ((< code #x100) + (setf (%get-unsigned-byte pointer idx) code) + (incf idx)) + ((< code #x10000) + (setf (%get-unsigned-byte pointer idx) + (logand #xff (ash code -8))) + (setf (%get-unsigned-byte pointer (the fixnum (1+ idx))) + (logand code #xff)) + (incf idx 2)) + (t + (setf (%get-unsigned-byte pointer idx) + (logand #xff (ash code -16))) + (setf (%get-unsigned-byte pointer (the fixnum (1+ idx))) + (logand #xff (ash code -8))) + (setf (%get-unsigned-byte pointer (the fixnum (+ 2 idx))) + (logand code #xff)) + (incf idx 3)))))) + :memory-decode-function + (lambda (pointer noctets idx string) + (declare (fixnum noctets idx)) + (do* ((i 0 (1+ i)) + (end (+ idx noctets)) + (index idx (1+ index))) + ((>= index end) (if (= index end) index 0)) + (let* ((1st-unit (%get-unsigned-byte pointer index))) + (declare (type (unsigned-byte 8) 1st-unit)) + (let* ((code + (,to-ucs + (case ,length-by-1st-unit + (3 (logior + #x8f0000 + (ash (%get-unsigned-byte + pointer (incf index)) 8) + (%get-unsigned-byte pointer (incf index)))) + (2 (logior + (ash 1st-unit 8) + (%get-unsigned-byte pointer (incf index)))) + (1 1st-unit)))) + (char (if code (code-char code) #\?))) + (setf (schar string i) char))))) + :octets-in-string-function + (lambda (string start end) + (if (>= end start) + (do* ((noctets 0) + (i start (1+ i))) + ((= i end) noctets) + (declare (fixnum noctets)) + (let* ((code (,from-ucs (char-code (schar string i))))) + (if code + (incf noctets ,length-by-code) + (incf noctets)))) + 0)) + :length-of-vector-encoding-function + (lambda (vector start end) + (declare (type (simple-array (unsigned-byte 8) (*)) vector)) + (do* ((i start) + (nchars 0)) + ((>= i end) + (values nchars i)) + (declare (fixnum i)) + (let* ((1st-unit (aref vector i)) + (nexti (+ i ,length-by-1st-unit))) + (declare (type (unsigned-byte 8) 1st-unit)) + (if (> nexti end) + (return (values nchars i)) + (setq nchars (1+ nchars) i nexti))))) + :length-of-memory-encoding-function + (lambda (pointer noctets start) + (do* ((i start) + (end (+ start noctets)) + (nchars 0 (1+ nchars))) + ((= i end) (values nchars (- i start))) + (let* ((1st-unit (%get-unsigned-byte pointer i)) + (nexti (+ i ,length-by-1st-unit))) + (declare (type (unsigned-byte 8) 1st-unit)) + (if (> nexti end) + (return (values nchars (- i start))) + (setq i nexti))))) + :decode-literal-code-unit-limit #x80 + :encode-literal-char-code-limit #x80 + :character-size-in-octets-function + (lambda (c) + (let ((code (,from-ucs (char-code c)))) + (if code + ,length-by-code + 1))))) + + +(define-jp-encoding :euc-jp + "An 8-bit, variable-length character encoding in which +character code points in the range #x00-#x7f can be encoded in a +single octet; characters with larger code values can be encoded +in 2 to 3 bytes." + '(:eucjp) + 3 + ucs-to-eucjp + eucjp-to-ucs + (cond ((< code #x100) 1) + ((< code #x10000) 2) + (t 3)) + (cond ((= 1st-unit #x8f) + 3) + ((or (= 1st-unit #x8e) + (< #xa0 1st-unit #xff)) + 2) + (t 1))) + +(define-jp-encoding :windows-31j + "An 8-bit, variable-length character encoding in which +character code points in the range #x00-#x7f can be encoded in a +single octet; characters with larger code values can be encoded +in 2 bytes." + '(:cp932 :csWindows31J) + 2 + ucs-to-cp932 + cp932-to-ucs + (cond ((< code #x100) 1) + (t 2)) + (cond ((or (<= #x81 1st-unit #x9f) + (<= #xe0 1st-unit #xfc)) + 2) + (t 1))) Index: /branches/new-random/library/leaks.lisp =================================================================== --- /branches/new-random/library/leaks.lisp (revision 13309) +++ /branches/new-random/library/leaks.lisp (revision 13309) @@ -0,0 +1,365 @@ +;;;-*-Mode: LISP; Package: ccl -*- +;;; +;;; Copyright (C) 2008-2009 Clozure Associates and contributors +;;; This file is part of Clozure CL. +;;; +;;; Clozure CL is licensed under the terms of the Lisp Lesser GNU Public +;;; License , known as the LLGPL and distributed with Clozure CL as the +;;; file "LICENSE". The LLGPL consists of a preamble and the LGPL, +;;; which is distributed with Clozure CL as the file "LGPL". Where these +;;; conflict, the preamble takes precedence. +;;; +;;; Clozure CL is referenced in the preamble as the "LIBRARY." +;;; +;;; The LLGPL is also available online at +;;; http://opensource.franz.com/preamble.html + +; leaks.lisp +; A few functions to help in finding memory leaks + +(in-package :ccl) + +;; Returns all objects that satisfy predicate of one of the types in +;; ccl::*heap-utilization-vector-type-names* +;; Note that these can contain stack-consed objects that are dead. +;; Use pointer-in-some-dynamic-area-p to be sure to follow only real objects +;; (ccl::heap-utilization) prints a useful list of object counts and sizes +;; per type. +(defun all-objects-of-type (type &optional predicate) + (let ((typecode (position type ccl::*heap-utilization-vector-type-names*)) + (res nil)) + (when typecode + (flet ((mapper (thing) + (when (and (eq typecode (ccl::typecode thing)) + (or (null predicate) (funcall predicate thing))) + (push thing res)))) + (declare (dynamic-extent #'mapper)) + (ccl::%map-areas #'mapper)) + res))) + +;; Counts objects that satisfy predicate of one of the types in +;; ccl::*heap-utilization-vector-type-names* +(defun count-objects-of-type (type &optional predicate) + (let ((typecode (position type ccl::*heap-utilization-vector-type-names*)) + (res 0)) + (when typecode + (flet ((mapper (thing) + (when (and (eq typecode (ccl::typecode thing)) + (or (null predicate) (funcall predicate thing))) + (incf res)))) + (declare (dynamic-extent #'mapper)) + (ccl::%map-areas #'mapper)) + res))) + +(defun count-conses () + (let ((res 0)) + (flet ((mapper (thing) + (when (consp thing) (incf res)))) + (declare (dynamic-extent #'mapper)) + (ccl::%map-areas #'mapper)) + res)) + +;; Like set-difference, but uses a hash table to go faster. +(defun fast-set-difference (list1 list2 &optional (test #'eq)) + (let ((hash (make-hash-table :test test)) + (res nil)) + (dolist (e1 list1) (setf (gethash e1 hash) t)) + (dolist (e2 list2) (remhash e2 hash)) + (maphash (lambda (k v) + (declare (ignore v)) + (push k res)) + hash) + res)) + +;; Returns all references to object. +;; Note that these can contain stack-consed objects that are dead. +;; Use pointer-in-some-dynamic-area-p to be sure to follow only real objects +(defun find-references (object) + (let ((res nil)) + (ccl::%map-areas + (lambda (thing) + (cond ((and (not (eq thing object)) + (ccl::uvectorp thing) + (not (ccl::ivectorp thing))) + (dotimes (i (ccl::uvsize thing)) + (when (eq object (ccl::uvref thing i)) + (push thing res) + (return)))) + ((consp thing) + (when(or (eq object (car thing)) + (eq object (cdr thing))) + (push thing res)))))) + res)) + +;; Return true if P is heap-consed +(defun pointer-in-some-dynamic-area-p (p) + (block found + (ccl::do-consing-areas (a) + (when (eql (%fixnum-ref a target::area.code) ccl::area-dynamic) + (when (ccl::%ptr-in-area-p p a) + (return-from found t)))))) + +;; Find all transitive referencers to object-or-list. If as-object is +;; true, just start with object-or-list. If as-object is false, then if +;; object-or-list is a list, start with its elements, and ignore its +;; cons cells. +;; Returns a hash table with the references as keys. +(defun transitive-referencers (object-or-list &optional as-object) + (let ((found (make-hash-table :test 'eq))) + (cond ((or (atom object-or-list) as-object) + (setf (gethash object-or-list found) t)) + (t (loop for cons on object-or-list + do + (setf (gethash cons found) t + (gethash (car cons) found) t)))) + (ccl:gc) + (format t "Searching") (finish-output) + (loop + (let ((added-one nil)) + (format t " ~d" (hash-table-count found)) (finish-output) + (ccl::%map-areas + (lambda (thing) + (unless (or (not (pointer-in-some-dynamic-area-p thing)) + (gethash thing found)) + (cond ((and (not (eq thing (ccl::nhash.vector found))) + (ccl::uvectorp thing) + (not (ccl::ivectorp thing)) + (not (packagep thing))) + (dotimes (i (ccl::uvsize thing)) + (let ((object (ccl::uvref thing i))) + (when (gethash object found) + (setf (gethash thing found) t + added-one t) + (return))))) + ((and (consp thing) + (pointer-in-some-dynamic-area-p (car thing)) + (pointer-in-some-dynamic-area-p (cdr thing))) + (when (or (gethash (car thing) found) + (gethash (cdr thing) found)) + (setf (gethash thing found) t))))))) + (unless added-one + (return)))) + (format t " done.~%") (finish-output) + ;; Eliminate any cons that is referenced by another cons. + ;; Also eliminate or replace objects that nobody will want to see. + (let ((cons-refs (make-hash-table :test 'eq)) + (additions nil)) + (loop for cons being the hash-keys of found + when (consp cons) + do + (when (consp (car cons)) + (setf (gethash (car cons) cons-refs) t)) + (when (consp (cdr cons)) + (setf (gethash (cdr cons) cons-refs) t))) + (loop for key being the hash-keys of found + when (or (and (consp key) (gethash key cons-refs)) + (and (consp key) (eq (car key) 'ccl::%function-source-note)) + (typep key 'ccl::hash-table-vector) + (when (and key + (typep key + #+x8664-target 'ccl::symbol-vector + #-x8664-target 'symbol + )) + (push (ccl::symvector->symptr key) additions) + t) + (when (typep key + #+x8664-target 'ccl::function-vector + #-x8664-target 'function + ) + (push (ccl::function-vector-to-function key) additions) + t)) + do + (remhash key found)) + (dolist (addition additions) + (setf (gethash addition found) t)) + (remhash object-or-list found) + (unless (or (atom object-or-list) as-object) + (loop for cons on object-or-list + do + (remhash cons found) + (remhash (car cons) found))) + found))) + +;; One convenient way to print the hash table returned by transitive-referencers +(defun print-referencers (hash &key + predicate + (pause-period 20) + (print-circle t) + (print-length 20) + (print-level 5)) + (let ((cnt 0) + (*print-circle* print-circle) + (*print-length* print-length) + (*print-level* print-level)) + (maphash (lambda (key value) + (declare (ignore value)) + (when (or (null predicate) (funcall predicate key)) + (format t "~s~%" key) + (when (> (incf cnt) pause-period) + (format t "Continue (Y/N)? ") + (unless (equalp (read-line) "Y") + (return-from print-referencers)) + (setq cnt 0)))) + hash))) + +;; Returns all the obsolete CLOS instances, those whose class has been +;; changed since they were created. Each will be updated as soon as +;; method dispatch is done on it." +(defun obsolete-instances (list) + (let ((res nil)) + (dolist (i list) + (when (eq 0 (ccl::%wrapper-hash-index (ccl::instance-class-wrapper i))) + (push i res))) + res)) + +;; Linux-only malloc leak finding +#+linux-target +(progn + +;; (ccl::start-mtrace LOGFILE) +;; Do some work. +;; (ccl::stop-mtrace) +;; (ccl::parse-mtrace-log LOGFILE) +(defun start-mtrace (log-file) + (touch log-file) + (setf log-file (probe-file log-file)) + (setenv "MALLOC_TRACE" (namestring log-file)) + (gc) + (#_mtrace)) + +(defun stop-mtrace () + (gc) + (#_muntrace)) + +(defun parse-mtrace-log (log-file) + (with-open-file (s log-file) + (let ((hash (make-hash-table :test 'equal)) + (free-list '()) + (eof (list :eof))) + (loop for line = (read-line s nil eof) + until (eq line eof) + when (and (> (length line) 2) + (equal "@ " (subseq line 0 2))) + do + (setf line (subseq line 2)) + (let ((plus-pos (or (search " + " line) (search " > " line))) + (minus-pos (or (search " - " line) (search " < " line)))) + (cond (plus-pos + (let* ((where (subseq line 0 plus-pos)) + (addr-and-size (subseq line (+ plus-pos 3))) + (space-pos (position #\space addr-and-size)) + (addr (subseq addr-and-size 0 space-pos)) + (size (subseq addr-and-size (1+ space-pos)))) + (setf (gethash addr hash) (list where size)))) + (minus-pos + (let* ((where (subseq line 0 minus-pos)) + (addr (subseq line (+ minus-pos 3))) + (found (nth-value 1 (gethash addr hash)))) + (if found + (remhash addr hash) + (push (list where addr) free-list))))))) + (let ((res nil)) + (maphash (lambda (key value) + (push (append value (list key)) res)) + hash) + (values res free-list))))) + +(defun pretty-print-mtrace-summary (file) + (let* ((malloc-sum 0)) + (multiple-value-bind (mallocs frees) (parse-mtrace-log file) + (dolist (i mallocs) + (incf malloc-sum (parse-integer (second i) :radix 16 :start 2)) + (format t "~&~A" i)) + (format t "~&Freed but not malloced:~%~{~A~%~}" frees) + (format t "~&total-malloc-not-freed: ~A ~A free not malloc: ~A" + (/ malloc-sum 1024.0) + (length mallocs) + (length frees))))) + +;; Return the total number of bytes allocated by malloc() +(defun mallinfo () + (ccl:rlet ((mallinfo :mallinfo)) + (#_mallinfo mallinfo) + (ccl::rref mallinfo :mallinfo.uordblks))) + +#|| +http://www.gnu.org/s/libc/manual/html_node/Statistics-of-Malloc.html + +int arena + This is the total size of memory allocated with sbrk by malloc, in bytes. +int ordblks + This is the number of chunks not in use. (The memory allocator internally gets chunks of memory from the operating system, and then carves them up to satisfy individual malloc requests; see Efficiency and Malloc.) +int smblks + This field is unused. +int hblks + This is the total number of chunks allocated with mmap. +int hblkhd + This is the total size of memory allocated with mmap, in bytes. +int usmblks + This field is unused. +int fsmblks + This field is unused. +int uordblks + This is the total size of memory occupied by chunks handed out by malloc. +int fordblks + This is the total size of memory occupied by free (not in use) chunks. +int keepcost + This is the size of the top-most releasable chunk that normally borders the end of the heap (i.e., the high end of the virtual address space's data segment). +||# + +(defun show-malloc-info () + (rlet ((info :mallinfo)) + (#_mallinfo info) ;struct return invisible arg. + (let* ((arena (pref info :mallinfo.arena)) + (ordblks (pref info :mallinfo.ordblks)) + (hblks (pref info :mallinfo.hblks)) + (hblkhd (pref info :mallinfo.hblkhd)) + (uordblks (pref info :mallinfo.uordblks)) + (fordblks (pref info :mallinfo.fordblks)) + (keepcost (pref info :mallinfo.keepcost))) + (format t "~& arena size: ~d/#x~x" arena arena) + (format t "~& number of unused chunks = ~d" ordblks) + (format t "~& number of mmap'ed chunks = ~d" hblks) + (format t "~& total size of mmap'ed chunks = ~d/#x~x" hblkhd hblkhd) + (format t "~& total size of malloc'ed chunks = ~d/#x~x" uordblks uordblks) + (format t "~& total size of free chunks = ~d/#x~x" fordblks fordblks) + (format t "~& size of releaseable chunk = ~d/#x~x" keepcost keepcost)))) + +) ;; end of linux-only code + +(defun get-allocation-sentinel (&key (gc-first t)) + ;; Return the object with the highest address that can be guaranteed to be at a lower + ;; address than any newer objects. + ;; If gc-first is true, can also conversely guarantee that all older objects are at a + ;; lower address than the sentinel. If gc-first is false, than there may be some + ;; already-allocated objects at higher addresses, though no more than the size of the + ;; youngest generation (and usually even less than that). Second value returned is the + ;; size of the active region above the sentinel. + (with-other-threads-suspended + (when gc-first (gc)) ;; get rid of thread allocation chunks. Wish could just egc... + ;; This mustn't cons. + (let* ((first-area (%normalize-areas)) ;; youngest generation + (min-base (loop with current = (%current-tcr) + for tcr = (%fixnum-ref current target::tcr.next) + then (%fixnum-ref tcr target::tcr.next) + as base fixnum = (%fixnum-ref tcr target::tcr.save-allocbase) + when (> base 0) + minimize base + until (eql tcr current))) + (active (%fixnum-ref first-area target::area.active)) + (limit (if (eql min-base 0) active min-base)) + (last-obj nil)) + ;; Normally will find it in the youngest generation, but loop in case limit = area.low. + (block walk + (flet ((skip (obj) + (declare (optimize (speed 3) (safety 0))) ;; lie + (unless (%i< obj limit) + (return-from walk)) + (setq last-obj obj))) + (declare (dynamic-extent #'skip)) + (loop for area = first-area then (%fixnum-ref area target::area.succ) + until (neq (%fixnum-ref area target::area.code) area-dynamic) + when (< (%fixnum-ref area target::area.low) (%fixnum-ref area target::area.active)) + do (walk-static-area area #'skip)))) + (values last-obj (%i- active limit))))) + Index: /branches/new-random/library/lisp-package.lisp =================================================================== --- /branches/new-random/library/lisp-package.lisp (revision 13309) +++ /branches/new-random/library/lisp-package.lisp (revision 13309) @@ -0,0 +1,1650 @@ +;;;-*-Mode: LISP; Package: ccl -*- +;;; +;;; Copyright (C) 2009 Clozure Associates +;;; Copyright (C) 1994-2001 Digitool, Inc +;;; This file is part of Clozure CL. +;;; +;;; Clozure CL is licensed under the terms of the Lisp Lesser GNU Public +;;; License , known as the LLGPL and distributed with Clozure CL as the +;;; file "LICENSE". The LLGPL consists of a preamble and the LGPL, +;;; which is distributed with Clozure CL as the file "LGPL". Where these +;;; conflict, the preamble takes precedence. +;;; +;;; Clozure CL is referenced in the preamble as the "LIBRARY." +;;; +;;; The LLGPL is also available online at +;;; http://opensource.franz.com/preamble.html + +; lisp-package.lisp +; Define a lisp package that attempts to behave like CLTL-1. + +(in-package "CCL") + +(defpackage "LISP" + (:use ) + (:import-from "COMMON-LISP" + "&ALLOW-OTHER-KEYS" + "&AUX" + "&BODY" + "&ENVIRONMENT" + "&KEY" + "&OPTIONAL" + "&REST" + "&WHOLE" + "*" + "**" + "***" + "*DEBUG-IO*" + "*DEFAULT-PATHNAME-DEFAULTS*" + "*ERROR-OUTPUT*" + "*FEATURES*" + "*LOAD-VERBOSE*" + "*MACROEXPAND-HOOK*" + "*PACKAGE*" + "*PRINT-ARRAY*" + "*PRINT-BASE*" + "*PRINT-CASE*" + "*PRINT-CIRCLE*" + "*PRINT-ESCAPE*" + "*PRINT-GENSYM*" + "*PRINT-LENGTH*" + "*PRINT-LEVEL*" + "*PRINT-PRETTY*" + "*PRINT-RADIX*" + "*QUERY-IO*" + "*RANDOM-STATE*" + "*READ-BASE*" + "*READ-DEFAULT-FLOAT-FORMAT*" + "*READ-SUPPRESS*" + "*READTABLE*" + "*STANDARD-INPUT*" + "*STANDARD-OUTPUT*" + "*TERMINAL-IO*" + "*TRACE-OUTPUT*" + "+" + "++" + "+++" + "-" + "/" + "//" + "///" + "/=" + "1+" + "1-" + "<" + "<=" + "=" + ">" + ">=" + "ABS" + "ACONS" + "ACOS" + "ACOSH" + "ADJOIN" + "ADJUST-ARRAY" + "ADJUSTABLE-ARRAY-P" + "ALPHA-CHAR-P" + "ALPHANUMERICP" + "AND" + "APPEND" + "APPLY" + "APROPOS" + "APROPOS-LIST" + "AREF" + "ARRAY" + "ARRAY-DIMENSION" + "ARRAY-DIMENSION-LIMIT" + "ARRAY-DIMENSIONS" + "ARRAY-ELEMENT-TYPE" + "ARRAY-HAS-FILL-POINTER-P" + "ARRAY-IN-BOUNDS-P" + "ARRAY-RANK" + "ARRAY-RANK-LIMIT" + "ARRAY-ROW-MAJOR-INDEX" + "ARRAY-TOTAL-SIZE" + "ARRAY-TOTAL-SIZE-LIMIT" + "ARRAYP" + "ASH" + "ASIN" + "ASINH" + "ASSERT" + "ASSOC" + "ASSOC-IF" + "ASSOC-IF-NOT" + "ATAN" + "ATANH" + "ATOM" + "BIGNUM" + "BIT" + "BIT-AND" + "BIT-ANDC1" + "BIT-ANDC2" + "BIT-EQV" + "BIT-IOR" + "BIT-NAND" + "BIT-NOR" + "BIT-NOT" + "BIT-ORC1" + "BIT-ORC2" + "BIT-VECTOR" + "BIT-VECTOR-P" + "BIT-XOR" + "BLOCK" + "BOOLE" + "BOOLE-1" + "BOOLE-2" + "BOOLE-AND" + "BOOLE-ANDC1" + "BOOLE-ANDC2" + "BOOLE-C1" + "BOOLE-C2" + "BOOLE-CLR" + "BOOLE-EQV" + "BOOLE-IOR" + "BOOLE-NAND" + "BOOLE-NOR" + "BOOLE-ORC1" + "BOOLE-ORC2" + "BOOLE-SET" + "BOOLE-XOR" + "BOTH-CASE-P" + "BOUNDP" + "BREAK" + "BUTLAST" + "BYTE" + "BYTE-POSITION" + "BYTE-SIZE" + "CAAAAR" + "CAAADR" + "CAAAR" + "CAADAR" + "CAADDR" + "CAADR" + "CAAR" + "CADAAR" + "CADADR" + "CADAR" + "CADDAR" + "CADDDR" + "CADDR" + "CADR" + "CALL-ARGUMENTS-LIMIT" + "CAR" + "CASE" + "CATCH" + "CCASE" + "CDAAAR" + "CDAADR" + "CDAAR" + "CDADAR" + "CDADDR" + "CDADR" + "CDAR" + "CDDAAR" + "CDDADR" + "CDDAR" + "CDDDAR" + "CDDDDR" + "CDDDR" + "CDDR" + "CDR" + "CEILING" + "CERROR" + "CHAR" + "CHAR-CODE" + "CHAR-CODE-LIMIT" + "CHAR-DOWNCASE" + "CHAR-EQUAL" +; "CHAR-FONT" + "CHAR-GREATERP" + "CHAR-INT" + "CHAR-LESSP" + "CHAR-NAME" + "CHAR-NOT-EQUAL" + "CHAR-NOT-GREATERP" + "CHAR-NOT-LESSP" + "CHAR-UPCASE" + "CHAR/=" + "CHAR<" + "CHAR<=" + "CHAR=" + "CHAR>" + "CHAR>=" + "CHARACTER" + "CHARACTERP" + "CHECK-TYPE" + "CIS" + "CLEAR-INPUT" + "CLEAR-OUTPUT" + "CLOSE" + "CLRHASH" + "CODE-CHAR" + "COERCE" + "COMPILATION-SPEED" + "COMPILE" + "COMPILE-FILE" + "COMPILED-FUNCTION" + "COMPILED-FUNCTION-P" + "COMPLEX" + "COMPLEXP" + "CONCATENATE" + "COND" + "CONJUGATE" + "CONS" + "CONSP" + "CONSTANTP" + "COPY-ALIST" + "COPY-LIST" + "COPY-READTABLE" + "COPY-SEQ" + "COPY-SYMBOL" + "COPY-TREE" + "COS" + "COSH" + "COUNT" + "COUNT-IF" + "COUNT-IF-NOT" + "CTYPECASE" + "DECF" + "DECLARATION" + "DECLARE" + "DECODE-FLOAT" + "DECODE-UNIVERSAL-TIME" + "DEFCONSTANT" + "DEFINE-MODIFY-MACRO" + "DEFMACRO" + "DEFPARAMETER" + "DEFSETF" + "DEFSTRUCT" + "DEFTYPE" + "DEFUN" + "DEFVAR" + "DELETE" + "DELETE-DUPLICATES" + "DELETE-FILE" + "DELETE-IF" + "DELETE-IF-NOT" + "DENOMINATOR" + "DEPOSIT-FIELD" + "DESCRIBE" + "DIGIT-CHAR-P" + "DIRECTORY" + "DIRECTORY-NAMESTRING" + "DISASSEMBLE" + "DO" + "DO*" + "DO-ALL-SYMBOLS" + "DO-EXTERNAL-SYMBOLS" + "DO-SYMBOLS" + "DOCUMENTATION" + "DOLIST" + "DOTIMES" + "DOUBLE-FLOAT" + "DOUBLE-FLOAT-EPSILON" + "DOUBLE-FLOAT-NEGATIVE-EPSILON" + "DPB" + "DRIBBLE" + "ECASE" + "ED" + "EIGHTH" + "ELT" + "ENCODE-UNIVERSAL-TIME" + "ENDP" + "ENOUGH-NAMESTRING" + "EQ" + "EQL" + "EQUAL" + "EQUALP" + "ERROR" + "ETYPECASE" + "EVAL" + "EVAL-WHEN" + "EVENP" + "EVERY" + "EXP" + "EXPT" + "FBOUNDP" + "FCEILING" + "FFLOOR" + "FIFTH" + "FILE-AUTHOR" + "FILE-LENGTH" + "FILE-NAMESTRING" + "FILE-POSITION" + "FILE-WRITE-DATE" + "FILL" + "FILL-POINTER" + "FIND" + "FIND-ALL-SYMBOLS" + "FIND-IF" + "FIND-IF-NOT" + "FIND-PACKAGE" + "FIND-SYMBOL" + "FINISH-OUTPUT" + "FIRST" + "FIXNUM" + "FLET" + "FLOAT" + "FLOAT-DIGITS" + "FLOAT-PRECISION" + "FLOAT-RADIX" + "FLOAT-SIGN" + "FLOATP" + "FLOOR" + "FMAKUNBOUND" + "FORCE-OUTPUT" + "FORMAT" + "FOURTH" + "FRESH-LINE" + "FROUND" + "FTRUNCATE" + "FTYPE" + "FUNCALL" + "FUNCTION" + "GCD" + "GENSYM" + "GENTEMP" + "GET" + "GET-DECODED-TIME" + "GET-DISPATCH-MACRO-CHARACTER" + "GET-INTERNAL-REAL-TIME" + "GET-INTERNAL-RUN-TIME" + "GET-MACRO-CHARACTER" + "GET-OUTPUT-STREAM-STRING" + "GET-PROPERTIES" + "GET-UNIVERSAL-TIME" + "GETF" + "GETHASH" + "GO" + "GRAPHIC-CHAR-P" + "HASH-TABLE" + "HASH-TABLE-COUNT" + "HASH-TABLE-P" + "HOST-NAMESTRING" + "IDENTITY" + "IF" + "IGNORE" + "IMAGPART" + "INCF" + "INLINE" + "INPUT-STREAM-P" + "INSPECT" + "INTEGER" + "INTEGER-DECODE-FLOAT" + "INTEGER-LENGTH" + "INTEGERP" + "INTERN" + "INTERNAL-TIME-UNITS-PER-SECOND" + "INTERSECTION" + "ISQRT" + "KEYWORD" + "KEYWORDP" + "LABELS" + "LAMBDA" + "LAMBDA-LIST-KEYWORDS" + "LAMBDA-PARAMETERS-LIMIT" + "LAST" + "LCM" + "LDB" + "LDB-TEST" + "LDIFF" + "LEAST-NEGATIVE-DOUBLE-FLOAT" + "LEAST-NEGATIVE-LONG-FLOAT" + "LEAST-NEGATIVE-SHORT-FLOAT" + "LEAST-NEGATIVE-SINGLE-FLOAT" + "LEAST-POSITIVE-DOUBLE-FLOAT" + "LEAST-POSITIVE-LONG-FLOAT" + "LEAST-POSITIVE-SHORT-FLOAT" + "LEAST-POSITIVE-SINGLE-FLOAT" + "LENGTH" + "LET" + "LET*" + "LISP-IMPLEMENTATION-TYPE" + "LISP-IMPLEMENTATION-VERSION" + "LIST" + "LIST*" + "LIST-ALL-PACKAGES" + "LIST-LENGTH" + "LISTEN" + "LISTP" + "LOAD" + "LOCALLY" + "LOG" + "LOGAND" + "LOGANDC1" + "LOGANDC2" + "LOGBITP" + "LOGCOUNT" + "LOGEQV" + "LOGIOR" + "LOGNAND" + "LOGNOR" + "LOGNOT" + "LOGORC1" + "LOGORC2" + "LOGTEST" + "LOGXOR" + "LONG-FLOAT" + "LONG-FLOAT-EPSILON" + "LONG-FLOAT-NEGATIVE-EPSILON" + "LONG-SITE-NAME" + "LOOP" + "LOWER-CASE-P" + "MACHINE-INSTANCE" + "MACHINE-TYPE" + "MACHINE-VERSION" + "MACRO-FUNCTION" + "MACROEXPAND" + "MACROEXPAND-1" + "MACROLET" + "MAKE-ARRAY" + "MAKE-BROADCAST-STREAM" + "MAKE-CONCATENATED-STREAM" + "MAKE-DISPATCH-MACRO-CHARACTER" + "MAKE-ECHO-STREAM" + "MAKE-HASH-TABLE" + "MAKE-LIST" + "MAKE-PATHNAME" + "MAKE-RANDOM-STATE" + "MAKE-SEQUENCE" + "MAKE-STRING" + "MAKE-STRING-INPUT-STREAM" + "MAKE-STRING-OUTPUT-STREAM" + "MAKE-SYMBOL" + "MAKE-SYNONYM-STREAM" + "MAKE-TWO-WAY-STREAM" + "MAKUNBOUND" + "MAP" + "MAPC" + "MAPCAN" + "MAPCAR" + "MAPCON" + "MAPHASH" + "MAPL" + "MAPLIST" + "MASK-FIELD" + "MAX" + "MEMBER" + "MEMBER-IF" + "MEMBER-IF-NOT" + "MERGE" + "MERGE-PATHNAMES" + "MIN" + "MINUSP" + "MISMATCH" + "MOD" + "MOST-NEGATIVE-DOUBLE-FLOAT" + "MOST-NEGATIVE-FIXNUM" + "MOST-NEGATIVE-LONG-FLOAT" + "MOST-NEGATIVE-SHORT-FLOAT" + "MOST-NEGATIVE-SINGLE-FLOAT" + "MOST-POSITIVE-DOUBLE-FLOAT" + "MOST-POSITIVE-FIXNUM" + "MOST-POSITIVE-LONG-FLOAT" + "MOST-POSITIVE-SHORT-FLOAT" + "MOST-POSITIVE-SINGLE-FLOAT" + "MULTIPLE-VALUE-BIND" + "MULTIPLE-VALUE-CALL" + "MULTIPLE-VALUE-LIST" + "MULTIPLE-VALUE-PROG1" + "MULTIPLE-VALUE-SETQ" + "MULTIPLE-VALUES-LIMIT" + "NAME-CHAR" + "NAMESTRING" + "NBUTLAST" + "NCONC" + "NIL" + "NINTERSECTION" + "NINTH" + "NOT" + "NOTANY" + "NOTEVERY" + "NOTINLINE" + "NRECONC" + "NREVERSE" + "NSET-DIFFERENCE" + "NSET-EXCLUSIVE-OR" + "NSTRING-CAPITALIZE" + "NSTRING-DOWNCASE" + "NSTRING-UPCASE" + "NSUBLIS" + "NSUBST" + "NSUBST-IF" + "NSUBST-IF-NOT" + "NSUBSTITUTE" + "NSUBSTITUTE-IF" + "NSUBSTITUTE-IF-NOT" + "NTH" + "NTHCDR" + "NULL" + "NUMBER" + "NUMBERP" + "NUMERATOR" + "NUNION" + "ODDP" + "OPEN" + "OPTIMIZE" + "OR" + "OTHERWISE" + "OUTPUT-STREAM-P" + "PACKAGE" + "PACKAGE-NAME" + "PACKAGE-NICKNAMES" + "PACKAGE-SHADOWING-SYMBOLS" + "PACKAGE-USE-LIST" + "PACKAGE-USED-BY-LIST" + "PACKAGEP" + "PAIRLIS" + "PARSE-INTEGER" + "PARSE-NAMESTRING" + "PATHNAME" + "PATHNAME-DEVICE" + "PATHNAME-DIRECTORY" + "PATHNAME-HOST" + "PATHNAME-NAME" + "PATHNAME-TYPE" + "PATHNAME-VERSION" + "PATHNAMEP" + "PEEK-CHAR" + "PHASE" + "PI" + "PLUSP" + "POP" + "POSITION" + "POSITION-IF" + "POSITION-IF-NOT" + "PPRINT" + "PRIN1" + "PRIN1-TO-STRING" + "PRINC" + "PRINC-TO-STRING" + "PRINT" + "PROBE-FILE" + "PROCLAIM" + "PROG" + "PROG*" + "PROG1" + "PROG2" + "PROGN" + "PROGV" + "PSETF" + "PSETQ" + "PUSH" + "PUSHNEW" + "QUOTE" + "RANDOM" + "RANDOM-STATE" + "RANDOM-STATE-P" + "RASSOC" + "RASSOC-IF" + "RASSOC-IF-NOT" + "RATIO" + "RATIONAL" + "RATIONALIZE" + "RATIONALP" + "READ" + "READ-BYTE" + "READ-CHAR" + "READ-CHAR-NO-HANG" + "READ-DELIMITED-LIST" + "READ-FROM-STRING" + "READ-LINE" + "READ-PRESERVING-WHITESPACE" + "READTABLE" + "READTABLEP" + "REALPART" + "REDUCE" + "REM" + "REMF" + "REMHASH" + "REMOVE" + "REMOVE-DUPLICATES" + "REMOVE-IF" + "REMOVE-IF-NOT" + "REMPROP" + "RENAME-FILE" + "RENAME-PACKAGE" + "REPLACE" + "REST" + "RETURN" + "RETURN-FROM" + "REVAPPEND" + "REVERSE" + "ROOM" + "ROTATEF" + "ROUND" + "RPLACA" + "RPLACD" + "SAFETY" + "SATISFIES" + "SBIT" + "SCALE-FLOAT" + "SCHAR" + "SEARCH" + "SECOND" + "SEQUENCE" + "SET" +; "SET-CHAR-BIT" + "SET-DIFFERENCE" + "SET-DISPATCH-MACRO-CHARACTER" + "SET-EXCLUSIVE-OR" + "SET-MACRO-CHARACTER" + "SET-SYNTAX-FROM-CHAR" + "SETF" + "SETQ" + "SEVENTH" + "SHIFTF" + "SHORT-FLOAT" + "SHORT-FLOAT-EPSILON" + "SHORT-FLOAT-NEGATIVE-EPSILON" + "SHORT-SITE-NAME" + "SIGNED-BYTE" + "SIGNUM" + "SIMPLE-ARRAY" + "SIMPLE-BIT-VECTOR" + "SIMPLE-BIT-VECTOR-P" + "SIMPLE-STRING" + "SIMPLE-STRING-P" + "SIMPLE-VECTOR" + "SIMPLE-VECTOR-P" + "SIN" + "SINGLE-FLOAT" + "SINGLE-FLOAT-EPSILON" + "SINGLE-FLOAT-NEGATIVE-EPSILON" + "SINH" + "SIXTH" + "SLEEP" + "SOFTWARE-TYPE" + "SOFTWARE-VERSION" + "SOME" + "SORT" + "SPACE" + "SPECIAL" + "SPEED" + "SQRT" + "STABLE-SORT" + "STANDARD-CHAR" + "STANDARD-CHAR-P" + "STEP" + "STREAM" + "STREAM-ELEMENT-TYPE" + "STREAMP" + "STRING" + "STRING-CAPITALIZE" +; "STRING-CHAR" +; "STRING-CHAR-P" + "STRING-DOWNCASE" + "STRING-EQUAL" + "STRING-GREATERP" + "STRING-LEFT-TRIM" + "STRING-LESSP" + "STRING-NOT-EQUAL" + "STRING-NOT-GREATERP" + "STRING-NOT-LESSP" + "STRING-RIGHT-TRIM" + "STRING-TRIM" + "STRING-UPCASE" + "STRING/=" + "STRING<" + "STRING<=" + "STRING=" + "STRING>" + "STRING>=" + "STRINGP" + "STRUCTURE" + "SUBLIS" + "SUBSEQ" + "SUBSETP" + "SUBST" + "SUBST-IF" + "SUBST-IF-NOT" + "SUBSTITUTE" + "SUBSTITUTE-IF" + "SUBSTITUTE-IF-NOT" + "SUBTYPEP" + "SVREF" + "SXHASH" + "SYMBOL" + "SYMBOL-FUNCTION" + "SYMBOL-NAME" + "SYMBOL-PACKAGE" + "SYMBOL-PLIST" + "SYMBOL-VALUE" + "SYMBOLP" + "T" + "TAGBODY" + "TAILP" + "TAN" + "TANH" + "TENTH" + "TERPRI" + "THE" + "THIRD" + "THROW" + "TIME" + "TRACE" + "TREE-EQUAL" + "TRUENAME" + "TRUNCATE" + "TYPE" + "TYPE-OF" + "TYPECASE" + "TYPEP" + "UNINTERN" + "UNION" + "UNLESS" + "UNREAD-CHAR" + "UNSIGNED-BYTE" + "UNTRACE" + "UNWIND-PROTECT" + "UPPER-CASE-P" + "USER-HOMEDIR-PATHNAME" + "VALUES" + "VALUES-LIST" + "VARIABLE" + "VECTOR" + "VECTOR-POP" + "VECTOR-PUSH" + "VECTOR-PUSH-EXTEND" + "VECTORP" + "WARN" + "WHEN" + "WITH-INPUT-FROM-STRING" + "WITH-OPEN-FILE" + "WITH-OPEN-STREAM" + "WITH-OUTPUT-TO-STRING" + "WRITE" + "WRITE-BYTE" + "WRITE-CHAR" + "WRITE-LINE" + "WRITE-STRING" + "WRITE-TO-STRING" + "Y-OR-N-P" + "YES-OR-NO-P" + "ZEROP" + "*MODULES*" + "PROVIDE" + "REQUIRE") + (:import-from "CCL" + "*BREAK-ON-WARNINGS*" + "COMPILER-LET" + "*APPLYHOOK*" + "*EVALHOOK*" + "APPLYHOOK" + "EVALHOOK" + "SPECIAL-FORM-P" + "GET-SETF-METHOD" + "GET-SETF-METHOD-MULTIPLE-VALUE" + "DEFINE-SETF-METHOD" +) + (:shadow "IN-PACKAGE" + "FUNCTIONP" + "MAKE-PACKAGE" + "SHADOW" + "SHADOWING-IMPORT" + "EXPORT" + "UNEXPORT" + "USE-PACKAGE" + "UNUSE-PACKAGE" + "IMPORT") + (:export + "&ALLOW-OTHER-KEYS" + "&AUX" + "&BODY" + "&ENVIRONMENT" + "&KEY" + "&OPTIONAL" + "&REST" + "&WHOLE" + "*" + "**" + "***" + "*APPLYHOOK*" + "*BREAK-ON-WARNINGS*" + "*DEBUG-IO*" + "*DEFAULT-PATHNAME-DEFAULTS*" + "*ERROR-OUTPUT*" + "*EVALHOOK*" + "*FEATURES*" + "*LOAD-VERBOSE*" + "*MODULES*" + "*MACROEXPAND-HOOK*" + "*PACKAGE*" + "*PRINT-ARRAY*" + "*PRINT-BASE*" + "*PRINT-CASE*" + "*PRINT-CIRCLE*" + "*PRINT-ESCAPE*" + "*PRINT-GENSYM*" + "*PRINT-LENGTH*" + "*PRINT-LEVEL*" + "*PRINT-PRETTY*" + "*PRINT-RADIX*" + "*QUERY-IO*" + "*RANDOM-STATE*" + "*READ-BASE*" + "*READ-DEFAULT-FLOAT-FORMAT*" + "*READ-SUPPRESS*" + "*READTABLE*" + "*STANDARD-INPUT*" + "*STANDARD-OUTPUT*" + "*TERMINAL-IO*" + "*TRACE-OUTPUT*" + "+" + "++" + "+++" + "-" + "/" + "//" + "///" + "/=" + "1+" + "1-" + "<" + "<=" + "=" + ">" + ">=" + "ABS" + "ACONS" + "ACOS" + "ACOSH" + "ADJOIN" + "ADJUST-ARRAY" + "ADJUSTABLE-ARRAY-P" + "ALPHA-CHAR-P" + "ALPHANUMERICP" + "AND" + "APPEND" + "APPLY" + "APPLYHOOK" + "APROPOS" + "APROPOS-LIST" + "AREF" + "ARRAY" + "ARRAY-DIMENSION" + "ARRAY-DIMENSION-LIMIT" + "ARRAY-DIMENSIONS" + "ARRAY-ELEMENT-TYPE" + "ARRAY-HAS-FILL-POINTER-P" + "ARRAY-IN-BOUNDS-P" + "ARRAY-RANK" + "ARRAY-RANK-LIMIT" + "ARRAY-ROW-MAJOR-INDEX" + "ARRAY-TOTAL-SIZE" + "ARRAY-TOTAL-SIZE-LIMIT" + "ARRAYP" + "ASH" + "ASIN" + "ASINH" + "ASSERT" + "ASSOC" + "ASSOC-IF" + "ASSOC-IF-NOT" + "ATAN" + "ATANH" + "ATOM" + "BIGNUM" + "BIT" + "BIT-AND" + "BIT-ANDC1" + "BIT-ANDC2" + "BIT-EQV" + "BIT-IOR" + "BIT-NAND" + "BIT-NOR" + "BIT-NOT" + "BIT-ORC1" + "BIT-ORC2" + "BIT-VECTOR" + "BIT-VECTOR-P" + "BIT-XOR" + "BLOCK" + "BOOLE" + "BOOLE-1" + "BOOLE-2" + "BOOLE-AND" + "BOOLE-ANDC1" + "BOOLE-ANDC2" + "BOOLE-C1" + "BOOLE-C2" + "BOOLE-CLR" + "BOOLE-EQV" + "BOOLE-IOR" + "BOOLE-NAND" + "BOOLE-NOR" + "BOOLE-ORC1" + "BOOLE-ORC2" + "BOOLE-SET" + "BOOLE-XOR" + "BOTH-CASE-P" + "BOUNDP" + "BREAK" + "BUTLAST" + "BYTE" + "BYTE-POSITION" + "BYTE-SIZE" + "CAAAAR" + "CAAADR" + "CAAAR" + "CAADAR" + "CAADDR" + "CAADR" + "CAAR" + "CADAAR" + "CADADR" + "CADAR" + "CADDAR" + "CADDDR" + "CADDR" + "CADR" + "CALL-ARGUMENTS-LIMIT" + "CAR" + "CASE" + "CATCH" + "CCASE" + "CDAAAR" + "CDAADR" + "CDAAR" + "CDADAR" + "CDADDR" + "CDADR" + "CDAR" + "CDDAAR" + "CDDADR" + "CDDAR" + "CDDDAR" + "CDDDDR" + "CDDDR" + "CDDR" + "CDR" + "CEILING" + "CERROR" + "CHAR" + "CHAR-BIT" + "CHAR-BITS" + "CHAR-BITS-LIMIT" + "CHAR-CODE" + "CHAR-CODE-LIMIT" + "CHAR-CONTROL-BIT" + "CHAR-DOWNCASE" + "CHAR-EQUAL" + "CHAR-FONT" + "CHAR-FONT-LIMIT" + "CHAR-GREATERP" + "CHAR-HYPER-BIT" + "CHAR-INT" + "CHAR-LESSP" + "CHAR-META-BIT" + "CHAR-NAME" + "CHAR-NOT-EQUAL" + "CHAR-NOT-GREATERP" + "CHAR-NOT-LESSP" + "CHAR-SUPER-BIT" + "CHAR-UPCASE" + "CHAR/=" + "CHAR<" + "CHAR<=" + "CHAR=" + "CHAR>" + "CHAR>=" + "CHARACTER" + "CHARACTERP" + "CHECK-TYPE" + "CIS" + "CLEAR-INPUT" + "CLEAR-OUTPUT" + "CLOSE" + "CLRHASH" + "CODE-CHAR" + "COERCE" + "COMMON" + "COMMONP" + "COMPILATION-SPEED" + "COMPILE" + "COMPILE-FILE" + "COMPILED-FUNCTION" + "COMPILED-FUNCTION-P" + "COMPILER-LET" + "COMPLEX" + "COMPLEXP" + "CONCATENATE" + "COND" + "CONJUGATE" + "CONS" + "CONSP" + "CONSTANTP" + "COPY-ALIST" + "COPY-LIST" + "COPY-READTABLE" + "COPY-SEQ" + "COPY-SYMBOL" + "COPY-TREE" + "COS" + "COSH" + "COUNT" + "COUNT-IF" + "COUNT-IF-NOT" + "CTYPECASE" + "DECF" + "DECLARATION" + "DECLARE" + "DECODE-FLOAT" + "DECODE-UNIVERSAL-TIME" + "DEFCONSTANT" + "DEFINE-MODIFY-MACRO" + "DEFINE-SETF-METHOD" + "DEFMACRO" + "DEFPARAMETER" + "DEFSETF" + "DEFSTRUCT" + "DEFTYPE" + "DEFUN" + "DEFVAR" + "DELETE" + "DELETE-DUPLICATES" + "DELETE-FILE" + "DELETE-IF" + "DELETE-IF-NOT" + "DENOMINATOR" + "DEPOSIT-FIELD" + "DESCRIBE" + "DIGIT-CHAR" + "DIGIT-CHAR-P" + "DIRECTORY" + "DIRECTORY-NAMESTRING" + "DISASSEMBLE" + "DO" + "DO*" + "DO-ALL-SYMBOLS" + "DO-EXTERNAL-SYMBOLS" + "DO-SYMBOLS" + "DOCUMENTATION" + "DOLIST" + "DOTIMES" + "DOUBLE-FLOAT" + "DOUBLE-FLOAT-EPSILON" + "DOUBLE-FLOAT-NEGATIVE-EPSILON" + "DPB" + "DRIBBLE" + "ECASE" + "ED" + "EIGHTH" + "ELT" + "ENCODE-UNIVERSAL-TIME" + "ENDP" + "ENOUGH-NAMESTRING" + "EQ" + "EQL" + "EQUAL" + "EQUALP" + "ERROR" + "ETYPECASE" + "EVAL" + "EVAL-WHEN" + "EVALHOOK" + "EVENP" + "EVERY" + "EXP" + "EXPORT" + "EXPT" + "FBOUNDP" + "FCEILING" + "FFLOOR" + "FIFTH" + "FILE-AUTHOR" + "FILE-LENGTH" + "FILE-NAMESTRING" + "FILE-POSITION" + "FILE-WRITE-DATE" + "FILL" + "FILL-POINTER" + "FIND" + "FIND-ALL-SYMBOLS" + "FIND-IF" + "FIND-IF-NOT" + "FIND-PACKAGE" + "FIND-SYMBOL" + "FINISH-OUTPUT" + "FIRST" + "FIXNUM" + "FLET" + "FLOAT" + "FLOAT-DIGITS" + "FLOAT-PRECISION" + "FLOAT-RADIX" + "FLOAT-SIGN" + "FLOATP" + "FLOOR" + "FMAKUNBOUND" + "FORCE-OUTPUT" + "FORMAT" + "FOURTH" + "FRESH-LINE" + "FROUND" + "FTRUNCATE" + "FTYPE" + "FUNCALL" + "FUNCTION" + "FUNCTIONP" + "GCD" + "GENSYM" + "GENTEMP" + "GET" + "GET-DECODED-TIME" + "GET-DISPATCH-MACRO-CHARACTER" + "GET-INTERNAL-REAL-TIME" + "GET-INTERNAL-RUN-TIME" + "GET-MACRO-CHARACTER" + "GET-OUTPUT-STREAM-STRING" + "GET-PROPERTIES" + "GET-SETF-METHOD" + "GET-SETF-METHOD-MULTIPLE-VALUE" + "GET-UNIVERSAL-TIME" + "GETF" + "GETHASH" + "GO" + "GRAPHIC-CHAR-P" + "HASH-TABLE" + "HASH-TABLE-COUNT" + "HASH-TABLE-P" + "HOST-NAMESTRING" + "IDENTITY" + "IF" + "IGNORE" + "IMAGPART" + "IMPORT" + "IN-PACKAGE" + "INCF" + "INLINE" + "INPUT-STREAM-P" + "INSPECT" + "INT-CHAR" + "INTEGER" + "INTEGER-DECODE-FLOAT" + "INTEGER-LENGTH" + "INTEGERP" + "INTERN" + "INTERNAL-TIME-UNITS-PER-SECOND" + "INTERSECTION" + "ISQRT" + "KEYWORD" + "KEYWORDP" + "LABELS" + "LAMBDA" + "LAMBDA-LIST-KEYWORDS" + "LAMBDA-PARAMETERS-LIMIT" + "LAST" + "LCM" + "LDB" + "LDB-TEST" + "LDIFF" + "LEAST-NEGATIVE-DOUBLE-FLOAT" + "LEAST-NEGATIVE-LONG-FLOAT" + "LEAST-NEGATIVE-SHORT-FLOAT" + "LEAST-NEGATIVE-SINGLE-FLOAT" + "LEAST-POSITIVE-DOUBLE-FLOAT" + "LEAST-POSITIVE-LONG-FLOAT" + "LEAST-POSITIVE-SHORT-FLOAT" + "LEAST-POSITIVE-SINGLE-FLOAT" + "LENGTH" + "LET" + "LET*" + "LISP-IMPLEMENTATION-TYPE" + "LISP-IMPLEMENTATION-VERSION" + "LIST" + "LIST*" + "LIST-ALL-PACKAGES" + "LIST-LENGTH" + "LISTEN" + "LISTP" + "LOAD" + "LOCALLY" + "LOG" + "LOGAND" + "LOGANDC1" + "LOGANDC2" + "LOGBITP" + "LOGCOUNT" + "LOGEQV" + "LOGIOR" + "LOGNAND" + "LOGNOR" + "LOGNOT" + "LOGORC1" + "LOGORC2" + "LOGTEST" + "LOGXOR" + "LONG-FLOAT" + "LONG-FLOAT-EPSILON" + "LONG-FLOAT-NEGATIVE-EPSILON" + "LONG-SITE-NAME" + "LOOP" + "LOWER-CASE-P" + "MACHINE-INSTANCE" + "MACHINE-TYPE" + "MACHINE-VERSION" + "MACRO-FUNCTION" + "MACROEXPAND" + "MACROEXPAND-1" + "MACROLET" + "MAKE-ARRAY" + "MAKE-BROADCAST-STREAM" + "MAKE-CHAR" + "MAKE-CONCATENATED-STREAM" + "MAKE-DISPATCH-MACRO-CHARACTER" + "MAKE-ECHO-STREAM" + "MAKE-HASH-TABLE" + "MAKE-LIST" + "MAKE-PACKAGE" + "MAKE-PATHNAME" + "MAKE-RANDOM-STATE" + "MAKE-SEQUENCE" + "MAKE-STRING" + "MAKE-STRING-INPUT-STREAM" + "MAKE-STRING-OUTPUT-STREAM" + "MAKE-SYMBOL" + "MAKE-SYNONYM-STREAM" + "MAKE-TWO-WAY-STREAM" + "MAKUNBOUND" + "MAP" + "MAPC" + "MAPCAN" + "MAPCAR" + "MAPCON" + "MAPHASH" + "MAPL" + "MAPLIST" + "MASK-FIELD" + "MAX" + "MEMBER" + "MEMBER-IF" + "MEMBER-IF-NOT" + "MERGE" + "MERGE-PATHNAMES" + "MIN" + "MINUSP" + "MISMATCH" + "MOD" + "MOST-NEGATIVE-DOUBLE-FLOAT" + "MOST-NEGATIVE-FIXNUM" + "MOST-NEGATIVE-LONG-FLOAT" + "MOST-NEGATIVE-SHORT-FLOAT" + "MOST-NEGATIVE-SINGLE-FLOAT" + "MOST-POSITIVE-DOUBLE-FLOAT" + "MOST-POSITIVE-FIXNUM" + "MOST-POSITIVE-LONG-FLOAT" + "MOST-POSITIVE-SHORT-FLOAT" + "MOST-POSITIVE-SINGLE-FLOAT" + "MULTIPLE-VALUE-BIND" + "MULTIPLE-VALUE-CALL" + "MULTIPLE-VALUE-LIST" + "MULTIPLE-VALUE-PROG1" + "MULTIPLE-VALUE-SETQ" + "MULTIPLE-VALUES-LIMIT" + "NAME-CHAR" + "NAMESTRING" + "NBUTLAST" + "NCONC" + "NIL" + "NINTERSECTION" + "NINTH" + "NOT" + "NOTANY" + "NOTEVERY" + "NOTINLINE" + "NRECONC" + "NREVERSE" + "NSET-DIFFERENCE" + "NSET-EXCLUSIVE-OR" + "NSTRING-CAPITALIZE" + "NSTRING-DOWNCASE" + "NSTRING-UPCASE" + "NSUBLIS" + "NSUBST" + "NSUBST-IF" + "NSUBST-IF-NOT" + "NSUBSTITUTE" + "NSUBSTITUTE-IF" + "NSUBSTITUTE-IF-NOT" + "NTH" + "NTHCDR" + "NULL" + "NUMBER" + "NUMBERP" + "NUMERATOR" + "NUNION" + "ODDP" + "OPEN" + "OPTIMIZE" + "OR" + "OTHERWISE" + "OUTPUT-STREAM-P" + "PACKAGE" + "PACKAGE-NAME" + "PACKAGE-NICKNAMES" + "PACKAGE-SHADOWING-SYMBOLS" + "PACKAGE-USE-LIST" + "PACKAGE-USED-BY-LIST" + "PACKAGEP" + "PAIRLIS" + "PARSE-INTEGER" + "PARSE-NAMESTRING" + "PATHNAME" + "PATHNAME-DEVICE" + "PATHNAME-DIRECTORY" + "PATHNAME-HOST" + "PATHNAME-NAME" + "PATHNAME-TYPE" + "PATHNAME-VERSION" + "PATHNAMEP" + "PEEK-CHAR" + "PHASE" + "PI" + "PLUSP" + "POP" + "POSITION" + "POSITION-IF" + "POSITION-IF-NOT" + "PPRINT" + "PRIN1" + "PRIN1-TO-STRING" + "PRINC" + "PRINC-TO-STRING" + "PRINT" + "PROBE-FILE" + "PROCLAIM" + "PROG" + "PROG*" + "PROG1" + "PROG2" + "PROGN" + "PROGV" + "PROVIDE" + "PSETF" + "PSETQ" + "PUSH" + "PUSHNEW" + "QUOTE" + "RANDOM" + "RANDOM-STATE" + "RANDOM-STATE-P" + "RASSOC" + "RASSOC-IF" + "RASSOC-IF-NOT" + "RATIO" + "RATIONAL" + "RATIONALIZE" + "RATIONALP" + "READ" + "READ-BYTE" + "READ-CHAR" + "READ-CHAR-NO-HANG" + "READ-DELIMITED-LIST" + "READ-FROM-STRING" + "READ-LINE" + "READ-PRESERVING-WHITESPACE" + "READTABLE" + "READTABLEP" + "REALPART" + "REDUCE" + "REM" + "REMF" + "REMHASH" + "REMOVE" + "REMOVE-DUPLICATES" + "REMOVE-IF" + "REMOVE-IF-NOT" + "REMPROP" + "RENAME-FILE" + "RENAME-PACKAGE" + "REPLACE" + "REQUIRE" + "REST" + "RETURN" + "RETURN-FROM" + "REVAPPEND" + "REVERSE" + "ROOM" + "ROTATEF" + "ROUND" + "RPLACA" + "RPLACD" + "SAFETY" + "SATISFIES" + "SBIT" + "SCALE-FLOAT" + "SCHAR" + "SEARCH" + "SECOND" + "SEQUENCE" + "SET" + "SET-CHAR-BIT" + "SET-DIFFERENCE" + "SET-DISPATCH-MACRO-CHARACTER" + "SET-EXCLUSIVE-OR" + "SET-MACRO-CHARACTER" + "SET-SYNTAX-FROM-CHAR" + "SETF" + "SETQ" + "SEVENTH" + "SHADOW" + "SHADOWING-IMPORT" + "SHIFTF" + "SHORT-FLOAT" + "SHORT-FLOAT-EPSILON" + "SHORT-FLOAT-NEGATIVE-EPSILON" + "SHORT-SITE-NAME" + "SIGNED-BYTE" + "SIGNUM" + "SIMPLE-ARRAY" + "SIMPLE-BIT-VECTOR" + "SIMPLE-BIT-VECTOR-P" + "SIMPLE-STRING" + "SIMPLE-STRING-P" + "SIMPLE-VECTOR" + "SIMPLE-VECTOR-P" + "SIN" + "SINGLE-FLOAT" + "SINGLE-FLOAT-EPSILON" + "SINGLE-FLOAT-NEGATIVE-EPSILON" + "SINH" + "SIXTH" + "SLEEP" + "SOFTWARE-TYPE" + "SOFTWARE-VERSION" + "SOME" + "SORT" + "SPACE" + "SPECIAL" + "SPEED" + "SQRT" + "STABLE-SORT" + "STANDARD-CHAR" + "STANDARD-CHAR-P" + "STEP" + "STREAM" + "STREAM-ELEMENT-TYPE" + "STREAMP" + "STRING" + "STRING-CAPITALIZE" + "STRING-CHAR" + "STRING-CHAR-P" + "STRING-DOWNCASE" + "STRING-EQUAL" + "STRING-GREATERP" + "STRING-LEFT-TRIM" + "STRING-LESSP" + "STRING-NOT-EQUAL" + "STRING-NOT-GREATERP" + "STRING-NOT-LESSP" + "STRING-RIGHT-TRIM" + "STRING-TRIM" + "STRING-UPCASE" + "STRING/=" + "STRING<" + "STRING<=" + "STRING=" + "STRING>" + "STRING>=" + "STRINGP" + "STRUCTURE" + "SUBLIS" + "SUBSEQ" + "SUBSETP" + "SUBST" + "SUBST-IF" + "SUBST-IF-NOT" + "SUBSTITUTE" + "SUBSTITUTE-IF" + "SUBSTITUTE-IF-NOT" + "SUBTYPEP" + "SVREF" + "SXHASH" + "SYMBOL" + "SYMBOL-FUNCTION" + "SYMBOL-NAME" + "SYMBOL-PACKAGE" + "SYMBOL-PLIST" + "SYMBOL-VALUE" + "SYMBOLP" + "T" + "TAGBODY" + "TAILP" + "TAN" + "TANH" + "TENTH" + "TERPRI" + "THE" + "THIRD" + "THROW" + "TIME" + "TRACE" + "TREE-EQUAL" + "TRUENAME" + "TRUNCATE" + "TYPE" + "TYPE-OF" + "TYPECASE" + "TYPEP" + "UNEXPORT" + "UNINTERN" + "UNION" + "UNLESS" + "UNREAD-CHAR" + "UNSIGNED-BYTE" + "UNTRACE" + "UNUSE-PACKAGE" + "UNWIND-PROTECT" + "UPPER-CASE-P" + "USE-PACKAGE" + "USER-HOMEDIR-PATHNAME" + "VALUES" + "VALUES-LIST" + "VARIABLE" + "VECTOR" + "VECTOR-POP" + "VECTOR-PUSH" + "VECTOR-PUSH-EXTEND" + "VECTORP" + "WARN" + "WHEN" + "WITH-INPUT-FROM-STRING" + "WITH-OPEN-FILE" + "WITH-OPEN-STREAM" + "WITH-OUTPUT-TO-STRING" + "WRITE" + "WRITE-BYTE" + "WRITE-CHAR" + "WRITE-LINE" + "WRITE-STRING" + "WRITE-TO-STRING" + "Y-OR-N-P" + "YES-OR-NO-P" + "ZEROP" + )) + +(%resize-package (find-package "LISP")) + +(defpackage "USER" + (:use "LISP" "CCL")) + +(defconstant lisp:char-control-bit 0) +(defconstant lisp:char-meta-bit 0) +(defconstant lisp:char-super-bit 0) +(defconstant lisp:char-hyper-bit 0) +(defconstant lisp:char-bits-limit 1) +(defconstant lisp:char-font-limit 1) + +(defun lisp:int-char (i) + (cl:code-char i)) + +(defun lisp:char-bits (c) + (require-type c 'character) + 0) + +(defun lisp:char-font (c) + (require-type c 'character) + 0) + +(defun lisp:digit-char (weight &optional (radix 10) font) + (when (and font (not (eql font 0))) + (error "Non-zero ~S (~S) not supported" 'font font)) + (cl:digit-char weight radix)) + +; 'It is an error to give char-bit the name of a bit not supported by the +; implementation' +(defun lisp:char-bit (char name) + (declare (ignore char)) + (error "Unsupported character bit name ~S." name)) + +(defun lisp:set-char-bit (char name newvalue) + (declare (ignore char newvalue)) + (error "Unsupported character bit name ~S." name)) + +(defun lisp:make-char (char &optional bits font) + (flet ((non-supported (argname argval) + (if (and argval (not (eql argval 0))) + (error "Non-zero ~S argument (~S) not supported." argname argval)))) + (non-supported 'bits bits) + (non-supported 'font font) + (require-type char 'character))) + +; A tragic waste of precious silicon. +(define-setf-method char-bit (place bit-name &environment env) + (multiple-value-bind (dummies vals newval setter getter) + (get-setf-method place env) + (let ((btemp (gensym)) + (gnuval (gensym))) + (values `(,@dummies ,btemp) + `(,@vals ,bit-name) + (list gnuval) + `(let ((,(car newval) + (set-char-bit ,getter ,btemp ,gnuval))) + ,setter + ,gnuval) + `(char-bit ,getter ,btemp))))) + +(defun lisp:in-package (package-name &rest rest &key + nicknames use internal-size external-size) + (declare (ignore nicknames use internal-size external-size)) + (declare (dynamic-extent rest)) + (apply 'old-in-package package-name rest)) + +(defun lisp:functionp (x) + (or (symbolp x) + (and (consp x) (eq (ccl::%car x) 'lambda)) + (cl:functionp x))) + +(setf (cl:find-class 'lisp:string-char) (cl:find-class 'cl:base-char) + (symbol-function 'lisp:string-char-p) #'cl:characterp) + +(dolist (sym '(lisp:make-package lisp:in-package lisp:shadow lisp:shadowing-import + lisp:export lisp:unexport lisp:use-package lisp:unuse-package + lisp:import)) + (unless (eq sym 'lisp:in-package) + (setf (symbol-function sym) + (symbol-function (find-symbol (symbol-name sym) "COMMON-LISP")))) + (pushnew sym *fcomp-eval-always-functions*)) + +(provide :lisp-package) Index: /branches/new-random/library/lispequ.lisp =================================================================== --- /branches/new-random/library/lispequ.lisp (revision 13309) +++ /branches/new-random/library/lispequ.lisp (revision 13309) @@ -0,0 +1,1607 @@ +;;;-*-Mode: LISP; Package: CCL -*- +;;; +;;; Copyright (C) 2009 Clozure Associates +;;; Copyright (C) 1994-2001 Digitool, Inc +;;; This file is part of Clozure CL. +;;; +;;; Clozure CL is licensed under the terms of the Lisp Lesser GNU Public +;;; License , known as the LLGPL and distributed with Clozure CL as the +;;; file "LICENSE". The LLGPL consists of a preamble and the LGPL, +;;; which is distributed with Clozure CL as the file "LGPL". Where these +;;; conflict, the preamble takes precedence. +;;; +;;; Clozure CL is referenced in the preamble as the "LIBRARY." +;;; +;;; The LLGPL is also available online at +;;; http://opensource.franz.com/preamble.html + +;; LispEqu.lisp + +(in-package "CCL") + +(defconstant $flags_Normal 0) +(defconstant $flags_DisposeRecursiveLock 1) +(defconstant $flags_DisposPtr 2) +(defconstant $flags_DisposeRwlock 3) +(defconstant $flags_DisposeSemaphore 4) + +(defconstant $system-lock-type-recursive 0) +(defconstant $system-lock-type-rwlock 1) + +;;; this stuff is really ppc specific at the moment +(defconstant $population_weak-list 0) +(defconstant $population_weak-alist 1) +(defconstant $population_termination-bit 16) + +;;; type of 0 is a weak-list +;;; Note that this evals its args in the wrong order. +(defmacro %cons-population (data &optional (type 0) (termination? nil)) + (if termination? + `(gvector :population 0 (logior (ash 1 $population_termination-bit) ,type) ,data nil) + `(gvector :population 0 ,type ,data))) + +(defmacro %cons-terminatable-alist (&optional data) + `(%cons-population ,data $population_weak-alist t)) + +;;; The GC assumes that this structure is laid out exactly as below. +;;; It also assumes that if the $population_termination-bit is set in the +;;; population.type slot, the vector is of length 4, otherwise 3. +(def-accessors (population) %svref + population.gclink + population.type + population.data + population.termination-list) + +(def-accessors () uvref + nil + nil + population-data ; type-checked + population-termination-list) + +(defmacro %cons-pool (&optional data) + `(gvector :pool ,data)) + +(def-accessors (pool) %svref + pool.data) + +(def-accessors (resource) %svref + nil ; 'resource + resource.constructor + resource.destructor + resource.initializer + resource.pool + resource.lock) + +(defmacro gvector (type-keyword &rest initial-values) + `(%gvector ,(type-keyword-code type-keyword) ,@initial-values)) + + +(defmacro allocate-typed-vector (type-keyword elements &optional (init nil init-p)) + `(%alloc-misc ,elements ,(type-keyword-code type-keyword) + ,@(if init-p `(,init)))) + + +(def-accessors (semaphore) %svref + nil ;'semaphore + semaphore.value) + + +(defmacro %istruct (istruct-name &rest initial-values) + `(gvector :ISTRUCT (register-istruct-cell ,istruct-name) ,@initial-values)) + + +(defmacro %cons-resource (constructor &optional destructor initializer) + `(%istruct 'resource ,constructor ,destructor ,initializer (%cons-pool) (make-lock))) + + + +;;; Symbol [f,v]bits. + +(defconstant $sym_bit_bound 0) ;Proclaimed bound. +(defconstant $sym_bit_const 1) +(defconstant $sym_bit_global 2) ;Should never be lambda-bound. +(defconstant $sym_bit_special 4) +(defconstant $sym_vbit_typeppred 5) +(defconstant $sym_bit_indirect 6) +(defconstant $sym_bit_defunct 7) + +(defconstant $sym_vbit_bound $sym_bit_bound) +(defconstant $sym_vbit_const $sym_bit_const) +(defconstant $sym_vbit_global $sym_bit_global) +(defconstant $sym_vbit_special $sym_bit_special) +(defconstant $sym_vbit_indirect $sym_bit_indirect) +(defconstant $sym_vbit_defunct $sym_bit_defunct) + +(defconstant $sym_fbit_frozen (+ 8 $sym_bit_bound)) +(defconstant $sym_fbit_special (+ 8 $sym_bit_special)) +(defconstant $sym_fbit_indirect (+ 8 $sym_bit_indirect)) +(defconstant $sym_fbit_defunct (+ 8 $sym_bit_defunct)) + +(defconstant $sym_fbit_constant_fold (+ 8 $sym_bit_const)) +(defconstant $sym_fbit_fold_subforms (+ 8 $sym_bit_global)) + +(def-accessors () %svref + nil ;'destructure-state + destructure-state.current + destructure-state.whole + destructure-state.lambda + ) + +;Lfun bits. +;Assumed to be a fixnum, so if you ever assign a bit number > 28, +;change lfun-bits and its callers. +(defconstant $lfbits-nonnullenv-bit 0) +(defconstant $lfbits-keys-bit 1) +(defconstant $lfbits-numopt (byte 5 2)) +(defconstant $lfbits-restv-bit 7) +(defconstant $lfbits-numreq (byte 6 8)) +(defconstant $lfbits-optinit-bit 14) +(defconstant $lfbits-rest-bit 15) +(defconstant $lfbits-aok-bit 16) +(defconstant $lfbits-numinh (byte 6 17)) +(defconstant $lfbits-info-bit 23) +(defconstant $lfbits-trampoline-bit 24) +(defconstant $lfbits-code-coverage-bit 25) +(defconstant $lfbits-cm-bit 26) ; combined-method +(defconstant $lfbits-nextmeth-bit 26) ; or call-next-method with method-bit +(defconstant $lfbits-gfn-bit 27) ; generic-function +(defconstant $lfbits-nextmeth-with-args-bit 27) ; or call-next-method-with-args with method-bit +(defconstant $lfbits-method-bit 28) ; method function +(defconstant $lfbits-noname-bit 29) + + +(defconstant $lfbits-args-mask + (%ilogior (dpb -1 $lfbits-numreq 0) + (dpb -1 $lfbits-numopt 0) + (%ilsl $lfbits-rest-bit 1) + (%ilsl $lfbits-keys-bit 1) + (%ilsl $lfbits-aok-bit 1))) + +;Bits in $arh_bits. +(defconstant $arh_adjp_bit 7) ;adjustable-p +(defconstant $arh_fill_bit 6) ;fill-pointer-p +(defconstant $arh_disp_bit 5) ;displaced to another array header -p +(defconstant $arh_simple_bit 4) ;not adjustable, no fill-pointer and + ; not user-visibly displaced -p +(defconstant $arh_exp_disp_bit 3) ;explicitly-displaced -p + +(def-accessors (lexical-environment) %svref + () ; 'lexical-environment + lexenv.parent-env + lexenv.functions + lexenv.variables + lexenv.fdecls ; function-binding decls, e.g., [NOT]INLINE, FTYPE + lexenv.vdecls ; variable-binding decls, e.g., SPECIAL, TYPE + lexenv.mdecls ; misc decls, e.g., OPTIMIZE + lexenv.lambda ; unique id (e.g., afunc) of containing lambda expression. + ) + +(def-accessors (definition-environment) %svref + () ; 'definition-environment + defenv.type ; must be LIST, match lexenv.parent-env + defenv.functions ; compile-time macros, same structure as lexenv.functions + defenv.constants ; definition-time constants, shadows lexenv.variables + defenv.fdecls ; shadows lexenv.fdecls + defenv.vdecls ; shadows lexenv.vdecls + defenv.mdecls ; shadows lexenv.mdecls +;;; extended info + defenv.types ; compile-time deftype info, shadows lexenv.function + defenv.defined ; functions defined in compilation unit. + defenv.specials + defenv.classes ; classed defined in compilation unit + defenv.structrefs ; compile-time DEFSTRUCT accessor info + defenv.structures ; compile-time DEFSTRUCT info + defenv.symbol-macros ; compile-time SYMBOL-MACROS. +) + +(def-accessors (var) %svref + nil ; 'var + var-name ; symbol + (var-bits var-parent) ; fixnum or ptr to parent + (var-ea var-expansion) ; p2 address (or symbol-macro expansion) + var-ref-forms ; in intermediate-code + var-inittype + var-binding-info + var-refs + var-nvr + var-declared-type +) + +(def-accessors (package) %svref + pkg.itab + pkg.etab + pkg.used + pkg.used-by + pkg.names + pkg.shadowed + pkg.lock + pkg.intern-hook + ) + +(defmacro package-deleted-marker () + `(%unbound-marker)) + + + + +(defmacro %cons-fake-stack-frame (&optional sp next-sp fn lr vsp xp link) + `(%istruct 'fake-stack-frame ,sp ,next-sp ,fn ,lr ,vsp ,xp ,link)) + +(def-accessors () svref + bt.dialog + bt.youngest + bt.oldest + bt.tcr + bt.restarts + bt.top-catch + bt.break-condition + bt.current + bt.fake-frames + bt.db-link + bt.break-level) + +(defconstant bt.sg bt.tcr) +(setf (macro-function 'bt.sg) (macro-function 'bt.tcr)) + + +(def-accessors (lock) %svref + lock.value + lock.name) + + + + + + + +;contents of pkg.itab/pkg.etab. +(defmacro pkgtab-table (htab) `(car (the list ,htab))) +#| +(defmacro pkgtab-hcount (htab) `(car (the list (cdr (the list ,htab))))) (mkint acc))) +(defmacro pkgtab-hlimit (htab) `(cdr (the list (cdr (the list ,htab))))) +|# + + + +(def-accessors (pathname) %svref + () ; 'pathname + %pathname-directory + %pathname-name + %pathname-type + %physical-pathname-version + %physical-pathname-device) + +(def-accessors (logical-pathname) %svref + () ; 'logical-pathname + nil ; %pathname-directory + nil ; %pathname-name + nil ; %pathname-type + %logical-pathname-host + %logical-pathname-version) + +(defmacro %cons-pathname (directory name type &optional version device) + `(%istruct 'pathname ,directory ,name ,type ,version ,device)) + +(defmacro %cons-logical-pathname (directory name type host version) + `(%istruct 'logical-pathname ,directory ,name ,type ,host ,version)) + +(def-accessors (restart) %svref + () ; 'restart + %restart-name + %restart-action + %restart-report + %restart-interactive + %restart-test) + +;;; %cons-restart now in level-2.lisp + + +(def-accessors %svref + nil ; 'periodic-task + ptask.state + ptask.name + ptask.function +) + +;;;;;; CMU type system. + + + +(def-accessors (type-class) %svref + nil ; 'type-class + type-class-name ; name + + ;; Dyadic type methods. If the classes of the two types are EQ, then we call + ;; the SIMPLE-xxx method. If the classes are not EQ, and either type's class + ;; has a COMPLEX-xxx method, then we call it. + ;; + ;; Although it is undefined which method will get precedence when both types + ;; have a complex method, the complex method can assume that the second arg + ;; always is in its class, and the first always is not. The arguments to + ;; commutative operations will be swapped if the first argument has a complex + ;; method. + ;; + ;; Since SUBTYPEP is not commutative, we have two complex methods. the ARG1 + ;; method is only called when the first argument is in its class, and the + ;; ARG2 method is only called when called when the second type is. If either + ;; is specified, both must be. + type-class-simple-subtypep + type-class-complex-subtypep-arg1 + type-class-complex-subtypep-arg2 + ;; + ;; SIMPLE-UNION combines two types of the same class into a single type of + ;; that class. If the result is a two-type union, then return NIL. + ;; VANILLA-UNION returns whichever argument is a supertype of the other, or + ;; NIL. + type-class-simple-union + type-class-complex-union + ;; The default intersection methods assume that if one type is a subtype of + ;; the other, then that type is the intersection. + type-class-simple-intersection + type-class-complex-intersection + ;; + type-class-simple-= + type-class-complex-= + type-class-unparse +) + +;; This istruct (and its subtypes) are used to define types. +(def-accessors (ctype) %svref + nil ; 'ctype or a subtype + ctype-class-info ; a type-class + ;; True if this type has a fixed number of members, and as such could + ;; possibly be completely specified in a MEMBER type. This is used by the + ;; MEMBER type methods. + ctype-enumerable +) + +;; args-ctype is a subtype of ctype +(def-accessors (args-ctype) %svref + nil ; 'args-ctype + nil ; ctype-class-info + nil ; ctype-enumerable + ;; Lists of the type for each required and optional argument. + args-ctype-required + args-ctype-optional + ;; + ;; The type for the rest arg. NIL if there is no rest arg. + args-ctype-rest + ;; True if keyword arguments are specified. + args-ctype-keyp + ;; List of key-info structures describing the keyword arguments. + args-ctype-keywords + ;; True if other keywords are allowed. + args-ctype-allowp +) + +(def-accessors (key-info) %svref + nil ; 'key-info + key-info-name ; Name of &key arg + key-info-type ; type (ctype) of this &key arg +) + +;;; VALUES-ctype is a subtype of ARGS-ctype. +(def-accessors (values-ctype) %svref + nil ; 'values-ctype + nil ; ctype-class-info + nil ; ctype-enumerable + ;; Lists of the type for each required and optional argument. + values-ctype-required + values-ctype-optional + ;; + ;; The type for the rest arg. NIL if there is no rest arg. + values-ctype-rest + ;; True if keyword arguments are specified. + values-ctype-keyp + ;; List of key-info structures describing the keyword arguments. + values-ctype-keywords + ;; True if other keywords are allowed. + values-ctype-allowp +) + +;;; FUNCTION-ctype is a subtype of ARGS-ctype. +(def-accessors (args-ctype) %svref + nil ; 'function-ctype + nil ; ctype-class-info + nil ; ctype-enumerable + function-ctype-required ; args-ctype-required + function-ctype-optional ; args-ctype-optional + function-ctype-rest ; args-ctype-rest + function-ctype-keyp ; args-ctype-keyp + function-ctype-keywords ; args-ctype-keywords + function-ctype-allowp ; args-ctype-allowp +;; True if the arguments are unrestrictive, i.e. *. + function-ctype-wild-args + ;; + ;; Type describing the return values. This is a values type + ;; when multiple values were specified for the return. + function-ctype-returns +) + +;;; The CONSTANT-ctype structure represents a use of the CONSTANT-ARGUMENT "type +;;; specifier", which is only meaningful in function argument type specifiers +;;; used within the compiler. +;;; + + +(def-accessors (constant-ctype) %svref + nil ; 'constant-ctype + nil ; ctype-class-info + nil ; ctype-enumerable + ;; The type which the argument must be a constant instance of for this type + ;; specifier to win. + constant-ctype-type +) + +;;; The NAMED-ctype is used to represent *, T and NIL. These types must be +;;; super or sub types of all types, not just classes and * & NIL aren't +;;; classes anyway, so it wouldn't make much sense to make them built-in +;;; classes. +;;; + +(def-accessors (named-ctype) %svref + nil ; 'named-ctype + nil ; ctype-class-info + nil ; ctype-enumerable + named-ctype-name +) + +;;; The Hairy-ctype represents anything too wierd to be described +;;; reasonably or to be useful, such as SATISFIES. We just remember +;;; the original type spec. +;;; + +(def-accessors (hairy-ctype) %svref + nil ; 'hairy-ctype + nil ; ctype-class-info + nil ; ctype-enumerable + ;; The type which the argument must be a constant instance of for this type + ;; specifier to win. + hairy-ctype-specifier +) + +;;; An UNKNOWN-ctype is a type not known to the type system (not yet defined). +;;; We make this distinction since we don't want to complain about types that +;;; are hairy but defined. +;;; + +;;; This means that UNKNOWN-ctype is a HAIRY-ctype. +(def-accessors (unknown-ctype) %svref + nil ; 'unknown-ctype + nil ; ctype-class-info + nil ; ctype-enumerable + unknown-ctype-specifier +) + +;;; CONS-ctype is a subclass of CTYPE +(def-accessors (cons-ctype) %svref + nil ; 'cons-ctype + nil ; ctype-class-info + nil ; ctype-enumerable + cons-ctype-car-ctype ; ctype of the car + cons-ctype-cdr-ctype ; ctype of the cdr + ) + +;;; NUMERIC-ctype is a subclass of CTYPE +(def-accessors (numeric-ctype) %svref + nil ; numeric-ctype + nil ; ctype-class-info + nil ; ctype-enumerable + ;; + ;; The kind of numeric type we have. NIL if not specified (just NUMBER or + ;; COMPLEX). + numeric-ctype-class + ;; Format for a float type. NIL if not specified or not a float. Formats + ;; which don't exist in a given implementation don't appear here. + numeric-ctype-format + ;; Is this a complex numeric type? Null if unknown (only in NUMBER.) + numeric-ctype-complexp + ;; The upper and lower bounds on the value. If null, there is no bound. If + ;; a list of a number, the bound is exclusive. Integer types never have + ;; exclusive bounds. + numeric-ctype-low + numeric-ctype-high + numeric-ctype-predicate +) + +;;; ARRAY-ctype is a subclass of CTYPE. +(def-accessors (array-ctype) %svref + nil ; 'array-ctype + nil ; ctype-class-info + nil ; ctype-enumerable + ;; + ;; The dimensions of the array. * if unspecified. If a dimension is + ;; unspecified, it is *. + array-ctype-dimensions + ;; + ;; Is this not a simple array type? + array-ctype-complexp + ;; + ;; The element type as originally specified. + array-ctype-element-type + ;; + ;; The element type as it is specialized in this implementation. + array-ctype-specialized-element-type + ;; The typecode of the specialize element type, or NIL. + array-ctype-typecode +) + +;;; MEMBER-ctype is a direct subclass of CTYPE. +(def-accessors (member-ctype) %svref + nil ; 'member-ctype + nil ; ctype-class-info + nil ; ctype-enumerable + ;; + ;; The things in the set, with no duplications. + member-ctype-members +) + +;;; UNION-ctype is a direct subclass of CTYPE. +(def-accessors (union-ctype) %svref + nil ; 'union-ctype + nil ; ctype-class-info + nil ; ctype-enumerable + ;; + ;; The types in the union. + union-ctype-types +) + +;;; INTERSECTION-ctype is a direct subclass of CTYPE. +(def-accessors (intersection-ctype) %svref + nil ; 'intersection-ctype + nil ; ctype-class-info + nil ; ctype-enumerable + ;; + ;; The types in the intersection + intersection-ctype-types +) + +(def-accessors (negation-ctype) %svref + nil ; 'negation-ctype + nil ; ctype-class-info + nil ; ctype-enumerable + ;; The type of what we're not: + negation-ctype-type + ) + + + + +;;; It'd be nice to integrate "foreign" types into the type system +(def-accessors (foreign-ctype) %svref + nil ; 'foreign-ctype + nil ; ctype-class-info + nil ; ctype-enumerable + foreign-ctype-foreign-type +) + +;;; Most "real" CLOS objects have one of these in their %class.ctype slot + +(def-accessors (class-ctype) %svref + nil ; 'class-ctype + nil ; ctype-class-info + nil ; ctype-enumerable + class-ctype-class ; backptr to class. + class-ctype-translation ; ctype for some built-in-classes. +) + + + +;;;;;;; +;; +;; state for with-package-iterator +;; +(def-accessors %svref + pkg-iter-step.pkg ; package + pkg-iter-step.type ; keyword + pkg-iter-step.table + pkg-iter-step.shadowed + pkg-iter-step.vector + pkg-iter-step.index) + +(def-accessors %svref + pkg-iter.step ; current step + pkg-iter.remaining-steps ; steps to be processed +) + +;;;;;;;;;;;;; + +;;; Bits in *gc-event-status-bits* +(defconstant $gc-retain-pages-bit 0) +(defconstant $gc-integrity-check-bit 2) +(defconstant $gc-allow-stack-overflows-bit 5) +(defconstant $egc-verbose-bit 3) +(defconstant $gc-verbose-bit 4) +(defconstant $gc-postgc-pending-bit 26) + + + +;;; Values for the flags arg to %install-periodic-task +(defconstant $ptask_draw-flag 1) ; set for tasks that do drawing +(defconstant $ptask_event-dispatch-flag 2) ; set for tasks that do event processing + + + + + +(defconstant struct.type 0) +(defconstant istruct.type 0) + +(def-accessors (readtable) %svref + () ; 'readtable + rdtab.ttab ; type table + rdtab.alist ; macro-char alist + rdtab.case) ; gratuitous braindeath + +;character types in readtables +(defconstant $cht_ill 0) ;Illegal char +(defconstant $cht_wsp 1) ;Whitespace +(defconstant $cht_sesc 4) ;Single escape (\) +(defconstant $cht_mesc 5) ;Multiple escape (|) +(defconstant $cht_cnst 6) ;Atom constituent +(defconstant $cht_tmac 8) ;Terminating macro +(defconstant $cht_ntmac 9) ;Non-terminating macro + +(defconstant $cht_macbit 3) ;This bit on in CHT_TMAC and CHT_NTMAC + +;;; quantifiers + +(defconstant $some 0) +(defconstant $notany 1) +(defconstant $every 2) +(defconstant $notevery 3) + +;;; Error string constants. As accurate as constants.i ... + +(defconstant $XVUNBND 1) +;(defconstant $XNOCDR 2) +(defconstant $xbadvec 6) +(defconstant $XTMINPS 3) +(defconstant $XNEINPS 4) +(defconstant $XWRNGINP 5) +(defconstant $err-bad-input 5) +(defconstant $XFUNBND 6) +;;(defconstant $err-fundefined 6) +;;(defconstant $XNOCAR 7) +(defconstant $xsetbadvec 7) +(defconstant $xcoerce 8) +(defconstant $xnofinfunction 9) +(defconstant $xnomem 10) +(defconstant $xnotranslation 12) +(defconstant $XNOTFUN 13) +(defconstant $XNOTsymlam 14) +(defconstant $Xdeclpos 15) +(defconstant $Xsetconstant 16) +(defconstant $Xoddsetq 17) +(defconstant $Xbadsetq 18) +(defconstant $Xnotsym 19) +(defconstant $Xisconstant 20) +(defconstant $Xbadinit 21) +(defconstant $Xsmacspec 22) +(defconstant $X2manyargs 23) +(defconstant $XNolexvar 24) +(defconstant $XNolexfunc 25) +(defconstant $XNolextag 26) +(defconstant $XNolexblock 27) +(defconstant $XNotag 28) +(defconstant $Xduplicatetag 29) +(defconstant $XNoblock 30) +(defconstant $XBadLambdaList 31) +(defconstant $XBadLambda 32) +(defconstant $XNOCTAG 33) +(defconstant $XOBJBadType 34) +(defconstant $XFuncLexMacro 35) +(defconstant $xumrpr 41) +(defconstant $xnotsamevol 42) +(defconstant $xbadfilenamechar 43) +(defconstant $xillwild 44) +(defconstant $xnotfaslortext 45) +(defconstant $xrenamedir 46) +(defconstant $xdirnotfile 47) +(defconstant $xnocopydir 48) +(defconstant $XBADTOK 49) +(defconstant $err-long-pstr 49) +(defconstant $xnocreate 50) +(defconstant $XFLOVFL 64) +(defconstant $XDIVZRO 66) +(defconstant $XFLDZRO 66) +(defconstant $XSTKOVER 75) +(defconstant $XMEMFULL 76) +(defconstant $xarrlimit 77) +(defconstant $err-printer 94) +(defconstant $err-printer-load 95) +(defconstant $err-printer-params 96) +(defconstant $err-printer-start 97) +(defconstant $XFLEXC 98) +(defconstant $xfileof 111) +(defconstant $XARROOB 112) +(defconstant $err-arroob 112) +(defconstant $xunread 113) +(defconstant $xbadmac 114) +(defconstant $XCONST 115) +(defconstant $xillchr 116) +(defconstant $xbadsym 117) +(defconstant $xdoterr 118) +(defconstant $xbadrdx 119) +(defconstant $XNOSPREAD 120) +(defconstant $XFASLVERS 121) +(defconstant $XNOTFASL 122) +(defconstant $xudfcall 123) + +(defconstant $xusecX 127) +(defconstant $ximprtcx 128) +(defconstant $xbadnum 129) ;Bad arg to #b/#o/#x/#r... +(defconstant $XNOPKG 130) +(defconstant $xnoesym 131) +(defconstant $XBADFASL 132) +(defconstant $ximprtc 133) +(defconstant $xunintc 134) +(defconstant $XSYMACC 135) +(defconstant $XEXPRTC 136) +(defconstant $xusec 137) +(defconstant $xduppkg 138) +(defconstant $xrmactx 139) +(defconstant $xnordisp 140) +(defconstant $xrdnoarg 141) +(defconstant $xrdndarg 142) +(defconstant $xmacrdx 143) +(defconstant $xduprdlbl 144) +(defconstant $xnordlbl 145) +(defconstant $xrdfont 146) +(defconstant $xrdname 147) +(defconstant $XNDIMS 148) +(defconstant $err-disp-size 149) +(defconstant $XNARGS 150) +(defconstant $xdifdim 151) +(defconstant $xkeyconflict 152) +(defconstant $XBADKEYS 153) +(defconstant $xtoofew 154) +(defconstant $xtoomany 155) +(defconstant $XWRONGTYPE 157) +(defconstant $XBADSTRUCT 158) +(defconstant $XSTRUCTBOUNDS 159) +(defconstant $XCALLNOTLAMBDA 160) +(defconstant $XTEMPFLT 161) +(defconstant $xrdfeature 163) +(defconstant $err-no-file 164) +(defconstant $err-bad-named-arg 165) +(defconstant $err-bad-named-arg-2 166) +(defconstant $XCALLTOOMANY 167) +(defconstant $XCALLTOOFEW 168) +(defconstant $XCALLNOMATCH 169) +(defconstant $XIMPROPERLIST 170) +(defconstant $XNOFILLPTR 171) +(defconstant $XMALADJUST 172) +(defconstant $XACCESSNTH 173) +(defconstant $XNOTELT 174) +(defconstant $XSGEXHAUSTED 175) +(defconstant $XSGNARGS 176) +(defconstant $XTOOMANYVALUES 177) +(defconstant $XFOREIGNEXCEPTION 200) + +(defconstant $cons-area.gspace-start 0) +(defconstant $cons-area.gspace-end 4) +(defconstant $cons-area.ispace-start 8) +(defconstant $cons-area.ispace-end 12) +(defconstant $cons-area.pgc-count 16) +(defconstant $cons-area.pgc-time 20) +(defconstant $cons-area.total 24) + + +;; Values returned by %number-check. + +(defconstant $Num1Dfloat 0) +(defconstant $Num1Int 2) +(defconstant $Num1Sfloat 4) +(defconstant $Num1Ratio 6) +(defconstant $Num1CR 8) +(defconstant $Num1CF 10) +(defconstant $Num1CS 12) + +(defconstant %numeric-type-names-alist% + `((double-float . ,$Num1Dfloat) + (integer . ,$Num1Int) + (short-float . ,$Num1Sfloat) + (ratio . ,$Num1Ratio) + ((complex rational) . ,$Num1CR) + ((complex double-float) . ,$Num1CF) + ((complex short-float) . ,$Num1CS))) + +(defmacro numeric-dispatch (numform &body cases) + (flet ((numtype (name) + (if (memq name '(t otherwise)) + name + (dolist (pair %numeric-type-names-alist% (error "Unknown numeric type name ~s" name)) + (when (subtypep name (car pair)) (return (cdr pair))))))) + (flet ((numify (case) + (destructuring-bind (types &body body) case + (if (atom types) + `(,(numtype types) ,@body) + `(,(mapcar #'numtype types) ,@body))))) + `(case (%number-check ,numform) + ,@(mapcar #'numify cases))))) + +(def-accessors (random-state) %svref + () + random.seed-1 + random.seed-2) + +;;; IEEE-floating-point constants. + +(defconstant IEEE-single-float-bias 126) +(defconstant IEEE-single-float-exponent-offset 23) +(defconstant IEEE-single-float-exponent-width 8) +(defconstant IEEE-single-float-mantissa-offset 0) +(defconstant IEEE-single-float-mantissa-width 23) +(defconstant IEEE-single-float-hidden-bit 23) +(defconstant IEEE-single-float-signalling-NAN-bit 22) +(defconstant IEEE-single-float-normal-exponent-min 1) +(defconstant IEEE-single-float-normal-exponent-max 254) +(defconstant IEEE-single-float-digits (1+ IEEE-single-float-mantissa-width)) + +;;; Double-floats are IEEE DOUBLE-FLOATs in both MCL implementations. + +(defconstant IEEE-double-float-bias 1022) +(defconstant IEEE-double-float-exponent-offset 52) +(defconstant IEEE-double-float-exponent-width 11) +(defconstant IEEE-double-float-mantissa-offset 0) +(defconstant IEEE-double-float-mantissa-width 52) +(defconstant IEEE-double-float-hidden-bit 52) +(defconstant IEEE-double-float-signalling-NAN-bit 51) +(defconstant IEEE-double-float-normal-exponent-min 1) +(defconstant IEEE-double-float-normal-exponent-max 2046) +(defconstant IEEE-double-float-digits (1+ IEEE-double-float-mantissa-width)) + + + + +(def-accessors (ptaskstate) %svref + nil ;ptaskstate + ptaskstate.nexttick + ptaskstate.interval + ptaskstate.privatedata + ptaskstate.flags) + + + + + + + +;;;;;; clos instance and class layout. + +;;; All standard-instances (classes, instances other than funcallable +;;; instances) consist of a vector of slot values and a pointer to the +;;; class wrapper. +(def-accessors (instance) %svref + instance.hash ; a fixnum for EQ-based hashing + instance.class-wrapper + instance.slots ; a slot-vector +) +;;; Doing this via %SLOT-REF traps if the slot is unbound +(defmacro standard-instance-instance-location-access (instance location) + `(%slot-ref (instance-slots ,instance) ,location)) + +;;; Get the "raw" contents of the slot, even if it's %SLOT-UNBOUND-MARKER. +(defmacro %standard-instance-instance-location-access (instance location) + `(%svref (instance-slots ,instance) ,location)) + +(defmacro set-standard-instance-instance-location-access (instance location new) + `(setf (%svref (instance-slots ,instance) ,location) ,new)) + +(defsetf standard-instance-instance-location-access + set-standard-instance-instance-location-access) + +(defmacro standard-generic-function-instance-location-access (sgf location) + `(%slot-ref (gf.slots ,sgf) ,location)) + +(defmacro %standard-generic-function-instance-location-access (sgf location) + `(%svref (gf.slots ,sgf) ,location)) + +(defmacro set-standard-generic-function-instance-location-access (sgf location new) + `(setf (%svref (gf.slots ,sgf) ,location) ,new)) + +(defsetf standard-generic-function-instance-location-access + set-standard-generic-function-instance-location-access) + +;;; Slot vectors contain the instance they "belong" to (or NIL) in +;;; their 0th element, and the instance's slots in elements 1 .. n. + +(def-accessors (slot-vector) %svref + slot-vector.instance + ) + +(def-accessors (class-wrapper) %svref + nil ; 'class-wrapper + %wrapper-hash-index ; for generic-function dispatch tables + %wrapper-class ; the class itself + %wrapper-instance-slots ; vector of instance slot names + %wrapper-class-slots ; alist of (name . value-cell) pairs + %wrapper-slot-id->slotd ; map slot-id to slotd, or NIL + %wrapper-slot-id-map ; (vector (mod nslots) next-slot-id-index) + %wrapper-slot-definition-table ; vector of nil || slot-definitions + %wrapper-slot-id-value ; "fast" SLOT-VALUE function + %wrapper-set-slot-id-value ; "fast" (SETF SLOT-VALUE) function + %wrapper-cpl ; cached cpl of %wrapper-class or NIL + %wrapper-class-ordinal ; cached copy of class-ordinal + %wrapper-cpl-bits ; bitvector representation of cpl +) + +;; Use the wrapper-class-slots for info on obsolete & forwarded instances +;; Note: none of this xx-forwarding-xx or xx-forwarded-xx is valid unless +;; (%wrapper-instance-slots ...) is 0. +(defmacro %wrapper-forwarding-info (instance) + `(%wrapper-class-slots ,instance)) + +(defmacro %forwarding-instance-slots (info) + `(%car ,info)) +(defmacro %forwarding-class-slots (info) + `(%cdr ,info)) + + +(defmacro %wrapper-forwarded-instance-slots (instance) + `(%forwarding-instance-slots (%wrapper-forwarding-info ,instance))) +(defmacro %wrapper-forwarded-class-slots (instance) + `(%forwarding-class-slots (%wrapper-forwarding-info ,instance))) + + +(defmacro %cons-forwarding-info (instance-slots class-slots) + `(cons ,instance-slots ,class-slots)) + + +(defmacro %cons-wrapper (class &optional + (hash-index '(new-class-wrapper-hash-index))) + (let* ((c (gensym))) + `(let* ((,c ,class)) + (%istruct 'class-wrapper ,hash-index ,c nil nil #'slot-id-lookup-no-slots nil nil #'%slot-id-ref-missing #'%slot-id-set-missing nil (%class-ordinal ,c t) nil)))) + + +(defmacro %instance-class (instance) + `(%wrapper-class (instance.class-wrapper ,instance))) + +(def-accessors standard-instance-instance-location-access ;A specializer + nil ; backptr + specializer.direct-methods +) + +(def-accessors (class) standard-instance-instance-location-access ;Slots of any class + nil ; backptr + %class.direct-methods ; aka specializer.direct-methods + %class.prototype ; prototype instance + %class.name + %class.cpl ; class-precedence-list + %class.own-wrapper ; own wrapper (or nil) + %class.local-supers ; class-direct-superclasses + %class.subclasses ; class-direct-subclasses + %class.dependents ; arbitrary dependents + %class.ctype + %class.direct-slots ; local slots + %class.slots ; all slots + %class.info ; cons of kernel-p, proper-name + %class.local-default-initargs ; local default initargs alist + %class.default-initargs ; all default initargs if initialized. +) + + +(def-accessors () standard-instance-instance-location-access ; any standard class + nil ; slot-vector backptr + nil ; usual class stuff: direct-methods, + nil ; prototype, + nil ; name, + nil ; cpl, + nil ; own-wrapper, + nil ; local-supers, + nil ; subclasses, + nil ; dependents, + nil ; ctype. + nil ; local slots + nil ; all slots + nil ; true if a non-redefinable class + nil ; local default initargs alist + nil ; all default initargs if initialized. + %class.alist ; other stuff about the class. + %class.make-instance-initargs ; (vector of) valid initargs to make-instance + %class.reinit-initargs ; valid initargs to reinitialize-instance + %class.redefined-initargs ; valid initargs to update-instance-for-redefined-class + %class.changed-initargs ; valid initargs to update-instance-for-changed-class + ) + + + + + +(defmacro %instance-vector (wrapper &rest slots) + (let ((instance (gensym)) + (slots-vector (gensym))) + `(let* ((,instance (gvector :instance 0 ,wrapper nil)) + (,slots-vector (gvector :slot-vector ,instance ,@slots))) + (setf (instance.slots ,instance) ,slots-vector + (instance.hash ,instance) (strip-tag-to-fixnum ,instance)) + ,instance))) + + + + +(defmacro %cons-built-in-class (name) + `(%instance-vector *built-in-class-wrapper* + nil ;direct-methods + nil ;prototype + ,name ;name + nil ;precedence-list + nil ;own-wrapper + nil ;direct-superclasses + nil ;direct-subclasses + nil ;dependents + nil ;class-ctype + nil ;direct-slots + nil ;slots + (cons nil nil) ;info + nil ;direct-default-initargs + nil ;default-initargs + )) + +(defmacro %cons-standard-class (name &optional + (metaclass-wrapper '*standard-class-wrapper*)) + `(%instance-vector ,metaclass-wrapper + nil ;direct-methods + nil ;prototype + ,name ;name + nil ;precedence-list + nil ;own-wrapper + nil ;direct-superclasses + nil ;direct-subclasses + nil ;dependents + nil ;class-ctype + nil ;direct-slots + nil ;slots + (cons nil nil) ;info + nil ;direct-default-initargs + nil ;default-initargs + nil ;alist + nil ;make-instance-initargs + nil ;reinit-initargs + nil ;redefined-initargs + nil ;changed-initargs + ) +) + + + +(defconstant max-class-ordinal (ash 1 20)) + + +(def-accessors () standard-instance-instance-location-access + nil ; backptr + standard-slot-definition.name + standard-slot-definition.type + standard-slot-definition.initfunction + standard-slot-definition.initform + standard-slot-definition.initargs + standard-slot-definition.allocation + standard-slot-definition.documentation + standard-slot-definition.class + ) + +(def-accessors () standard-instance-instance-location-access + nil + standard-effective-slot-definition.name + standard-effective-slot-definition.type + standard-effective-slot-definition.initfunction + standard-effective-slot-definition.initform + standard-effective-slot-definition.initargs + standard-effective-slot-definition.allocation + standard-effective-slot-definition.documentation + standard-effective-slot-definition.class + standard-effective-slot-definition.location + standard-effective-slot-definition.slot-id + standard-effective-slot-definition.type-predicate + ) + + +(def-accessors () standard-instance-instance-location-access + nil + standard-direct-slot-definition.name + standard-direct-slot-definition.type + standard-direct-slot-definition.initfunction + standard-direct-slot-definition.initform + standard-direct-slot-definition.initargs + standard-direct-slot-definition.allocation + standard-direct-slot-definition.documentation + standard-direct-slot-definition.class + standard-direct-slot-definition.readers + standard-direct-slot-definition.writers + ) + +;; Methods +(defmacro %cons-method (name qualifiers specializers function &optional + (class '*standard-method-class*)) + `(%instance-vector + (%class.own-wrapper ,class) + ,qualifiers + ,specializers + ,function + nil + ,name)) + + +(def-accessors standard-instance-instance-location-access ; method + nil ; backptr + %method.qualifiers + %method.specializers + %method.function + %method.gf + %method.name + %method.lambda-list) + +;;; Painful, but seems to be necessary. +(def-accessors standard-instance-instance-location-access ; standard-accessor-method + nil ; backptr + nil ;%method.qualifiers + nil ;%method.specializers + nil ;%method.function + nil ;%method.gf + nil ;%method.name + nil ;%method.lambda-list + %accessor-method.slot-definition) + + + + + +;; Generic Function Dispatch tables. +;; These accessors are at the beginning of the table. +;; rest of the table is alternating wrappers & combined-methods. + +(def-accessors %svref + %gf-dispatch-table-methods ; List of methods + %gf-dispatch-table-precedence-list ; List of argument numbers in precedence order + %gf-dispatch-table-keyvect ; keyword vector, set by E-G-F. + %gf-dispatch-table-argnum ; argument number + %gf-dispatch-table-gf ; back pointer to gf - NEW + %gf-dispatch-table-mask ; mask for rest of table + %gf-dispatch-table-first-data) ; offset to first data. Must follow mask. + +(defmacro %gf-dispatch-table-size (dt) + `(%i- (uvsize ,dt) ,(+ 2 %gf-dispatch-table-first-data))) + +(defmacro %gf-dispatch-table-ref (table index) + `(%svref ,table (%i+ ,index %gf-dispatch-table-first-data))) + +(defmacro %cons-gf-dispatch-table (size) + `(make-array (%i+ ,size ,(%i+ 2 %gf-dispatch-table-first-data)) + :initial-element nil)) + + +;;; method-combination info +(def-accessors svref + mci.class ; short-method-combination or long-method-combination + mci.options ; short-form-options or long-form function + mci.instances ; a population of instances + mci.gfs ; a population of generic-functions + ) + +(defmacro %cons-mci (&optional class options) + `(vector ,class ,options (%cons-population nil) (%cons-population nil))) + +;;; slot accessor info for primary classes +(def-accessors %svref + %slot-accessor-info.class + (%slot-accessor-info.accessor %slot-accessor-info.slot-name) + %slot-accessor-info.offset + ) + +(defmacro %cons-slot-accessor-info (class accessor-or-slot-name &optional offset) + `(vector ,class ,accessor-or-slot-name ,offset)) + +(def-accessors (combined-method) nth-immediate + combined-method.code-vector ; trampoline code vector + combined-method.thing ; arbitrary arg to dcode + combined-method.dcode ; discriminator function + combined-method.gf ; gf + combined-method.bits ; lfun-bits + ) +;;; The structure of a generic-function object (funcallable instance). +(def-accessors (generic-function) nth-immediate + gf.code-vector ; trampoline code-vector + gf.instance.class-wrapper ; instance class-wrapper + gf.slots ; slots vector + gf.dispatch-table ; effective-method cache + gf.dcode ; discriminating code + gf.hash ; hashing identity + gf.bits ; + ) + +;;; The slots of STANDARD-GENERIC-FUNCTION. +(def-accessors (standard-generic-function) standard-generic-function-instance-location-access + nil ; backptr + sgf.name ; generic-function-name + sgf.method-combination ; generic-function-method-combination + sgf.method-class ; generic-function-method-class + sgf.methods ; generic-function-methods + sgf.decls ; generic-function-declarations + sgf.%lambda-list ; explicit lambda-list + sgf.dependents ; dependents for MAP-DEPENDENTS et al. + ) + +(def-accessors (slot-id) %svref + nil ;'slot-id + slot-id.name ; slot name (symbol) + slot-id.index ; index (integer) + ) + +(def-accessors (foreign-object-domain) %svref + nil ; foreign-object-domain + foreign-object-domain-index ; 1..n + foreign-object-domain-name ; + foreign-object-domain-recognize ; function: is object one of ours ? + foreign-object-domain-class-of ; function: returns class of object + foreign-object-domain-classp ; function: true if object is a class + foreign-object-domain-instance-class-wrapper ; function: returns wrapper of object's class + foreign-object-domain-class-own-wrapper ; function: returns class own wrapper if class + foreign-object-domain-slots-vector ; returns slots vector of object or nil + foreign-object-domain-class-ordinal ; returns class ordinal if class + foreign-object-domain-set-class-ordinal ; sets class ordinal if class + ) + +;;; Hash table accessors. +(def-accessors (hash-table) %svref + nil ; 'HASH-TABLE + nhash.keytransF ; transform key into (values primary addressp) + nhash.compareF ; comparison function: 0 -> eq, -1 ->eql, else function + nhash.rehash-bits ; bitset (array (unsigned-byte 32)) for rehash + nhash.vector ; N pairs; n relatively prime to & larger than all secondary keys + nhash.lock ; flag: non-zero if lock-free + nhash.owner ; tcr of "owning" thread, else NIL. + nhash.grow-threshold ; Max # entries before grow + nhash.rehash-ratio ; inverted rehash-threshold + nhash.rehash-size ; rehash-size from user + nhash.puthash-count ; number of times table has been rehashed or grown + nhash.exclusion-lock ; read-write lock for access + nhash.find ; function: find vector-index + nhash.find-new ; function: find vector-index on put + nhash.read-only ; boolean: true when read-only + ) + +(def-accessors (lock-acquisition) %svref + nil ; 'lock-acquisition + lock-acquisition.status + ) + +(defmacro make-lock-acquisition () + `(%istruct 'lock-acquisition nil)) + +(def-accessors (semaphore-notification) %svref + nil ; 'semaphore-notification + semaphore-notification.status + ) + +(defmacro make-semaphore-notification () + `(%istruct 'semaphore-notification nil)) + +;;; Why were these ever in architecture-dependent packages ? +(defenum (:prefix "AREA-") + void ; list header + cstack ; a control stack + vstack ; a value stack + tstack ; (dynamic-extent) temp stack + readonly ; readonly section + watched ; static area containing a single object + static-cons ; static cons cells + managed-static ; growable static area + static ; static data in application + dynamic ; dynmaic (heap) data in application +) + +;;; areas are sorted such that (in the "succ" direction) codes are >=. +;;; If you think that you're looking for a stack (instead of a heap), look +;;; in the "pred" direction from the all-areas header. +(defconstant max-stack-area-code area-tstack) +(defconstant min-heap-area-code area-readonly) + + +;;; Lisp threads, which barely need to exist and aren't worth burning +;;; a separate tag on ... +(def-accessors (lisp-thread) %svref + nil ;'lisp-thread + lisp-thread.tcr + lisp-thread.name + lisp-thread.cs-size + lisp-thread.vs-size + lisp-thread.ts-size + lisp-thread.initial-function.args + lisp-thread.interrupt-functions + lisp-thread.interrupt-lock + lisp-thread.startup-function + lisp-thread.state + lisp-thread.state-change-lock + ) + +;;; "basic" (e.g., builtin, non-extensible) streams. +(def-accessors (basic-stream) %svref + basic-stream.wrapper ; a class wrapper object + basic-stream.flags ; fixnum; bits. + basic-stream.state ; typically an ioblock + basic-stream.info ; a plist for less-often-used things. +) + +(def-accessors (basic-file-stream) %svref + basic-file-stream.class ; a class object + basic-file-stream.flags ; fixnum; bits. + basic-file-stream.state ; typically an ioblock + basic-file-stream.info ; a plist for less-often-used things. + basic-file-stream.filename + basic-file-stream.actual-filename + basic-file-stream.external-format + ) + +;;; Bits in basic-stream.flags +(defenum (:prefix "BASIC-STREAM-FLAG.") + open-input + open-output + open-character + open-binary + file-stream) + + +(def-accessors (class-cell) %svref + nil ; 'class-cell + class-cell-name + class-cell-class + class-cell-instantiate + class-cell-extra ; wrapper in some cases + ) + +(defmacro make-class-cell (name) `(%istruct 'class-cell ,name nil '%make-instance nil)) + +;;; Map between TYPE-SPECIFIERS and CTYPEs +(def-accessors (type-cell) %svref + nil + type-cell-type-specifier + type-cell-ctype) + +(defmacro make-type-cell (specifier) `(%istruct 'type-cell ,specifier nil)) + +;;; Map between package names and packages, sometimes. +(def-accessors (package-ref) %svref + nil + package-ref.name ; a string + package-ref.pkg ; a package or NIL + ) + +(defmacro make-package-ref (name) `(%istruct 'package-ref (string ,name) nil)) + + +(def-accessor-macros %svref + nil ; 'external-entry-point + eep.address + eep.name + eep.container) + +(defmacro %cons-external-entry-point (name &optional container) + `(%istruct 'external-entry-point nil ,name ,container)) + +(def-accessor-macros %svref + nil ;'foreign-variable + fv.addr ; a MACPTR, or nil + fv.name ; a string + fv.type ; a foreign type + fv.container ; containing library + ) + + +(def-accessor-macros %svref + nil ;'shlib + shlib.soname + shlib.pathname + shlib.handle ; if explicitly opened + shlib.map + shlib.base + shlib.opencount) + +(defmacro %cons-shlib (soname pathname map base) + `(%istruct 'shlib ,soname ,pathname nil ,map ,base 0)) + +(def-accessors uvref ; %svref + () ;'entry + entry-test ;predicate function or count of higher priority others. + entry-fn ;pprint function + entry-full-spec ;list of priority and type specifier + ) + +;;; MacOS toolbox routines were once written mostly in Pascal, so some +;;; code still refers to callbacks from foreign code as "pascal-callable +;;; functions". + +; %Pascal-Functions% Entry +(def-accessor-macros %svref + pfe.routine-descriptor + pfe.proc-info + pfe.lisp-function + pfe.sym + pfe.without-interrupts + pfe.trace-p) + +(defmacro %cons-pfe (routine-descriptor proc-info lisp-function sym without-interrupts) + `(vector ,routine-descriptor ,proc-info ,lisp-function ,sym ,without-interrupts nil)) + + +(def-accessors %svref + () ; 'xp-structure + xp-base-stream ;;The stream io eventually goes to. + xp-linel ;;The line length to use for formatting. + xp-line-limit ;;If non-NIL the max number of lines to print. + xp-line-no ;;number of next line to be printed. + xp-char-mode ;;NIL :UP :DOWN :CAP0 :CAP1 :CAPW + xp-char-mode-counter ;depth of nesting of ~(...~) + xp-depth-in-blocks ;;Number of logical blocks at QRIGHT that + ;;are started but not ended. + xp-block-stack + xp-block-stack-ptr + ;;This stack is pushed and popped in accordance with the way blocks are + ;;nested at the moment they are entered into the queue. It contains the + ;;following block specific value. + ;;SECTION-START total position where the section (see AIM-1102) + ;;that is rightmost in the queue started. + xp-buffer + xp-charpos + xp-buffer-ptr + xp-buffer-offset + ;;This is a vector of characters (eg a string) that builds up the + ;;line images that will be printed out. BUFFER-PTR is the + ;;buffer position where the next character should be inserted in + ;;the string. CHARPOS is the output character position of the + ;;first character in the buffer (non-zero only if a partial line + ;;has been output). BUFFER-OFFSET is used in computing total lengths. + ;;It is changed to reflect all shifting and insertion of prefixes so that + ;;total length computes things as they would be if they were + ;;all on one line. Positions are kept three different ways + ;; Buffer position (eg BUFFER-PTR) + ;; Line position (eg (+ BUFFER-PTR CHARPOS)). Indentations are stored in this form. + ;; Total position if all on one line (eg (+ BUFFER-PTR BUFFER-OFFSET)) + ;; Positions are stored in this form. + xp-queue + xp-qleft + xp-qright + ;;This holds a queue of action descriptors. QLEFT and QRIGHT + ;;point to the next entry to dequeue and the last entry enqueued + ;;respectively. The queue is empty when + ;;(> QLEFT QRIGHT). The queue entries have several parts: + ;;QTYPE one of :NEWLINE/:IND/:START-BLOCK/:END-BLOCK + ;;QKIND :LINEAR/:MISER/:FILL/:MANDATORY or :UNCONDITIONAL/:FRESH + ;; or :BLOCK/:CURRENT + ;;QPOS total position corresponding to this entry + ;;QDEPTH depth in blocks of this entry. + ;;QEND offset to entry marking end of section this entry starts. (NIL until known.) + ;; Only :start-block and non-literal :newline entries can start sections. + ;;QOFFSET offset to :END-BLOCK for :START-BLOCK (NIL until known). + ;;QARG for :IND indentation delta + ;; for :START-BLOCK suffix in the block if any. + ;; or if per-line-prefix then cons of suffix and + ;; per-line-prefix. + ;; for :END-BLOCK suffix for the block if any. + xp-prefix + ;;this stores the prefix that should be used at the start of the line + xp-prefix-stack + xp-prefix-stack-ptr + ;;This stack is pushed and popped in accordance with the way blocks + ;;are nested at the moment things are taken off the queue and printed. + ;;It contains the following block specific values. + ;;PREFIX-PTR current length of PREFIX. + ;;SUFFIX-PTR current length of pending suffix + ;;NON-BLANK-PREFIX-PTR current length of non-blank prefix. + ;;INITIAL-PREFIX-PTR prefix-ptr at the start of this block. + ;;SECTION-START-LINE line-no value at last non-literal break at this level. + xp-suffix + ;;this stores the suffixes that have to be printed to close of the current + ;;open blocks. For convenient in popping, the whole suffix + ;;is stored in reverse order. + xp-stream ;;; the xp-stream containing this structure + xp-string-stream ;; string-stream for output until first circularity (in case none) + ) + +(def-accessors (afunc) %svref + () ; 'afunc + afunc-acode + afunc-parent + afunc-vars + afunc-inherited-vars + afunc-blocks + afunc-tags + afunc-inner-functions + afunc-name + afunc-bits + afunc-lfun + afunc-environment + afunc-lambdaform + afunc-argsword + afunc-ref-form + afunc-warnings + afunc-fn-refcount + afunc-fn-downward-refcount + afunc-all-vars + afunc-callers + afunc-vcells + afunc-fcells + afunc-fwd-refs + afunc-lfun-info + afunc-linkmap) + +(defmacro %make-afunc () + `(%istruct 'afunc + nil ;afunc-acode + nil ;afunc-parent + nil ;afunc-vars + nil ;afunc-inherited-vars + nil ;afunc-blocks + nil ;afunc-tags + nil ;afunc-inner-functions + nil ;afunc-name + nil ;afunc-bits + nil ;afunc-lfun + nil ;afunc-environment + nil ;afunc-lambdaform + nil ;afunc-argsword + nil ;afunc-ref-form + nil ;afunc-warnings + nil ;afunc-fn-refcount + nil ;afunc-fn-downward-refcount + nil ;afunc-all-vars + nil ;afunc-callers + nil ;afunc-vcells + nil ;afunc-fcells + nil ;afunc-fwd-refs + nil ;afunc-lfun-info + nil ;afunc-linkmap + )) + + +(def-accessors (compiler-policy) uvref + nil ; 'compiler-policy + policy.allow-tail-recursion-elimination + policy.inhibit-register-allocation + policy.trust-declarations + policy.open-code-inline + policy.inhibit-safety-checking + policy.declarations-typecheck + policy.inline-self-calls + policy.allow-transforms + policy.force-boundp-checks + policy.allow-constant-substitution + policy.misc) + + +(def-accessors (deferred-warnings) %svref + nil + deferred-warnings.parent + deferred-warnings.warnings + deferred-warnings.defs + deferred-warnings.last-file +) + +;;; loader framework istruct +(def-accessors (faslapi) %svref + () + ;; these represent all users of faslstate.iobuffer, .bufcount, and + ;; .faslfd -- I think these are all the important file- and + ;; buffer-IO-specific slots in faslstate; encapsulating these allows + ;; sophisticated users to load fasl data from nonstandard sources + ;; without too much trouble + faslapi.fasl-open + faslapi.fasl-close + faslapi.fasl-init-buffer + faslapi.fasl-set-file-pos + faslapi.fasl-get-file-pos + faslapi.fasl-read-buffer + faslapi.fasl-read-byte + faslapi.fasl-read-n-bytes) + + +(defmacro istruct-cell-name (cell) + `(car ,cell)) + +(defmacro istruct-cell-info (cell) + `(cdr ,cell)) + +(provide "LISPEQU") + +;;; End of lispequ.lisp Index: /branches/new-random/library/loop.lisp =================================================================== --- /branches/new-random/library/loop.lisp (revision 13309) +++ /branches/new-random/library/loop.lisp (revision 13309) @@ -0,0 +1,2129 @@ +;;; -*- Mode: LISP; Syntax: Common-lisp; Package: (ANSI-LOOP "COMMON-LISP"); Base: 10; Lowercase:T -*- +;;;> +;;;> Portions of LOOP are Copyright (c) 1986 by the Massachusetts Institute of Technology. +;;;> All Rights Reserved. +;;;> +;;;> Permission to use, copy, modify and distribute this software and its +;;;> documentation for any purpose and without fee is hereby granted, +;;;> provided that the M.I.T. copyright notice appear in all copies and that +;;;> both that copyright notice and this permission notice appear in +;;;> supporting documentation. The names "M.I.T." and "Massachusetts +;;;> Institute of Technology" may not be used in advertising or publicity +;;;> pertaining to distribution of the software without specific, written +;;;> prior permission. Notice must be given in supporting documentation that +;;;> copying distribution is by permission of M.I.T. M.I.T. makes no +;;;> representations about the suitability of this software for any purpose. +;;;> It is provided "as is" without express or implied warranty. +;;;> +;;;> Massachusetts Institute of Technology +;;;> 77 Massachusetts Avenue +;;;> Cambridge, Massachusetts 02139 +;;;> United States of America +;;;> +1-617-253-1000 +;;;> +;;;> Portions of LOOP are Copyright (c) 1989, 1990, 1991, 1992 by Symbolics, Inc. +;;;> All Rights Reserved. +;;;> +;;;> Permission to use, copy, modify and distribute this software and its +;;;> documentation for any purpose and without fee is hereby granted, +;;;> provided that the Symbolics copyright notice appear in all copies and +;;;> that both that copyright notice and this permission notice appear in +;;;> supporting documentation. The name "Symbolics" may not be used in +;;;> advertising or publicity pertaining to distribution of the software +;;;> without specific, written prior permission. Notice must be given in +;;;> supporting documentation that copying distribution is by permission of +;;;> Symbolics. Symbolics makes no representations about the suitability of +;;;> this software for any purpose. It is provided "as is" without express +;;;> or implied warranty. +;;;> +;;;> Symbolics, CLOE Runtime, and Minima are trademarks, and CLOE, Genera, +;;;> and Zetalisp are registered trademarks of Symbolics, Inc. +;;;> +;;;> Symbolics, Inc. +;;;> 8 New England Executive Park, East +;;;> Burlington, Massachusetts 01803 +;;;> United States of America +;;;> +1-617-221-1000 + +;;;;;;;;;;;;;;;;;;;;;;;;;; +;;; +;;; Modification History +;;; +;;; 07/28/92 bill loop-bind-block now does destructuring correctly. +;;; 07/07/92 bill Prevent one more warning in loop-hash-table-iteration-path +;;; 04/23/92 bill loop-do-finally now supports "finally return expr" +;;; and "finally [do | doing] {expr}*" instead of just +;;; "finally {expr}*". +;;; 03/23/92 gb Use IGNORABLE declarations when (if (multiple-value-setq (...) ...) ...) +;;; involved. +;;; ------------- 2.0 +;;; 03/12/92 bill gb's patches to prevent compiler warnings +;;; for hash-values, hash-types, and symbols + +;;;; LOOP Iteration Macro + +(defpackage ANSI-LOOP (:use "COMMON-LISP")) + +(in-package :ansi-loop) + +;;; Technology. +;;; +;;; The LOOP iteration macro is one of a number of pieces of code +;;; originally developed at MIT for which free distribution has been +;;; permitted, as long as the code is not sold for profit, and as long +;;; as notification of MIT's interest in the code is preserved. +;;; +;;; This version of LOOP, which is almost entirely rewritten both as +;;; clean-up and to conform with the ANSI Lisp LOOP standard, started +;;; life as MIT LOOP version 829 (which was a part of NIL, possibly +;;; never released). +;;; +;;; A "light revision" was performed by me (Glenn Burke) while at +;;; Palladian Software in April 1986, to make the code run in Common +;;; Lisp. This revision was informally distributed to a number of +;;; people, and was sort of the "MIT" version of LOOP for running in +;;; Common Lisp. +;;; +;;; A later more drastic revision was performed at Palladian perhaps a +;;; year later. This version was more thoroughly Common Lisp in style, +;;; with a few miscellaneous internal improvements and extensions. I +;;; have lost track of this source, apparently never having moved it to +;;; the MIT distribution point. I do not remember if it was ever +;;; distributed. +;;; +;;; This revision for the ANSI standard is based on the code of my April +;;; 1986 version, with almost everything redesigned and/or rewritten. + + + +;;; The design of this LOOP is intended to permit, using mostly the same +;;; kernel of code, up to three different "loop" macros: +;;; +;;; (1) The unextended, unextensible ANSI standard LOOP; +;;; +;;; (2) A clean "superset" extension of the ANSI LOOP which provides +;;; functionality similar to that of the old LOOP, but "in the style of" +;;; the ANSI LOOP. For instance, user-definable iteration paths, with a +;;; somewhat cleaned-up interface. +;;; +;;; (3) Extensions provided in another file which can make this LOOP +;;; kernel behave largely compatibly with the Genera-vintage LOOP macro, +;;; with only a small addition of code (instead of two whole, separate, +;;; LOOP macros). +;;; +;;; Each of the above three LOOP variations can coexist in the same LISP +;;; environment. +;;; + + + +;;;; Miscellaneous Environment Things + +;;; The uses of this macro are retained in the CL version of loop, in +;;; case they are needed in a particular implementation. Originally +;;; dating from the use of the Zetalisp COPYLIST* function, this is used +;;; in situations where, were cdr-coding in use, having cdr-NIL at the +;;; end of the list might be suboptimal because the end of the list will +;;; probably be RPLACDed and so cdr-normal should be used instead. +(defmacro loop-copylist* (l) + `(copy-list ,l)) + +(defvar *loop-gentemp* + nil) + +(defun loop-gentemp (&optional (pref 'loopvar-)) + (if *loop-gentemp* + (gentemp (string pref)) + (gensym (string pref)))) + +(defvar *loop-real-data-type* 'real) + +(defun loop-optimization-quantities (env) + ;;@@@@ The ANSI conditionalization here is for those lisps that implement + ;; DECLARATION-INFORMATION (from cleanup SYNTACTIC-ENVIRONMENT-ACCESS). + ;; It is really commentary on how this code could be written. I don't + ;; actually expect there to be an ANSI #+-conditional -- it should be + ;; replaced with the appropriate conditional name for your + ;; implementation/dialect. + ;; Uhh, DECLARATION-INFORMATION isn't ANSI-CL anymore + (let ((stuff (ccl:declaration-information 'optimize env))) + (values (or (cadr (assoc 'speed stuff)) 1) + (or (cadr (assoc 'space stuff)) 1) + (or (cadr (assoc 'safety stuff)) 1) + (or (cadr (assoc 'compilation-speed stuff)) 1) + (or (cadr (assoc 'debug stuff)) 1)))) + + +;;;@@@@ The following form takes a list of variables and a form which presumably +;;; references those variables, and wraps it somehow so that the compiler does not +;;; consider those variables have been referenced. The intent of this is that +;;; iteration variables can be flagged as unused by the compiler, e.g. I in +;;; (loop for i from 1 to 10 do (print t)), since we will tell it when a usage +;;; of it is "invisible" or "not to be considered". +;;;We implicitly assume that a setq does not count as a reference. That is, the +;;; kind of form generated for the above loop construct to step I, simplified, is +;;; `(SETQ I ,(HIDE-VARIABLE-REFERENCES '(I) '(1+ I))). +(defun hide-variable-references (variable-list form) + (declare (ignore variable-list)) + form) + +;;;@@@@ The following function takes a flag, a variable, and a form which presumably +;;; references that variable, and wraps it somehow so that the compiler does not +;;; consider that variable to have been referenced. The intent of this is that +;;; iteration variables can be flagged as unused by the compiler, e.g. I in +;;; (loop for i from 1 to 10 do (print t)), since we will tell it when a usage +;;; of it is "invisible" or "not to be considered". +;;;We implicitly assume that a setq does not count as a reference. That is, the +;;; kind of form generated for the above loop construct to step I, simplified, is +;;; `(SETQ I ,(HIDE-VARIABLE-REFERENCES T 'I '(1+ I))). +;;;Certain cases require that the "invisibility" of the reference be conditional upon +;;; something. This occurs in cases of "named" variables (the USING clause). For instance, +;;; we want IDX in (LOOP FOR E BEING THE VECTOR-ELEMENTS OF V USING (INDEX IDX) ...) +;;; to be "invisible" when it is stepped, so that the user gets informed if IDX is +;;; not referenced. However, if no USING clause is present, we definitely do not +;;; want to be informed that some random gensym is not used. +;;;It is easier for the caller to do this conditionally by passing a flag (which +;;; happens to be the second value of NAMED-VARIABLE, q.v.) to this function than +;;; for all callers to contain the conditional invisibility construction. +(defun hide-variable-reference (really-hide variable form) + (declare (ignore really-hide variable)) + form) + + + +;;;; List Collection Macrology + + +(defmacro with-loop-list-collection-head ((head-var tail-var &optional user-head-var) + &body body) + (let ((l (and user-head-var (list (list user-head-var nil))))) + `(let* ((,head-var (list nil)) (,tail-var ,head-var) ,@l) + ,@body))) + + +(defmacro loop-collect-rplacd (&environment env + (head-var tail-var &optional user-head-var) form) + (setq form (macroexpand form env)) + (flet ((cdr-wrap (form n) + (declare (fixnum n)) + (do () ((<= n 4) (setq form `(,(case n + (1 'cdr) + (2 'cddr) + (3 'cdddr) + (4 'cddddr)) + ,form))) + (setq form `(cddddr ,form) n (- n 4))))) + (let ((tail-form form) (ncdrs nil)) + ;;Determine if the form being constructed is a list of known length. + (when (consp form) + (cond ((eq (car form) 'list) + (setq ncdrs (1- (length (cdr form)))) + ;;@@@@ Because the last element is going to be RPLACDed, + ;; we don't want the cdr-coded implementations to use + ;; cdr-nil at the end (which would just force copying + ;; the whole list again). + ) + ((member (car form) '(list* cons)) + (when (and (cddr form) (member (car (last form)) '(nil 'nil))) + (setq ncdrs (- (length (cdr form)) 2)))))) + (let ((answer + (cond ((null ncdrs) + `(when (setf (cdr ,tail-var) ,tail-form) + (setq ,tail-var (last (cdr ,tail-var))))) + ((< ncdrs 0) (return-from loop-collect-rplacd nil)) + ((= ncdrs 0) + ;;@@@@ Here we have a choice of two idioms: + ;; (rplacd tail (setq tail tail-form)) + ;; (setq tail (setf (cdr tail) tail-form)). + ;;Genera and most others I have seen do better with the former. + `(rplacd ,tail-var (setq ,tail-var ,tail-form))) + (t `(setq ,tail-var ,(cdr-wrap `(setf (cdr ,tail-var) ,tail-form) + ncdrs)))))) + ;;If not using locatives or something similar to update the user's + ;; head variable, we've got to set it... It's harmless to repeatedly set it + ;; unconditionally, and probably faster than checking. + (when user-head-var + (setq answer `(progn ,answer (setq ,user-head-var (cdr ,head-var))))) + answer)))) + + +(defmacro loop-collect-answer (head-var &optional user-head-var) + (or user-head-var + (progn + ;;If we use locatives to get tail-updating to update the head var, + ;; then the head var itself contains the answer. Otherwise we + ;; have to cdr it. + `(cdr ,head-var)))) + + + +;;;; Maximization Technology + + +#| +The basic idea of all this minimax randomness here is that we have to +have constructed all uses of maximize and minimize to a particular +"destination" before we can decide how to code them. The goal is to not +have to have any kinds of flags, by knowing both that (1) the type is +something which we can provide an initial minimum or maximum value for +and (2) know that a MAXIMIZE and MINIMIZE are not being combined. + +SO, we have a datastructure which we annotate with all sorts of things, +incrementally updating it as we generate loop body code, and then use +a wrapper and internal macros to do the coding when the loop has been +constructed. +|# + + +(defstruct (loop-minimax + (:constructor make-loop-minimax-internal) + (:copier nil) + (:predicate nil)) + answer-variable + type + temp-variable + flag-variable + operations + infinity-data) + + +(defvar *loop-minimax-type-infinities-alist* + '((fixnum most-positive-fixnum most-negative-fixnum)) + ) + + +(defun make-loop-minimax (answer-variable type) + (let ((infinity-data (cdr (assoc type *loop-minimax-type-infinities-alist* :test #'subtypep)))) + (make-loop-minimax-internal + :answer-variable answer-variable + :type type + :temp-variable (loop-gentemp 'loop-maxmin-temp-) + :flag-variable (and (not infinity-data) (loop-gentemp 'loop-maxmin-flag-)) + :operations nil + :infinity-data infinity-data))) + + +(defun loop-note-minimax-operation (operation minimax) + (pushnew (the symbol operation) (loop-minimax-operations minimax)) + (when (and (cdr (loop-minimax-operations minimax)) + (not (loop-minimax-flag-variable minimax))) + (setf (loop-minimax-flag-variable minimax) (loop-gentemp 'loop-maxmin-flag-))) + operation) + + +(defmacro with-minimax-value (lm &body body) + (let ((init (loop-typed-init (loop-minimax-type lm))) + (which (car (loop-minimax-operations lm))) + (infinity-data (loop-minimax-infinity-data lm)) + (answer-var (loop-minimax-answer-variable lm)) + (temp-var (loop-minimax-temp-variable lm)) + (flag-var (loop-minimax-flag-variable lm)) + (type (loop-minimax-type lm))) + (if flag-var + `(let ((,answer-var ,init) (,temp-var ,init) (,flag-var nil)) + (declare (type ,type ,answer-var ,temp-var)) + ,@body) + `(let ((,answer-var ,(if (eq which 'min) (first infinity-data) (second infinity-data))) + (,temp-var ,init)) + (declare (type ,type ,answer-var ,temp-var)) + ,@body)))) + + +(defmacro loop-accumulate-minimax-value (lm operation form) + (let* ((answer-var (loop-minimax-answer-variable lm)) + (temp-var (loop-minimax-temp-variable lm)) + (flag-var (loop-minimax-flag-variable lm)) + (test + (hide-variable-reference + t (loop-minimax-answer-variable lm) + `(,(ecase operation + (min '<) + (max '>)) + ,temp-var ,answer-var)))) + `(progn + (setq ,temp-var ,form) + (when ,(if flag-var `(or (not ,flag-var) ,test) test) + (setq ,@(and flag-var `(,flag-var t)) + ,answer-var ,temp-var))))) + + + + +;;;; Loop Keyword Tables + + +#| +LOOP keyword tables are hash tables string keys and a test of EQUAL. + +The actual descriptive/dispatch structure used by LOOP is called a "loop +universe" contains a few tables and parameterizations. The basic idea is +that we can provide a non-extensible ANSI-compatible loop environment, +an extensible ANSI-superset loop environment, and (for such environments +as CLOE) one which is "sufficiently close" to the old Genera-vintage +LOOP for use by old user programs without requiring all of the old LOOP +code to be loaded. +|# + + +;;;; Token Hackery + + +;;;Compare two "tokens". The first is the frob out of *LOOP-SOURCE-CODE*, +;;; the second a symbol to check against. +(defun loop-tequal (x1 x2) + (and (symbolp x1) (string= x1 x2))) + + +(defun loop-tassoc (kwd alist) + (and (symbolp kwd) (assoc kwd alist :test #'string=))) + + +(defun loop-tmember (kwd list) + (and (symbolp kwd) (member kwd list :test #'string=))) + + +(defun loop-lookup-keyword (loop-token table) + (and (symbolp loop-token) + (values (gethash (symbol-name loop-token) table)))) + + +(defmacro loop-store-table-data (symbol table datum) + `(setf (gethash (symbol-name ,symbol) ,table) ,datum)) + + +(defstruct (loop-universe + (:print-function print-loop-universe) + (:copier nil) + (:predicate nil)) + keywords ;hash table, value = (fn-name . extra-data). + iteration-keywords ;hash table, value = (fn-name . extra-data). + for-keywords ;hash table, value = (fn-name . extra-data). + path-keywords ;hash table, value = (fn-name . extra-data). + type-symbols ;hash table of type SYMBOLS, test EQ, value = CL type specifier. + type-keywords ;hash table of type STRINGS, test EQUAL, value = CL type spec. + ansi ;NIL, T, or :EXTENDED. + implicit-for-required ;see loop-hack-iteration + ) + + +(defun print-loop-universe (u stream level) + (declare (ignore level)) + (let ((str (case (loop-universe-ansi u) + ((nil) "Non-ANSI") + ((t) "ANSI") + (:extended "Extended-ANSI") + (t (loop-universe-ansi u))))) + (print-unreadable-object (u stream :type t :identity t) + (princ str stream)))) + + +;;;This is the "current" loop context in use when we are expanding a +;;;loop. It gets bound on each invocation of LOOP. +(defvar *loop-universe*) + + +(defun make-standard-loop-universe (&key keywords for-keywords iteration-keywords path-keywords + type-keywords type-symbols ansi) + (check-type ansi (member nil t :extended)) + (flet ((maketable (entries) + (let* ((size (length entries)) + (ht (make-hash-table :size (if (< size 10) 10 size) :test #'equal))) + (dolist (x entries) (setf (gethash (symbol-name (car x)) ht) (cadr x))) + ht))) + (make-loop-universe + :keywords (maketable keywords) + :for-keywords (maketable for-keywords) + :iteration-keywords (maketable iteration-keywords) + :path-keywords (maketable path-keywords) + :ansi ansi + :implicit-for-required (not (null ansi)) + :type-keywords (maketable type-keywords) + :type-symbols (let* ((size (length type-symbols)) + (ht (make-hash-table :size (if (< size 10) 10 size) :test #'eq))) + (dolist (x type-symbols) + (if (atom x) (setf (gethash x ht) x) (setf (gethash (car x) ht) (cadr x)))) + ht)))) + + + +;;;; Setq Hackery + + +(defvar *loop-destructuring-hooks* + nil + "If not NIL, this must be a list of two things: +a LET-like macro, and a SETQ-like macro, which perform LOOP-style destructuring.") + + +(defun loop-make-psetq (frobs) + (and frobs + (loop-make-desetq + (list (car frobs) + (if (null (cddr frobs)) (cadr frobs) + `(prog1 ,(cadr frobs) + ,(loop-make-psetq (cddr frobs)))))))) + + +(defun loop-make-desetq (var-val-pairs) + (if (null var-val-pairs) + nil + (cons (if *loop-destructuring-hooks* + (cadr *loop-destructuring-hooks*) + 'loop-really-desetq) + var-val-pairs))) + + +(defvar *loop-desetq-temporary* + (make-symbol "LOOP-DESETQ-TEMP")) + + +(defmacro loop-really-desetq (&environment env &rest var-val-pairs) + (labels ((find-non-null (var) + ;; see if there's any non-null thing here + ;; recurse if the list element is itself a list + (do ((tail var)) ((not (consp tail)) tail) + (when (find-non-null (pop tail)) (return t)))) + (loop-desetq-internal (var val &optional temp) + ;; returns a list of actions to be performed + (typecase var + (null + (when (consp val) + ;; don't lose possible side-effects + (if (eq (car val) 'prog1) + ;; these can come from psetq or desetq below. + ;; throw away the value, keep the side-effects. + ;;Special case is for handling an expanded POP. + (mapcan #'(lambda (x) + (and (consp x) + (or (not (eq (car x) 'car)) + (not (symbolp (cadr x))) + (not (symbolp (setq x (macroexpand x env))))) + (cons x nil))) + (cdr val)) + `(,val)))) + (cons + (let* ((car (car var)) + (cdr (cdr var)) + (car-non-null (find-non-null car)) + (cdr-non-null (find-non-null cdr))) + (when (or car-non-null cdr-non-null) + (if cdr-non-null + (let* ((temp-p temp) + (temp (or temp *loop-desetq-temporary*)) + (body `(,@(loop-desetq-internal car `(car ,temp)) + (setq ,temp (cdr ,temp)) + ,@(loop-desetq-internal cdr temp temp)))) + (if temp-p + `(,@(unless (eq temp val) + `((setq ,temp ,val))) + ,@body) + `((let ((,temp ,val)) + ,@body)))) + ;; no cdring to do + (loop-desetq-internal car `(car ,val) temp))))) + (otherwise + (unless (eq var val) + `((setq ,var ,val))))))) + (do ((actions)) + ((null var-val-pairs) + (if (null (cdr actions)) (car actions) `(progn ,@(nreverse actions)))) + (setq actions (revappend + (loop-desetq-internal (pop var-val-pairs) (pop var-val-pairs)) + actions))))) + + + +;;;; LOOP-local variables + +;;;This is the "current" pointer into the LOOP source code. +(defvar *loop-source-code*) + + +;;;This is the pointer to the original, for things like NAMED that +;;;insist on being in a particular position +(defvar *loop-original-source-code*) + + +;;;This is *loop-source-code* as of the "last" clause. It is used +;;;primarily for generating error messages (see loop-error, loop-warn). +(defvar *loop-source-context*) + + +;;;List of names for the LOOP, supplied by the NAMED clause. +(defvar *loop-names*) + +;;;The macroexpansion environment given to the macro. +(defvar *loop-macro-environment*) + +;;;This holds variable names specified with the USING clause. +;;; See LOOP-NAMED-VARIABLE. +(defvar *loop-named-variables*) + +;;; LETlist-like list being accumulated for one group of parallel bindings. +(defvar *loop-variables*) + +;;;List of declarations being accumulated in parallel with +;;;*loop-variables*. +(defvar *loop-declarations*) + +;;;Used by LOOP for destructuring binding, if it is doing that itself. +;;; See loop-make-variable. +(defvar *loop-desetq-crocks*) + +;;; List of wrapping forms, innermost first, which go immediately inside +;;; the current set of parallel bindings being accumulated in +;;; *loop-variables*. The wrappers are appended onto a body. E.g., +;;; this list could conceivably has as its value ((with-open-file (g0001 +;;; g0002 ...))), with g0002 being one of the bindings in +;;; *loop-variables* (this is why the wrappers go inside of the variable +;;; bindings). +(defvar *loop-wrappers*) + +;;;This accumulates lists of previous values of *loop-variables* and the +;;;other lists above, for each new nesting of bindings. See +;;;loop-bind-block. +(defvar *loop-bind-stack*) + +;;;This is a LOOP-global variable for the (obsolete) NODECLARE clause +;;;which inhibits LOOP from actually outputting a type declaration for +;;;an iteration (or any) variable. +(defvar *loop-nodeclare*) + +;;;This is simply a list of LOOP iteration variables, used for checking +;;;for duplications. +(defvar *loop-iteration-variables*) + + +;;;List of prologue forms of the loop, accumulated in reverse order. +(defvar *loop-prologue*) + +(defvar *loop-before-loop*) +(defvar *loop-body*) +(defvar *loop-after-body*) + +;;;This is T if we have emitted any body code, so that iteration driving +;;;clauses can be disallowed. This is not strictly the same as +;;;checking *loop-body*, because we permit some clauses such as RETURN +;;;to not be considered "real" body (so as to permit the user to "code" +;;;an abnormal return value "in loop"). +(defvar *loop-emitted-body*) + + +;;;List of epilogue forms (supplied by FINALLY generally), accumulated +;;; in reverse order. +(defvar *loop-epilogue*) + +;;;List of epilogue forms which are supplied after the above "user" +;;;epilogue. "normal" termination return values are provide by putting +;;;the return form in here. Normally this is done using +;;;loop-emit-final-value, q.v. +(defvar *loop-after-epilogue*) + +;;;The "culprit" responsible for supplying a final value from the loop. +;;;This is so loop-emit-final-value can moan about multiple return +;;;values being supplied. +(defvar *loop-final-value-culprit*) + +;;;If not NIL, we are in some branch of a conditional. Some clauses may +;;;be disallowed. +(defvar *loop-inside-conditional*) + +;;;If not NIL, this is a temporary bound around the loop for holding the +;;;temporary value for "it" in things like "when (f) collect it". It +;;;may be used as a supertemporary by some other things. +(defvar *loop-when-it-variable*) + +;;;Sometimes we decide we need to fold together parts of the loop, but +;;;some part of the generated iteration code is different for the first +;;;and remaining iterations. This variable will be the temporary which +;;;is the flag used in the loop to tell whether we are in the first or +;;;remaining iterations. +(defvar *loop-never-stepped-variable*) + +;;;List of all the value-accumulation descriptor structures in the loop. +;;; See loop-get-collection-info. +(defvar *loop-collection-cruft*) ; for multiple COLLECTs (etc) + + + +;;;; Code Analysis Stuff + + +(defun loop-constant-fold-if-possible (form &optional expected-type) + (let ((new-form form) (constantp nil) (constant-value nil)) + (when (setq constantp (constantp new-form)) + (setq constant-value (eval new-form))) + (when (and constantp expected-type) + (unless (typep constant-value expected-type) + (loop-warn "The form ~S evaluated to ~S, which was not of the anticipated type ~S." + form constant-value expected-type) + (setq constantp nil constant-value nil))) + (values new-form constantp constant-value))) + + +(defun loop-constantp (form) + (constantp form)) + + + +;;;; LOOP Iteration Optimization + +(defvar *loop-duplicate-code* + nil) + + +(defvar *loop-iteration-flag-variable* + (make-symbol "LOOP-NOT-FIRST-TIME")) + + +(defun loop-code-duplication-threshold (env) + (multiple-value-bind (speed space) (loop-optimization-quantities env) + (+ 40 (* (- speed space) 10)))) + + +(defmacro loop-body (&environment env + prologue + before-loop + main-body + after-loop + epilogue + &aux rbefore rafter flagvar) + (unless (= (length before-loop) (length after-loop)) + (loop-error "LOOP-BODY called with non-synched before- and after-loop lists.")) + ;;All our work is done from these copies, working backwards from the end: + (setq rbefore (reverse before-loop) rafter (reverse after-loop)) + (labels ((psimp (l) + (let ((ans nil)) + (dolist (x l) + (when x + (push x ans) + (when (and (consp x) (member (car x) '(go return return-from))) + (return nil)))) + (nreverse ans))) + (pify (l) (if (null (cdr l)) (car l) `(progn ,@l))) + (makebody () + (let ((form `(tagbody + ,@(psimp (append prologue (nreverse rbefore))) + next-loop + ,@(psimp (append main-body (nreconc rafter `((go next-loop))))) + end-loop + ,@(psimp epilogue)))) + (if flagvar `(let ((,flagvar nil)) ,form) form)))) + (when (or *loop-duplicate-code* (not rbefore)) + (return-from loop-body (makebody))) + ;; This outer loop iterates once for each not-first-time flag test generated + ;; plus once more for the forms that don't need a flag test + (do ((threshold (loop-code-duplication-threshold env))) (nil) + (declare (fixnum threshold)) + ;; Go backwards from the ends of before-loop and after-loop merging all the equivalent + ;; forms into the body. + (do () ((or (null rbefore) (not (equal (car rbefore) (car rafter))))) + (push (pop rbefore) main-body) + (pop rafter)) + (unless rbefore (return (makebody))) + ;; The first forms in rbefore & rafter (which are the chronologically + ;; last forms in the list) differ, therefore they cannot be moved + ;; into the main body. If everything that chronologically precedes + ;; them either differs or is equal but is okay to duplicate, we can + ;; just put all of rbefore in the prologue and all of rafter after + ;; the body. Otherwise, there is something that is not okay to + ;; duplicate, so it and everything chronologically after it in + ;; rbefore and rafter must go into the body, with a flag test to + ;; distinguish the first time around the loop from later times. + ;; What chronologically precedes the non-duplicatable form will + ;; be handled the next time around the outer loop. + (do ((bb rbefore (cdr bb)) (aa rafter (cdr aa)) (lastdiff nil) (count 0) (inc nil)) + ((null bb) (return-from loop-body (makebody))) ;Did it. + (cond ((not (equal (car bb) (car aa))) (setq lastdiff bb count 0)) + ((or (not (setq inc (estimate-code-size (car bb) env))) + (> (incf count inc) threshold)) + ;; Ok, we have found a non-duplicatable piece of code. Everything + ;; chronologically after it must be in the central body. + ;; Everything chronologically at and after lastdiff goes into the + ;; central body under a flag test. + (let ((then nil) (else nil)) + (do () (nil) + (push (pop rbefore) else) + (push (pop rafter) then) + (when (eq rbefore (cdr lastdiff)) (return))) + (unless flagvar + (push `(setq ,(setq flagvar *loop-iteration-flag-variable*) t) else)) + (push `(if ,flagvar ,(pify (psimp then)) ,(pify (psimp else))) + main-body)) + ;; Everything chronologically before lastdiff until the non-duplicatable form (car bb) + ;; is the same in rbefore and rafter so just copy it into the body + (do () (nil) + (pop rafter) + (push (pop rbefore) main-body) + (when (eq rbefore (cdr bb)) (return))) + (return))))))) + + + + +(defun duplicatable-code-p (expr env) + (if (null expr) 0 + (let ((ans (estimate-code-size expr env))) + (declare (fixnum ans)) + ;;@@@@ Use (DECLARATION-INFORMATION 'OPTIMIZE ENV) here to get an alist of + ;; optimize quantities back to help quantify how much code we are willing to + ;; duplicate. + ans))) + + +(defvar *special-code-sizes* + '((return 0) (progn 0) + (null 1) (not 1) (eq 1) (car 1) (cdr 1) + (when 1) (unless 1) (if 1) + (caar 2) (cadr 2) (cdar 2) (cddr 2) + (caaar 3) (caadr 3) (cadar 3) (caddr 3) (cdaar 3) (cdadr 3) (cddar 3) (cdddr 3) + (caaaar 4) (caaadr 4) (caadar 4) (caaddr 4) + (cadaar 4) (cadadr 4) (caddar 4) (cadddr 4) + (cdaaar 4) (cdaadr 4) (cdadar 4) (cdaddr 4) + (cddaar 4) (cddadr 4) (cdddar 4) (cddddr 4))) + + +(defvar *estimate-code-size-punt* + '(block + do do* dolist + flet + labels lambda let let* locally + macrolet multiple-value-bind + prog prog* + symbol-macrolet + tagbody + unwind-protect + with-open-file)) + + +(defun destructuring-size (x) + (do ((x x (cdr x)) (n 0 (+ (destructuring-size (car x)) n))) + ((atom x) (+ n (if (null x) 0 1))))) + + +(defun estimate-code-size (x env) + (catch 'estimate-code-size + (estimate-code-size-1 x env))) + + +(defun estimate-code-size-1 (x env) + (flet ((list-size (l) + (let ((n 0)) + (declare (fixnum n)) + (dolist (x l n) (incf n (estimate-code-size-1 x env)))))) + ;;@@@@ ???? (declare (function list-size (list) fixnum)) + (cond ((constantp x) 1) + ((symbolp x) (multiple-value-bind (new-form expanded-p) (macroexpand-1 x env) + (if expanded-p (estimate-code-size-1 new-form env) 1))) + ((atom x) 1) ;??? self-evaluating??? + ((symbolp (car x)) + (let ((fn (car x)) (tem nil) (n 0)) + (declare (symbol fn) (fixnum n)) + (macrolet ((f (overhead &optional (args nil args-p)) + `(the fixnum (+ (the fixnum ,overhead) + (the fixnum (list-size ,(if args-p args '(cdr x)))))))) + (cond ((setq tem (get fn 'estimate-code-size)) + (typecase tem + (fixnum (f tem)) + (t (funcall tem x env)))) + ((setq tem (assoc fn *special-code-sizes*)) (f (second tem))) + ((eq fn 'cond) + (dolist (clause (cdr x) n) (incf n (list-size clause)) (incf n))) + ((eq fn 'desetq) + (do ((l (cdr x) (cdr l))) ((null l) n) + (setq n (+ n (destructuring-size (car l)) (estimate-code-size-1 (cadr l) env))))) + ((member fn '(setq psetq)) + (do ((l (cdr x) (cdr l))) ((null l) n) + (setq n (+ n (estimate-code-size-1 (cadr l) env) 1)))) + ((eq fn 'go) 1) + ((eq fn 'function) + ;;This skirts the issue of implementationally-defined lambda macros + ;; by recognizing CL function names and nothing else. + (if (or (symbolp (cadr x)) + (ccl::setf-function-name-p (cadr x))) + 1 + (throw 'duplicatable-code-p nil))) + ((eq fn 'multiple-value-setq) (f (length (second x)) (cddr x))) + ((eq fn 'return-from) (1+ (estimate-code-size-1 (third x) env))) + ((or (special-operator-p fn) (member fn *estimate-code-size-punt*)) + (throw 'estimate-code-size nil)) + (t (multiple-value-bind (new-form expanded-p) (macroexpand-1 x env) + (if expanded-p + (estimate-code-size-1 new-form env) + (f 3)))))))) + (t (throw 'estimate-code-size nil))))) + + + +;;;; Loop Errors + + +(defun loop-context () + (do ((l *loop-source-context* (cdr l)) (new nil (cons (car l) new))) + ((eq l (cdr *loop-source-code*)) (nreverse new)))) + + +(defun loop-error (format-string &rest format-args) + (ccl::signal-program-error "~?~%Current LOOP context:~{ ~S~}." + format-string format-args (loop-context))) + + +(defun loop-warn (format-string &rest format-args) + (warn "~?~%Current LOOP context:~{ ~S~}." format-string format-args (loop-context))) + +(pushnew '(loop-error . 0) ccl::*format-arg-functions* :test #'equal) +(pushnew '(loop-warn . 0) ccl::*format-arg-functions* :test #'equal) + + +(defun loop-check-data-type (specified-type required-type + &optional (default-type required-type)) + (if (null specified-type) + default-type + (multiple-value-bind (a b) (subtypep specified-type required-type) + (cond ((not b) + (loop-warn "LOOP couldn't verify that ~S is a subtype of the required type ~S." + specified-type required-type)) + ((not a) + (loop-error "Specified data type ~S is not a subtype of ~S." + specified-type required-type))) + specified-type))) + + + +;;;INTERFACE: Traditional, ANSI, Lucid. +(defmacro loop-finish () + "Cause the iteration to terminate \"normally\", the same as implicit +termination by an iteration driving clause, or by use of WHILE or +UNTIL -- the epilogue code (if any) will be run, and any implicitly +collected result will be returned as the value of the LOOP." + '(go end-loop)) + + + + +(defun subst-gensyms-for-nil (tree) + (declare (special *ignores*)) + (cond + ((null tree) (car (push (loop-gentemp) *ignores*))) + ((atom tree) tree) + (t (cons (subst-gensyms-for-nil (car tree)) + (subst-gensyms-for-nil (cdr tree)))))) + +(defun loop-build-destructuring-bindings (crocks forms) + (if crocks + (let ((*ignores* ())) + (declare (special *ignores*)) + `((destructuring-bind ,(subst-gensyms-for-nil (car crocks)) + ,(cadr crocks) + (declare (ignore ,@*ignores*)) + ,@(loop-build-destructuring-bindings (cddr crocks) forms)))) + forms)) + +(defun loop-translate (*loop-source-code* *loop-macro-environment* *loop-universe*) + (let ((*loop-original-source-code* *loop-source-code*) + (*loop-source-context* nil) + (*loop-iteration-variables* nil) + (*loop-variables* nil) + (*loop-nodeclare* nil) + (*loop-named-variables* nil) + (*loop-declarations* nil) + (*loop-desetq-crocks* nil) + (*loop-bind-stack* nil) + (*loop-prologue* nil) + (*loop-wrappers* nil) + (*loop-before-loop* nil) + (*loop-body* nil) + (*loop-emitted-body* nil) + (*loop-after-body* nil) + (*loop-epilogue* nil) + (*loop-after-epilogue* nil) + (*loop-final-value-culprit* nil) + (*loop-inside-conditional* nil) + (*loop-when-it-variable* nil) + (*loop-never-stepped-variable* nil) + (*loop-names* nil) + (*loop-collection-cruft* nil)) + (loop-iteration-driver) + (loop-bind-block) + (let ((answer `(loop-body + ,(nreverse *loop-prologue*) + ,(nreverse *loop-before-loop*) + ,(nreverse *loop-body*) + ,(nreverse *loop-after-body*) + ,(nreconc *loop-epilogue* (nreverse *loop-after-epilogue*))))) + (dolist (entry *loop-bind-stack*) + (let ((vars (first entry)) + (dcls (second entry)) + (crocks (third entry)) + (wrappers (fourth entry))) + (dolist (w wrappers) + (setq answer (append w (list answer)))) + (when (or vars dcls crocks) + (let ((forms (list answer))) + ;;(when crocks (push crocks forms)) + (when dcls (push `(declare ,@dcls) forms)) + (setq answer `(,(cond ((not vars) 'locally) + (*loop-destructuring-hooks* (first *loop-destructuring-hooks*)) + (t 'let)) + ,vars + ,@(loop-build-destructuring-bindings crocks forms))))))) + (if *loop-names* + (do () ((null (car *loop-names*)) answer) + (setq answer `(block ,(pop *loop-names*) ,answer))) + `(block nil ,answer))))) + + +(defun loop-iteration-driver () + (do () ((null *loop-source-code*)) + (let ((keyword (car *loop-source-code*)) (tem nil)) + (cond ((not (symbolp keyword)) + (loop-error "~S found where LOOP keyword expected." keyword)) + (t (setq *loop-source-context* *loop-source-code*) + (loop-pop-source) + (cond ((setq tem (loop-lookup-keyword keyword (loop-universe-keywords *loop-universe*))) + ;;It's a "miscellaneous" toplevel LOOP keyword (do, collect, named, etc.) + (apply (symbol-function (first tem)) (rest tem))) + ((setq tem (loop-lookup-keyword keyword (loop-universe-iteration-keywords *loop-universe*))) + (loop-hack-iteration tem)) + ((loop-tmember keyword '(and else)) + ;; Alternative is to ignore it, ie let it go around to the next keyword... + (loop-error "Secondary clause misplaced at top level in LOOP macro: ~S ~S ~S ..." + keyword (car *loop-source-code*) (cadr *loop-source-code*))) + (t (loop-error "~S is an unknown keyword in LOOP macro." keyword)))))))) + + + + +(defun loop-pop-source () + (if *loop-source-code* + (pop *loop-source-code*) + (loop-error "LOOP source code ran out when another token was expected."))) + + +(defun loop-get-compound-form () + (let ((form (loop-get-form))) + (unless (consp form) + (loop-error "Compound form expected, but found ~A." form)) + form)) + +(defun loop-get-progn () + (do ((forms (list (loop-get-compound-form)) + (cons (loop-get-compound-form) forms)) + (nextform (car *loop-source-code*) + (car *loop-source-code*))) + ((atom nextform) + (if (null (cdr forms)) (car forms) (cons 'progn (nreverse forms)))))) + + +(defun loop-get-form () + (if *loop-source-code* + (loop-pop-source) + (loop-error "LOOP code ran out where a form was expected."))) + + +(defun loop-construct-return (form) + `(return-from ,(car *loop-names*) ,form)) + + +(defun loop-pseudo-body (form) + (cond ((or *loop-emitted-body* *loop-inside-conditional*) (push form *loop-body*)) + (t (push form *loop-before-loop*) (push form *loop-after-body*)))) + +(defun loop-emit-body (form) + (setq *loop-emitted-body* t) + (loop-pseudo-body form)) + +(defun loop-emit-final-value (&optional (form nil form-supplied-p)) + (when form-supplied-p + (push (loop-construct-return form) *loop-after-epilogue*)) + (when *loop-final-value-culprit* + (loop-warn "LOOP clause is providing a value for the iteration,~@ + however one was already established by a ~S clause." + *loop-final-value-culprit*)) + (setq *loop-final-value-culprit* (car *loop-source-context*))) + + +(defun loop-disallow-conditional (&optional kwd) + (when *loop-inside-conditional* + (loop-error "~:[This LOOP~;The LOOP ~:*~S~] clause is not permitted inside a conditional." kwd))) + +(defun loop-disallow-anonymous-collectors () + (when (find-if-not 'loop-collector-name *loop-collection-cruft*) + (loop-error "This LOOP clause is not permitted with anonymous collectors."))) + +(defun loop-disallow-aggregate-booleans () + (when (loop-tmember *loop-final-value-culprit* '(always never thereis)) + (loop-error "This anonymous collection LOOP clause is not permitted with aggregate booleans."))) + + + + +;;;; Loop Types + + +(defun loop-typed-init (data-type) + (when data-type + (let ((val (if (subtypep data-type 'number) + (if (or (subtypep data-type 'float) (subtypep data-type '(complex float))) + (coerce 0 data-type) + 0) + (if (subtypep data-type 'character) + #\Null + nil)))) + (and val (typep val data-type) val)))) + + +(defun loop-optional-type (&optional variable) + ;;No variable specified implies that no destructuring is permissible. + (and *loop-source-code* ;Don't get confused by NILs... + (let ((z (car *loop-source-code*))) + (cond ((loop-tequal z 'of-type) + ;;This is the syntactically unambigous form in that the form of the + ;; type specifier does not matter. Also, it is assumed that the + ;; type specifier is unambiguously, and without need of translation, + ;; a common lisp type specifier or pattern (matching the variable) thereof. + (loop-pop-source) + (loop-pop-source)) + + ((symbolp z) + ;;This is the (sort of) "old" syntax, even though we didn't used to support all of + ;; these type symbols. + (let ((type-spec (or (gethash z (loop-universe-type-symbols *loop-universe*)) + (gethash (symbol-name z) (loop-universe-type-keywords *loop-universe*))))) + (when type-spec + (loop-pop-source) + type-spec))) + (t + ;;This is our sort-of old syntax. But this is only valid for when we are destructuring, + ;; so we will be compulsive (should we really be?) and require that we in fact be + ;; doing variable destructuring here. We must translate the old keyword pattern typespec + ;; into a fully-specified pattern of real type specifiers here. + (if (consp variable) + (unless (consp z) + (loop-error + "~S found where a LOOP keyword, LOOP type keyword, or LOOP type pattern expected." + z)) + (loop-error "~S found where a LOOP keyword or LOOP type keyword expected." z)) + (loop-pop-source) + (labels ((translate (k v) + (cond ((null k) nil) + ((atom k) + (replicate + (or (gethash k (loop-universe-type-symbols *loop-universe*)) + (gethash (symbol-name k) (loop-universe-type-keywords *loop-universe*)) + (loop-error + "Destructuring type pattern ~S contains unrecognized type keyword ~S." + z k)) + v)) + ((atom v) + (loop-error + "Destructuring type pattern ~S doesn't match variable pattern ~S." + z variable)) + (t (cons (translate (car k) (car v)) (translate (cdr k) (cdr v)))))) + (replicate (typ v) + (if (atom v) typ (cons (replicate typ (car v)) (replicate typ (cdr v)))))) + (translate z variable))))))) + + + + +;;;; Loop Variables + + +(defun loop-bind-block () + (when (or *loop-variables* *loop-declarations* *loop-wrappers*) + (push (list (nreverse *loop-variables*) *loop-declarations* *loop-desetq-crocks* *loop-wrappers*) + *loop-bind-stack*) + (setq *loop-variables* nil + *loop-declarations* nil + *loop-desetq-crocks* nil + *loop-wrappers* nil))) + +(defun loop-variable-p (name) + (do ((entry *loop-bind-stack* (cdr entry))) (nil) + (cond ((null entry) + (return nil)) + ((assoc name (caar entry) :test #'eq) + (return t))))) + +(defun loop-make-variable (name initialization dtype &optional iteration-variable-p) + (cond ((null name) + (cond ((not (null initialization)) + (push (list (setq name (loop-gentemp 'loop-ignore-)) + initialization) + *loop-variables*) + (push `(ignore ,name) *loop-declarations*)))) + ((atom name) + (cond (iteration-variable-p + (if (member name *loop-iteration-variables*) + (loop-error "Duplicated LOOP iteration variable ~S." name) + (push name *loop-iteration-variables*))) + ((assoc name *loop-variables*) + (loop-error "Duplicated variable ~S in LOOP parallel binding." name))) + (unless (symbolp name) + (loop-error "Bad variable ~S somewhere in LOOP." name)) + (unless initialization (setq initialization (loop-typed-init dtype))) + (when (and dtype + (null initialization) + (not (typep nil dtype))) + (if (eq dtype 'complex) + (setq initialization 0 dtype 'number) + (when iteration-variable-p + (setq dtype `(or null ,dtype))))) + (loop-declare-variable name dtype) + ;; We use ASSOC on this list to check for duplications (above), + ;; so don't optimize out this list: + (push (list name initialization) *loop-variables*)) + (initialization + (cond (*loop-destructuring-hooks* + (loop-declare-variable name dtype) + (push (list name initialization) *loop-variables*)) + (t (let ((newvar (loop-gentemp 'loop-destructure-))) + (loop-declare-variable name dtype) + (push (list newvar initialization) *loop-variables*) + ;; *LOOP-DESETQ-CROCKS* gathered in reverse order. + (setq *loop-desetq-crocks* + (list* name newvar *loop-desetq-crocks*)))))) + (t (let ((tcar nil) (tcdr nil)) + (if (atom dtype) (setq tcar (setq tcdr dtype)) + (setq tcar (car dtype) tcdr (cdr dtype))) + (loop-make-variable (car name) nil tcar iteration-variable-p) + (loop-make-variable (cdr name) nil tcdr iteration-variable-p)))) + name) + + +(defun loop-make-iteration-variable (name initialization dtype) + (loop-make-variable name initialization dtype t)) + + +(defun loop-declare-variable (name dtype) + (cond ((or (null name) (null dtype) (eq dtype t)) nil) + ((symbolp name) + (unless (or (eq dtype t) (member (the symbol name) *loop-nodeclare*)) + (push `(type ,dtype ,name) *loop-declarations*))) + ((consp name) + (cond ((consp dtype) + (loop-declare-variable (car name) (car dtype)) + (loop-declare-variable (cdr name) (cdr dtype))) + (t (loop-declare-variable (car name) dtype) + (loop-declare-variable (cdr name) dtype)))) + (t (loop-error "Invalid LOOP variable passed in: ~S." name)))) + + +(defun loop-maybe-bind-form (form data-type) + (if (loop-constantp form) + form + (loop-make-variable (loop-gentemp 'loop-bind-) form data-type))) + + + + +(defun loop-do-if (for negatep) + (let ((form (loop-get-form)) + (*loop-inside-conditional* t) + (it-p nil) + (first-clause-p t)) + (flet ((get-clause (for) + (do ((body nil)) (nil) + (let ((key (car *loop-source-code*)) (*loop-body* nil) data) + (cond ((not (symbolp key)) + (loop-error + "~S found where keyword expected getting LOOP clause after ~S." + key for)) + (t (setq *loop-source-context* *loop-source-code*) + (loop-pop-source) + (when (and (loop-tequal (car *loop-source-code*) 'it) + first-clause-p) + (setq *loop-source-code* + (cons (or it-p (setq it-p (loop-when-it-variable))) + (cdr *loop-source-code*)))) + (cond ((or (not (setq data (loop-lookup-keyword + key (loop-universe-keywords *loop-universe*)))) + (progn (apply (symbol-function (car data)) (cdr data)) + (null *loop-body*))) + (loop-error + "~S does not introduce a LOOP clause that can follow ~S." + key for)) + (t (setq body (nreconc *loop-body* body))))))) + (setq first-clause-p nil) + (if (loop-tequal (car *loop-source-code*) :and) + (loop-pop-source) + (return (if (cdr body) `(progn ,@(nreverse body)) (car body))))))) + (let ((then (get-clause for)) + (else (when (loop-tequal (car *loop-source-code*) :else) + (loop-pop-source) + (list (get-clause :else))))) + (when (loop-tequal (car *loop-source-code*) :end) + (loop-pop-source)) + (when it-p (setq form `(setq ,it-p ,form))) + (loop-pseudo-body + `(if ,(if negatep `(not ,form) form) + ,then + ,@else)))))) + + +(defun loop-do-initially () + (loop-disallow-conditional :initially) + (push (loop-get-progn) *loop-prologue*)) + +(defun loop-do-finally () + (loop-disallow-conditional :finally) + (push (loop-get-progn) *loop-epilogue*)) + +(defun loop-do-do () + (loop-emit-body (loop-get-progn))) + +(defun loop-do-named () + (let ((name (loop-pop-source))) + (unless (symbolp name) + (loop-error "~S is an invalid name for your LOOP." name)) + (when (or *loop-before-loop* *loop-body* *loop-after-epilogue* *loop-inside-conditional*) + (loop-error "The NAMED ~S clause occurs too late." name)) + (when *loop-names* + (loop-error "You may only use one NAMED clause in your loop: NAMED ~S ... NAMED ~S." + (car *loop-names*) name)) + (setq *loop-names* (list name nil)))) + +(defun loop-do-return () + (loop-emit-body (loop-construct-return (loop-get-form)))) + + + +;;;; Value Accumulation: List + + +(defstruct (loop-collector + (:copier nil) + (:predicate nil)) + name + class + (history nil) + (tempvars nil) + dtype + (data nil)) ;collector-specific data + + +(defun loop-get-collection-info (collector class default-type) + (let ((form (loop-get-form)) + (dtype (and (not (loop-universe-ansi *loop-universe*)) (loop-optional-type))) + (name (when (loop-tequal (car *loop-source-code*) 'into) + (loop-pop-source) + (loop-pop-source)))) + (when (not (symbolp name)) + (loop-error "Value accumulation recipient name, ~S, is not a symbol." name)) + (unless name + (loop-disallow-aggregate-booleans)) + (unless dtype + (setq dtype (or (loop-optional-type) default-type))) + (let ((cruft (find (the symbol name) *loop-collection-cruft* + :key #'loop-collector-name))) + (cond ((not cruft) + (when (and name (loop-variable-p name)) + (loop-error "Variable ~S cannot be used in INTO clause" name)) + (push (setq cruft (make-loop-collector + :name name :class class + :history (list collector) :dtype dtype)) + *loop-collection-cruft*)) + (t (unless (eq (loop-collector-class cruft) class) + (loop-error + "Incompatible kinds of LOOP value accumulation specified for collecting~@ + ~:[as the value of the LOOP~;~:*INTO ~S~]: ~S and ~S." + name (car (loop-collector-history cruft)) collector)) + (unless (equal dtype (loop-collector-dtype cruft)) + (loop-warn + "Unequal datatypes specified in different LOOP value accumulations~@ + into ~S: ~S and ~S." + name dtype (loop-collector-dtype cruft)) + (when (eq (loop-collector-dtype cruft) t) + (setf (loop-collector-dtype cruft) dtype))) + (push collector (loop-collector-history cruft)))) + (values cruft form)))) + + +(defun loop-list-collection (specifically) ;NCONC, LIST, or APPEND + (multiple-value-bind (lc form) (loop-get-collection-info specifically 'list 'list) + (let ((tempvars (loop-collector-tempvars lc))) + (unless tempvars + (setf (loop-collector-tempvars lc) + (setq tempvars (list* (loop-gentemp 'loop-list-head-) + (loop-gentemp 'loop-list-tail-) + (and (loop-collector-name lc) + (list (loop-collector-name lc)))))) + (push `(with-loop-list-collection-head ,tempvars) *loop-wrappers*) + (unless (loop-collector-name lc) + (loop-emit-final-value `(loop-collect-answer ,(car tempvars) ,@(cddr tempvars))))) + (ecase specifically + (list (setq form `(list ,form))) + (nconc nil) + (append (unless (and (consp form) (eq (car form) 'list)) + (setq form `(loop-copylist* ,form))))) + (loop-emit-body `(loop-collect-rplacd ,tempvars ,form))))) + + + +;;;; Value Accumulation: max, min, sum, count. + + + +(defun loop-sum-collection (specifically required-type default-type) ;SUM, COUNT + (multiple-value-bind (lc form) + (loop-get-collection-info specifically 'sum default-type) + (loop-check-data-type (loop-collector-dtype lc) required-type) + (let ((tempvars (loop-collector-tempvars lc))) + (unless tempvars + (setf (loop-collector-tempvars lc) + (setq tempvars (list (loop-make-variable + (or (loop-collector-name lc) + (loop-gentemp 'loop-sum-)) + nil (loop-collector-dtype lc))))) + (unless (loop-collector-name lc) + (loop-emit-final-value (car (loop-collector-tempvars lc))))) + (loop-emit-body + (if (eq specifically 'count) + `(when ,form + (setq ,(car tempvars) + ,(hide-variable-reference t (car tempvars) `(1+ ,(car tempvars))))) + `(setq ,(car tempvars) + (+ ,(hide-variable-reference t (car tempvars) (car tempvars)) + ,form))))))) + + + +(defun loop-maxmin-collection (specifically) + (multiple-value-bind (lc form) + (loop-get-collection-info specifically 'maxmin *loop-real-data-type*) + (loop-check-data-type (loop-collector-dtype lc) *loop-real-data-type*) + (let ((data (loop-collector-data lc))) + (unless data + (setf (loop-collector-data lc) + (setq data (make-loop-minimax + (or (loop-collector-name lc) (loop-gentemp 'loop-maxmin-)) + (loop-collector-dtype lc)))) + (unless (loop-collector-name lc) + (loop-emit-final-value (loop-minimax-answer-variable data)))) + (loop-note-minimax-operation specifically data) + (push `(with-minimax-value ,data) *loop-wrappers*) + (loop-emit-body `(loop-accumulate-minimax-value ,data ,specifically ,form)) + ))) + + + +;;;; Value Accumulation: Aggregate Booleans + +;;;ALWAYS and NEVER. +;;; Under ANSI these are not permitted to appear under conditionalization. +(defun loop-do-always (restrictive negate) + (let ((form (loop-get-form))) + (when restrictive (loop-disallow-conditional)) + (loop-disallow-anonymous-collectors) + (loop-emit-body `(,(if negate 'when 'unless) ,form + ,(loop-construct-return nil))) + (loop-emit-final-value t))) + + + +;;;THERIS. +;;; Under ANSI this is not permitted to appear under conditionalization. +(defun loop-do-thereis (restrictive) + (when restrictive (loop-disallow-conditional)) + (loop-disallow-anonymous-collectors) + (loop-emit-final-value) + (loop-emit-body `(when (setq ,(loop-when-it-variable) ,(loop-get-form)) + ,(loop-construct-return *loop-when-it-variable*)))) + + + +(defun loop-do-while (negate kwd &aux (form (loop-get-form))) + (loop-disallow-conditional kwd) + (loop-pseudo-body `(,(if negate 'when 'unless) ,form (go end-loop)))) + + +(defun loop-do-with () + (loop-disallow-conditional :with) + (do ((var) (val) (dtype)) (nil) + (setq var (loop-pop-source) + dtype (loop-optional-type var) + val (cond ((loop-tequal (car *loop-source-code*) :=) + (loop-pop-source) + (loop-get-form)) + (t nil))) + (when (and var (loop-variable-p var)) + (loop-error "Variable ~S has already been used" var)) + (loop-make-variable var val dtype) + (if (loop-tequal (car *loop-source-code*) :and) + (loop-pop-source) + (return (loop-bind-block))))) + + + +;;;; The iteration driver + +(defun loop-hack-iteration (entry) + (flet ((make-endtest (list-of-forms) + (cond ((null list-of-forms) nil) + ((member t list-of-forms) '(go end-loop)) + (t `(when ,(if (null (cdr (setq list-of-forms (nreverse list-of-forms)))) + (car list-of-forms) + (cons 'or list-of-forms)) + (go end-loop)))))) + (do ((pre-step-tests nil) + (steps nil) + (post-step-tests nil) + (pseudo-steps nil) + (pre-loop-pre-step-tests nil) + (pre-loop-steps nil) + (pre-loop-post-step-tests nil) + (pre-loop-pseudo-steps nil) + (tem) (data)) + (nil) + ;; Note we collect endtests in reverse order, but steps in correct + ;; order. MAKE-ENDTEST does the nreverse for us. + (setq tem (setq data (apply (symbol-function (first entry)) (rest entry)))) + (and (car tem) (push (car tem) pre-step-tests)) + (setq steps (nconc steps (loop-copylist* (car (setq tem (cdr tem)))))) + (and (car (setq tem (cdr tem))) (push (car tem) post-step-tests)) + (setq pseudo-steps (nconc pseudo-steps (loop-copylist* (car (setq tem (cdr tem)))))) + (setq tem (cdr tem)) + (when *loop-emitted-body* + (loop-error "Iteration in LOOP follows body code.")) + (unless tem (setq tem data)) + (when (car tem) (push (car tem) pre-loop-pre-step-tests)) + (setq pre-loop-steps (nconc pre-loop-steps (loop-copylist* (car (setq tem (cdr tem)))))) + (when (car (setq tem (cdr tem))) (push (car tem) pre-loop-post-step-tests)) + (setq pre-loop-pseudo-steps (nconc pre-loop-pseudo-steps (loop-copylist* (cadr tem)))) + (unless (loop-tequal (car *loop-source-code*) :and) + (setq *loop-before-loop* (list* (loop-make-desetq pre-loop-pseudo-steps) + (make-endtest pre-loop-post-step-tests) + (loop-make-psetq pre-loop-steps) + (make-endtest pre-loop-pre-step-tests) + *loop-before-loop*) + *loop-after-body* (list* (loop-make-desetq pseudo-steps) + (make-endtest post-step-tests) + (loop-make-psetq steps) + (make-endtest pre-step-tests) + *loop-after-body*)) + (loop-bind-block) + (return nil)) + (loop-pop-source) ; flush the "AND" + (when (and (not (loop-universe-implicit-for-required *loop-universe*)) + (setq tem (loop-lookup-keyword + (car *loop-source-code*) + (loop-universe-iteration-keywords *loop-universe*)))) + ;;Latest ANSI clarification is that the FOR/AS after the AND must NOT be supplied. + (loop-pop-source) + (setq entry tem))))) + + + +;;;; Main Iteration Drivers + + +;FOR variable keyword ..args.. +(defun loop-do-for () + (let* ((var (loop-pop-source)) + (data-type (loop-optional-type var)) + (keyword (loop-pop-source)) + (first-arg nil) + (tem nil)) + (setq first-arg (loop-get-form)) + (unless (and (symbolp keyword) + (setq tem (loop-lookup-keyword + keyword + (loop-universe-for-keywords *loop-universe*)))) + (loop-error "~S is an unknown keyword in FOR or AS clause in LOOP." keyword)) + (apply (car tem) var first-arg data-type (cdr tem)))) + +(defun loop-do-repeat () + (loop-disallow-conditional :repeat) + (let ((form (loop-get-form)) + (type 'real)) + (let ((var (loop-make-variable (loop-gentemp) form type))) + (push `(when (minusp (decf ,var)) (go end-loop)) *loop-before-loop*) + (push `(when (minusp (decf ,var)) (go end-loop)) *loop-after-body*) + ;; FIXME: What should + ;; (loop count t into a + ;; repeat 3 + ;; count t into b + ;; finally (return (list a b))) + ;; return: (3 3) or (4 3)? PUSHes above are for the former + ;; variant, L-P-B below for the latter. + ))) + +(defun loop-when-it-variable () + (or *loop-when-it-variable* + (setq *loop-when-it-variable* + (loop-make-variable (loop-gentemp 'loop-it-) nil nil)))) + + + +;;;; Various FOR/AS Subdispatches + + +;;;ANSI "FOR x = y [THEN z]" is sort of like the old Genera one when the THEN +;;; is omitted (other than being more stringent in its placement), and like +;;; the old "FOR x FIRST y THEN z" when the THEN is present. I.e., the first +;;; initialization occurs in the loop body (first-step), not in the variable binding +;;; phase. +(defun loop-ansi-for-equals (var val data-type) + (loop-make-iteration-variable var nil data-type) + (cond ((loop-tequal (car *loop-source-code*) :then) + ;;Then we are the same as "FOR x FIRST y THEN z". + (loop-pop-source) + `(() (,var ,(loop-get-form)) () () + () (,var ,val) () ())) + (t ;;We are the same as "FOR x = y". + `(() (,var ,val) () ())))) + + +(defun loop-for-across (var val data-type) + (loop-make-iteration-variable var nil data-type) + (let ((vector-var (loop-gentemp 'loop-across-vector-)) + (index-var (loop-gentemp 'loop-across-index-))) + (multiple-value-bind (vector-form constantp vector-value) + (loop-constant-fold-if-possible val 'vector) + (loop-make-variable + vector-var vector-form + (if (and (consp vector-form) (eq (car vector-form) 'the)) + (cadr vector-form) + 'vector)) + (loop-make-variable index-var 0 'fixnum) + (let* ((length 0) + (length-form (cond ((not constantp) + (let ((v (loop-gentemp 'loop-across-limit-))) + (push `(setq ,v (length ,vector-var)) *loop-prologue*) + (loop-make-variable v 0 'fixnum))) + (t (setq length (length vector-value))))) + (first-test `(>= ,index-var ,length-form)) + (other-test first-test) + (step `(,var (aref ,vector-var ,index-var))) + (pstep `(,index-var (1+ ,index-var)))) + (declare (fixnum length)) + (when constantp + (setq first-test (= length 0)) + (when (<= length 1) + (setq other-test t))) + `(,other-test ,step () ,pstep + ,@(and (not (eq first-test other-test)) `(,first-test ,step () ,pstep))))))) + + + + +;;;; List Iteration + + +(defun loop-list-step (listvar) + ;;We are not equipped to analyze whether 'FOO is the same as #'FOO here in any + ;; sensible fashion, so let's give an obnoxious warning whenever 'FOO is used + ;; as the stepping function. + ;;While a Discerning Compiler may deal intelligently with (funcall 'foo ...), not + ;; recognizing FOO may defeat some LOOP optimizations. + (let ((stepper (cond ((loop-tequal (car *loop-source-code*) :by) + (loop-pop-source) + (loop-get-form)) + (t '(function cdr))))) + (cond ((and (consp stepper) (eq (car stepper) 'quote)) + (loop-warn "Use of QUOTE around stepping function in LOOP will be left verbatim.") + (values `(funcall ,stepper ,listvar) nil)) + ((and (consp stepper) (eq (car stepper) 'function)) + (values (list (cadr stepper) listvar) (cadr stepper))) + (t (values `(funcall ,(loop-make-variable (loop-gentemp 'loop-fn-) stepper 'function) + ,listvar) + nil))))) + + +(defun loop-for-on (var val data-type) + (multiple-value-bind (list constantp list-value) (loop-constant-fold-if-possible val) + (let ((listvar var)) + (cond ((and var (symbolp var)) (loop-make-iteration-variable var list data-type)) + (t (loop-make-variable (setq listvar (loop-gentemp)) list nil) + (loop-make-iteration-variable var nil data-type))) + (multiple-value-bind (list-step step-function) (loop-list-step `(the cons ,listvar)) + (declare (ignore step-function)) + ;;@@@@ The CLOE problem above has to do with bug in macroexpansion of multiple-value-bind. + (let* ((first-endtest + (hide-variable-reference + (eq var listvar) + listvar + ;; the following should use `atom' instead of `endp', per + ;; [bug2428] + `(atom ,listvar))) + (other-endtest first-endtest)) + (when (and constantp (listp list-value)) + (setq first-endtest (null list-value))) + (cond ((eq var listvar) + ;;Contour of the loop is different because we use the user's variable... + `(() (,listvar ,(hide-variable-reference t listvar list-step)) ,other-endtest + () () () ,first-endtest ())) + (t (let ((step `(,var (the cons ,listvar))) (pseudo `(,listvar ,list-step))) + `(,other-endtest ,step () ,pseudo + ,@(and (not (eq first-endtest other-endtest)) + `(,first-endtest ,step () ,pseudo))))))))))) + + +(defun loop-for-in (var val data-type) + (multiple-value-bind (list constantp list-value) (loop-constant-fold-if-possible val) + (let ((listvar (loop-gentemp 'loop-list-))) + (loop-make-iteration-variable var nil data-type) + (loop-make-variable listvar list 'list) + (multiple-value-bind (list-step step-function) (loop-list-step listvar) + (declare (ignore step-function)) + (let* ((first-endtest `(endp ,listvar)) + (other-endtest first-endtest) + (step `(,var (car ,listvar))) + (pseudo-step `(,listvar ,list-step))) + (when (and constantp (listp list-value)) + (setq first-endtest (null list-value))) + `(,other-endtest ,step () ,pseudo-step + ,@(and (not (eq first-endtest other-endtest)) + `(,first-endtest ,step () ,pseudo-step)))))))) + + + +;;;; Iteration Paths + + +(defstruct (loop-path + (:copier nil) + (:predicate nil)) + names + preposition-groups + inclusive-permitted + function + user-data) + + +(defun add-loop-path (names function universe &key preposition-groups inclusive-permitted user-data) + (unless (listp names) (setq names (list names))) + ;; Can't do this due to CLOS bootstrapping problems. + (check-type universe loop-universe) + (let ((ht (loop-universe-path-keywords universe)) + (lp (make-loop-path + :names (mapcar #'symbol-name names) + :function function + :user-data user-data + :preposition-groups (mapcar #'(lambda (x) (if (listp x) x (list x))) preposition-groups) + :inclusive-permitted inclusive-permitted))) + (dolist (name names) (setf (gethash (symbol-name name) ht) lp)) + lp)) + + + +;;; Note: path functions are allowed to use loop-make-variable, hack +;;; the prologue, etc. +(defun loop-for-being (var val data-type) + ;; FOR var BEING each/the pathname prep-phrases using-stuff... + ;; each/the = EACH or THE. Not clear if it is optional, so I guess we'll warn. + (let ((path nil) + (data nil) + (inclusive nil) + (stuff nil) + (initial-prepositions nil)) + (cond ((loop-tmember val '(:each :the)) (setq path (loop-pop-source))) + ((loop-tequal (car *loop-source-code*) :and) + (loop-pop-source) + (setq inclusive t) + (unless (loop-tmember (car *loop-source-code*) '(:its :each :his :her)) + (loop-error "~S found where ITS or EACH expected in LOOP iteration path syntax." + (car *loop-source-code*))) + (loop-pop-source) + (setq path (loop-pop-source)) + (setq initial-prepositions `((:in ,val)))) + (t (loop-error "Unrecognizable LOOP iteration path syntax. Missing EACH or THE?"))) + (cond ((not (symbolp path)) + (loop-error "~S found where a LOOP iteration path name was expected." path)) + ((not (setq data (loop-lookup-keyword path (loop-universe-path-keywords *loop-universe*)))) + (loop-error "~S is not the name of a LOOP iteration path." path)) + ((and inclusive (not (loop-path-inclusive-permitted data))) + (loop-error "\"Inclusive\" iteration is not possible with the ~S LOOP iteration path." path))) + (let ((fun (loop-path-function data)) + (preps (nconc initial-prepositions + (loop-collect-prepositional-phrases (loop-path-preposition-groups data) t))) + (user-data (loop-path-user-data data))) + (when (symbolp fun) (setq fun (symbol-function fun))) + (setq stuff (if inclusive + (apply fun var data-type preps :inclusive t user-data) + (apply fun var data-type preps user-data)))) + (when *loop-named-variables* + (loop-error "Unused USING variables: ~S." *loop-named-variables*)) + ;; STUFF is now (bindings prologue-forms . stuff-to-pass-back). Protect the system from the user + ;; and the user from himself. + (unless (member (length stuff) '(6 10)) + (loop-error "Value passed back by LOOP iteration path function for path ~S has invalid length." + path)) + (do ((l (car stuff) (cdr l)) (x)) ((null l)) + (if (atom (setq x (car l))) + (loop-make-iteration-variable x nil nil) + (loop-make-iteration-variable (car x) (cadr x) (caddr x)))) + (setq *loop-prologue* (nconc (reverse (cadr stuff)) *loop-prologue*)) + (cddr stuff))) + + + + +;;;INTERFACE: Lucid, exported. +;;; i.e., this is part of our extended ansi-loop interface. +(defun named-variable (name) + (let ((tem (loop-tassoc name *loop-named-variables*))) + (declare (list tem)) + (cond ((null tem) (values (loop-gentemp) nil)) + (t (setq *loop-named-variables* (delete tem *loop-named-variables*)) + (values (cdr tem) t))))) + + +(defun loop-collect-prepositional-phrases (preposition-groups &optional USING-allowed initial-phrases) + (flet ((in-group-p (x group) (car (loop-tmember x group)))) + (do ((token nil) + (prepositional-phrases initial-phrases) + (this-group nil nil) + (this-prep nil nil) + (disallowed-prepositions + (mapcan #'(lambda (x) + (loop-copylist* + (find (car x) preposition-groups :test #'in-group-p))) + initial-phrases)) + (used-prepositions (mapcar #'car initial-phrases))) + ((null *loop-source-code*) (nreverse prepositional-phrases)) + (declare (symbol this-prep)) + (setq token (car *loop-source-code*)) + (dolist (group preposition-groups) + (when (setq this-prep (in-group-p token group)) + (return (setq this-group group)))) + (cond (this-group + (when (member this-prep disallowed-prepositions) + (loop-error + (if (member this-prep used-prepositions) + "A ~S prepositional phrase occurs multiply for some LOOP clause." + "Preposition ~S used when some other preposition has subsumed it.") + token)) + (setq used-prepositions (if (listp this-group) + (append this-group used-prepositions) + (cons this-group used-prepositions))) + (loop-pop-source) + (push (list this-prep (loop-get-form)) prepositional-phrases)) + ((and USING-allowed (loop-tequal token 'using)) + (loop-pop-source) + (do ((z (loop-pop-source) (loop-pop-source)) (tem)) (nil) + (when (cadr z) + (if (setq tem (loop-tassoc (car z) *loop-named-variables*)) + (loop-error + "The variable substitution for ~S occurs twice in a USING phrase,~@ + with ~S and ~S." + (car z) (cadr z) (cadr tem)) + (push (cons (car z) (cadr z)) *loop-named-variables*))) + (when (or (null *loop-source-code*) (symbolp (car *loop-source-code*))) + (return nil)))) + (t (return (nreverse prepositional-phrases))))))) + + + +;;;; Master Sequencer Function + + +(defun loop-sequencer (indexv indexv-type indexv-user-specified-p + variable variable-type + sequence-variable sequence-type + step-hack default-top + prep-phrases) + (let ((endform nil) ;Form (constant or variable) with limit value. + (sequencep nil) ;T if sequence arg has been provided. + (testfn nil) ;endtest function + (test nil) ;endtest form. + (stepby (1+ (or (loop-typed-init indexv-type) 0))) ;Our increment. + (stepby-constantp t) + (step nil) ;step form. + (dir nil) ;Direction of stepping: NIL, :UP, :DOWN. + (inclusive-iteration nil) ;T if include last index. + (start-given nil) ;T when prep phrase has specified start + (start-value nil) + (start-constantp nil) + (limit-given nil) ;T when prep phrase has specified end + (limit-constantp nil) + (limit-value nil) + ) + (when variable (loop-make-iteration-variable variable nil variable-type)) + (do ((l prep-phrases (cdr l)) (prep) (form) (odir)) ((null l)) + (setq prep (caar l) form (cadar l)) + (case prep + ((:of :in) + (setq sequencep t) + (loop-make-variable sequence-variable form sequence-type)) + ((:from :downfrom :upfrom) + (setq start-given t) + (cond ((eq prep :downfrom) (setq dir ':down)) + ((eq prep :upfrom) (setq dir ':up))) + (multiple-value-setq (form start-constantp start-value) + (loop-constant-fold-if-possible form indexv-type)) + (setq indexv (loop-make-iteration-variable indexv form indexv-type))) + ((:upto :to :downto :above :below) + (cond ((loop-tequal prep :upto) (setq inclusive-iteration (setq dir ':up))) + ((loop-tequal prep :to) (setq inclusive-iteration t)) + ((loop-tequal prep :downto) (setq inclusive-iteration (setq dir ':down))) + ((loop-tequal prep :above) (setq dir ':down)) + ((loop-tequal prep :below) (setq dir ':up))) + (setq limit-given t) + (multiple-value-setq (form limit-constantp limit-value) + (loop-constant-fold-if-possible form indexv-type)) + (setq endform (if limit-constantp + `',limit-value + (loop-make-variable + (loop-gentemp 'loop-limit-) form indexv-type)))) + (:by + (multiple-value-setq (form stepby-constantp stepby) + (loop-constant-fold-if-possible form indexv-type)) + (unless stepby-constantp + (loop-make-variable (setq stepby (loop-gentemp 'loop-step-by-)) form indexv-type))) + (t (loop-error + "~S invalid preposition in sequencing or sequence path.~@ + Invalid prepositions specified in iteration path descriptor or something?" + prep))) + (when (and odir dir (not (eq dir odir))) + (loop-error "Conflicting stepping directions in LOOP sequencing path")) + (setq odir dir)) + (when (and sequence-variable (not sequencep)) + (loop-error "Missing OF or IN phrase in sequence path")) + ;; Now fill in the defaults. + (unless start-given + (loop-make-iteration-variable + indexv + (setq start-constantp t start-value (or (loop-typed-init indexv-type) 0)) + indexv-type)) + (cond ((member dir '(nil :up)) + (when (or limit-given default-top) + (unless limit-given + (loop-make-variable (setq endform (loop-gentemp 'loop-seq-limit-)) + nil indexv-type) + (push `(setq ,endform ,default-top) *loop-prologue*)) + (setq testfn (if inclusive-iteration '> '>=))) + (setq step (if (eql stepby 1) `(1+ ,indexv) `(+ ,indexv ,stepby)))) + (t (unless start-given + (unless default-top + (loop-error "Don't know where to start stepping.")) + (push `(setq ,indexv (1- ,default-top)) *loop-prologue*)) + (when (and default-top (not endform)) + (setq endform (loop-typed-init indexv-type) inclusive-iteration t)) + (when endform (setq testfn (if inclusive-iteration '< '<=))) + (setq step (if (eql stepby 1) `(1- ,indexv) `(- ,indexv ,stepby))))) + (when testfn (setq test (hide-variable-reference t indexv `(,testfn ,indexv ,endform)))) + (when step-hack + (setq step-hack `(,variable ,(hide-variable-reference indexv-user-specified-p indexv step-hack)))) + (let ((first-test test) (remaining-tests test)) + (when (and stepby-constantp start-constantp limit-constantp) + (when (setq first-test (funcall (symbol-function testfn) start-value limit-value)) + (setq remaining-tests t))) + `(() (,indexv ,(hide-variable-reference t indexv step)) ,remaining-tests ,step-hack + () () ,first-test ,step-hack)))) + + + +;;;; Interfaces to the Master Sequencer + + + +(defun loop-for-arithmetic (var val data-type kwd) + (loop-sequencer + var (loop-check-data-type data-type 'number) t + nil nil nil nil nil nil + (loop-collect-prepositional-phrases + '((:from :upfrom :downfrom) (:to :upto :downto :above :below) (:by)) + nil (list (list kwd val))))) + + +(defun loop-sequence-elements-path (variable data-type prep-phrases + &key fetch-function size-function sequence-type element-type) + (multiple-value-bind (indexv indexv-user-specified-p) (named-variable 'index) + (let ((sequencev (named-variable 'sequence))) + (list* nil nil ; dummy bindings and prologue + (loop-sequencer + indexv 'fixnum indexv-user-specified-p + variable (or data-type element-type) + sequencev sequence-type + `(,fetch-function ,sequencev ,indexv) `(,size-function ,sequencev) + prep-phrases))))) + + + +;;;; Builtin LOOP Iteration Paths + + +#|| +(loop for v being the hash-values of ht do (print v)) +(loop for k being the hash-keys of ht do (print k)) +(loop for v being the hash-values of ht using (hash-key k) do (print (list k v))) +(loop for k being the hash-keys of ht using (hash-value v) do (print (list k v))) +||# + +(defun loop-hash-table-iteration-path (variable data-type prep-phrases &key which) + (check-type which (member hash-key hash-value)) + (cond ((or (cdr prep-phrases) (not (member (caar prep-phrases) '(:in :of)))) + (loop-error "Too many prepositions!")) + ((null prep-phrases) (loop-error "Missing OF or IN in iteration path." ))) + (let ((ht-var (loop-gentemp 'loop-hashtab-)) + (next-fn (loop-gentemp 'loop-hashtab-next-)) + (dummy-predicate-var nil) + (post-steps nil)) + (multiple-value-bind (other-var other-p) + (named-variable (if (eq which 'hash-key) 'hash-value 'hash-key)) + ;;@@@@ named-variable returns a second value of T if the name was actually + ;; specified, so clever code can throw away the gensym'ed up variable if + ;; it isn't really needed. + (unless other-p (push `(ignorable ,other-var) *loop-declarations*)) + ;;The following is for those implementations in which we cannot put dummy NILs + ;; into multiple-value-setq variable lists. + (setq other-p t + dummy-predicate-var (loop-when-it-variable)) + (setq variable (or variable (loop-gentemp 'ignore-))) + (let ((key-var nil) + (val-var nil) + (bindings `((,variable nil ,data-type) + (,ht-var ,(cadar prep-phrases)) + ,@(and other-p other-var `((,other-var nil)))))) + (if (eq which 'hash-key) + (setq key-var variable val-var (and other-p other-var)) + (setq key-var (and other-p other-var) val-var variable)) + (push `(with-hash-table-iterator (,next-fn ,ht-var)) *loop-wrappers*) + (when (or (consp key-var) data-type) + (setq post-steps `(,key-var ,(setq key-var (loop-gentemp 'loop-hash-key-temp-)) + ,@post-steps)) + (push `(,key-var nil) bindings)) + (when (or (consp val-var) data-type) + (setq post-steps `(,val-var ,(setq val-var (loop-gentemp 'loop-hash-val-temp-)) + ,@post-steps)) + (push `(,val-var nil) bindings)) + (push `(ignorable ,dummy-predicate-var) *loop-declarations*) + `(,bindings ;bindings + () ;prologue + () ;pre-test + () ;parallel steps + (not (multiple-value-setq (,dummy-predicate-var ,key-var ,val-var) (,next-fn))) ;post-test + ,post-steps))))) + + +(defun loop-package-symbols-iteration-path (variable data-type prep-phrases &key symbol-types) + (cond ((and prep-phrases (cdr prep-phrases)) + (loop-error "Too many prepositions!")) + ((and prep-phrases (not (member (caar prep-phrases) '(:in :of)))) + (loop-error "Unknown preposition ~S" (caar prep-phrases)))) + (unless (symbolp variable) + (loop-error "Destructuring is not valid for package symbol iteration.")) + (let ((pkg-var (loop-gentemp 'loop-pkgsym-)) + (next-fn (loop-gentemp 'loop-pkgsym-next-)) + (variable (or variable (loop-gentemp 'ignore-))) + (pkg (or (cadar prep-phrases) '*package*))) + (push `(with-package-iterator (,next-fn ,pkg-var ,@symbol-types)) *loop-wrappers*) + (push `(ignorable ,(loop-when-it-variable)) *loop-declarations*) + + `(((,variable nil ,data-type) (,pkg-var ,pkg)) + () + () + () + (not (multiple-value-setq (,(progn + ;;@@@@ If an implementation can get away without actually + ;; using a variable here, so much the better. + (loop-when-it-variable)) + ,variable) + (,next-fn))) + ()))) + + +;;;; ANSI Loop + +(defun make-ansi-loop-universe (extended-p) + (let ((w (make-standard-loop-universe + :keywords `((named (loop-do-named)) + (initially (loop-do-initially)) + (finally (loop-do-finally)) + (do (loop-do-do)) + (doing (loop-do-do)) + (return (loop-do-return)) + (collect (loop-list-collection list)) + (collecting (loop-list-collection list)) + (append (loop-list-collection append)) + (appending (loop-list-collection append)) + (nconc (loop-list-collection nconc)) + (nconcing (loop-list-collection nconc)) + (count (loop-sum-collection count ,*loop-real-data-type* fixnum)) + (counting (loop-sum-collection count ,*loop-real-data-type* fixnum)) + (sum (loop-sum-collection sum number number)) + (summing (loop-sum-collection sum number number)) + (maximize (loop-maxmin-collection max)) + (minimize (loop-maxmin-collection min)) + (maximizing (loop-maxmin-collection max)) + (minimizing (loop-maxmin-collection min)) + (always (loop-do-always t nil)) ; Normal, do always + (never (loop-do-always t t)) ; Negate the test on always. + (thereis (loop-do-thereis t)) + (while (loop-do-while nil :while)) ; Normal, do while + (until (loop-do-while t :until)) ; Negate the test on while + (when (loop-do-if when nil)) ; Normal, do when + (if (loop-do-if if nil)) ; synonymous + (unless (loop-do-if unless t)) ; Negate the test on when + (with (loop-do-with)) + (repeat (loop-do-repeat))) + :for-keywords '((= (loop-ansi-for-equals)) + (across (loop-for-across)) + (in (loop-for-in)) + (on (loop-for-on)) + (from (loop-for-arithmetic :from)) + (downfrom (loop-for-arithmetic :downfrom)) + (upfrom (loop-for-arithmetic :upfrom)) + (below (loop-for-arithmetic :below)) + (above (loop-for-arithmetic :above)) + (by (loop-for-arithmetic :by)) + (to (loop-for-arithmetic :to)) + (upto (loop-for-arithmetic :upto)) + (downto (loop-for-arithmetic :downto)) + (being (loop-for-being))) + :iteration-keywords '((for (loop-do-for)) + (as (loop-do-for))) + :type-symbols '(array atom bignum bit bit-vector character compiled-function + complex cons double-float fixnum float + function hash-table integer keyword list long-float + nil null number package pathname random-state + ratio rational readtable sequence short-float + simple-array simple-bit-vector simple-string + simple-vector single-float standard-char + stream string base-char + symbol t vector) + :type-keywords nil + :ansi (if extended-p :extended t)))) + (add-loop-path '(hash-key hash-keys) 'loop-hash-table-iteration-path w + :preposition-groups '((:of :in)) + :inclusive-permitted nil + :user-data '(:which hash-key)) + (add-loop-path '(hash-value hash-values) 'loop-hash-table-iteration-path w + :preposition-groups '((:of :in)) + :inclusive-permitted nil + :user-data '(:which hash-value)) + (add-loop-path '(symbol symbols) 'loop-package-symbols-iteration-path w + :preposition-groups '((:of :in)) + :inclusive-permitted nil + :user-data '(:symbol-types (:internal :external :inherited))) + (add-loop-path '(external-symbol external-symbols) 'loop-package-symbols-iteration-path w + :preposition-groups '((:of :in)) + :inclusive-permitted nil + :user-data '(:symbol-types (:external))) + (add-loop-path '(present-symbol present-symbols) 'loop-package-symbols-iteration-path w + :preposition-groups '((:of :in)) + :inclusive-permitted nil + :user-data '(:symbol-types (:internal :external))) + w)) + + +(defparameter *loop-ansi-universe* + (make-ansi-loop-universe nil)) + + +(defun loop-standard-expansion (keywords-and-forms environment universe) + (if (and keywords-and-forms (symbolp (car keywords-and-forms))) + (loop-translate keywords-and-forms environment universe) + (let ((tag (gensym))) + `(block nil (tagbody ,tag (progn ,@keywords-and-forms) (go ,tag)))))) + + +(fmakunbound 'loop) ; Avoid redefinition warning + +;;;INTERFACE: ANSI +(defmacro loop (&environment env &rest keywords-and-forms) + (loop-standard-expansion keywords-and-forms env *loop-ansi-universe*)) + +(cl:provide "LOOP") Index: /branches/new-random/library/mac-file-io.lisp =================================================================== --- /branches/new-random/library/mac-file-io.lisp (revision 13309) +++ /branches/new-random/library/mac-file-io.lisp (revision 13309) @@ -0,0 +1,161 @@ +;;-*- Mode: Lisp; Package: CCL -*- +;;; +;;; Copyright (C) 1994-2001 Digitool, Inc +;;; This file is part of Opensourced MCL. +;;; +;;; Opensourced MCL is free software; 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. +;;; +;;; Opensourced MCL 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 +;;; + + +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; +;; +;; mac-file-io.lisp +;; + +;; This file implements something similar to the high-level file I/O +;; primitives in Inside Macintosh. +;; It does NOT support asynchronous I/O (and neither does the Macintosh, really). + +;; Routines that take an errorp parameter will signal an error if +;; the parameter is unspecified or true, otherwise, if there is an +;; error they return two values: NIL & the error number. +;; If there is no error, routines return one or more values the +;; first of which is non-NIL. + +;;;;;;;;;;;;; +;; +;; Modification History +;; + +(in-package "CCL") + +(eval-when (:compile-toplevel :execute) + (require 'sysequ)) + +(eval-when (:compile-toplevel :load-toplevel :execute) + (export '(with-FSOpen-file FSOpen FSClose FSRead FSWrite setFPos getFPos getEOF))) + +(defmacro with-FSOpen-file ((pb filename &optional read-write-p (vrefnum 0)) + &body body) + `(let ((,pb (FSOpen ,filename ,read-write-p ,vrefnum))) + (unwind-protect + (progn ,@body) + (FSClose ,pb)))) + +(defmacro with-FSOpen-file-noerr ((pb filename &optional read-write-p (vrefnum 0)) + &body body) + `(let ((,pb (ignore-errors + (FSOpen ,filename ,read-write-p ,vrefnum)))) + (when ,pb + (unwind-protect + (progn ,@body) + (FSClose ,pb))))) + +; Returns a paramBlock for doing furthur I/O with the file +(defun FSOpen (filename &optional read-write-p (vrefnum 0) (errorp t) + (resolve-aliases-p t)) + (when resolve-aliases-p (setq filename (truename filename))) + (let ((paramBlock (make-record :hparamblockrec)) + ok) + (unwind-protect + (with-pstrs ((pname (mac-namestring filename))) + (setf (pref paramblock :hparamblockrec.ioNameptr) pname + (pref paramblock :hparamblockrec.ioVrefnum) vrefnum + (pref paramblock :hparamblockrec.ioVersNum) 0 + (pref paramblock :hparamblockrec.ioPermssn) (if read-write-p #$fsRdWrPerm #$fsRdPerm) + (pref paramblock :hparamblockrec.ioMisc) (%null-ptr)) + (#_PBOpenSync paramBlock) + (let ((res (pref paramBlock :hparamblockrec.ioResult))) + (if (eql #$NoErr res) + (progn + (setf (pref paramblock :hparamblockrec.ioPosOffSet) 0 + (pref paramblock :hparamblockrec.ioPosMode) #$fsAtMark) + (setq ok t) + paramBlock) + (maybe-file-error errorp res filename)))) + (unless ok + (#_DisposePtr paramBlock))))) + +(defun FSClose (paramBlock &optional (errorp t)) + (#_PBCloseSync paramBlock) + (let ((errnum (pref paramBlock :hparamblockrec.ioResult))) + (#_DisposePtr paramBlock) + (or (eql errnum #$noErr) + (maybe-file-error errorp errnum)))) + +; Returns two values: the number of bytes actually read, and the +; location of the file mark. +(defun fsRead (paramBlock count buffer &optional (offset 0) (errorp t)) + (setf (pref paramBlock :hparamblockrec.ioBuffer) (%inc-ptr buffer offset) + (pref paramBlock :hparamblockrec.ioReqCount) count) + (#_PBReadSync paramBlock) + (setf (pref paramBlock :hparamblockrec.ioPosMode) #$fsAtMark) + (let ((errnum (pref paramBlock :hparamblockrec.ioResult))) + (if (or (eql #$noErr errnum) (eql #$eofErr errnum)) + (values (pref paramBlock :hparamblockrec.ioActCount) + (pref paramBlock :hparamblockrec.ioPosOffset)) + (maybe-file-error errorp errnum)))) + +; Returns two values: the number of bytes actually written, and the +; location of the file mark. +(defun fsWrite (paramBlock count buffer &optional (offset 0) (errorp t)) + (setf (pref paramBlock :hparamblockrec.ioBuffer) (%inc-ptr buffer offset) + (pref paramBlock :hparamblockrec.ioReqCount) count) + (#_PBWriteSync paramBlock) + (setf (pref paramBlock :hparamblockrec.ioPosMode) #$fsAtMark) + (let ((errnum (pref paramBlock :hparamblockrec.ioResult))) + (if (or (eql #$noErr errnum) (eql #$eofErr errnum)) + (values (pref paramBlock :hparamblockrec.ioActCount) + (pref paramBlock :hparamblockrec.ioPosOffset)) + (maybe-file-error errorp errnum)))) + +(defun setFPos (paramBlock pos) + (setf (pref paramBlock :hparamblockrec.ioPosOffset) pos + (pref paramblock :hparamblockrec.ioPosMode) #$fsFromStart) + pos) + +(defun getFPos (paramBlock) + (pref paramBlock :hparamblockrec.ioPosOffset)) + +(defun getEOF (paramBlock &optional (errorp t)) + (let* ((errnum (#_PBGetEOFSync paramBlock))) + (if (eql #$noErr errnum) + (%ptr-to-int (pref paramblock :hparamblockrec.ioMisc)) + (maybe-file-error errorp errnum)))) + +(defun GetVInfo (&key (volName "") (vRefNum 0)) + (let* ((vol-pathname (truename (make-pathname :type nil :name nil :defaults volName))) + (directory (pathname-directory vol-pathname))) + (assert (and directory (eq :absolute (car directory)))) + (rlet ((paramBlock :hparamblockrec)) + (with-returned-pstrs ((pname (cadr directory))) + (setf (pref paramblock :hparamblockrec.ioCompletion) (%null-ptr) + (pref paramblock :hparamblockrec.ioNamePtr) pname + (pref paramblock :hparamblockrec.ioVRefNum) vRefNum + (pref paramblock :hparamblockrec.ioVolIndex) 0) + (values (#_PBHGetVInfoSync paramBlock) + (* (%get-unsigned-long paramblock $ioVAlBlkSiz) ; see IM:Files 2-46 + (pref paramblock :hparamblockrec.ioVFrBlk)) + (pref paramblock :hparamblockrec.ioVRefNum) + (%get-string (pref paramblock :hparamblockrec.ioNamePtr))))))) + +(defun maybe-file-error (errorp errnum &optional filename) + (if errorp + (%err-disp errnum filename) + (values nil errnum))) + +(provide :mac-file-io) + +; End of mac-file-io.lisp Index: /branches/new-random/library/mach-o-symbols.lisp =================================================================== --- /branches/new-random/library/mach-o-symbols.lisp (revision 13309) +++ /branches/new-random/library/mach-o-symbols.lisp (revision 13309) @@ -0,0 +1,216 @@ +;;; Copyright 2009 Clozure Associates +;;; This file is part of Clozure CL. +;;; +;;; Clozure CL is licensed under the terms of the Lisp Lesser GNU +;;; Public License , known as the LLGPL and distributed with Clozure +;;; CL as the file "LICENSE". The LLGPL consists of a preamble and +;;; the LGPL, which is distributed with Clozure CL as the file "LGPL". +;;; Where these conflict, the preamble takes precedence. +;;; +;;; Clozure CL is referenced in the preamble as the "LIBRARY." +;;; +;;; The LLGPL is also available online at +;;; http://opensource.franz.com/preamble.html + +(in-package "CCL") + +;;; String tables: used both for symbol names and for section names. +(defstruct mach-o-string-table + (hash (make-hash-table :test #'equal)) + (string (make-array 100 :element-type '(unsigned-byte 8) :fill-pointer 1 :adjustable t))) + +;;; Collect info about Mach-O symbols. +(defstruct mach-o-symbol-table + (strings (make-mach-o-string-table)) + data ; foreign pointer + nsyms + ) + +(defun mach-o-lisp-function-name (f) + (let* ((name (format nil "~s" f))) + (subseq (nsubstitute #\0 #\# (nsubstitute #\. #\Space name)) 1))) + +(defun mach-o-register-string (string table) + (let* ((hash (mach-o-string-table-hash table)) + (s (mach-o-string-table-string table))) + (when (gethash string hash) + (format t "~& duplicate: ~s" string)) + (or (gethash string hash) + (setf (gethash string hash) + (let* ((n (length s))) + (dotimes (i (length string) (progn (vector-push-extend 0 s) n)) + (let* ((code (char-code (char string i)))) + (declare (type (mod #x110000 code))) + (if (> code 255) + (vector-push-extend (char-code #\sub) s) + (vector-push-extend code s))))))))) + +(defun readonly-area-bounds () + (ccl::do-gc-areas (a) + (when (eql (ccl::%fixnum-ref a target::area.code) + ccl::area-readonly) + (return + (values (ash (ccl::%fixnum-ref a target::area.low) target::fixnumshift) + (ash (ccl::%fixnum-ref a target::area.active) target::fixnumshift)))))) + +#+ppc-target +(defun collect-mach-o-static-functions () + (purify) + (multiple-value-bind (readonly-low readonly-high) + (readonly-area-bounds) + (let* ((hash (make-hash-table :test #'eq))) + (ccl::%map-lfuns #'(lambda (f) + (let* ((code-vector (ccl:uvref f 0)) + (startaddr (+ (ccl::%address-of code-vector) + target::misc-data-offset))) + (when (and (>= startaddr readonly-low) + (< startaddr readonly-high)) + (push f (gethash code-vector hash)))))) + (collect ((functions)) + (maphash #'(lambda (k v) + (declare (ignore k)) + (if (null (cdr v)) + (functions (car v)))) + hash) + (values (sort (functions) + #'(lambda (x y) + (< (ccl::%address-of (uvref x 0)) + (ccl::%address-of (uvref y 0))))) + readonly-low + (- readonly-high readonly-low)))))) + +(defun register-mach-o-functions (functions section-number) + (let* ((n (length functions)) + (nlist-len #+64-bit-target (record-length :nlist_64) + #+32-bit-target (record-length :nlist)) + (data (#_calloc n nlist-len)) + (string-table (make-mach-o-string-table))) + (declare (fixnum n)) + (do* ((i 0 (1+ i)) + (p (%inc-ptr data 0) (progn (%incf-ptr p nlist-len) p)) + (f (pop functions) (pop functions))) + ((= i n) + (make-mach-o-symbol-table :strings string-table :data data :nsyms n)) + (declare (fixnum i)) + (let* ((namidx (mach-o-register-string (mach-o-lisp-function-name f) string-table)) + (value (%address-of #+ppc-target (uvref f 0) #-ppc-target g)) + (type #$N_SECT)) + #+32-bit-target + (setf (pref p :nlist.n_un.n_strx) namidx + (pref p :nlist.n_value) value + (pref p :nlist.n_type) type + (pref p :nlist.n_other) section-number) + #+64-bit-target + (setf (pref p :nlist_64.n_un.n_strx) namidx + (pref p :nlist_64.n_value) value + (pref p :nlist_64.n_type) type + (pref p :nlist_64.n_sect) section-number))))) + +(defun write-mach-o-symbol-info (fd symtab) + (let* ((symoff *host-page-size*) + (nsyms (mach-o-symbol-table-nsyms symtab)) + (symsize (* nsyms (record-length #+64-bit-target :nlist_64 + #+32-bit-target :nlist))) + (stroff (+ symoff symsize)) + (string (mach-o-string-table-string (mach-o-symbol-table-strings symtab))) + (strsize (length string)) + (bytes (array-data-and-offset string)) + (strbuf (#_malloc strsize))) + (%copy-ivector-to-ptr bytes 0 strbuf 0 strsize) + (fd-lseek fd symoff #$SEEK_SET) + (fd-write fd (mach-o-symbol-table-data symtab) symsize) + (fd-write fd strbuf strsize) + (values symoff nsyms stroff strsize))) + +(defun write-mach-o-load-commands (fd pos) + (multiple-value-bind (functions start length) + (collect-mach-o-static-functions) + (let* ((symbols (register-mach-o-functions functions 1))) + (multiple-value-bind (symoff nsyms stroff strsize) + (write-mach-o-symbol-info fd symbols) + (rlet ((symtab :symtab_command + :cmd #$LC_SYMTAB + :cmdsize (record-length :symtab_command) + :symoff symoff + :nsyms nsyms + :stroff stroff + :strsize strsize)) + (let* ((segsize (record-length #+64-bit-target :segment_command_64 + #+32-bit-target :segment_command)) + (sectsize (record-length #+64-bit-target :section_64 + #+32-bit-target :section)) + (totalsize (+ segsize sectsize))) + (%stack-block ((segment totalsize :clear t)) + (let* ((section (%inc-ptr segment segsize))) + #+64-bit-target + (progn + (setf (pref segment :segment_command_64.cmd) #$LC_SEGMENT_64 + (pref segment :segment_command_64.cmdsize) totalsize) + (%cstr-pointer #$SEG_DATA + (pref segment :segment_command_64.segname) + nil) + (setf (pref segment :segment_command_64.vmaddr) start + (pref segment :segment_command_64.vmsize) length + (pref segment :segment_command_64.fileoff) 0 + (pref segment :segment_command_64.filesize) 0 + (pref segment :segment_command_64.maxprot) 0 + (pref segment :segment_command_64.initprot) 0 + (pref segment :segment_command_64.nsects) 1) + (%cstr-pointer "__lisp" (pref section :section_64.sectname) nil) + (%cstr-pointer #$SEG_DATA (pref section :section_64.segname) nil) + (setf (pref section :section_64.addr) start + (pref section :section_64.size) length + (pref section :section_64.align) 12)) + #+32-bit-target + (progn + (setf (pref segment :segment_command.cmd) #$LC_SEGMENT + (pref segment :segment_command.cmdsize) totalsize) + (%cstr-pointer #$SEG_DATA + (pref segment :segment_command.segname) + nil) + (setf (pref segment :segment_command.vmaddr) start + (pref segment :segment_command.vmsize) length + (pref segment :segment_command.fileoff) 0 + (pref segment :segment_command.filesize) 0 + (pref segment :segment_command.maxprot) 0 + (pref segment :segment_command.initprot) 0 + (pref segment :segment_command.nsects) 1) + (%cstr-pointer "__lisp" (pref section :section.sectname) nil) + (%cstr-pointer #$SEG_DATA (pref section :section.segname) nil) + (setf (pref section :section.addr) start + (pref section :section.size) length + (pref section :section.align) 12)) + (fd-lseek fd pos #$SEEK_SET) + (fd-write fd segment totalsize) + (fd-write fd symtab (record-length :symtab_command)) + (values 2 + (+ totalsize (record-length :symtab_command))))))))))) + + +(defun write-mach-header (fd) + (let* ((n (record-length #+64-bit-target :mach_header_64 + #+32-bit-target :mach_header))) + (multiple-value-bind (ncmds cmd-size) + (write-mach-o-load-commands fd n) + (rlet ((header #+64-bit-target :mach_header_64 #+32-bit-target :mach_header + :magic #+64-bit-target #$#$MH_MAGIC_64 #+32-bit-target #$MH_MAGIC + :cputype (logior #+64-bit-target #$CPU_ARCH_ABI64 + #+32-bit-target 0 + #+ppc-target #$CPU_TYPE_POWERPC + #+x86-target #$CPU_TYPE_X86) + :cpusubtype #+x86-target #$CPU_SUBTYPE_X86_ALL #+ppc-target #$CPU_SUBTYPE_POWERPC_ALL + :filetype #$MH_BUNDLE + :ncmds ncmds + :sizeofcmds cmd-size + :flags (logior #$MH_NOUNDEFS))) + (fd-lseek fd 0 #$SEEK_SET) + (let* ((res (fd-write fd header n))) + (unless (eql res n) + (%errno-disp res))) + (fd-close fd))))) + + + + + + Index: /branches/new-random/library/mach-o.lisp =================================================================== --- /branches/new-random/library/mach-o.lisp (revision 13309) +++ /branches/new-random/library/mach-o.lisp (revision 13309) @@ -0,0 +1,133 @@ +;;; Copyright 2009 Clozure Associates +;;; This file is part of Clozure CL. +;;; +;;; Clozure CL is licensed under the terms of the Lisp Lesser GNU +;;; Public License , known as the LLGPL and distributed with Clozure +;;; CL as the file "LICENSE". The LLGPL consists of a preamble and +;;; the LGPL, which is distributed with Clozure CL as the file "LGPL". +;;; Where these conflict, the preamble takes precedence. +;;; +;;; Clozure CL is referenced in the preamble as the "LIBRARY." +;;; +;;; The LLGPL is also available online at +;;; http://opensource.franz.com/preamble.html + +(defstruct mach-o-file + header + load-commands + segments + symbols + strings) + +(defmethod print-object ((m mach-o-file) stream) + (print-unreadable-object (m stream :type t :identity t))) + + +(defstruct mach-o-string-table + (hash (make-hash-table :test #'equal)) + (string (make-array 100 :element-type '(unsigned-byte 8) :fill-pointer 1 :adjustable t))) + +(defstruct mach-o-symbol + string-index + type + sect + desc + value) + +(defun init-mach-o-string-table (fd symtab-command) + (fd-lseek fd (pref symtab-command #>symtab_command.stroff) #$SEEK_SET) + (let* ((strsize (pref symtab-command #>symtab_command.strsize)) + (nbytes (+ strsize strsize)) + (bytes (make-array nbytes :element-type '(unsigned-byte 8))) + (out 0)) + (declare (fixnum nbytes strsize out)) + (%stack-block ((buf 32768)) + (do* ((n strsize)) + ((= n 0)) + (let* ((bufsize (fd-read fd buf (min n 32768)))) + (%copy-ptr-to-ivector buf 0 bytes out bufsize) + (incf out bufsize) + (decf n bufsize)))) + (make-mach-o-string-table + :string (make-array nbytes + :element-type '(unsigned-byte 8) + :displaced-to bytes + :fill-pointer strsize + :adjustable t)))) + +(defun init-mach-o-symbols64 (fd symtab-command) + (fd-lseek fd (pref symtab-command #>symtab_command.symoff) #$SEEK_SET) + (rlet ((nlist #>nlist_64)) + (let* ((nsyms (pref symtab-command #>symtab_command.nsyms)) + (nentries (* nsyms 2)) + (vec (make-array nentries))) + (declare (fixnum nsyms nentries)) + (flet ((read-nlist () + (fd-read fd nlist (record-length #>nlist_64)) + (make-mach-o-symbol :string-index (pref nlist #>nlist_64.n_un.n_strx) + :type (pref nlist #>nlist_64.n_type) + :sect (pref nlist #>nlist_64.n_sect) + :desc (pref nlist #>nlist_64.n_desc) + :value (pref nlist #>nlist_64.n_value)))) + (dotimes (i nsyms (make-array nentries + :displaced-to vec + :fill-pointer nsyms + :adjustable t)) + (setf (svref vec i) (read-nlist))))))) + + +(defun read-header-and-load-commands64 (fd) + (fd-lseek fd 0 #$SEEK_SET) + (let* ((mh (make-record :mach_header_64)) + (mach-o (make-mach-o-file :header mh))) + (when (= (fd-read fd mh (record-length :mach_header_64)) + (record-length :mach_header_64)) + (collect ((commands)) + (flet ((read-command () + (rlet ((cmd :load_command)) + (fd-read fd cmd (record-length :load_command)) + (let* ((n (pref cmd :load_command.cmdsize)) + (p (#_malloc n)) + (q (%inc-ptr p (record-length :load_command)))) + (#_memcpy p cmd (record-length :load_command)) + (fd-read fd q (- n (record-length :load_command))) + (let* ((lcmd (pref cmd :load_command.cmd)) + (ftype + (cond ((= lcmd #$LC_SEGMENT_64) + (load-record #>segment_command_64)) + ((= lcmd #$LC_SYMTAB) + (load-record #>symtab_command)) + ((= lcmd #$LC_DYSYMTAB) + (load-record #>dysymtab_command)) + ((= lcmd #$LC_LOAD_DYLINKER) + (load-record #>dylinker_command)) + ((= lcmd #$LC_UUID) + (load-record #>uuid_command)) + ((= lcmd #$LC_LOAD_DYLIB) + (load-record #>dylib_command)) + ((= lcmd #$LC_UNIXTHREAD) + (load-record #>thread_command))))) + + (if ftype + (%set-macptr-type p (foreign-record-type-ordinal ftype)) + (format t "~&~x" lcmd))) + p)))) + (dotimes (i (pref mh :mach_header_64.ncmds)) + (commands (read-command))) + (setf (mach-o-file-load-commands mach-o) (commands)) + (dolist (cmd (mach-o-file-load-commands mach-o)) + (when (= #$LC_SYMTAB (pref cmd #>load_command.cmd)) + (setf (mach-o-file-strings mach-o) + (init-mach-o-string-table fd cmd) + (mach-o-file-symbols mach-o) + (init-mach-o-symbols64 fd cmd)))) + mach-o))))) + +(defun mach-o-string-index (mo string) + (let* ((bytes (make-array (the fixnum (+ (length string) 2)) :element-type '(unsigned-byte 8)))) + (declare (dynamic-extent bytes)) + (dotimes (i (length string)) + (setf (aref bytes (1+ i)) (char-code (char string i)))) + (let* ((pos (search bytes (mach-o-string-table-string (mach-o-file-strings mo))))) + (when pos (1+ pos))))) + Index: /branches/new-random/library/macptr-termination.lisp =================================================================== --- /branches/new-random/library/macptr-termination.lisp (revision 13309) +++ /branches/new-random/library/macptr-termination.lisp (revision 13309) @@ -0,0 +1,480 @@ +; -*- Mode: Lisp; Package: CCL; -*- +;;; +;;; Copyright (C) 2009 Clozure Associates +;;; Copyright (C) 1994-2001 Digitool, Inc +;;; This file is part of Clozure CL. +;;; +;;; Clozure CL is licensed under the terms of the Lisp Lesser GNU Public +;;; License , known as the LLGPL and distributed with Clozure CL as the +;;; file "LICENSE". The LLGPL consists of a preamble and the LGPL, +;;; which is distributed with Clozure CL as the file "LGPL". Where these +;;; conflict, the preamble takes precedence. +;;; +;;; Clozure CL is referenced in the preamble as the "LIBRARY." +;;; +;;; The LLGPL is also available online at +;;; http://opensource.franz.com/preamble.html + +;;; macptr-termination.lisp +;;; +;;; Allows you to associate a termination function with a macptr. +;;; The termination function will be called with the macptr as +;;; its single arg when the macptr is no longer accessible in the +;;; mac heap (i.e. when the garbage collector decides that its +;;; storage can be recycled). +;;; +;;; This file is provided primarily for backward compatibility. +;;; You can use terminate-when-unreachable for new code. + +;; Modification History +;; +;; 11/26/96 bill Remove cons-terminable-macptr from the PPC version of the code. +;; It referenced undefined $macptr-size and it was not used. +;; ------------- 4.0 +;; 09/12/96 bill *slave-macptrs-table* is for non-terminable slaves. +;; *terminable-slaves-table* is for terminable slaves. +;; *terminable-slaves-table* is not weak, *slave-macptrs-table* still is. +;; *terminable-slaves-table* is an EQL hash table which maps a copy of the +;; slave to the master. +;; When a slave is terminated, its entry is explicitly removed from *terminable-slaves-table*. +;; This means that a master will be removed on the next GC after all of +;; its slaves are terminated. Not optimal, but it guarantees that all the slaves are +;; disposed before the master. +;; 08/23/96 bill A *save-exit-function* to clear-terminable-macptrs +;; 08/21/96 bill add the SK8 register-slave-macptr & teminable-macptr-p functions +;; and the :deactivate-only keyword to deactivate-macptr +;; ------------- 4.0b1 +;; 02/28/96 bill Make it work in PPC MCL +;; + +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; +;;; +;;; Documentation +;;; + +#| + +SET-POST-EGC-HOOK-ENABLED-P value + This package works by setting MCL's undocumented ccl::*post-gc-hook*. +The hook is normally called only after a full GC. If you want it to +be called after each ephemeral GC as well, call this with a true value. + +POST-EGC-HOOK-ENABLED-P + Returns true if the post gc hook will be called after EGC as well as +after full GC.¬ + +ADD-PRE-GC-HOOK hook +DELETE-PRE-GC-HOOK hook +ADD-POST-GC-HOOK hook +DELETE-POST-GC-HOOK hook + MCL's ccl::*pre-gc-hook* and ccl::*post-gc-hook* can each contain +either a function or NIL. These four functions extend that functionality +by maintaining a list of functions for each of the two hooks. Hooks are +compared with EQ, so it is best to pass a symbol that has a global +definition (see the last form in this file). + +MAKE-TERMINABLE-MACPTR macptr termination-function &key master + Creates and returns a terminable macptr. It will point at the same Mac +Heap address as the macptr arg. When the return value becomes scavengeable +(e.g. no longer accessible in the Lisp heap), will call the +termination-function with a single arg, the returned macptr. If the +termination-function's return value is non-NIL, will free the macptr. +Otherwise, will assume that you decided not to terminate it, and will +call the termination-function again the next time the GC runs and +it is scavengeable. If master is supplied, then +initialize the new terminable macptr as a slave to the given master. +All slave terminable macptrs are terminated before their master is terminated. +Raise an error if macptr is not a macptr or the supplied master +is not a terminable macptr. + +REGISTER-SLAVE-MACPTR slave-macptr master-macptr + Registers a macptr as the slave of a terminable macptr. +A master terminable macptr is not terminated until all of its slaves +have been GC'ed (and terminated if appropriate). +Raise an error if master-macptr is not a terminable macptr. + +TERMINABLE-MACPTR-P thing +returns t if thing is an active terminable or gcable macptr; +otherwise returns nil. + +DEACTIVATE-MACPTR macptr &key deactivate-only + If macptr has an associated termination action, +cancel that action. If deactivate-only is nil, call the +termination action before canceling it, and change +the macptr to a dead macptr. Raise an error if macptr +is not a macptr. Return nil if not a terminable macptr +or if deactivate-only is nil and disposal function returns +nil; otherwise return true. + +|# + +(in-package "CCL") + +(provide "MACPTR-TERMINATION") + +(export '(set-post-egc-hook-enabled-p post-egc-hook-enabled-p + add-pre-gc-hook delete-pre-gc-hook add-post-gc-hook delete-post-gc-hook + make-terminable-macptr register-slave-macptr terminable-macptr-p deactivate-macptr)) + +; Map slave-macptr to master-macptr +; This holds on to the master until the slave is GC'd +(defvar *slave-macptrs-table* + (make-hash-table :test 'eq :weak :key)) + +; Map a copy of a terminable slave to its master +; This holds on to the master until the slave is terminated +(defvar *terminable-slaves-table* + (make-hash-table :test 'eql)) + +(defun register-slave-macptr (slave-macptr master-macptr) + (unless (terminable-macptr-p master-macptr) + (error "~s is not a terminable macptr" master-macptr)) + (unless (macptrp slave-macptr) + (setq slave-macptr (require-type slave-macptr 'macptr))) + (if (terminable-macptr-p slave-macptr) + (setf (gethash (%inc-ptr slave-macptr 0) *terminable-slaves-table*) master-macptr) + (setf (gethash slave-macptr *slave-macptrs-table*) master-macptr))) + +(defun dispose-gcable-macptr (macptr) + (let ((flags (macptr-flags macptr))) + ; we set to $flags_normal before calling the dispose function. + ; (client code can and does depend on this). + ; hence, if it aborts a memory leak results. + ; if we were to wait until after the user function returns + ; to put in the $flags_normal, then it will get called again + ; and might try to free something twice: crash! + (setf (macptr.flags macptr) #.$flags_normal) + (case flags + (#.$flags_normal nil) + (#.$flags_DisposHandle (#_DisposeHandle macptr) t) + (#.$flags_DisposPtr (#_DisposePtr macptr) t) + (#.$flags_DisposWindow (#_DisposeWindow macptr) t) + (#.$flags_DisposGWorld (#_DisposeGWorld macptr) t) + (otherwise (error "Macptr has bogus flags"))))) + +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; +;;; +;;; The PPC version uses the new general termination support +;;; + +#+ppc-target +(progn + +(eval-when (:compile-toplevel :execute) + (require "LISPEQU")) + +(defvar *macptr-termination-population* + (%cons-terminatable-alist)) + +(defun make-terminable-macptr (macptr termination-function &key master) + (let* ((p (%inc-ptr macptr 0)) + (cell (list (cons p termination-function))) + (population *macptr-termination-population*)) + (without-interrupts + (setf (cdr cell) (population-data population) + (population-data population) cell)) + (when master + (register-slave-macptr p master)) + p)) + +(defun terminable-macptr-p (thing) + (or (not (eql $flags_normal (macptr-flags thing))) + (member thing (population-data *macptr-termination-population*) + :key 'car))) + +(defun deactivate-macptr (macptr &key (deactivate-only t)) + (unless (macptrp macptr) + (setq macptr (require-type macptr 'macptr))) + (let ((termination-function nil) + (population *macptr-termination-population*)) + (flet ((test (macptr cell) (and (eq macptr (car cell)) (setq termination-function (cdr cell))))) + (declare (dynamic-extent #'test)) + (without-interrupts + (setf (population-data population) + (delete macptr (population-data population) + :test #'test + :count 1)))) + (when termination-function + (remhash macptr *terminable-slaves-table*)) + (if deactivate-only + termination-function + (prog1 + (if termination-function + (funcall termination-function macptr) + (progn + (dispose-gcable-macptr macptr) + (remhash macptr *slave-macptrs-table*))) + (macptr->dead-macptr macptr))))) + +; The post GC hook +(defun terminate-macptrs () + (let ((population *macptr-termination-population*) + list cell) + (loop + (without-interrupts + (setq list (population-termination-list population)) + (unless list (return)) + (setf cell (car list) + (population-termination-list population) (cdr list) + (cdr list) nil)) + (let ((macptr (car cell))) + (if (funcall (cdr cell) macptr) + (remhash macptr *terminable-slaves-table*) + (without-interrupts + (setf (cdr list) (population-data population) + (population-data population) list))))))) + +(defun macptr->dead-macptr (macptr) + (if (macptrp macptr) + (%macptr->dead-macptr macptr) + (macptr->dead-macptr (require-type macptr 'macptr)))) + + + +; Call this before save-application. +; It makes no sense to keep terminable macptrs around after that. +; They'll be dead-macptr's then causing lots of grief. +(defun clear-terminable-macptrs () + (let ((population *macptr-termination-population*)) + (setf (population-data population) nil + (population-termination-list population) nil) + (clrhash *slave-macptrs-table*))) + +) ; end of #+ppc-target progn + + +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; +;;; +;;; The 68K version needs to work harder. +;;; It also requires a kernel patch. +;;; It won't work in a vanilla MCL 3.0 (or 2.0). +;;; + +#-ppc-target +(progn + +(eval-when (:compile-toplevel :execute) + (require "LAPMACROS") + + (defconstant $flags_terminable 5) + (defconstant $flags_terminate_when_ready 6) + + (defconstant $gc-finalize-macptrs-bit (- 26 $fixnumshift)) + (defconstant $gc-post-egc-hook-p (- 25 $fixnumshift)) + + (def-accessors () %svref + nil ; macptr.ptr + nil ; macptr.flags + macptr.link + macptr.id + macptr-size) + + ; This is not exported from the kernel. In future MCL versions, it + ; will be and this definition will not be necessary. + ; This value came from the lisp-8.map file for the new kernel + (defconstant $gcable_ptrs (- #xD84 #x1000)) + ) + +(defun gcable-ptrs-head () + (lap-inline () + (move.l (a5 $gcable_ptrs) acc))) + +(defun (setf macptr-flags) (value p) + (setq p (require-type p 'macptr)) + (setq value (require-type value 'fixnum)) + (lap-inline (value p) + (move.l arg_z atemp0) + (getint arg_y) + (move.l arg_y (atemp0 $macptr.flags))) + value) + +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; +;;; +;;; cons-terminable-macptr & map-over-terminated-macptrs +;;; are the low-level interface to this package. +;;; + +; Create a terminable macptr from another macptr +(defun cons-terminable-macptr (macptr &optional (id 0)) + (setq macptr (require-type macptr 'macptr)) + (setq id (require-type id 'fixnum)) + (let ((p (make-uvector macptr-size $v_macptr :initial-element 0))) + (%setf-macptr p macptr) + (setf (macptr-flags p) $flags_terminable + (macptr.id p) id) + (lap-inline (p) + (move.l arg_z atemp0) + (move.l (a5 $gcable_ptrs) (svref atemp0 macptr.link)) + (move.l atemp0 (a5 $gcable_ptrs))) + p)) + +; Calls function with each terminated macptr. +; If function returns NIL, will not reap the macptr; +; it will reappear in the list of terminated macptrs after the next GC +; (assuming FUNCTION didn't store it somewhere). +(defun map-over-terminated-macptrs (function) + (declare (fixnum *gc-event-status-bits*)) + (when (logbitp $gc-finalize-macptrs-bit *gc-event-status-bits*) + (let ((done? nil)) + (unwind-protect + (let ((p (gcable-ptrs-head))) + (setq *gc-event-status-bits* + (the fixnum + (bitclr $gc-finalize-macptrs-bit *gc-event-status-bits*))) + (loop + (when (eql 0 p) + (return)) + (when (eql $flags_terminate_when_ready (macptr-flags p)) + ; We set to $flags_normal BEFORE calling the user function. + ; Hence, if it aborts a memory leak results. + ; If we were to wait until after the user function returns + ; to put in the $flags_normal, then it will get called again + ; and might try to free something twice: CRASH! + (setf (macptr-flags p) $flags_normal) + (unless (funcall function p) + (setf (macptr-flags p) $flags_terminable))) + (setq p (macptr.link p))) + (setq done? t)) + (unless done? + (setq *gc-event-status-bits* + (the fixnum + (bitset $gc-finalize-macptrs-bit *gc-event-status-bits*)))))))) + +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; +;;; +;;; make-terminable-macptr is the user entry point. +;;; + +; This table cannot be weak on key since hash tables are reaped before gcable-macptrs. +(defvar *termination-functions-table* (make-hash-table :test 'eql)) + +(defvar *terminable-macptr-max-id* most-negative-fixnum) +(defvar *free-terminable-macptr-ids* nil) + +(defun make-terminable-macptr (macptr termination-function &key master) + (let* ((id (or (pop *free-terminable-macptr-ids*) + (incf *terminable-macptr-max-id*))) + (p (cons-terminable-macptr macptr id))) + (setf (gethash id *termination-functions-table*) termination-function + (gethash nil *termination-functions-table*) nil) ; clear cache + (when master + (register-slave-macptr p master)) + p)) + +(defun terminable-macptr-p (thing) + (not (eql $flags_normal (macptr-flags thing)))) + +(defun terminate-macptrs () + (map-over-terminated-macptrs + #'(lambda (p) + (let* ((id (macptr.id p)) + (termination-function (gethash id *termination-functions-table*))) + (if termination-function + (when (funcall termination-function p) + (remhash id *termination-functions-table*) + (remhash p *terminable-slaves-table*) + (push id *free-terminable-macptr-ids*) + t) + (progn + (cerror "Continue." "Can't find ~s in ~s" + p '*termination-functions-table*) + t)))))) + +(defun deactivate-macptr (macptr &key (deactivate-only t)) + (setq macptr (require-type macptr 'macptr)) + (let ((flags (macptr-flags macptr)) + (termination-function nil)) + (unless (eql $flags_normal flags) + (when (or (eql flags $flags_terminable) + (eql flags $flags_terminate_when_ready)) + (setf (macptr-flags macptr) $flags_normal) + (let ((id (macptr.id macptr))) + (setq termination-function + (if deactivate-only + t + (gethash id *termination-functions-table*))) + (remhash id *termination-functions-table*) + (push id *free-terminable-macptr-ids*) + (remhash macptr *terminable-slaves-table*))) + (if deactivate-only + termination-function + (prog1 + (if termination-function + (funcall termination-function macptr) + (progn + (dispose-gcable-macptr macptr) + (remhash macptr *slave-macptrs-table*))) + (macptr->dead-macptr macptr)))))) + +#+ccl-3 +(defun macptr->dead-macptr (macptrObject) + (require-type macptrObject 'macptr) + (lap-inline () + (:variable macptrobject) + (move.l (varg macptrObject) atemp0) + (set_vsubtype ($ $v_badptr) atemp0 da)) + macptrObject) + +#-ccl-3 +(defun macptr->dead-macptr (macptrObject) + (require-type macptrObject 'macptr) + (lap + (move.l (varg macptrObject) atemp0) + (move.b ($ $v_badptr) (atemp0 $v_subtype))) + macptrObject) + +; Call this before save-application. +; It makes no sense to keep terminable macptrs around after that. +; They'll be dead-macptr's then causing lots of grief. +(defun clear-terminable-macptrs () + (clrhash *termination-functions-table*) + (clrhash *slave-macptrs-table*)) + +) ; End of #-ppc-target progn + +(pushnew 'clear-terminable-macptrs *save-exit-functions*) + +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; +;;; +;;; Backward compatibility for the gc-hook maintenance functions. +;;; + +(defun add-pre-gc-hook (hook) + (add-gc-hook hook :pre-gc)) + +(defun delete-pre-gc-hook (hook) + (remove-gc-hook hook :pre-gc)) + +(defun add-post-gc-hook (hook) + (add-gc-hook hook :post-gc)) + +(defun delete-post-gc-hook (hook) + (remove-gc-hook hook :post-gc)) + +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; +;;; +;;; Enabling the ccl::*post-gc-hook* after EGC +;;; + +#| ; These are built in now + +(defun post-egc-hook-enabled-p () + (declare (fixnum *gc-event-status-bits*)) + (logbitp $gc-post-egc-hook-p *gc-event-status-bits*)) + +(defun set-post-egc-hook-enabled-p (value) + (declare (fixnum *gc-event-status-bits*)) + (setq *gc-event-status-bits* + (if (setq value (not (null value))) + (the fixnum (bitset $gc-post-egc-hook-p *gc-event-status-bits*)) + (the fixnum (bitclr $gc-post-egc-hook-p *gc-event-status-bits*)))) + value) + +|# + +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; +;;; +;;; Install the hook +;;; + +(add-post-gc-hook 'terminate-macptrs) Index: /branches/new-random/library/openmcl-gtk-support.lisp =================================================================== --- /branches/new-random/library/openmcl-gtk-support.lisp (revision 13309) +++ /branches/new-random/library/openmcl-gtk-support.lisp (revision 13309) @@ -0,0 +1,73 @@ +;;;-*-Mode: LISP; Package: CCL -*- +;;; +;;; Copyright (C) 2001-2009 Clozure Associates +;;; This file is part of Clozure CL. +;;; +;;; Opensourced MCL is free software; 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. +;;; +;;; Opensourced MCL 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 LLGPL is also available online at +;;; http://opensource.franz.com/preamble.html + +(in-package "CCL") + +(eval-when (:compile-toplevel :execute) + (use-interface-dir :GTK2)) + +(eval-when (:compile-toplevel :load-toplevel :execute) + (open-shared-library "libgnomeui-2.so")) + + +;;; All arguments (including the first, required one) should +;;; be strings. This is supposed to be called from a C main +;;; function; it picks off gtk+-specific arguments from the +;;; caller's argv and deletes them from that C string vector. +;;; I don't know how to suppress any messages that this call +;;; might generate. +(defun gtk-init (arg &rest args) + (declare (dynamic-extent args)) + (push arg args) + (with-string-vector (argv args) + (rlet ((argvp (* t)) + (argcp :signed)) + (setf (%get-ptr argvp) argv + (%get-long argcp) (length args)) + (#_gtk_init argcp argvp)))) + +;;; Run this every 10 ticks. (There seem to be about 100 ticks +;;; per second.) +#-openmcl-native-threads +(def-load-pointers gtk-task () + (%install-periodic-task 'gtk-task + #'(lambda () + (do* () + ((eql (#_gtk_events_pending) 0)) + (#_gtk_main_iteration))) + 10)) + +;;; Ensure that GTK's initialized whenever this file's loaded +;;; and whenever a saved image starts up. (If an application +;;; needs to defer GTK initialization, *GTK-AUTO-INITIALIZE* +;;; can be set to nil to suppress this behavior.) + +;;; Used in error reporting and to provide default window titles +(defvar *gtk-init-application-name* "Clozure CL") + +(defvar *gtk-init-arguments* ()) +(defvar *gtk-auto-initialize* t) + +(def-load-pointers initialize-gtk () + (when *gtk-auto-initialize* + (apply #'gtk-init *gtk-init-application-name* *gtk-init-arguments*))) + Index: /branches/new-random/library/oprofile.txt =================================================================== --- /branches/new-random/library/oprofile.txt (revision 13309) +++ /branches/new-random/library/oprofile.txt (revision 13309) @@ -0,0 +1,155 @@ +Using the Linux oprofile system-level profiler with CCL +======================================================= + +'oprofile' () is a system-level profiler +that's available for most modern Linux distributions. + +Use of oprofile and its companion programs isn't really documented here; +what -is- described is a way of generating symbolic information that +enables profiling summaries generated by the 'opreport' program to +identify lisp functions meaningfully. + + +Generating a lisp image for use with oprofile +--------------------------------------------- + +Modern Linux uses the 'ELF" (Executable and Linking Format) object +file format; the oprofile tools can associate symbolic names with +addresses in a memory-mapped file if that file appears to be an +ELF object file and if it contains ELF symbol information that +describes those memory regiions. So, the general idea is to make +a lisp heap image that looks enough like an ELF shared library +to fool the oprofile tools (we don't actually load heap images +via ELF dynamic linking technology, but we can make it look like +we did.) + +Prerequisites +------------- + +1) oprofile itself, which is almost certainly available via your +distributions's package management system if not already preinstalled. +2) 'libelf', which provides utilities for reading and writing ELF +files (and is likewise likely preinstalled or readily installable.) + +Generating ELF symbols for lisp functions. +----------------------------------------- +In order to create a lisp heap image which can be used for oprofile- +based profiling, we need to: + +1) load any code that we want to profile +2) generate a file that contains ELF symbol information describing +the names and addresses of all lisp functions. + +This step involves doing (from within CCL) + +? (require "ELF") +"ELF" +("ELF") + +? (ccl::write-elf-symbols-to-file "home:elf-symbols") + +The argument to CCL::WRITE-ELF-SYMBOLS-TO-FILE can be any writable +pathname. The function will do whatever's necessary to nail lisp +functions down in memory (so that they aren't moved by GC), then +write an ELF object file to the indicated pathname. This typically +takes a few seconds. + +3) Generating a lisp heap image in which the ELF symbols generated +in the previous step are prepended. + +The function CCL:SAVE-APPLICATION provides a :PREPEND-KERNEL argument, +which is ordinarily used to save a standalone application in which +the kernel and heap image occupy a single file. :PREPEND-KERNEL +doesn't really care what it's prepending to the image, and we can +just as easily ask it to prepend the ELF symbol file generated in +the previous step. + +? (save-application "somewhere/image-for-profiling" :prepend-kernel +"home:elf-symbols") + +If you then run + +shell> ccl64 somewhare/image-for-profiling + +any lisp code sampled by oprofile in that image will be identified +"symbolically" by opreport. + +Example +------- +;;; Define some lisp functions that we want to profile and save +;;; a profiling-enabled image. In this case, we just want to +;;; define the FACTORIAL funcion, to keep things simple. +? (defun fact (n) (if (zerop n) 1 (* n (fact (1- n))))) +FACT +? (require "ELF") +"ELF" +("ELF") +? (ccl::write-elf-symbols-to-file "home:elf-symbols") +"home:elf-symbols" +? (save-application "home:profiled-ccl" :prepend-kernel "home:elf-symbols") + +;;; Setup oprofile with (mostly) default arguments. This example was +;;; run on a Fedora 8 system where an uncompressed 'vmlinux' kernel +;;; image isn't readily available. + +;;; Note that use of 'opcontrol' generally requires root access, e.g., +;;; 'sudo' or equivalent: + +[~] gb@rinpoche> sudo opcontrol --no-vmlinux --setup + +;;; Start the profiler + +[~] gb@rinpoche> sudo opcontrol --start +Using 2.6+ OProfile kernel interface. +Using log file /var/lib/oprofile/samples/oprofiled.log +Daemon started. +Profiler running. + +;;; Start CCL with the "profiled-ccl" image created above. +;;; Invoke "(FACT 10000)" + +[~] gb@rinpoche> ccl64 profiled-ccl +Welcome to Clozure Common Lisp Version 1.2-r9198M-trunk (LinuxX8664)! +? (null (fact 10000)) +NIL +? (quit) + +;;; We could stop the profiler (opcontrol --stop) here; instead, +;;; we simply flush profiling data to disk, where 'opreport' can +;;; find it. + +[~] gb@rinpoche> sudo opcontrol --dump + +;;; Ask opreport to show us where we were spending time in the +;;; 'profiled-ccl' image. + +[~] gb@rinpoche> opreport -l profiled-ccl | head +CPU: Core 2, speed 1596 MHz (estimated) +Counted CPU_CLK_UNHALTED events (Clock cycles when not halted) with a unit mask of 0x00 (Unhalted core cycles) count 100000 +samples % symbol name +6417 65.2466 +3211 32.6487 +17 0.1729 +11 0.1118 +10 0.1017 +7 0.0712 +7 0.0712 + +I think that we can conclude that (FACT 10000) mostly involves multiplying +bignums by small fixnums. + +Issues +------ +CCL::WRITE-ELF-SYMBOLS-TO-FILE currently only works on x86-64; it certainly +-could- be made to work on ppc32/ppc64 as well. + +So far, no one has been able to make oprofile/opreport options that're +supposed to generate call-stack info generate meaningful call-stack info. + +As of a few months ago, there was an attempt to provide symbol info +for oprofile/opreport "on the fly", e.g., for use in JIT compilation +or other incremental compilations scenarios. That's obviously more nearly +The Right Thing, but it might be awhile before that experimental code +makes it into widespread use. + + Index: /branches/new-random/library/parse-ffi.lisp =================================================================== --- /branches/new-random/library/parse-ffi.lisp (revision 13309) +++ /branches/new-random/library/parse-ffi.lisp (revision 13309) @@ -0,0 +1,1485 @@ +;;;-*-Mode: LISP; Package: CCL -*- +;;; +;;; Copyright (C) 2001-2009 Clozure Associates +;;; This file is part of Clozure CL. +;;; +;;; Clozure CL is licensed under the terms of the Lisp Lesser GNU Public +;;; License , known as the LLGPL and distributed with Clozure CL as the +;;; file "LICENSE". The LLGPL consists of a preamble and the LGPL, +;;; which is distributed with Clozure CL as the file "LGPL". Where these +;;; conflict, the preamble takes precedence. +;;; +;;; Clozure CL is referenced in the preamble as the "LIBRARY." +;;; +;;; The LLGPL is also available online at +;;; http://opensource.franz.com/preamble.html + +(in-package "CCL") + +(defvar *parse-ffi-target-ftd* *target-ftd*) +(defvar *ffi-lisp-readtable* (copy-readtable nil)) +(defvar *ffi-ordinal* -1) +(defpackage "C" (:use)) +(defvar *lparen-symbol* (intern "(" (find-package "C"))) +(defvar *rparen-symbol* (intern ")" (find-package "C"))) +(defvar *leftbracket-symbol* (intern "[" (find-package "C"))) +(defvar *rightbracket-symbol* (intern "]" (find-package "C"))) +(defvar *sharp-symbol* (intern "#" (find-package "C"))) +(defvar *sharp-sharp-symbol* (intern "##" (find-package "C"))) +(defvar *comma-symbol* (intern "," (find-package "C"))) + + +(defstruct (ffi-macro (:include ffi-type)) + args + expansion + disposition + tokens + expression ) + +(defstruct (ffi-enum (:include ffi-type))) + +(defvar *ffi-typedefs*) +(defvar *ffi-global-typedefs* nil) +(defvar *ffi-unions*) +(defvar *ffi-global-unions* nil) +(defvar *ffi-transparent-unions* nil) +(defvar *ffi-global-transparent-unions* nil) +(defvar *ffi-structs*) +(defvar *ffi-global-structs* nil) +(defvar *ffi-functions*) +(defvar *ffi-global-functions* nil) +(defvar *ffi-global-constants* nil) +(defvar *ffi-global-vars* nil) +(defvar *ffi-objc-classes* nil) +(defvar *ffi-global-objc-classes* nil) +(defvar *ffi-global-objc-messages* nil) +;;; Some things are just too hard to parse, but are important. +;;; Override those things with simpler versions. +(defvar *ffi-macro-overrides* + '((:macro ("{override}" 0) "_IOC_TYPECHECK ( t )" "sizeof(t)"))) + +(defvar *ffi-void-reference* '(:primitive :void)) + + + +(defun find-or-create-ffi-struct (string) + (or (gethash string *ffi-structs*) + (setf (gethash string *ffi-structs*) + (make-ffi-struct :string string + :name (unless (digit-char-p (schar string 0)) + (escape-foreign-name string)))))) + +(defun find-or-create-ffi-union (string) + (or (gethash string *ffi-unions*) + (setf (gethash string *ffi-unions*) + (make-ffi-union :string string + :name (unless (digit-char-p (schar string 0)) + (escape-foreign-name string)))))) + +(defun find-or-create-ffi-transparent-union (string) + (or (gethash string *ffi-transparent-unions*) + (setf (gethash string *ffi-transparent-unions*) + (make-ffi-transparent-union :string string + :name (unless (digit-char-p (schar string 0)) + (escape-foreign-name string)))))) + +(defun find-or-create-ffi-objc-class (string) + (or (gethash string *ffi-objc-classes*) + (setf (gethash string *ffi-objc-classes*) + (make-ffi-objc-class :string string + :name (escape-foreign-name string))))) + +(defun find-or-create-ffi-objc-message (string) + (or (gethash string *ffi-global-objc-messages*) + (setf (gethash string *ffi-global-objc-messages*) + (make-ffi-objc-message :string string)))) + +(defun find-or-create-ffi-typedef (string) + (or (gethash string *ffi-typedefs*) + (setf (gethash string *ffi-typedefs*) + (make-ffi-typedef :string string + :name (escape-foreign-name string))))) + +(defun eval-complex-c-expression (string constant-alist) + (declare (ignore string constant-alist))) + +(defun eval-c-float-string (string) + (setq string (nstring-upcase string)) + ;; Make the c float string (which may contain trailing garbage) + ;; look enough like a lisp float string that READ-FROM-STRING will + ;; work. + ;; There can be some trailing garbage on the string, or it might + ;; end in a decimal point. + ;; The trailing garbage might be a size specifier : #\L or #\F, + ;; to denote a LONG-DOUBLE or a (single) FLOAT. + ;; MCL can't deal with LONG-DOUBLEs, and will assume that an + ;; unqualified float constant is a SINGLE-FLOAT (or whatever + ;; *READ-DEFAULT-FLOAT-FORMAT* says. We may have to add or + ;; change an exponent marker. + (let* ((lastpos (1- (length string))) + (lastchar (schar string lastpos)) + (size :double)) + (case lastchar + (#\L (setq size :long-double) (setf (schar string lastpos) #\Space)) + (#\F (setq size :single) (setf (schar string lastpos) #\Space)) + (#\. (setq string (concatenate 'string string "0")))) + (unless (eq size :long-double) + (let* ((epos (position #\E string)) + (dpos (position #\D string))) + (if (eq size :double) + (if epos + (setf (schar string epos) #\d) + (setq string (concatenate 'string string "d0"))) + (if dpos + (setf (schar string dpos) #\e)))) + (values (ignore-errors (let* ((*readtable* *ffi-lisp-readtable*)) + (read-from-string string))))))) + +(defun read-c-number (stream char) + (loop collect char into chars + with class = :integer + with hex = nil + with octal = (eql char #\0) + do (setq char (read-char stream nil nil)) + while (or (find char "0123456789abcdefABCDEFxulXUL.") + (and (find char "+-") + (char-equal (car (last chars)) #\e))) ;signed exponent + do (cond ((char-equal char #\x) + (setq hex t octal nil)) + ((and (not hex) (or (char-equal char #\.) (char-equal char #\e))) + (setq class :float))) + finally + (when char (unread-char char stream)) + (setq chars (coerce chars 'string)) + (if (eq class :integer) + (return + (values + (ignore-errors + (parse-integer chars + :start (if hex 2 0) + :radix (if hex 16 (if octal 8 10)) + :junk-allowed t)))) + (return (eval-c-float-string chars))))) + +(defun eval-c-number (string char) + (loop collect char into chars + with class = :integer + with hex = nil + with octal = (eql char #\0) + with len = (length string) + with i = 0 + do (setq char (if (< (incf i) len) (schar string i))) + while (or (find char "0123456789abcdefABCDEFxulXUL.") + (and (find char "+-") + (char-equal (car (last chars)) #\e))) ;signed exponent + do (cond ((char-equal char #\x) + (setq hex t octal nil)) + ((and (not hex) (or (char-equal char #\.) (char-equal char #\e))) + (setq class :float))) + finally + (setq chars (coerce chars 'string)) + (if (eq class :integer) + (return + (values + (ignore-errors + (parse-integer chars + :start (if hex 2 0) + :radix (if hex 16 (if octal 8 10)) + :junk-allowed t)))) + (return (eval-c-float-string chars))))) + +;;; For our purposes (evaluating constant expressions in C macros), +;;; we don't have to get this exactly right (since the result is +;;; only going to be used in a size-of or cast operation.) +;;; All pointer types would therefore look identical. + +(defvar *the-ffi-pointer-type* (parse-foreign-type '(* t))) + +;;; If we don't get this right the first time, we never will; +;;; if there's nothing better, just return the void type. + +(defvar *the-ffi-void-type* (parse-foreign-type :void)) + +(defun parse-c-ffi-type (spec) + (flet ((parse-it-or-lose (spec) + (or (ignore-errors (parse-foreign-type spec)) + *the-ffi-void-type*)) + (make-type-name (name) + (escape-foreign-name (string name)))) + (cond ((eq (car (last spec)) 'c::*) *the-ffi-pointer-type*) + ((member (car spec) '(c::|struct| c::|union|)) + (parse-it-or-lose (mapcar #'make-type-name spec))) + ((null (cdr spec)) + (parse-it-or-lose (make-type-name (car spec)))) + (t + ;;; A qualified primitive type + (let* ((primitive (parse-it-or-lose (make-type-name (car (last spec)))))) + (if (eq primitive *the-ffi-void-type*) + primitive + (let* ((long 0) + (explicitly-signed nil)) + (declare (fixnum long)) + (if + (dolist (token (butlast spec) t) + (case token + (c::|unsigned| (setq explicitly-signed :unsigned)) + (c::|signed| (setq explicitly-signed :signed)) + (c::|long| (incf long)) + (c::|short| (decf long)) + (t (return nil)))) + (cond ((typep primitive 'foreign-integer-type) + (let* ((prim-bits (foreign-type-bits primitive)) + (prim-signed (foreign-integer-type-signed primitive))) + (if (> long 1) + (make-foreign-integer-type :bits 64 + :signed (or (not explicitly-signed) + (eq explicitly-signed :signed))) + (if (< long 0) + (make-foreign-integer-type :bits 16 + :signed (or (not explicitly-signed) + (eq explicitly-signed :signed))) + (if (= long 1) + (make-foreign-integer-type :bits 32 + :signed (or (not explicitly-signed) + (eq explicitly-signed :signed))) + (make-foreign-integer-type :bits prim-bits + :signed + (case explicitly-signed + (:signed t) + (:unsigned nil) + (t prim-signed)))))))) + ((and (= long 1) + (typep primitive 'foreign-double-float-type)) + (parse-it-or-lose :long-double)) + (t *the-ffi-void-type*)) + *the-ffi-void-type*)))))))) + +(defun eval-parsed-c-expression (expression constant-alist) + (if (atom expression) + (if (identifierp expression) + (find-constant expression constant-alist) + (if (typep expression 'character) + (char-code expression) + expression)) + (let* ((operator (car expression)) + (operands (cdr expression)) + (noperands (length operands))) + (case operator + (c::resolve-type (let* ((foreign-type (ignore-errors (parse-c-ffi-type (car operands))))) + (when foreign-type + (setf (cdr expression) nil + (car expression) foreign-type) + ))) + (c::curly-bracketed-list ()) + (t + (if (typep operator 'foreign-type) + operator + (when (do* ((tail (cdr expression) (cdr tail))) + ((null tail) t) + (let* ((expr (car tail)) + (value (eval-parsed-c-expression expr constant-alist))) + (unless value (return)) + (unless (eq expr value) + (rplaca tail value)))) + (case noperands + (1 + (let* ((operand (cadr expression))) + (case operator + (c::! (if (zerop operand) 1 0)) + (c::- (- operand)) + (c::+ operand) + (c::~ (lognot operand)) + (c::size-of + (let* ((bits (ignore-errors (ensure-foreign-type-bits operand)))) + (when bits + (ash (+ bits 7) -3)))) + (t + ;(break "~s" expression) + nil)))) + (2 + (let* ((a (car operands)) + (b (cadr operands))) + (case operator + (c::<< (ash a b)) + (c::>> (ash a (- b))) + (c::* (* a b)) + (c::/ (if (zerop b) 0 (values (floor a b)))) ; or maybe TRUNCATE ? + (c::+ (+ a b)) + (c::- (- a b)) + (c::\| (logior a b)) + (c::\& (logand a b)) + (c::cast (if (foreign-typep (setq b (eval-parsed-c-expression b constant-alist)) a) + b + (if (and (typep a 'foreign-integer-type) + (not (foreign-integer-type-signed a)) + (typep b 'integer) + (not (> (integer-length b) + (foreign-integer-type-bits a)))) + (logand b (1- (ash 1 (foreign-integer-type-bits a)))) + (if (and (typep a 'foreign-pointer-type) + (typep b 'integer) + (<= (integer-length b) 16)) + (progn + (%int-to-ptr (logand b #xffffffff))))))) + + + (t + ;(break "binary op = ~s ~s ~s" operator a b) + nil)))) + (t + ;(break "expression = ~s" expression) + nil))))))))) + +(defun eval-c-expression (macro constant-alist macro-table) + (let* ((string (ffi-macro-expansion macro)) + (len (length string))) + (if (= len 0) + 1 + (progn + (unless (ffi-macro-tokens macro) + (let* ((transitive (gethash (ffi-macro-expansion macro) macro-table))) + (if transitive + (setf (ffi-macro-tokens macro) transitive + (gethash (ffi-macro-name macro) macro-table) transitive) + (multiple-value-bind (tokens error) (ignore-errors (string-to-tokens string)) + (if error + (setf (ffi-macro-disposition macro) :bad-tokenize) + (setf (ffi-macro-tokens macro) tokens)))))) + (unless (ffi-macro-expression macro) + (let* ((tokens (ffi-macro-tokens macro))) + (when tokens + (multiple-value-bind (expression error) + (ignore-errors (parse-c-expression tokens + :constants constant-alist + :expand-macros macro-table )) + (if (or error (null expression)) + (progn + ;(format t "~& parse failed: ~s ~s" (ffi-macro-name macro) string) + ;(format t "~& tokens = ~s, error = ~a" tokens error) + (setf (ffi-macro-disposition macro) :bad-parse)) + (setf (ffi-macro-expression macro) expression)))))) + (let* ((expression (ffi-macro-expression macro))) + (when expression (values (eval-parsed-c-expression expression constant-alist) t))))))) + +;;; Repeatedly iterate over the macros until nothing new's defined. +(defun process-defined-macros (ffi-macros constant-alist parameterized-macros) + (let* ((new-def ())) + (loop + (setq new-def nil) + (dolist (macro ffi-macros) + (unless (ffi-macro-disposition macro) + (let* ((expansion (ffi-macro-expansion macro)) + (name (ffi-macro-name macro)) + (value nil)) + (if (string= name expansion) + (setf (ffi-macro-disposition macro) t) + (when (setq value (eval-c-expression macro constant-alist parameterized-macros)) + (push (cons name value) constant-alist) + (setf (ffi-macro-disposition macro) t) + (setq new-def t)))))) + (unless new-def + (return (values (reverse constant-alist) nil)))))) + +(defun reference-ffi-type (spec) + (case (car spec) + (:typedef (list :typedef (find-or-create-ffi-typedef (cadr spec)))) + (:struct-ref (list :struct (find-or-create-ffi-struct (cadr spec)))) + (:union-ref (list :union (find-or-create-ffi-union (cadr spec)))) + (:transparent-union-ref + (list :transparent-union (find-or-create-ffi-transparent-union (cadr spec)))) + (:enum-ref `(:primitive :signed)) + (:function `(:primitive (* t))) + (:pointer (list :pointer (reference-ffi-type (cadr spec)))) + (:array (list :array (cadr spec) (reference-ffi-type (caddr spec)))) + (:void *ffi-void-reference*) + (t + (list :primitive + (ecase (car spec) + (:char (if (getf (ftd-attributes *parse-ffi-target-ftd*) + :signed-char) + '(:signed 8) + '(:unsigned 8))) + (:signed-char '(:signed 8)) + (:unsigned-char '(:unsigned 8)) + (:short '(:signed 16)) + (:unsigned-short '(:unsigned 16)) + ((:vec128 :unsigned-long-long-long) '(:unsigned 128)) + (:signed-long-long-long '(:signed 128)) + (:int '(:signed 32)) + (:long (ecase (or + (getf + (ftd-attributes *parse-ffi-target-ftd*) + :bits-per-long) + (getf + (ftd-attributes *parse-ffi-target-ftd*) + :bits-per-word)) + (32 '(:signed 32)) + (64 '(:signed 64)))) + (:unsigned '(:unsigned 32)) + (:unsigned-long (ecase (or + (getf + (ftd-attributes *parse-ffi-target-ftd*) + :bits-per-long) + (getf + (ftd-attributes *parse-ffi-target-ftd*) + :bits-per-word)) + (32 '(:unsigned 32)) + (64 '(:unsigned 64)))) + (:long-long '(:signed 64)) + ((:vec64 :unsigned-long-long) '(:unsigned 64)) + (:float :float) + (:double :double) + (:long-double :long-float) + (:complex-int :complex-int) + (:complex-float :complex-float) + (:complex-double :complex-double) + (:complex-long-double :complex-long-float) + (:long-long-long :long-long-long) + #|(:void :void)|#))))) + + +(defun process-ffi-fieldlist (fields) + (let* ((parsed-fields ())) + (dolist (field fields (nreverse parsed-fields)) + (let* ((field-name (escape-foreign-name (car field))) + (field-descr (cadr field))) + (destructuring-bind (field-type offset width) + (cdr field-descr) + (push (cons field-name + (ecase (car field-descr) + (:field `(,(reference-ffi-type field-type) ,(ash offset 3) ,(ash width 3))) + (:bitfield `((:primitive (:unsigned ,width)) ,offset ,width)))) + parsed-fields)))))) + +(defun process-ffi-union (form) + (destructuring-bind (source-info string fields &optional alignform) + (cdr form) + (declare (ignore source-info)) + (let* ((union (find-or-create-ffi-union string))) + (setf (ffi-union-ordinal union) (incf *ffi-ordinal*)) + (when alignform + (setf (ffi-union-alt-alignment-bits union) (cadr alignform))) + (unless (ffi-union-fields union) + (setf (ffi-union-fields union) + (process-ffi-fieldlist fields))) + union))) + +(defun process-ffi-transparent-union (form) + (destructuring-bind (source-info string fields &optional alignform) + (cdr form) + (declare (ignore source-info)) + (let* ((union (find-or-create-ffi-transparent-union string))) + (setf (ffi-transparent-union-ordinal union) (incf *ffi-ordinal*)) + (when alignform + (setf (ffi-transparent-union-alt-alignment-bits union) (cadr alignform))) + (unless (ffi-transparent-union-fields union) + (setf (ffi-transparent-union-fields union) + (process-ffi-fieldlist fields))) + union))) + +(defun process-ffi-struct (form) + (destructuring-bind (source-info string fields &optional alignform) + (cdr form) + (declare (ignore source-info)) + (let* ((struct (find-or-create-ffi-struct string))) + (setf (ffi-struct-ordinal struct) (incf *ffi-ordinal*)) + (when alignform + (setf (ffi-struct-alt-alignment-bits struct) (cadr alignform))) + (unless (ffi-struct-fields struct) + (setf (ffi-struct-fields struct) + (process-ffi-fieldlist fields))) + struct))) + +(defun process-ffi-objc-class (form) + (destructuring-bind (source-info class-name superclass-form protocols ivars) (cdr form) + (declare (ignore source-info)) + (let* ((class (find-or-create-ffi-objc-class class-name))) + (setf (ffi-objc-class-ordinal class) (incf *ffi-ordinal*)) + (unless (ffi-objc-class-super-foreign-name class) + (let* ((super-name (car superclass-form))) + (unless (eq super-name :void) + (setf (ffi-objc-class-super-foreign-name class) + super-name)))) + (unless (ffi-objc-class-protocol-names class) + (setf (ffi-objc-class-protocol-names class) protocols)) + (unless (ffi-objc-class-own-ivars class) + (setf (ffi-objc-class-own-ivars class) + (process-ffi-fieldlist ivars))) + class))) + +(defun process-ffi-objc-method (form) + (destructuring-bind (method-type source-info class-name category-name message-name arglist result-type) form + (declare (ignore source-info category-name)) + (let* ((flags ())) + (if (or (eq method-type :objc-class-method) + (eq method-type :objc-protocol-class-method)) + (setf (getf flags :class) t)) + (if (or (eq method-type :objc-protocol-class-method) + (eq method-type :objc-protocol-instance-method)) + (setf (getf flags :protocol) t)) + (let* ((message (find-or-create-ffi-objc-message message-name)) + (class-method-p (getf flags :class)) + (method + (make-ffi-objc-method :class-name class-name + :arglist (mapcar #'reference-ffi-type + arglist) + :result-type (reference-ffi-type + result-type) + :flags flags))) + (unless (dolist (m (ffi-objc-message-methods message)) + (when (and (equal (ffi-objc-method-class-name m) + class-name) + (eq (getf (ffi-objc-method-flags m) :class) + class-method-p)) + (return t))) + (push method (ffi-objc-message-methods message))))))) + +(defun process-ffi-typedef (form) + (let* ((string (caddr form)) + (def (find-or-create-ffi-typedef string))) + (setf (ffi-typedef-ordinal def) (incf *ffi-ordinal*)) + (unless (ffi-typedef-type def) + (setf (ffi-typedef-type def) (reference-ffi-type (cadddr form)))) + def)) + + +(defun process-ffi-function (form) + (let* ((name (caddr form)) + (ftype (cadddr form))) + (make-ffi-function :string name + :arglist (mapcar #'reference-ffi-type (cadr ftype)) + :return-value (reference-ffi-type (caddr ftype))))) + +(defun process-ffi-macro (form) + (let* ((name-form (caddr form)) + (expansion (cadddr form)) + (name name-form) + (args nil) + (space-pos (position #\space name-form))) + (when space-pos + (setq name (subseq name-form 0 space-pos)) + (let* ((open-pos (position #$ name-form)) + (close-pos (position #$ name-form))) + (when (and open-pos close-pos (> close-pos open-pos)) + (let* ((arg-string (subseq name-form open-pos close-pos)) + (arg-tokens (ignore-errors (string-to-tokens arg-string))) + (arg-names (let* ((l ())) + (dolist (arg-token arg-tokens (nreverse l)) + (unless (or (eq arg-token 'c::|,|) + (eq arg-token *lparen-symbol*)) + (push arg-token l))))) + (body-tokens (ignore-errors (string-to-tokens expansion)))) + (when (and arg-names body-tokens) + (setq args (list arg-names body-tokens) + expansion name)))))) + (make-ffi-macro :name name :args args :expansion expansion))) + +(defun process-ffi-enum (form) + (declare (ignore form))) + +(defun process-ffi-var (form) + (let* ((name (caddr form)) + (type (cadddr form))) + (cons name (reference-ffi-type type)))) + +(defun process-ffi-enum-ident (form) + (cons (caddr form) (cadddr form))) + +(defun ensure-referenced-type-defined (spec) + (declare (ignorable spec)) + (when nil + (ecase (car spec) + (:primitive) + (:typedef (define-typedef-from-ffi-info (cadr spec))) + (:struct (ensure-struct-defined (cadr spec))) + (:union (ensure-union-defined (cadr spec))) + (:transparent-union (ensure-transparent-union-defined (cadr spec))) + (:pointer (ensure-referenced-type-defined (cadr spec))) + (:array (ensure-referenced-type-defined (caddr spec))) + (:function (dolist (arg (ffi-function-arglist (cadr spec))) + (ensure-referenced-type-defined arg)) + (ensure-referenced-type-defined (ffi-function-return-value (cadr spec)))) + ))) + + +(defun ensure-fields-defined (fields) + (dolist (f fields) + (let* ((ftype (cadr f))) + (ensure-referenced-type-defined ftype)))) + +(defun record-global-objc-class (c) + (when *ffi-global-objc-classes* + (setf (gethash (ffi-objc-class-string c) *ffi-global-objc-classes*) c))) + +(defun define-objc-class-from-ffi-info (c) + (unless (ffi-objc-class-defined c) + (setf (ffi-objc-class-defined c) t) + (record-global-objc-class c) + (ensure-fields-defined (ffi-objc-class-own-ivars c)))) + +(defun record-global-union (u) + (when (and *ffi-global-unions* (ffi-union-fields u)) + (setf (gethash (ffi-union-reference u) *ffi-global-unions*) u))) + +(defun record-global-transparent-union (u) + (when (and *ffi-global-transparent-unions* (ffi-transparent-union-fields u)) + (setf (gethash (ffi-transparent-union-reference u) *ffi-global-transparent-unions*) u))) + +(defun define-union-from-ffi-info (u) + (unless (ffi-union-defined u) + (setf (ffi-union-defined u) t) + (record-global-union u) + (when (ffi-union-name u) + (let* ((fields (ffi-union-fields u))) + (ensure-fields-defined fields))))) + +(defun define-transparent-union-from-ffi-info (u) + (unless (ffi-transparent-union-defined u) + (setf (ffi-transparent-union-defined u) t) + (record-global-transparent-union u) + (when (ffi-transparent-union-name u) + (let* ((fields (ffi-transparent-union-fields u))) + (ensure-fields-defined fields))))) + +(defun ensure-union-defined (u) + (let* ((name (ffi-union-name u))) + (if name + (define-union-from-ffi-info u) + (ensure-fields-defined (ffi-union-fields u))))) + +(defun ensure-transparent-union-defined (u) + (let* ((name (ffi-transparent-union-name u))) + (if name + (define-transparent-union-from-ffi-info u) + (ensure-fields-defined (ffi-transparent-union-fields u))))) + +(defun record-global-struct (s) + (when (and *ffi-global-structs* (ffi-struct-fields s)) + (setf (gethash (ffi-struct-reference s) *ffi-global-structs*) s))) + +(defun define-struct-from-ffi-info (s) + (unless (ffi-struct-defined s) + (setf (ffi-struct-defined s) t) + (record-global-struct s) + (when (typep (ffi-struct-name s) 'keyword) + (let* ((fields (ffi-struct-fields s))) + (ensure-fields-defined fields))))) + +(defun ensure-struct-defined (s) + (let* ((name (ffi-struct-name s))) + (if (typep name 'keyword) + (define-struct-from-ffi-info s) + (ensure-fields-defined (ffi-struct-fields s))))) + +(defun record-global-typedef (def) + (when *ffi-global-typedefs* + (setf (gethash (ffi-typedef-string def) *ffi-global-typedefs*) def))) + +(defun define-typedef-from-ffi-info (def) + (unless (ffi-typedef-defined def) + (setf (ffi-typedef-defined def) t) + (record-global-typedef def) + (let* ((target (ffi-typedef-type def))) + (unless (and (consp target) + (member (car target) '(:struct :union :transparent-union :primitive))) + (ensure-referenced-type-defined target))))) + +(defun record-global-constant (name val) + (when *ffi-global-constants* + (setf (gethash name *ffi-global-constants*) val))) + +(defun emit-ffi-constant (name val) + (record-global-constant name val)) + +(defun record-global-var (name type) + (when *ffi-global-vars* + (setf (gethash name *ffi-global-vars*) type))) + +(defun emit-ffi-var (name type) + (record-global-var name type)) + + +(defun ffi-record-type-p (typeref) + (case (car typeref) + ((:struct :union :transparent-union) t) + (:typedef (ffi-record-type-p (ffi-typedef-type (cadr typeref)))) + (t nil))) + +(defun record-global-function (ffi-function) + (when *ffi-global-functions* + (setf (gethash (ffi-function-string ffi-function) *ffi-global-functions*) + ffi-function))) + +(defun emit-function-decl (ffi-function) + (let* ((args (ffi-function-arglist ffi-function)) + (retval (ffi-function-return-value ffi-function))) + (if (eq (car (last args)) *ffi-void-reference*) + (setq args (butlast args))) + (dolist (arg args) (ensure-referenced-type-defined arg)) + (ensure-referenced-type-defined retval) + (record-global-function ffi-function))) + + +(defun read-ffi-toplevel-form (stream eof-value) + (loop + (let* ((ch (peek-char nil stream nil eof-value))) + (cond ((eq ch eof-value) (return eof-value)) + ((eql ch #\() (return (read stream nil eof-value))) + (t (read-line stream)))))) + +(defun parse-ffi (inpath) + (let* ((*ffi-typedefs* (make-hash-table :test 'string= :hash-function 'sxhash)) + (*ffi-unions* (make-hash-table :test 'string= :hash-function 'sxhash)) + (*ffi-transparent-unions* (make-hash-table :test 'string= :hash-function 'sxhash)) + (*ffi-structs* (make-hash-table :test 'string= :hash-function 'sxhash)) + (*ffi-objc-classes* (make-hash-table :test 'string= :hash-function 'sxhash)) + (argument-macros (make-hash-table :test 'equal))) + (let* ((defined-types ()) + (defined-constants ()) + (defined-macros ()) + (defined-functions ()) + (defined-vars ())) + (with-open-file (in inpath) + (let* ((*ffi-ordinal* -1)) + (let* ((*package* (find-package "KEYWORD"))) + (do* ((form (read-ffi-toplevel-form in :eof) + (read-ffi-toplevel-form in :eof))) + ((eq form :eof)) + (case (car form) + (:struct (push (process-ffi-struct form) defined-types)) + (:objc-class (push (process-ffi-objc-class form) defined-types)) + ((:objc-class-method + :objc-instance-method + :objc-protocol-class-method + :objc-protocol-instance-method + ) + (process-ffi-objc-method form)) + (:function (push (process-ffi-function form) defined-functions)) + (:macro (let* ((m (process-ffi-macro form)) + (args (ffi-macro-args m))) + (if args + (setf (gethash (string (ffi-macro-name m)) argument-macros) args) + (push m defined-macros)))) + (:type (push (process-ffi-typedef form) defined-types)) + (:var (push (process-ffi-var form) defined-vars)) + (:enum-ident (push (process-ffi-enum-ident form) defined-constants)) + (:enum (process-ffi-enum form)) + (:union (push (process-ffi-union form) defined-types)) + (:transparent-union (push (process-ffi-transparent-union form) defined-types))))) + (dolist (override *ffi-macro-overrides*) + (let* ((m (process-ffi-macro override)) + (args (ffi-macro-args m))) + (if args + (setf (gethash (string (ffi-macro-name m)) argument-macros) args) + (push m defined-macros)))) + (multiple-value-bind (new-constants new-macros) + (process-defined-macros defined-macros (reverse defined-constants) argument-macros) + ;; If we're really lucky, we might be able to turn some C macros + ;; into lisp macros. We can probably turn some C macros into + ;; lisp constants. + (declare (ignore new-macros)) + (dolist (x (reverse new-constants)) + (emit-ffi-constant (car x) (cdr x))) + (dolist (x defined-vars) + (emit-ffi-var (car x) (cdr x))) + (dolist (x (sort defined-types #'< :key #'ffi-type-ordinal)) + (typecase x + (ffi-struct (define-struct-from-ffi-info x)) + (ffi-union (define-union-from-ffi-info x)) + (ffi-transparent-union (define-transparent-union-from-ffi-info x)) + (ffi-typedef (define-typedef-from-ffi-info x)) + (ffi-objc-class (define-objc-class-from-ffi-info x)))) + (dolist (f defined-functions) (emit-function-decl f)))))))) + +(defun parse-standard-ffi-files (dirname &optional target) + (let* ((backend (if target (find-backend target) *target-backend*)) + (ftd (backend-target-foreign-type-data backend)) + (*parse-ffi-target-ftd* ftd) + (*target-ftd* ftd) + (*target-backend* backend) + (d (use-interface-dir dirname ftd)) + (interface-dir (merge-pathnames + (interface-dir-subdir d) + (ftd-interface-db-directory ftd))) + (*prepend-underscores-to-ffi-function-names* + (getf (ftd-attributes ftd) :prepend-underscores)) + (*ffi-global-typedefs* (make-hash-table :test 'string= :hash-function 'sxhash)) + (*ffi-global-unions* (make-hash-table :test 'string= :hash-function 'sxhash)) + (*ffi-global-transparent-unions* (make-hash-table :test 'string= :hash-function 'sxhash)) + (*ffi-global-structs* (make-hash-table :test 'string= :hash-function 'sxhash)) + (*ffi-global-objc-classes* (make-hash-table :test 'string= :hash-function 'sxhash)) + (*ffi-global-objc-messages* (make-hash-table :test 'string= :hash-function 'sxhash)) + (*ffi-global-functions* (make-hash-table :test 'string= :hash-function 'sxhash)) + (*ffi-global-constants* (make-hash-table :test 'string= :hash-function 'sxhash)) + (*ffi-global-vars* (make-hash-table :test 'string= :hash-function 'sxhash))) + + (dolist (f (directory (merge-pathnames ";C;**;*.ffi" + interface-dir))) + (format t "~&~s ..." f) + (parse-ffi f ) + (format t "~&")) + (with-new-db-file (constants-cdbm (merge-pathnames + "new-constants.cdb" + interface-dir)) + (maphash #'(lambda (name def) + (db-define-constant constants-cdbm name def)) + *ffi-global-constants*)) + (with-new-db-file (types-cdbm (merge-pathnames + "new-types.cdb" + interface-dir)) + (maphash #'(lambda (name def) + (declare (ignore name)) + (save-ffi-typedef types-cdbm def)) + *ffi-global-typedefs*)) + (with-new-db-file (records-cdbm (merge-pathnames + "new-records.cdb" + interface-dir)) + (maphash #'(lambda (name def) + (declare (ignore name)) + (save-ffi-union records-cdbm def)) + *ffi-global-unions*) + (maphash #'(lambda (name def) + (declare (ignore name)) + (save-ffi-transparent-union records-cdbm def)) + *ffi-global-transparent-unions*) + + (maphash #'(lambda (name def) + (declare (ignore name)) + (save-ffi-struct records-cdbm def)) + *ffi-global-structs*)) + (with-new-db-file (function-cdbm (merge-pathnames + "new-functions.cdb" + interface-dir)) + (maphash #'(lambda (name def) + (declare (ignore name)) + (save-ffi-function function-cdbm def)) + *ffi-global-functions*)) + (with-new-db-file (class-cdbm (merge-pathnames + "new-objc-classes.cdb" + interface-dir)) + (maphash #'(lambda (name def) + (declare (ignore name)) + (save-ffi-objc-class class-cdbm def)) + *ffi-global-objc-classes*)) + (with-new-db-file (vars-cdbm (merge-pathnames + "new-vars.cdb" + interface-dir)) + (maphash #'(lambda (name type) + (db-define-var vars-cdbm name type)) + *ffi-global-vars*)) + (with-new-db-file (methods-cdbm (merge-pathnames + "new-objc-methods.cdb" + interface-dir)) + (maphash #'(lambda (name message) + (declare (ignore name)) + (save-ffi-objc-message methods-cdbm message)) + *ffi-global-objc-messages*)) + (install-new-db-files ftd d))) + +(defvar *c-readtable* (copy-readtable nil)) +(setf (readtable-case *c-readtable*) :preserve) + + +;;; Each element of operators can be a symbol or a list of a symbol, a +;;; function, and args All the symbols must start with the character +;;; for which this is the macro-character fcn The entries must be in +;;; the right order, e.g. dictionary order, so any two symbols with a +;;; common prefix are adjacent in the list. Furthermore each symbol +;;; in the list must be preceded by every non-empty leading substring +;;; of that symbol, since we only have one character of look-ahead in +;;; the stream. +(defun operator-macro (operators) + ;; The tree is an alist keyed by character (with a nil key at the end for the default) + ;; The cdr of each entry is either a symbol to produce, another decision tree, + ;; or a list of a function to call and additional arguments for the function + (let ((decision-tree (make-decision-tree operators))) + (labels ((read-c-operator (stream char) + (declare (ignore char)) + (loop with decision-tree = decision-tree + as char = (read-char stream nil nil) ; eof => nil which works too + as elem = (assoc char decision-tree) + do (unless elem + (unread-char char stream) + (setq elem (assoc nil decision-tree))) + (setq elem (cdr elem)) + (cond ((symbolp elem) + (return elem)) + ((symbolp (car elem)) + (return (apply (car elem) stream (cdr elem)))) + (t (setq decision-tree elem))))) + (read-c-singleton-operator (stream char) + (declare (ignore stream char)) + (first operators)) + (read-c-macro-character (stream char) + (declare (ignore char)) + (apply (car decision-tree) stream (cdr decision-tree)))) + (cond ((symbolp decision-tree) #'read-c-singleton-operator) + ((consp (car decision-tree)) #'read-c-operator) + (t #'read-c-macro-character))))) + +(defun make-decision-tree (operators) + (labels ((recurse (operators chars-so-far) ;returns new operators and decision tree element + (let ((next-char (aref (key (first operators)) + (length chars-so-far))) + (alist nil)) + (setq chars-so-far (append chars-so-far (list next-char))) + (loop while operators + as key = (key (first operators)) + while (every #'char= key chars-so-far) + do (if (= (length key) (length chars-so-far)) + (push (cons nil (val (pop operators))) alist) + (multiple-value-bind (remaining-operators elem) + (recurse operators chars-so-far) + (push elem alist) + (setq operators remaining-operators)))) + (values operators + (cons next-char (if (cdr alist) alist (cdar alist)))))) + (key (operator) + (string (if (atom operator) operator (car operator)))) + (val (operator) + (if (atom operator) operator (cdr operator)))) + (multiple-value-bind (left-over elem) (recurse operators nil) + (when left-over + (error "Malformed operators list ~S:~S" (ldiff operators left-over) left-over)) + (cdr elem)))) + +;;; Doesn't support the L prefix for wide characters. What a complete kludge! +(defun c-read-string (stream single-quote) + (loop with delimiter = (if single-quote #\' #\") + as char = (read-char stream nil nil) + do (cond ((null char) + (c-parse-error stream "Unmatched ~A" delimiter)) + ((char= char delimiter) + + (return (if single-quote + (char-code (car chars)) + (coerce chars 'string)))) + ((char= char #\\) + (setq char (read-char stream nil nil)) + (unless char (c-parse-error stream "EOF after backslash in string")) + (let ((tem (assoc char '((#\n . #\newline) + (#\t . #\tab) + (#\v . #\^K) + (#\b . #\backspace) + (#\r . #\return) + (#\f . #\page) + (#\a . #\bell) + (#\\ . #\\) + (#\? . #\?) + (#\' . #\') + (#\" . #\"))))) + (cond (tem (setq char (cdr tem))) + ((char<= #\0 char #\7) + (setq char (loop while (char<= #\0 char #\7) for count from 1 + with sum = 0 + do (setq sum (+ (* sum 8) (digit-char-p char))) + (setq char (read-char stream nil nil)) + until (= count 3) + finally + (unread-char char stream) + (return (code-char sum))))) + ((char= char #\x) + (setq char (loop with sum = 0 + as char = (read-char stream) + while (or (char<= #\0 char #\9) + (char<= #\A char #\F) + (char<= #\a char #\f)) + do (setq sum (+ (* sum 16) (digit-char-p char 16))) + finally + (unread-char char stream) + (return (code-char sum))))))))) + collect char into chars)) + +(dolist (char '(#\_)) + (set-syntax-from-char char #\A *c-readtable*)) + +(dolist (op '( (c::! c::!=) + ((\" c-read-string nil)) + (|#| |##|) ; # and ## are pre-processor operators + (c::% c::%=) + (c::& c::&= c::&&) + ((\' c-read-string t)) + (c::$) + (c::$) + (c::* c::*=) + (c::+ c::+= c::++) + (c::- c::-= c::-- c::->) + (c::\,) + (c::|.| c::|.*| c::|..| c::|...|) ; .01 will fail to parse as 0.01 + (c::/ c::/= (// c-read-line-comment) (/* c-read-block-comment)) + (c::\: c::\:\:) + (c::\;) + (c::< c::<= c::<< c::<<=) + (c::= c::==) + (c::> c::>= c::>> c::>>=) + (c::?) + (c::[) + (c::\\) + (c::]) + (c::^ c::^=) + (c::{) + (c::\| c::\|= c::\|\|) + (c::}) + (c::~) + ;; C++ doesn't define any meaning for these, treat them as operators + (c::\$) + (c::\@) + (c::\`) + )) + (set-macro-character (char (string (if (atom (car op)) (car op) (caar op))) 0) + (operator-macro op) + nil ;token-terminating + *c-readtable*)) + +(dolist (char '(#\0 #\1 #\2 #\3 #\4 #\5 #\6 #\7 #\8 #\9)) + (set-macro-character char 'read-c-number t *c-readtable*)) + + +(defvar *backslash-symbol* 'c::|\\|) + +(defvar *pending-tokens* ()) + +(defun unread-token (token) + (push token *pending-tokens*) + token) + +(defun next-token (stream) + (if *pending-tokens* + (pop *pending-tokens*) + (do* ((tok (read-preserving-whitespace stream nil :eof) + (read-preserving-whitespace stream nil :eof))) + ((or (not (eq tok *backslash-symbol*)) + (not (eq (peek-char nil stream nil nil) #\Newline))) + tok) + ;; Consume the #\newline that followed #\\. Yecch. + (read-char stream nil nil)))) + +(defun string-to-tokens (string) + (with-input-from-string (stream string) + (let* ((*package* (find-package "C")) + (*readtable* *c-readtable*) + (tokens ())) + (loop + (let* ((token (next-token stream))) + (when (eq token :eof) + (return (nreverse tokens))) + (push token tokens)))))) + + +(defun identifierp (token) + (and (symbolp token) + (let ((char (char (symbol-name token) 0))) + (or (alpha-char-p char) (char= char #\_))))) + + +(defun evaluate-type-name (x) + (let* ((name (car x))) + (if (and (atom name) nil (null (cdr x))) + name))) + + +(defun find-constant (x constants) + (when (symbolp x) + (cdr (assoc (string x) constants :test #'string=)))) + +(defun find-user-or-primitive-type (x) + x + nil) + +(defun macro-definition (id table) + (gethash (string id) table)) + +(defun expand-c-macro (name parameters arguments body stream macros-not-to-expand macro-table) + (let ((expansion nil)) + (unless (= (length arguments) (length parameters)) + (c-parse-error stream "Expected ~D argument~:P to macro ~A but got ~D argument~:P." + (length parameters) name (length arguments))) + (loop while body + as token = (pop body) + as next = (first body) + as argno = (position token parameters) do + (cond ((and argno (eq next *sharp-sharp-symbol*)) ; parameter ## token/parameter + (pop body) + (setq next (pop body)) + (let ((next-argno (position next parameters))) + (push (intern (concatenate 'string (c-stringize-token-list (nth argno arguments)) + (if next-argno + (c-stringize-token-list (nth next-argno arguments)) + (c-stringize-token next)))) + expansion))) + (argno ; normal parameter substitution + (setq expansion (nreconc (expand-c-macros-in-token-list (nth argno arguments) + stream macros-not-to-expand + macro-table) + expansion))) + ((and (eq token *sharp-sharp-symbol*) ; token ## parameter + (setq argno (position next parameters))) + (pop body) + (push (intern (concatenate 'string (c-stringize-token (pop expansion)) + (c-stringize-token-list (nth argno arguments)))) + expansion)) + ((and (eq token *sharp-symbol*) ; # parameter + (setq argno (position next parameters))) + (pop body) + (push (c-stringize-token-list (nth argno arguments)) expansion)) + (t (push token expansion)))) + (expand-c-macros-in-token-list (nreverse expansion) stream + (adjoin name macros-not-to-expand) + macro-table))) + +(defun expand-c-macros-in-token-list (tokens stream macros-not-to-expand macro-table) + (loop + while tokens + as token = (pop tokens) + as macro = (and (symbolp token) + (not (member token macros-not-to-expand)) + (macro-definition token macro-table)) + if macro + nconc (if (eq (first macro) :none) + (expand-c-macros-in-token-list (second macro) stream + (adjoin token macros-not-to-expand) macro-table) + (expand-c-macro token (first macro) + (let ((open (pop tokens))) + (unless (eq open *lparen-symbol*) + (c-parse-error + stream + "~A where open parenthesis expected after macro name ~A" + open token)) + (loop with done = nil + collect + (loop as token = (if tokens (pop tokens) + (c-parse-error stream + "Unexpected impossible EOF")) + with level = 0 + do (cond ((eq token *lparen-symbol*) (incf level)) + ((eq token *rparen-symbol*) + (if (plusp level) (decf level) (setq done t)))) + until (or done (and (zerop level) + (eq token *comma-symbol*))) + collect token) + until done)) + (second macro) stream macros-not-to-expand macro-table)) + else collect token)) + +(defun parse-c-expression (token-list &key constants additional-constants + expand-macros) + (labels ((next () + (unless token-list + (fail "Unterminated expression or unbalanced parentheses")) + (pop token-list)) + (peek () + (car token-list)) + (unread (token) + (push token token-list)) + (collect-parenthesized () + (loop with level = 0 + as token = (next) + until (and (eq token *rparen-symbol*) (= level 0)) + collect token + do (case token + (#.*lparen-symbol* (incf level)) + (#.*rparen-symbol* (decf level))))) + (fail (format-string &rest format-arguments) + (apply #'c-parse-error nil format-string format-arguments)) + (parse-expression () + (parse-assignment)) + (parse-assignment () + (let ((left (parse-conditional))) + (if (eq (peek) 'c::|=|) + (let ((right (progn (next) (parse-assignment)))) + (list 'setf left right)) + left))) + (parse-conditional () + (let ((left (parse-logical-or))) + (if (eq (peek) 'c::|?|) + (let ((then (progn (next) (parse-expression))) + (else (if (eq (peek) 'c::|:|) + (progn (next) (parse-conditional)) + (fail "~A where : was expected" (peek))))) + (list 'if left then else)) + left))) + (parse-logical-or () + (let ((left (parse-logical-and))) + (loop while (eq (peek) 'c::|\|\||) + do (setq left (list (next) left (parse-logical-and)))) + left)) + (parse-logical-and () + (let ((left (parse-bitwise-ior))) + (loop while (eq (peek) 'c::|&&|) + do (setq left (list (next) left (parse-bitwise-ior)))) + left)) + (parse-bitwise-ior () + (let ((left (parse-bitwise-xor))) + (loop while (eq (peek) 'c::|\||) + do (setq left (list (next) left (parse-bitwise-xor)))) + left)) + (parse-bitwise-xor () + (let ((left (parse-bitwise-and))) + (loop while (eq (peek) 'c::|\^|) + do (setq left (list (next) left (parse-bitwise-and)))) + left)) + (parse-bitwise-and () + (let ((left (parse-equality))) + (loop while (eq (peek) 'c::|&|) + do (setq left (list (next) left (parse-equality)))) + left)) + (parse-equality () + (let ((left (parse-relational))) + (loop while (member (peek) '(c::|==| c::|!=|)) + do (setq left (list (next) left (parse-relational)))) + left)) + (parse-relational () + (let ((left (parse-shift))) + (loop while (member (peek) '(c::|<| c::|>| c::|<=| c::|>=|)) + do (setq left (list (next) left (parse-shift)))) + left)) + (parse-shift () + (let ((left (parse-additive))) + (loop while (member (peek) '(c::|<<| c::|>>|)) + do (setq left (list (next) left (parse-additive)))) + left)) + (parse-additive () + (let ((left (parse-multiplicative))) + (loop while (member (peek) '(c::|+| c::|-|)) + do (setq left (list (next) left (parse-multiplicative)))) + left)) + (parse-multiplicative () + (let ((left (parse-pointer-to-member))) + (loop while (member (peek) '(c::|*| c::|/| c::|%|)) + do (setq left (list (next) left (parse-pointer-to-member)))) + left)) + (parse-pointer-to-member () + (let ((left (parse-unary))) + (loop while (member (peek) '(c::|.*| c::|->*|)) + do (setq left (list (next) left (parse-unary)))) + left)) + (parse-unary () ; subsumes parse-cast, thus accepting some invalid programs + (let ((token (next))) ; --- doesn't support new and delete yet + (cond ((member token '(c::|+| c::|-| c::|!| c::|~| c::|++| c::|--|)) + ;;--- doesn't yet have special support for calling destructors... + (list token (parse-unary))) + ((eq token 'c::|*|) + (list 'c::indirect (parse-unary))) + ((eq token 'c::|&|) + (list 'c::address-of (parse-unary))) + ((eq token 'c::|sizeof|) + (unless (eq (peek) *lparen-symbol*) ; Require open paren, maybe it's really optional + (fail "~A where ( was expected after sizeof" (peek))) + (next) ; Swallow open parenthesis + `(c::size-of (c::resolve-type ,(loop as token = (next) + until (eq token *rparen-symbol*) + collect token)))) + (t (parse-postfix token))))) + (parse-postfix (token) + (loop with left = (parse-primary token) + as right = (peek) do + (setq left + (cond ((eq right *leftbracket-symbol*) + (next) ; swallow [ + (let ((subscript (parse-expression)) + (delimiter (next))) + (unless (eq delimiter *rightbracket-symbol*) + (fail "~A where ] expected after subscript" delimiter)) + `(c::aref ,left ,subscript))) + ((eq right *lparen-symbol*) + (next) ; swallow open parenthesis + (let ((macro (and expand-macros + (identifierp left) + (macro-definition left expand-macros)))) + (cond ((and macro (not (eq (first macro) ':none))) + ;; Function-like macro - constant-like was alraedy handled + (let ((more-tokens + (expand-c-macro left (first macro) + (collect-macro-arguments) + (second macro) nil '() + expand-macros))) + (setq token-list (append more-tokens token-list)) + (parse-expression))) + ((valid-type-name? (list left)) + ;; This is an explicit type conversion + `(c::cast ,(evaluate-type-name (list left)) + ,@(parse-argument-list))) + (t nil #|`(c::call ,left ,@(parse-argument-list))|#)))) + ((memq right '(c::|.| c::|->|)) + (next) ; swallow operator + `(,right ,left ,(parse-primary (next)))) ; parse-name, really + ((eq right 'c::|++|) + (next) ; swallow operator + `(c::postfix++ ,left)) + ((eq right 'c::|--|) + (next) ; swallow operator + `(c::postfix-- ,left)) + (t (return left)))))) + (parse-primary (token) + (cond ((identifierp token) + ;; nonqualified name + (let ((value (find-constant token constants))) + (cond (value + (setq value (list value) token-list `(,@value #.*rparen-symbol* ,@token-list)) + (parse-parenthesized)) + ((setq value (assoc token additional-constants)) + (cdr value)) + ((and expand-macros + (setq value (macro-definition-of-token token)) + (eq (first value) ':none)) + (setq token-list (append (expand-c-macros-in-token-list + (second value) nil (list token) expand-macros) + token-list )) + (parse-primary (next))) + (t token)))) + ((eq token *lparen-symbol*) + (let* ((save-token-list token-list) + (type-name (collect-parenthesized)) + (type (valid-type-name? type-name))) + (cond (type + ;; This is a cast + ;; Doing cast here is easier but accepts some invalid programs + (progn + `(c::cast (,type) ,(parse-unary)))) + (t + ;; These are ordinary grouping parentheses + (setq token-list save-token-list) + (parse-parenthesized))))) + ((eq token 'c::|{|) + (cons 'c::curly-bracketed-list + (loop as token = (next) + until (eq token 'c::|}|) + do (unread token) + collect (parse-expression) + do (let ((delimiter (peek))) + (case delimiter + (c::|,| (next)) + (c::|}| ) + (otherwise + (fail "~A where , or } was expected" delimiter))))))) + ((numberp token) token) + ((stringp token) token) + ((eq token 'c::|::|) + (fail "Unary :: is not supported yet")) + (t (fail "~A is unrecognized syntax in an expression" token)))) + (parse-parenthesized () + (prog1 (parse-expression) + (let ((close (next))) + (unless (eq close *rparen-symbol*) + (fail "~A where ) was expected" close))))) + (parse-argument-list () + (if (eq (peek) *rparen-symbol*) + (progn (next) '()) + (loop as arg = (parse-expression) + as delimiter = (next) + collect arg + do (unless (or (eq delimiter 'c::|,|) (eq delimiter *rparen-symbol*)) + (fail "~A where , or ) expected in function arguments" + delimiter)) + while (eq delimiter 'c::|,|)))) + (collect-macro-arguments () + (loop with done = nil with first = t + collect (loop as token = (next) with level = 0 + do (cond ((eq token *lparen-symbol*) (incf level)) + ((eq token *rparen-symbol*) + (when first ; () has to be treated as a special case + (return-from collect-macro-arguments '())) + (if (plusp level) (decf level) (setq done t)))) + (setq first nil) + until (or done (and (zerop level) (eq token 'c::|,|))) + collect token) + until done)) + + ;;--- The following type-name routines don't support the full C++ syntax + ;;--- Maybe we will add ::, arrays, functions, and God knows what later + (valid-type-name? (token-list &optional tailp) + (let* ((type (ignore-errors (parse-c-ffi-type token-list)))) + tailp + (return-from valid-type-name? + (if (and type (not (eq type *the-ffi-void-type*))) + type))) + + ;; At least one type-specifier followed by an optional abstract-declarator + ;; For now the type-specifier cannot contain :: and the only + ;; abstract-declarators we accept are stars (not functions, arrays) + (cond ((null token-list) tailp) + ((member (car token-list) '(c::|long| c::|short| c::|signed| c::|unsigned|)) + (valid-type-name? (cdr token-list) t)) + ((and (identifierp (car token-list)) + (find-user-or-primitive-type (car token-list))) + (valid-type-name? (cdr token-list) t)) + ;((eq (car token-list) '|::|) (valid-type-name? (cdr token-list))) + ((and tailp (eq (car token-list) 'c::|*|)) + (valid-type-name? (cdr token-list) t)) + (t nil)))) + (prog1 (parse-expression) + (when token-list + (fail "~{~A ~} left over after expression" token-list))))) + +(defun c-parse-error (stream format &rest args) + (declare (ignore stream)) + (apply #'error format args)) + +(pushnew '(c-parse-error . 1) ccl::*format-arg-functions* :test #'equal) + +(defun macro-definition-of-token (x) + (declare (ignore x))) + +(defun c-stringize-token-list (tokens) + (apply #'concatenate 'string (mapcar #'c-stringize-token tokens))) + +(defun c-stringize-token (token) + (etypecase token + (symbol (string token)) + (string token) + (number (princ-to-string token)))) + +(defun install-new-db-files (ftd d) + (let* ((dir (merge-pathnames (interface-dir-subdir d) + (ftd-interface-db-directory ftd)))) + (flet ((rename-and-reopen (was-open path newpath) + (let* ((path (merge-pathnames path dir)) + (newpath (merge-pathnames newpath dir))) + (when was-open + (cdb-close was-open)) + (when (probe-file path) + (rename-file path + (concatenate 'string (namestring (truename path)) "-BAK") + :if-exists :supersede)) + (rename-file newpath path) + (when was-open + (cdb-open path))))) + (without-interrupts + (setf (interface-dir-constants-interface-db-file d) + (rename-and-reopen + (interface-dir-constants-interface-db-file d) + "constants.cdb" + "new-constants.cdb")) + (setf (interface-dir-functions-interface-db-file d) + (rename-and-reopen + (interface-dir-functions-interface-db-file d) + "functions.cdb" + "new-functions.cdb")) + (setf (interface-dir-records-interface-db-file d) + (rename-and-reopen + (interface-dir-records-interface-db-file d) + "records.cdb" + "new-records.cdb")) + (setf (interface-dir-types-interface-db-file d) + (rename-and-reopen + (interface-dir-types-interface-db-file d) + "types.cdb" + "new-types.cdb")) + (setf (interface-dir-vars-interface-db-file d) + (rename-and-reopen + (interface-dir-vars-interface-db-file d) + "vars.cdb" + "new-vars.cdb")) + (setf (interface-dir-objc-classes-interface-db-file d) + (rename-and-reopen + (interface-dir-objc-classes-interface-db-file d) + "objc-classes.cdb" + "new-objc-classes.cdb")) + (setf (interface-dir-objc-methods-interface-db-file d) + (rename-and-reopen + (interface-dir-objc-methods-interface-db-file d) + "objc-methods.cdb" + "new-objc-methods.cdb"))))) + t) + + Index: /branches/new-random/library/pascal-strings.lisp =================================================================== --- /branches/new-random/library/pascal-strings.lisp (revision 13309) +++ /branches/new-random/library/pascal-strings.lisp (revision 13309) @@ -0,0 +1,107 @@ +;;;-*- Mode: Lisp; Package: CCL -*- +;;; +;;; Copyright (C) 2003-2009 Clozure Associates +;;; This file is part of Clozure CL. +;;; +;;; Clozure CL is licensed under the terms of the Lisp Lesser GNU Public +;;; License , known as the LLGPL and distributed with Clozure CL as the +;;; file "LICENSE". The LLGPL consists of a preamble and the LGPL, +;;; which is distributed with Clozure CL as the file "LGPL". Where these +;;; conflict, the preamble takes precedence. +;;; +;;; Clozure CL is referenced in the preamble as the "LIBRARY." +;;; +;;; The LLGPL is also available online at +;;; http://opensource.franz.com/preamble.html + + +;;; Utilities for dealing with Pascal strings +;;; +;;; In 68K Mac Pascal, strings were represented by a pointer to a +;;; "length byte", which indicated the number of data bytes immediately +;;; following. + +(in-package "CCL") + +(eval-when (:compile-toplevel :load-toplevel :execute) + ;; What else should be exported ? What else should be added + ;; to this file ? + (export '(with-pstrs with-returned-pstrs %get-string))) + +(defun %pstr-pointer (string pointer) + (multiple-value-bind (s o n) (dereference-base-string string) + (declare (fixnum o n)) + (%copy-ivector-to-ptr s o pointer 1 n) + (setf (%get-byte pointer 0) n)) + nil) + +(defun %pstr-segment-pointer (string pointer start end) + (declare (fixnum start end)) + (let* ((n (- end start))) + (multiple-value-bind (s o) (dereference-base-string string) + (declare (fixnum o)) + (%copy-ivector-to-ptr s (the fixnum (+ o start)) pointer 1 n) + (setf (%get-byte pointer 0) n) + nil))) + +(defun %get-string (pointer) + (let* ((len (%get-unsigned-byte pointer))) + (%copy-ptr-to-ivector + pointer + 1 + (make-string len :element-type 'base-char) + 0 + len))) + +(defun (setf %get-string) (lisp-string pointer) + (let* ((len (length lisp-string))) + (multiple-value-bind (string offset) + (dereference-base-string lisp-string) + (setf (%get-unsigned-byte pointer) len) + (%copy-ivector-to-ptr string offset pointer 1 len)) + lisp-string)) + +(defmacro with-pstr ((sym str &optional start end) &rest body &environment env) + (multiple-value-bind (body decls) (parse-body body env nil) + (if (and (base-string-p str) (null start) (null end)) + (let ((strlen (%i+ (length str) 1))) + `(%stack-block ((,sym ,strlen)) + ,@decls + (%pstr-pointer ,str ,sym) + ,@body)) + (let ((strname (gensym)) + (start-name (gensym)) + (end-name (gensym))) + `(let ((,strname ,str) + ,@(if (or start end) + `((,start-name ,(or start 0)) + (,end-name ,(or end `(length ,strname)))))) + (%vstack-block (,sym + (the fixnum + (1+ + (the fixnum + ,(if (or start end) + `(byte-length + ,strname ,start-name ,end-name) + `(length ,strname)))))) + ,@decls + ,(if (or start end) + `(%pstr-segment-pointer ,strname ,sym ,start-name ,end-name) + `(%pstr-pointer ,strname ,sym)) + ,@body)))))) + + +(defmacro with-returned-pstr ((sym str &optional start end) &body body) + `(%stack-block ((,sym 256)) + ,(if (or start end) + `(%pstr-segment-pointer ,str ,sym ,start ,end) + `(%pstr-pointer ,str ,sym)) + ,@body)) + +(defmacro with-pstrs (speclist &body body) + (with-specs-aux 'with-pstr speclist body)) + +(defmacro with-returned-pstrs (speclist &body body) + (with-specs-aux 'with-returned-pstr speclist body)) + + Index: /branches/new-random/library/ppc-linux-syscalls.lisp =================================================================== --- /branches/new-random/library/ppc-linux-syscalls.lisp (revision 13309) +++ /branches/new-random/library/ppc-linux-syscalls.lisp (revision 13309) @@ -0,0 +1,234 @@ +;;;-*-Mode: LISP; Package: CCL -*- +;;; +;;; Copyright (C) 2001-2009 Clozure Associates +;;; This file is part of Clozure CL. +;;; +;;; Clozure CL is licensed under the terms of the Lisp Lesser GNU Public +;;; License , known as the LLGPL and distributed with Clozure CL as the +;;; file "LICENSE". The LLGPL consists of a preamble and the LGPL, +;;; which is distributed with Clozure CL as the file "LGPL". Where these +;;; conflict, the preamble takes precedence. +;;; +;;; Clozure CL is referenced in the preamble as the "LIBRARY." +;;; +;;; The LLGPL is also available online at +;;; http://opensource.franz.com/preamble.html + +(in-package "CCL") + +(eval-when (:compile-toplevel :load-toplevel :execute) + (require "SYSCALL")) + + + + + + + +(define-syscall (logior platform-cpu-ppc platform-os-linux) syscalls::exit 1 (:signed-fullword) :void) +(define-syscall (logior platform-cpu-ppc platform-os-linux) syscalls::fork 2 () :signed-fullword) +(define-syscall (logior platform-cpu-ppc platform-os-linux) syscalls::read 3 (:unsigned-fullword :address :unsigned-fullword) + :signed-fullword) +(define-syscall (logior platform-cpu-ppc platform-os-linux) syscalls::write 4 (:unsigned-fullword :address :unsigned-fullword) + :signed-fullword) +(define-syscall (logior platform-cpu-ppc platform-os-linux) syscalls::open 5 (:address :unsigned-fullword :unsigned-fullword) :signed-fullword :min-args 2) +(define-syscall (logior platform-cpu-ppc platform-os-linux) syscalls::close 6 (:unsigned-fullword) :signed-fullword ) +(define-syscall (logior platform-cpu-ppc platform-os-linux) syscalls::waitpid 7 (:unsigned-fullword :address :signed-fullword) + :signed-fullword) +(define-syscall (logior platform-cpu-ppc platform-os-linux) syscalls::creat 8 (:address :unsigned-fullword) :signed-fullword ) +(define-syscall (logior platform-cpu-ppc platform-os-linux) syscalls::link 9 (:address :address) :signed-fullword) +(define-syscall (logior platform-cpu-ppc platform-os-linux) syscalls::unlink 10 (:address) :signed-fullword ) +(define-syscall (logior platform-cpu-ppc platform-os-linux) syscalls::execve 11 (:address :address :address) :signed-fullword ) +(define-syscall (logior platform-cpu-ppc platform-os-linux) syscalls::chdir 12 (:address) :signed-fullword ) +(define-syscall (logior platform-cpu-ppc platform-os-linux) syscalls::time 13 (:address) :unsigned-fullword ) +(define-syscall (logior platform-cpu-ppc platform-os-linux) syscalls::mknod 14 (:address :unsigned-fullword :unsigned-fullword) + :signed-fullword) +(define-syscall (logior platform-cpu-ppc platform-os-linux) syscalls::chmod 15 (:address :unsigned-fullword) :signed-fullword) +(define-syscall (logior platform-cpu-ppc platform-os-linux) syscalls::lchown 16 (:address :unsigned-fullword :unsigned-fullword) + :signed-fullword) +;(define-syscall (logior platform-cpu-ppc platform-os-linux) syscalls::oldstat 18 () ) +(define-syscall (logior platform-cpu-ppc platform-os-linux) syscalls::lseek 19 (:unsigned-fullword :signed-fullword :unsigned-fullword) :signed-fullword ) +(define-syscall (logior platform-cpu-ppc platform-os-linux) syscalls::getpid 20 () :unsigned-fullword) +(define-syscall (logior platform-cpu-ppc platform-os-linux) syscalls::mount 21 (:address + :address + :address + :unsigned-fullword + :address) :signed-fullword ) +(define-syscall (logior platform-cpu-ppc platform-os-linux) syscalls::umount 22 (:address) :signed-fullword ) + +(define-syscall (logior platform-cpu-ppc platform-os-linux) syscalls::setuid 23 (:unsigned-fullword) :signed-fullword ) +(define-syscall (logior platform-cpu-ppc platform-os-linux) syscalls::getuid 24 () :unsigned-fullword ) +(define-syscall (logior platform-cpu-ppc platform-os-linux) syscalls::stime 25 (:address) :signed-fullword ) +(define-syscall (logior platform-cpu-ppc platform-os-linux) syscalls::ptrace 26 (:unsigned-fullword + :unsigned-fullword + :address + :address) + :signed-fullword) +(define-syscall (logior platform-cpu-ppc platform-os-linux) syscalls::alarm 27 (:unsigned-fullword) :unsigned-fullword ) + +(define-syscall (logior platform-cpu-ppc platform-os-linux) syscalls::pause 29 () :signed-fullword) +(define-syscall (logior platform-cpu-ppc platform-os-linux) syscalls::utime 30 (:address :address) :signed-fullword ) +(define-syscall (logior platform-cpu-ppc platform-os-linux) syscalls::access 33 (:address :unsigned-fullword) :signed-fullword) +(define-syscall (logior platform-cpu-ppc platform-os-linux) syscalls::nice 34 (:signed-fullword) :signed-fullword ) +(define-syscall (logior platform-cpu-ppc platform-os-linux) syscalls::sync 36 () :unsigned-fullword ) +(define-syscall (logior platform-cpu-ppc platform-os-linux) syscalls::kill 37 (:signed-fullword :unsigned-fullword) :signed-fullword ) +(define-syscall (logior platform-cpu-ppc platform-os-linux) syscalls::rename 38 (:address :address) :signed-fullword ) +(define-syscall (logior platform-cpu-ppc platform-os-linux) syscalls::mkdir 39 (:address :unsigned-fullword) :signed-fullword ) +(define-syscall (logior platform-cpu-ppc platform-os-linux) syscalls::rmdir 40 (:address) :signed-fullword ) +(define-syscall (logior platform-cpu-ppc platform-os-linux) syscalls::dup 41 (:unsigned-fullword) :signed-fullword ) +(define-syscall (logior platform-cpu-ppc platform-os-linux) syscalls::pipe 42 (:address) :signed-fullword ) +(define-syscall (logior platform-cpu-ppc platform-os-linux) syscalls::times 43 (:address) :unsigned-fullword ) + +(define-syscall (logior platform-cpu-ppc platform-os-linux) syscalls::brk 45 (:address) :signed-fullword ) +(define-syscall (logior platform-cpu-ppc platform-os-linux) syscalls::setgid 46 (:unsigned-fullword) :signed-fullword) +(define-syscall (logior platform-cpu-ppc platform-os-linux) syscalls::getgid 47 () :unsigned-fullword ) +(define-syscall (logior platform-cpu-ppc platform-os-linux) syscalls::signal 48 (:unsigned-fullword :address) :address ) +(define-syscall (logior platform-cpu-ppc platform-os-linux) syscalls::geteuid 49 () :unsigned-fullword ) +(define-syscall (logior platform-cpu-ppc platform-os-linux) syscalls::getegid 50 () :unsigned-fullword) +(define-syscall (logior platform-cpu-ppc platform-os-linux) syscalls::acct 51 (:address) :signed-fullword ) +(define-syscall (logior platform-cpu-ppc platform-os-linux) syscalls::umount2 52 (:address) :signed-fullword ) +(define-syscall (logior platform-cpu-ppc platform-os-linux) syscalls::ioctl 54 (:unsigned-fullword :signed-fullword :address) :signed-fullword :min-args 2 ) +(define-syscall (logior platform-cpu-ppc platform-os-linux) syscalls::fcntl 55 (:unsigned-fullword :signed-fullword :signed-fullword) :signed-fullword :min-args 2 ) +(define-syscall (logior platform-cpu-ppc platform-os-linux) syscalls::setpgid 57 (:signed-fullword :signed-fullword) :signed-fullword ) +(define-syscall (logior platform-cpu-ppc platform-os-linux) syscalls::umask 60 (:unsigned-fullword) :unsigned-fullword ) +(define-syscall (logior platform-cpu-ppc platform-os-linux) syscalls::chroot 61 (:address) :signed-fullword ) +(define-syscall (logior platform-cpu-ppc platform-os-linux) syscalls::ustat 62 (:unsigned-fullword :address) :signed-fullword ) +(define-syscall (logior platform-cpu-ppc platform-os-linux) syscalls::dup2 63 (:unsigned-fullword :unsigned-fullword) :signed-fullword ) +(define-syscall (logior platform-cpu-ppc platform-os-linux) syscalls::getppid 64 () :unsigned-fullword) +(define-syscall (logior platform-cpu-ppc platform-os-linux) syscalls::getpgrp 65 () :unsigned-fullword) +(define-syscall (logior platform-cpu-ppc platform-os-linux) syscalls::setsid 66 () :signed-fullword) +(define-syscall (logior platform-cpu-ppc platform-os-linux) syscalls::sigaction 67 (:unsigned-fullword :address :address) :signed-fullword ) +(define-syscall (logior platform-cpu-ppc platform-os-linux) syscalls::getrusage 77 (:signed-fullword :address) :signed-fullword) +(define-syscall (logior platform-cpu-ppc platform-os-linux) syscalls::gettimeofday 78 (:address :address) :void) +(define-syscall (logior platform-cpu-ppc platform-os-linux) syscalls::ftruncate 93 (:unsigned-fullword :unsigned-fullword) + :signed-fullword) +(define-syscall (logior platform-cpu-ppc platform-os-linux) syscalls::fchmod 94 (:unsigned-fullword :unsigned-fullword) + :signed-fullword ) +(define-syscall (logior platform-cpu-ppc platform-os-linux) syscalls::socketcall 102 (:unsigned-fullword :address) :signed-fullword ) +(define-syscall (logior platform-cpu-ppc platform-os-linux) syscalls::stat 106 (:address :address) :signed-fullword) +(define-syscall (logior platform-cpu-ppc platform-os-linux) syscalls::lstat 107 (:address :address) :signed-fullword) +(define-syscall (logior platform-cpu-ppc platform-os-linux) syscalls::fstat 108 (:unsigned-fullword :address) :signed-fullword ) + +(define-syscall (logior platform-cpu-ppc platform-os-linux) syscalls::fsync 118 (:unsigned-fullword) :signed-fullword ) +(define-syscall (logior platform-cpu-ppc platform-os-linux) syscalls::uname 122 (:address) :signed-fullword) +(define-syscall (logior platform-cpu-ppc platform-os-linux) syscalls::fchdir 133 (:unsigned-fullword) :signed-fullword ) +(define-syscall (logior platform-cpu-ppc platform-os-linux) syscalls::_llseek 140 (:unsigned-fullword :unsigned-fullword :unsigned-fullword :address :unsigned-fullword) :signed-fullword ) +(define-syscall (logior platform-cpu-ppc platform-os-linux) syscalls::select 142 (:unsigned-fullword :address :address + :address :address) + :signed-fullword) +(define-syscall (logior platform-cpu-ppc platform-os-linux) syscalls::getcwd 182 (:address :unsigned-fullword) :signed-fullword ) + +(define-syscall (logior platform-cpu-ppc platform-os-linux) syscalls::poll 167 ((:* (:struct :pollfd)) :int :int) :int) + +#+notdefinedyet +(progn +(define-syscall (logior platform-cpu-ppc platform-os-linux) syscalls::sgetmask 68 () ) +(define-syscall (logior platform-cpu-ppc platform-os-linux) syscalls::ssetmask 69 () ) +(define-syscall (logior platform-cpu-ppc platform-os-linux) syscalls::setreuid 70 () ) +(define-syscall (logior platform-cpu-ppc platform-os-linux) syscalls::setregid 71 () ) +(define-syscall (logior platform-cpu-ppc platform-os-linux) syscalls::sigsuspend 72 () ) +(define-syscall (logior platform-cpu-ppc platform-os-linux) syscalls::sigpending 73 () ) +(define-syscall (logior platform-cpu-ppc platform-os-linux) syscalls::sethostname 74 () ) +(define-syscall (logior platform-cpu-ppc platform-os-linux) syscalls::setrlimit 75 () ) +(define-syscall (logior platform-cpu-ppc platform-os-linux) syscalls::getrlimit 76 () ) +(define-syscall (logior platform-cpu-ppc platform-os-linux) syscalls::settimeofday 79 () ) +(define-syscall (logior platform-cpu-ppc platform-os-linux) syscalls::getgroups 80 () ) +(define-syscall (logior platform-cpu-ppc platform-os-linux) syscalls::setgroups 81 () ) +(define-syscall (logior platform-cpu-ppc platform-os-linux) syscalls::symlink 83 () ) +(define-syscall (logior platform-cpu-ppc platform-os-linux) syscalls::oldlstat 84 () ) +(define-syscall (logior platform-cpu-ppc platform-os-linux) syscalls::readlink 85 () ) +(define-syscall (logior platform-cpu-ppc platform-os-linux) syscalls::uselib 86 () ) +(define-syscall (logior platform-cpu-ppc platform-os-linux) syscalls::swapon 87 () ) +(define-syscall (logior platform-cpu-ppc platform-os-linux) syscalls::reboot 88 () ) +(define-syscall (logior platform-cpu-ppc platform-os-linux) syscalls::readdir 89 () ) +(define-syscall (logior platform-cpu-ppc platform-os-linux) syscalls::mmap 90 () ) +(define-syscall (logior platform-cpu-ppc platform-os-linux) syscalls::munmap 91 () ) +(define-syscall (logior platform-cpu-ppc platform-os-linux) syscalls::truncate 92 () ) + +(define-syscall (logior platform-cpu-ppc platform-os-linux) syscalls::fchown 95 () ) +(define-syscall (logior platform-cpu-ppc platform-os-linux) syscalls::getpriority 96 () ) +(define-syscall (logior platform-cpu-ppc platform-os-linux) syscalls::setpriority 97 () ) +(define-syscall (logior platform-cpu-ppc platform-os-linux) syscalls::statfs 99 () ) +(define-syscall (logior platform-cpu-ppc platform-os-linux) syscalls::fstatfs 100 () ) +(define-syscall (logior platform-cpu-ppc platform-os-linux) syscalls::ioperm 101 () ) +(define-syscall (logior platform-cpu-ppc platform-os-linux) syscalls::syslog 103 () ) +(define-syscall (logior platform-cpu-ppc platform-os-linux) syscalls::setitimer 104 () ) +(define-syscall (logior platform-cpu-ppc platform-os-linux) syscalls::getitimer 105 () ) +(define-syscall (logior platform-cpu-ppc platform-os-linux) syscalls::olduname 109 () ) +(define-syscall (logior platform-cpu-ppc platform-os-linux) syscalls::iopl 110 () ) +(define-syscall (logior platform-cpu-ppc platform-os-linux) syscalls::vhangup 111 () ) +(define-syscall (logior platform-cpu-ppc platform-os-linux) syscalls::idle 112 () ) +(define-syscall (logior platform-cpu-ppc platform-os-linux) syscalls::vm86 113 () ) +(define-syscall (logior platform-cpu-ppc platform-os-linux) syscalls::wait4 114 () ) +(define-syscall (logior platform-cpu-ppc platform-os-linux) syscalls::swapoff 115 () ) +(define-syscall (logior platform-cpu-ppc platform-os-linux) syscalls::sysinfo 116 () ) +(define-syscall (logior platform-cpu-ppc platform-os-linux) syscalls::ipc 117 () ) +(define-syscall (logior platform-cpu-ppc platform-os-linux) syscalls::sigreturn 119 () ) +(define-syscall (logior platform-cpu-ppc platform-os-linux) syscalls::clone 120 () ) +(define-syscall (logior platform-cpu-ppc platform-os-linux) syscalls::setdomainname 121 () ) +(define-syscall (logior platform-cpu-ppc platform-os-linux) syscalls::modify_ldt 123 () ) +(define-syscall (logior platform-cpu-ppc platform-os-linux) syscalls::adjtimex 124 () ) +(define-syscall (logior platform-cpu-ppc platform-os-linux) syscalls::mprotect 125 () ) +(define-syscall (logior platform-cpu-ppc platform-os-linux) syscalls::sigprocmask 126 () ) +(define-syscall (logior platform-cpu-ppc platform-os-linux) syscalls::create_module 127 () ) +(define-syscall (logior platform-cpu-ppc platform-os-linux) syscalls::init_module 128 () ) +(define-syscall (logior platform-cpu-ppc platform-os-linux) syscalls::delete_module 129 () ) +(define-syscall (logior platform-cpu-ppc platform-os-linux) syscalls::get_kernel_syms 130 () ) +(define-syscall (logior platform-cpu-ppc platform-os-linux) syscalls::quotactl 131 () ) +(define-syscall (logior platform-cpu-ppc platform-os-linux) syscalls::getpgid 132 () ) +(define-syscall (logior platform-cpu-ppc platform-os-linux) syscalls::bdflush 134 () ) +(define-syscall (logior platform-cpu-ppc platform-os-linux) syscalls::sysfs 135 () ) +(define-syscall (logior platform-cpu-ppc platform-os-linux) syscalls::personality 136 () ) +(define-syscall (logior platform-cpu-ppc platform-os-linux) syscalls::setfsuid 138 () ) +(define-syscall (logior platform-cpu-ppc platform-os-linux) syscalls::setfsgid 139 () ) +(define-syscall (logior platform-cpu-ppc platform-os-linux) syscalls::getdents 141 () ) +(define-syscall (logior platform-cpu-ppc platform-os-linux) syscalls::_newselect 142 () ) +(define-syscall (logior platform-cpu-ppc platform-os-linux) syscalls::flock 143 () ) +(define-syscall (logior platform-cpu-ppc platform-os-linux) syscalls::msync 144 () ) +(define-syscall (logior platform-cpu-ppc platform-os-linux) syscalls::readv 145 () ) +(define-syscall (logior platform-cpu-ppc platform-os-linux) syscalls::writev 146 () ) +(define-syscall (logior platform-cpu-ppc platform-os-linux) syscalls::getsid 147 () ) +(define-syscall (logior platform-cpu-ppc platform-os-linux) syscalls::fdatasync 148 () ) +(define-syscall (logior platform-cpu-ppc platform-os-linux) syscalls::_sysctl 149 () ) +(define-syscall (logior platform-cpu-ppc platform-os-linux) syscalls::mlock 150 () ) +(define-syscall (logior platform-cpu-ppc platform-os-linux) syscalls::munlock 151 () ) +(define-syscall (logior platform-cpu-ppc platform-os-linux) syscalls::mlockall 152 () ) +(define-syscall (logior platform-cpu-ppc platform-os-linux) syscalls::munlockall 153 () ) +(define-syscall (logior platform-cpu-ppc platform-os-linux) syscalls::sched_setparam 154 () ) +(define-syscall (logior platform-cpu-ppc platform-os-linux) syscalls::sched_getparam 155 () ) +(define-syscall (logior platform-cpu-ppc platform-os-linux) syscalls::sched_setscheduler 156 () ) +(define-syscall (logior platform-cpu-ppc platform-os-linux) syscalls::sched_getscheduler 157 () ) +(define-syscall (logior platform-cpu-ppc platform-os-linux) syscalls::sched_yield 158 () ) +(define-syscall (logior platform-cpu-ppc platform-os-linux) syscalls::sched_get_priority_max 159 () ) +(define-syscall (logior platform-cpu-ppc platform-os-linux) syscalls::sched_get_priority_min 160 () ) +(define-syscall (logior platform-cpu-ppc platform-os-linux) syscalls::sched_rr_get_interval 161 () ) +(define-syscall (logior platform-cpu-ppc platform-os-linux) syscalls::nanosleep 162 () ) +(define-syscall (logior platform-cpu-ppc platform-os-linux) syscalls::mremap 163 () ) +(define-syscall (logior platform-cpu-ppc platform-os-linux) syscalls::setresuid 164 () ) +(define-syscall (logior platform-cpu-ppc platform-os-linux) syscalls::getresuid 165 () ) +(define-syscall (logior platform-cpu-ppc platform-os-linux) syscalls::query_module 166 () ) +(define-syscall (logior platform-cpu-ppc platform-os-linux) syscalls::poll 167 () ) +(define-syscall (logior platform-cpu-ppc platform-os-linux) syscalls::nfsservctl 168 () ) +(define-syscall (logior platform-cpu-ppc platform-os-linux) syscalls::setresgid 169 () ) +(define-syscall (logior platform-cpu-ppc platform-os-linux) syscalls::getresgid 170 () ) +(define-syscall (logior platform-cpu-ppc platform-os-linux) syscalls::prctl 171 () ) +(define-syscall (logior platform-cpu-ppc platform-os-linux) syscalls::rt_sigreturn 172 () ) +(define-syscall (logior platform-cpu-ppc platform-os-linux) syscalls::rt_sigaction 173 () ) +(define-syscall (logior platform-cpu-ppc platform-os-linux) syscalls::rt_sigprocmask 174 () ) +(define-syscall (logior platform-cpu-ppc platform-os-linux) syscalls::rt_sigpending 175 () ) +(define-syscall (logior platform-cpu-ppc platform-os-linux) syscalls::rt_sigtimedwait 176 () ) +(define-syscall (logior platform-cpu-ppc platform-os-linux) syscalls::rt_sigqueueinfo 177 () ) +(define-syscall (logior platform-cpu-ppc platform-os-linux) syscalls::rt_sigsuspend 178 () ) +(define-syscall (logior platform-cpu-ppc platform-os-linux) syscalls::pread 179 () ) +(define-syscall (logior platform-cpu-ppc platform-os-linux) syscalls::pwrite 180 () ) +(define-syscall (logior platform-cpu-ppc platform-os-linux) syscalls::chown 181 (:address) ) + +(define-syscall (logior platform-cpu-ppc platform-os-linux) syscalls::capget 183 () ) +(define-syscall (logior platform-cpu-ppc platform-os-linux) syscalls::capset 184 () ) +(define-syscall (logior platform-cpu-ppc platform-os-linux) syscalls::sigaltstack 185 () ) +(define-syscall (logior platform-cpu-ppc platform-os-linux) syscalls::sendfile 186 () ) +(define-syscall (logior platform-cpu-ppc platform-os-linux) syscalls::getpmsg 187 () ) +(define-syscall (logior platform-cpu-ppc platform-os-linux) syscalls::putpmsg 188 () ) +(define-syscall (logior platform-cpu-ppc platform-os-linux) syscalls::vfork 189 () ) + +) Index: /branches/new-random/library/pty.lisp =================================================================== --- /branches/new-random/library/pty.lisp (revision 13309) +++ /branches/new-random/library/pty.lisp (revision 13309) @@ -0,0 +1,143 @@ +;;;-*-Mode: LISP; Package: CCL -*- +;;; +;;; Copyright (C) 2002-2009 Clozure Associates. +;;; This file is part of Clozure CL. +;;; +;;; Clozure CL is licensed under the terms of the Lisp Lesser GNU Public +;;; License , known as the LLGPL and distributed with Clozure CL as the +;;; file "LICENSE". The LLGPL consists of a preamble and the LGPL, +;;; which is distributed with Clozure CL as the file "LGPL". Where these +;;; conflict, the preamble takes precedence. +;;; +;;; Clozure CL is referenced in the preamble as the "LIBRARY." +;;; +;;; The LLGPL is also available online at +;;; http://opensource.franz.com/preamble.html + +;;; (very) preliminary support for dealing with TTYs (and PTYs). + +(in-package "CCL") + +;;; Open a (connected) pair of pty file descriptors, such that anything +;;; written to one can be read from the other. +#+linuxppc-target +(eval-when (:load-toplevel :execute) + (open-shared-library "libutil.so")) + +(defun open-pty-pair () + (rlet ((alphap :unsigned 0) + (betap :unsigned 0)) + (let* ((status (#_openpty alphap betap (%null-ptr) (%null-ptr) (%null-ptr)))) + (if (eql status 0) + (values (pref alphap :unsigned) (pref betap :unsigned)) + (%errno-disp (%get-errno)))))) + + +(defun %get-tty-attributes (tty-fd &optional control-chars) + (if (and control-chars + (not (and (typep control-chars 'simple-string) + (= (length control-chars) #$NCCS)))) + (report-bad-arg control-chars '(or null (simple-string #.#$NCCS)))) + (rlet ((attr :termios)) + (let* ((result (#_tcgetattr tty-fd attr))) + (if (< result 0) + (values nil nil nil nil nil nil nil) + (progn + (if control-chars + (%str-from-ptr (pref attr :termios.c_cc) #$NCCS control-chars)) + (values + (pref attr :termios.c_iflag) + (pref attr :termios.c_oflag) + (pref attr :termios.c_cflag) + (pref attr :termios.c_lflag) + #+darwin-target 0 + #-darwin-target + (pref attr :termios.c_line) + control-chars + (pref attr :termios.c_ispeed) + (pref attr :termios.c_ospeed))))))) + +(defun %set-tty-attributes (tty &key + input-modes + output-modes + control-modes + local-modes + control-chars + input-speed + output-speed) + (if (and control-chars + (not (and (typep control-chars 'simple-string) + (= (length control-chars) #$NCCS)))) + (report-bad-arg control-chars '(or null (simple-string #.#$NCCS)))) + (rlet ((attr :termios)) + (let* ((get-ok (#_tcgetattr tty attr)) + (write-back nil)) + (when (eql 0 get-ok) + (when input-modes + (setf (pref attr :termios.c_iflag) input-modes) + (setq write-back t)) + (when output-modes + (setf (pref attr :termios.c_oflag) output-modes) + (setq write-back t)) + (when control-modes + (setf (pref attr :termios.c_cflag) control-modes) + (setq write-back t)) + (when local-modes + (setf (pref attr :termios.c_lflag) local-modes) + (setq write-back t)) + (when control-chars + (%cstr-pointer control-chars (pref attr :termios.c_cc) nil) + (setq write-back t)) + (when input-speed + (setf (pref attr :termios.c_ispeed) input-speed) + (setq write-back t)) + (when output-speed + (setf (pref attr :termios.c_ospeed) output-speed) + (setq write-back t)) + (and write-back + (eql 0 (#_tcsetattr tty #$TCSAFLUSH attr))))))) + +(defun enable-tty-input-modes (tty mask) + (let* ((old (nth-value 0 (%get-tty-attributes tty)))) + (when old + (%set-tty-attributes tty :input-modes (logior old mask))))) + +(defun disable-tty-input-modes (tty mask) + (let* ((old (nth-value 0 (%get-tty-attributes tty)))) + (when old + (%set-tty-attributes tty :input-modes (logand old (lognot mask)))))) + +(defun enable-tty-output-modes (tty mask) + (let* ((old (nth-value 1 (%get-tty-attributes tty)))) + (when old + (%set-tty-attributes tty :output-modes (logior old mask))))) + +(defun disable-tty-output-modes (tty mask) + (let* ((old (nth-value 1 (%get-tty-attributes tty)))) + (when old + (%set-tty-attributes tty :output-modes (logand old (lognot mask)))))) + +(defun enable-tty-control-modes (tty mask) + (let* ((old (nth-value 2 (%get-tty-attributes tty)))) + (when old + (%set-tty-attributes tty :control-modes (logior old mask))))) + +(defun disable-tty-control-modes (tty mask) + (let* ((old (nth-value 2 (%get-tty-attributes tty)))) + (when old + (%set-tty-attributes tty :control-modes (logand old (lognot mask)))))) + +(defun enable-tty-local-modes (tty mask) + (let* ((old (nth-value 3 (%get-tty-attributes tty)))) + (when old + (%set-tty-attributes tty :local-modes (logior old mask))))) + +(defun disable-tty-local-modes (tty mask) + (let* ((old (nth-value 3 (%get-tty-attributes tty)))) + (when old + (%set-tty-attributes tty :local-modes (logand old (lognot mask)))))) + +(defun set-tty-raw (tty) + (rlet ((attr :termios)) + (#_cfmakeraw attr) + (eql 0 (#_tcsetattr tty #$TCSAFLUSH attr)))) Index: /branches/new-random/library/sequence-utils.lisp =================================================================== --- /branches/new-random/library/sequence-utils.lisp (revision 13309) +++ /branches/new-random/library/sequence-utils.lisp (revision 13309) @@ -0,0 +1,92 @@ +;;;; -*- Mode: Lisp; Syntax: ANSI-Common-Lisp; Base: 10; Package: cl-user -*- +;;;; *********************************************************************** +;;;; FILE IDENTIFICATION +;;;; +;;;; Name: sequence-utils.lisp +;;;; Version: 0.2 +;;;; Project: utilities +;;;; Purpose: utilities for working with sequences +;;;; +;;;; *********************************************************************** + +(in-package "CCL") + +;;; ----------------------------------------------------------------- +;;; splitting sequences +;;; ----------------------------------------------------------------- + +;;; Split a sequence SEQ at each point where TEST is true +;;; DIR should be one of :BEFORE, :AFTER or :ELIDE + +(defun split-if (test seq &optional (dir :before)) + (remove-if + #'(lambda (x) (equal x (subseq seq 0 0))) + (loop for start fixnum = 0 + then (if (eq dir :before) stop (the fixnum (1+ (the fixnum stop)))) + while (< start (length seq)) + for stop = (position-if + test seq + :start (if (eq dir :elide) start (the fixnum (1+ start)))) + collect (subseq + seq start + (if (and stop (eq dir :after)) + (the fixnum (1+ (the fixnum stop))) + stop)) + while stop))) + +(defun split-if-char (char seq &optional dir) + (split-if #'(lambda (ch) (eq ch char)) seq dir)) + +(defmethod split-lines ((text string)) + (delete-if (lambda (x) (string= x "")) + (mapcar (lambda (s) + (string-trim '(#\return #\newline) s)) + (split-if (lambda (c) (member c '(#\return #\newline) :test #'char=)) + text)))) + +;;; ----------------------------------------------------------------- +;;; matching subsequences +;;; ----------------------------------------------------------------- + +(defun match-subsequence (subseq seq &key (test #'eql) (start 0)) + (let ((max-index (1- (length seq)))) + (block matching + ;; search for mismatches + (dotimes (i (length subseq)) + (let ((pos (+ start i))) + (when (or (> pos max-index) + (not (funcall test (elt seq pos) + (elt subseq i)))) + (return-from matching nil)))) + ;; no mismatches found; return true + (return-from matching t)))) + +(defun %find-matching-subsequence-backward (subseq seq &key (test #'eql) (start 0) end) + (let ((end (or end (length seq))) + (pos end) + (min-index (or start 0))) + (block finding + (dotimes (i (- (length seq) start)) + (setf pos (- end i)) + (if (<= pos min-index) + (return-from finding nil) + (when (match-subsequence subseq seq :test test :start pos) + (return-from finding pos)))) + nil))) + +(defun %find-matching-subsequence-forward (subseq seq &key (test #'eql) (start 0) end) + (let ((pos start) + (max-index (or end (length seq)))) + (block finding + (dotimes (i (- (length seq) start)) + (setf pos (+ start i)) + (if (>= pos max-index) + (return-from finding nil) + (when (match-subsequence subseq seq :test test :start pos) + (return-from finding pos)))) + nil))) + +(defun find-matching-subsequence (subseq seq &key (test #'eql) (start 0) end from-end) + (if from-end + (%find-matching-subsequence-backward subseq seq :test test :start start :end end) + (%find-matching-subsequence-forward subseq seq :test test :start start :end end))) Index: /branches/new-random/library/sharp-comma.lisp =================================================================== --- /branches/new-random/library/sharp-comma.lisp (revision 13309) +++ /branches/new-random/library/sharp-comma.lisp (revision 13309) @@ -0,0 +1,32 @@ +;;;-*- Mode: Lisp; Package: CCL -*- +;;; +;;; Copyright (C) 1994-2001 Digitool, Inc. +;;; This file is part of Clozure CL. +;;; +;;; Clozure CL is licensed under the terms of the Lisp Lesser GNU Public +;;; License , known as the LLGPL and distributed with Clozure CL as the +;;; file "LICENSE". The LLGPL consists of a preamble and the LGPL, +;;; which is distributed with Clozure CL as the file "LGPL". Where these +;;; conflict, the preamble takes precedence. +;;; +;;; Clozure CL is referenced in the preamble as the "LIBRARY." +;;; +;;; The LLGPL is also available online at +;;; http://opensource.franz.com/preamble.html + + +(in-package "CCL") + +;;; #, was removed from CL in 1998 or so, but there may be some legacy +;;; code that still uses it. + +(set-dispatch-macro-character + #\# + #\, + #'(lambda (stream subchar numarg) + (let* ((sharp-comma-token *reading-for-cfasl*)) + (if (or *read-suppress* (not *compiling-file*) (not sharp-comma-token)) + (read-eval stream subchar numarg) + (progn + (require-no-numarg subchar numarg) + (list sharp-comma-token (read stream t nil t))))))) Index: /branches/new-random/library/splay-tree.lisp =================================================================== --- /branches/new-random/library/splay-tree.lisp (revision 13309) +++ /branches/new-random/library/splay-tree.lisp (revision 13309) @@ -0,0 +1,208 @@ +;;;-*-Mode: LISP; Package: CCL -*- +;;; +;;; Copyright (C) 2003-2009 Clozure Associates +;;; This file is part of Clozure CL. +;;; +;;; Clozure CL is licensed under the terms of the Lisp Lesser GNU Public +;;; License , known as the LLGPL and distributed with Clozure CL as the +;;; file "LICENSE". The LLGPL consists of a preamble and the LGPL, +;;; which is distributed with Clozure CL as the file "LGPL". Where these +;;; conflict, the preamble takes precedence. +;;; +;;; Clozure CL is referenced in the preamble as the "LIBRARY." +;;; +;;; The LLGPL is also available online at +;;; http://opensource.franz.com/preamble.html + +(in-package "CCL") + + +;;; A (partial) implementation of SPLAY-TREEs, which are binary trees +;;; that reorganize themselves so that the most recently accessed keys +;;; cluster near the tree's root. + +(defstruct (tree-node + (:constructor make-tree-node (key value))) + key + value + left ; the child < this key, or NIL + right ; the child > this key, or NIL + parent ; we're the root if NIL. + ) + +(defmethod print-object ((node tree-node) stream) + (print-unreadable-object (node stream :type t :identity t) + (let* ((*print-circle* t)) + (format stream "~s -> ~s" (tree-node-key node) (tree-node-value node))))) + + +(defun tree-node-is-leaf (n) + (and (null (tree-node-left n)) + (null (tree-node-right n)))) + +(defun tree-node-is-root (n) + (null (tree-node-parent n))) + +;;; Is node the left child of its parent ? +(defun tree-node-is-left (n) + (let* ((parent (tree-node-parent n))) + (and parent (eq n (tree-node-left parent))))) + +(defun tree-node-is-right (n) + (let* ((parent (tree-node-parent n))) + (and parent (eq n (tree-node-right parent))))) + +(defun tree-node-set-right (node newright) + (when (setf (tree-node-right node) newright) + (setf (tree-node-parent newright) node))) + +(defun tree-node-set-left (node newleft) + (when (setf (tree-node-left node) newleft) + (setf (tree-node-parent newleft) node))) + +(defun tree-node-replace-child (node old new) + (if (eq old (tree-node-left node)) + (tree-node-set-left node new) + (tree-node-set-right node new))) + +(defstruct (splay-tree (:constructor %make-splay-tree)) + (root nil #|:type (or null splay-tree-node)|#) + equal ; true if x = y + less ; true if x < y + (count 0) + ) + +(defmethod print-object ((tree splay-tree) stream) + (print-unreadable-object (tree stream :type t :identity t) + (format stream "count = ~d, root = ~s" + (splay-tree-count tree) + (splay-tree-root tree)))) + + + +;;; Returns tree-node or NIL +(defun binary-tree-get (tree key) + (do* ((equal (splay-tree-equal tree)) + (less (splay-tree-less tree)) + (node (splay-tree-root tree))) + ((null node)) + (let* ((node-key (tree-node-key node))) + (if (funcall equal key node-key) + (return node) + (if (funcall less key node-key) + (setq node (tree-node-left node)) + (setq node (tree-node-right node))))))) + +;;; No node with matching key exists in the tree +(defun binary-tree-insert (tree node) + (let* ((root (splay-tree-root tree))) + (if (null root) + (setf (splay-tree-root tree) node) + (do* ((less (splay-tree-less tree)) + (key (tree-node-key node)) + (current root) + (parent nil)) + ((null current) + (if (funcall less key (tree-node-key parent)) + (tree-node-set-left parent node) + (tree-node-set-right parent node))) + (setq parent current) + (if (funcall less key (tree-node-key current)) + (setq current (tree-node-left current)) + (setq current (tree-node-right current)))))) + (incf (splay-tree-count tree))) + + +;;; Replace the node's parent with the node itself, updating the +;;; affected children so that the binary tree remains properly +;;; ordered. +(defun binary-tree-rotate (tree node) + (when (and node (not (tree-node-is-root node))) + (let* ((parent (tree-node-parent node)) + (grandparent (if parent (tree-node-parent parent))) + (was-left (tree-node-is-left node))) + (if grandparent + (tree-node-replace-child grandparent parent node) + (setf (splay-tree-root tree) node + (tree-node-parent node) nil)) + (if was-left + (progn + (tree-node-set-left parent (tree-node-right node)) + (tree-node-set-right node parent)) + (progn + (tree-node-set-right parent (tree-node-left node)) + (tree-node-set-left node parent)))))) + +;;; Keep rotating the node (and maybe its parent) until the node's the +;;; root of tree. +(defun splay-tree-splay (tree node) + (when node + (do* () + ((tree-node-is-root node)) + (let* ((parent (tree-node-parent node)) + (grandparent (tree-node-parent parent))) + (cond ((null grandparent) + (binary-tree-rotate tree node)) ; node is now root + ((eq (tree-node-is-left node) + (tree-node-is-left parent)) + (binary-tree-rotate tree parent) + (binary-tree-rotate tree node)) + (t + (binary-tree-rotate tree node) + (binary-tree-rotate tree node))))))) + + + +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; +;;; +;;; The more-or-less public API follows. +;;; +;;; I suppose that we should support DELETE as well, and perhaps +;;; UPDATE (find the node and modify its key in place.) For now, +;;; SPLAY-TREE-PUT assumes that no node with a matching key exists. +;;; Access to the tree has to be serialized by the caller. + +(defun splay-tree-get (tree key &optional default) + (let* ((node (binary-tree-get tree key))) + (if node + (progn + (splay-tree-splay tree node) + (tree-node-value node)) + default))) + +(defun splay-tree-put (tree key value) + (let* ((node (make-tree-node key value))) + (binary-tree-insert tree node) + (splay-tree-splay tree node) + value)) + +;;; Note that the tree wants two comparison functions. This may +;;; increase the chance that builtin CL functions can be used; a tree +;;; whose keys are real numbers could use #'= and #'<, for instance. +;;; Using two comparison functions is (at best) only slightly better +;;; than insisting that a single comparison function return (values +;;; equal less), or (member -1 0 1), or some other convention. + +(defun make-splay-tree (equal less) + (check-type equal function) + (check-type less function) + (%make-splay-tree :equal equal :less less)) + +;;; Do an inorder traversal of the splay tree, applying function F +;;; to the value of each node. + +(defun map-splay-tree (tree f) + (labels ((map-tree-node (node) + (when node + (map-tree-node (tree-node-left node)) + (funcall f (tree-node-value node)) + (map-tree-node (tree-node-right node))))) + (map-tree-node (splay-tree-root tree)))) + +(defun map-splay-tree-keys-and-values (tree f) + (labels ((map-tree-node (node) + (when node + (map-tree-node (tree-node-left node)) + (funcall f (tree-node-key node) (tree-node-value node)) + (map-tree-node (tree-node-right node))))) + (map-tree-node (splay-tree-root tree)))) Index: /branches/new-random/library/syscall.lisp =================================================================== --- /branches/new-random/library/syscall.lisp (revision 13309) +++ /branches/new-random/library/syscall.lisp (revision 13309) @@ -0,0 +1,68 @@ +;;;-*-Mode: LISP; Package: CCL -*- +;;; +;;; Copyright (C) 2001-2009 Clozure Associates +;;; This file is part of Clozure CL. +;;; +;;; Clozure CL is licensed under the terms of the Lisp Lesser GNU Public +;;; License , known as the LLGPL and distributed with Clozure CL as the +;;; file "LICENSE". The LLGPL consists of a preamble and the LGPL, +;;; which is distributed with Clozure CL as the file "LGPL". Where these +;;; conflict, the preamble takes precedence. +;;; +;;; Clozure CL is referenced in the preamble as the "LIBRARY." +;;; +;;; The LLGPL is also available online at +;;; http://opensource.franz.com/preamble.html + +;;; "Generic" syscall sypport. + +(in-package "CCL") + +(defpackage "SYSCALLS" (:use)) + +(defstruct syscall + (idx 0 :type fixnum) + (arg-specs () :type list) + (result-spec nil :type symbol) + (min-args 0 :type fixnum)) + +(defvar *os-syscall-definitions* ()) + +(defun platform-syscall-definitions (platform-os) + (or (getf *os-syscall-definitions* platform-os) + (setf (getf *os-syscall-definitions* platform-os) + (make-hash-table :test 'eq)))) + +(defun backend-syscall-definitions (backend) + (platform-syscall-definitions (backend-platform-syscall-mask backend))) + + + +(defmacro define-syscall (platform name idx (&rest arg-specs) result-spec + &key (min-args (length arg-specs))) + `(progn + (setf (gethash ',name (platform-syscall-definitions ,platform)) + (make-syscall :idx ,idx + :arg-specs ',arg-specs + :result-spec ',result-spec + :min-args ,min-args)) + ',name)) + +(defmacro syscall (name &rest args) + (let* ((info (or (gethash name (backend-syscall-definitions *target-backend*)) + (error "Unknown system call: ~s" name))) + (idx (syscall-idx info)) + (arg-specs (syscall-arg-specs info)) + (n-argspecs (length arg-specs)) + (n-args (length args)) + (min-args (syscall-min-args info)) + (result (syscall-result-spec info))) + (unless (and (>= n-args min-args) (<= n-args n-argspecs)) + (error "wrong number of args in ~s" args)) + (do* ((call ()) + (specs arg-specs (cdr specs)) + (args args (cdr args))) + ((null args) + `(%syscall ,idx ,@(nreverse (cons result call)))) + (push (car specs) call) + (push (car args) call)))) Index: /branches/new-random/library/x86-win64-syscalls.lisp =================================================================== --- /branches/new-random/library/x86-win64-syscalls.lisp (revision 13309) +++ /branches/new-random/library/x86-win64-syscalls.lisp (revision 13309) @@ -0,0 +1,281 @@ +;;;-*-Mode: LISP; Package: CCL -*- +;;; +;;; Copyright (C) 2008-2009 Clozure Associates +;;; This file is part of Clozure CL. +;;; +;;; Clozure CL is licensed under the terms of the Lisp Lesser GNU Public +;;; License , known as the LLGPL and distributed with Clozure CL as the +;;; file "LICENSE". The LLGPL consists of a preamble and the LGPL, +;;; which is distributed with Clozure CL as the file "LGPL". Where these +;;; conflict, the preamble takes precedence. +;;; +;;; Clozure CL is referenced in the preamble as the "LIBRARY." +;;; +;;; The LLGPL is also available online at +;;; http://opensource.franz.com/preamble.html + +(in-package "CCL") + +(eval-when (:compile-toplevel :load-toplevel :execute) + (require "SYSCALL")) + + +(define-syscall (logior platform-os-windows platform-cpu-x86 platform-word-size-64) syscalls::open 0 (:address :unsigned-fullword :unsigned-fullword) :signed-fullword :min-args 2) +(define-syscall (logior platform-os-windows platform-cpu-x86 platform-word-size-64) syscalls::close 1 (:unsigned-fullword) :signed-fullword ) +(define-syscall (logior platform-os-windows platform-cpu-x86 platform-word-size-64) syscalls::read 2 (:unsigned-fullword :address :unsigned-fullword) + :signed-fullword) +(define-syscall (logior platform-os-windows platform-cpu-x86 platform-word-size-64) syscalls::write 3 (:unsigned-fullword :address :unsigned-fullword) + :signed-fullword) +(define-syscall (logior platform-os-windows platform-cpu-x86 platform-word-size-64) syscalls::fchmod 4 (:unsigned-fullword :unsigned-fullword) + :signed-fullword ) +(define-syscall (logior platform-os-windows platform-cpu-x86 platform-word-size-64) syscalls::lseek 5 (:unsigned-fullword :signed-doubleword :unsigned-fullword) :signed-doubleword ) + +(define-syscall (logior platform-os-windows platform-cpu-x86 platform-word-size-64) syscalls::stat 6 (:address :address) :signed-fullword) +(define-syscall (logior platform-os-windows platform-cpu-x86 platform-word-size-64) syscalls::fstat 7 (:unsigned-fullword :address) :signed-fullword ) +(define-syscall (logior platform-os-windows platform-cpu-x86 platform-word-size-64) syscalls::ftruncate 8 (:unsigned-fullword :unsigned-doubleword) + :signed-fullword) + +(define-syscall (logior platform-os-windows platform-cpu-x86 platform-word-size-64) syscalls::opendir 9 (:address) :address) +(define-syscall (logior platform-os-windows platform-cpu-x86 platform-word-size-64) syscalls::readdir 10 (:address) :address) +(define-syscall (logior platform-os-windows platform-cpu-x86 platform-word-size-64) syscalls::closedir 11 (:address) + :signed-fullword) +(define-syscall (logior platform-os-windows platform-cpu-x86 platform-word-size-64) syscalls::pipe 12 (:address) :signed-fullword ) + +#+notdefinedyet +(progn + +(define-syscall (logior platform-os-windows platform-cpu-x86 platform-word-size-64) syscalls::lstat 190 (:address :address) :signed-fullword) + + + +(define-syscall (logior platform-os-windows platform-cpu-x86 platform-word-size-64) syscalls::exit 1 (:signed-fullword) :void) +(define-syscall (logior platform-os-windows platform-cpu-x86 platform-word-size-64) syscalls::fork 2 () :signed-fullword) + + + +#+notyet +(define-syscall (logior platform-os-windows platform-cpu-x86 platform-word-size-64) syscalls::creat 85 (:address :unsigned-fullword) :signed-fullword ) + +(define-syscall (logior platform-os-windows platform-cpu-x86 platform-word-size-64) syscalls::link 9 (:address :address) :signed-fullword) +(define-syscall (logior platform-os-windows platform-cpu-x86 platform-word-size-64) syscalls::unlink 10 (:address) :signed-fullword ) +(define-syscall (logior platform-os-windows platform-cpu-x86 platform-word-size-64) syscalls::execve 59 (:address :address :address) :signed-fullword ) +(define-syscall (logior platform-os-windows platform-cpu-x86 platform-word-size-64) syscalls::chdir 12 (:address) :signed-fullword ) + +#+notyet +(define-syscall (logior platform-os-windows platform-cpu-x86 platform-word-size-64) syscalls::time 201 (:address) :unsigned-fullword ) + +(define-syscall (logior platform-os-windows platform-cpu-x86 platform-word-size-64) syscalls::mknod 14 (:address :unsigned-fullword :unsigned-fullword) + :signed-fullword) +(define-syscall (logior platform-os-windows platform-cpu-x86 platform-word-size-64) syscalls::chmod 15 (:address :unsigned-fullword) :signed-fullword) +(define-syscall (logior platform-os-windows platform-cpu-x86 platform-word-size-64) syscalls::lchown 254 (:address :unsigned-fullword :unsigned-fullword) + :signed-fullword) + +(define-syscall (logior platform-os-windows platform-cpu-x86 platform-word-size-64) syscalls::getpid 20 () :unsigned-fullword) +(define-syscall (logior platform-os-windows platform-cpu-x86 platform-word-size-64) syscalls::mount 21 (:address :address :address :unsigned-fullword :address) :signed-fullword ) + +#+notyet +(define-syscall (logior platform-os-windows platform-cpu-x86 platform-word-size-64) syscalls::umount2 166 (:address) :signed-fullword ) + +(define-syscall (logior platform-os-windows platform-cpu-x86 platform-word-size-64) syscalls::setuid 23 (:unsigned-fullword) :signed-fullword ) +(define-syscall (logior platform-os-windows platform-cpu-x86 platform-word-size-64) syscalls::getuid 24 () :unsigned-fullword ) + +(define-syscall (logior platform-os-windows platform-cpu-x86 platform-word-size-64) syscalls::ptrace 26 (:unsigned-fullword + :unsigned-fullword + :address + :address) + :signed-fullword) + +#+notyet +(define-syscall (logior platform-os-windows platform-cpu-x86 platform-word-size-64) syscalls::alarm 37 (:unsigned-fullword) :unsigned-fullword ) + +#+notyet +(define-syscall (logior platform-os-windows platform-cpu-x86 platform-word-size-64) syscalls::pause 34 () :signed-fullword) + +#+notyet +(define-syscall (logior platform-os-windows platform-cpu-x86 platform-word-size-64) syscalls::utime 132 (:address :address) :signed-fullword ) +(define-syscall (logior platform-os-windows platform-cpu-x86 platform-word-size-64) syscalls::access 33 (:address :unsigned-fullword) :signed-fullword) + +(define-syscall (logior platform-os-windows platform-cpu-x86 platform-word-size-64) syscalls::sync 36 () :signed-fullword ) +(define-syscall (logior platform-os-windows platform-cpu-x86 platform-word-size-64) syscalls::kill 37 (:signed-fullword :unsigned-fullword) :signed-fullword ) +(define-syscall (logior platform-os-windows platform-cpu-x86 platform-word-size-64) syscalls::rename 128 (:address :address) :signed-fullword ) +(define-syscall (logior platform-os-windows platform-cpu-x86 platform-word-size-64) syscalls::mkdir 136 (:address :unsigned-fullword) :signed-fullword ) +(define-syscall (logior platform-os-windows platform-cpu-x86 platform-word-size-64) syscalls::rmdir 17 (:address) :signed-fullword ) +(define-syscall (logior platform-os-windows platform-cpu-x86 platform-word-size-64) syscalls::dup 41 (:unsigned-fullword) :signed-fullword ) +(define-syscall (logior platform-os-windows platform-cpu-x86 platform-word-size-64) syscalls::times 100 (:address) :unsigned-fullword ) + +#+notyet +(define-syscall (logior platform-os-windows platform-cpu-x86 platform-word-size-64) syscalls::brk 12 (:address) :signed-fullword ) +(define-syscall (logior platform-os-windows platform-cpu-x86 platform-word-size-64) syscalls::setgid 181 (:unsigned-fullword) :signed-fullword) +(define-syscall (logior platform-os-windows platform-cpu-x86 platform-word-size-64) syscalls::getgid 47 () :unsigned-fullword ) + +(define-syscall (logior platform-os-windows platform-cpu-x86 platform-word-size-64) syscalls::geteuid 25 () :unsigned-fullword ) +(define-syscall (logior platform-os-windows platform-cpu-x86 platform-word-size-64) syscalls::getegid 43 () :unsigned-fullword) +(define-syscall (logior platform-os-windows platform-cpu-x86 platform-word-size-64) syscalls::acct 51 (:address) :signed-fullword ) + +(define-syscall (logior platform-os-windows platform-cpu-x86 platform-word-size-64) syscalls::ioctl 54 (:unsigned-fullword :signed-fullword :address) :signed-fullword :min-args 2 ) +(define-syscall (logior platform-os-windows platform-cpu-x86 platform-word-size-64) syscalls::fcntl 92 (:unsigned-fullword :signed-fullword :signed-fullword) :signed-fullword :min-args 2 ) +(define-syscall (logior platform-os-windows platform-cpu-x86 platform-word-size-64) syscalls::setpgid 82 (:signed-fullword :signed-fullword) :signed-fullword ) +(define-syscall (logior platform-os-windows platform-cpu-x86 platform-word-size-64) syscalls::umask 60 (:unsigned-fullword) :unsigned-fullword ) +(define-syscall (logior platform-os-windows platform-cpu-x86 platform-word-size-64) syscalls::chroot 61 (:address) :signed-fullword ) + +#+notyet +(define-syscall (logior platform-os-windows platform-cpu-x86 platform-word-size-64) syscalls::ustat 136 (:unsigned-fullword :address) :signed-fullword ) + +(define-syscall (logior platform-os-windows platform-cpu-x86 platform-word-size-64) syscalls::dup2 90 (:unsigned-fullword :unsigned-fullword) :signed-fullword ) +(define-syscall (logior platform-os-windows platform-cpu-x86 platform-word-size-64) syscalls::getppid 39 () :unsigned-fullword) +(define-syscall (logior platform-os-windows platform-cpu-x86 platform-word-size-64) syscalls::getpgrp 81 () :unsigned-fullword) +(define-syscall (logior platform-os-windows platform-cpu-x86 platform-word-size-64) syscalls::setsid 147 () :signed-fullword) +(define-syscall (logior platform-os-windows platform-cpu-x86 platform-word-size-64) syscalls::sigaction 416 (:unsigned-fullword :address :address) :signed-fullword ) +(define-syscall (logior platform-os-windows platform-cpu-x86 platform-word-size-64) syscalls::getrusage 117 (:signed-fullword :address) :signed-fullword) +(define-syscall (logior platform-os-windows platform-cpu-x86 platform-word-size-64) syscalls::gettimeofday 116 (:address :address) :void) + + +(define-syscall (logior platform-os-windows platform-cpu-x86 platform-word-size-64) syscalls::fchmod 124 (:unsigned-fullword :unsigned-fullword) + :signed-fullword ) +(define-syscall (logior platform-os-windows platform-cpu-x86 platform-word-size-64) syscalls::socket 97 (:signed-fullword :signed-fullword :signed-fullword) + :signed-fullword ) +(define-syscall (logior platform-os-windows platform-cpu-x86 platform-word-size-64) syscalls::connect 98 (:signed-fullword :address :signed-fullword) + :signed-fullword ) +(define-syscall (logior platform-os-windows platform-cpu-x86 platform-word-size-64) syscalls::accept 30 (:signed-fullword :address :address) + :signed-fullword ) +(define-syscall (logior platform-os-windows platform-cpu-x86 platform-word-size-64) syscalls::sendto 133 (:unsigned-fullword :address :unsigned-fullword :unsigned-fullword :address :unsigned-fullword) + :signed-fullword ) +(define-syscall (logior platform-os-windows platform-cpu-x86 platform-word-size-64) syscalls::recvfrom 29 (:unsigned-fullword :address :unsigned-long :unsigned-fullword :address :address) :signed-fullword ) +(define-syscall (logior platform-os-windows platform-cpu-x86 platform-word-size-64) syscalls::sendmsg 28 (:unsigned-fullword :address :unsigned-fullword) :signed-fullword ) +(define-syscall (logior platform-os-windows platform-cpu-x86 platform-word-size-64) syscalls::recvmsg 27 (:unsigned-fullword :address :unsigned-fullword) :signed-fullword ) +(define-syscall (logior platform-os-windows platform-cpu-x86 platform-word-size-64) syscalls::shutdown 134 (:unsigned-fullword :unsigned-fullword) :signed-fullword ) +(define-syscall (logior platform-os-windows platform-cpu-x86 platform-word-size-64) syscalls::bind 104 (:signed-fullword :address :signed-fullword) + :signed-fullword ) +(define-syscall (logior platform-os-windows platform-cpu-x86 platform-word-size-64) syscalls::listen 106 (:signed-fullword :signed-fullword) + :signed-fullword ) +(define-syscall (logior platform-os-windows platform-cpu-x86 platform-word-size-64) syscalls::getpeername 31 (:signed-fullword :address :address) + :signed-fullword ) +(define-syscall (logior platform-os-windows platform-cpu-x86 platform-word-size-64) syscalls::getsockname 32 (:signed-fullword :address :address) + :signed-fullword ) +(define-syscall (logior platform-os-windows platform-cpu-x86 platform-word-size-64) syscalls::socketpair 135 (:signed-fullword :signed-fullword :signed-fullword :address) + :signed-fullword ) +(define-syscall (logior platform-os-windows platform-cpu-x86 platform-word-size-64) syscalls::setsockopt 105 (:unsigned-fullword :signed-fullword :signed-fullword :address :unsigned-fullword) :signed-fullword ) +(define-syscall (logior platform-os-windows platform-cpu-x86 platform-word-size-64) syscalls::getsockopt 118 (:unsigned-fullword :signed-fullword :unsigned-fullword :address :address) :signed-fullword ) + +(define-syscall (logior platform-os-windows platform-cpu-x86 platform-word-size-64) syscalls::fsync 95 (:unsigned-fullword) :signed-fullword ) +(define-syscall (logior platform-os-windows platform-cpu-x86 platform-word-size-64) syscalls::uname 164 (:address) :signed-fullword) +(define-syscall (logior platform-os-windows platform-cpu-x86 platform-word-size-64) syscalls::fchdir 13 (:unsigned-fullword) :signed-fullword ) + +(define-syscall (logior platform-os-windows platform-cpu-x86 platform-word-size-64) syscalls::select 93 (:unsigned-fullword :address :address + :address :address) + :signed-fullword) +(define-syscall (logior platform-os-windows platform-cpu-x86 platform-word-size-64) syscalls::getcwd 326 (:address :unsigned-fullword) :signed-fullword ) + +(define-syscall (logior platform-os-windows platform-cpu-x86 platform-word-size-64) syscalls::poll 209 ((:* (:struct :pollfd)) :int :int) :int) + +(define-syscall (logior platform-os-windows platform-cpu-x86 platform-word-size-64) syscalls::sgetmask 68 () ) +(define-syscall (logior platform-os-windows platform-cpu-x86 platform-word-size-64) syscalls::ssetmask 69 () ) +(define-syscall (logior platform-os-windows platform-cpu-x86 platform-word-size-64) syscalls::setreuid 70 () ) +(define-syscall (logior platform-os-windows platform-cpu-x86 platform-word-size-64) syscalls::setregid 71 () ) +(define-syscall (logior platform-os-windows platform-cpu-x86 platform-word-size-64) syscalls::sigsuspend 72 () ) +(define-syscall (logior platform-os-windows platform-cpu-x86 platform-word-size-64) syscalls::sigpending 73 () ) +(define-syscall (logior platform-os-windows platform-cpu-x86 platform-word-size-64) syscalls::sethostname 74 () ) +(define-syscall (logior platform-os-windows platform-cpu-x86 platform-word-size-64) syscalls::setrlimit 75 () ) +(define-syscall (logior platform-os-windows platform-cpu-x86 platform-word-size-64) syscalls::getrlimit 76 () ) +(define-syscall (logior platform-os-windows platform-cpu-x86 platform-word-size-64) syscalls::settimeofday 79 () ) +(define-syscall (logior platform-os-windows platform-cpu-x86 platform-word-size-64) syscalls::getgroups 80 () ) +(define-syscall (logior platform-os-windows platform-cpu-x86 platform-word-size-64) syscalls::setgroups 81 () ) +(define-syscall (logior platform-os-windows platform-cpu-x86 platform-word-size-64) syscalls::symlink 83 () ) +(define-syscall (logior platform-os-windows platform-cpu-x86 platform-word-size-64) syscalls::oldlstat 84 () ) +(define-syscall (logior platform-os-windows platform-cpu-x86 platform-word-size-64) syscalls::readlink 58 () ) +(define-syscall (logior platform-os-windows platform-cpu-x86 platform-word-size-64) syscalls::uselib 86 () ) +(define-syscall (logior platform-os-windows platform-cpu-x86 platform-word-size-64) syscalls::swapon 87 () ) +(define-syscall (logior platform-os-windows platform-cpu-x86 platform-word-size-64) syscalls::reboot 88 () ) +(define-syscall (logior platform-os-windows platform-cpu-x86 platform-word-size-64) syscalls::readdir 89 () ) +(define-syscall (logior platform-os-windows platform-cpu-x86 platform-word-size-64) syscalls::truncate 92 () ) + +(define-syscall (logior platform-os-windows platform-cpu-x86 platform-word-size-64) syscalls::fchown 95 () ) +(define-syscall (logior platform-os-windows platform-cpu-x86 platform-word-size-64) syscalls::getpriority 96 () ) +(define-syscall (logior platform-os-windows platform-cpu-x86 platform-word-size-64) syscalls::setpriority 97 () ) +(define-syscall (logior platform-os-windows platform-cpu-x86 platform-word-size-64) syscalls::statfs 99 () ) +(define-syscall (logior platform-os-windows platform-cpu-x86 platform-word-size-64) syscalls::fstatfs 100 () ) +(define-syscall (logior platform-os-windows platform-cpu-x86 platform-word-size-64) syscalls::ioperm 101 () ) +(define-syscall (logior platform-os-windows platform-cpu-x86 platform-word-size-64) syscalls::syslog 103 () ) +(define-syscall (logior platform-os-windows platform-cpu-x86 platform-word-size-64) syscalls::setitimer 38 () ) +(define-syscall (logior platform-os-windows platform-cpu-x86 platform-word-size-64) syscalls::getitimer 36 () ) +(define-syscall (logior platform-os-windows platform-cpu-x86 platform-word-size-64) syscalls::olduname 109 () ) +(define-syscall (logior platform-os-windows platform-cpu-x86 platform-word-size-64) syscalls::iopl 110 () ) +(define-syscall (logior platform-os-windows platform-cpu-x86 platform-word-size-64) syscalls::vhangup 111 () ) +(define-syscall (logior platform-os-windows platform-cpu-x86 platform-word-size-64) syscalls::idle 112 () ) +(define-syscall (logior platform-os-windows platform-cpu-x86 platform-word-size-64) syscalls::vm86 113 () ) +(define-syscall (logior platform-os-windows platform-cpu-x86 platform-word-size-64) syscalls::wait4 7 () ) +(define-syscall (logior platform-os-windows platform-cpu-x86 platform-word-size-64) syscalls::swapoff 115 () ) +(define-syscall (logior platform-os-windows platform-cpu-x86 platform-word-size-64) syscalls::sysinfo 116 () ) +(define-syscall (logior platform-os-windows platform-cpu-x86 platform-word-size-64) syscalls::ipc 117 () ) +(define-syscall (logior platform-os-windows platform-cpu-x86 platform-word-size-64) syscalls::sigreturn 119 () ) +(define-syscall (logior platform-os-windows platform-cpu-x86 platform-word-size-64) syscalls::clone 120 () ) +(define-syscall (logior platform-os-windows platform-cpu-x86 platform-word-size-64) syscalls::setdomainname 121 () ) +(define-syscall (logior platform-os-windows platform-cpu-x86 platform-word-size-64) syscalls::modify_ldt 123 () ) +(define-syscall (logior platform-os-windows platform-cpu-x86 platform-word-size-64) syscalls::adjtimex 124 () ) +(define-syscall (logior platform-os-windows platform-cpu-x86 platform-word-size-64) syscalls::mprotect 10 () ) +(define-syscall (logior platform-os-windows platform-cpu-x86 platform-word-size-64) syscalls::sigprocmask 126 () ) +(define-syscall (logior platform-os-windows platform-cpu-x86 platform-word-size-64) syscalls::create_module 127 () ) +(define-syscall (logior platform-os-windows platform-cpu-x86 platform-word-size-64) syscalls::init_module 128 () ) +(define-syscall (logior platform-os-windows platform-cpu-x86 platform-word-size-64) syscalls::delete_module 129 () ) +(define-syscall (logior platform-os-windows platform-cpu-x86 platform-word-size-64) syscalls::get_kernel_syms 130 () ) +(define-syscall (logior platform-os-windows platform-cpu-x86 platform-word-size-64) syscalls::quotactl 131 () ) +(define-syscall (logior platform-os-windows platform-cpu-x86 platform-word-size-64) syscalls::getpgid 132 () ) +(define-syscall (logior platform-os-windows platform-cpu-x86 platform-word-size-64) syscalls::bdflush 134 () ) +(define-syscall (logior platform-os-windows platform-cpu-x86 platform-word-size-64) syscalls::sysfs 135 () ) +(define-syscall (logior platform-os-windows platform-cpu-x86 platform-word-size-64) syscalls::personality 136 () ) +(define-syscall (logior platform-os-windows platform-cpu-x86 platform-word-size-64) syscalls::setfsuid 138 () ) +(define-syscall (logior platform-os-windows platform-cpu-x86 platform-word-size-64) syscalls::setfsgid 139 () ) +(define-syscall (logior platform-os-windows platform-cpu-x86 platform-word-size-64) syscalls::getdents 141 () ) +(define-syscall (logior platform-os-windows platform-cpu-x86 platform-word-size-64) syscalls::_newselect 142 () ) +(define-syscall (logior platform-os-windows platform-cpu-x86 platform-word-size-64) syscalls::flock 143 () ) +(define-syscall (logior platform-os-windows platform-cpu-x86 platform-word-size-64) syscalls::msync 26 () ) +(define-syscall (logior platform-os-windows platform-cpu-x86 platform-word-size-64) syscalls::readv 19 () ) +(define-syscall (logior platform-os-windows platform-cpu-x86 platform-word-size-64) syscalls::writev 20 () ) +(define-syscall (logior platform-os-windows platform-cpu-x86 platform-word-size-64) syscalls::getsid 147 () ) +(define-syscall (logior platform-os-windows platform-cpu-x86 platform-word-size-64) syscalls::fdatasync 148 () ) +(define-syscall (logior platform-os-windows platform-cpu-x86 platform-word-size-64) syscalls::_sysctl 149 () ) +(define-syscall (logior platform-os-windows platform-cpu-x86 platform-word-size-64) syscalls::mlock 150 () ) +(define-syscall (logior platform-os-windows platform-cpu-x86 platform-word-size-64) syscalls::munlock 151 () ) +(define-syscall (logior platform-os-windows platform-cpu-x86 platform-word-size-64) syscalls::mlockall 152 () ) +(define-syscall (logior platform-os-windows platform-cpu-x86 platform-word-size-64) syscalls::munlockall 153 () ) +(define-syscall (logior platform-os-windows platform-cpu-x86 platform-word-size-64) syscalls::sched_setparam 154 () ) +(define-syscall (logior platform-os-windows platform-cpu-x86 platform-word-size-64) syscalls::sched_getparam 155 () ) +(define-syscall (logior platform-os-windows platform-cpu-x86 platform-word-size-64) syscalls::sched_setscheduler 156 () ) +(define-syscall (logior platform-os-windows platform-cpu-x86 platform-word-size-64) syscalls::sched_getscheduler 157 () ) +(define-syscall (logior platform-os-windows platform-cpu-x86 platform-word-size-64) syscalls::sched_yield 24 () ) +(define-syscall (logior platform-os-windows platform-cpu-x86 platform-word-size-64) syscalls::sched_get_priority_max 159 () ) +(define-syscall (logior platform-os-windows platform-cpu-x86 platform-word-size-64) syscalls::sched_get_priority_min 160 () ) +(define-syscall (logior platform-os-windows platform-cpu-x86 platform-word-size-64) syscalls::sched_rr_get_interval 161 () ) +(define-syscall (logior platform-os-windows platform-cpu-x86 platform-word-size-64) syscalls::nanosleep 35 () ) +(define-syscall (logior platform-os-windows platform-cpu-x86 platform-word-size-64) syscalls::mremap 25 () ) +(define-syscall (logior platform-os-windows platform-cpu-x86 platform-word-size-64) syscalls::setresuid 164 () ) +(define-syscall (logior platform-os-windows platform-cpu-x86 platform-word-size-64) syscalls::getresuid 165 () ) +(define-syscall (logior platform-os-windows platform-cpu-x86 platform-word-size-64) syscalls::query_module 166 () ) + +(define-syscall (logior platform-os-windows platform-cpu-x86 platform-word-size-64) syscalls::nfsservctl 168 () ) +(define-syscall (logior platform-os-windows platform-cpu-x86 platform-word-size-64) syscalls::setresgid 169 () ) +(define-syscall (logior platform-os-windows platform-cpu-x86 platform-word-size-64) syscalls::getresgid 170 () ) +(define-syscall (logior platform-os-windows platform-cpu-x86 platform-word-size-64) syscalls::prctl 171 () ) +(define-syscall (logior platform-os-windows platform-cpu-x86 platform-word-size-64) syscalls::rt_sigreturn 15 () ) +(define-syscall (logior platform-os-windows platform-cpu-x86 platform-word-size-64) syscalls::rt_sigaction 13 () ) +(define-syscall (logior platform-os-windows platform-cpu-x86 platform-word-size-64) syscalls::rt_sigprocmask 14 () ) +(define-syscall (logior platform-os-windows platform-cpu-x86 platform-word-size-64) syscalls::rt_sigpending 175 () ) +(define-syscall (logior platform-os-windows platform-cpu-x86 platform-word-size-64) syscalls::rt_sigtimedwait 176 () ) +(define-syscall (logior platform-os-windows platform-cpu-x86 platform-word-size-64) syscalls::rt_sigqueueinfo 177 () ) +(define-syscall (logior platform-os-windows platform-cpu-x86 platform-word-size-64) syscalls::rt_sigsuspend 178 () ) +(define-syscall (logior platform-os-windows platform-cpu-x86 platform-word-size-64) syscalls::pread 17 () ) +(define-syscall (logior platform-os-windows platform-cpu-x86 platform-word-size-64) syscalls::pwrite 18 () ) +(define-syscall (logior platform-os-windows platform-cpu-x86 platform-word-size-64) syscalls::chown 181 (:address) ) + +(define-syscall (logior platform-os-windows platform-cpu-x86 platform-word-size-64) syscalls::capget 183 () ) +(define-syscall (logior platform-os-windows platform-cpu-x86 platform-word-size-64) syscalls::capset 184 () ) +(define-syscall (logior platform-os-windows platform-cpu-x86 platform-word-size-64) syscalls::sigaltstack 185 () ) +(define-syscall (logior platform-os-windows platform-cpu-x86 platform-word-size-64) syscalls::sendfile 40 () ) +(define-syscall (logior platform-os-windows platform-cpu-x86 platform-word-size-64) syscalls::getpmsg 187 () ) +(define-syscall (logior platform-os-windows platform-cpu-x86 platform-word-size-64) syscalls::putpmsg 188 () ) +(define-syscall (logior platform-os-windows platform-cpu-x86 platform-word-size-64) syscalls::vfork 189 () ) + +(define-syscall (logior platform-os-windows platform-cpu-x86 platform-word-size-64) syscalls::mmap 9 () ) +(define-syscall (logior platform-os-windows platform-cpu-x86 platform-word-size-64) syscalls::munmap 73 () ) + +) Index: /branches/new-random/library/x8664-freebsd-syscalls.lisp =================================================================== --- /branches/new-random/library/x8664-freebsd-syscalls.lisp (revision 13309) +++ /branches/new-random/library/x8664-freebsd-syscalls.lisp (revision 13309) @@ -0,0 +1,272 @@ +;;;-*-Mode: LISP; Package: CCL -*- +;;; +;;; Copyright (C) 2006-2009 Clozure Associates +;;; This file is part of Clozure CL. +;;; +;;; Clozure CL is licensed under the terms of the Lisp Lesser GNU Public +;;; License , known as the LLGPL and distributed with Clozure CL as the +;;; file "LICENSE". The LLGPL consists of a preamble and the LGPL, +;;; which is distributed with Clozure CL as the file "LGPL". Where these +;;; conflict, the preamble takes precedence. +;;; +;;; Clozure CL is referenced in the preamble as the "LIBRARY." +;;; +;;; The LLGPL is also available online at +;;; http://opensource.franz.com/preamble.html + +(in-package "CCL") + +(eval-when (:compile-toplevel :load-toplevel :execute) + (require "SYSCALL")) + + + + +(define-syscall (logior platform-os-freebsd platform-cpu-x86 platform-word-size-64) syscalls::read 3 (:unsigned-fullword :address :unsigned-fullword) + :signed-fullword) +(define-syscall (logior platform-os-freebsd platform-cpu-x86 platform-word-size-64) syscalls::write 4 (:unsigned-fullword :address :unsigned-fullword) + :signed-fullword) +(define-syscall (logior platform-os-freebsd platform-cpu-x86 platform-word-size-64) syscalls::open 5 (:address :unsigned-fullword :unsigned-fullword) :signed-fullword :min-args 2) +(define-syscall (logior platform-os-freebsd platform-cpu-x86 platform-word-size-64) syscalls::close 6 (:unsigned-fullword) :signed-fullword ) +(define-syscall (logior platform-os-freebsd platform-cpu-x86 platform-word-size-64) syscalls::stat 188 (:address :address) :signed-fullword) +(define-syscall (logior platform-os-freebsd platform-cpu-x86 platform-word-size-64) syscalls::fstat 189 (:unsigned-fullword :address) :signed-fullword ) +(define-syscall (logior platform-os-freebsd platform-cpu-x86 platform-word-size-64) syscalls::lstat 190 (:address :address) :signed-fullword) + +(define-syscall (logior platform-os-freebsd platform-cpu-x86 platform-word-size-64) syscalls::lseek 199 (:unsigned-fullword :unsigned-doubleword :signed-doubleword :unsigned-fullword) :signed-doubleword ) + +(define-syscall (logior platform-os-freebsd platform-cpu-x86 platform-word-size-64) syscalls::exit 1 (:signed-fullword) :void) +(define-syscall (logior platform-os-freebsd platform-cpu-x86 platform-word-size-64) syscalls::fork 2 () :signed-fullword) + + + +#+notyet +(define-syscall (logior platform-os-freebsd platform-cpu-x86 platform-word-size-64) syscalls::creat 85 (:address :unsigned-fullword) :signed-fullword ) + +(define-syscall (logior platform-os-freebsd platform-cpu-x86 platform-word-size-64) syscalls::link 9 (:address :address) :signed-fullword) +(define-syscall (logior platform-os-freebsd platform-cpu-x86 platform-word-size-64) syscalls::unlink 10 (:address) :signed-fullword ) +(define-syscall (logior platform-os-freebsd platform-cpu-x86 platform-word-size-64) syscalls::execve 59 (:address :address :address) :signed-fullword ) +(define-syscall (logior platform-os-freebsd platform-cpu-x86 platform-word-size-64) syscalls::chdir 12 (:address) :signed-fullword ) + +#+notyet +(define-syscall (logior platform-os-freebsd platform-cpu-x86 platform-word-size-64) syscalls::time 201 (:address) :unsigned-fullword ) + +(define-syscall (logior platform-os-freebsd platform-cpu-x86 platform-word-size-64) syscalls::mknod 14 (:address :unsigned-fullword :unsigned-fullword) + :signed-fullword) +(define-syscall (logior platform-os-freebsd platform-cpu-x86 platform-word-size-64) syscalls::chmod 15 (:address :unsigned-fullword) :signed-fullword) +(define-syscall (logior platform-os-freebsd platform-cpu-x86 platform-word-size-64) syscalls::lchown 254 (:address :unsigned-fullword :unsigned-fullword) + :signed-fullword) + +(define-syscall (logior platform-os-freebsd platform-cpu-x86 platform-word-size-64) syscalls::getpid 20 () :unsigned-fullword) +(define-syscall (logior platform-os-freebsd platform-cpu-x86 platform-word-size-64) syscalls::mount 21 (:address :address :address :unsigned-fullword :address) :signed-fullword ) + +#+notyet +(define-syscall (logior platform-os-freebsd platform-cpu-x86 platform-word-size-64) syscalls::umount2 166 (:address) :signed-fullword ) + +(define-syscall (logior platform-os-freebsd platform-cpu-x86 platform-word-size-64) syscalls::setuid 23 (:unsigned-fullword) :signed-fullword ) +(define-syscall (logior platform-os-freebsd platform-cpu-x86 platform-word-size-64) syscalls::getuid 24 () :unsigned-fullword ) + +(define-syscall (logior platform-os-freebsd platform-cpu-x86 platform-word-size-64) syscalls::ptrace 26 (:unsigned-fullword + :unsigned-fullword + :address + :address) + :signed-fullword) + +#+notyet +(define-syscall (logior platform-os-freebsd platform-cpu-x86 platform-word-size-64) syscalls::alarm 37 (:unsigned-fullword) :unsigned-fullword ) + +#+notyet +(define-syscall (logior platform-os-freebsd platform-cpu-x86 platform-word-size-64) syscalls::pause 34 () :signed-fullword) + +#+notyet +(define-syscall (logior platform-os-freebsd platform-cpu-x86 platform-word-size-64) syscalls::utime 132 (:address :address) :signed-fullword ) +(define-syscall (logior platform-os-freebsd platform-cpu-x86 platform-word-size-64) syscalls::access 33 (:address :unsigned-fullword) :signed-fullword) + +(define-syscall (logior platform-os-freebsd platform-cpu-x86 platform-word-size-64) syscalls::sync 36 () :signed-fullword ) +(define-syscall (logior platform-os-freebsd platform-cpu-x86 platform-word-size-64) syscalls::kill 37 (:signed-fullword :unsigned-fullword) :signed-fullword ) +(define-syscall (logior platform-os-freebsd platform-cpu-x86 platform-word-size-64) syscalls::rename 128 (:address :address) :signed-fullword ) +(define-syscall (logior platform-os-freebsd platform-cpu-x86 platform-word-size-64) syscalls::mkdir 136 (:address :unsigned-fullword) :signed-fullword ) +(define-syscall (logior platform-os-freebsd platform-cpu-x86 platform-word-size-64) syscalls::rmdir 137 (:address) :signed-fullword ) +(define-syscall (logior platform-os-freebsd platform-cpu-x86 platform-word-size-64) syscalls::dup 41 (:unsigned-fullword) :signed-fullword ) +(define-syscall (logior platform-os-freebsd platform-cpu-x86 platform-word-size-64) syscalls::pipe 42 (:address) :signed-fullword ) +(define-syscall (logior platform-os-freebsd platform-cpu-x86 platform-word-size-64) syscalls::times 100 (:address) :unsigned-fullword ) + +#+notyet +(define-syscall (logior platform-os-freebsd platform-cpu-x86 platform-word-size-64) syscalls::brk 12 (:address) :signed-fullword ) +(define-syscall (logior platform-os-freebsd platform-cpu-x86 platform-word-size-64) syscalls::setgid 181 (:unsigned-fullword) :signed-fullword) +(define-syscall (logior platform-os-freebsd platform-cpu-x86 platform-word-size-64) syscalls::getgid 47 () :unsigned-fullword ) + +(define-syscall (logior platform-os-freebsd platform-cpu-x86 platform-word-size-64) syscalls::geteuid 25 () :unsigned-fullword ) +(define-syscall (logior platform-os-freebsd platform-cpu-x86 platform-word-size-64) syscalls::getegid 43 () :unsigned-fullword) +(define-syscall (logior platform-os-freebsd platform-cpu-x86 platform-word-size-64) syscalls::acct 51 (:address) :signed-fullword ) + +(define-syscall (logior platform-os-freebsd platform-cpu-x86 platform-word-size-64) syscalls::ioctl 54 (:unsigned-fullword :signed-fullword :address) :signed-fullword :min-args 2 ) +(define-syscall (logior platform-os-freebsd platform-cpu-x86 platform-word-size-64) syscalls::fcntl 92 (:unsigned-fullword :signed-fullword :signed-fullword) :signed-fullword :min-args 2 ) +(define-syscall (logior platform-os-freebsd platform-cpu-x86 platform-word-size-64) syscalls::setpgid 82 (:signed-fullword :signed-fullword) :signed-fullword ) +(define-syscall (logior platform-os-freebsd platform-cpu-x86 platform-word-size-64) syscalls::umask 60 (:unsigned-fullword) :unsigned-fullword ) +(define-syscall (logior platform-os-freebsd platform-cpu-x86 platform-word-size-64) syscalls::chroot 61 (:address) :signed-fullword ) + +#+notyet +(define-syscall (logior platform-os-freebsd platform-cpu-x86 platform-word-size-64) syscalls::ustat 136 (:unsigned-fullword :address) :signed-fullword ) + +(define-syscall (logior platform-os-freebsd platform-cpu-x86 platform-word-size-64) syscalls::dup2 90 (:unsigned-fullword :unsigned-fullword) :signed-fullword ) +(define-syscall (logior platform-os-freebsd platform-cpu-x86 platform-word-size-64) syscalls::getppid 39 () :unsigned-fullword) +(define-syscall (logior platform-os-freebsd platform-cpu-x86 platform-word-size-64) syscalls::getpgrp 81 () :unsigned-fullword) +(define-syscall (logior platform-os-freebsd platform-cpu-x86 platform-word-size-64) syscalls::setsid 147 () :signed-fullword) +(define-syscall (logior platform-os-freebsd platform-cpu-x86 platform-word-size-64) syscalls::sigaction 416 (:unsigned-fullword :address :address) :signed-fullword ) +(define-syscall (logior platform-os-freebsd platform-cpu-x86 platform-word-size-64) syscalls::getrusage 117 (:signed-fullword :address) :signed-fullword) +(define-syscall (logior platform-os-freebsd platform-cpu-x86 platform-word-size-64) syscalls::gettimeofday 116 (:address :address) :void) +(define-syscall (logior platform-os-freebsd platform-cpu-x86 platform-word-size-64) syscalls::ftruncate 201 (:unsigned-fullword :unsigned-fullword) + :signed-fullword) +(define-syscall (logior platform-os-freebsd platform-cpu-x86 platform-word-size-64) syscalls::fchmod 91 (:unsigned-fullword :unsigned-fullword) + :signed-fullword ) +(define-syscall (logior platform-os-freebsd platform-cpu-x86 platform-word-size-64) syscalls::fchmod 124 (:unsigned-fullword :unsigned-fullword) + :signed-fullword ) +(define-syscall (logior platform-os-freebsd platform-cpu-x86 platform-word-size-64) syscalls::socket 97 (:signed-fullword :signed-fullword :signed-fullword) + :signed-fullword ) +(define-syscall (logior platform-os-freebsd platform-cpu-x86 platform-word-size-64) syscalls::connect 98 (:signed-fullword :address :signed-fullword) + :signed-fullword ) +(define-syscall (logior platform-os-freebsd platform-cpu-x86 platform-word-size-64) syscalls::accept 30 (:signed-fullword :address :address) + :signed-fullword ) +(define-syscall (logior platform-os-freebsd platform-cpu-x86 platform-word-size-64) syscalls::sendto 133 (:unsigned-fullword :address :unsigned-fullword :unsigned-fullword :address :unsigned-fullword) + :signed-fullword ) +(define-syscall (logior platform-os-freebsd platform-cpu-x86 platform-word-size-64) syscalls::recvfrom 29 (:unsigned-fullword :address :unsigned-long :unsigned-fullword :address :address) :signed-fullword ) +(define-syscall (logior platform-os-freebsd platform-cpu-x86 platform-word-size-64) syscalls::sendmsg 28 (:unsigned-fullword :address :unsigned-fullword) :signed-fullword ) +(define-syscall (logior platform-os-freebsd platform-cpu-x86 platform-word-size-64) syscalls::recvmsg 27 (:unsigned-fullword :address :unsigned-fullword) :signed-fullword ) +(define-syscall (logior platform-os-freebsd platform-cpu-x86 platform-word-size-64) syscalls::shutdown 134 (:unsigned-fullword :unsigned-fullword) :signed-fullword ) +(define-syscall (logior platform-os-freebsd platform-cpu-x86 platform-word-size-64) syscalls::bind 104 (:signed-fullword :address :signed-fullword) + :signed-fullword ) +(define-syscall (logior platform-os-freebsd platform-cpu-x86 platform-word-size-64) syscalls::listen 106 (:signed-fullword :signed-fullword) + :signed-fullword ) +(define-syscall (logior platform-os-freebsd platform-cpu-x86 platform-word-size-64) syscalls::getpeername 31 (:signed-fullword :address :address) + :signed-fullword ) +(define-syscall (logior platform-os-freebsd platform-cpu-x86 platform-word-size-64) syscalls::getsockname 32 (:signed-fullword :address :address) + :signed-fullword ) +(define-syscall (logior platform-os-freebsd platform-cpu-x86 platform-word-size-64) syscalls::socketpair 135 (:signed-fullword :signed-fullword :signed-fullword :address) + :signed-fullword ) +(define-syscall (logior platform-os-freebsd platform-cpu-x86 platform-word-size-64) syscalls::setsockopt 105 (:unsigned-fullword :signed-fullword :signed-fullword :address :unsigned-fullword) :signed-fullword ) +(define-syscall (logior platform-os-freebsd platform-cpu-x86 platform-word-size-64) syscalls::getsockopt 118 (:unsigned-fullword :signed-fullword :unsigned-fullword :address :address) :signed-fullword ) + +(define-syscall (logior platform-os-freebsd platform-cpu-x86 platform-word-size-64) syscalls::fsync 95 (:unsigned-fullword) :signed-fullword ) +(define-syscall (logior platform-os-freebsd platform-cpu-x86 platform-word-size-64) syscalls::uname 164 (:address) :signed-fullword) +(define-syscall (logior platform-os-freebsd platform-cpu-x86 platform-word-size-64) syscalls::fchdir 13 (:unsigned-fullword) :signed-fullword ) + +(define-syscall (logior platform-os-freebsd platform-cpu-x86 platform-word-size-64) syscalls::select 93 (:unsigned-fullword :address :address + :address :address) + :signed-fullword) +(define-syscall (logior platform-os-freebsd platform-cpu-x86 platform-word-size-64) syscalls::getcwd 326 (:address :unsigned-fullword) :signed-fullword ) + +(define-syscall (logior platform-os-freebsd platform-cpu-x86 platform-word-size-64) syscalls::poll 209 ((:* (:struct :pollfd)) :int :int) :int) + +#+notdefinedyet +(progn +(define-syscall (logior platform-os-freebsd platform-cpu-x86 platform-word-size-64) syscalls::sgetmask 68 () ) +(define-syscall (logior platform-os-freebsd platform-cpu-x86 platform-word-size-64) syscalls::ssetmask 69 () ) +(define-syscall (logior platform-os-freebsd platform-cpu-x86 platform-word-size-64) syscalls::setreuid 70 () ) +(define-syscall (logior platform-os-freebsd platform-cpu-x86 platform-word-size-64) syscalls::setregid 71 () ) +(define-syscall (logior platform-os-freebsd platform-cpu-x86 platform-word-size-64) syscalls::sigsuspend 72 () ) +(define-syscall (logior platform-os-freebsd platform-cpu-x86 platform-word-size-64) syscalls::sigpending 73 () ) +(define-syscall (logior platform-os-freebsd platform-cpu-x86 platform-word-size-64) syscalls::sethostname 74 () ) +(define-syscall (logior platform-os-freebsd platform-cpu-x86 platform-word-size-64) syscalls::setrlimit 75 () ) +(define-syscall (logior platform-os-freebsd platform-cpu-x86 platform-word-size-64) syscalls::getrlimit 76 () ) +(define-syscall (logior platform-os-freebsd platform-cpu-x86 platform-word-size-64) syscalls::settimeofday 79 () ) +(define-syscall (logior platform-os-freebsd platform-cpu-x86 platform-word-size-64) syscalls::getgroups 80 () ) +(define-syscall (logior platform-os-freebsd platform-cpu-x86 platform-word-size-64) syscalls::setgroups 81 () ) +(define-syscall (logior platform-os-freebsd platform-cpu-x86 platform-word-size-64) syscalls::symlink 83 () ) +(define-syscall (logior platform-os-freebsd platform-cpu-x86 platform-word-size-64) syscalls::oldlstat 84 () ) +(define-syscall (logior platform-os-freebsd platform-cpu-x86 platform-word-size-64) syscalls::readlink 58 () ) +(define-syscall (logior platform-os-freebsd platform-cpu-x86 platform-word-size-64) syscalls::uselib 86 () ) +(define-syscall (logior platform-os-freebsd platform-cpu-x86 platform-word-size-64) syscalls::swapon 87 () ) +(define-syscall (logior platform-os-freebsd platform-cpu-x86 platform-word-size-64) syscalls::reboot 88 () ) +(define-syscall (logior platform-os-freebsd platform-cpu-x86 platform-word-size-64) syscalls::readdir 89 () ) +(define-syscall (logior platform-os-freebsd platform-cpu-x86 platform-word-size-64) syscalls::truncate 92 () ) + +(define-syscall (logior platform-os-freebsd platform-cpu-x86 platform-word-size-64) syscalls::fchown 95 () ) +(define-syscall (logior platform-os-freebsd platform-cpu-x86 platform-word-size-64) syscalls::getpriority 96 () ) +(define-syscall (logior platform-os-freebsd platform-cpu-x86 platform-word-size-64) syscalls::setpriority 97 () ) +(define-syscall (logior platform-os-freebsd platform-cpu-x86 platform-word-size-64) syscalls::statfs 99 () ) +(define-syscall (logior platform-os-freebsd platform-cpu-x86 platform-word-size-64) syscalls::fstatfs 100 () ) +(define-syscall (logior platform-os-freebsd platform-cpu-x86 platform-word-size-64) syscalls::ioperm 101 () ) +(define-syscall (logior platform-os-freebsd platform-cpu-x86 platform-word-size-64) syscalls::syslog 103 () ) +(define-syscall (logior platform-os-freebsd platform-cpu-x86 platform-word-size-64) syscalls::setitimer 38 () ) +(define-syscall (logior platform-os-freebsd platform-cpu-x86 platform-word-size-64) syscalls::getitimer 36 () ) +(define-syscall (logior platform-os-freebsd platform-cpu-x86 platform-word-size-64) syscalls::olduname 109 () ) +(define-syscall (logior platform-os-freebsd platform-cpu-x86 platform-word-size-64) syscalls::iopl 110 () ) +(define-syscall (logior platform-os-freebsd platform-cpu-x86 platform-word-size-64) syscalls::vhangup 111 () ) +(define-syscall (logior platform-os-freebsd platform-cpu-x86 platform-word-size-64) syscalls::idle 112 () ) +(define-syscall (logior platform-os-freebsd platform-cpu-x86 platform-word-size-64) syscalls::vm86 113 () ) +(define-syscall (logior platform-os-freebsd platform-cpu-x86 platform-word-size-64) syscalls::wait4 7 () ) +(define-syscall (logior platform-os-freebsd platform-cpu-x86 platform-word-size-64) syscalls::swapoff 115 () ) +(define-syscall (logior platform-os-freebsd platform-cpu-x86 platform-word-size-64) syscalls::sysinfo 116 () ) +(define-syscall (logior platform-os-freebsd platform-cpu-x86 platform-word-size-64) syscalls::ipc 117 () ) +(define-syscall (logior platform-os-freebsd platform-cpu-x86 platform-word-size-64) syscalls::sigreturn 119 () ) +(define-syscall (logior platform-os-freebsd platform-cpu-x86 platform-word-size-64) syscalls::clone 120 () ) +(define-syscall (logior platform-os-freebsd platform-cpu-x86 platform-word-size-64) syscalls::setdomainname 121 () ) +(define-syscall (logior platform-os-freebsd platform-cpu-x86 platform-word-size-64) syscalls::modify_ldt 123 () ) +(define-syscall (logior platform-os-freebsd platform-cpu-x86 platform-word-size-64) syscalls::adjtimex 124 () ) +(define-syscall (logior platform-os-freebsd platform-cpu-x86 platform-word-size-64) syscalls::mprotect 10 () ) +(define-syscall (logior platform-os-freebsd platform-cpu-x86 platform-word-size-64) syscalls::sigprocmask 126 () ) +(define-syscall (logior platform-os-freebsd platform-cpu-x86 platform-word-size-64) syscalls::create_module 127 () ) +(define-syscall (logior platform-os-freebsd platform-cpu-x86 platform-word-size-64) syscalls::init_module 128 () ) +(define-syscall (logior platform-os-freebsd platform-cpu-x86 platform-word-size-64) syscalls::delete_module 129 () ) +(define-syscall (logior platform-os-freebsd platform-cpu-x86 platform-word-size-64) syscalls::get_kernel_syms 130 () ) +(define-syscall (logior platform-os-freebsd platform-cpu-x86 platform-word-size-64) syscalls::quotactl 131 () ) +(define-syscall (logior platform-os-freebsd platform-cpu-x86 platform-word-size-64) syscalls::getpgid 132 () ) +(define-syscall (logior platform-os-freebsd platform-cpu-x86 platform-word-size-64) syscalls::bdflush 134 () ) +(define-syscall (logior platform-os-freebsd platform-cpu-x86 platform-word-size-64) syscalls::sysfs 135 () ) +(define-syscall (logior platform-os-freebsd platform-cpu-x86 platform-word-size-64) syscalls::personality 136 () ) +(define-syscall (logior platform-os-freebsd platform-cpu-x86 platform-word-size-64) syscalls::setfsuid 138 () ) +(define-syscall (logior platform-os-freebsd platform-cpu-x86 platform-word-size-64) syscalls::setfsgid 139 () ) +(define-syscall (logior platform-os-freebsd platform-cpu-x86 platform-word-size-64) syscalls::getdents 141 () ) +(define-syscall (logior platform-os-freebsd platform-cpu-x86 platform-word-size-64) syscalls::_newselect 142 () ) +(define-syscall (logior platform-os-freebsd platform-cpu-x86 platform-word-size-64) syscalls::flock 143 () ) +(define-syscall (logior platform-os-freebsd platform-cpu-x86 platform-word-size-64) syscalls::msync 26 () ) +(define-syscall (logior platform-os-freebsd platform-cpu-x86 platform-word-size-64) syscalls::readv 19 () ) +(define-syscall (logior platform-os-freebsd platform-cpu-x86 platform-word-size-64) syscalls::writev 20 () ) +(define-syscall (logior platform-os-freebsd platform-cpu-x86 platform-word-size-64) syscalls::getsid 147 () ) +(define-syscall (logior platform-os-freebsd platform-cpu-x86 platform-word-size-64) syscalls::fdatasync 148 () ) +(define-syscall (logior platform-os-freebsd platform-cpu-x86 platform-word-size-64) syscalls::_sysctl 149 () ) +(define-syscall (logior platform-os-freebsd platform-cpu-x86 platform-word-size-64) syscalls::mlock 150 () ) +(define-syscall (logior platform-os-freebsd platform-cpu-x86 platform-word-size-64) syscalls::munlock 151 () ) +(define-syscall (logior platform-os-freebsd platform-cpu-x86 platform-word-size-64) syscalls::mlockall 152 () ) +(define-syscall (logior platform-os-freebsd platform-cpu-x86 platform-word-size-64) syscalls::munlockall 153 () ) +(define-syscall (logior platform-os-freebsd platform-cpu-x86 platform-word-size-64) syscalls::sched_setparam 154 () ) +(define-syscall (logior platform-os-freebsd platform-cpu-x86 platform-word-size-64) syscalls::sched_getparam 155 () ) +(define-syscall (logior platform-os-freebsd platform-cpu-x86 platform-word-size-64) syscalls::sched_setscheduler 156 () ) +(define-syscall (logior platform-os-freebsd platform-cpu-x86 platform-word-size-64) syscalls::sched_getscheduler 157 () ) +(define-syscall (logior platform-os-freebsd platform-cpu-x86 platform-word-size-64) syscalls::sched_yield 24 () ) +(define-syscall (logior platform-os-freebsd platform-cpu-x86 platform-word-size-64) syscalls::sched_get_priority_max 159 () ) +(define-syscall (logior platform-os-freebsd platform-cpu-x86 platform-word-size-64) syscalls::sched_get_priority_min 160 () ) +(define-syscall (logior platform-os-freebsd platform-cpu-x86 platform-word-size-64) syscalls::sched_rr_get_interval 161 () ) +(define-syscall (logior platform-os-freebsd platform-cpu-x86 platform-word-size-64) syscalls::nanosleep 35 () ) +(define-syscall (logior platform-os-freebsd platform-cpu-x86 platform-word-size-64) syscalls::mremap 25 () ) +(define-syscall (logior platform-os-freebsd platform-cpu-x86 platform-word-size-64) syscalls::setresuid 164 () ) +(define-syscall (logior platform-os-freebsd platform-cpu-x86 platform-word-size-64) syscalls::getresuid 165 () ) +(define-syscall (logior platform-os-freebsd platform-cpu-x86 platform-word-size-64) syscalls::query_module 166 () ) + +(define-syscall (logior platform-os-freebsd platform-cpu-x86 platform-word-size-64) syscalls::nfsservctl 168 () ) +(define-syscall (logior platform-os-freebsd platform-cpu-x86 platform-word-size-64) syscalls::setresgid 169 () ) +(define-syscall (logior platform-os-freebsd platform-cpu-x86 platform-word-size-64) syscalls::getresgid 170 () ) +(define-syscall (logior platform-os-freebsd platform-cpu-x86 platform-word-size-64) syscalls::prctl 171 () ) +(define-syscall (logior platform-os-freebsd platform-cpu-x86 platform-word-size-64) syscalls::rt_sigreturn 15 () ) +(define-syscall (logior platform-os-freebsd platform-cpu-x86 platform-word-size-64) syscalls::rt_sigaction 13 () ) +(define-syscall (logior platform-os-freebsd platform-cpu-x86 platform-word-size-64) syscalls::rt_sigprocmask 14 () ) +(define-syscall (logior platform-os-freebsd platform-cpu-x86 platform-word-size-64) syscalls::rt_sigpending 175 () ) +(define-syscall (logior platform-os-freebsd platform-cpu-x86 platform-word-size-64) syscalls::rt_sigtimedwait 176 () ) +(define-syscall (logior platform-os-freebsd platform-cpu-x86 platform-word-size-64) syscalls::rt_sigqueueinfo 177 () ) +(define-syscall (logior platform-os-freebsd platform-cpu-x86 platform-word-size-64) syscalls::rt_sigsuspend 178 () ) +(define-syscall (logior platform-os-freebsd platform-cpu-x86 platform-word-size-64) syscalls::pread 17 () ) +(define-syscall (logior platform-os-freebsd platform-cpu-x86 platform-word-size-64) syscalls::pwrite 18 () ) +(define-syscall (logior platform-os-freebsd platform-cpu-x86 platform-word-size-64) syscalls::chown 181 (:address) ) + +(define-syscall (logior platform-os-freebsd platform-cpu-x86 platform-word-size-64) syscalls::capget 183 () ) +(define-syscall (logior platform-os-freebsd platform-cpu-x86 platform-word-size-64) syscalls::capset 184 () ) +(define-syscall (logior platform-os-freebsd platform-cpu-x86 platform-word-size-64) syscalls::sigaltstack 185 () ) +(define-syscall (logior platform-os-freebsd platform-cpu-x86 platform-word-size-64) syscalls::sendfile 40 () ) +(define-syscall (logior platform-os-freebsd platform-cpu-x86 platform-word-size-64) syscalls::getpmsg 187 () ) +(define-syscall (logior platform-os-freebsd platform-cpu-x86 platform-word-size-64) syscalls::putpmsg 188 () ) +(define-syscall (logior platform-os-freebsd platform-cpu-x86 platform-word-size-64) syscalls::vfork 189 () ) + +(define-syscall (logior platform-os-freebsd platform-cpu-x86 platform-word-size-64) syscalls::mmap 9 () ) +(define-syscall (logior platform-os-freebsd platform-cpu-x86 platform-word-size-64) syscalls::munmap 73 () ) + +) Index: /branches/new-random/library/x8664-linux-syscalls.lisp =================================================================== --- /branches/new-random/library/x8664-linux-syscalls.lisp (revision 13309) +++ /branches/new-random/library/x8664-linux-syscalls.lisp (revision 13309) @@ -0,0 +1,261 @@ +;;;-*-Mode: LISP; Package: CCL -*- +;;; +;;; Copyright (C) 2001-2009 Clozure Associates +;;; This file is part of Clozure CL. +;;; +;;; Clozure CL is licensed under the terms of the Lisp Lesser GNU Public +;;; License , known as the LLGPL and distributed with Clozure CL as the +;;; file "LICENSE". The LLGPL consists of a preamble and the LGPL, +;;; which is distributed with Clozure CL as the file "LGPL". Where these +;;; conflict, the preamble takes precedence. +;;; +;;; Clozure CL is referenced in the preamble as the "LIBRARY." +;;; +;;; The LLGPL is also available online at +;;; http://opensource.franz.com/preamble.html + +(in-package "CCL") + +(eval-when (:compile-toplevel :load-toplevel :execute) + (require "SYSCALL")) + + + + + + +(define-syscall (logior platform-os-linux platform-cpu-x86 platform-word-size-64) syscalls::read 0 (:int :address :size_t) + :ssize_t) +(define-syscall (logior platform-os-linux platform-cpu-x86 platform-word-size-64) syscalls::write 1 (:int :address :size_t) + :ssize_t) +(define-syscall (logior platform-os-linux platform-cpu-x86 platform-word-size-64) syscalls::open 2 (:address :int :mode_t) :int :min-args 2) +(define-syscall (logior platform-os-linux platform-cpu-x86 platform-word-size-64) syscalls::close 3 (:int) :int ) +(define-syscall (logior platform-os-linux platform-cpu-x86 platform-word-size-64) syscalls::stat 4 (:address :address) :signed-fullword) +(define-syscall (logior platform-os-linux platform-cpu-x86 platform-word-size-64) syscalls::fstat 5 (:unsigned-fullword :address) :signed-fullword ) +(define-syscall (logior platform-os-linux platform-cpu-x86 platform-word-size-64) syscalls::lstat 6 (:address :address) :signed-fullword) +(define-syscall (logior platform-os-linux platform-cpu-x86 platform-word-size-64) syscalls::poll 7 ((:* (:struct :pollfd)) :int :int) :int) +(define-syscall (logior platform-os-linux platform-cpu-x86 platform-word-size-64) syscalls::lseek 8 (:int :off_t :int) :off_t ) + +(define-syscall (logior platform-os-linux platform-cpu-x86 platform-word-size-64) syscalls::exit 60 (:int) :void) +(define-syscall (logior platform-os-linux platform-cpu-x86 platform-word-size-64) syscalls::fork 57 () :pid_t) + + + + +(define-syscall (logior platform-os-linux platform-cpu-x86 platform-word-size-64) syscalls::creat 85 (:address :mode_t) :int ) +(define-syscall (logior platform-os-linux platform-cpu-x86 platform-word-size-64) syscalls::link 86 (:address :address) :int) +(define-syscall (logior platform-os-linux platform-cpu-x86 platform-word-size-64) syscalls::unlink 87 (:address) :int ) +(define-syscall (logior platform-os-linux platform-cpu-x86 platform-word-size-64) syscalls::execve 59 (:address :address :address) :int ) +(define-syscall (logior platform-os-linux platform-cpu-x86 platform-word-size-64) syscalls::chdir 80 (:address) :int ) +(define-syscall (logior platform-os-linux platform-cpu-x86 platform-word-size-64) syscalls::time 201 (:address) :time_t ) +(define-syscall (logior platform-os-linux platform-cpu-x86 platform-word-size-64) syscalls::mknod 133 (:address :mode_t :dev_t) + :int) +(define-syscall (logior platform-os-linux platform-cpu-x86 platform-word-size-64) syscalls::chmod 90 (:address :mode_t) :int) +(define-syscall (logior platform-os-linux platform-cpu-x86 platform-word-size-64) syscalls::lchown 94 (:address :uid_t :gid_t) + :int) + +(define-syscall (logior platform-os-linux platform-cpu-x86 platform-word-size-64) syscalls::getpid 39 () :pid_t) +(define-syscall (logior platform-os-linux platform-cpu-x86 platform-word-size-64) syscalls::mount 165 (:address + :address + :address + :unsigned-long + :address) :int ) +(define-syscall (logior platform-os-linux platform-cpu-x86 platform-word-size-64) syscalls::umount2 166 (:address :int) :int ) + +(define-syscall (logior platform-os-linux platform-cpu-x86 platform-word-size-64) syscalls::setuid 105 (:uid_t) :int ) +(define-syscall (logior platform-os-linux platform-cpu-x86 platform-word-size-64) syscalls::getuid 102 () :uid_t ) + +(define-syscall (logior platform-os-linux platform-cpu-x86 platform-word-size-64) syscalls::ptrace 101 (:unsigned-fullword + :pid_t + :address + :address) + :long) +(define-syscall (logior platform-os-linux platform-cpu-x86 platform-word-size-64) syscalls::alarm 37 (:unsigned) :unsigned ) + +(define-syscall (logior platform-os-linux platform-cpu-x86 platform-word-size-64) syscalls::pause 34 () :unt) +(define-syscall (logior platform-os-linux platform-cpu-x86 platform-word-size-64) syscalls::utime 132 (:address :address) :int ) +(define-syscall (logior platform-os-linux platform-cpu-x86 platform-word-size-64) syscalls::access 21 (:address :int) :int) + +(define-syscall (logior platform-os-linux platform-cpu-x86 platform-word-size-64) syscalls::sync 162 () :void ) +(define-syscall (logior platform-os-linux platform-cpu-x86 platform-word-size-64) syscalls::kill 62 (:pid_t :int) :int ) +(define-syscall (logior platform-os-linux platform-cpu-x86 platform-word-size-64) syscalls::rename 82 (:address :address) :int ) +(define-syscall (logior platform-os-linux platform-cpu-x86 platform-word-size-64) syscalls::mkdir 83 (:address :mode_t) :int ) +(define-syscall (logior platform-os-linux platform-cpu-x86 platform-word-size-64) syscalls::rmdir 84 (:address) :int ) +(define-syscall (logior platform-os-linux platform-cpu-x86 platform-word-size-64) syscalls::dup 32 (:int) :int ) +(define-syscall (logior platform-os-linux platform-cpu-x86 platform-word-size-64) syscalls::pipe 22 (:address) :int ) +(define-syscall (logior platform-os-linux platform-cpu-x86 platform-word-size-64) syscalls::times 100 (:address) :clock_t ) + +(define-syscall (logior platform-os-linux platform-cpu-x86 platform-word-size-64) syscalls::brk 12 (:address) :int ) +(define-syscall (logior platform-os-linux platform-cpu-x86 platform-word-size-64) syscalls::setgid 106 (:gid_t) :int) +(define-syscall (logior platform-os-linux platform-cpu-x86 platform-word-size-64) syscalls::getgid 104 () :gid_t ) + +(define-syscall (logior platform-os-linux platform-cpu-x86 platform-word-size-64) syscalls::geteuid 107 () :uid_t ) +(define-syscall (logior platform-os-linux platform-cpu-x86 platform-word-size-64) syscalls::getegid 108 () :gid_t) +(define-syscall (logior platform-os-linux platform-cpu-x86 platform-word-size-64) syscalls::acct 163 (:address) :INT ) +(define-syscall (logior platform-os-linux platform-cpu-x86 platform-word-size-64) syscalls::ioctl 16 (:int :int :address) :int :min-args 2 ) +(define-syscall (logior platform-os-linux platform-cpu-x86 platform-word-size-64) syscalls::fcntl 72 (:int :int :long) :int :min-args 2 ) +(define-syscall (logior platform-os-linux platform-cpu-x86 platform-word-size-64) syscalls::setpgid 109 (:pid_t :gid_t) :int ) +(define-syscall (logior platform-os-linux platform-cpu-x86 platform-word-size-64) syscalls::umask 95 (:mode_t) :mode_t ) +(define-syscall (logior platform-os-linux platform-cpu-x86 platform-word-size-64) syscalls::chroot 161 (:address) :int ) +(define-syscall (logior platform-os-linux platform-cpu-x86 platform-word-size-64) syscalls::ustat 136 (:dev_t :address) :int ) +(define-syscall (logior platform-os-linux platform-cpu-x86 platform-word-size-64) syscalls::dup2 33 (:int :int) :int ) +(define-syscall (logior platform-os-linux platform-cpu-x86 platform-word-size-64) syscalls::getppid 110 () :pid_t) +(define-syscall (logior platform-os-linux platform-cpu-x86 platform-word-size-64) syscalls::getpgrp 111 () :gid_t) +(define-syscall (logior platform-os-linux platform-cpu-x86 platform-word-size-64) syscalls::setsid 112 () :pid_t) +(define-syscall (logior platform-os-linux platform-cpu-x86 platform-word-size-64) syscalls::rt-sigaction 13 (:unsigned-fullword :address :address) :signed-fullword ) +(define-syscall (logior platform-os-linux platform-cpu-x86 platform-word-size-64) syscalls::getrusage 98 (:int :address) :int) +(define-syscall (logior platform-os-linux platform-cpu-x86 platform-word-size-64) syscalls::gettimeofday 96 (:address :address) :void) +(define-syscall (logior platform-os-linux platform-cpu-x86 platform-word-size-64) syscalls::ftruncate 77 (:int :off_t) + :int) +(define-syscall (logior platform-os-linux platform-cpu-x86 platform-word-size-64) syscalls::fchmod 91 (:int :mode_t) + :int ) + +(define-syscall (logior platform-os-linux platform-cpu-x86 platform-word-size-64) syscalls::socket 41 (:int :int :int) + :int ) +(define-syscall (logior platform-os-linux platform-cpu-x86 platform-word-size-64) syscalls::connect 42 (:int :address :socklen_t) + :int ) +(define-syscall (logior platform-os-linux platform-cpu-x86 platform-word-size-64) syscalls::accept 43 (:int :address :address) + :int ) +(define-syscall (logior platform-os-linux platform-cpu-x86 platform-word-size-64) syscalls::sendto 44 (:int :address :size_t :int :address :socklen_t) :int) +(define-syscall (logior platform-os-linux platform-cpu-x86 platform-word-size-64) syscalls::recvfrom 45 (:int :address :size_t :int :address :address) :int ) +(define-syscall (logior platform-os-linux platform-cpu-x86 platform-word-size-64) syscalls::sendmsg 46 (:int :address :int) :int ) +(define-syscall (logior platform-os-linux platform-cpu-x86 platform-word-size-64) syscalls::recvmsg 47 (:int :address :int) :int ) +(define-syscall (logior platform-os-linux platform-cpu-x86 platform-word-size-64) syscalls::shutdown 48 (:int :int) :int ) +(define-syscall (logior platform-os-linux platform-cpu-x86 platform-word-size-64) syscalls::bind 49 (:int :address :socklen_t) + :int ) +(define-syscall (logior platform-os-linux platform-cpu-x86 platform-word-size-64) syscalls::listen 50 (:int :int) + :int ) +(define-syscall (logior platform-os-linux platform-cpu-x86 platform-word-size-64) syscalls::getsockname 51 (:int :address :address) + :int ) +(define-syscall (logior platform-os-linux platform-cpu-x86 platform-word-size-64) syscalls::getpeername 52 (:int :address :address) + :int ) +(define-syscall (logior platform-os-linux platform-cpu-x86 platform-word-size-64) syscalls::socketpair 53 (:int :int :int :address) + :int ) +(define-syscall (logior platform-os-linux platform-cpu-x86 platform-word-size-64) syscalls::setsockopt 54 (:int :int :int :address :socklen_t) :int ) +(define-syscall (logior platform-os-linux platform-cpu-x86 platform-word-size-64) syscalls::getsockopt 55 (:int :int :int :address :address) :int ) + +(define-syscall (logior platform-os-linux platform-cpu-x86 platform-word-size-64) syscalls::fsync 118 (:int) :int ) +(define-syscall (logior platform-os-linux platform-cpu-x86 platform-word-size-64) syscalls::uname 63 (:address) :int) +(define-syscall (logior platform-os-linux platform-cpu-x86 platform-word-size-64) syscalls::fchdir 133 (:int) :int ) +(define-syscall (logior platform-os-linux platform-cpu-x86 platform-word-size-64) syscalls::_llseek 140 (:unsigned-fullword :unsigned-fullword :unsigned-fullword :address :unsigned-fullword) :signed-fullword ) +(define-syscall (logior platform-os-linux platform-cpu-x86 platform-word-size-64) syscalls::select 23 (:int :address :address + :address :address) + :int) +(define-syscall (logior platform-os-linux platform-cpu-x86 platform-word-size-64) syscalls::getcwd 79 (:address :unsigned-long) :long ) + + +(define-syscall (logior platform-os-linux platform-cpu-x86 platform-word-size-64) syscalls::futex 202 (:address :int :int :address :address :int) :int ) + +#+notdefinedyet +(progn +(define-syscall (logior platform-os-linux platform-cpu-x86 platform-word-size-64) syscalls::sgetmask 68 () ) +(define-syscall (logior platform-os-linux platform-cpu-x86 platform-word-size-64) syscalls::ssetmask 69 () ) +(define-syscall (logior platform-os-linux platform-cpu-x86 platform-word-size-64) syscalls::setreuid 70 () ) +(define-syscall (logior platform-os-linux platform-cpu-x86 platform-word-size-64) syscalls::setregid 71 () ) +(define-syscall (logior platform-os-linux platform-cpu-x86 platform-word-size-64) syscalls::sigsuspend 72 () ) +(define-syscall (logior platform-os-linux platform-cpu-x86 platform-word-size-64) syscalls::sigpending 73 () ) +(define-syscall (logior platform-os-linux platform-cpu-x86 platform-word-size-64) syscalls::sethostname 74 () ) +(define-syscall (logior platform-os-linux platform-cpu-x86 platform-word-size-64) syscalls::setrlimit 75 () ) +(define-syscall (logior platform-os-linux platform-cpu-x86 platform-word-size-64) syscalls::getrlimit 76 () ) +(define-syscall (logior platform-os-linux platform-cpu-x86 platform-word-size-64) syscalls::settimeofday 79 () ) +(define-syscall (logior platform-os-linux platform-cpu-x86 platform-word-size-64) syscalls::getgroups 80 () ) +(define-syscall (logior platform-os-linux platform-cpu-x86 platform-word-size-64) syscalls::setgroups 81 () ) +(define-syscall (logior platform-os-linux platform-cpu-x86 platform-word-size-64) syscalls::symlink 83 () ) +(define-syscall (logior platform-os-linux platform-cpu-x86 platform-word-size-64) syscalls::oldlstat 84 () ) +(define-syscall (logior platform-os-linux platform-cpu-x86 platform-word-size-64) syscalls::readlink 85 () ) +(define-syscall (logior platform-os-linux platform-cpu-x86 platform-word-size-64) syscalls::uselib 86 () ) +(define-syscall (logior platform-os-linux platform-cpu-x86 platform-word-size-64) syscalls::swapon 87 () ) +(define-syscall (logior platform-os-linux platform-cpu-x86 platform-word-size-64) syscalls::reboot 88 () ) +(define-syscall (logior platform-os-linux platform-cpu-x86 platform-word-size-64) syscalls::readdir 89 () ) +(define-syscall (logior platform-os-linux platform-cpu-x86 platform-word-size-64) syscalls::truncate 92 () ) + +(define-syscall (logior platform-os-linux platform-cpu-x86 platform-word-size-64) syscalls::fchown 95 () ) +(define-syscall (logior platform-os-linux platform-cpu-x86 platform-word-size-64) syscalls::getpriority 96 () ) +(define-syscall (logior platform-os-linux platform-cpu-x86 platform-word-size-64) syscalls::setpriority 97 () ) +(define-syscall (logior platform-os-linux platform-cpu-x86 platform-word-size-64) syscalls::statfs 99 () ) +(define-syscall (logior platform-os-linux platform-cpu-x86 platform-word-size-64) syscalls::fstatfs 100 () ) +(define-syscall (logior platform-os-linux platform-cpu-x86 platform-word-size-64) syscalls::ioperm 101 () ) +(define-syscall (logior platform-os-linux platform-cpu-x86 platform-word-size-64) syscalls::syslog 103 () ) +(define-syscall (logior platform-os-linux platform-cpu-x86 platform-word-size-64) syscalls::setitimer 38 () ) +(define-syscall (logior platform-os-linux platform-cpu-x86 platform-word-size-64) syscalls::getitimer 36 () ) +(define-syscall (logior platform-os-linux platform-cpu-x86 platform-word-size-64) syscalls::olduname 109 () ) +(define-syscall (logior platform-os-linux platform-cpu-x86 platform-word-size-64) syscalls::iopl 110 () ) +(define-syscall (logior platform-os-linux platform-cpu-x86 platform-word-size-64) syscalls::vhangup 111 () ) +(define-syscall (logior platform-os-linux platform-cpu-x86 platform-word-size-64) syscalls::idle 112 () ) +(define-syscall (logior platform-os-linux platform-cpu-x86 platform-word-size-64) syscalls::vm86 113 () ) +(define-syscall (logior platform-os-linux platform-cpu-x86 platform-word-size-64) syscalls::wait4 114 () ) +(define-syscall (logior platform-os-linux platform-cpu-x86 platform-word-size-64) syscalls::swapoff 115 () ) +(define-syscall (logior platform-os-linux platform-cpu-x86 platform-word-size-64) syscalls::sysinfo 116 () ) +(define-syscall (logior platform-os-linux platform-cpu-x86 platform-word-size-64) syscalls::ipc 117 () ) +(define-syscall (logior platform-os-linux platform-cpu-x86 platform-word-size-64) syscalls::sigreturn 119 () ) +(define-syscall (logior platform-os-linux platform-cpu-x86 platform-word-size-64) syscalls::clone 120 () ) +(define-syscall (logior platform-os-linux platform-cpu-x86 platform-word-size-64) syscalls::setdomainname 121 () ) +(define-syscall (logior platform-os-linux platform-cpu-x86 platform-word-size-64) syscalls::modify_ldt 123 () ) +(define-syscall (logior platform-os-linux platform-cpu-x86 platform-word-size-64) syscalls::adjtimex 124 () ) +(define-syscall (logior platform-os-linux platform-cpu-x86 platform-word-size-64) syscalls::mprotect 10 () ) +(define-syscall (logior platform-os-linux platform-cpu-x86 platform-word-size-64) syscalls::sigprocmask 126 () ) +(define-syscall (logior platform-os-linux platform-cpu-x86 platform-word-size-64) syscalls::create_module 127 () ) +(define-syscall (logior platform-os-linux platform-cpu-x86 platform-word-size-64) syscalls::init_module 128 () ) +(define-syscall (logior platform-os-linux platform-cpu-x86 platform-word-size-64) syscalls::delete_module 129 () ) +(define-syscall (logior platform-os-linux platform-cpu-x86 platform-word-size-64) syscalls::get_kernel_syms 130 () ) +(define-syscall (logior platform-os-linux platform-cpu-x86 platform-word-size-64) syscalls::quotactl 131 () ) +(define-syscall (logior platform-os-linux platform-cpu-x86 platform-word-size-64) syscalls::getpgid 132 () ) +(define-syscall (logior platform-os-linux platform-cpu-x86 platform-word-size-64) syscalls::bdflush 134 () ) +(define-syscall (logior platform-os-linux platform-cpu-x86 platform-word-size-64) syscalls::sysfs 135 () ) +(define-syscall (logior platform-os-linux platform-cpu-x86 platform-word-size-64) syscalls::personality 136 () ) +(define-syscall (logior platform-os-linux platform-cpu-x86 platform-word-size-64) syscalls::setfsuid 138 () ) +(define-syscall (logior platform-os-linux platform-cpu-x86 platform-word-size-64) syscalls::setfsgid 139 () ) +(define-syscall (logior platform-os-linux platform-cpu-x86 platform-word-size-64) syscalls::getdents 141 () ) +(define-syscall (logior platform-os-linux platform-cpu-x86 platform-word-size-64) syscalls::_newselect 142 () ) +(define-syscall (logior platform-os-linux platform-cpu-x86 platform-word-size-64) syscalls::flock 143 () ) +(define-syscall (logior platform-os-linux platform-cpu-x86 platform-word-size-64) syscalls::msync 26 () ) +(define-syscall (logior platform-os-linux platform-cpu-x86 platform-word-size-64) syscalls::readv 19 () ) +(define-syscall (logior platform-os-linux platform-cpu-x86 platform-word-size-64) syscalls::writev 20 () ) +(define-syscall (logior platform-os-linux platform-cpu-x86 platform-word-size-64) syscalls::getsid 147 () ) +(define-syscall (logior platform-os-linux platform-cpu-x86 platform-word-size-64) syscalls::fdatasync 148 () ) +(define-syscall (logior platform-os-linux platform-cpu-x86 platform-word-size-64) syscalls::_sysctl 149 () ) +(define-syscall (logior platform-os-linux platform-cpu-x86 platform-word-size-64) syscalls::mlock 150 () ) +(define-syscall (logior platform-os-linux platform-cpu-x86 platform-word-size-64) syscalls::munlock 151 () ) +(define-syscall (logior platform-os-linux platform-cpu-x86 platform-word-size-64) syscalls::mlockall 152 () ) +(define-syscall (logior platform-os-linux platform-cpu-x86 platform-word-size-64) syscalls::munlockall 153 () ) +(define-syscall (logior platform-os-linux platform-cpu-x86 platform-word-size-64) syscalls::sched_setparam 154 () ) +(define-syscall (logior platform-os-linux platform-cpu-x86 platform-word-size-64) syscalls::sched_getparam 155 () ) +(define-syscall (logior platform-os-linux platform-cpu-x86 platform-word-size-64) syscalls::sched_setscheduler 156 () ) +(define-syscall (logior platform-os-linux platform-cpu-x86 platform-word-size-64) syscalls::sched_getscheduler 157 () ) +(define-syscall (logior platform-os-linux platform-cpu-x86 platform-word-size-64) syscalls::sched_yield 24 () ) +(define-syscall (logior platform-os-linux platform-cpu-x86 platform-word-size-64) syscalls::sched_get_priority_max 159 () ) +(define-syscall (logior platform-os-linux platform-cpu-x86 platform-word-size-64) syscalls::sched_get_priority_min 160 () ) +(define-syscall (logior platform-os-linux platform-cpu-x86 platform-word-size-64) syscalls::sched_rr_get_interval 161 () ) +(define-syscall (logior platform-os-linux platform-cpu-x86 platform-word-size-64) syscalls::nanosleep 35 () ) +(define-syscall (logior platform-os-linux platform-cpu-x86 platform-word-size-64) syscalls::mremap 25 () ) +(define-syscall (logior platform-os-linux platform-cpu-x86 platform-word-size-64) syscalls::setresuid 164 () ) +(define-syscall (logior platform-os-linux platform-cpu-x86 platform-word-size-64) syscalls::getresuid 165 () ) +(define-syscall (logior platform-os-linux platform-cpu-x86 platform-word-size-64) syscalls::query_module 166 () ) + +(define-syscall (logior platform-os-linux platform-cpu-x86 platform-word-size-64) syscalls::nfsservctl 168 () ) +(define-syscall (logior platform-os-linux platform-cpu-x86 platform-word-size-64) syscalls::setresgid 169 () ) +(define-syscall (logior platform-os-linux platform-cpu-x86 platform-word-size-64) syscalls::getresgid 170 () ) +(define-syscall (logior platform-os-linux platform-cpu-x86 platform-word-size-64) syscalls::prctl 171 () ) +(define-syscall (logior platform-os-linux platform-cpu-x86 platform-word-size-64) syscalls::rt_sigreturn 15 () ) +(define-syscall (logior platform-os-linux platform-cpu-x86 platform-word-size-64) syscalls::rt_sigaction 13 () ) +(define-syscall (logior platform-os-linux platform-cpu-x86 platform-word-size-64) syscalls::rt_sigprocmask 14 () ) +(define-syscall (logior platform-os-linux platform-cpu-x86 platform-word-size-64) syscalls::rt_sigpending 175 () ) +(define-syscall (logior platform-os-linux platform-cpu-x86 platform-word-size-64) syscalls::rt_sigtimedwait 176 () ) +(define-syscall (logior platform-os-linux platform-cpu-x86 platform-word-size-64) syscalls::rt_sigqueueinfo 177 () ) +(define-syscall (logior platform-os-linux platform-cpu-x86 platform-word-size-64) syscalls::rt_sigsuspend 178 () ) +(define-syscall (logior platform-os-linux platform-cpu-x86 platform-word-size-64) syscalls::pread 17 () ) +(define-syscall (logior platform-os-linux platform-cpu-x86 platform-word-size-64) syscalls::pwrite 18 () ) +(define-syscall (logior platform-os-linux platform-cpu-x86 platform-word-size-64) syscalls::chown 181 (:address) ) + +(define-syscall (logior platform-os-linux platform-cpu-x86 platform-word-size-64) syscalls::capget 183 () ) +(define-syscall (logior platform-os-linux platform-cpu-x86 platform-word-size-64) syscalls::capset 184 () ) +(define-syscall (logior platform-os-linux platform-cpu-x86 platform-word-size-64) syscalls::sigaltstack 185 () ) +(define-syscall (logior platform-os-linux platform-cpu-x86 platform-word-size-64) syscalls::sendfile 40 () ) +(define-syscall (logior platform-os-linux platform-cpu-x86 platform-word-size-64) syscalls::getpmsg 187 () ) +(define-syscall (logior platform-os-linux platform-cpu-x86 platform-word-size-64) syscalls::putpmsg 188 () ) +(define-syscall (logior platform-os-linux platform-cpu-x86 platform-word-size-64) syscalls::vfork 189 () ) + +(define-syscall (logior platform-os-linux platform-cpu-x86 platform-word-size-64) syscalls::mmap 9 () ) +(define-syscall (logior platform-os-linux platform-cpu-x86 platform-word-size-64) syscalls::munmap 11 () ) + +) Index: /branches/new-random/library/x8664-solaris-syscalls.lisp =================================================================== --- /branches/new-random/library/x8664-solaris-syscalls.lisp (revision 13309) +++ /branches/new-random/library/x8664-solaris-syscalls.lisp (revision 13309) @@ -0,0 +1,493 @@ +;;;-*-Mode: LISP; Package: CCL -*- +;;; +;;; Copyright (C) 2008-2009 Clozure Associates and contributors +;;; This file is part of Clozure CL. +;;; +;;; Clozure CL is licensed under the terms of the Lisp Lesser GNU Public +;;; License , known as the LLGPL and distributed with Clozure CL as the +;;; file "LICENSE". The LLGPL consists of a preamble and the LGPL, +;;; which is distributed with Clozure CL as the file "LGPL". Where these +;;; conflict, the preamble takes precedence. +;;; +;;; Clozure CL is referenced in the preamble as the "LIBRARY." +;;; +;;; The LLGPL is also available online at +;;; http://opensource.franz.com/preamble.html + +(in-package "CCL") + +(eval-when (:compile-toplevel :load-toplevel :execute) + (require "SYSCALL")) + +(define-syscall (logior platform-os-solaris platform-cpu-x86 platform-word-size-64) syscalls::syscall 0 () :void) +(define-syscall (logior platform-os-solaris platform-cpu-x86 platform-word-size-64) syscalls::exit 1 (:int) :void) +(define-syscall (logior platform-os-solaris platform-cpu-x86 platform-word-size-64) syscalls::forkall 2 () :void) +(define-syscall (logior platform-os-solaris platform-cpu-x86 platform-word-size-64) syscalls::read 3 (:int :address :size_t) :ssize_t) +(define-syscall (logior platform-os-solaris platform-cpu-x86 platform-word-size-64) syscalls::write 4 (:int :address :size_t) :ssize_t) +(define-syscall (logior platform-os-solaris platform-cpu-x86 platform-word-size-64) syscalls::open 5 (:address :int :mode_t) :int :min-args 2) +(define-syscall (logior platform-os-solaris platform-cpu-x86 platform-word-size-64) syscalls::close 6 (:int) :int) +(define-syscall (logior platform-os-solaris platform-cpu-x86 platform-word-size-64) syscalls::wait 7 () :void) +(define-syscall (logior platform-os-solaris platform-cpu-x86 platform-word-size-64) syscalls::creat 8 (:address :mode_t) :int) +(define-syscall (logior platform-os-solaris platform-cpu-x86 platform-word-size-64) syscalls::link 9 (:address :address) :int) +(define-syscall (logior platform-os-solaris platform-cpu-x86 platform-word-size-64) syscalls::unlink 10 (:address) :int) +(define-syscall (logior platform-os-solaris platform-cpu-x86 platform-word-size-64) syscalls::exec 11 () :void) +(define-syscall (logior platform-os-solaris platform-cpu-x86 platform-word-size-64) syscalls::chdir 12 (:address) :int) +(define-syscall (logior platform-os-solaris platform-cpu-x86 platform-word-size-64) syscalls::time 13 (:address) :time_t) +(define-syscall (logior platform-os-solaris platform-cpu-x86 platform-word-size-64) syscalls::mknod 14 (:address :mode_t :dev_t) :int) +(define-syscall (logior platform-os-solaris platform-cpu-x86 platform-word-size-64) syscalls::chmod 15 (:address :mode_t) :int) +(define-syscall (logior platform-os-solaris platform-cpu-x86 platform-word-size-64) syscalls::chown 16 (:address :uid_t :gid_t) :int) +(define-syscall (logior platform-os-solaris platform-cpu-x86 platform-word-size-64) syscalls::brk 17 (:address) :int) +(define-syscall (logior platform-os-solaris platform-cpu-x86 platform-word-size-64) syscalls::stat 18 (:address :address) :int) +(define-syscall (logior platform-os-solaris platform-cpu-x86 platform-word-size-64) syscalls::lseek 19 (:int :off_t :int) :off_t) +(define-syscall (logior platform-os-solaris platform-cpu-x86 platform-word-size-64) syscalls::getpid 20 () :pid_t) +(define-syscall (logior platform-os-solaris platform-cpu-x86 platform-word-size-64) syscalls::mount 21 (:address :address :int :address :address :int :adress :int) :int) +(define-syscall (logior platform-os-solaris platform-cpu-x86 platform-word-size-64) syscalls::umount 22 (:address) :int) +(define-syscall (logior platform-os-solaris platform-cpu-x86 platform-word-size-64) syscalls::setuid 23 (:uid_t) :int) +(define-syscall (logior platform-os-solaris platform-cpu-x86 platform-word-size-64) syscalls::getuid 24 () :uid_t) +(define-syscall (logior platform-os-solaris platform-cpu-x86 platform-word-size-64) syscalls::stime 25 () :void) +(define-syscall (logior platform-os-solaris platform-cpu-x86 platform-word-size-64) syscalls::pcsample 26 () :void) +(define-syscall (logior platform-os-solaris platform-cpu-x86 platform-word-size-64) syscalls::alarm 27 () :void) +(define-syscall (logior platform-os-solaris platform-cpu-x86 platform-word-size-64) syscalls::fstat 28 (:int :address) :int) +(define-syscall (logior platform-os-solaris platform-cpu-x86 platform-word-size-64) syscalls::pause 29 () :void) +(define-syscall (logior platform-os-solaris platform-cpu-x86 platform-word-size-64) syscalls::utime 30 () :void) +(define-syscall (logior platform-os-solaris platform-cpu-x86 platform-word-size-64) syscalls::stty 31 () :void) +(define-syscall (logior platform-os-solaris platform-cpu-x86 platform-word-size-64) syscalls::gtty 32 () :void) +(define-syscall (logior platform-os-solaris platform-cpu-x86 platform-word-size-64) syscalls::access 33 () :void) +(define-syscall (logior platform-os-solaris platform-cpu-x86 platform-word-size-64) syscalls::nice 34 () :void) +(define-syscall (logior platform-os-solaris platform-cpu-x86 platform-word-size-64) syscalls::statfs 35 () :void) +(define-syscall (logior platform-os-solaris platform-cpu-x86 platform-word-size-64) syscalls::sync 36 () :void) +(define-syscall (logior platform-os-solaris platform-cpu-x86 platform-word-size-64) syscalls::kill 37 (:pid_t :int) :int) +(define-syscall (logior platform-os-solaris platform-cpu-x86 platform-word-size-64) syscalls::fstatfs 38 () :void) +(define-syscall (logior platform-os-solaris platform-cpu-x86 platform-word-size-64) syscalls::pgrpsys 39 () :void) + #|| + * subcodes: + * getpgrp() :: syscall(39,0) + * setpgrp() :: syscall(39,1) + * getsid(pid) :: syscall(39,2,pid) + * setsid() :: syscall(39,3) + * getpgid(pid) :: syscall(39,4,pid) + * setpgid(pid,pgid) :: syscall(39,5,pid,pgid) + ||# +(define-syscall (logior platform-os-solaris platform-cpu-x86 platform-word-size-64) syscalls::uucopystr 40 () :void) +(define-syscall (logior platform-os-solaris platform-cpu-x86 platform-word-size-64) syscalls::dup 41 (:int) :int) +(define-syscall (logior platform-os-solaris platform-cpu-x86 platform-word-size-64) syscalls::pipe 42 () :void) +(define-syscall (logior platform-os-solaris platform-cpu-x86 platform-word-size-64) syscalls::times 43 () :void) +(define-syscall (logior platform-os-solaris platform-cpu-x86 platform-word-size-64) syscalls::profil 44 () :void) +(define-syscall (logior platform-os-solaris platform-cpu-x86 platform-word-size-64) syscalls::plock 45 () :void) +(define-syscall (logior platform-os-solaris platform-cpu-x86 platform-word-size-64) syscalls::setgid 46 (:gid_t) :int) +(define-syscall (logior platform-os-solaris platform-cpu-x86 platform-word-size-64) syscalls::getgid 47 () :void) +(define-syscall (logior platform-os-solaris platform-cpu-x86 platform-word-size-64) syscalls::signal 48 () :void) + #|| + * subcodes: + * signal(sig, f) :: signal(sig, f) ((sig&SIGNO_MASK) == sig) + * sigset(sig, f) :: signal(sig|SIGDEFER, f) + * sighold(sig) :: signal(sig|SIGHOLD) + * sigrelse(sig) :: signal(sig|SIGRELSE) + * sigignore(sig) :: signal(sig|SIGIGNORE) + * sigpause(sig) :: signal(sig|SIGPAUSE) + * see + ||# +(define-syscall (logior platform-os-solaris platform-cpu-x86 platform-word-size-64) syscalls::msgsys 49 () :void) + #|| + * subcodes: + * msgget(...) :: msgsys(0, ...) + * msgctl(...) :: msgsys(1, ...) + * msgrcv(...) :: msgsys(2, ...) + * msgsnd(...) :: msgsys(3, ...) + * msgids(...) :: msgsys(4, ...) + * msgsnap(...) :: msgsys(5, ...) + * see + ||# +(define-syscall (logior platform-os-solaris platform-cpu-x86 platform-word-size-64) syscalls::sysi86 50 () :void) + #|| + * subcodes: + * sysi86(code, ...) + ||# +(define-syscall (logior platform-os-solaris platform-cpu-x86 platform-word-size-64) syscalls::acct 51 () :void) +(define-syscall (logior platform-os-solaris platform-cpu-x86 platform-word-size-64) syscalls::shmsys 52 () :void) + #|| + * subcodes: + * shmat (...) :: shmsys(0, ...) + * shmctl(...) :: shmsys(1, ...) + * shmdt (...) :: shmsys(2, ...) + * shmget(...) :: shmsys(3, ...) + * shmids(...) :: shmsys(4, ...) + * see + ||# +(define-syscall (logior platform-os-solaris platform-cpu-x86 platform-word-size-64) syscalls::semsys 53 () :void) + #|| + * subcodes: + * semctl(...) :: semsys(0, ...) + * semget(...) :: semsys(1, ...) + * semop (...) :: semsys(2, ...) + * semids(...) :: semsys(3, ...) + * semtimedop(...) :: semsys(4, ...) + * see + ||# +(define-syscall (logior platform-os-solaris platform-cpu-x86 platform-word-size-64) syscalls::ioctl 54 (:int :int :address) :int :min-args 2) +(define-syscall (logior platform-os-solaris platform-cpu-x86 platform-word-size-64) syscalls::uadmin 55 () :void) +(define-syscall (logior platform-os-solaris platform-cpu-x86 platform-word-size-64) syscalls::utssys 57 () :void) + #|| + * subcodes (third argument): + * uname(obuf) (obsolete) :: syscall(57, obuf, ign, 0) + * subcode 1 unused + * ustat(dev, obuf) :: syscall(57, obuf, dev, 2) + * fusers(path, flags, obuf) :: syscall(57, path, flags, 3, obuf) + * see + ||# +(define-syscall (logior platform-os-solaris platform-cpu-x86 platform-word-size-64) syscalls::fdsync 58 (:int :int) :int) +(define-syscall (logior platform-os-solaris platform-cpu-x86 platform-word-size-64) syscalls::execve 59 () :void) +(define-syscall (logior platform-os-solaris platform-cpu-x86 platform-word-size-64) syscalls::umask 60 () :void) +(define-syscall (logior platform-os-solaris platform-cpu-x86 platform-word-size-64) syscalls::chroot 61 () :void) +(define-syscall (logior platform-os-solaris platform-cpu-x86 platform-word-size-64) syscalls::fcntl 62 (:int :int :address) :int :min-args 2) +(define-syscall (logior platform-os-solaris platform-cpu-x86 platform-word-size-64) syscalls::ulimit 63 () :void) +(define-syscall (logior platform-os-solaris platform-cpu-x86 platform-word-size-64) syscalls::reserved_64 64 #|| 64 reserved ||# () :void) +(define-syscall (logior platform-os-solaris platform-cpu-x86 platform-word-size-64) syscalls::reserved_65 65 #|| 65 reserved ||# () :void) +(define-syscall (logior platform-os-solaris platform-cpu-x86 platform-word-size-64) syscalls::reserved_66 66 #|| 66 reserved ||# () :void) +(define-syscall (logior platform-os-solaris platform-cpu-x86 platform-word-size-64) syscalls::reserved_67 67 #|| 67 reserved ||# () :void) +(define-syscall (logior platform-os-solaris platform-cpu-x86 platform-word-size-64) syscalls::reserved_68 68 #|| 68 reserved ||# () :void) +(define-syscall (logior platform-os-solaris platform-cpu-x86 platform-word-size-64) syscalls::reserved_69 69 #|| 69 reserved ||# () :void) +(define-syscall (logior platform-os-solaris platform-cpu-x86 platform-word-size-64) syscalls::tasksys 70 () :void) + #|| + * subcodes: + * settaskid(...) :: tasksys(0, ...) + * gettaskid(...) :: tasksys(1, ...) + * getprojid(...) :: tasksys(2, ...) + ||# +(define-syscall (logior platform-os-solaris platform-cpu-x86 platform-word-size-64) syscalls::acctctl 71 () :void) +(define-syscall (logior platform-os-solaris platform-cpu-x86 platform-word-size-64) syscalls::exacctsys 72 () :void) + #|| + * subcodes: + * getacct(...) :: exacct(0, ...) + * putacct(...) :: exacct(1, ...) + * wracct(...) :: exacct(2, ...) + ||# +(define-syscall (logior platform-os-solaris platform-cpu-x86 platform-word-size-64) syscalls::getpagesizes 73 () :void) + #|| + * subcodes: + * getpagesizes2(...) :: getpagesizes(0, ...) + * getpagesizes(...) :: getpagesizes(1, ...) legacy + ||# +(define-syscall (logior platform-os-solaris platform-cpu-x86 platform-word-size-64) syscalls::rctlsys 74 () :void) + #|| + * subcodes: + * getrctl(...) :: rctlsys(0, ...) + * setrctl(...) :: rctlsys(1, ...) + * rctllist(...) :: rctlsys(2, ...) + * rctlctl(...) :: rctlsys(3, ...) + ||# +(define-syscall (logior platform-os-solaris platform-cpu-x86 platform-word-size-64) syscalls::sidsys 75 () :void) + #|| + * subcodes: + * allocids(...) :: sidsys(0, ...) + * idmap_reg(...) :: sidsys(1, ...) + * idmap_unreg(...) :: sidsys(2, ...) + ||# +(define-syscall (logior platform-os-solaris platform-cpu-x86 platform-word-size-64) syscalls::fsat 76 () :void) + #|| + * subcodes: + * openat(...) :: fsat(0, ...) + * openat64(...) :: fsat(1, ...) + * fstatat64(...) :: fsat(2, ...) + * fstatat(...) :: fsat(3, ...) + * renameat(...) :: fsat(4, ...) + * fchownat(...) :: fsat(5, ...) + * unlinkat(...) :: fsat(6, ...) + * futimesat(...) :: fsat(7, ...) + ||# +(define-syscall (logior platform-os-solaris platform-cpu-x86 platform-word-size-64) syscalls::lwp_park 77 () :void) + #|| + * subcodes: + * _lwp_park(timespec_t *, lwpid_t) :: syslwp_park(0, ...) + * _lwp_unpark(lwpid_t, int) :: syslwp_park(1, ...) + * _lwp_unpark_all(lwpid_t *, int) :: syslwp_park(2, ...) + * _lwp_unpark_cancel(lwpid_t *, int) :: syslwp_park(3, ...) + * _lwp_set_park(lwpid_t *, int) :: syslwp_park(4, ...) + ||# +(define-syscall (logior platform-os-solaris platform-cpu-x86 platform-word-size-64) syscalls::sendfilev 78 () :void) + #|| + * subcodes : + * sendfilev() :: sendfilev(0, ...) + * sendfilev64() :: sendfilev(1, ...) + ||# +(define-syscall (logior platform-os-solaris platform-cpu-x86 platform-word-size-64) syscalls::rmdir 79 (:address) :int) +(define-syscall (logior platform-os-solaris platform-cpu-x86 platform-word-size-64) syscalls::mkdir 80 (:address :mode_t) :int) +(define-syscall (logior platform-os-solaris platform-cpu-x86 platform-word-size-64) syscalls::getdents 81 () :void) +(define-syscall (logior platform-os-solaris platform-cpu-x86 platform-word-size-64) syscalls::privsys 82 () :void) + #|| + * subcodes: + * setppriv(...) :: privsys(0, ...) + * getppriv(...) :: privsys(1, ...) + * getimplinfo(...) :: privsys(2, ...) + * setpflags(...) :: privsys(3, ...) + * getpflags(...) :: privsys(4, ...) + * issetugid(); :: privsys(5) + ||# +(define-syscall (logior platform-os-solaris platform-cpu-x86 platform-word-size-64) syscalls::ucredsys 83 () :void) + #|| + * subcodes: + * ucred_get(...) :: ucredsys(0, ...) + * getpeerucred(...) :: ucredsys(1, ...) + ||# +(define-syscall (logior platform-os-solaris platform-cpu-x86 platform-word-size-64) syscalls::sysfs 84 () :void) + #|| + * subcodes: + * sysfs(code, ...) + * see + ||# +(define-syscall (logior platform-os-solaris platform-cpu-x86 platform-word-size-64) syscalls::getmsg 85 () :void) +(define-syscall (logior platform-os-solaris platform-cpu-x86 platform-word-size-64) syscalls::putmsg 86 () :void) +(define-syscall (logior platform-os-solaris platform-cpu-x86 platform-word-size-64) syscalls::poll 87 (:address :nfds_t :int) :int) + +(define-syscall (logior platform-os-solaris platform-cpu-x86 platform-word-size-64) syscalls::lstat 88 (:address :address) :int) +(define-syscall (logior platform-os-solaris platform-cpu-x86 platform-word-size-64) syscalls::symlink 89 () :void) +(define-syscall (logior platform-os-solaris platform-cpu-x86 platform-word-size-64) syscalls::readlink 90 () :void) +(define-syscall (logior platform-os-solaris platform-cpu-x86 platform-word-size-64) syscalls::setgroups 91 () :void) +(define-syscall (logior platform-os-solaris platform-cpu-x86 platform-word-size-64) syscalls::getgroups 92 () :void) +(define-syscall (logior platform-os-solaris platform-cpu-x86 platform-word-size-64) syscalls::fchmod 93 (:int :mode_t) :int) +(define-syscall (logior platform-os-solaris platform-cpu-x86 platform-word-size-64) syscalls::fchown 94 () :void) +(define-syscall (logior platform-os-solaris platform-cpu-x86 platform-word-size-64) syscalls::sigprocmask 95 () :void) +(define-syscall (logior platform-os-solaris platform-cpu-x86 platform-word-size-64) syscalls::sigsuspend 96 () :void) +(define-syscall (logior platform-os-solaris platform-cpu-x86 platform-word-size-64) syscalls::sigaltstack 97 () :void) +(define-syscall (logior platform-os-solaris platform-cpu-x86 platform-word-size-64) syscalls::sigaction 98 () :void) +(define-syscall (logior platform-os-solaris platform-cpu-x86 platform-word-size-64) syscalls::sigpending 99 () :void) + #|| + * subcodes: + * subcode 0 unused + * sigpending(...) :: syscall(99, 1, ...) + * sigfillset(...) :: syscall(99, 2, ...) + ||# +(define-syscall (logior platform-os-solaris platform-cpu-x86 platform-word-size-64) syscalls::context 100 () :void) + #|| + * subcodes: + * getcontext(...) :: syscall(100, 0, ...) + * setcontext(...) :: syscall(100, 1, ...) + ||# +(define-syscall (logior platform-os-solaris platform-cpu-x86 platform-word-size-64) syscalls::evsys 101 () :void) +(define-syscall (logior platform-os-solaris platform-cpu-x86 platform-word-size-64) syscalls::evtrapret 102 () :void) +(define-syscall (logior platform-os-solaris platform-cpu-x86 platform-word-size-64) syscalls::statvfs 103 () :void) +(define-syscall (logior platform-os-solaris platform-cpu-x86 platform-word-size-64) syscalls::fstatvfs 104 () :void) +(define-syscall (logior platform-os-solaris platform-cpu-x86 platform-word-size-64) syscalls::getloadavg 105 () :void) +(define-syscall (logior platform-os-solaris platform-cpu-x86 platform-word-size-64) syscalls::nfssys 106 () :void) +(define-syscall (logior platform-os-solaris platform-cpu-x86 platform-word-size-64) syscalls::waitid 107 () :void) +(define-syscall (logior platform-os-solaris platform-cpu-x86 platform-word-size-64) syscalls::sigsendsys 108 () :void) +(define-syscall (logior platform-os-solaris platform-cpu-x86 platform-word-size-64) syscalls::hrtsys 109 () :void) +(define-syscall (logior platform-os-solaris platform-cpu-x86 platform-word-size-64) syscalls::sigresend 111 () :void) +(define-syscall (logior platform-os-solaris platform-cpu-x86 platform-word-size-64) syscalls::priocntlsys 112 () :void) +(define-syscall (logior platform-os-solaris platform-cpu-x86 platform-word-size-64) syscalls::pathconf 113 () :void) +(define-syscall (logior platform-os-solaris platform-cpu-x86 platform-word-size-64) syscalls::mincore 114 () :void) +(define-syscall (logior platform-os-solaris platform-cpu-x86 platform-word-size-64) syscalls::mmap 115 () :void) +(define-syscall (logior platform-os-solaris platform-cpu-x86 platform-word-size-64) syscalls::mprotect 116 () :void) +(define-syscall (logior platform-os-solaris platform-cpu-x86 platform-word-size-64) syscalls::munmap 117 () :void) +(define-syscall (logior platform-os-solaris platform-cpu-x86 platform-word-size-64) syscalls::fpathconf 118 () :void) +(define-syscall (logior platform-os-solaris platform-cpu-x86 platform-word-size-64) syscalls::vfork 119 () :void) +(define-syscall (logior platform-os-solaris platform-cpu-x86 platform-word-size-64) syscalls::fchdir 120 () :void) +(define-syscall (logior platform-os-solaris platform-cpu-x86 platform-word-size-64) syscalls::readv 121 () :void) +(define-syscall (logior platform-os-solaris platform-cpu-x86 platform-word-size-64) syscalls::writev 122 () :void) +(define-syscall (logior platform-os-solaris platform-cpu-x86 platform-word-size-64) syscalls::xstat 123 () :void) +(define-syscall (logior platform-os-solaris platform-cpu-x86 platform-word-size-64) syscalls::lxstat 124 () :void) +(define-syscall (logior platform-os-solaris platform-cpu-x86 platform-word-size-64) syscalls::fxstat 125 () :void) +(define-syscall (logior platform-os-solaris platform-cpu-x86 platform-word-size-64) syscalls::xmknod 126 () :void) +(define-syscall (logior platform-os-solaris platform-cpu-x86 platform-word-size-64) syscalls::setrlimit 128 () :void) +(define-syscall (logior platform-os-solaris platform-cpu-x86 platform-word-size-64) syscalls::getrlimit 129 () :void) +(define-syscall (logior platform-os-solaris platform-cpu-x86 platform-word-size-64) syscalls::lchown 130 () :void) +(define-syscall (logior platform-os-solaris platform-cpu-x86 platform-word-size-64) syscalls::memcntl 131 () :void) +(define-syscall (logior platform-os-solaris platform-cpu-x86 platform-word-size-64) syscalls::getpmsg 132 () :void) +(define-syscall (logior platform-os-solaris platform-cpu-x86 platform-word-size-64) syscalls::putpmsg 133 () :void) +(define-syscall (logior platform-os-solaris platform-cpu-x86 platform-word-size-64) syscalls::rename 134 () :void) +(define-syscall (logior platform-os-solaris platform-cpu-x86 platform-word-size-64) syscalls::uname 135 () :void) +(define-syscall (logior platform-os-solaris platform-cpu-x86 platform-word-size-64) syscalls::setegid 136 () :void) +(define-syscall (logior platform-os-solaris platform-cpu-x86 platform-word-size-64) syscalls::sysconfig 137 () :void) +(define-syscall (logior platform-os-solaris platform-cpu-x86 platform-word-size-64) syscalls::adjtime 138 () :void) +(define-syscall (logior platform-os-solaris platform-cpu-x86 platform-word-size-64) syscalls::systeminfo 139 () :void) +(define-syscall (logior platform-os-solaris platform-cpu-x86 platform-word-size-64) syscalls::sharefs 140 () :void) +(define-syscall (logior platform-os-solaris platform-cpu-x86 platform-word-size-64) syscalls::seteuid 141 () :void) +(define-syscall (logior platform-os-solaris platform-cpu-x86 platform-word-size-64) syscalls::forksys 142 () :void) + #|| + * subcodes: + * forkx(flags) :: forksys(0, flags) + * forkallx(flags) :: forksys(1, flags) + * vforkx(flags) :: forksys(2, flags) + ||# +(define-syscall (logior platform-os-solaris platform-cpu-x86 platform-word-size-64) syscalls::fork1 143 () :void) +(define-syscall (logior platform-os-solaris platform-cpu-x86 platform-word-size-64) syscalls::sigtimedwait 144 () :void) +(define-syscall (logior platform-os-solaris platform-cpu-x86 platform-word-size-64) syscalls::lwp_info 145 () :void) +(define-syscall (logior platform-os-solaris platform-cpu-x86 platform-word-size-64) syscalls::yield 146 () :void) +(define-syscall (logior platform-os-solaris platform-cpu-x86 platform-word-size-64) syscalls::lwp_sema_wait 147 () :void) +(define-syscall (logior platform-os-solaris platform-cpu-x86 platform-word-size-64) syscalls::lwp_sema_post 148 () :void) +(define-syscall (logior platform-os-solaris platform-cpu-x86 platform-word-size-64) syscalls::lwp_sema_trywait 149 () :void) +(define-syscall (logior platform-os-solaris platform-cpu-x86 platform-word-size-64) syscalls::lwp_detach 150 () :void) +(define-syscall (logior platform-os-solaris platform-cpu-x86 platform-word-size-64) syscalls::corectl 151 () :void) +(define-syscall (logior platform-os-solaris platform-cpu-x86 platform-word-size-64) syscalls::modctl 152 () :void) +(define-syscall (logior platform-os-solaris platform-cpu-x86 platform-word-size-64) syscalls::fchroot 153 () :void) +(define-syscall (logior platform-os-solaris platform-cpu-x86 platform-word-size-64) syscalls::utimes 154 () :void) +(define-syscall (logior platform-os-solaris platform-cpu-x86 platform-word-size-64) syscalls::vhangup 155 () :void) +(define-syscall (logior platform-os-solaris platform-cpu-x86 platform-word-size-64) syscalls::gettimeofday 156 () :void) +(define-syscall (logior platform-os-solaris platform-cpu-x86 platform-word-size-64) syscalls::getitimer 157 () :void) +(define-syscall (logior platform-os-solaris platform-cpu-x86 platform-word-size-64) syscalls::setitimer 158 () :void) +(define-syscall (logior platform-os-solaris platform-cpu-x86 platform-word-size-64) syscalls::lwp_create 159 () :void) +(define-syscall (logior platform-os-solaris platform-cpu-x86 platform-word-size-64) syscalls::lwp_exit 160 () :void) +(define-syscall (logior platform-os-solaris platform-cpu-x86 platform-word-size-64) syscalls::lwp_suspend 161 () :void) +(define-syscall (logior platform-os-solaris platform-cpu-x86 platform-word-size-64) syscalls::lwp_continue 162 () :void) +(define-syscall (logior platform-os-solaris platform-cpu-x86 platform-word-size-64) syscalls::lwp_kill 163 () :void) +(define-syscall (logior platform-os-solaris platform-cpu-x86 platform-word-size-64) syscalls::lwp_self 164 () :void) +(define-syscall (logior platform-os-solaris platform-cpu-x86 platform-word-size-64) syscalls::lwp_sigmask 165 () :void) +(define-syscall (logior platform-os-solaris platform-cpu-x86 platform-word-size-64) syscalls::lwp_private 166 () :void) +(define-syscall (logior platform-os-solaris platform-cpu-x86 platform-word-size-64) syscalls::lwp_wait 167 () :void) +(define-syscall (logior platform-os-solaris platform-cpu-x86 platform-word-size-64) syscalls::lwp_mutex_wakeup 168 () :void) +(define-syscall (logior platform-os-solaris platform-cpu-x86 platform-word-size-64) syscalls::lwp_mutex_lock 169 () :void) +(define-syscall (logior platform-os-solaris platform-cpu-x86 platform-word-size-64) syscalls::lwp_cond_wait 170 () :void) +(define-syscall (logior platform-os-solaris platform-cpu-x86 platform-word-size-64) syscalls::lwp_cond_signal 171 () :void) +(define-syscall (logior platform-os-solaris platform-cpu-x86 platform-word-size-64) syscalls::lwp_cond_broadcast 172 () :void) +(define-syscall (logior platform-os-solaris platform-cpu-x86 platform-word-size-64) syscalls::pread 173 () :void) +(define-syscall (logior platform-os-solaris platform-cpu-x86 platform-word-size-64) syscalls::pwrite 174 () :void) +(define-syscall (logior platform-os-solaris platform-cpu-x86 platform-word-size-64) syscalls::llseek 175 () :void) +(define-syscall (logior platform-os-solaris platform-cpu-x86 platform-word-size-64) syscalls::inst_sync 176 () :void) +(define-syscall (logior platform-os-solaris platform-cpu-x86 platform-word-size-64) syscalls::brand 177 () :void) +(define-syscall (logior platform-os-solaris platform-cpu-x86 platform-word-size-64) syscalls::kaio 178 () :void) + #|| + * subcodes: + * aioread(...) :: kaio(AIOREAD, ...) + * aiowrite(...) :: kaio(AIOWRITE, ...) + * aiowait(...) :: kaio(AIOWAIT, ...) + * aiocancel(...) :: kaio(AIOCANCEL, ...) + * aionotify() :: kaio(AIONOTIFY) + * aioinit() :: kaio(AIOINIT) + * aiostart() :: kaio(AIOSTART) + * see + ||# +(define-syscall (logior platform-os-solaris platform-cpu-x86 platform-word-size-64) syscalls::cpc 179 () :void) +(define-syscall (logior platform-os-solaris platform-cpu-x86 platform-word-size-64) syscalls::lgrpsys 180 () :void) + #|| + * subcodes: + * meminfo(...) :: meminfosys(MIsyscalls::MEMINFO, ...) + ||# +(define-syscall (logior platform-os-solaris platform-cpu-x86 platform-word-size-64) syscalls::rusagesys 181 (:int :int :address) :int) + #|| + * subcodes: + * getrusage(...) :: rusagesys(RUSAGEsyscalls::GETRUSAGE, ...) + * getvmusage(...) :: rusagesys(RUSAGEsyscalls::GETVMUSAGE, ...) + ||# +(define-syscall (logior platform-os-solaris platform-cpu-x86 platform-word-size-64) syscalls::port 182 () :void) + #|| + * subcodes: + * port_create(...) :: portfs(PORT_CREATE, ...) + * port_associate(...) :: portfs(PORT_ASSOCIATE, ...) + * port_dissociate(...) :: portfs(PORT_DISSOCIATE, ...) + * port_send(...) :: portfs(PORT_SEND, ...) + * port_sendn(...) :: portfs(PORT_SENDN, ...) + * port_get(...) :: portfs(PORT_GET, ...) + * port_getn(...) :: portfs(PORT_GETN, ...) + * port_alert(...) :: portfs(PORT_ALERT, ...) + * port_dispatch(...) :: portfs(PORT_DISPATCH, ...) + ||# +(define-syscall (logior platform-os-solaris platform-cpu-x86 platform-word-size-64) syscalls::pollsys 183 () :void) +(define-syscall (logior platform-os-solaris platform-cpu-x86 platform-word-size-64) syscalls::labelsys 184 () :void) +(define-syscall (logior platform-os-solaris platform-cpu-x86 platform-word-size-64) syscalls::acl 185 () :void) +(define-syscall (logior platform-os-solaris platform-cpu-x86 platform-word-size-64) syscalls::auditsys 186 () :void) +(define-syscall (logior platform-os-solaris platform-cpu-x86 platform-word-size-64) syscalls::processor_bind 187 () :void) +(define-syscall (logior platform-os-solaris platform-cpu-x86 platform-word-size-64) syscalls::processor_info 188 () :void) +(define-syscall (logior platform-os-solaris platform-cpu-x86 platform-word-size-64) syscalls::p_online 189 () :void) +(define-syscall (logior platform-os-solaris platform-cpu-x86 platform-word-size-64) syscalls::sigqueue 190 () :void) +(define-syscall (logior platform-os-solaris platform-cpu-x86 platform-word-size-64) syscalls::clock_gettime 191 () :void) +(define-syscall (logior platform-os-solaris platform-cpu-x86 platform-word-size-64) syscalls::clock_settime 192 () :void) +(define-syscall (logior platform-os-solaris platform-cpu-x86 platform-word-size-64) syscalls::clock_getres 193 () :void) +(define-syscall (logior platform-os-solaris platform-cpu-x86 platform-word-size-64) syscalls::timer_create 194 () :void) +(define-syscall (logior platform-os-solaris platform-cpu-x86 platform-word-size-64) syscalls::timer_delete 195 () :void) +(define-syscall (logior platform-os-solaris platform-cpu-x86 platform-word-size-64) syscalls::timer_settime 196 () :void) +(define-syscall (logior platform-os-solaris platform-cpu-x86 platform-word-size-64) syscalls::timer_gettime 197 () :void) +(define-syscall (logior platform-os-solaris platform-cpu-x86 platform-word-size-64) syscalls::timer_getoverrun 198 () :void) +(define-syscall (logior platform-os-solaris platform-cpu-x86 platform-word-size-64) syscalls::nanosleep 199 () :void) +(define-syscall (logior platform-os-solaris platform-cpu-x86 platform-word-size-64) syscalls::facl 200 () :void) +(define-syscall (logior platform-os-solaris platform-cpu-x86 platform-word-size-64) syscalls::door 201 () :void) + #|| + * Door Subcodes: + * 0 door_create + * 1 door_revoke + * 2 door_info + * 3 door_call + * 4 door_return + ||# +(define-syscall (logior platform-os-solaris platform-cpu-x86 platform-word-size-64) syscalls::setreuid 202 () :void) +(define-syscall (logior platform-os-solaris platform-cpu-x86 platform-word-size-64) syscalls::setregid 203 () :void) +(define-syscall (logior platform-os-solaris platform-cpu-x86 platform-word-size-64) syscalls::install_utrap 204 () :void) +(define-syscall (logior platform-os-solaris platform-cpu-x86 platform-word-size-64) syscalls::signotify 205 () :void) +(define-syscall (logior platform-os-solaris platform-cpu-x86 platform-word-size-64) syscalls::schedctl 206 () :void) +(define-syscall (logior platform-os-solaris platform-cpu-x86 platform-word-size-64) syscalls::pset 207 () :void) +(define-syscall (logior platform-os-solaris platform-cpu-x86 platform-word-size-64) syscalls::sparc_utrap_install 208 () :void) +(define-syscall (logior platform-os-solaris platform-cpu-x86 platform-word-size-64) syscalls::resolvepath 209 () :void) +(define-syscall (logior platform-os-solaris platform-cpu-x86 platform-word-size-64) syscalls::lwp_mutex_timedlock 210 () :void) +(define-syscall (logior platform-os-solaris platform-cpu-x86 platform-word-size-64) syscalls::lwp_sema_timedwait 211 () :void) +(define-syscall (logior platform-os-solaris platform-cpu-x86 platform-word-size-64) syscalls::lwp_rwlock_sys 212 () :void) + #|| + * subcodes: + * lwp_rwlock_rdlock(...) :: syscall(212, 0, ...) + * lwp_rwlock_wrlock(...) :: syscall(212, 1, ...) + * lwp_rwlock_tryrdlock(...) :: syscall(212, 2, ...) + * lwp_rwlock_trywrlock(...) :: syscall(212, 3, ...) + * lwp_rwlock_unlock(...) :: syscall(212, 4, ...) + ||# +#|| system calls for large file ( > 2 gigabyte) support ||# +(define-syscall (logior platform-os-solaris platform-cpu-x86 platform-word-size-64) syscalls::getdents64 213 () :void) +(define-syscall (logior platform-os-solaris platform-cpu-x86 platform-word-size-64) syscalls::mmap64 214 () :void) +(define-syscall (logior platform-os-solaris platform-cpu-x86 platform-word-size-64) syscalls::stat64 215 () :void) +(define-syscall (logior platform-os-solaris platform-cpu-x86 platform-word-size-64) syscalls::lstat64 216 () :void) +(define-syscall (logior platform-os-solaris platform-cpu-x86 platform-word-size-64) syscalls::fstat64 217 () :void) +(define-syscall (logior platform-os-solaris platform-cpu-x86 platform-word-size-64) syscalls::statvfs64 218 () :void) +(define-syscall (logior platform-os-solaris platform-cpu-x86 platform-word-size-64) syscalls::fstatvfs64 219 () :void) +(define-syscall (logior platform-os-solaris platform-cpu-x86 platform-word-size-64) syscalls::setrlimit64 220 () :void) +(define-syscall (logior platform-os-solaris platform-cpu-x86 platform-word-size-64) syscalls::getrlimit64 221 () :void) +(define-syscall (logior platform-os-solaris platform-cpu-x86 platform-word-size-64) syscalls::pread64 222 () :void) +(define-syscall (logior platform-os-solaris platform-cpu-x86 platform-word-size-64) syscalls::pwrite64 223 () :void) +(define-syscall (logior platform-os-solaris platform-cpu-x86 platform-word-size-64) syscalls::creat64 224 () :void) +(define-syscall (logior platform-os-solaris platform-cpu-x86 platform-word-size-64) syscalls::open64 225 () :void) +(define-syscall (logior platform-os-solaris platform-cpu-x86 platform-word-size-64) syscalls::rpcsys 226 () :void) +(define-syscall (logior platform-os-solaris platform-cpu-x86 platform-word-size-64) syscalls::zone 227 () :void) + #|| + * subcodes: + * zone_create(...) :: zone(ZONE_CREATE, ...) + * zone_destroy(...) :: zone(ZONE_DESTROY, ...) + * zone_getattr(...) :: zone(ZONE_GETATTR, ...) + * zone_enter(...) :: zone(ZONE_ENTER, ...) + * zone_list(...) :: zone(ZONE_LIST, ...) + * zone_shutdown(...) :: zone(ZONE_SHUTDOWN, ...) + * zone_lookup(...) :: zone(ZONE_LOOKUP, ...) + * zone_boot(...) :: zone(ZONE_BOOT, ...) + * zone_version(...) :: zone(ZONE_VERSION, ...) + * zone_setattr(...) :: zone(ZONE_SETATTR, ...) + * zone_add_datalink(...) :: zone(ZONE_ADD_DATALINK, ...) + * zone_remove_datalink(...) :: zone(ZONE_DEL_DATALINK, ...) + * zone_check_datalink(...) :: zone(ZONE_CHECK_DATALINK, ...) + * zone_list_datalink(...) :: zone(ZONE_LIST_DATALINK, ...) + ||# +(define-syscall (logior platform-os-solaris platform-cpu-x86 platform-word-size-64) syscalls::autofssys 228 () :void) +(define-syscall (logior platform-os-solaris platform-cpu-x86 platform-word-size-64) syscalls::getcwd 229 () :void) +(define-syscall (logior platform-os-solaris platform-cpu-x86 platform-word-size-64) syscalls::so_socket 230 (:int :int :int :address :int) :int) +(define-syscall (logior platform-os-solaris platform-cpu-x86 platform-word-size-64) syscalls::so_socketpair 231 (:address) :int) +(define-syscall (logior platform-os-solaris platform-cpu-x86 platform-word-size-64) syscalls::bind 232 (:int :address :socklen_t) :int) +(define-syscall (logior platform-os-solaris platform-cpu-x86 platform-word-size-64) syscalls::listen 233 (:int :int) :int) +(define-syscall (logior platform-os-solaris platform-cpu-x86 platform-word-size-64) syscalls::accept 234 (:int :address :address) :int) +(define-syscall (logior platform-os-solaris platform-cpu-x86 platform-word-size-64) syscalls::connect 235 (:int :address :socklen_t) :int) +(define-syscall (logior platform-os-solaris platform-cpu-x86 platform-word-size-64) syscalls::shutdown 236 (:int :int) :int) +(define-syscall (logior platform-os-solaris platform-cpu-x86 platform-word-size-64) syscalls::recv 237 () :void) +(define-syscall (logior platform-os-solaris platform-cpu-x86 platform-word-size-64) syscalls::recvfrom 238 (:int :address :size_t :int :address :address) :int) +(define-syscall (logior platform-os-solaris platform-cpu-x86 platform-word-size-64) syscalls::recvmsg 239 (:int :address :int) :int) +(define-syscall (logior platform-os-solaris platform-cpu-x86 platform-word-size-64) syscalls::send 240 () :void) +(define-syscall (logior platform-os-solaris platform-cpu-x86 platform-word-size-64) syscalls::sendmsg 241 (:int :address :int) :int) +(define-syscall (logior platform-os-solaris platform-cpu-x86 platform-word-size-64) syscalls::sendto 242 (:int :address :size_t :int :address :socklen_t) :int) +(define-syscall (logior platform-os-solaris platform-cpu-x86 platform-word-size-64) syscalls::getpeername 243 (:int :address :address) :int) +(define-syscall (logior platform-os-solaris platform-cpu-x86 platform-word-size-64) syscalls::getsockname 244 (:int :address :address) :int) +(define-syscall (logior platform-os-solaris platform-cpu-x86 platform-word-size-64) syscalls::getsockopt 245 (:int :int :int :address :address) :int) +(define-syscall (logior platform-os-solaris platform-cpu-x86 platform-word-size-64) syscalls::setsockopt 246 (:int :int :int :address :socklen_t) :int) +(define-syscall (logior platform-os-solaris platform-cpu-x86 platform-word-size-64) syscalls::sockconfig 247 () :void) + #|| + * NTP codes + ||# +(define-syscall (logior platform-os-solaris platform-cpu-x86 platform-word-size-64) syscalls::ntp_gettime 248 () :void) +(define-syscall (logior platform-os-solaris platform-cpu-x86 platform-word-size-64) syscalls::ntp_adjtime 249 () :void) +(define-syscall (logior platform-os-solaris platform-cpu-x86 platform-word-size-64) syscalls::lwp_mutex_unlock 250 () :void) +(define-syscall (logior platform-os-solaris platform-cpu-x86 platform-word-size-64) syscalls::lwp_mutex_trylock 251 () :void) +(define-syscall (logior platform-os-solaris platform-cpu-x86 platform-word-size-64) syscalls::lwp_mutex_register 252 () :void) +(define-syscall (logior platform-os-solaris platform-cpu-x86 platform-word-size-64) syscalls::cladm 253 () :void) +(define-syscall (logior platform-os-solaris platform-cpu-x86 platform-word-size-64) syscalls::uucopy 254 () :void) +(define-syscall (logior platform-os-solaris platform-cpu-x86 platform-word-size-64) syscalls::umount2 255 () :void) Index: /branches/new-random/lisp-kernel/.cvsignore =================================================================== --- /branches/new-random/lisp-kernel/.cvsignore (revision 13309) +++ /branches/new-random/lisp-kernel/.cvsignore (revision 13309) @@ -0,0 +1,1 @@ +*~.* Index: /branches/new-random/lisp-kernel/Threads.h =================================================================== --- /branches/new-random/lisp-kernel/Threads.h (revision 13309) +++ /branches/new-random/lisp-kernel/Threads.h (revision 13309) @@ -0,0 +1,275 @@ +/* + Copyright (C) 2009 Clozure Associates + Copyright (C) 1994-2001 Digitool, Inc + This file is part of Clozure CL. + + Clozure CL is licensed under the terms of the Lisp Lesser GNU Public + License , known as the LLGPL and distributed with Clozure CL as the + file "LICENSE". The LLGPL consists of a preamble and the LGPL, + which is distributed with Clozure CL as the file "LGPL". Where these + conflict, the preamble takes precedence. + + Clozure CL is referenced in the preamble as the "LIBRARY." + + The LLGPL is also available online at + http://opensource.franz.com/preamble.html +*/ + +#include +#ifndef WINDOWS +#include +#include +#endif +#undef __argv +#include +#ifndef WINDOWS +#include +#endif +#ifdef WINDOWS +#include +#endif +#include +#include + +#ifdef SOLARIS +#include +#include +#endif + +#ifdef LINUX +#include +#endif + +#undef USE_MACH_SEMAPHORES +#define USE_POSIX_SEMAPHORES +#undef USE_WINDOWS_SEMAPHORES + +#ifdef DARWIN +#define USE_MACH_SEMAPHORES 1 +#undef USE_POSIX_SEMAPHORES +#endif +#ifdef WINDOWS +#define USE_WINDOWS_SEMAPHORES 1 +#undef USE_POSIX_SEMAPHORES +#ifdef WIN_32 +struct timespec { + int tv_sec; + int tv_nsec; +}; +#endif +#endif + +#ifdef USE_POSIX_SEMAPHORES +#include +#endif + + +#ifdef USE_MACH_SEMAPHORES +/* We have to use Mach semaphores, even if we're otherwise + using POSIX signals, etc. */ +#include +#include +#endif + +#include + +#ifdef FREEBSD +#include +#endif + +#ifndef WINDOWS +#include +#endif + +#include "lisp.h" +#include "lisp_globals.h" +#include "gc.h" + +#ifdef USE_FUTEX +#ifndef FUTEX_WAIT +#define FUTEX_WAIT (0) +#endif +#ifndef FUTEX_WAKE +#define FUTEX_WAKE (1) +#endif +#include +#endif + +#ifndef WINDOWS +#include +#endif + +Boolean extern threads_initialized; +Boolean extern log_tcr_info; + +#define LOCK_SPINLOCK(x,tcr) get_spin_lock(&(x),tcr) +#define RELEASE_SPINLOCK(x) (x)=0 + +#define TCR_TO_TSD(tcr) ((void *)((natural)(tcr)+TCR_BIAS)) +#define TCR_FROM_TSD(tsd) ((TCR *)((natural)(tsd)-TCR_BIAS)) + +#ifdef USE_WINDOWS_SEMAPHORES + +typedef void * SEMAPHORE; +#define SEM_WAIT(s) WaitForSingleObject(s,INFINITE) +#define SEM_RAISE(s) ReleaseSemaphore(s, 1L, NULL) +#define SEM_BROADCAST(s, count) do {while(count) {SEM_RAISE(s);(count)--;}}while(0) +#define SEM_TIMEDWAIT(s,t) WaitOnSingleObject(s,t) + +#endif +#ifdef USE_POSIX_SEMAPHORES +typedef sem_t * SEMAPHORE; +#define SEM_WAIT(s) sem_wait((SEMAPHORE)s) +#define SEM_RAISE(s) sem_post((SEMAPHORE)s) +#define SEM_BROADCAST(s, count) do {while(count) {SEM_RAISE(s);(count)--;}}while(0) +#define SEM_TIMEDWAIT(s,t) sem_timedwait((SEMAPHORE)s,(struct timespec *)t) +#endif + +#ifdef USE_MACH_SEMAPHORES +typedef semaphore_t SEMAPHORE; +#define SEM_WAIT(s) semaphore_wait((SEMAPHORE)(natural)s) +#define SEM_RAISE(s) semaphore_signal((SEMAPHORE)(natural)s) +#define SEM_BROADCAST(s,count)semaphore_signal_all((SEMAPHORE)(natural)s) +#define SEM_TIMEDWAIT(s,t) semaphore_timedwait((SEMAPHORE)(natural)s,t) +#endif + +void sem_wait_forever(SEMAPHORE s); + +#ifdef USE_POSIX_SEMAPHORES +#define SEM_WAIT_FOREVER(s) sem_wait_forever((SEMAPHORE)s) +#endif + +#ifdef USE_MACH_SEMAPHORES +#define SEM_WAIT_FOREVER(s) sem_wait_forever((SEMAPHORE)(natural)s) +#endif + +#ifdef USE_WINDOWS_SEMAPHORES +#define SEM_WAIT_FOREVER(s) sem_wait_forever((SEMAPHORE)s) +#endif + +typedef struct +{ + signed_natural avail; + TCR* owner; + signed_natural count; + void* signal; + signed_natural waiting; + void *malloced_ptr; + signed_natural spinlock; +} _recursive_lock, *RECURSIVE_LOCK; + + +int lock_recursive_lock(RECURSIVE_LOCK, TCR *); +int unlock_recursive_lock(RECURSIVE_LOCK, TCR *); +RECURSIVE_LOCK new_recursive_lock(void); +void destroy_recursive_lock(RECURSIVE_LOCK); +int recursive_lock_trylock(RECURSIVE_LOCK, TCR *, int *); + +#define LOCK(m, t) lock_recursive_lock((RECURSIVE_LOCK)ptr_from_lispobj(m), (TCR *)t) +#define UNLOCK(m, t) unlock_recursive_lock((RECURSIVE_LOCK)ptr_from_lispobj(m), (TCR *)t) + +/* Hmm. This doesn't look like the MacOS Thread Manager ... */ +LispObj current_thread_osid(void); +void *current_native_thread_id(void); +void *new_semaphore(int); +void destroy_semaphore(void**); +void tsd_set(LispObj, void *); +void *tsd_get(LispObj); +TCR *new_tcr(natural, natural); +TCR *initial_thread_tcr; + +#define DEFAULT_THREAD_STACK_SIZE ((size_t) -1) +#define MINIMAL_THREAD_STACK_SIZE ((size_t) 0) + + +LispObj create_system_thread(size_t stack_size, + void* stackaddr, +#ifdef WINDOWS + unsigned CALLBACK (*start_routine)(void *) +#else + void* (*start_routine)(void *) +#endif + , + void* param); + +TCR *get_tcr(Boolean); +TCR *get_interrupt_tcr(Boolean); +Boolean suspend_tcr(TCR *); +Boolean resume_tcr(TCR *); + +typedef struct +{ + signed_natural spin; /* need spin lock to change fields */ + signed_natural state; /* 0 = free, positive if writer, negative if readers; */ + natural blocked_writers; + natural blocked_readers; + TCR *writer; +#ifdef USE_FUTEX + natural reader_signal; + natural writer_signal; +#else + void * reader_signal; + void * writer_signal; +#endif + void *malloced_ptr; +} rwlock; + + +rwlock * rwlock_new(void); +void rwlock_destroy(rwlock *); +int rwlock_rlock(rwlock *, TCR *, struct timespec *); +int rwlock_wlock(rwlock *, TCR *, struct timespec *); +int rwlock_try_wlock(rwlock *, TCR *); +int rwlock_try_rlock(rwlock *, TCR *); +int rwlock_unlock(rwlock *, TCR *); + + +natural +atomic_and(natural*, natural); + +natural +atomic_ior(natural*, natural); + +#define SET_TCR_FLAG(t,bit) atomic_ior(&(t->flags),(1L<flags),~(1L<succ sense) those that don't (stacks). + The list header's "area" pointer is an "AREA_VOID" area; the header + (once allocated during kernel initialization) never + moves or changes. Lisp code can get its hands on + the list header via a nilreg global, and carefully, + atomically, traverse it to do ROOM, etc. +*/ + + +area *new_area(BytePtr, BytePtr, area_code); +void add_area(area *, TCR *); +void add_area_holding_area_lock(area *); +void condemn_area(area *, TCR *); +void condemn_area_holding_area_lock(area *); +area *area_containing(BytePtr); +area *stack_area_containing(BytePtr); +area *heap_area_containing(BytePtr); +void tenure_to_area(area *); +void untenure_from_area(area *); + +/* serialize add_area/remove_area, and also the tcr queue */ +void *tcr_area_lock; + +#define reserved_area ((area *)(all_areas)) +#define active_dynamic_area ((area *)(reserved_area->succ)) + +typedef struct area_list { + area *the_area; + struct area_list *next; +} area_list; + +/* The useable size of a tsp or vsp stack segment. + */ +/* #define STACK_SEGMENT_SIZE (64<<10) */ +#define MIN_CSTACK_SIZE (1<<17) +#define CSTACK_HARDPROT (100<<10) +#define CSTACK_SOFTPROT (100<<10) +#define MIN_VSTACK_SIZE (1<<16) +#define VSTACK_HARDPROT (1<<12) +#define VSTACK_SOFTPROT (1<<16) +#define MIN_TSTACK_SIZE (1<<18) +#define TSTACK_HARDPROT 0 +#define TSTACK_SOFTPROT (1<<16) +#ifdef PPC +#define CS_OVERFLOW_FORCE_LIMIT ((natural)(-(sizeof(lisp_frame)))) +#endif + +#ifdef X86 +#define CS_OVERFLOW_FORCE_LIMIT ((natural)(-16)) +#endif + + +#ifdef PPC +#ifdef LINUX +#ifdef PPC64 +#define IMAGE_BASE_ADDRESS 0x50000000000L +#else +#define IMAGE_BASE_ADDRESS 0x31000000 +#endif +#endif +#ifdef DARWIN +#ifdef PPC64 +#define IMAGE_BASE_ADDRESS 0x300000000000L +#else +#define IMAGE_BASE_ADDRESS 0x04000000 +#endif +#endif +#endif + +#ifdef X86 +#ifdef LINUX +#ifdef X8664 +#define IMAGE_BASE_ADDRESS 0x300000000000L +#else +#define IMAGE_BASE_ADDRESS 0x10000000 +#endif +#endif +#ifdef FREEBSD +#ifdef X8664 +#define IMAGE_BASE_ADDRESS 0x300000000000L /* 0x100000000L */ +#else +#define IMAGE_BASE_ADDRESS 0x30000000 +#endif +#endif +#ifdef SOLARIS +#ifdef X8664 +#define IMAGE_BASE_ADDRESS 0x300000000000L +#else +#define IMAGE_BASE_ADDRESS 0x10000000 +#endif +#endif +#ifdef DARWIN +#ifdef X8664 +#define IMAGE_BASE_ADDRESS 0x300000000000L +#else +#define IMAGE_BASE_ADDRESS 0x04000000 +#endif +#endif +#endif +#ifdef WINDOWS +#ifdef X8664 +#define IMAGE_BASE_ADDRESS 0x100000000LL +#else +#define IMAGE_BASE_ADDRESS 0x04000000 +#endif +#endif + +#if (WORD_SIZE==64) +#define PURESPACE_RESERVE 0x2000000000LL /* 128 GB */ +#define PURESPACE_SIZE (1LL<<30LL) +#else +#define PURESPACE_RESERVE (128<<20) /* MB */ +#define PURESPACE_SIZE (64<<20) +#endif + +#define STATIC_RESERVE heap_segment_size + +#ifndef X86 +#define STATIC_BASE_ADDRESS (0x00002000+(LOWMEM_BIAS)) +#else +#define STATIC_BASE_ADDRESS (0x00012000+(LOWMEM_BIAS)) +#endif + +#define SPJUMP_TARGET_ADDRESS (STATIC_BASE_ADDRESS+0x3000) + +extern LispObj image_base; +extern BytePtr pure_space_start, pure_space_active, pure_space_limit; +extern BytePtr static_space_start, static_space_active, static_space_limit; +extern area *find_readonly_area(void); +extern BytePtr low_relocatable_address, high_relocatable_address, + low_markable_address, high_markable_address; + +#endif /* __AREA_H__ */ Index: /branches/new-random/lisp-kernel/bits.c =================================================================== --- /branches/new-random/lisp-kernel/bits.c (revision 13309) +++ /branches/new-random/lisp-kernel/bits.c (revision 13309) @@ -0,0 +1,70 @@ +/* + Copyright (C) 2009 Clozure Associates + Copyright (C) 1994-2001 Digitool, Inc + This file is part of Clozure CL. + + Clozure CL is licensed under the terms of the Lisp Lesser GNU Public + License , known as the LLGPL and distributed with Clozure CL as the + file "LICENSE". The LLGPL consists of a preamble and the LGPL, + which is distributed with Clozure CL as the file "LGPL". Where these + conflict, the preamble takes precedence. + + Clozure CL is referenced in the preamble as the "LIBRARY." + + The LLGPL is also available online at + http://opensource.franz.com/preamble.html +*/ + + +#include "lisp.h" +#include "bits.h" +#include "lisp-exceptions.h" + + +/* This should be a lot faster than calling set_bit N times */ + +void +set_n_bits(bitvector bits, natural first, natural n) +{ + if (n) { + natural + lastbit = (first+n)-1, + leftbit = first & bitmap_shift_count_mask, + leftmask = ALL_ONES >> leftbit, + rightmask = ALL_ONES << ((nbits_in_word-1) - (lastbit & bitmap_shift_count_mask)), + *wstart = ((natural *) bits) + (first>>bitmap_shift), + *wend = ((natural *) bits) + (lastbit>>bitmap_shift); + + if (wstart == wend) { + *wstart |= (leftmask & rightmask); + } else { + *wstart++ |= leftmask; + n -= (nbits_in_word - leftbit); + + while (n >= nbits_in_word) { + *wstart++ = ALL_ONES; + n-= nbits_in_word; + } + + if (n) { + *wstart |= rightmask; + } + } + } +} + +/* Note that this zeros longwords */ +void +zero_bits(bitvector bits, natural nbits) +{ + memset(bits, 0, ((sizeof(natural)*(((nbits+(nbits_in_word-1)))>>bitmap_shift)))); +} + +void +ior_bits(bitvector dest, bitvector src, natural nbits) +{ + while (nbits > 0) { + *dest++ |= *src++; + nbits -= nbits_in_word; + } +} Index: /branches/new-random/lisp-kernel/bits.h =================================================================== --- /branches/new-random/lisp-kernel/bits.h (revision 13309) +++ /branches/new-random/lisp-kernel/bits.h (revision 13309) @@ -0,0 +1,183 @@ +/* + Copyright (C) 2009 Clozure Associates + Copyright (C) 1994-2001 Digitool, Inc + This file is part of Clozure CL. + + Clozure CL is licensed under the terms of the Lisp Lesser GNU Public + License , known as the LLGPL and distributed with Clozure CL as the + file "LICENSE". The LLGPL consists of a preamble and the LGPL, + which is distributed with Clozure CL as the file "LGPL". Where these + conflict, the preamble takes precedence. + + Clozure CL is referenced in the preamble as the "LIBRARY." + + The LLGPL is also available online at + http://opensource.franz.com/preamble.html +*/ + + + +#ifndef __bits_h__ +#define __bits_h__ 1 + +#include + +typedef natural *bitvector; + +#if WORD_SIZE == 64 +#define bitmap_shift 6 +#define BIT0_MASK 0x8000000000000000ULL +#define ALL_ONES 0xffffffffffffffffULL +#define NATURAL1 1ULL +#else +#define bitmap_shift 5 +#define BIT0_MASK 0x80000000U +#define ALL_ONES 0xFFFFFFFFU +#define NATURAL1 1U +#endif + +#define bitmap_shift_count_mask ((1<>bitmap_shift, + old = bits[windex], + new = old | (BIT0_MASK >> (bitnum & bitmap_shift_count_mask)); + if (new == old) { + return 1; /* Was set */ + } else { + bits[windex] = new; + return 0; /* Was clear */ + } +} + +static inline int +atomic_set_bit(bitvector bits ,natural bitnum) +{ + extern natural atomic_ior(bitvector, natural); + natural + windex = bitnum>>bitmap_shift, + mask = (BIT0_MASK >> (bitnum & bitmap_shift_count_mask)); + + return atomic_ior(bits + windex, mask); +} + +void set_n_bits(bitvector,natural,natural); + +static inline int +clr_bit(bitvector bits, natural bitnum) +{ + unsigned + windex = bitnum>>bitmap_shift, + old = bits[windex], + new = old & ~(BIT0_MASK >> (bitnum & bitmap_shift_count_mask)); + if (new == old) { + return 0; /* Was clear */ + } else { + bits[windex] = new; + return 1; /* Was set */ + } +} + + +static inline unsigned +ref_bit(bitvector bits,natural bitnum) __attribute__((always_inline)); + +static inline unsigned +ref_bit(bitvector bits,natural bitnum) +{ + return ((bits[bitnum>>bitmap_shift] & (BIT0_MASK >> (bitnum & bitmap_shift_count_mask))) != 0); +} + +void zero_bits(bitvector, natural); +void ior_bits(bitvector,bitvector,natural); + +#define bits_word_index(bitnum) (((natural)(bitnum)) >> bitmap_shift) +#define bits_bit_index(bitnum) (((natural)(bitnum)) & bitmap_shift_count_mask) +#define bits_word_ptr(bits,bitnum) \ + ((natural*) (((natural*) bits) + ((natural) (bits_word_index(bitnum))))) +#define bits_word_mask(bitnum) ((BIT0_MASK) >> bits_bit_index(bitnum)) +#define bits_indexed_word(bitv,indexw) ((((natural*)(bitv))[indexw])) +#define bits_word(bitv,bitnum) bits_indexed_word(bits,bits_word_index(bitnum)) + +/* Evaluates some arguments twice */ + +#define set_bits_vars(BITVvar,BITNUMvar,BITPvar,BITWvar,MASKvar) \ +{ BITPvar = bits_word_ptr(BITVvar,BITNUMvar); BITWvar = *BITPvar; MASKvar = bits_word_mask(BITNUMvar); } + +#define set_bitidx_vars(BITVvar,BITNUMvar,BITPvar,BITWvar,BITIDXvar) \ +{ BITPvar = bits_word_ptr(BITVvar,BITNUMvar); BITIDXvar = bits_bit_index(BITNUMvar); \ + BITWvar = (*BITPvar << BITIDXvar) >> BITIDXvar; } + +#ifdef __GNUC__ +static __inline__ natural +current_stack_pointer(void) __attribute__((always_inline)); + +static __inline__ natural +current_stack_pointer(void) +{ +#ifdef PPC + register natural _sp __asm__("r1"); +#endif +#ifdef X8664 + register natural _sp __asm__("%rsp"); +#endif +#ifdef X8632 + register natural _sp __asm__("%esp"); +#endif + return _sp; +} +#else +natural +current_stack_pointer(void); +#endif + +#ifdef __GNUC__ +static __inline__ unsigned +count_leading_zeros(natural w) __attribute__((always_inline)); + + +/* Beware: on some platforms, __builtin_clz[ll](0) returns an undefined + result */ + +static __inline__ unsigned +count_leading_zeros(natural w) +{ +#if __GNUC__ >= 4 +#if WORD_SIZE == 64 + return __builtin_clzll(w); +#else + return __builtin_clz(w); +#endif +#else /* __GNUC__ < 4 */ + natural lz; +#ifdef PPC +#ifdef PPC64 + __asm__ __volatile__("cntlzd %0,%1" : "=r" (lz) : "r" (w)); +#else + __asm__ __volatile__("cntlzw %0,%1" : "=r" (lz) : "r" (w)); +#endif +#endif /* PPC */ +#ifdef X86 +#ifdef X8664 + __asm__ __volatile__("bsr %1,%0" : "=r" (lz) : "r" (w)); + __asm__ __volatile__("xor $63,%0" : "=r" (lz)); +#else + __asm__ __volatile__("bsr %1,%0" : "=r" (lz) : "r" (w)); + __asm__ __volatile__("xor $31,%0" : "=r" (lz)); +#endif +#endif + return lz; +#endif +} +#else /* not __GNUC__ */ +unsigned +count_leading_zeros(natural); +#endif + +#endif /* __bits_h__ */ Index: /branches/new-random/lisp-kernel/darwinppc/.cvsignore =================================================================== --- /branches/new-random/lisp-kernel/darwinppc/.cvsignore (revision 13309) +++ /branches/new-random/lisp-kernel/darwinppc/.cvsignore (revision 13309) @@ -0,0 +1,1 @@ +*~.* Index: /branches/new-random/lisp-kernel/darwinppc/.gdbinit =================================================================== --- /branches/new-random/lisp-kernel/darwinppc/.gdbinit (revision 13309) +++ /branches/new-random/lisp-kernel/darwinppc/.gdbinit (revision 13309) @@ -0,0 +1,39 @@ +define pl +call print_lisp_object($arg0) +end + +define arg_x +pl $r21 +end + +define arg_y +pl $r22 +end + +define arg_z +pl $r23 +end + +define lw +pl $r16 +end + +define fname +pl $r17 +end + + +break Bug + +display/i $pc + +handle SIGKILL pass nostop noprint +handle SIGILL pass nostop noprint +handle SIGSEGV pass nostop noprint +handle SIGBUS pass nostop noprint +handle SIGFPE pass nostop noprint +handle SIGUSR1 pass nostop noprint +handle SIGUSR2 pass nostop noprint +handle SIGEMT pass nostop noprint +# Work around apparent Apple GDB bug +handle SIGTTIN nopass nostop noprint Index: /branches/new-random/lisp-kernel/darwinppc/Makefile =================================================================== --- /branches/new-random/lisp-kernel/darwinppc/Makefile (revision 13309) +++ /branches/new-random/lisp-kernel/darwinppc/Makefile (revision 13309) @@ -0,0 +1,125 @@ +# +# Copyright (C) 1994-2001 Digitool, Inc +# This file is part of Clozure CL. +# +# Clozure CL is licensed under the terms of the Lisp Lesser GNU Public +# License , known as the LLGPL and distributed with Clozure CL as the +# file "LICENSE". The LLGPL consists of a preamble and the LGPL, +# which is distributed with Clozure CL as the file "LGPL". Where these +# conflict, the preamble takes precedence. +# +# Clozure CL is referenced in the preamble as the "LIBRARY." +# +# The LLGPL is also available online at +# http://opensource.franz.com/preamble.html + + +# For versions of GCC prior to 3.3, the option "-traditional-cpp" meant +# "don't use precompiled headers", which was good advice since they didn't +# work too well. Beginning with GCC 3.3, the "-traditional-cpp" means +# "use a broken preprocessor", which is (in a sense) the opposite of what +# it used to mean. + +# Try to determine the version of GCC in use. Invoke gcc with the +# -v flag, and look for a line containing the phrase "specs from" in +# the output. Use sed to extract the full pathname of ths specs file +# printed in that line, then strip off the trailing "/specs". +gccdir = $(shell $(CC) -v 2>&1 | grep "specs from" | sed -e 's/.*from //' -e 's|/specs||') +# $(gccdir) is set to the directory containing the specs file, without the +# trailing slash. The make intrinsic 'notdir' will strip a leading directory +# prefix from that pathname, leaving us with a string that should match +# the gcc version number +ifneq ($(gccdir),) +gccversion:=$(notdir $(gccdir)) +oldgcc:=$(shell expr $(gccversion) "<" "3.3") +pregcc4:=$(shell expr $(gccversion) "<" "4.0") +ifeq ($(oldgcc),1) +BROKEN_PREPROCESSOR_WORKAROUND = -traditional-cpp +endif +endif + +MDYNAMIC_NO_PIC = $(shell ($(CC) --help -v 2>&1 | grep -q -e "-mdynamic-no-pic") && /bin/echo "-mdynamic-no-pic") + +OPENMCL_MAJOR_VERSION=0 +OPENMCL_MINOR_VERSION=14 + +VPATH = .. +RM = /bin/rm +LD = ld +LDFLAGS = -arch ppc -dynamic -o $@ -e start -pagezero_size 0x1000 -seg1addr 0x00001000 -sectalign __TEXT __text 0x1000 +AS = as +M4 = gm4 +M4FLAGS = -DDARWIN -DPPC +ASFLAGS = -arch ppc -force_cpusubtype_ALL +CDEFINES = -DDARWIN -DPPC $(BROKEN_PREPROCESSOR_WORKAROUND) #-DDEBUG -DGC_INTEGRITY_CHECKING +CDEBUG = -g +COPT = -O2 + +.s.o: + $(M4) $(M4FLAGS) -I../ $< | $(AS) $(ASFLAGS) -o $@ +.c.o: + $(CC) -c -arch ppc $< $(CDEFINES) $(CDEBUG) $(COPT) -Wno-deprecated-declarations -mmacosx-version-min=10.4 -isysroot /Developer/SDKs/MacOSX10.4u.sdk $(MDYNAMIC_NO_PIC) -o $@ + +SPOBJ = ppc-spjump.o ppc-spentry.o ppc-subprims.o +ASMOBJ = ppc-asmutils.o imports.o + +COBJ = pmcl-kernel.o gc-common.o ppc-gc.o bits.o ppc-exceptions.o \ + thread_manager.o lisp-debug.o image.o memory.o unix-calls.o + +DEBUGOBJ = lispdcmd.o plprint.o plsym.o plbt.o ppc_print.o +KERNELOBJ= imports.o $(COBJ) ppc-asmutils.o + +SPINC = lisp.s m4macros.m4 ppc-constants.s ppc-macros.s errors.s ppc-uuo.s ppc-constants32.s + +CHEADERS = area.h bits.h ppc-constants.h lisp-errors.h gc.h lisp.h \ + lisp-exceptions.h lisp_globals.h macros.h memprotect.h image.h \ + Threads.h lisptypes.h ppc-constants32.h ppc-exceptions.h + +# Subprims linked into the kernel ? +# Yes: + +KSPOBJ= $(SPOBJ) +all: ../../dppccl + + +# No: + +# KSPOBJ= + +OSEARLYLIBS = -lcrt1.o +OSLATELIBS = -lSystem + +# gcc 4.0 and later want to use -lSystemStubs for many of the +# runtime support functions that were in -lgcc in previous +# versions. 'pregcc4' may have been set above. +ifeq ($(pregcc4),1) +OSMIDDLELIBS = -lgcc +else +OSMIDDLELIBS = -lSystemStubs +endif + +OSLIBS = $(OSEARLYLIBS) $(OSMIDDLELIBS) $(OSLATELIBS) + +../../dppccl: $(KSPOBJ) $(KERNELOBJ) $(DEBUGOBJ) + $(LD) $(LDFLAGS) $(KSPOBJ) $(KERNELOBJ) $(DEBUGOBJ) $(OSLIBS) + + +$(SPOBJ): $(SPINC) +$(ASMOBJ): $(SPINC) +$(COBJ): $(CHEADERS) +$(DEBUGOBJ): $(CHEADERS) lispdcmd.h + + + +thread_manager.o: thread_manager.c + +cclean: + $(RM) -f $(KERNELOBJ) $(DEBUGOBJ) ../../dppccl + +# Some earlier versions of this Makefile built "subprims_r.o". +# (That file is now defunct.) +clean: cclean + $(RM) -f $(SPOBJ) $(KSPOBJ) subprims_r.o + +strip: ../../dppccl + strip -s retain ../../dppccl Index: /branches/new-random/lisp-kernel/darwinppc/retain =================================================================== --- /branches/new-random/lisp-kernel/darwinppc/retain (revision 13309) +++ /branches/new-random/lisp-kernel/darwinppc/retain (revision 13309) @@ -0,0 +1,3 @@ +#symbols that must be retained in a lisp kernel image +# % strip -s dppccl +_catch_exception_raise Index: /branches/new-random/lisp-kernel/darwinppc64/.cvsignore =================================================================== --- /branches/new-random/lisp-kernel/darwinppc64/.cvsignore (revision 13309) +++ /branches/new-random/lisp-kernel/darwinppc64/.cvsignore (revision 13309) @@ -0,0 +1,1 @@ +*~.* Index: /branches/new-random/lisp-kernel/darwinppc64/Makefile =================================================================== --- /branches/new-random/lisp-kernel/darwinppc64/Makefile (revision 13309) +++ /branches/new-random/lisp-kernel/darwinppc64/Makefile (revision 13309) @@ -0,0 +1,129 @@ +# +# Copyright (C) 2005 Clozure Associates and contributors. +# This file is part of Clozure CL. +# +# Clozure CL is licensed under the terms of the Lisp Lesser GNU Public +# License , known as the LLGPL and distributed with Clozure CL as the +# file "LICENSE". The LLGPL consists of a preamble and the LGPL, +# which is distributed with Clozure CL as the file "LGPL". Where these +# conflict, the preamble takes precedence. +# +# Clozure CL is referenced in the preamble as the "LIBRARY." +# +# The LLGPL is also available online at +# http://opensource.franz.com/preamble.html + + +# For versions of GCC prior to 3.3, the option "-traditional-cpp" meant +# "don't use precompiled headers", which was good advice since they didn't +# work too well. Beginning with GCC 3.3, the "-traditional-cpp" means +# "use a broken preprocessor", which is (in a sense) the opposite of what +# it used to mean. + +# Try to determine the version of GCC in use. Invoke gcc with the +# -v flag, and look for a line containing the phrase "specs from" in +# the output. Use sed to extract the full pathname of ths specs file +# printed in that line, then strip off the trailing "/specs". +gccdir = $(shell $(CC) -v 2>&1 | grep "specs from" | sed -e 's/.*from //' -e 's|/specs||') +# $(gccdir) is set to the directory containing the specs file, without the +# trailing slash. The make intrinsic 'notdir' will strip a leading directory +# prefix from that pathname, leaving us with a string that should match +# the gcc version number +#gccversion:=$(notdir $(gccdir)) +#oldgcc:=$(shell expr $(gccversion) "<" "3.3") +#ifeq ($(oldgcc),1) +#BROKEN_PREPROCESSOR_WORKAROUND = -traditional-cpp +#endif + +MDYNAMIC_NO_PIC = $(shell ($(CC) --help -v 2>&1 | grep -q -e "-mdynamic-no-pic") && /bin/echo "-mdynamic-no-pic") + +OPENMCL_MAJOR_VERSION=0 +OPENMCL_MINOR_VERSION=14 + +VPATH = .. +RM = /bin/rm +LD = ld64 + +### The -pagezero_size/-seg1addr args are an attempt to work around a +### bug (#4057702) in ld64. + +### The -seg1addr and -pagezero_size arguments below are nonsense; +### early versions of ld64 were/are broken. +LDFLAGS = -macosx_version_min 10.4 -M -arch ppc64 -dynamic -o $@ -e start -pagezero_size 0x1000 -seg1addr 0x1000 -sectalign __TEXT __text 0x1000 +AS = as +M4 = gm4 +M4FLAGS = -DDARWIN -DPPC -DPPC64 +ASFLAGS = -arch ppc64 +CDEFINES = -DDARWIN -DPPC -DPPC64 $(BROKEN_PREPROCESSOR_WORKAROUND) +CDEBUG = -g +COPT = -O2 + +.s.o: + $(M4) $(M4FLAGS) -I../ $< | $(AS) $(ASFLAGS) -o $@ +.c.o: + $(CC) -c $< -arch ppc64 -m64 $(CDEFINES) $(CDEBUG) $(COPT) $(MDYNAMIC_NO_PIC) -mmacosx-version-min=10.4 -isysroot /Developer/SDKs/MacOSX10.4u.sdk -o $@ + +SPOBJ = ppc-spjump.o ppc-spentry.o ppc-subprims.o +ASMOBJ = ppc-asmutils.o imports.o + +COBJ = pmcl-kernel.o gc-common.o ppc-gc.o bits.o ppc-exceptions.o \ + thread_manager.o lisp-debug.o image.o memory.o unix-calls.o + +DEBUGOBJ = lispdcmd.o plprint.o plsym.o plbt.o ppc_print.o +KERNELOBJ= imports.o $(COBJ) ppc-asmutils.o + +SPINC = lisp.s m4macros.m4 ppc-constants.s ppc-macros.s errors.s ppc-uuo.s \ + ppc-constants64.s + +CHEADERS = area.h bits.h ppc-constants.h lisp-errors.h gc.h lisp.h \ + lisp-exceptions.h lisp_globals.h macros.h memprotect.h image.h \ + Threads.h lisptypes.h ppc-constants64.h ppc-exceptions.h + +# Subprims linked into the kernel ? +# Yes: + +KSPOBJ= $(SPOBJ) +all: ../../dppccl64 + + +# No: + +# KSPOBJ= + +OSEARLYLIBS = -lcrt1.o +OSLATELIBS = -lSystem -lmx + +# If the linker can find an absolute path to -lSystemStubs, use +# -lSystemStubs; otherwise, just use libgcc.a +SYSTEMSTUBSPATH = $(shell $(CC) --print-file-name=libSystemStubs.a) +SYSTEMSTUBSABSOLUTE = $(shell expr $(SYSTEMSTUBSPATH) : "^/*") +ifeq ($(SYSTEMSTUBSABSOLUTE),1) +OSMIDDLELIBS = -lSystemStubs +else +OSMIDDLELIBS = -lgcc +endif + +OSLIBS = $(OSEARLYLIBS) $(OSMIDDLELIBS) $(OSLATELIBS) + +../../dppccl64: $(KSPOBJ) $(KERNELOBJ) $(DEBUGOBJ) Makefile + $(LD) $(LDFLAGS) $(KSPOBJ) $(KERNELOBJ) $(DEBUGOBJ) $(OSLIBS) + + +$(SPOBJ): $(SPINC) +$(ASMOBJ): $(SPINC) +$(COBJ): $(CHEADERS) +$(DEBUGOBJ): $(CHEADERS) lispdcmd.h + + +thread_manager.o: thread_manager.c + +cclean: + $(RM) -f $(KERNELOBJ) $(DEBUGOBJ) ../../dppccl64 + +# Some earlier versions of this Makefile built "subprims_r.o". +# (That file is now defunct.) +clean: cclean + $(RM) -f $(SPOBJ) $(KSPOBJ) subprims_r.o + +strip: ../../dppccl64 + strip -s retain ../../dppccl64 Index: /branches/new-random/lisp-kernel/darwinx8632/.gdbinit =================================================================== --- /branches/new-random/lisp-kernel/darwinx8632/.gdbinit (revision 13309) +++ /branches/new-random/lisp-kernel/darwinx8632/.gdbinit (revision 13309) @@ -0,0 +1,48 @@ +define pl + call print_lisp_object($arg0) +end + +define showlist + set $l=$arg0 + while $l != 0x3001 + set $car = *((LispObj *)($l+3)) + set $l = *((LispObj *)($l-1)) + pl $car + end +end + + +define fn + pl $edi +end + +define arg_y + pl $esi +end + +define arg_z + pl $ebx +end + +define offset + p (int)$pc-$edi +end + + +break Bug + +display/i $pc + +handle SIGKILL pass nostop noprint +handle SIGILL pass nostop noprint +handle SIGSEGV pass nostop noprint +handle SIGBUS pass nostop noprint +handle SIGFPE pass nostop noprint +handle SIGUSR1 pass nostop noprint +handle SIGUSR2 pass nostop noprint +handle SIGEMT pass nostop noprint +# Work around apparent Apple GDB bug +handle SIGTTIN nopass nostop noprint +# Work around Leopard bug du jour +handle SIGSYS pass nostop noprint + Index: /branches/new-random/lisp-kernel/darwinx8632/Makefile =================================================================== --- /branches/new-random/lisp-kernel/darwinx8632/Makefile (revision 13309) +++ /branches/new-random/lisp-kernel/darwinx8632/Makefile (revision 13309) @@ -0,0 +1,102 @@ +# +# Copyright (C) 2005 Clozure Associates and contributors. +# This file is part of Clozure CL. +# +# Clozure CL is licensed under the terms of the Lisp Lesser GNU Public +# License , known as the LLGPL and distributed with Clozure CL as the +# file "LICENSE". The LLGPL consists of a preamble and the LGPL, +# which is distributed with Clozure CL as the file "LGPL". Where these +# conflict, the preamble takes precedence. +# +# Clozure CL is referenced in the preamble as the "LIBRARY." +# +# The LLGPL is also available online at +# http://opensource.franz.com/preamble.html + + +MDYNAMIC_NO_PIC = $(shell ($(CC) --help -v 2>&1 | grep -q -e "-mdynamic-no-pic") && /bin/echo "-mdynamic-no-pic") + +VPATH = .. +RM = /bin/rm +LD = ld +LDFLAGS = -macosx_version_min 10.4 -arch i386 -dynamic -o $@ -e start -pagezero_size 0x11000 -seg1addr 0x00011000 -sectalign __TEXT __text 0x1000 +AS = as +M4 = gm4 +M4FLAGS = -DDARWIN -DX86 -DX8632 +ASFLAGS = -arch i386 -g +CDEFINES = -DDARWIN -DX86 -DX8632 #-DGC_INTEGRITY_CHECKING -DFORCE_DWS_MARK -DDISABLE_EGC -DDEBUG_MACH_EXCEPTIONS +CDEBUG = -g +COPT = -O2 +CC=gcc-4.0 + +.s.o: + $(M4) $(M4FLAGS) -I../ $< | $(AS) $(ASFLAGS) -o $@ +.c.o: + $(CC) -c -arch i386 $< $(CDEFINES) $(CDEBUG) $(COPT) $(MDYNAMIC_NO_PIC) -mmacosx-version-min=10.4 -isysroot /Developer/SDKs/MacOSX10.4u.sdk -o $@ + +SPOBJ = x86-spjump32.o x86-spentry32.o x86-subprims32.o +ASMOBJ = x86-asmutils32.o imports.o + +COBJ = pmcl-kernel.o gc-common.o bits.o \ + thread_manager.o lisp-debug.o image.o memory.o x86-gc.o \ + x86-exceptions.o unix-calls.o + +DEBUGOBJ = lispdcmd.o plprint.o plsym.o x86_print.o xlbt.o +KERNELOBJ= imports.o $(COBJ) x86-asmutils32.o + +SPINC = lisp.s m4macros.m4 x86-constants.s x86-macros.s errors.s x86-uuo.s x86-constants32.s + +CHEADERS = area.h bits.h x86-constants.h lisp-errors.h gc.h lisp.h \ + lisp-exceptions.h lisp_globals.h macros.h memprotect.h image.h \ + Threads.h lisptypes.h x86-constants32.h x86-exceptions.h + +# Subprims linked into the kernel ? +# Yes: + +KSPOBJ= $(SPOBJ) +all: ../../dx86cl + + +# No: + +# KSPOBJ= + +OSEARLYLIBS = -lcrt1.o +OSLATELIBS = -lSystem + +# is this needed? +#OSMIDDLELIBS = -lSystemStubs + +OSLIBS = $(OSEARLYLIBS) $(OSMIDDLELIBS) $(OSLATELIBS) + +../../dx86cl: tiger-sdk-check $(KSPOBJ) $(KERNELOBJ) $(DEBUGOBJ) Makefile + $(LD) $(LDFLAGS) $(KSPOBJ) $(KERNELOBJ) $(DEBUGOBJ) $(OSLIBS) + + +$(SPOBJ): $(SPINC) +$(ASMOBJ): $(SPINC) +$(COBJ): $(CHEADERS) +$(DEBUGOBJ): $(CHEADERS) lispdcmd.h + + + +thread_manager.o: thread_manager.c + +cclean: + $(RM) -f $(KERNELOBJ) $(DEBUGOBJ) ../../dx86cl + +# Some earlier versions of this Makefile built "subprims_r.o". +# (That file is now defunct.) +clean: cclean + $(RM) -f $(SPOBJ) $(KSPOBJ) subprims_r.o + +# retain file not here at the moment +strip: ../../dx86cl + strip -s retain ../../dx86cl + +.PHONY: tiger-sdk-check +tiger-sdk-check: + @test -d /Developer/SDKs/MacOSX10.4u.sdk || \ + (echo "*** Install Xcode 10.4 support"; exit 1) + + Index: /branches/new-random/lisp-kernel/darwinx8664/.gdbinit =================================================================== --- /branches/new-random/lisp-kernel/darwinx8664/.gdbinit (revision 13309) +++ /branches/new-random/lisp-kernel/darwinx8664/.gdbinit (revision 13309) @@ -0,0 +1,78 @@ +define x86_lisp_string +x/s $arg0-5 +end + +define x86pname +set $temp=*((long *)((long)($arg0-6))) +x86_lisp_string $temp +end + +define gtra +br *$r10 +cont +end + + +define pname + x86pname $arg0 +end + +define pl + call print_lisp_object($arg0) +end + +define lw + pl $r13 +end + +define clobber_breakpoint + set *(short *)($pc-2)=0x9090 +end + +define arg_z + pl $rsi +end + +define arg_y + pl $rdi +end + +define arg_x + pl $r8 +end + +define bx + pl $rbx +end + + +define lbt + call plbt_sp($rbp) +end + +define ada + p/x *(all_areas->succ) +end + +define lregs + call debug_lisp_registers($arg0,0,0) +end + +break Bug + +display/i $pc + +handle SIGKILL pass nostop noprint +handle SIGILL pass nostop noprint +handle SIGSEGV pass nostop noprint +handle SIGBUS pass nostop noprint +handle SIGFPE pass nostop noprint +handle SIGUSR1 pass nostop noprint +handle SIGUSR2 pass nostop noprint +handle SIGEMT pass nostop noprint +# Work around apparent Apple GDB bug +handle SIGTTIN nopass nostop noprint +# Work around Leopard bug du jour +handle SIGSYS pass nostop noprint +handle SIGQUIT pass nostop noprint + Index: /branches/new-random/lisp-kernel/darwinx8664/Makefile =================================================================== --- /branches/new-random/lisp-kernel/darwinx8664/Makefile (revision 13309) +++ /branches/new-random/lisp-kernel/darwinx8664/Makefile (revision 13309) @@ -0,0 +1,122 @@ +# +# Copyright (C) 2005 Clozure Associates and contributors. +# This file is part of Clozure CL. +# +# Clozure CL is licensed under the terms of the Lisp Lesser GNU Public +# License , known as the LLGPL and distributed with Clozure CL as the +# file "LICENSE". The LLGPL consists of a preamble and the LGPL, +# which is distributed with Clozure CL as the file "LGPL". Where these +# conflict, the preamble takes precedence. +# +# Clozure CL is referenced in the preamble as the "LIBRARY." +# +# The LLGPL is also available online at +# http://opensource.franz.com/preamble.html + + + + +MDYNAMIC_NO_PIC = $(shell ($(CC) --help -v 2>&1 | grep -q -e "-mdynamic-no-pic") && /bin/echo "-mdynamic-no-pic") + + +VPATH = .. +RM = /bin/rm +LD = ld +CC=gcc-4.0 + +### Current ld64 bugs include the claim that 0x1000 isn't a power of 2. +### Gosh. I always thought that it was. Go know, right ? +LDFLAGS = -macosx_version_min 10.4 -arch x86_64 -dynamic -o $@ -e start -pagezero_size 0x11000 -seg1addr 0x00011000 + + +AS = as +M4 = gm4 +### +### DARWIN_GS_HACK enables some awful, dangerous, and slow workarounds +### for the fact that early versions of x86-64 Darwin don't provide +### working mechanisms for threads to address thread-local-data +### relative to a spare segment register. We instead use the +### undocumented mechanism which the pthreads library uses to +### keep pthread data in %gs, and switch %gs between pthread data +### when running foreign code and lisp tcr data when running lisp +### code. Hopefully, we won't have to do this for very long. +### +### (Things like i386_set_ldt() are defined, but not implemented +### correctly on the libc side and not implemented at all on the +### Mach kernel side.) +### +### Apple never +M4FLAGS = -DDARWIN -DX86 -DX8664 -DTCR_IN_GPR +ASFLAGS = -arch x86_64 -g +CDEFINES = -DDARWIN -DX86 -DX8664 -DTCR_IN_GPR +CDEBUG = -g +COPT = -O2 + +.s.o: + $(M4) $(M4FLAGS) -I../ $< | $(AS) $(ASFLAGS) -o $@ +.c.o: + $(CC) -c $< -arch x86_64 -m64 $(CDEFINES) $(CDEBUG) $(COPT) $(MDYNAMIC_NO_PIC) -mmacosx-version-min=10.4 -isysroot /Developer/SDKs/MacOSX10.4u.sdk -o $@ + +SPOBJ = x86-spjump64.o x86-spentry64.o x86-subprims64.o +ASMOBJ = x86-asmutils64.o imports.o + +COBJ = pmcl-kernel.o gc-common.o x86-gc.o bits.o x86-exceptions.o \ + thread_manager.o lisp-debug.o image.o memory.o unix-calls.o + +DEBUGOBJ = lispdcmd.o plprint.o plsym.o xlbt.o x86_print.o +KERNELOBJ= imports.o $(COBJ) x86-asmutils64.o + +SPINC = lisp.s m4macros.m4 x86-constants.s x86-macros.s errors.s x86-uuo.s \ + x86-constants64.s + +CHEADERS = area.h bits.h x86-constants.h lisp-errors.h gc.h lisp.h \ + lisp-exceptions.h lisp_globals.h macros.h memprotect.h image.h \ + Threads.h lisptypes.h x86-constants64.h x86-exceptions.h + +# Subprims linked into the kernel ? +# Yes: + +KSPOBJ= $(SPOBJ) +all: ../../dx86cl64 + + +# No: + +# KSPOBJ= + +OSEARLYLIBS = -lcrt1.o +OSLATELIBS = -lSystem + +OSMIDDLELIBS = + + +OSLIBS = $(OSEARLYLIBS) $(OSMIDDLELIBS) $(OSLATELIBS) + +../../dx86cl64: tiger-sdk-check $(KSPOBJ) $(KERNELOBJ) $(DEBUGOBJ) Makefile + $(LD) $(LDFLAGS) $(KSPOBJ) $(KERNELOBJ) $(DEBUGOBJ) $(OSLIBS) + + +$(SPOBJ): $(SPINC) +$(ASMOBJ): $(SPINC) +$(COBJ): $(CHEADERS) +$(DEBUGOBJ): $(CHEADERS) lispdcmd.h + + +thread_manager.o: thread_manager.c + +cclean: + $(RM) -f $(KERNELOBJ) $(DEBUGOBJ) ../../dx86cl64 + +# Some earlier versions of this Makefile built "subprims_r.o". +# (That file is now defunct.) +clean: cclean + $(RM) -f $(SPOBJ) $(KSPOBJ) subprims_r.o + +strip: ../../dx86cl64 + strip -s retain ../../dx86cl64 + +.PHONY: tiger-sdk-check +tiger-sdk-check: + @test -d /Developer/SDKs/MacOSX10.4u.sdk || \ + (echo "*** Install Xcode 10.4 support"; exit 1) + Index: /branches/new-random/lisp-kernel/errors.s =================================================================== --- /branches/new-random/lisp-kernel/errors.s (revision 13309) +++ /branches/new-random/lisp-kernel/errors.s (revision 13309) @@ -0,0 +1,236 @@ +/* Copyright (C) 2009 Clozure Associates */ +/* Copyright (C) 1994-2001 Digitool, Inc */ +/* This file is part of Clozure CL. */ + +/* Clozure CL is licensed under the terms of the Lisp Lesser GNU Public */ +/* License , known as the LLGPL and distributed with Clozure CL as the */ +/* file "LICENSE". The LLGPL consists of a preamble and the LGPL, */ +/* which is distributed with Clozure CL as the file "LGPL". Where these */ +/* conflict, the preamble takes precedence. */ + +/* Clozure CL is referenced in the preamble as the "LIBRARY." */ + +/* The LLGPL is also available online at */ +/* http://opensource.franz.com/preamble.html */ + + + + + +error_reg_errnum = 0 /* "real" (typically negative) error number is in RB */ +error_udf = 1 +error_udf_call = 2 +error_throw_tag_missing = 3 +error_alloc_failed = 4 +error_stack_overflow = 5 +error_excised_function_call = 6 +error_too_many_values = 7 +error_propagate_suspend = 10 +error_interrupt = 11 +error_suspend = 12 +error_suspend_all = 13 +error_resume = 14 +error_resume_all = 15 +error_cant_call = 17 + +error_type_error = 128 + +define([__type_error_counter__],128) +define([def_type_error],[ +error_object_not_$1 = __type_error_counter__ + define([__type_error_counter__],eval(__type_error_counter__+1))]) + + def_type_error(array) + def_type_error(bignum) + def_type_error(fixnum) + def_type_error(character) + def_type_error(integer) + def_type_error(list) + def_type_error(number) + def_type_error(sequence) + def_type_error(simple_string) + def_type_error(simple_vector) + def_type_error(string) + def_type_error(symbol) + def_type_error(macptr) + def_type_error(real) + def_type_error(cons) + def_type_error(unsigned_byte) + def_type_error(radix) + def_type_error(float) + def_type_error(rational) + def_type_error(ratio) + def_type_error(short_float) + def_type_error(double_float) + def_type_error(complex) + def_type_error(vector) + def_type_error(simple_base_string) + def_type_error(function) + def_type_error(unsigned_byte_16) + def_type_error(unsigned_byte_8) + def_type_error(unsigned_byte_32) + def_type_error(signed_byte_32) + def_type_error(signed_byte_16) + def_type_error(signed_byte_8) + def_type_error(base_character) + def_type_error(bit) + def_type_error(unsigned_byte_24) + def_type_error(u64) + def_type_error(s64) + def_type_error(unsigned_byte_56) + def_type_error(simple_array_double_float_2d) + def_type_error(simple_array_single_float_2d) + def_type_error(mod_char_code_limit) + def_type_error(array_2d) + def_type_error(array_3d) + def_type_error(array_t) + def_type_error(array_bit) + def_type_error(array_s8) + def_type_error(array_u8) + def_type_error(array_s16) + def_type_error(array_u16) + def_type_error(array_s32) + def_type_error(array_u32) + def_type_error(array_s64) + def_type_error(array_u64) + def_type_error(array_fixnum) + def_type_error(array_single_float) + def_type_error(array_double_float) + def_type_error(array_char) + def_type_error(array_t_2d) + def_type_error(array_bit_2d) + def_type_error(array_s8_2d) + def_type_error(array_u8_2d) + def_type_error(array_s16_2d) + def_type_error(array_u16_2d) + def_type_error(array_s32_2d) + def_type_error(array_u32_2d) + def_type_error(array_s64_2d) + def_type_error(array_u64_2d) + def_type_error(array_fixnum_2d) + def_type_error(array_single_float_2d) + def_type_error(array_double_float_2d) + def_type_error(array_char_2d) + def_type_error(simple_array_t_2d) + def_type_error(simple_array_bit_2d) + def_type_error(simple_array_s8_2d) + def_type_error(simple_array_u8_2d) + def_type_error(simple_array_s16_2d) + def_type_error(simple_array_u16_2d) + def_type_error(simple_array_s32_2d) + def_type_error(simple_array_u32_2d) + def_type_error(simple_array_s64_2d) + def_type_error(simple_array_u64_2d) + def_type_error(simple_array_fixnum_2d) + def_type_error(simple_array_char_2d) + def_type_error(array_t_3d) + def_type_error(array_bit_3d) + def_type_error(array_s8_3d) + def_type_error(array_u8_3d) + def_type_error(array_s16_3d) + def_type_error(array_u16_3d) + def_type_error(array_s32_3d) + def_type_error(array_u32_3d) + def_type_error(array_s64_3d) + def_type_error(array_u64_3d) + def_type_error(array_fixnum_3d) + def_type_error(array_single_float_3d) + def_type_error(array_double_float_3d) + def_type_error(array_char_3d) + def_type_error(simple_array_t_3d) + def_type_error(simple_array_bit_3d) + def_type_error(simple_array_s8_3d) + def_type_error(simple_array_u8_3d) + def_type_error(simple_array_s16_3d) + def_type_error(simple_array_u16_3d) + def_type_error(simple_array_s32_3d) + def_type_error(simple_array_u32_3d) + def_type_error(simple_array_s64_3d) + def_type_error(simple_array_u64_3d) + def_type_error(simple_array_fixnum_3d) + def_type_error(simple_array_single_float_3d) + def_type_error(simple_array_double_float_3d) + def_type_error(simple_array_char_3d) + def_type_error(vector_t) + def_type_error(bit_vector) + def_type_error(vector_s8) + def_type_error(vector_u8) + def_type_error(vector_s16) + def_type_error(vector_u16) + def_type_error(vector_s32) + def_type_error(vector_u32) + def_type_error(vector_s64) + def_type_error(vector_u64) + def_type_error(vector_fixnum) + def_type_error(vector_single_float) + def_type_error(vector_double_float) + + + +/* These are the "old" error constants that %ERR-DISP understands */ + +define([deferr],[ +$1 = $2<succ) +end + +define lregs + call debug_lisp_registers($arg0,0,0) +end + +break Bug + +display/i $pc + +handle SIGKILL pass nostop noprint +handle SIGILL pass nostop noprint +handle SIGSEGV pass nostop noprint +handle SIGBUS pass nostop noprint +handle SIGFPE pass nostop noprint +handle SIGEMT pass nostop noprint +handle SIGUSR1 pass nostop noprint +handle SIGUSR2 pass nostop noprint Index: /branches/new-random/lisp-kernel/freebsdx8664/Makefile =================================================================== --- /branches/new-random/lisp-kernel/freebsdx8664/Makefile (revision 13309) +++ /branches/new-random/lisp-kernel/freebsdx8664/Makefile (revision 13309) @@ -0,0 +1,78 @@ +# +# Copyright (C) 2005-2006 Clozure Associates +# This file is part of Clozure CL. +# +# Clozure CL is licensed under the terms of the Lisp Lesser GNU Public +# License , known as the LLGPL and distributed with Clozure CL as the +# file "LICENSE". The LLGPL consists of a preamble and the LGPL, +# which is distributed with Clozure CL as the file "LGPL". Where these +# conflict, the preamble takes precedence. +# +# Clozure CL is referenced in the preamble as the "LIBRARY." +# +# The LLGPL is also available online at +# http://opensource.franz.com/preamble.html + + +VPATH = .. +RM = /bin/rm +AS = as +M4 = m4 +ASFLAGS = --64 +M4FLAGS = -DFREEBSD -DX86 -DX8664 -DHAVE_TLS +CDEFINES = -DFREEBSD -D_REENTRANT -DX86 -DX8664 -D_GNU_SOURCE -DHAVE_TLS +CDEBUG = -g +COPT = #-O2 + + + + +SPOBJ = pad.o x86-spjump64.o x86-spentry64.o x86-subprims64.o +ASMOBJ = x86-asmutils64.o imports.o + +COBJ = pmcl-kernel.o gc-common.o x86-gc.o bits.o x86-exceptions.o \ + image.o thread_manager.o lisp-debug.o memory.o unix-calls.o + +DEBUGOBJ = lispdcmd.o plprint.o plsym.o xlbt.o x86_print.o +KERNELOBJ= $(COBJ) x86-asmutils64.o imports.o + +SPINC = lisp.s m4macros.m4 x86-constants.s x86-macros.s errors.s x86-uuo.s \ + x86-constants64.s + +CHEADERS = area.h bits.h x86-constants.h lisp-errors.h gc.h lisp.h \ + lisp-exceptions.h lisp_globals.h macros.h memprotect.h image.h \ + Threads.h x86-constants64.h x86-exceptions.h + + +KSPOBJ = $(SPOBJ) +all: ../../fx86cl64 + + +OSLIBS = -lm -lthr + +.s.o: + $(M4) $(M4FLAGS) -I../ $< | $(AS) $(ASFLAGS) -o $@ +.c.o: + $(CC) -c $< $(CDEFINES) $(CDEBUG) $(COPT) -m64 -o $@ + +LINKSCRIPTFILE = # ./elf_x86_64.x +LINKSCRIPT = # -T $(LINKSCRIPTFILE) + +../../fx86cl64: $(KSPOBJ) $(KERNELOBJ) $(DEBUGOBJ) $(LINKSCRIPTFILE) + $(CC) -m64 $(CDEBUG) -Wl,--export-dynamic $(LINKSCRIPT) -o $@ $(KSPOBJ) $(KERNELOBJ) $(DEBUGOBJ) $(OSLIBS) + + +$(SPOBJ): $(SPINC) +$(ASMOBJ): $(SPINC) +$(COBJ): $(CHEADERS) +$(DEBUGOBJ): $(CHEADERS) lispdcmd.h + + +cclean: + $(RM) -f $(KERNELOBJ) $(DEBUGOBJ) ../../fx86cl64 + +clean: cclean + $(RM) -f $(SPOBJ) + +strip: ../../fx86cl64 + strip -g ../../fx86cl64 Index: /branches/new-random/lisp-kernel/gc-common.c =================================================================== --- /branches/new-random/lisp-kernel/gc-common.c (revision 13309) +++ /branches/new-random/lisp-kernel/gc-common.c (revision 13309) @@ -0,0 +1,1556 @@ +/* + Copyright (C) 2009 Clozure Associates + Copyright (C) 1994-2001 Digitool, Inc + This file is part of Clozure CL. + + Clozure CL is licensed under the terms of the Lisp Lesser GNU Public + License , known as the LLGPL and distributed with Clozure CL as the + file "LICENSE". The LLGPL consists of a preamble and the LGPL, + which is distributed with Clozure CL as the file "LGPL". Where these + conflict, the preamble takes precedence. + + Clozure CL is referenced in the preamble as the "LIBRARY." + + The LLGPL is also available online at + http://opensource.franz.com/preamble.html +*/ + +#include "lisp.h" +#include "lisp_globals.h" +#include "bits.h" +#include "gc.h" +#include "area.h" +#include "Threads.h" +#include +#include +#include + +#ifndef WINDOWS +#include +#endif + +#ifndef timeradd +# define timeradd(a, b, result) \ + do { \ + (result)->tv_sec = (a)->tv_sec + (b)->tv_sec; \ + (result)->tv_usec = (a)->tv_usec + (b)->tv_usec; \ + if ((result)->tv_usec >= 1000000) \ + { \ + ++(result)->tv_sec; \ + (result)->tv_usec -= 1000000; \ + } \ + } while (0) +#endif +#ifndef timersub +# define timersub(a, b, result) \ + do { \ + (result)->tv_sec = (a)->tv_sec - (b)->tv_sec; \ + (result)->tv_usec = (a)->tv_usec - (b)->tv_usec; \ + if ((result)->tv_usec < 0) { \ + --(result)->tv_sec; \ + (result)->tv_usec += 1000000; \ + } \ + } while (0) +#endif + +void +comma_output_decimal(char *buf, int len, natural n) +{ + int nout = 0; + + buf[--len] = 0; + do { + buf[--len] = n%10+'0'; + n = n/10; + if (n == 0) { + while (len) { + buf[--len] = ' '; + } + return; + } + if (len == 0) return; + nout ++; + if (nout == 3) { + buf[--len] = ','; + nout = 0; + } + } while (len >= 0); +} + + +natural +static_dnodes_for_area(area *a) +{ + if (a->low == tenured_area->low) { + return tenured_area->static_dnodes; + } + return 0; +} + +Boolean GCDebug = false, GCverbose = false; +bitvector GCmarkbits = NULL, GCdynamic_markbits = NULL; +LispObj GCarealow = 0, GCareadynamiclow = 0; +natural GCndnodes_in_area = 0, GCndynamic_dnodes_in_area = 0; +LispObj GCweakvll = (LispObj)NULL; +LispObj GCdwsweakvll = (LispObj)NULL; +LispObj GCephemeral_low = 0; +natural GCn_ephemeral_dnodes = 0; +natural GCstack_limit = 0; + + +void +reapweakv(LispObj weakv) +{ + /* + element 2 of the weak vector should be tagged as a cons: if it + isn't, just mark it as a root. if it is, cdr through it until a + "marked" cons is encountered. If the car of any unmarked cons is + marked, mark the cons which contains it; otherwise, splice the + cons out of the list. N.B. : elements 0 and 1 are already marked + (or are immediate, etc.) + */ + LispObj *prev = ((LispObj *) ptr_from_lispobj(untag(weakv))+(1+2)), cell = *prev; + LispObj termination_list = lisp_nil; + natural weak_type = (natural) deref(weakv,2); + Boolean alistp = ((weak_type & population_type_mask) == population_weak_alist), + terminatablep = ((weak_type >> population_termination_bit) != 0); + Boolean done = false; + cons *rawcons; + natural dnode, car_dnode; + bitvector markbits = GCmarkbits; + + if (terminatablep) { + termination_list = deref(weakv,1+3); + } + + if (fulltag_of(cell) != fulltag_cons) { + mark_root(cell); + } else if (alistp) { + /* weak alist */ + while (! done) { + dnode = gc_area_dnode(cell); + if ((dnode >= GCndnodes_in_area) || + (ref_bit(markbits, dnode))) { + done = true; + } else { + /* Cons cell is unmarked. */ + LispObj alist_cell, thecar; + unsigned cell_tag; + + rawcons = (cons *) ptr_from_lispobj(untag(cell)); + alist_cell = rawcons->car; + cell_tag = fulltag_of(alist_cell); + + if ((cell_tag == fulltag_cons) && + ((car_dnode = gc_area_dnode(alist_cell)) < GCndnodes_in_area) && + (! ref_bit(markbits, car_dnode)) && + (is_node_fulltag(fulltag_of(thecar = car(alist_cell)))) && + ((car_dnode = gc_area_dnode(thecar)) < GCndnodes_in_area) && + (! ref_bit(markbits, car_dnode))) { + *prev = rawcons->cdr; + if (terminatablep) { + rawcons->cdr = termination_list; + termination_list = cell; + } + } else { + set_bit(markbits, dnode); + prev = (LispObj *)(&(rawcons->cdr)); + mark_root(alist_cell); + } + cell = *prev; + } + } + } else { + /* weak list */ + while (! done) { + dnode = gc_area_dnode(cell); + if ((dnode >= GCndnodes_in_area) || + (ref_bit(markbits, dnode))) { + done = true; + } else { + /* Cons cell is unmarked. */ + LispObj thecar; + unsigned cartag; + + rawcons = (cons *) ptr_from_lispobj(untag(cell)); + thecar = rawcons->car; + cartag = fulltag_of(thecar); + + if (is_node_fulltag(cartag) && + ((car_dnode = gc_area_dnode(thecar)) < GCndnodes_in_area) && + (! ref_bit(markbits, car_dnode))) { + *prev = rawcons->cdr; + if (terminatablep) { + rawcons->cdr = termination_list; + termination_list = cell; + } + } else { + set_bit(markbits, dnode); + prev = (LispObj *)(&(rawcons->cdr)); + } + cell = *prev; + } + } + } + + if (terminatablep) { + deref(weakv,1+3) = termination_list; + if (termination_list != lisp_nil) { + deref(weakv,1) = GCweakvll; + GCweakvll = weakv; + } + } +} + +/* + Screw: doesn't deal with finalization. + */ + +void +reaphashv(LispObj hashv) +{ + hash_table_vector_header + *hashp = (hash_table_vector_header *) ptr_from_lispobj(untag(hashv)); + natural + dnode, + npairs = (header_element_count(hashp->header) - + (hash_table_vector_header_count -1)) >> 1; + LispObj *pairp = (LispObj*) (hashp+1), weakelement; + Boolean + weak_on_value = ((hashp->flags & nhash_weak_value_mask) != 0); + Boolean + keys_frozen = ((hashp->flags & nhash_keys_frozen_mask) != 0); + bitvector markbits = GCmarkbits; + int tag; + + while (npairs--) { + if (weak_on_value) { + weakelement = pairp[1]; + } else { + weakelement = pairp[0]; + } + tag = fulltag_of(weakelement); + if (is_node_fulltag(tag)) { + dnode = gc_area_dnode(weakelement); + if ((dnode < GCndnodes_in_area) && + ! ref_bit(markbits, dnode)) { + pairp[0] = slot_unbound; + if (keys_frozen) { + if (pairp[1] != slot_unbound) { + pairp[1] = unbound; + } + } + else { + pairp[1] = lisp_nil; + } + hashp->weak_deletions_count += (1<header) - + (hash_table_vector_header_count - 1)) >> 1; + LispObj *pairp = (LispObj*) (hashp+1); + Boolean + weak_on_value = ((hashp->flags & nhash_weak_value_mask) != 0); + + + for (i = 2; i <= skip; i++) { + rmark(deref(htabv,i)); + } + + if (!weak_on_value) { + pairp++; + } + /* unconditionally mark the non-weak element of each pair */ + while (npairs--) { + rmark(*pairp); + pairp += 2; + } + + deref(htabv,1) = GCweakvll; + GCweakvll = htabv; +} + + +Boolean +mark_weak_hash_vector(hash_table_vector_header *hashp, natural elements) +{ + natural flags = hashp->flags, key_dnode, val_dnode; + Boolean + marked_new = false, + key_marked, + val_marked, + weak_value = ((flags & nhash_weak_value_mask) != 0); + int + skip = hash_table_vector_header_count-1, + key_tag, + val_tag, + i; + LispObj + *pairp = (LispObj*) (hashp+1), + key, + val; + + /* Mark everything in the header */ + + for (i = 2; i<= skip; i++) { + mark_root(deref(ptr_to_lispobj(hashp),i)); + } + + elements -= skip; + + for (i = 0; i> population_termination_bit) { + elements -= 1; + } + for(alist = deref(weak_alist, elements); + (fulltag_of(alist) == fulltag_cons) && + ((dnode = gc_area_dnode(alist)) < GCndnodes_in_area) && + (! ref_bit(markbits,dnode)); + alist = cdr(alist)) { + pair = car(alist); + pair_tag = fulltag_of(pair); + if ((is_node_fulltag(pair_tag)) && + ((dnode = gc_area_dnode(pair_tag)) < GCndnodes_in_area) && + (! ref_bit(markbits,dnode))) { + if (pair_tag == fulltag_cons) { + key = car(pair); + if ((! is_node_fulltag(fulltag_of(key))) || + ((dnode = gc_area_dnode(key)) >= GCndnodes_in_area) || + ref_bit(markbits,dnode)) { + /* key is marked, mark value if necessary */ + value = cdr(pair); + if (is_node_fulltag(fulltag_of(value)) && + ((dnode = gc_area_dnode(value)) < GCndnodes_in_area) && + (! ref_bit(markbits,dnode))) { + mark_root(value); + marked_new = true; + } + } + } else { + mark_root(pair); + marked_new = true; + } + } + } + return marked_new; +} + +void +traditional_markhtabvs() +{ + LispObj this, header, pending; + int subtag; + hash_table_vector_header *hashp; + Boolean marked_new; + + do { + pending = (LispObj) NULL; + marked_new = false; + + while (GCweakvll) { + this = GCweakvll; + GCweakvll = deref(this,1); + + header = header_of(this); + subtag = header_subtag(header); + + if (subtag == subtag_weak) { + natural weak_type = deref(this,2); + deref(this,1) = pending; + pending = this; + if ((weak_type & population_type_mask) == population_weak_alist) { + if (mark_weak_alist(this, weak_type)) { + marked_new = true; + } + } + } else if (subtag == subtag_hash_vector) { + natural elements = header_element_count(header); + + hashp = (hash_table_vector_header *) ptr_from_lispobj(untag(this)); + if (hashp->flags & nhash_weak_mask) { + deref(this,1) = pending; + pending = this; + if (mark_weak_hash_vector(hashp, elements)) { + marked_new = true; + } + } + } else { + Bug(NULL, "Strange object on weak vector linked list: 0x~08x\n", this); + } + } + + if (marked_new) { + GCweakvll = pending; + } + } while (marked_new); + + /* Now, everything's marked that's going to be, and "pending" is a list + of populations and weak hash tables. CDR down that list and free + anything that isn't marked. + */ + + while (pending) { + this = pending; + pending = deref(this,1); + deref(this,1) = (LispObj)NULL; + + subtag = header_subtag(header_of(this)); + if (subtag == subtag_weak) { + reapweakv(this); + } else { + reaphashv(this); + } + } + + /* Finally, mark the termination lists in all terminatable weak vectors + They are now linked together on GCweakvll. + This is where to store lisp_global(TERMINATION_LIST) if we decide to do that, + but it will force terminatable popualations to hold on to each other + (set TERMINATION_LIST before clearing GCweakvll, and don't clear deref(this,1)). + */ + pending = GCweakvll; + GCweakvll = (LispObj)NULL; + while (pending) { + this = pending; + pending = deref(this,1); + deref(this,1) = (LispObj)NULL; + mark_root(deref(this,1+3)); + } +} + +void +ncircle_markhtabvs() +{ + LispObj this, header, pending = 0; + int subtag; + Boolean marked_new; + + /* First, process any weak hash tables that may have + been encountered by the link-inverting marker; we + should have more stack space now. */ + + while (GCdwsweakvll) { + this = GCdwsweakvll; + GCdwsweakvll = deref(this,1); + ncircle_mark_weak_htabv(this); + } + + while (GCweakvll) { + this = GCweakvll; + GCweakvll = deref(this,1); + + header = header_of(this); + subtag = header_subtag(header); + + if (subtag == subtag_weak) { + natural weak_type = deref(this,2); + deref(this,1) = pending; + pending = this; + if ((weak_type & population_type_mask) == population_weak_alist) { + if (mark_weak_alist(this, weak_type)) { + marked_new = true; + } + } + } else if (subtag == subtag_hash_vector) { + reaphashv(this); + } + } + + /* Now, everything's marked that's going to be, and "pending" is a list + of populations. CDR down that list and free + anything that isn't marked. + */ + + while (pending) { + this = pending; + pending = deref(this,1); + deref(this,1) = (LispObj)NULL; + + subtag = header_subtag(header_of(this)); + if (subtag == subtag_weak) { + reapweakv(this); + } else { + Bug(NULL, "Bad object on pending list: %s\n", this); + } + } + + /* Finally, mark the termination lists in all terminatable weak vectors + They are now linked together on GCweakvll. + This is where to store lisp_global(TERMINATION_LIST) if we decide to do that, + but it will force terminatable popualations to hold on to each other + (set TERMINATION_LIST before clearing GCweakvll, and don't clear deref(this,1)). + */ + pending = GCweakvll; + GCweakvll = (LispObj)NULL; + while (pending) { + this = pending; + pending = deref(this,1); + deref(this,1) = (LispObj)NULL; + mark_root(deref(this,1+3)); + } +} + +void +mark_tcr_tlb(TCR *tcr) +{ + natural n = tcr->tlb_limit; + LispObj + *start = tcr->tlb_pointer, + *end = (LispObj *) ((BytePtr)start+n), + node; + + while (start < end) { + node = *start; + if (node != no_thread_local_binding_marker) { + mark_root(node); + } + start++; + } +} + +/* + Mark things that're only reachable through some (suspended) TCR. + (This basically means the tcr's gc_context and the exception + frames on its xframe_list.) +*/ + +void +mark_tcr_xframes(TCR *tcr) +{ + xframe_list *xframes; + ExceptionInformation *xp; + + xp = tcr->gc_context; + if (xp) { +#ifndef X8632 + mark_xp(xp); +#else + mark_xp(xp, tcr->node_regs_mask); +#endif + } +#ifdef X8632 + mark_root(tcr->save0); + mark_root(tcr->save1); + mark_root(tcr->save2); + mark_root(tcr->save3); + mark_root(tcr->next_method_context); +#endif + + for (xframes = (xframe_list *) tcr->xframe; + xframes; + xframes = xframes->prev) { +#ifndef X8632 + mark_xp(xframes->curr); +#else + mark_xp(xframes->curr, xframes->node_regs_mask); +#endif + } +} + + +void *postGCptrs = NULL; +struct xmacptr *user_postGC_macptrs = NULL; + + +void +postGCfree(void *p) +{ + *(void **)p = postGCptrs; + postGCptrs = p; +} + +void +postGCfreexmacptr(struct xmacptr *p) +{ + p->class = (LispObj) user_postGC_macptrs; + user_postGC_macptrs = p; +} + + +xmacptr_dispose_fn xmacptr_dispose_functions[xmacptr_flag_user_last-xmacptr_flag_user_first]; + + + +void +freeGCptrs() +{ + void *p, *next, *addr; + struct xmacptr *x, *xnext; + int i, flags; + xmacptr_dispose_fn dfn; + + for (p = postGCptrs; p; p = next) { + next = *((void **)p); + free(p); + } + postGCptrs = NULL; + + for (x = user_postGC_macptrs; x; x = xnext) { + xnext = (xmacptr *) (x->class);; + flags = x->flags - xmacptr_flag_user_first; + dfn = xmacptr_dispose_functions[flags]; + addr = (void *) x->address; + x->address = 0; + x->flags = 0; + x->link = 0; + x->class = 0; + if (dfn && addr) { + dfn(addr); + } + } + + user_postGC_macptrs = NULL; +} + +int +register_xmacptr_dispose_function(void *dfn) +{ + int i, k; + + for( i = 0, k = xmacptr_flag_user_first; k < xmacptr_flag_user_last; i++, k++) { + if (xmacptr_dispose_functions[i]==NULL) { + xmacptr_dispose_functions[i] = dfn; + return k; + } + if (xmacptr_dispose_functions[i] == dfn) { + return k; + } + } + return 0; +} + +void +reap_gcable_ptrs() +{ + LispObj *prev = &(lisp_global(GCABLE_POINTERS)), next, ptr; + xmacptr_flag flag; + natural dnode; + xmacptr *x; + + while((next = *prev) != (LispObj)NULL) { + dnode = gc_area_dnode(next); + x = (xmacptr *) ptr_from_lispobj(untag(next)); + + if ((dnode >= GCndnodes_in_area) || + (ref_bit(GCmarkbits,dnode))) { + prev = &(x->link); + } else { + *prev = x->link; + flag = (xmacptr_flag)(x->flags); + ptr = x->address; + + if (ptr) { + switch (flag) { + case xmacptr_flag_recursive_lock: + destroy_recursive_lock((RECURSIVE_LOCK)ptr_from_lispobj(ptr)); + break; + + case xmacptr_flag_ptr: + postGCfree((void *)ptr_from_lispobj(ptr)); + break; + + case xmacptr_flag_rwlock: + rwlock_destroy((rwlock *)ptr_from_lispobj(ptr)); + break; + + case xmacptr_flag_semaphore: + destroy_semaphore((void**)&(x->address)); + break; + + default: + if ((flag >= xmacptr_flag_user_first) && + (flag < xmacptr_flag_user_last)) { + set_n_bits(GCmarkbits,dnode,3); + postGCfreexmacptr(x); + break; + } + /* (warn "unknown xmacptr_flag: ~s" flag) */ + /* Unknowd, and perhaps unknowdable. */ + /* Fall in: */ + case xmacptr_flag_none: + break; + } + } + } + } +} + + + +#if WORD_SIZE == 64 +unsigned short *_one_bits = NULL; + +unsigned short +logcount16(unsigned short n) +{ + unsigned short c=0; + + while(n) { + n = n & (n-1); + c++; + } + return c; +} + +void +gc_init() +{ + int i; + + _one_bits = malloc(sizeof(unsigned short) * (1<<16)); + + for (i = 0; i < (1<<16); i++) { + _one_bits[i] = dnode_size*logcount16(i); + } +} + + +#else +const unsigned char _one_bits[256] = { + 0*8,1*8,1*8,2*8,1*8,2*8,2*8,3*8,1*8,2*8,2*8,3*8,2*8,3*8,3*8,4*8, + 1*8,2*8,2*8,3*8,2*8,3*8,3*8,4*8,2*8,3*8,3*8,4*8,3*8,4*8,4*8,5*8, + 1*8,2*8,2*8,3*8,2*8,3*8,3*8,4*8,2*8,3*8,3*8,4*8,3*8,4*8,4*8,5*8, + 2*8,3*8,3*8,4*8,3*8,4*8,4*8,5*8,3*8,4*8,4*8,5*8,4*8,5*8,5*8,6*8, + 1*8,2*8,2*8,3*8,2*8,3*8,3*8,4*8,2*8,3*8,3*8,4*8,3*8,4*8,4*8,5*8, + 2*8,3*8,3*8,4*8,3*8,4*8,4*8,5*8,3*8,4*8,4*8,5*8,4*8,5*8,5*8,6*8, + 2*8,3*8,3*8,4*8,3*8,4*8,4*8,5*8,3*8,4*8,4*8,5*8,4*8,5*8,5*8,6*8, + 3*8,4*8,4*8,5*8,4*8,5*8,5*8,6*8,4*8,5*8,5*8,6*8,5*8,6*8,6*8,7*8, + 1*8,2*8,2*8,3*8,2*8,3*8,3*8,4*8,2*8,3*8,3*8,4*8,3*8,4*8,4*8,5*8, + 2*8,3*8,3*8,4*8,3*8,4*8,4*8,5*8,3*8,4*8,4*8,5*8,4*8,5*8,5*8,6*8, + 2*8,3*8,3*8,4*8,3*8,4*8,4*8,5*8,3*8,4*8,4*8,5*8,4*8,5*8,5*8,6*8, + 3*8,4*8,4*8,5*8,4*8,5*8,5*8,6*8,4*8,5*8,5*8,6*8,5*8,6*8,6*8,7*8, + 2*8,3*8,3*8,4*8,3*8,4*8,4*8,5*8,3*8,4*8,4*8,5*8,4*8,5*8,5*8,6*8, + 3*8,4*8,4*8,5*8,4*8,5*8,5*8,6*8,4*8,5*8,5*8,6*8,5*8,6*8,6*8,7*8, + 3*8,4*8,4*8,5*8,4*8,5*8,5*8,6*8,4*8,5*8,5*8,6*8,5*8,6*8,6*8,7*8, + 4*8,5*8,5*8,6*8,5*8,6*8,6*8,7*8,5*8,6*8,6*8,7*8,6*8,7*8,7*8,8*8 +}; + + +void +gc_init() +{ +} + +#endif + + +weak_mark_fun dws_mark_weak_htabv = traditional_dws_mark_htabv; +weak_mark_fun mark_weak_htabv = traditional_mark_weak_htabv; +weak_process_fun markhtabvs = traditional_markhtabvs; + +void +install_weak_mark_functions(natural set) { + switch(set) { + case 0: + default: + dws_mark_weak_htabv = traditional_dws_mark_htabv; + mark_weak_htabv = traditional_mark_weak_htabv; + markhtabvs = traditional_markhtabvs; + break; + case 1: + dws_mark_weak_htabv = ncircle_dws_mark_htabv; + mark_weak_htabv = ncircle_mark_weak_htabv; + markhtabvs = ncircle_markhtabvs; + break; + } +} + +LispObj +node_forwarding_address(LispObj node) +{ + int tag_n; + natural dnode = gc_dynamic_area_dnode(node); + + if ((dnode >= GCndynamic_dnodes_in_area) || + (node < GCfirstunmarked)) { + return node; + } + + tag_n = fulltag_of(node); + if (!is_node_fulltag(tag_n)) { + return node; + } + + return dnode_forwarding_address(dnode, tag_n); +} + +Boolean +update_noderef(LispObj *noderef) +{ + LispObj + node = *noderef, + new = node_forwarding_address(node); + + if (new != node) { + *noderef = new; + return true; + } + return false; +} + +void +update_locref(LispObj *locref) +{ + LispObj + obj = *locref, + new = locative_forwarding_address(obj); + + if (new != obj) { + *locref = new; + } +} + +void +forward_gcable_ptrs() +{ + LispObj *prev = &(lisp_global(GCABLE_POINTERS)), next, new; + struct xmacptr **xprev, *xnext, *xnew; + + while ((next = *prev) != (LispObj)NULL) { + new = node_forwarding_address(next); + if (new != next) { + *prev = new; + } + prev = &(((xmacptr *)ptr_from_lispobj(untag(next)))->link); + } + xprev = &user_postGC_macptrs; + while (xnext = *xprev) { + xnew = (struct xmacptr *)locative_forwarding_address((LispObj)xnext); + if (xnew != xnext) { + *xprev = xnew; + } + xprev = (struct xmacptr **)(&(xnext->class)); + } +} + +void +forward_memoized_area(area *a, natural num_memo_dnodes) +{ + bitvector refbits = a->refbits; + LispObj *p = (LispObj *) a->low, x1, x2, new; + natural bits, bitidx, *bitsp, nextbit, diff, memo_dnode = 0, hash_dnode_limit = 0; + int tag_x1; + hash_table_vector_header *hashp = NULL; + Boolean header_p; + + if (num_memo_dnodes) { + if (GCDebug) { + check_refmap_consistency(p, p+(num_memo_dnodes << 1), refbits); + } + + /* This is pretty straightforward, but we have to note + when we move a key in a hash table vector that wants + us to tell it about that. */ + + set_bitidx_vars(refbits, 0, bitsp, bits, bitidx); + while (memo_dnode < num_memo_dnodes) { + if (bits == 0) { + int remain = nbits_in_word - bitidx; + memo_dnode += remain; + p += (remain+remain); + bits = *++bitsp; + bitidx = 0; + } else { + nextbit = count_leading_zeros(bits); + if ((diff = (nextbit - bitidx)) != 0) { + memo_dnode += diff; + bitidx = nextbit; + p += (diff+diff); + } + x1 = p[0]; + x2 = p[1]; + tag_x1 = fulltag_of(x1); + bits &= ~(BIT0_MASK >> bitidx); + header_p = (nodeheader_tag_p(tag_x1)); + + if (header_p && + (header_subtag(x1) == subtag_hash_vector)) { + hashp = (hash_table_vector_header *) p; + if (hashp->flags & nhash_track_keys_mask) { + hash_dnode_limit = memo_dnode + ((header_element_count(x1)+2)>>1); + } else { + hashp = NULL; + } + } + + + if (! header_p) { + new = node_forwarding_address(x1); + if (new != x1) { + *p = new; + } + } + p++; + + new = node_forwarding_address(x2); + if (new != x2) { + *p = new; + if (memo_dnode < hash_dnode_limit) { + /* If this code is reached, 'hashp' is non-NULL and pointing + at the header of a hash_table_vector, and 'memo_dnode' identifies + a pair of words inside the hash_table_vector. It may be + hard for program analysis tools to recognize that, but I + believe that warnings about 'hashp' being NULL here can + be safely ignored. */ + hashp->flags |= nhash_key_moved_mask; + hash_dnode_limit = 0; + hashp = NULL; + } + } + p++; + memo_dnode++; + bitidx++; + + } + } + } +} + +void +forward_tcr_tlb(TCR *tcr) +{ + natural n = tcr->tlb_limit; + LispObj + *start = tcr->tlb_pointer, + *end = (LispObj *) ((BytePtr)start+n), + node; + + while (start < end) { + node = *start; + if (node != no_thread_local_binding_marker) { + update_noderef(start); + } + start++; + } +} + +void +reclaim_static_dnodes() +{ + natural nstatic = tenured_area->static_dnodes, + i, + bits, + bitnum, + nfree = 0, + nstatic_conses = area_dnode(static_cons_area->high, static_cons_area->low); + cons *c = (cons *)tenured_area->low, *d; + bitvector bitsp = GCmarkbits; + LispObj head = lisp_global(STATIC_CONSES); + + for (i = 0; i < nstatic; i+= nbits_in_word, c+= nbits_in_word) { + bits = *bitsp++; + if (bits != ALL_ONES) { + for (bitnum = 0; bitnum < nbits_in_word; bitnum++) { + if (! (bits & (BIT0_MASK>>bitnum))) { + d = c + bitnum; + d->car = 0; + if (i < nstatic_conses) { + d->cdr = head; + head = ((LispObj)d)+fulltag_cons; + nfree++; + } else { + d->cdr = 0; + } + } + } + } + } + lisp_global(STATIC_CONSES) = head; + lisp_global(FREE_STATIC_CONSES)+=(nfree<active == a->high) { + return false; + } else { + for (a = a->younger; a; a = a->younger) { + if (a->active != a->high) { + return false; + } + } + }; + return true; +} + +Boolean just_purified_p = false; + +/* + All thread's stack areas have been "normalized", as + has the dynamic heap. (The "active" pointer in these areas + matches the stack pointer/freeptr value at the time that + the exception occurred.) +*/ + +#define get_time(when) gettimeofday(&when, NULL) + + + +#ifdef FORCE_DWS_MARK +#warning recursive marker disabled for testing; remember to re-enable it +#endif + + +Boolean +mark_static_ref(LispObj n, BytePtr dynamic_start, natural ndynamic_dnodes) +{ + int tag_n = fulltag_of(n); + natural dyn_dnode; + + if (nodeheader_tag_p(tag_n)) { + return (header_subtag(n) == subtag_hash_vector); + } + + if (is_node_fulltag (tag_n)) { + dyn_dnode = area_dnode(n, dynamic_start); + if (dyn_dnode < ndynamic_dnodes) { + mark_root(n); /* May or may not mark it */ + return true; /* but return true 'cause it's a dynamic node */ + } + } + return false; /* Not a heap pointer or not dynamic */ +} + +void +mark_managed_static_refs(area *a, BytePtr low_dynamic_address, natural ndynamic_dnodes) +{ + bitvector refbits = a->refbits; + LispObj *p = (LispObj *) a->low, x1, x2; + natural inbits, outbits, bits, bitidx, *bitsp, nextbit, diff, memo_dnode = 0, + num_memo_dnodes = a->ndnodes; + Boolean keep_x1, keep_x2; + + if (num_memo_dnodes) { + if (GCDebug) { + check_refmap_consistency(p, p+(num_memo_dnodes << 1), refbits); + } + + + set_bitidx_vars(refbits, 0, bitsp, bits, bitidx); + inbits = outbits = bits; + while (memo_dnode < num_memo_dnodes) { + if (bits == 0) { + int remain = nbits_in_word - bitidx; + memo_dnode += remain; + p += (remain+remain); + if (outbits != inbits) { + *bitsp = outbits; + } + bits = *++bitsp; + inbits = outbits = bits; + bitidx = 0; + } else { + nextbit = count_leading_zeros(bits); + if ((diff = (nextbit - bitidx)) != 0) { + memo_dnode += diff; + bitidx = nextbit; + p += (diff+diff); + } + x1 = *p++; + x2 = *p++; + bits &= ~(BIT0_MASK >> bitidx); + keep_x1 = mark_static_ref(x1, low_dynamic_address, ndynamic_dnodes); + keep_x2 = mark_static_ref(x2, low_dynamic_address, ndynamic_dnodes); + if ((keep_x1 == false) && + (keep_x2 == false)) { + outbits &= ~(BIT0_MASK >> bitidx); + } + memo_dnode++; + bitidx++; + } + } + if (GCDebug) { + p = (LispObj *) a->low; + check_refmap_consistency(p, p+(num_memo_dnodes << 1), refbits); + } + } +} + +void +gc(TCR *tcr, signed_natural param) +{ + struct timeval start, stop; + area *a = active_dynamic_area, *to = NULL, *from = NULL, *note = NULL; + unsigned timeidx = 1; + paging_info paging_info_start; + LispObj + pkg = 0, + itabvec = 0; + BytePtr oldfree = a->active; + TCR *other_tcr; + natural static_dnodes; + + install_weak_mark_functions(lisp_global(WEAK_GC_METHOD) >> fixnumshift); + +#ifndef FORCE_DWS_MARK + if ((natural) (tcr->cs_limit) == CS_OVERFLOW_FORCE_LIMIT) { + GCstack_limit = CS_OVERFLOW_FORCE_LIMIT; + } else { + GCstack_limit = (natural)(tcr->cs_limit)+(natural)page_size; + } +#else + GCstack_limit = CS_OVERFLOW_FORCE_LIMIT; +#endif + + GCephemeral_low = lisp_global(OLDEST_EPHEMERAL); + if (GCephemeral_low) { + GCn_ephemeral_dnodes=area_dnode(oldfree, GCephemeral_low); + } else { + GCn_ephemeral_dnodes = 0; + } + + if (GCn_ephemeral_dnodes) { + GCverbose = ((nrs_GC_EVENT_STATUS_BITS.vcell & egc_verbose_bit) != 0); + } else { + GCverbose = ((nrs_GC_EVENT_STATUS_BITS.vcell & gc_verbose_bit) != 0); + } + + if (GCephemeral_low) { + if ((oldfree-g1_area->low) < g1_area->threshold) { + to = g1_area; + note = a; + timeidx = 4; + } else if ((oldfree-g2_area->low) < g2_area->threshold) { + to = g2_area; + from = g1_area; + note = g1_area; + timeidx = 3; + } else { + to = tenured_area; + from = g2_area; + note = g2_area; + timeidx = 2; + } + } else { + note = tenured_area; + } + + if (GCverbose) { + char buf[16]; + + sample_paging_info(&paging_info_start); + comma_output_decimal(buf,16,area_dnode(oldfree,a->low) << dnode_shift); + if (GCephemeral_low) { + fprintf(dbgout, + "\n\n;;; Starting Ephemeral GC of generation %d", + (from == g2_area) ? 2 : (from == g1_area) ? 1 : 0); + } else { + fprintf(dbgout,"\n\n;;; Starting full GC"); + } + fprintf(dbgout, ", %s bytes allocated.\n", buf); + } + + get_time(start); + + /* The link-inverting marker might need to write to watched areas */ + unprotect_watched_areas(); + + lisp_global(IN_GC) = (1<markbits; + GCarealow = ptr_to_lispobj(a->low); + GCareadynamiclow = GCarealow+(static_dnodes << dnode_shift); + GCndnodes_in_area = gc_area_dnode(oldfree); + + if (GCndnodes_in_area) { + GCndynamic_dnodes_in_area = GCndnodes_in_area-static_dnodes; + GCdynamic_markbits = + GCmarkbits + ((GCndnodes_in_area-GCndynamic_dnodes_in_area)>>bitmap_shift); + + zero_bits(GCmarkbits, GCndnodes_in_area); + GCweakvll = (LispObj)NULL; + + if (GCn_ephemeral_dnodes == 0) { + /* For GCTWA, mark the internal package hash table vector of + *PACKAGE*, but don't mark its contents. */ + { + LispObj + itab; + natural + dnode, ndnodes; + + pkg = nrs_PACKAGE.vcell; + if ((fulltag_of(pkg) == fulltag_misc) && + (header_subtag(header_of(pkg)) == subtag_package)) { + itab = ((package *)ptr_from_lispobj(untag(pkg)))->itab; + itabvec = car(itab); + dnode = gc_area_dnode(itabvec); + if (dnode < GCndnodes_in_area) { + ndnodes = (header_element_count(header_of(itabvec))+1) >> 1; + set_n_bits(GCmarkbits, dnode, ndnodes); + } + } + } + } + + mark_root(lisp_global(STATIC_CONSES)); + + { + area *next_area; + area_code code; + + /* Could make a jump table instead of the typecase */ + + for (next_area = a->succ; (code = next_area->code) != AREA_VOID; next_area = next_area->succ) { + switch (code) { + case AREA_TSTACK: + mark_tstack_area(next_area); + break; + + case AREA_VSTACK: + mark_vstack_area(next_area); + break; + + case AREA_CSTACK: + mark_cstack_area(next_area); + break; + + case AREA_STATIC: + case AREA_WATCHED: + case AREA_DYNAMIC: /* some heap that isn't "the" heap */ + /* In both of these cases, we -could- use the area's "markbits" + bitvector as a reference map. It's safe (but slower) to + ignore that map and process the entire area. + */ + if (next_area->younger == NULL) { + mark_simple_area_range((LispObj *) next_area->low, (LispObj *) next_area->active); + } + break; + + default: + break; + } + } + } + + if (lisp_global(OLDEST_EPHEMERAL)) { + mark_memoized_area(tenured_area, area_dnode(a->low,tenured_area->low)); + } + + mark_managed_static_refs(managed_static_area,low_markable_address,area_dnode(a->active,low_markable_address)); + + other_tcr = tcr; + do { + mark_tcr_xframes(other_tcr); + mark_tcr_tlb(other_tcr); + other_tcr = other_tcr->next; + } while (other_tcr != tcr); + + + + + /* Go back through *package*'s internal symbols, marking + any that aren't worthless. + */ + + if (itabvec) { + natural + i, + n = header_element_count(header_of(itabvec)); + LispObj + sym, + *raw = 1+((LispObj *)ptr_from_lispobj(untag(itabvec))); + + for (i = 0; i < n; i++) { + sym = *raw++; + if (is_symbol_fulltag(sym)) { + lispsymbol *rawsym = (lispsymbol *)ptr_from_lispobj(untag(sym)); + natural dnode = gc_area_dnode(sym); + + if ((dnode < GCndnodes_in_area) && + (!ref_bit(GCmarkbits,dnode))) { + /* Symbol is in GC area, not marked. + Mark it if fboundp, boundp, or if + it has a plist or another home package. + */ + + if (FBOUNDP(rawsym) || + BOUNDP(rawsym) || + (rawsym->flags != 0) || /* SPECIAL, etc. */ + (rawsym->plist != lisp_nil) || + ((rawsym->package_predicate != pkg) && + (rawsym->package_predicate != lisp_nil))) { + mark_root(sym); + } + } + } + } + } + + (void)markhtabvs(); + + if (itabvec) { + natural + i, + n = header_element_count(header_of(itabvec)); + LispObj + sym, + *raw = 1+((LispObj *)ptr_from_lispobj(untag(itabvec))); + + for (i = 0; i < n; i++, raw++) { + sym = *raw; + if (is_symbol_fulltag(sym)) { + natural dnode = gc_area_dnode(sym); + + if ((dnode < GCndnodes_in_area) && + (!ref_bit(GCmarkbits,dnode))) { + *raw = unbound_marker; + } + } + } + } + + reap_gcable_ptrs(); + + GCrelocptr = global_reloctab; + GCfirstunmarked = calculate_relocation(); + + if (!GCephemeral_low) { + reclaim_static_dnodes(); + } + + forward_range((LispObj *) ptr_from_lispobj(GCarealow), (LispObj *) ptr_from_lispobj(GCfirstunmarked)); + + other_tcr = tcr; + do { + forward_tcr_xframes(other_tcr); + forward_tcr_tlb(other_tcr); + other_tcr = other_tcr->next; + } while (other_tcr != tcr); + + + forward_gcable_ptrs(); + + + + { + area *next_area; + area_code code; + + /* Could make a jump table instead of the typecase */ + + for (next_area = a->succ; (code = next_area->code) != AREA_VOID; next_area = next_area->succ) { + switch (code) { + case AREA_TSTACK: + forward_tstack_area(next_area); + break; + + case AREA_VSTACK: + forward_vstack_area(next_area); + break; + + case AREA_CSTACK: + forward_cstack_area(next_area); + break; + + case AREA_STATIC: + case AREA_WATCHED: + case AREA_DYNAMIC: /* some heap that isn't "the" heap */ + if (next_area->younger == NULL) { + forward_range((LispObj *) next_area->low, (LispObj *) next_area->active); + } + break; + + default: + break; + } + } + } + + if (GCephemeral_low) { + forward_memoized_area(tenured_area, area_dnode(a->low, tenured_area->low)); + } + + forward_memoized_area(managed_static_area,area_dnode(managed_static_area->active,managed_static_area->low)); + a->active = (BytePtr) ptr_from_lispobj(compact_dynamic_heap()); + if (to) { + tenure_to_area(to); + } + + zero_memory_range(a->active, oldfree); + + resize_dynamic_heap(a->active, + (GCephemeral_low == 0) ? lisp_heap_gc_threshold : 0); + + /* + If the EGC is enabled: If there's no room for the youngest + generation, untenure everything. If this was a full GC and + there's now room for the youngest generation, tenure everything. + */ + if (a->older != NULL) { + natural nfree = (a->high - a->active); + + + if (nfree < a->threshold) { + untenure_from_area(tenured_area); + } else { + if (GCephemeral_low == 0) { + tenure_to_area(tenured_area); + } + } + } + } + lisp_global(GC_NUM) += (1<gccount += (1<vcell; + if ((fulltag_of(val) == fulltag_misc) && + (header_subtag(header_of(val)) == subtag_macptr)) { + timersub(&stop, &start, &elapsed); + timeinfo = (struct timeval *) ptr_from_lispobj(((macptr *) ptr_from_lispobj(untag(val)))->address); + timeradd(timeinfo, &elapsed, timeinfo); + timeradd(timeinfo+timeidx, &elapsed, timeinfo+timeidx); + } + + val = total_bytes_freed->vcell; + if ((fulltag_of(val) == fulltag_misc) && + (header_subtag(header_of(val)) == subtag_macptr)) { + long long justfreed = oldfree - a->active; + *( (long long *) ptr_from_lispobj(((macptr *) ptr_from_lispobj(untag(val)))->address)) += justfreed; + if (GCverbose) { + char buf[16]; + paging_info paging_info_stop; + + sample_paging_info(&paging_info_stop); + if (justfreed <= heap_segment_size) { + justfreed = 0; + } + comma_output_decimal(buf,16,justfreed); + if (note == tenured_area) { + fprintf(dbgout,";;; Finished full GC. %s bytes freed in %d.%06d s\n\n", buf, elapsed.tv_sec, elapsed.tv_usec); + } else { + fprintf(dbgout,";;; Finished EGC of generation %d. %s bytes freed in %d.%06d s\n\n", + (from == g2_area) ? 2 : (from == g1_area) ? 1 : 0, + buf, + elapsed.tv_sec, elapsed.tv_usec); + } + report_paging_info_delta(dbgout, &paging_info_start, &paging_info_stop); + } + } + } +} Index: /branches/new-random/lisp-kernel/gc.h =================================================================== --- /branches/new-random/lisp-kernel/gc.h (revision 13309) +++ /branches/new-random/lisp-kernel/gc.h (revision 13309) @@ -0,0 +1,246 @@ +/* + Copyright (C) 2009 Clozure Associates + Copyright (C) 1994-2001 Digitool, Inc + This file is part of Clozure CL. + + Clozure CL is licensed under the terms of the Lisp Lesser GNU Public + License , known as the LLGPL and distributed with Clozure CL as the + file "LICENSE". The LLGPL consists of a preamble and the LGPL, + which is distributed with Clozure CL as the file "LGPL". Where these + conflict, the preamble takes precedence. + + Clozure CL is referenced in the preamble as the "LIBRARY." + + The LLGPL is also available online at + http://opensource.franz.com/preamble.html +*/ + +#ifndef __GC_H__ +#define __GC_H__ 1 + +#include "lisp.h" +#include "bits.h" +#include "lisp-exceptions.h" +#include "memprotect.h" + + + +#ifdef PPC +#define is_node_fulltag(f) ((1<<(f))&((1<>dnode_shift)) +#define gc_area_dnode(w) area_dnode(w,GCarealow) +#define gc_dynamic_area_dnode(w) area_dnode(w,GCareadynamiclow) + +#if defined(PPC64) || defined(X8632) +#define forward_marker subtag_forward_marker +#else +#define forward_marker fulltag_nil +#endif + +#ifdef PPC64 +#define VOID_ALLOCPTR ((LispObj)(0x8000000000000000-dnode_size)) +#else +#define VOID_ALLOCPTR ((LispObj)(-dnode_size)) +#endif + +#ifdef DARWIN +#include +typedef struct task_events_info paging_info; +#else +#ifndef WINDOWS +#include +typedef struct rusage paging_info; +#else +typedef natural paging_info; +#endif +#endif + +#undef __argv +#include + +void sample_paging_info(paging_info *); +void report_paging_info_delta(FILE*, paging_info *, paging_info *); + + +#define GC_TRAP_FUNCTION_IMMEDIATE_GC (-1) +#define GC_TRAP_FUNCTION_GC 0 +#define GC_TRAP_FUNCTION_PURIFY 1 +#define GC_TRAP_FUNCTION_IMPURIFY 2 +#define GC_TRAP_FUNCTION_FLASH_FREEZE 4 +#define GC_TRAP_FUNCTION_SAVE_APPLICATION 8 + +#define GC_TRAP_FUNCTION_GET_LISP_HEAP_THRESHOLD 16 +#define GC_TRAP_FUNCTION_SET_LISP_HEAP_THRESHOLD 17 +#define GC_TRAP_FUNCTION_USE_LISP_HEAP_THRESHOLD 18 +#define GC_TRAP_FUNCTION_ENSURE_STATIC_CONSES 19 +#define GC_TRAP_FUNCTION_EGC_CONTROL 32 +#define GC_TRAP_FUNCTION_CONFIGURE_EGC 64 +#define GC_TRAP_FUNCTION_FREEZE 129 +#define GC_TRAP_FUNCTION_THAW 130 + +Boolean GCDebug, GCverbose, just_purified_p; +bitvector GCmarkbits, GCdynamic_markbits; +LispObj GCarealow, GCareadynamiclow; +natural GCndnodes_in_area, GCndynamic_dnodes_in_area; +LispObj GCweakvll,GCdwsweakvll; +LispObj GCephemeral_low; +natural GCn_ephemeral_dnodes; +natural GCstack_limit; + +#if WORD_SIZE == 64 +unsigned short *_one_bits; +#else +const unsigned char _one_bits[256]; +#endif + +#define one_bits(x) _one_bits[x] + +natural static_dnodes_for_area(area *a); +void reapweakv(LispObj weakv); +void reaphashv(LispObj hashv); +Boolean mark_weak_hash_vector(hash_table_vector_header *hashp, natural elements); +Boolean mark_weak_alist(LispObj weak_alist, int weak_type); +void mark_tcr_tlb(TCR *); +void mark_tcr_xframes(TCR *); +void freeGCptrs(void); +void reap_gcable_ptrs(void); +unsigned short logcount16(unsigned short); +void gc_init(void); +LispObj node_forwarding_address(LispObj); +Boolean update_noderef(LispObj *); +void update_locref(LispObj *); +void forward_gcable_ptrs(void); +void forward_memoized_area(area *, natural); +void forward_tcr_tlb(TCR *); +void reclaim_static_dnodes(void); +Boolean youngest_non_null_area_p(area *); +void gc(TCR *, signed_natural); + +/* backend-interface */ + +typedef void (*weak_mark_fun) (LispObj); +weak_mark_fun mark_weak_htabv, dws_mark_weak_htabv; + +typedef void (*weak_process_fun)(void); + +weak_process_fun markhtabvs; + + +#define hash_table_vector_header_count (sizeof(hash_table_vector_header)/sizeof(LispObj)) + +void mark_root(LispObj); +void rmark(LispObj); +#ifdef X8632 +void mark_xp(ExceptionInformation *, natural); +#else +void mark_xp(ExceptionInformation *); +#endif +LispObj dnode_forwarding_address(natural, int); +LispObj locative_forwarding_address(LispObj); +void check_refmap_consistency(LispObj *, LispObj *, bitvector); +void check_all_areas(TCR *); +void mark_tstack_area(area *); +void mark_vstack_area(area *); +void mark_cstack_area(area *); +void mark_simple_area_range(LispObj *, LispObj *); +void mark_memoized_area(area *, natural); +LispObj calculate_relocation(void); +void forward_range(LispObj *, LispObj *); +void forward_tstack_area(area *); +void forward_vstack_area(area *); +void forward_cstack_area(area *); +LispObj compact_dynamic_heap(void); +signed_natural purify(TCR *, signed_natural); +signed_natural impurify(TCR *, signed_natural); +signed_natural gc_like_from_xp(ExceptionInformation *, signed_natural(*fun)(TCR *, signed_natural), signed_natural); + + +typedef enum { + xmacptr_flag_none = 0, /* Maybe already disposed by Lisp */ + xmacptr_flag_recursive_lock, /* recursive-lock */ + xmacptr_flag_ptr, /* malloc/free */ + xmacptr_flag_rwlock, /* read/write lock */ + xmacptr_flag_semaphore, /* semaphore */ + xmacptr_flag_user_first = 8, /* first user-defined dispose fn */ + xmacptr_flag_user_last = 16 /* exclusive upper bound */ +} xmacptr_flag; + + +typedef void (*xmacptr_dispose_fn)(void *); + +extern xmacptr_dispose_fn xmacptr_dispose_functions[]; + +extern bitvector global_mark_ref_bits, dynamic_mark_ref_bits, relocatable_mark_ref_bits; + + +#endif /* __GC_H__ */ Index: /branches/new-random/lisp-kernel/image.c =================================================================== --- /branches/new-random/lisp-kernel/image.c (revision 13309) +++ /branches/new-random/lisp-kernel/image.c (revision 13309) @@ -0,0 +1,619 @@ +/* + Copyright (C) 2002-2009 Clozure Associates + This file is part of Clozure CL. + + Clozure CL is licensed under the terms of the Lisp Lesser GNU Public + License , known as the LLGPL and distributed with Clozure CL as the + file "LICENSE". The LLGPL consists of a preamble and the LGPL, + which is distributed with Clozure CL as the file "LGPL". Where these + conflict, the preamble takes precedence. + + Clozure CL is referenced in the preamble as the "LIBRARY." + + The LLGPL is also available online at + http://opensource.franz.com/preamble.html +*/ + +#include "lisp.h" +#include "lisp_globals.h" +#include "area.h" +#include "image.h" +#include "gc.h" +#include +#include +#ifndef WINDOWS +#include +#endif +#include +#include + + + +#if defined(PPC64) || defined(X8632) +#define RELOCATABLE_FULLTAG_MASK \ + ((1<low), + *end = (LispObj *)(a->active), + low = (LispObj)image_base - bias, + high = ptr_to_lispobj(active_dynamic_area->active) - bias, + w0; + int fulltag; + + while (start < end) { + w0 = *start; + fulltag = fulltag_of(w0); + if (immheader_tag_p(fulltag)) { + start = (LispObj *)skip_over_ivector((natural)start, w0); + } else { +#ifdef X86 + if (header_subtag(w0) == subtag_function) { +#ifdef X8664 + int skip = ((int) start[1])+1; +#else + extern void update_self_references(LispObj *); + extern natural imm_word_count(LispObj); + + natural skip = (natural)imm_word_count(((LispObj)start)+fulltag_misc)+1; + update_self_references(start); +#endif + + start += skip; + if (((LispObj) start) & node_size) { + --start; + } + w0 = *start; + fulltag = fulltag_of(w0); + } +#endif + + if ((w0 >= low) && (w0 < high) && + ((1<= low) && (w0 < high) && + ((1< end) { + Bug(NULL, "Overran area bounds in relocate_area_contents"); + } +} + + + + +off_t +seek_to_next_page(int fd) +{ + off_t pos = LSEEK(fd, 0, SEEK_CUR); + pos = align_to_power_of_2(pos, log2_page_size); + return LSEEK(fd, pos, SEEK_SET); +} + +/* + fd is positioned to EOF; header has been allocated by caller. + If we find a trailer (and that leads us to the header), read + the header & return true else return false. +*/ +Boolean +find_openmcl_image_file_header(int fd, openmcl_image_file_header *header) +{ + openmcl_image_file_trailer trailer; + int disp; + off_t pos; + unsigned version, flags; + + pos = LSEEK(fd, 0, SEEK_END); + if (pos < 0) { + return false; + } + pos -= sizeof(trailer); + + if (LSEEK(fd, pos, SEEK_SET) < 0) { + return false; + } + if (read(fd, &trailer, sizeof(trailer)) != sizeof(trailer)) { + return false; + } + if ((trailer.sig0 != IMAGE_SIG0) || + (trailer.sig1 != IMAGE_SIG1) || + (trailer.sig2 != IMAGE_SIG2)) { + return false; + } + disp = trailer.delta; + + if (disp >= 0) { + return false; + } + if (LSEEK(fd, disp, SEEK_CUR) < 0) { + return false; + } + if (read(fd, header, sizeof(openmcl_image_file_header)) != + sizeof(openmcl_image_file_header)) { + return false; + } + if ((header->sig0 != IMAGE_SIG0) || + (header->sig1 != IMAGE_SIG1) || + (header->sig2 != IMAGE_SIG2) || + (header->sig3 != IMAGE_SIG3)) { + return false; + } + version = (header->abi_version) & 0xffff; + if (version < ABI_VERSION_MIN) { + fprintf(dbgout, "Heap image is too old for this kernel.\n"); + return false; + } + if (version > ABI_VERSION_MAX) { + fprintf(dbgout, "Heap image is too new for this kernel.\n"); + return false; + } + flags = header->flags; + if (flags != PLATFORM) { + fprintf(dbgout, "Heap image was saved for another platform.\n"); + return false; + } + return true; +} + +void +load_image_section(int fd, openmcl_image_section_header *sect) +{ + extern area* allocate_dynamic_area(unsigned); + off_t + pos = seek_to_next_page(fd), advance; + natural + mem_size = sect->memory_size; + void *addr; + area *a; + + advance = mem_size; + switch(sect->code) { + case AREA_READONLY: + if (!MapFile(pure_space_active, + pos, + align_to_power_of_2(mem_size,log2_page_size), + MEMPROTECT_RX, + fd)) { + return; + } + a = new_area(pure_space_active, pure_space_limit, AREA_READONLY); + pure_space_active += mem_size; + a->active = pure_space_active; + sect->area = a; + break; + + case AREA_STATIC: + if (!MapFile(static_space_active, + pos, + align_to_power_of_2(mem_size,log2_page_size), + MEMPROTECT_RWX, + fd)) { + return; + } + a = new_area(static_space_active, static_space_limit, AREA_STATIC); + static_space_active += mem_size; + a->active = static_space_active; + sect->area = a; + break; + + case AREA_DYNAMIC: + a = allocate_dynamic_area(mem_size); + if (!MapFile(a->low, + pos, + align_to_power_of_2(mem_size,log2_page_size), + MEMPROTECT_RWX, + fd)) { + return; + } + + a->static_dnodes = sect->static_dnodes; + sect->area = a; + break; + + case AREA_MANAGED_STATIC: + a = new_area(pure_space_limit, pure_space_limit+align_to_power_of_2(mem_size,log2_page_size), AREA_MANAGED_STATIC); + a->active = a->low+mem_size; + if (mem_size) { + natural + refbits_size = align_to_power_of_2((((mem_size>>dnode_shift)+7)>>3), + log2_page_size); + if (!MapFile(a->low, + pos, + align_to_power_of_2(mem_size,log2_page_size), + MEMPROTECT_RWX, + fd)) { + return; + } + /* Need to save/restore persistent refbits. */ + if (!MapFile(global_mark_ref_bits, + align_to_power_of_2(pos+mem_size,log2_page_size), + refbits_size, + MEMPROTECT_RW, + fd)) { + return; + } + advance += refbits_size; + } + sect->area = a; + a->ndnodes = area_dnode(a->active, a->low); + managed_static_area = a; + lisp_global(REF_BASE) = (LispObj) a->low; + break; + + /* In many respects, the static_cons_area is part of the dynamic + area; it's physically adjacent to it (immediately precedes the + dynamic area in memory) and its contents are subject to full + GC (but not compaction.) It's maintained as a seperate section + in the image file, at least for now. */ + + + case AREA_STATIC_CONS: + addr = (void *) lisp_global(HEAP_START); + a = new_area(addr-align_to_power_of_2(mem_size,log2_page_size), addr, AREA_STATIC_CONS); + if (mem_size) { + if (!MapFile(a->low, + pos, + align_to_power_of_2(mem_size,log2_page_size), + MEMPROTECT_RWX, + fd)) { + return; + } + } + a->ndnodes = area_dnode(a->active, a->low); + sect->area = a; + static_cons_area = a; + break; + + default: + return; + + } + LSEEK(fd, pos+advance, SEEK_SET); +} + +LispObj +load_openmcl_image(int fd, openmcl_image_file_header *h) +{ + LispObj image_nil = 0; + area *a; + if (find_openmcl_image_file_header(fd, h)) { + int i, nsections = h->nsections; + openmcl_image_section_header sections[nsections], *sect=sections; + LispObj bias = image_base - ACTUAL_IMAGE_BASE(h); +#if (WORD_SIZE== 64) + signed_natural section_data_delta = + ((signed_natural)(h->section_data_offset_high) << 32L) | h->section_data_offset_low; +#endif + + if (read (fd, sections, nsections*sizeof(openmcl_image_section_header)) != + nsections * sizeof(openmcl_image_section_header)) { + return 0; + } +#if WORD_SIZE == 64 + LSEEK(fd, section_data_delta, SEEK_CUR); +#endif + for (i = 0; i < nsections; i++, sect++) { + load_image_section(fd, sect); + a = sect->area; + if (a == NULL) { + return 0; + } + } + + for (i = 0, sect = sections; i < nsections; i++, sect++) { + a = sect->area; + switch(sect->code) { + case AREA_STATIC: + nilreg_area = a; +#ifdef PPC +#ifdef PPC64 + image_nil = ptr_to_lispobj(a->low + (1024*4) + sizeof(lispsymbol) + fulltag_misc); +#else + image_nil = (LispObj)(a->low + 8 + 8 + (1024*4) + fulltag_nil); +#endif +#endif +#ifdef X86 +#ifdef X8664 + image_nil = (LispObj)(a->low) + (1024*4) + fulltag_nil; +#else + image_nil = (LispObj)(a->low) + (1024*4) + fulltag_cons; +#endif +#endif + set_nil(image_nil); + if (bias) { + relocate_area_contents(a, bias); + } + make_dynamic_heap_executable(a->low, a->active); + add_area_holding_area_lock(a); + break; + + case AREA_READONLY: + if (bias && + (managed_static_area->active != managed_static_area->low)) { + UnProtectMemory(a->low, a->active-a->low); + relocate_area_contents(a, bias); + ProtectMemory(a->low, a->active-a->low); + } + readonly_area = a; + add_area_holding_area_lock(a); + break; + } + } + for (i = 0, sect = sections; i < nsections; i++, sect++) { + a = sect->area; + switch(sect->code) { + case AREA_MANAGED_STATIC: + if (bias) { + relocate_area_contents(a, bias); + } + add_area_holding_area_lock(a); + break; + case AREA_STATIC_CONS: + break; + case AREA_DYNAMIC: + lower_heap_start(static_cons_area->low,a); + if (bias) { + relocate_area_contents(a, bias); + } + resize_dynamic_heap(a->active, lisp_heap_gc_threshold); + xMakeDataExecutable(a->low, a->active - a->low); + break; + } + } + } + return image_nil; +} + +void +prepare_to_write_dynamic_space() +{ + area *a = active_dynamic_area; + LispObj + *start = (LispObj *)(a->low), + *end = (LispObj *) (a->active), + x1; + int tag, subtag, element_count; + + while (start < end) { + x1 = *start; + tag = fulltag_of(x1); + if (immheader_tag_p(tag)) { + subtag = header_subtag(x1); + if (subtag == subtag_macptr) { + if ((start[1] >= (natural)0x10000) && (start[1] < (natural)-0x10000)) { + /* Leave small pointers alone */ + *start = make_header(subtag_dead_macptr,header_element_count(x1)); + } + } + start = (LispObj *)skip_over_ivector((natural)start, x1); + } else if (nodeheader_tag_p(tag)) { + element_count = header_element_count(x1) | 1; + start += (element_count+1); + } else { + start += 2; + } + } +} + + + +int +write_file_and_section_headers(int fd, + openmcl_image_file_header *file_header, + openmcl_image_section_header* section_headers, + int nsections, + off_t *header_pos) +{ + *header_pos = seek_to_next_page(fd); + + if (LSEEK (fd, *header_pos, SEEK_SET) < 0) { + return errno; + } + if (write(fd, file_header, sizeof(*file_header)) != sizeof(*file_header)) { + return errno; + } + if (write(fd, section_headers, sizeof(section_headers[0])*nsections) + != (sizeof(section_headers[0])*nsections)) { + return errno; + } + return 0; +} + +natural +writebuf(int fd, char *bytes, natural n) +{ + natural remain = n, this_size; + signed_natural result; + + while (remain) { + this_size = remain; + if (this_size > INT_MAX) { + this_size = INT_MAX; + } + result = write(fd, bytes, this_size); + if (result < 0) { + return errno; + } + bytes += result; + + remain -= result; + } + return 0; +} + +OSErr +save_application(unsigned fd, Boolean egc_was_enabled) +{ + openmcl_image_file_header fh; + openmcl_image_section_header sections[NUM_IMAGE_SECTIONS]; + openmcl_image_file_trailer trailer; + area *areas[NUM_IMAGE_SECTIONS], *a; + int i, err; + off_t header_pos, eof_pos; +#if WORD_SIZE == 64 + off_t image_data_pos; + signed_natural section_data_delta; +#endif + + /* + Coerce macptrs to dead_macptrs. + */ + + prepare_to_write_dynamic_space(active_dynamic_area); + + /* + If we ever support continuing after saving an image, + undo this .. */ + + if (static_cons_area->high > static_cons_area->low) { + active_dynamic_area->low = static_cons_area->high; + tenured_area->static_dnodes -= area_dnode(static_cons_area->high, static_cons_area->low); + } + + areas[0] = nilreg_area; + areas[1] = readonly_area; + areas[2] = active_dynamic_area; + areas[3] = managed_static_area; + areas[4] = static_cons_area; + for (i = 0; i < NUM_IMAGE_SECTIONS; i++) { + a = areas[i]; + sections[i].code = a->code; + sections[i].area = NULL; + sections[i].memory_size = a->active - a->low; + if (a == active_dynamic_area) { + sections[i].static_dnodes = tenured_area->static_dnodes; + } else { + sections[i].static_dnodes = 0; + } + } + fh.sig0 = IMAGE_SIG0; + fh.sig1 = IMAGE_SIG1; + fh.sig2 = IMAGE_SIG2; + fh.sig3 = IMAGE_SIG3; + fh.timestamp = time(NULL); + CANONICAL_IMAGE_BASE(&fh) = IMAGE_BASE_ADDRESS; + ACTUAL_IMAGE_BASE(&fh) = image_base; + fh.nsections = NUM_IMAGE_SECTIONS; + fh.abi_version=ABI_VERSION_CURRENT; +#if WORD_SIZE == 64 + fh.section_data_offset_high = 0; + fh.section_data_offset_low = 0; +#else + fh.pad0[0] = fh.pad0[1] = 0; + fh.pad1[0] = fh.pad1[1] = fh.pad1[2] = fh.pad1[3] = 0; +#endif + fh.flags = PLATFORM; + +#if WORD_SIZE == 64 + image_data_pos = seek_to_next_page(fd); +#else + err = write_file_and_section_headers(fd, &fh, sections, NUM_IMAGE_SECTIONS, &header_pos); + if (err) { + return err; + } +#endif + + + { + area *g0_area = g1_area->younger; + + /* Save GC config */ + lisp_global(LISP_HEAP_THRESHOLD) = lisp_heap_gc_threshold; + lisp_global(G0_THRESHOLD) = g0_area->threshold; + lisp_global(G1_THRESHOLD) = g1_area->threshold; + lisp_global(G2_THRESHOLD) = g2_area->threshold; + lisp_global(EGC_ENABLED) = (LispObj)egc_was_enabled; + } + /* + lisp_global(GC_NUM) and lisp_global(FWDNUM) are persistent, + as is DELETED_STATIC_PAIRS. + Nothing else is even meaningful at this point. + */ + for (i = MIN_KERNEL_GLOBAL; i < 0; i++) { + switch (i) { + case FREE_STATIC_CONSES: + case FWDNUM: + case GC_NUM: + case STATIC_CONSES: + case WEAK_GC_METHOD: + case LISP_HEAP_THRESHOLD: + case EGC_ENABLED: + case G0_THRESHOLD: + case G1_THRESHOLD: + case G2_THRESHOLD: + break; + default: + lisp_global(i) = 0; + } + } + + for (i = 0; i < NUM_IMAGE_SECTIONS; i++) { + natural n; + a = areas[i]; + seek_to_next_page(fd); + n = sections[i].memory_size; + if (writebuf(fd, a->low, n)) { + return errno; + } + if (n && ((sections[i].code) == AREA_MANAGED_STATIC)) { + natural ndnodes = area_dnode(a->active, a->low); + natural nrefbytes = align_to_power_of_2((ndnodes+7)>>3,log2_page_size); + + seek_to_next_page(fd); + if (writebuf(fd,(char*)a->refbits,nrefbytes)) { + return errno; + } + } + } + +#if WORD_SIZE == 64 + seek_to_next_page(fd); + section_data_delta = -((LSEEK(fd,0,SEEK_CUR)+sizeof(fh)+sizeof(sections)) - + image_data_pos); + fh.section_data_offset_high = (int)(section_data_delta>>32L); + fh.section_data_offset_low = (unsigned)section_data_delta; + err = write_file_and_section_headers(fd, &fh, sections, NUM_IMAGE_SECTIONS, &header_pos); + if (err) { + return err; + } +#endif + + trailer.sig0 = IMAGE_SIG0; + trailer.sig1 = IMAGE_SIG1; + trailer.sig2 = IMAGE_SIG2; + eof_pos = LSEEK(fd, 0, SEEK_CUR) + sizeof(trailer); + trailer.delta = (int) (header_pos-eof_pos); + if (write(fd, &trailer, sizeof(trailer)) == sizeof(trailer)) { +#ifndef WINDOWS + fsync(fd); +#endif + close(fd); + return 0; + } + i = errno; + close(fd); + return i; +} + + + + Index: /branches/new-random/lisp-kernel/image.h =================================================================== --- /branches/new-random/lisp-kernel/image.h (revision 13309) +++ /branches/new-random/lisp-kernel/image.h (revision 13309) @@ -0,0 +1,96 @@ +/* + Copyright (C) 2002-2009 Clozure Associates + This file is part of Clozure CL. + + Clozure CL is licensed under the terms of the Lisp Lesser GNU Public + License , known as the LLGPL and distributed with Clozure CL as the + file "LICENSE". The LLGPL consists of a preamble and the LGPL, + which is distributed with Clozure CL as the file "LGPL". Where these + conflict, the preamble takes precedence. + + Clozure CL is referenced in the preamble as the "LIBRARY." + + The LLGPL is also available online at + http://opensource.franz.com/preamble.html +*/ + + +#define IMAGE_SIG0 (('O'<<24) | ('p'<<16) | ('e'<<8) | 'n') +#define IMAGE_SIG1 (('M'<<24) | ('C'<<16) | ('L'<<8) | 'I') +#define IMAGE_SIG2 (('m'<<24) | ('a'<<16) | ('g'<<8) | 'e') +#define IMAGE_SIG3 (('F'<<24) | ('i'<<16) | ('l'<<8) | 'e') + +/* + An image file contains a header (which describes the type, size, + and nominal memory address of one or more sections) and data for + each section; each section's data is page-aligned within the image + file, so its disk address is implicit. The header must reside + entirely within a page; the first section's data starts on the page + after the image header, and subsequent sections start on the pages + after the page which contains the last byte of their predecessor's + data. + + The image header's position relative to the start of the file is + arbitrary. The image header's position relative to the end of the + file is indicated by the last word in the file (which is preceded + by the first three signature words above.) The last word contains + the distance from the end-of-file to the start of the header. + + As long as these alignment constraints are met, the image file can + have arbitrary data (or executable programs, or shell scripts) + prepended to it. This is supposed to simplify distribution. +*/ + +typedef struct { + natural code; + area *area; + natural memory_size; + natural static_dnodes; +} openmcl_image_section_header; + +typedef struct { + unsigned sig0, sig1, sig2, sig3; + unsigned timestamp; + unsigned canonical_image_base_32; /* IMAGE_BASE_ADDRESS */ + unsigned actual_image_base_32; /* Hopefully the same */ + unsigned nsections; + unsigned abi_version; +#if WORD_SIZE == 64 + int section_data_offset_high; /* signed offset from end of + section headers to first + section's data. May be zero. */ + unsigned section_data_offset_low; + unsigned flags; + natural canonical_image_base_64; + natural actual_image_base_64; +#else + unsigned pad0[2]; + unsigned flags; + unsigned pad1[4]; +#endif +} openmcl_image_file_header; + +#if WORD_SIZE == 64 +#define ACTUAL_IMAGE_BASE(header) ((header)->actual_image_base_64) +#define CANONICAL_IMAGE_BASE(header) ((header)->canonical_image_base_64) +#else +#define ACTUAL_IMAGE_BASE(header) ((header)->actual_image_base_32) +#define CANONICAL_IMAGE_BASE(header) ((header)->canonical_image_base_32) +#endif + +typedef struct { + unsigned sig0, sig1, sig2; + int delta; +} openmcl_image_file_trailer; + +LispObj +load_openmcl_image(int, openmcl_image_file_header*); + + + + +#define ABI_VERSION_MIN 1036 +#define ABI_VERSION_CURRENT 1036 +#define ABI_VERSION_MAX 1036 + +#define NUM_IMAGE_SECTIONS 5 /* used to be 3 */ Index: /branches/new-random/lisp-kernel/imports.s =================================================================== --- /branches/new-random/lisp-kernel/imports.s (revision 13309) +++ /branches/new-random/lisp-kernel/imports.s (revision 13309) @@ -0,0 +1,120 @@ +/* Copyright (C) 2009 Clozure Associates */ +/* Copyright (C) 1994-2001 Digitool, Inc */ +/* This file is part of Clozure CL. */ + +/* Clozure CL is licensed under the terms of the Lisp Lesser GNU Public */ +/* License , known as the LLGPL and distributed with Clozure CL as the */ +/* file "LICENSE". The LLGPL consists of a preamble and the LGPL, */ +/* which is distributed with Clozure CL as the file "LGPL". Where these */ +/* conflict, the preamble takes precedence. */ + +/* Clozure CL is referenced in the preamble as the "LIBRARY." */ + +/* The LLGPL is also available online at */ +/* http://opensource.franz.com/preamble.html */ + + include(m4macros.m4) +define([PTR],[ + __ifdef([PPC64]) + .quad $1 + __else + __ifdef([X8664]) + .quad $1 + __else + .long $1 + __endif + __endif +]) + _beginfile + + + .globl C(import_ptrs_base) +define([defimport],[ + .globl C($1) + PTR(C($1)) + +# __line__ +]) + .data +import_ptrs_start: + + defimport(fd_setsize_bytes) + defimport(do_fd_set) + defimport(do_fd_clr) + defimport(do_fd_is_set) + defimport(do_fd_zero) + defimport(xMakeDataExecutable) + defimport(xGetSharedLibrary) + defimport(xFindSymbol) + defimport(allocate) + defimport(deallocate) + defimport(jvm_init) + defimport(tcr_frame_ptr) + defimport(register_xmacptr_dispose_function) + defimport(open_debug_output) + defimport(get_r_debug) + defimport(restore_soft_stack_limit) + defimport(lisp_egc_control) + defimport(lisp_bug) + defimport(xNewThread) + defimport(cooperative_thread_startup) + defimport(xDisposeThread) + defimport(xThreadCurrentStackSpace) + defimport(usage_exit) + defimport(save_fp_context) + defimport(restore_fp_context) + defimport(put_vector_registers) + defimport(get_vector_registers) + defimport(new_semaphore) + defimport(wait_on_semaphore) + defimport(signal_semaphore) + defimport(destroy_semaphore) + defimport(new_recursive_lock) + defimport(lock_recursive_lock) + defimport(unlock_recursive_lock) + defimport(destroy_recursive_lock) + defimport(lisp_suspend_other_threads) + defimport(lisp_resume_other_threads) + defimport(lisp_suspend_tcr) + defimport(lisp_resume_tcr) + defimport(rwlock_new) + defimport(rwlock_destroy) + defimport(rwlock_rlock) + defimport(rwlock_wlock) + defimport(rwlock_unlock) + defimport(recursive_lock_trylock) + defimport(foreign_name_and_offset) + defimport(lisp_read) + defimport(lisp_write) + defimport(lisp_open) + defimport(lisp_fchmod) + defimport(lisp_lseek) + defimport(lisp_close) + defimport(lisp_ftruncate) + defimport(lisp_stat) + defimport(lisp_fstat) + defimport(lisp_futex) + defimport(lisp_opendir) + defimport(lisp_readdir) + defimport(lisp_closedir) + defimport(lisp_pipe) + defimport(lisp_gettimeofday) + defimport(lisp_sigexit) + + .globl C(import_ptrs_base) +C(import_ptrs_base): + PTR(import_ptrs_start) + + __ifdef([PPC]) + __ifdef([LINUX]) + __ifndef([PPC64]) + .globl __trampoline_setup + .long __trampoline_setup + __endif + __endif + __endif + + + + + _endfile Index: /branches/new-random/lisp-kernel/kernel-globals.h =================================================================== --- /branches/new-random/lisp-kernel/kernel-globals.h (revision 13309) +++ /branches/new-random/lisp-kernel/kernel-globals.h (revision 13309) @@ -0,0 +1,33 @@ +/* + Copyright (C) 2009 Clozure Associates + Copyright (C) 1994-2001 Digitool, Inc + This file is part of Clozure CL. + + Clozure CL is licensed under the terms of the Lisp Lesser GNU Public + License , known as the LLGPL and distributed with Clozure CL as the + file "LICENSE". The LLGPL consists of a preamble and the LGPL, + which is distributed with Clozure CL as the file "LGPL". Where these + conflict, the preamble takes precedence. + + Clozure CL is referenced in the preamble as the "LIBRARY." + + The LLGPL is also available online at + http://opensource.franz.com/preamble.html +*/ + +#ifndef __kernel_globals__ +#define __kernel_globals__ +#include "area.h" + + +extern area *nilreg_area, *tenured_area, *g2_area, *g1_area, *managed_static_area, *readonly_area, *static_cons_area; +extern area *all_areas; +extern int cache_block_size; + + + + + + + +#endif /* __kernel_globals__ */ Index: /branches/new-random/lisp-kernel/linuxppc/.cvsignore =================================================================== --- /branches/new-random/lisp-kernel/linuxppc/.cvsignore (revision 13309) +++ /branches/new-random/lisp-kernel/linuxppc/.cvsignore (revision 13309) @@ -0,0 +1,1 @@ +*~.* Index: /branches/new-random/lisp-kernel/linuxppc/.gdbinit =================================================================== --- /branches/new-random/lisp-kernel/linuxppc/.gdbinit (revision 13309) +++ /branches/new-random/lisp-kernel/linuxppc/.gdbinit (revision 13309) @@ -0,0 +1,120 @@ +directory lisp-kernel + +define header32 +x/x $arg0-6 +end + +define header64 +x/x $arg0-12 +end + +define lisp_string32 +x/s ($arg0-2) +end + +define lisp_string64 +x/s (($arg0)-4) +end + +define pname32 +lisp_string32 (*($arg0-2)) +end + +# GDB's expression parser seems to have difficulty +# with this unless the temporary is used. +define pname64 +set $temp=*((long *)((long)($arg0-4))) +lisp_string64 $temp +end + +define ada + p *all_areas->succ +end + +define _TCR + p/x *(TCR *) $arg0 +end + +define tcr32 + _TCR $r13 +end + +define tcr64 + _TCR $r2 +end + +define regs32 + p/x *(((struct pt_regs **)$arg0)[12]) +end + +define regs64 + p/x * (((ExceptionInformation *)$arg0)->uc_mcontext.regs) +end + +define xpGPR + p/x (((struct pt_regs **)$arg0)[12])->gpr[$arg1] +end + +define xpPC + p/x ((ExceptionInformation *)$arg0)->uc_mcontext.regs->nip +end + +define lisp_string + if $ppc64 + lisp_string64 $arg0 + else + lisp_string32 $arg0 + end +end + +define pname + if $ppc64 + pname64 $arg0 + else + pname32 $arg0 + end +end + +define tcr + if $ppc64 + tcr64 + else + tcr32 + end +end + +define regs + if $ppc64 + regs64 $arg0 + else + regs32 $arg0 + end +end + +define xpGPR + if $ppc64 + xpGPR64 $arg0 $arg1 + else + xpGPR32 $arg0 $arg1 + end +end + +define lisp + call print_lisp_object($arg0) +end + +set $ppc64=0 + + +break Bug + +handle SIGILL pass nostop noprint +handle SIGSEGV pass nostop noprint +handle SIGBUS pass nostop noprint +handle SIGFPE pass nostop noprint +handle SIG40 pass nostop noprint +handle SIG41 pass nostop noprint +handle SIG42 pass nostop noprint +handle SIGPWR pass nostop noprint + +display/i $pc Index: /branches/new-random/lisp-kernel/linuxppc/Makefile =================================================================== --- /branches/new-random/lisp-kernel/linuxppc/Makefile (revision 13309) +++ /branches/new-random/lisp-kernel/linuxppc/Makefile (revision 13309) @@ -0,0 +1,107 @@ +# +# Copyright (C) 1994-2001 Digitool, Inc +# This file is part of Clozure CL. +# +# Clozure CL is licensed under the terms of the Lisp Lesser GNU Public +# License , known as the LLGPL and distributed with Clozure CL as the +# file "LICENSE". The LLGPL consists of a preamble and the LGPL, +# which is distributed with Clozure CL as the file "LGPL". Where these +# conflict, the preamble takes precedence. +# +# Clozure CL is referenced in the preamble as the "LIBRARY." +# +# The LLGPL is also available online at +# http://opensource.franz.com/preamble.html + + +VPATH = ../ +RM = /bin/rm +# Versions of GNU as >= 2.9.1 all seem to work +# AS = gas-2.9.1 +AS = as +M4 = m4 +ASFLAGS = -mregnames -mppc32 -maltivec +M4FLAGS = -DLINUX -DPPC +CDEFINES = -DLINUX -DPPC -D_REENTRANT -D_GNU_SOURCE +CDEBUG = -g +COPT = -O2 +# Once in a while, -Wformat says something useful. The odds are against that, +# however. +WFORMAT = -Wno-format + +# If the linker supports a "--hash-style=" option, use traditional +# Sysv hash tables. (If it doesn't support that option, assume +# that traditional hash tables will be used by default.) +ld_has_hash_style = $(shell $(LD) --help | grep "hash-style=") +ifeq ($(ld_has_hash_style),) +HASH_STYLE= +else +HASH_STYLE="-Wl,--hash-style=sysv" +endif + +# The only version of GCC I have that supports both ppc32 and ppc64 +# compilation uses the -m32 option to target ppc32. This may not be +# definitive; there seem to be a bewildering array of similar options +# in other GCC versions. It's assumed here that if "-m32" is recognized, +# it's required as well. + +PPC32 = $(shell ($(CC) --help -v 2>&1 | grep -q -e "-m32 ") && /bin/echo "-m32") + +# Likewise, some versions of GAS may need a "-a32" flag, to force the +# output file to be 32-bit compatible. + +A32 = $(shell ($(AS) --help -v 2>&1 | grep -q -e "-a32") && /bin/echo "-a32") + +.s.o: + $(M4) $(M4FLAGS) -I../ $< | $(AS) $(A32) $(ASFLAGS) -o $@ +.c.o: + $(CC) -c $< $(CDEFINES) $(CDEBUG) $(COPT) $(WFORMAT) $(PPC32) -o $@ + +SPOBJ = pad.o ppc-spjump.o ppc-spentry.o ppc-subprims.o +ASMOBJ = ppc-asmutils.o imports.o + +COBJ = pmcl-kernel.o gc-common.o ppc-gc.o bits.o ppc-exceptions.o \ + image.o thread_manager.o lisp-debug.o memory.o unix-calls.o + +DEBUGOBJ = lispdcmd.o plprint.o plsym.o plbt.o ppc_print.o +KERNELOBJ= $(COBJ) ppc-asmutils.o imports.o + +SPINC = lisp.s m4macros.m4 ppc-constants.s ppc-macros.s errors.s ppc-uuo.s ppc-constants32.s + +CHEADERS = area.h bits.h ppc-constants.h lisp-errors.h gc.h lisp.h \ + lisp-exceptions.h lisp_globals.h macros.h memprotect.h image.h \ + Threads.h ppc-constants32.h ppc-exceptions.h + +# Subprims linked into the kernel ? +# Yes: + +KSPOBJ = $(SPOBJ) +all: ../../ppccl + + +# No: + +# KSPOBJ= +# all: ../../ppccl ../../subprims.so + +OSLIBS = -ldl -lm -lpthread + + +../../ppccl: $(KSPOBJ) $(KERNELOBJ) $(DEBUGOBJ) + $(CC) $(PPC32) $(CDEBUG) -Wl,--export-dynamic $(HASH_STYLE) -o $@ -T ./elf32ppclinux.x $(KSPOBJ) $(KERNELOBJ) $(DEBUGOBJ) $(OSLIBS) + + +$(SPOBJ): $(SPINC) +$(ASMOBJ): $(SPINC) +$(COBJ): $(CHEADERS) +$(DEBUGOBJ): $(CHEADERS) lispdcmd.h + + +cclean: + $(RM) -f $(KERNELOBJ) $(DEBUGOBJ) ../../ppccl + +clean: cclean + $(RM) -f $(SPOBJ) + +strip: ../../ppccl + strip -g ../../ppccl Index: /branches/new-random/lisp-kernel/linuxppc/elf32ppclinux.x =================================================================== --- /branches/new-random/lisp-kernel/linuxppc/elf32ppclinux.x (revision 13309) +++ /branches/new-random/lisp-kernel/linuxppc/elf32ppclinux.x (revision 13309) @@ -0,0 +1,253 @@ +OUTPUT_FORMAT("elf32-powerpc", "elf32-powerpc", + "elf32-powerpc") +OUTPUT_ARCH(powerpc:common) +ENTRY(_start) +SEARCH_DIR(/lib); SEARCH_DIR(/usr/lib); SEARCH_DIR(/usr/local/lib); SEARCH_DIR(/usr/powerpc-linux/lib); +/* Do we need any of these for elf? + __DYNAMIC = 0; */ +VERSION {default { global : __trampoline_setup ; } ;} +SECTIONS +{ + PROVIDE (__executable_start = 0x00010000); + . = 0x00010000 + SIZEOF_HEADERS; + .pad : { pad.o(.text) } + .subprims ALIGN(0x1000) : + { + ppc-spjump.o(.text) + ppc-spentry.o(.text) + ppc-subprims.o(.text) + } + /* Read-only sections, merged into text segment: */ +/* . = 0x10000000; */ + .interp : { *(.interp) } + .hash : { *(.hash) } + .dynsym : { *(.dynsym) } + .dynstr : { *(.dynstr) } + .gnu.version : { *(.gnu.version) } + .gnu.version_d : { *(.gnu.version_d) } + .gnu.version_r : { *(.gnu.version_r) } + .rel.init : { *(.rel.init) } + .rela.init : { *(.rela.init) } + .rel.text : + { + *(.rel.text) + *(.rel.text.*) + *(.rel.gnu.linkonce.t*) + } + .rela.text : + { + *(.rela.text) + *(.rela.text.*) + *(.rela.gnu.linkonce.t*) + } + .rel.fini : { *(.rel.fini) } + .rela.fini : { *(.rela.fini) } + .rel.rodata : + { + *(.rel.rodata) + *(.rel.rodata.*) + *(.rel.gnu.linkonce.r*) + } + .rela.rodata : + { + *(.rela.rodata) + *(.rela.rodata.*) + *(.rela.gnu.linkonce.r*) + } + .rel.data : + { + *(.rel.data) + *(.rel.data.*) + *(.rel.gnu.linkonce.d*) + } + .rela.data : + { + *(.rela.data) + *(.rela.data.*) + *(.rela.gnu.linkonce.d*) + } + .rel.ctors : { *(.rel.ctors) } + .rela.ctors : { *(.rela.ctors) } + .rel.dtors : { *(.rel.dtors) } + .rela.dtors : { *(.rela.dtors) } + .rel.got : { *(.rel.got) } + .rela.got : { *(.rela.got) } + .rel.sdata : + { + *(.rel.sdata) + *(.rel.sdata.*) + *(.rel.gnu.linkonce.s*) + } + .rela.sdata : + { + *(.rela.sdata) + *(.rela.sdata.*) + *(.rela.gnu.linkonce.s*) + } + .rel.sbss : { *(.rel.sbss) } + .rela.sbss : { *(.rela.sbss) } + .rel.sdata2 : { *(.rel.sdata2) } + .rela.sdata2 : { *(.rela.sdata2) } + .rel.sbss2 : { *(.rel.sbss2) } + .rela.sbss2 : { *(.rela.sbss2) } + .rel.bss : { *(.rel.bss) } + .rela.bss : { *(.rela.bss) } + .rel.plt : { *(.rel.plt) } + .rela.plt : { *(.rela.plt) } + .init : + { + KEEP (*(.init)) + } =0 + .text : + { + *(.text) + *(.text.*) + *(.stub) + /* .gnu.warning sections are handled specially by elf32.em. */ + *(.gnu.warning) + *(.gnu.linkonce.t*) + } =0 + .fini : + { + KEEP (*(.fini)) + } =0 + PROVIDE (__etext = .); + PROVIDE (_etext = .); + PROVIDE (etext = .); + .rodata : { *(.rodata) *(.rodata.*) *(.gnu.linkonce.r*) } + .rodata1 : { *(.rodata1) } + .sdata2 : { *(.sdata2) } + .sbss2 : { *(.sbss2) } + /* Adjust the address for the data segment. We want to adjust up to + the same address within the page on the next page up. */ + . = ALIGN(0x10000) + (. & (0x10000 - 1)); + /* Ensure the __preinit_array_start label is properly aligned. We + could instead move the label definition inside the section, but + the linker would then create the section even if it turns out to + be empty, which isn't pretty. */ + . = ALIGN(32 / 8); + PROVIDE (__preinit_array_start = .); + .preinit_array : { *(.preinit_array) } + PROVIDE (__preinit_array_end = .); + PROVIDE (__init_array_start = .); + .init_array : { *(.init_array) } + PROVIDE (__init_array_end = .); + PROVIDE (__fini_array_start = .); + .fini_array : { *(.fini_array) } + PROVIDE (__fini_array_end = .); + .data : + { + *(.data) + *(.data.*) + *(.gnu.linkonce.d*) + SORT(CONSTRUCTORS) + } + .data1 : { *(.data1) } + .eh_frame : { *(.eh_frame) } + .gcc_except_table : { *(.gcc_except_table) } + .got1 : { *(.got1) } + .got2 : { *(.got2) } + .ctors : + { + /* gcc uses crtbegin.o to find the start of + the constructors, so we make sure it is + first. Because this is a wildcard, it + doesn't matter if the user does not + actually link against crtbegin.o; the + linker won't look for a file to match a + wildcard. The wildcard also means that it + doesn't matter which directory crtbegin.o + is in. */ + KEEP (*crtbegin.o(.ctors)) + /* We don't want to include the .ctor section from + from the crtend.o file until after the sorted ctors. + The .ctor section from the crtend file contains the + end of ctors marker and it must be last */ + KEEP (*(EXCLUDE_FILE (*crtend.o ) .ctors)) + KEEP (*(SORT(.ctors.*))) + KEEP (*(.ctors)) + } + .dtors : + { + KEEP (*crtbegin.o(.dtors)) + KEEP (*(EXCLUDE_FILE (*crtend.o ) .dtors)) + KEEP (*(SORT(.dtors.*))) + KEEP (*(.dtors)) + } + .got : { *(.got.plt) *(.got) } + .dynamic : { *(.dynamic) } + /* We want the small data sections together, so single-instruction offsets + can access them all, and initialized data all before uninitialized, so + we can shorten the on-disk segment size. */ + .sdata : + { + PROVIDE (_SDA_BASE_ = .); + *(.sdata) + *(.sdata.*) + *(.gnu.linkonce.s.*) + } + _edata = .; + PROVIDE (edata = .); + __bss_start = .; + .sbss : + { + PROVIDE (__sbss_start = .); + PROVIDE (___sbss_start = .); + *(.dynsbss) + *(.sbss) + *(.sbss.*) + *(.scommon) + PROVIDE (__sbss_end = .); + PROVIDE (___sbss_end = .); + } + .plt : { *(.plt) } + .bss : + { + *(.dynbss) + *(.bss) + *(.bss.*) + *(COMMON) + /* Align here to ensure that the .bss section occupies space up to + _end. Align after .bss to ensure correct alignment even if the + .bss section disappears because there are no input sections. */ + . = ALIGN(32 / 8); + } + . = ALIGN(32 / 8); + _end = .; + PROVIDE (end = .); + /* Stabs debugging sections. */ + .stab 0 : { *(.stab) } + .stabstr 0 : { *(.stabstr) } + .stab.excl 0 : { *(.stab.excl) } + .stab.exclstr 0 : { *(.stab.exclstr) } + .stab.index 0 : { *(.stab.index) } + .stab.indexstr 0 : { *(.stab.indexstr) } + .comment 0 : { *(.comment) } + /* DWARF debug sections. + Symbols in the DWARF debugging sections are relative to the beginning + of the section so we begin them at 0. */ + /* DWARF 1 */ + .debug 0 : { *(.debug) } + .line 0 : { *(.line) } + /* GNU DWARF 1 extensions */ + .debug_srcinfo 0 : { *(.debug_srcinfo) } + .debug_sfnames 0 : { *(.debug_sfnames) } + /* DWARF 1.1 and DWARF 2 */ + .debug_aranges 0 : { *(.debug_aranges) } + .debug_pubnames 0 : { *(.debug_pubnames) } + /* DWARF 2 */ + .debug_info 0 : { *(.debug_info) } + .debug_abbrev 0 : { *(.debug_abbrev) } + .debug_line 0 : { *(.debug_line) } + .debug_frame 0 : { *(.debug_frame) } + .debug_str 0 : { *(.debug_str) } + .debug_loc 0 : { *(.debug_loc) } + .debug_macinfo 0 : { *(.debug_macinfo) } + /* SGI/MIPS DWARF 2 extensions */ + .debug_weaknames 0 : { *(.debug_weaknames) } + .debug_funcnames 0 : { *(.debug_funcnames) } + .debug_typenames 0 : { *(.debug_typenames) } + .debug_varnames 0 : { *(.debug_varnames) } + /DISCARD/ : { *(.fixup) } + /* These must appear regardless of . */ +} Index: /branches/new-random/lisp-kernel/linuxppc64/.cvsignore =================================================================== --- /branches/new-random/lisp-kernel/linuxppc64/.cvsignore (revision 13309) +++ /branches/new-random/lisp-kernel/linuxppc64/.cvsignore (revision 13309) @@ -0,0 +1,1 @@ +*~.* Index: /branches/new-random/lisp-kernel/linuxppc64/Makefile =================================================================== --- /branches/new-random/lisp-kernel/linuxppc64/Makefile (revision 13309) +++ /branches/new-random/lisp-kernel/linuxppc64/Makefile (revision 13309) @@ -0,0 +1,95 @@ +# +# Copyright (C) 1994-2001 Digitool, Inc +# This file is part of Clozure CL. +# +# Clozure CL is licensed under the terms of the Lisp Lesser GNU Public +# License , known as the LLGPL and distributed with Clozure CL as the +# file "LICENSE". The LLGPL consists of a preamble and the LGPL, +# which is distributed with Clozure CL as the file "LGPL". Where these +# conflict, the preamble takes precedence. +# +# Clozure CL is referenced in the preamble as the "LIBRARY." +# +# The LLGPL is also available online at +# http://opensource.franz.com/preamble.html + + +VPATH = ../ +RM = /bin/rm +# Versions of GNU as >= 2.9.1 all seem to work +# AS = gas-2.9.1 +AS = as +M4 = m4 +ASFLAGS = -mregnames -mppc64 -a64 -maltivec +M4FLAGS = -DLINUX -DPPC -DPPC64 +CDEFINES = -DLINUX -D_REENTRANT -DPPC -DPPC64 -D_GNU_SOURCE +CDEBUG = -g +COPT = -O2 +# word size issues are a little more relevant on a 64-bit platform +# than elsewhere, but most gcc format warnings are still nonsense. +WFORMAT = -Wno-format + +# If the linker supports a "--hash-style=" option, use traditional +# Sysv hash tables. (If it doesn't support that option, assume +# that traditional hash tables will be used by default.) +ld_has_hash_style = $(shell $(LD) --help | grep "hash-style=") +ifeq ($(ld_has_hash_style),) +HASH_STYLE= +else +HASH_STYLE="-Wl,--hash-style=sysv" +endif + + +.s.o: + $(M4) $(M4FLAGS) -I../ $< | $(AS) $(ASFLAGS) -o $@ +.c.o: + $(CC) -c $< $(CDEFINES) $(CDEBUG) $(COPT) $(WFORMAT) -m64 -o $@ + +SPOBJ = pad.o ppc-spjump.o ppc-spentry.o ppc-subprims.o +ASMOBJ = ppc-asmutils.o imports.o + +COBJ = pmcl-kernel.o gc-common.o ppc-gc.o bits.o ppc-exceptions.o \ + image.o thread_manager.o lisp-debug.o memory.o unix-calls.o + +DEBUGOBJ = lispdcmd.o plprint.o plsym.o plbt.o ppc_print.o +KERNELOBJ= $(COBJ) ppc-asmutils.o imports.o + +SPINC = lisp.s m4macros.m4 ppc-constants.s ppc-macros.s errors.s ppc-uuo.s ppc-constants64.s + +CHEADERS = area.h bits.h ppc-constants.h lisp-errors.h gc.h lisp.h \ + lisp-exceptions.h lisp_globals.h macros.h memprotect.h image.h \ + Threads.h ppc-constants64.h ppc-exceptions.h + +# Subprims linked into the kernel ? +# Yes: + +KSPOBJ = $(SPOBJ) +all: ../../ppccl64 + + +# No: + +# KSPOBJ= +# all: ../../ppccl64 ../../subprims.so + +OSLIBS = -ldl -lm -lpthread + + +../../ppccl64: $(KSPOBJ) $(KERNELOBJ) $(DEBUGOBJ) + $(CC) -m64 $(CDEBUG) -Wl,--export-dynamic $(HASH_STYLE) -o $@ -T ./elf64ppc.x $(KSPOBJ) $(KERNELOBJ) $(DEBUGOBJ) $(OSLIBS) + + +$(SPOBJ): $(SPINC) +$(ASMOBJ): $(SPINC) +$(COBJ): $(CHEADERS) +$(DEBUGOBJ): $(CHEADERS) lispdcmd.h + + +cclean: + $(RM) -f $(KERNELOBJ) $(DEBUGOBJ) ../../ppccl64 + +clean: cclean + $(RM) -f $(SPOBJ) + +strip: ../../ppccl64 + strip -g ../../ppccl64 Index: /branches/new-random/lisp-kernel/linuxppc64/elf64ppc.x =================================================================== --- /branches/new-random/lisp-kernel/linuxppc64/elf64ppc.x (revision 13309) +++ /branches/new-random/lisp-kernel/linuxppc64/elf64ppc.x (revision 13309) @@ -0,0 +1,229 @@ +/* Script for -z combreloc: combine and sort reloc sections */ +OUTPUT_FORMAT("elf64-powerpc", "elf64-powerpc", + "elf64-powerpc") +OUTPUT_ARCH(powerpc:common64) +ENTRY(_start) +SEARCH_DIR("/usr/local/lib64"); SEARCH_DIR("/lib64"); SEARCH_DIR("/usr/lib64"); SEARCH_DIR("/usr/local/lib"); SEARCH_DIR("/lib"); SEARCH_DIR("/usr/lib"); +/* Do we need any of these for elf? + __DYNAMIC = 0; */ +SECTIONS +{ + /* Read-only sections, merged into text segment: */ + PROVIDE (__executable_start = 0x00010000); . = 0x00010000 + SIZEOF_HEADERS; + .pad : { pad.o(.text) } + .subprims ALIGN(0x1000) : + { + ppc-spjump.o(.text) + ppc-spentry.o(.text) + ppc-subprims.o(.text) + } + .interp : { *(.interp) } + .hash : { *(.hash) } + .dynsym : { *(.dynsym) } + .dynstr : { *(.dynstr) } + .gnu.version : { *(.gnu.version) } + .gnu.version_d : { *(.gnu.version_d) } + .gnu.version_r : { *(.gnu.version_r) } + .rel.dyn : + { + *(.rel.init) + *(.rel.text .rel.text.* .rel.gnu.linkonce.t.*) + *(.rel.fini) + *(.rel.rodata .rel.rodata.* .rel.gnu.linkonce.r.*) + *(.rel.data.rel.ro*) + *(.rel.data .rel.data.* .rel.gnu.linkonce.d.*) + *(.rel.tdata .rel.tdata.* .rel.gnu.linkonce.td.*) + *(.rel.tbss .rel.tbss.* .rel.gnu.linkonce.tb.*) + *(.rel.ctors) + *(.rel.dtors) + *(.rel.got) + *(.rel.sdata .rel.sdata.* .rel.gnu.linkonce.s.*) + *(.rel.sbss .rel.sbss.* .rel.gnu.linkonce.sb.*) + *(.rel.sdata2 .rel.sdata2.* .rel.gnu.linkonce.s2.*) + *(.rel.sbss2 .rel.sbss2.* .rel.gnu.linkonce.sb2.*) + *(.rel.bss .rel.bss.* .rel.gnu.linkonce.b.*) + } + .rela.dyn : + { + *(.rela.init) + *(.rela.text .rela.text.* .rela.gnu.linkonce.t.*) + *(.rela.fini) + *(.rela.rodata .rela.rodata.* .rela.gnu.linkonce.r.*) + *(.rela.data .rela.data.* .rela.gnu.linkonce.d.*) + *(.rela.tdata .rela.tdata.* .rela.gnu.linkonce.td.*) + *(.rela.tbss .rela.tbss.* .rela.gnu.linkonce.tb.*) + *(.rela.ctors) + *(.rela.dtors) + *(.rela.got) + *(.rela.toc) + *(.rela.opd) + *(.rela.sdata .rela.sdata.* .rela.gnu.linkonce.s.*) + *(.rela.sbss .rela.sbss.* .rela.gnu.linkonce.sb.*) + *(.rela.sdata2 .rela.sdata2.* .rela.gnu.linkonce.s2.*) + *(.rela.sbss2 .rela.sbss2.* .rela.gnu.linkonce.sb2.*) + *(.rela.bss .rela.bss.* .rela.gnu.linkonce.b.*) + } + .rel.plt : { *(.rel.plt) } + .rela.plt : { *(.rela.plt) } + .rela.tocbss : { *(.rela.tocbss) } + .init : + { + KEEP (*(.init)) + } =0x60000000 + .text : + { + *(.text .stub .text.* .gnu.linkonce.t.*) + KEEP (*(.text.*personality*)) + /* .gnu.warning sections are handled specially by elf32.em. */ + *(.gnu.warning) + *(.sfpr .glink) + } =0x60000000 + .fini : + { + KEEP (*(.fini)) + } =0x60000000 + PROVIDE (__etext = .); + PROVIDE (_etext = .); + PROVIDE (etext = .); + .rodata : { *(.rodata .rodata.* .gnu.linkonce.r.*) } + .rodata1 : { *(.rodata1) } + .sdata2 : { *(.sdata2 .sdata2.* .gnu.linkonce.s2.*) } + .sbss2 : { *(.sbss2 .sbss2.* .gnu.linkonce.sb2.*) } + .eh_frame_hdr : { *(.eh_frame_hdr) } + .eh_frame : ONLY_IF_RO { KEEP (*(.eh_frame)) } + .gcc_except_table : ONLY_IF_RO { KEEP (*(.gcc_except_table)) *(.gcc_except_table.*) } + /* Adjust the address for the data segment. We want to adjust up to + the same address within the page on the next page up. */ + . = ALIGN (0x10000) - ((0x10000 - .) & (0x10000 - 1)); . = DATA_SEGMENT_ALIGN (0x10000, 0x1000); + /* Exception handling */ + .eh_frame : ONLY_IF_RW { KEEP (*(.eh_frame)) } + .gcc_except_table : ONLY_IF_RW { KEEP (*(.gcc_except_table)) *(.gcc_except_table.*) } + /* Thread Local Storage sections */ + .tdata : { *(.tdata .tdata.* .gnu.linkonce.td.*) } + .tbss : { *(.tbss .tbss.* .gnu.linkonce.tb.*) *(.tcommon) } + /* Ensure the __preinit_array_start label is properly aligned. We + could instead move the label definition inside the section, but + the linker would then create the section even if it turns out to + be empty, which isn't pretty. */ + . = ALIGN(64 / 8); + PROVIDE (__preinit_array_start = .); + .preinit_array : { KEEP (*(.preinit_array)) } + PROVIDE (__preinit_array_end = .); + PROVIDE (__init_array_start = .); + .init_array : { KEEP (*(.init_array)) } + PROVIDE (__init_array_end = .); + PROVIDE (__fini_array_start = .); + .fini_array : { KEEP (*(.fini_array)) } + PROVIDE (__fini_array_end = .); + .ctors : + { + /* gcc uses crtbegin.o to find the start of + the constructors, so we make sure it is + first. Because this is a wildcard, it + doesn't matter if the user does not + actually link against crtbegin.o; the + linker won't look for a file to match a + wildcard. The wildcard also means that it + doesn't matter which directory crtbegin.o + is in. */ + KEEP (*crtbegin*.o(.ctors)) + /* We don't want to include the .ctor section from + from the crtend.o file until after the sorted ctors. + The .ctor section from the crtend file contains the + end of ctors marker and it must be last */ + KEEP (*(EXCLUDE_FILE (*crtend*.o ) .ctors)) + KEEP (*(SORT(.ctors.*))) + KEEP (*(.ctors)) + } + .dtors : + { + KEEP (*crtbegin*.o(.dtors)) + KEEP (*(EXCLUDE_FILE (*crtend*.o ) .dtors)) + KEEP (*(SORT(.dtors.*))) + KEEP (*(.dtors)) + } + .jcr : { KEEP (*(.jcr)) } + .data.rel.ro : { *(.data.rel.ro.local) *(.data.rel.ro*) } + .dynamic : { *(.dynamic) } +/* . = DATA_SEGMENT_RELRO_END (0, .); */ + .data : + { + *(.data .data.* .gnu.linkonce.d.*) + KEEP (*(.gnu.linkonce.d.*personality*)) + SORT(CONSTRUCTORS) + } + .data1 : { *(.data1) } + .toc1 ALIGN(8) : { *(.toc1) } + .opd ALIGN(8) : { KEEP (*(.opd)) } + .got ALIGN(8) : { *(.got .toc) } + /* We want the small data sections together, so single-instruction offsets + can access them all, and initialized data all before uninitialized, so + we can shorten the on-disk segment size. */ + .sdata : + { + *(.sdata .sdata.* .gnu.linkonce.s.*) + } + _edata = .; + PROVIDE (edata = .); + __bss_start = .; + .tocbss ALIGN(8) : { *(.tocbss)} + .sbss : + { + PROVIDE (__sbss_start = .); + PROVIDE (___sbss_start = .); + *(.dynsbss) + *(.sbss .sbss.* .gnu.linkonce.sb.*) + *(.scommon) + PROVIDE (__sbss_end = .); + PROVIDE (___sbss_end = .); + } + .plt : { *(.plt) } + .bss : + { + *(.dynbss) + *(.bss .bss.* .gnu.linkonce.b.*) + *(COMMON) + /* Align here to ensure that the .bss section occupies space up to + _end. Align after .bss to ensure correct alignment even if the + .bss section disappears because there are no input sections. */ + . = ALIGN(64 / 8); + } + . = ALIGN(64 / 8); + _end = .; + PROVIDE (end = .); + . = DATA_SEGMENT_END (.); + /* Stabs debugging sections. */ + .stab 0 : { *(.stab) } + .stabstr 0 : { *(.stabstr) } + .stab.excl 0 : { *(.stab.excl) } + .stab.exclstr 0 : { *(.stab.exclstr) } + .stab.index 0 : { *(.stab.index) } + .stab.indexstr 0 : { *(.stab.indexstr) } + .comment 0 : { *(.comment) } + /* DWARF debug sections. + Symbols in the DWARF debugging sections are relative to the beginning + of the section so we begin them at 0. */ + /* DWARF 1 */ + .debug 0 : { *(.debug) } + .line 0 : { *(.line) } + /* GNU DWARF 1 extensions */ + .debug_srcinfo 0 : { *(.debug_srcinfo) } + .debug_sfnames 0 : { *(.debug_sfnames) } + /* DWARF 1.1 and DWARF 2 */ + .debug_aranges 0 : { *(.debug_aranges) } + .debug_pubnames 0 : { *(.debug_pubnames) } + /* DWARF 2 */ + .debug_info 0 : { *(.debug_info .gnu.linkonce.wi.*) } + .debug_abbrev 0 : { *(.debug_abbrev) } + .debug_line 0 : { *(.debug_line) } + .debug_frame 0 : { *(.debug_frame) } + .debug_str 0 : { *(.debug_str) } + .debug_loc 0 : { *(.debug_loc) } + .debug_macinfo 0 : { *(.debug_macinfo) } + /* SGI/MIPS DWARF 2 extensions */ + .debug_weaknames 0 : { *(.debug_weaknames) } + .debug_funcnames 0 : { *(.debug_funcnames) } + .debug_typenames 0 : { *(.debug_typenames) } + .debug_varnames 0 : { *(.debug_varnames) } + /DISCARD/ : { *(.note.GNU-stack) } +} Index: /branches/new-random/lisp-kernel/linuxx8632/.gdbinit =================================================================== --- /branches/new-random/lisp-kernel/linuxx8632/.gdbinit (revision 13309) +++ /branches/new-random/lisp-kernel/linuxx8632/.gdbinit (revision 13309) @@ -0,0 +1,46 @@ +define pl + call print_lisp_object($arg0) +end + +define showlist + set $l=$arg0 + while $l != 0x3001 + set $car = *((LispObj *)($l+3)) + set $l = *((LispObj *)($l-1)) + pl $car + end +end + + +define fn + pl $edi +end + +define arg_y + pl $esi +end + +define arg_z + pl $ebx +end + +define offset + p (int)$pc-$edi +end + + +break Bug + +display/i $pc + +handle SIGKILL pass nostop noprint +handle SIGILL pass nostop noprint +handle SIGSEGV pass nostop noprint +handle SIGBUS pass nostop noprint +handle SIGFPE pass nostop noprint +handle SIG40 pass nostop noprint +handle SIG41 pass nostop noprint +handle SIG42 pass nostop noprint +handle SIGPWR pass nostop noprint +handle SIGQUIT pass nostop noprint + Index: /branches/new-random/lisp-kernel/linuxx8632/Makefile =================================================================== --- /branches/new-random/lisp-kernel/linuxx8632/Makefile (revision 13309) +++ /branches/new-random/lisp-kernel/linuxx8632/Makefile (revision 13309) @@ -0,0 +1,85 @@ +# +# Copyright (C) 2008 Clozure Associates and contributors +# This file is part of Clozure CL. +# +# Clozure CL is licensed under the terms of the Lisp Lesser GNU Public +# License , known as the LLGPL and distributed with Clozure CL as the +# file "LICENSE". The LLGPL consists of a preamble and the LGPL, +# which is distributed with Clozure CL as the file "LGPL". Where these +# conflict, the preamble takes precedence. +# +# Clozure CL is referenced in the preamble as the "LIBRARY." +# +# The LLGPL is also available online at +# http://opensource.franz.com/preamble.html + + +VPATH = ../ +RM = /bin/rm +AS = as +M4 = m4 +ASFLAGS = --32 +M4FLAGS = -DLINUX -DX86 -DX8632 -DHAVE_TLS +CDEFINES = -DLINUX -D_REENTRANT -DX86 -DX8632 -D_GNU_SOURCE -DHAVE_TLS -DUSE_FUTEX #-DGC_INTEGRITY_CHECKING -DDISABLE_EGC +CDEBUG = -g +COPT = -O2 + +# If the linker supports a "--hash-style=" option, use traditional +# SysV hash tables. (If it doesn't support that option, assume +# that traditional hash tables will be used by default.) +ld_has_hash_style = $(shell $(LD) --help | grep "hash-style=") +ifeq ($(ld_has_hash_style),) +HASH_STYLE= +else +HASH_STYLE="-Wl,--hash-style=sysv" +endif + + +.s.o: + $(M4) $(M4FLAGS) -I../ $< | $(AS) $(ASFLAGS) -o $@ +.c.o: + $(CC) -c $< $(CDEFINES) $(CDEBUG) $(COPT) -m32 -o $@ + +SPOBJ = pad.o x86-spjump32.o x86-spentry32.o x86-subprims32.o +ASMOBJ = x86-asmutils32.o imports.o + +COBJ = pmcl-kernel.o gc-common.o x86-gc.o bits.o x86-exceptions.o \ + image.o thread_manager.o lisp-debug.o memory.o unix-calls.o + +DEBUGOBJ = lispdcmd.o plprint.o plsym.o xlbt.o x86_print.o +KERNELOBJ= $(COBJ) x86-asmutils32.o imports.o + +SPINC = lisp.s m4macros.m4 x86-constants.s x86-macros.s errors.s x86-uuo.s \ + x86-constants32.s + +CHEADERS = area.h bits.h x86-constants.h lisp-errors.h gc.h lisp.h \ + lisp-exceptions.h lisp_globals.h macros.h memprotect.h image.h \ + Threads.h x86-constants32.h x86-exceptions.h lisptypes.h + + +KSPOBJ = $(SPOBJ) +all: ../../lx86cl + + +OSLIBS = -ldl -lm -lpthread +LINK_SCRIPT = # ./elf_x86_32.x +USE_LINK_SCRIPT = # -T $(LINK_SCRIPT) + +../../lx86cl: $(KSPOBJ) $(KERNELOBJ) $(DEBUGOBJ) Makefile $(LINK_SCRIPT) + $(CC) -m32 $(CDEBUG) -Wl,--export-dynamic $(HASH_STYLE) -o $@ $(USE_LINK_SCRIPT) $(KSPOBJ) $(KERNELOBJ) $(DEBUGOBJ) $(OSLIBS) + + +$(SPOBJ): $(SPINC) +$(ASMOBJ): $(SPINC) +$(COBJ): $(CHEADERS) +$(DEBUGOBJ): $(CHEADERS) lispdcmd.h + + +cclean: + $(RM) -f $(KERNELOBJ) $(DEBUGOBJ) ../../lx86cl + +clean: cclean + $(RM) -f $(SPOBJ) + +strip: ../../lx86cl + strip -g ../../lx86cl Index: /branches/new-random/lisp-kernel/linuxx8664/.gdbinit =================================================================== --- /branches/new-random/lisp-kernel/linuxx8664/.gdbinit (revision 13309) +++ /branches/new-random/lisp-kernel/linuxx8664/.gdbinit (revision 13309) @@ -0,0 +1,83 @@ +define x86_lisp_string +x/s $arg0-5 +end + +define gtra +br *$r10 +cont +end + +define x86pname +set $temp=*((long *)((long)($arg0-6))) +x86_lisp_string $temp +end + + +define pname + x86pname $arg0 +end + +define l + call print_lisp_object($arg0) +end + +define lw + l $r13 +end + +define clobber_breakpoint + set *(short *)($pc-2)=0x9090 +end + +define arg_z + l $rsi +end + +define arg_y + l $rdi +end + +define arg_x + l $r8 +end + +define bx + l $rbx +end + +define showlist + set $l=$arg0 + while $l != 0x200b + set $car = *((LispObj *)($l+5)) + set $l = *((LispObj *)($l-3)) + l $car + end +end + +define lbt + call plbt_sp($rbp) +end + +define ada + p/x *(all_areas->succ) +end + +define lregs + call debug_lisp_registers($arg0,0,0) +end + +break Bug + +display/i $pc + +handle SIGKILL pass nostop noprint +handle SIGILL pass nostop noprint +handle SIGSEGV pass nostop noprint +handle SIGBUS pass nostop noprint +handle SIGFPE pass nostop noprint +handle SIG40 pass nostop noprint +handle SIG41 pass nostop noprint +handle SIG42 pass nostop noprint +handle SIGPWR pass nostop noprint +handle SIGQUIT pass nostop noprint + Index: /branches/new-random/lisp-kernel/linuxx8664/Makefile =================================================================== --- /branches/new-random/lisp-kernel/linuxx8664/Makefile (revision 13309) +++ /branches/new-random/lisp-kernel/linuxx8664/Makefile (revision 13309) @@ -0,0 +1,85 @@ +# +# Copyright (C) 2005 Clozure Associates +# This file is part of Clozure CL. +# +# Clozure CL is licensed under the terms of the Lisp Lesser GNU Public +# License , known as the LLGPL and distributed with Clozure CL as the +# file "LICENSE". The LLGPL consists of a preamble and the LGPL, +# which is distributed with Clozure CL as the file "LGPL". Where these +# conflict, the preamble takes precedence. +# +# Clozure CL is referenced in the preamble as the "LIBRARY." +# +# The LLGPL is also available online at +# http://opensource.franz.com/preamble.html + + +VPATH = ../ +RM = /bin/rm +AS = as +M4 = m4 +ASFLAGS = --64 +M4FLAGS = -DLINUX -DX86 -DX8664 -DHAVE_TLS +CDEFINES = -DLINUX -D_REENTRANT -DX86 -DX8664 -D_GNU_SOURCE -DHAVE_TLS -DUSE_FUTEX #-DDISABLE_EGC +CDEBUG = -g +COPT = -O2 + +# If the linker supports a "--hash-style=" option, use traditional +# SysV hash tables. (If it doesn't support that option, assume +# that traditional hash tables will be used by default.) +ld_has_hash_style = $(shell $(LD) --help | grep "hash-style=") +ifeq ($(ld_has_hash_style),) +HASH_STYLE= +else +HASH_STYLE="-Wl,--hash-style=sysv" +endif + + +.s.o: + $(M4) $(M4FLAGS) -I../ $< | $(AS) $(ASFLAGS) -o $@ +.c.o: + $(CC) -c $< $(CDEFINES) $(CDEBUG) $(COPT) -m64 -o $@ + +SPOBJ = pad.o x86-spjump64.o x86-spentry64.o x86-subprims64.o +ASMOBJ = x86-asmutils64.o imports.o + +COBJ = pmcl-kernel.o gc-common.o x86-gc.o bits.o x86-exceptions.o \ + image.o thread_manager.o lisp-debug.o memory.o unix-calls.o + +DEBUGOBJ = lispdcmd.o plprint.o plsym.o xlbt.o x86_print.o +KERNELOBJ= $(COBJ) x86-asmutils64.o imports.o + +SPINC = lisp.s m4macros.m4 x86-constants.s x86-macros.s errors.s x86-uuo.s \ + x86-constants64.s + +CHEADERS = area.h bits.h x86-constants.h lisp-errors.h gc.h lisp.h \ + lisp-exceptions.h lisp_globals.h macros.h memprotect.h image.h \ + Threads.h x86-constants64.h x86-exceptions.h lisptypes.h + + +KSPOBJ = $(SPOBJ) +all: ../../lx86cl64 + + +OSLIBS = -ldl -lm -lpthread +LINK_MAP = ./elf_x86_64.x +USE_LINK_MAP = # -T ./elf_x86_64.x + +../../lx86cl64: $(KSPOBJ) $(KERNELOBJ) $(DEBUGOBJ) Makefile $(LINK_MAP) + $(CC) -m64 $(CDEBUG) -Wl,--export-dynamic $(HASH_STYLE) -o $@ $(USE_LINK_MAP) $(KSPOBJ) $(KERNELOBJ) $(DEBUGOBJ) $(OSLIBS) + + +$(SPOBJ): $(SPINC) +$(ASMOBJ): $(SPINC) +$(COBJ): $(CHEADERS) +$(DEBUGOBJ): $(CHEADERS) lispdcmd.h + + +cclean: + $(RM) -f $(KERNELOBJ) $(DEBUGOBJ) ../../lx86cl64 + +clean: cclean + $(RM) -f $(SPOBJ) + +strip: ../../lx86cl64 + strip -g ../../lx86cl64 Index: /branches/new-random/lisp-kernel/linuxx8664/elf_x86_64.x =================================================================== --- /branches/new-random/lisp-kernel/linuxx8664/elf_x86_64.x (revision 13309) +++ /branches/new-random/lisp-kernel/linuxx8664/elf_x86_64.x (revision 13309) @@ -0,0 +1,196 @@ +/* Script for -z combreloc: combine and sort reloc sections */ +OUTPUT_FORMAT("elf64-x86-64", "elf64-x86-64", + "elf64-x86-64") +OUTPUT_ARCH(i386:x86-64) +ENTRY(_start) +SEARCH_DIR("/usr/x86_64-linux-gnu/lib64"); SEARCH_DIR("/usr/local/lib64"); SEARCH_DIR("/lib64"); SEARCH_DIR("/usr/lib64"); SEARCH_DIR("/usr/x86_64-linux-gnu/lib"); SEARCH_DIR("/usr/local/lib"); SEARCH_DIR("/lib"); SEARCH_DIR("/usr/lib"); +/* Do we need any of these for elf? + __DYNAMIC = 0; */ +SECTIONS +{ + /* Read-only sections, merged into text segment: */ + PROVIDE (__executable_start = 0x400000); . = 0x400000 + SIZEOF_HEADERS; + .interp : { *(.interp) } + .hash : { *(.hash) } + .dynsym : { *(.dynsym) } + .dynstr : { *(.dynstr) } + .gnu.version : { *(.gnu.version) } + .gnu.version_d : { *(.gnu.version_d) } + .gnu.version_r : { *(.gnu.version_r) } + .rel.dyn : + { + *(.rel.init) + *(.rel.text .rel.text.* .rel.gnu.linkonce.t.*) + *(.rel.fini) + *(.rel.rodata .rel.rodata.* .rel.gnu.linkonce.r.*) + *(.rel.data.rel.ro*) + *(.rel.data .rel.data.* .rel.gnu.linkonce.d.*) + *(.rel.tdata .rel.tdata.* .rel.gnu.linkonce.td.*) + *(.rel.tbss .rel.tbss.* .rel.gnu.linkonce.tb.*) + *(.rel.ctors) + *(.rel.dtors) + *(.rel.got) + *(.rel.bss .rel.bss.* .rel.gnu.linkonce.b.*) + } + .rela.dyn : + { + *(.rela.init) + *(.rela.text .rela.text.* .rela.gnu.linkonce.t.*) + *(.rela.fini) + *(.rela.rodata .rela.rodata.* .rela.gnu.linkonce.r.*) + *(.rela.data .rela.data.* .rela.gnu.linkonce.d.*) + *(.rela.tdata .rela.tdata.* .rela.gnu.linkonce.td.*) + *(.rela.tbss .rela.tbss.* .rela.gnu.linkonce.tb.*) + *(.rela.ctors) + *(.rela.dtors) + *(.rela.got) + *(.rela.bss .rela.bss.* .rela.gnu.linkonce.b.*) + } + .rel.plt : { *(.rel.plt) } + .rela.plt : { *(.rela.plt) } + .init : + { + KEEP (*(.init)) + } =0x90909090 + .plt : { *(.plt) } + .subprims 0x410000: + { + x86-spjump64.o(.text) + x86-spentry64.o(.text) + x86-subprims64.o(.text) + } + .text : + { + *(.text .stub .text.* .gnu.linkonce.t.*) + KEEP (*(.text.*personality*)) + /* .gnu.warning sections are handled specially by elf32.em. */ + *(.gnu.warning) + } =0x90909090 + .fini : + { + KEEP (*(.fini)) + } =0x90909090 + PROVIDE (__etext = .); + PROVIDE (_etext = .); + PROVIDE (etext = .); + .rodata : { *(.rodata .rodata.* .gnu.linkonce.r.*) } + .rodata1 : { *(.rodata1) } + .eh_frame_hdr : { *(.eh_frame_hdr) } + .eh_frame : ONLY_IF_RO { KEEP (*(.eh_frame)) } + .gcc_except_table : ONLY_IF_RO { KEEP (*(.gcc_except_table)) *(.gcc_except_table.*) } + /* Adjust the address for the data segment. We want to adjust up to + the same address within the page on the next page up. */ + . = ALIGN (0x100000) - ((0x100000 - .) & (0x100000 - 1)); . = DATA_SEGMENT_ALIGN (0x100000, 0x1000); + /* Exception handling */ + .eh_frame : ONLY_IF_RW { KEEP (*(.eh_frame)) } + .gcc_except_table : ONLY_IF_RW { KEEP (*(.gcc_except_table)) *(.gcc_except_table.*) } + /* Thread Local Storage sections */ + .tdata : { *(.tdata .tdata.* .gnu.linkonce.td.*) } + .tbss : { *(.tbss .tbss.* .gnu.linkonce.tb.*) *(.tcommon) } + /* Ensure the __preinit_array_start label is properly aligned. We + could instead move the label definition inside the section, but + the linker would then create the section even if it turns out to + be empty, which isn't pretty. */ + . = ALIGN(64 / 8); + PROVIDE (__preinit_array_start = .); + .preinit_array : { KEEP (*(.preinit_array)) } + PROVIDE (__preinit_array_end = .); + PROVIDE (__init_array_start = .); + .init_array : { KEEP (*(.init_array)) } + PROVIDE (__init_array_end = .); + PROVIDE (__fini_array_start = .); + .fini_array : { KEEP (*(.fini_array)) } + PROVIDE (__fini_array_end = .); + .ctors : + { + /* gcc uses crtbegin.o to find the start of + the constructors, so we make sure it is + first. Because this is a wildcard, it + doesn't matter if the user does not + actually link against crtbegin.o; the + linker won't look for a file to match a + wildcard. The wildcard also means that it + doesn't matter which directory crtbegin.o + is in. */ + KEEP (*crtbegin*.o(.ctors)) + /* We don't want to include the .ctor section from + from the crtend.o file until after the sorted ctors. + The .ctor section from the crtend file contains the + end of ctors marker and it must be last */ + KEEP (*(EXCLUDE_FILE (*crtend*.o ) .ctors)) + KEEP (*(SORT(.ctors.*))) + KEEP (*(.ctors)) + } + .dtors : + { + KEEP (*crtbegin*.o(.dtors)) + KEEP (*(EXCLUDE_FILE (*crtend*.o ) .dtors)) + KEEP (*(SORT(.dtors.*))) + KEEP (*(.dtors)) + } + .jcr : { KEEP (*(.jcr)) } + .data.rel.ro : { *(.data.rel.ro.local) *(.data.rel.ro*) } + .dynamic : { *(.dynamic) } + .got : { *(.got) } + . = DATA_SEGMENT_RELRO_END (24, .); + .got.plt : { *(.got.plt) } + .data : + { + *(.data .data.* .gnu.linkonce.d.*) + KEEP (*(.gnu.linkonce.d.*personality*)) + SORT(CONSTRUCTORS) + } + .data1 : { *(.data1) } + _edata = .; + PROVIDE (edata = .); + __bss_start = .; + .bss : + { + *(.dynbss) + *(.bss .bss.* .gnu.linkonce.b.*) + *(COMMON) + /* Align here to ensure that the .bss section occupies space up to + _end. Align after .bss to ensure correct alignment even if the + .bss section disappears because there are no input sections. */ + . = ALIGN(64 / 8); + } + . = ALIGN(64 / 8); + _end = .; + PROVIDE (end = .); + . = DATA_SEGMENT_END (.); + /* Stabs debugging sections. */ + .stab 0 : { *(.stab) } + .stabstr 0 : { *(.stabstr) } + .stab.excl 0 : { *(.stab.excl) } + .stab.exclstr 0 : { *(.stab.exclstr) } + .stab.index 0 : { *(.stab.index) } + .stab.indexstr 0 : { *(.stab.indexstr) } + .comment 0 : { *(.comment) } + /* DWARF debug sections. + Symbols in the DWARF debugging sections are relative to the beginning + of the section so we begin them at 0. */ + /* DWARF 1 */ + .debug 0 : { *(.debug) } + .line 0 : { *(.line) } + /* GNU DWARF 1 extensions */ + .debug_srcinfo 0 : { *(.debug_srcinfo) } + .debug_sfnames 0 : { *(.debug_sfnames) } + /* DWARF 1.1 and DWARF 2 */ + .debug_aranges 0 : { *(.debug_aranges) } + .debug_pubnames 0 : { *(.debug_pubnames) } + /* DWARF 2 */ + .debug_info 0 : { *(.debug_info .gnu.linkonce.wi.*) } + .debug_abbrev 0 : { *(.debug_abbrev) } + .debug_line 0 : { *(.debug_line) } + .debug_frame 0 : { *(.debug_frame) } + .debug_str 0 : { *(.debug_str) } + .debug_loc 0 : { *(.debug_loc) } + .debug_macinfo 0 : { *(.debug_macinfo) } + /* SGI/MIPS DWARF 2 extensions */ + .debug_weaknames 0 : { *(.debug_weaknames) } + .debug_funcnames 0 : { *(.debug_funcnames) } + .debug_typenames 0 : { *(.debug_typenames) } + .debug_varnames 0 : { *(.debug_varnames) } + /DISCARD/ : { *(.note.GNU-stack) } +} + Index: /branches/new-random/lisp-kernel/lisp-debug.c =================================================================== --- /branches/new-random/lisp-kernel/lisp-debug.c (revision 13309) +++ /branches/new-random/lisp-kernel/lisp-debug.c (revision 13309) @@ -0,0 +1,1256 @@ +/* + Copyright (C) 2009 Clozure Associates + Copyright (C) 1994-2001 Digitool, Inc + This file is part of Clozure CL. + + Clozure CL is licensed under the terms of the Lisp Lesser GNU Public + License , known as the LLGPL and distributed with Clozure CL as the + file "LICENSE". The LLGPL consists of a preamble and the LGPL, + which is distributed with Clozure CL as the file "LGPL". Where these + conflict, the preamble takes precedence. + + Clozure CL is referenced in the preamble as the "LIBRARY." + + The LLGPL is also available online at + http://opensource.franz.com/preamble.html +*/ + +#include "lisp.h" +#include "lisp-exceptions.h" +#include "lisp_globals.h" +#include "area.h" +#include "Threads.h" +#include +#include +#include +#include +#include +#include +#include + +#ifdef WINDOWS +#include +#else +#include +#include +#endif +#include + +FILE *dbgout = NULL; + +typedef enum { + debug_continue, /* stay in the repl */ + debug_exit_success, /* return 0 from lisp_Debugger */ + debug_exit_fail, /* return non-zero from lisp_Debugger */ + debug_kill +} debug_command_return; + + +Boolean +open_debug_output(int fd) +{ + FILE *f = fdopen(fd, "w"); + + if (f) { + if (setvbuf(f, NULL, _IONBF, 0) == 0) { +#ifdef WINDOWS + if (fileno(stdin) < 0) { + stdin->_file = 0; + } +#endif + dbgout = f; + return true; + } + fclose(f); + } + return false; +} + + +typedef debug_command_return (*debug_command) (ExceptionInformation *, + siginfo_t *, + int); + +#define DEBUG_COMMAND_FLAG_REQUIRE_XP 1 /* function */ +#define DEBUG_COMMAND_FLAG_AUX_REGNO (2 | DEBUG_COMMAND_FLAG_REQUIRE_XP) +#define DEBUG_COMMAND_FLAG_AUX_SPR (4 | DEBUG_COMMAND_FLAG_REQUIRE_XP) +#define DEBUG_COMMAND_REG_FLAGS 7 +#define DEBUG_COMMAND_FLAG_EXCEPTION_ENTRY_ONLY 8 +#define DEBUG_COMMAND_FLAG_EXCEPTION_REASON_ARG 16 + +typedef struct { + debug_command f; + char *help_text; + unsigned flags; + char *aux_prompt; + int c; +} debug_command_entry; + + +extern +debug_command_entry debug_command_entries[]; + +Boolean lisp_debugger_in_foreign_code = false; + +#ifndef WINDOWS +Boolean +stdin_is_dev_null() +{ + struct stat fd0stat, devnullstat; + + if (fstat(fileno(stdin),&fd0stat)) { + return true; + } + if (stat("/dev/null",&devnullstat)) { + return true; + } + return ((fd0stat.st_ino == devnullstat.st_ino) && + (fd0stat.st_dev == devnullstat.st_dev)); +} +#endif + +#ifdef WINDOWS +Boolean +stdin_is_dev_null() +{ + HANDLE stdIn; + stdIn = GetStdHandle(STD_INPUT_HANDLE); + return (stdIn == NULL); +} +#endif + + + + +char * +foreign_name_and_offset(natural addr, int *delta) +{ +#ifndef WINDOWS + Dl_info info; +#endif + char *ret = NULL; + + if (delta) { + *delta = 0; + } +#ifndef WINDOWS + if (dladdr((void *)addr, &info)) { + ret = (char *)info.dli_sname; + if (delta) { + *delta = ((natural)addr - (natural)info.dli_saddr); + } + } +#endif + return ret; +} + + +#if defined(LINUX) || defined(SOLARIS) +#define fpurge __fpurge +#endif + +#ifdef WINDOWS +void +fpurge (FILE* file) +{ +} +#endif + +int +readc() +{ + unsigned tries = 1000; + int c; + + while (tries) { + c = getchar(); + switch(c) { + case '\n': + continue; + case '\r': + continue; + case EOF: + if (ferror(stdin)) { + if ((errno == EINTR) || (errno == EIO)) { + clearerr(stdin); + tries--; + continue; + } + } + /* fall through */ + default: + return c; + } + } + return EOF; +} + +#ifdef X8664 +#ifdef LINUX +char* Iregnames[] = {"r8 ","r9 ","r10","r11","r12","r13","r14","r15", + "rdi","rsi","rbp", "rbx", "rdx", "rax", "rcx","rsp"}; +#endif +#ifdef SOLARIS +char* Iregnames[] = {"r15 ","r14 ","r13","r12","r11","r10","r9 ","r8 ", + "rdi","rsi","rbp", "rbx", "rdx", "rcx", "rcx","rsp"}; +#endif +#ifdef FREEBSD +char* Iregnames[] = {"???", "rdi", "rsi", "rdx", "rcx", "r8 ", "r9 ", "rax", + "rbx", "rbp", "r10", "r11", "r12", "r13", "r14", "r15", + "???", "???", "???", "???", "???", "???", "???", "rsp"}; +#endif +#ifdef DARWIN +char* Iregnames[] = {"rax", "rbx", "rcx", "rdx", "rdi", "rsi", + "rbp", "rsp", "r8 ", "r9 ", "r10", "r11", "r12", "r13", + "r14", "r15", "rip", "rfl"}; +#endif +#ifdef WINDOWS +char* Iregnames[] = {"rax ","rcx ","rdx","rbx","rsp","rrbp","rsi","rdi", + "r8","r9","r10", "r11", "r12", "r13", "r14","r15"}; +#endif +#endif + +#ifdef X8632 +#ifdef DARWIN +char *Iregnames[] = {"eax", "ebx", "ecx", "edx", "edi", "esi", + "ebp", "???", "efl", "eip"}; +#endif +#ifdef LINUX +char *Iregnames[] = {"???", "???", "???", "???", + "edi", "esi", "ebp", "esp", + "ebx", "edx", "ecx", "eax", + "???", "???", "eip", "???", "efl"}; +#endif +#ifdef WINDOWS +char *Iregnames[] = {"edi", "esi", "ebx", "edx", "ecx", "eax", + "ebp", "eip", "???", "efl", "esp"}; +#endif +#ifdef FREEBSD +char *Iregnames[] = {"???", "???", "???", "???", "???" + "edi", "esi", "ebp", "ebx", "edx", + "ecx", "eax", "???", "???", "eip", + "???", "efl", "esp"}; +#endif +#ifdef SOLARIS +char *Iregnames[] = {"???", "???", "???", "???", "???", + "edi", "esi", "ebp", "???", "ebx", + "edx", "ecx", "eax", "???", "???", + "eip", "???", "efl", "esp"}; +#endif +#endif + +#ifdef X8632 +int bit_for_regnum(int r) +{ + switch (r) { + case REG_EAX: return 1<<0; + case REG_ECX: return 1<<1; + case REG_EDX: return 1<<2; + case REG_EBX: return 1<<3; + case REG_ESP: return 1<<4; + case REG_EBP: return 1<<5; + case REG_ESI: return 1<<6; + case REG_EDI: return 1<<7; + } +} +#endif + +void +show_lisp_register(ExceptionInformation *xp, char *label, int r) +{ + + extern char* print_lisp_object(LispObj); + + LispObj val = xpGPR(xp, r); + +#ifdef PPC + fprintf(dbgout, "r%02d (%s) = %s\n", r, label, print_lisp_object(val)); +#endif +#ifdef X8664 + fprintf(dbgout, "%%%s (%s) = %s\n",Iregnames[r], label, print_lisp_object(val)); +#endif +#ifdef X8632 + { + TCR *tcr = get_tcr(false); + char *s; + + if (r == REG_EDX && (xpGPR(xp, REG_EFL) & EFL_DF)) + s = "marked as unboxed (DF set)"; + else if (tcr && (tcr->node_regs_mask & bit_for_regnum(r)) == 0) + s = "marked as unboxed (node_regs_mask)"; + else + s = print_lisp_object(val); + + fprintf(dbgout, "%%%s (%s) = %s\n", Iregnames[r], label, s); + } +#endif + +} + + +void +describe_memfault(ExceptionInformation *xp, siginfo_t *info) +{ +#ifdef PPC + void *addr = (void *)xpDAR(xp); + natural dsisr = xpDSISR(xp); + + fprintf(dbgout, "%s operation to %s address 0x%lx\n", + dsisr & (1<<25) ? "Write" : "Read", + dsisr & (1<<27) ? "protected" : "unmapped", + addr); +#endif +} + +#ifdef PPC +void +describe_ppc_illegal(ExceptionInformation *xp) +{ + pc where = xpPC(xp); + opcode the_uuo = *where; + Boolean described = false; + + if (IS_UUO(the_uuo)) { + unsigned + minor = UUO_MINOR(the_uuo), + errnum = 0x3ff & (the_uuo >> 16); + + switch(minor) { + case UUO_INTERR: + switch (errnum) { + case error_udf_call: + fprintf(dbgout, "ERROR: undefined function call: %s\n", + print_lisp_object(xpGPR(xp,fname))); + described = true; + break; + + default: + fprintf(dbgout, "ERROR: lisp error %d\n", errnum); + described = true; + break; + } + break; + + default: + break; + } + } + if (!described) { + fprintf(dbgout, "Illegal instruction (0x%08x) at 0x%lx\n", + the_uuo, where); + } +} +#endif + +#ifdef PPC +void +describe_ppc_trap(ExceptionInformation *xp) +{ + pc where = xpPC(xp); + opcode the_trap = *where, instr; + int err_arg2, ra, rs; + Boolean identified = false; + + if ((the_trap & OP_MASK) == OP(major_opcode_TRI)) { + /* TWI/TDI. If the RA field is "nargs", that means that the + instruction is either a number-of-args check or an + event-poll. Otherwise, the trap is some sort of + typecheck. */ + + if (RA_field(the_trap) == nargs) { + switch (TO_field(the_trap)) { + case TO_NE: + if (xpGPR(xp, nargs) < D_field(the_trap)) { + fprintf(dbgout, "Too few arguments (no opt/rest)\n"); + } else { + fprintf(dbgout, "Too many arguments (no opt/rest)\n"); + } + identified = true; + break; + + case TO_GT: + fprintf(dbgout, "Event poll !\n"); + identified = true; + break; + + case TO_HI: + fprintf(dbgout, "Too many arguments (with opt)\n"); + identified = true; + break; + + case TO_LT: + fprintf(dbgout, "Too few arguments (with opt/rest/key)\n"); + identified = true; + break; + + default: /* some weird trap, not ours. */ + identified = false; + break; + } + } else { + /* A type or boundp trap of some sort. */ + switch (TO_field(the_trap)) { + case TO_EQ: + /* Boundp traps are of the form: + treqi rX,unbound + where some preceding instruction is of the form: + lwz/ld rX,symbol.value(rY). + The error message should try to say that rY is unbound. */ + + if (D_field(the_trap) == unbound) { +#ifdef PPC64 + instr = scan_for_instr(LD_instruction(RA_field(the_trap), + unmasked_register, + offsetof(lispsymbol,vcell)-fulltag_misc), + D_RT_IMM_MASK, + where); +#else + instr = scan_for_instr(LWZ_instruction(RA_field(the_trap), + unmasked_register, + offsetof(lispsymbol,vcell)-fulltag_misc), + D_RT_IMM_MASK, + where); +#endif + if (instr) { + ra = RA_field(instr); + if (lisp_reg_p(ra)) { + fprintf(dbgout, "Unbound variable: %s\n", + print_lisp_object(xpGPR(xp,ra))); + identified = true; + } + } + } + break; + + case TO_NE: + /* A type check. If the type (the immediate field of the trap + instruction) is a header type, an "lbz + rX,misc_header_offset(rY)" should precede it, in which case + we say that "rY is not of header type ." If the type + is not a header type, then rX should have been set by a + preceding "clrlwi rX,rY,29/30". In that case, scan + backwards for an RLWINM instruction that set rX and report + that rY isn't of the indicated type. */ + err_arg2 = D_field(the_trap); + if (nodeheader_tag_p(err_arg2) || + immheader_tag_p(err_arg2)) { + instr = scan_for_instr(LBZ_instruction(RA_field(the_trap), + unmasked_register, + misc_subtag_offset), + D_RT_IMM_MASK, + where); + if (instr) { + ra = RA_field(instr); + if (lisp_reg_p(ra)) { + fprintf(dbgout, "value 0x%lX is not of the expected header type 0x%02X\n", xpGPR(xp, ra), err_arg2); + identified = true; + } + } + } else { + /* Not a header type, look for rlwinm whose RA field matches the_trap's */ + instr = scan_for_instr((OP(major_opcode_RLWINM) | (the_trap & RA_MASK)), + (OP_MASK | RA_MASK), + where); + if (instr) { + rs = RS_field(instr); + if (lisp_reg_p(rs)) { + fprintf(dbgout, "value 0x%lX is not of the expected type 0x%02X\n", + xpGPR(xp, rs), err_arg2); + identified = true; + } + } + } + break; + } + } + } else { + /* a "TW ,ra,rb" instruction." + twltu sp,rN is stack-overflow on SP. + twgeu rX,rY is subscript out-of-bounds, which was preceded + by an "lwz rM,misc_header_offset(rN)" instruction. + rM may or may not be the same as rY, but no other header + would have been loaded before the trap. */ + switch (TO_field(the_trap)) { + case TO_LO: + if (RA_field(the_trap) == sp) { + fprintf(dbgout, "Stack overflow! Run away! Run away!\n"); + identified = true; + } + break; + + case (TO_HI|TO_EQ): + instr = scan_for_instr(OP(major_opcode_LWZ) | (D_MASK & misc_header_offset), + (OP_MASK | D_MASK), + where); + if (instr) { + ra = RA_field(instr); + if (lisp_reg_p(ra)) { + fprintf(dbgout, "Bad index %d for vector %lX length %d\n", + unbox_fixnum(xpGPR(xp, RA_field(the_trap))), + xpGPR(xp, ra), + unbox_fixnum(xpGPR(xp, RB_field(the_trap)))); + identified = true; + } + } + break; + } + } + + if (!identified) { + fprintf(dbgout, "Unknown trap: 0x%08x\n", the_trap); + } + + +} +#endif + +debug_command_return +debug_lisp_registers(ExceptionInformation *xp, siginfo_t *info, int arg) +{ + if (lisp_debugger_in_foreign_code == false) { +#ifdef PPC + TCR *xpcontext = (TCR *)ptr_from_lispobj(xpGPR(xp, rcontext)); + + fprintf(dbgout, "rcontext = 0x%lX ", xpcontext); + if (!active_tcr_p(xpcontext)) { + fprintf(dbgout, "(INVALID)\n"); + } else { + fprintf(dbgout, "\nnargs = %d\n", xpGPR(xp, nargs) >> fixnumshift); + show_lisp_register(xp, "fn", fn); + show_lisp_register(xp, "arg_z", arg_z); + show_lisp_register(xp, "arg_y", arg_y); + show_lisp_register(xp, "arg_x", arg_x); + show_lisp_register(xp, "temp0", temp0); + show_lisp_register(xp, "temp1/next_method_context", temp1); + show_lisp_register(xp, "temp2/nfn", temp2); + show_lisp_register(xp, "temp3/fname", temp3); + /* show_lisp_register(xp, "new_fn", new_fn); */ + show_lisp_register(xp, "save0", save0); + show_lisp_register(xp, "save1", save1); + show_lisp_register(xp, "save2", save2); + show_lisp_register(xp, "save3", save3); + show_lisp_register(xp, "save4", save4); + show_lisp_register(xp, "save5", save5); + show_lisp_register(xp, "save6", save6); + show_lisp_register(xp, "save7", save7); + } +#endif +#ifdef X8664 + + show_lisp_register(xp, "arg_z", Iarg_z); + show_lisp_register(xp, "arg_y", Iarg_y); + show_lisp_register(xp, "arg_x", Iarg_x); + fprintf(dbgout,"------\n"); + show_lisp_register(xp, "fn", Ifn); + fprintf(dbgout,"------\n"); + show_lisp_register(xp, "save0", Isave0); + show_lisp_register(xp, "save1", Isave1); + show_lisp_register(xp, "save2", Isave2); + show_lisp_register(xp, "save3", Isave3); + fprintf(dbgout,"------\n"); + show_lisp_register(xp, "temp0", Itemp0); + show_lisp_register(xp, "temp1", Itemp1); + show_lisp_register(xp, "temp2", Itemp2); + fprintf(dbgout,"------\n"); + if (tag_of(xpGPR(xp,Inargs)) == tag_fixnum) { + fprintf(dbgout,"%%rcx (nargs) = %ld (maybe)\n", unbox_fixnum(xpGPR(xp,Inargs)&0xffff)); + } +#endif + +#ifdef X8632 + show_lisp_register(xp, "arg_z", Iarg_z); + show_lisp_register(xp, "arg_y", Iarg_y); + fprintf(dbgout,"------\n"); + show_lisp_register(xp, "fn", Ifn); + fprintf(dbgout,"------\n"); + show_lisp_register(xp, "temp0", Itemp0); + show_lisp_register(xp, "temp1", Itemp1); + fprintf(dbgout,"------\n"); + if (tag_of(xpGPR(xp,Inargs)) == tag_fixnum) { + fprintf(dbgout,"%%edx (nargs) = %d (maybe)\n", unbox_fixnum(xpGPR(xp,Inargs))); + } +#endif + } + + return debug_continue; +} + +#ifdef PPC +debug_command_return +debug_advance_pc(ExceptionInformation *xp, siginfo_t *info, int arg) +{ + adjust_exception_pc(xp,4); + return debug_continue; +} +#endif + +debug_command_return +debug_identify_exception(ExceptionInformation *xp, siginfo_t *info, int arg) +{ +#ifdef PPC + pc program_counter = xpPC(xp); + opcode instruction = 0; + + switch (arg) { + case SIGILL: + case SIGTRAP: + instruction = *program_counter; + if (major_opcode_p(instruction, major_opcode_TRI) || + X_opcode_p(instruction,major_opcode_X31,minor_opcode_TR)) { + describe_ppc_trap(xp); + } else { + describe_ppc_illegal(xp); + } + break; + case SIGSEGV: + case SIGBUS: + describe_memfault(xp, info); + break; + default: + break; + } +#endif + return debug_continue; +} + +char * +debug_get_string_value(char *prompt) +{ + static char buf[128]; + char *p, *res; + + do { + fpurge(stdin); + fprintf(dbgout, "\n %s :",prompt); + buf[0] = 0; + res = fgets(buf, sizeof(buf), stdin); + } while (0); + p = strchr(res, '\n'); + if (p) { + *p = 0; + return buf; + } + return NULL; +} + +natural +debug_get_natural_value(char *prompt) +{ + char s[32], *res; + int n; + natural val; + + do { + fpurge(stdin); + fprintf(dbgout, "\n %s :", prompt); + s[0]=0; + res = fgets(s, 24, stdin); + n = sscanf(s, "%lu", &val); + } while (n != 1); + return val; +} + +unsigned +debug_get_u5_value(char *prompt) +{ + char s[32], *res; + int n; + unsigned val; + + do { + fpurge(stdin); + fprintf(dbgout, "\n %s :", prompt); + res = fgets(s, 24, stdin); + n = sscanf(res, "%i", &val); + } while ((n != 1) || (val > 31)); + return val; +} + +debug_command_return +debug_show_symbol(ExceptionInformation *xp, siginfo_t *info, int arg) +{ + char *pname = debug_get_string_value("symbol name"); + extern void *plsym(ExceptionInformation *,char*); + + if (pname != NULL) { + plsym(xp, pname); + } + return debug_continue; +} + +debug_command_return +debug_thread_info(ExceptionInformation *xp, siginfo_t *info, int arg) +{ + TCR * tcr = get_tcr(false); + + if (tcr) { + area *vs_area = tcr->vs_area, *cs_area = tcr->cs_area; + + fprintf(dbgout, "Current Thread Context Record (tcr) = 0x" LISP "\n", tcr); + fprintf(dbgout, "Control (C) stack area: low = 0x" LISP ", high = 0x" LISP "\n", + (cs_area->low), (cs_area->high)); + fprintf(dbgout, "Value (lisp) stack area: low = 0x" LISP ", high = 0x" LISP "\n", + (u64_t)(natural)(vs_area->low), (u64_t)(natural)vs_area->high); + fprintf(dbgout, "Exception stack pointer = 0x" LISP "\n", +#ifdef PPC + (u64_t) (natural)(xpGPR(xp,1)) +#endif +#ifdef X86 + (u64_t) (natural)(xpGPR(xp,Isp)) +#endif + ); + } + return debug_continue; +} + + +debug_command_return +debug_set_gpr(ExceptionInformation *xp, siginfo_t *info, int arg) +{ + char buf[32]; + natural val; + + sprintf(buf, "value for GPR %d", arg); + val = debug_get_natural_value(buf); + xpGPR(xp,arg) = val; + return debug_continue; +} + +debug_command_return +debug_show_registers(ExceptionInformation *xp, siginfo_t *info, int arg) +{ + + +#ifdef PPC +#ifdef PPC64 + int a, b; + for (a = 0, b = 16; a < 16; a++, b++) { + fprintf(dbgout,"r%02d = 0x%016lX r%02d = 0x%016lX\n", + a, xpGPR(xp, a), + b, xpGPR(xp, b)); + } + + fprintf(dbgout, "\n PC = 0x%016lX LR = 0x%016lX\n", + xpPC(xp), xpLR(xp)); + fprintf(dbgout, "CTR = 0x%016lX CCR = 0x%08X\n", + xpCTR(xp), xpCCR(xp)); + fprintf(dbgout, "XER = 0x%08X MSR = 0x%016lX\n", + xpXER(xp), xpMSR(xp)); + fprintf(dbgout,"DAR = 0x%016lX DSISR = 0x%08X\n", + xpDAR(xp), xpDSISR(xp)); +#else + int a, b, c, d;; + for (a = 0, b = 8, c = 16, d = 24; a < 8; a++, b++, c++, d++) { + fprintf(dbgout,"r%02d = 0x%08X r%02d = 0x%08X r%02d = 0x%08X r%02d = 0x%08X\n", + a, xpGPR(xp, a), + b, xpGPR(xp, b), + c, xpGPR(xp, c), + d, xpGPR(xp, d)); + } + fprintf(dbgout, "\n PC = 0x%08X LR = 0x%08X CTR = 0x%08X CCR = 0x%08X\n", + xpPC(xp), xpLR(xp), xpCTR(xp), xpCCR(xp)); + fprintf(dbgout, "XER = 0x%08X MSR = 0x%08X DAR = 0x%08X DSISR = 0x%08X\n", + xpXER(xp), xpMSR(xp), xpDAR(xp), xpDSISR(xp)); +#endif +#endif + +#ifdef X8664 + fprintf(dbgout,"%%rax = 0x" ZLISP " %%r8 = 0x" ZLISP "\n", xpGPR(xp,REG_RAX),xpGPR(xp,REG_R8)); + fprintf(dbgout,"%%rcx = 0x" ZLISP " %%r9 = 0x" ZLISP "\n", xpGPR(xp,REG_RCX),xpGPR(xp,REG_R9)); + fprintf(dbgout,"%%rdx = 0x" ZLISP " %%r10 = 0x" ZLISP "\n", xpGPR(xp,REG_RDX),xpGPR(xp,REG_R10)); + fprintf(dbgout,"%%rbx = 0x" ZLISP " %%r11 = 0x" ZLISP "\n", xpGPR(xp,REG_RBX),xpGPR(xp,REG_R11)); + fprintf(dbgout,"%%rsp = 0x" ZLISP " %%r12 = 0x" ZLISP "\n", xpGPR(xp,REG_RSP),xpGPR(xp,REG_R12)); + fprintf(dbgout,"%%rbp = 0x" ZLISP " %%r13 = 0x" ZLISP "\n", xpGPR(xp,REG_RBP),xpGPR(xp,REG_R13)); + fprintf(dbgout,"%%rsi = 0x" ZLISP " %%r14 = 0x" ZLISP "\n", xpGPR(xp,REG_RSI),xpGPR(xp,REG_R14)); + fprintf(dbgout,"%%rdi = 0x" ZLISP " %%r15 = 0x" ZLISP "\n", xpGPR(xp,REG_RDI),xpGPR(xp,REG_R15)); + fprintf(dbgout,"%%rip = 0x" ZLISP " %%rflags = 0x%08lx\n", + xpGPR(xp, Iip), eflags_register(xp)); +#endif + +#ifdef X8632 + unsigned short rcs,rds,res,rfs,rgs,rss; +#ifdef DARWIN + rcs = xp->uc_mcontext->__ss.__cs; + rds = xp->uc_mcontext->__ss.__ds; + res = xp->uc_mcontext->__ss.__es; + rfs = xp->uc_mcontext->__ss.__fs; + rgs = xp->uc_mcontext->__ss.__gs; + rss = xp->uc_mcontext->__ss.__ss; +#define DEBUG_SHOW_X86_SEGMENT_REGISTERS +#endif +#ifdef LINUX + rcs = xp->uc_mcontext.gregs[REG_CS]; + rds = xp->uc_mcontext.gregs[REG_DS]; + res = xp->uc_mcontext.gregs[REG_ES]; + rfs = xp->uc_mcontext.gregs[REG_FS]; + rgs = xp->uc_mcontext.gregs[REG_GS]; + rss = xp->uc_mcontext.gregs[REG_SS]; +#define DEBUG_SHOW_X86_SEGMENT_REGISTERS +#endif +#ifdef FREEBSD + rcs = xp->uc_mcontext.mc_cs; + rds = xp->uc_mcontext.mc_ds; + res = xp->uc_mcontext.mc_es; + rfs = xp->uc_mcontext.mc_fs; + rgs = xp->uc_mcontext.mc_gs; + rss = xp->uc_mcontext.mc_ss; +#define DEBUG_SHOW_X86_SEGMENT_REGISTERS +#endif +#ifdef SOLARIS + rcs = xp->uc_mcontext.gregs[CS]; + rds = xp->uc_mcontext.gregs[DS]; + res = xp->uc_mcontext.gregs[ES]; + rfs = xp->uc_mcontext.gregs[FS]; + rgs = xp->uc_mcontext.gregs[GS]; + rss = xp->uc_mcontext.gregs[SS]; +#define DEBUG_SHOW_X86_SEGMENT_REGISTERS +#endif +#ifdef WINDOWS + rcs = xp->SegCs; + rds = xp->SegDs; + res = xp->SegEs; + rfs = xp->SegFs; + rgs = xp->SegGs; + rss = xp->SegSs; +#define DEBUG_SHOW_X86_SEGMENT_REGISTERS +#endif + + + + fprintf(dbgout, "%%eax = 0x" ZLISP "\n", xpGPR(xp, REG_EAX)); + fprintf(dbgout, "%%ecx = 0x" ZLISP "\n", xpGPR(xp, REG_ECX)); + fprintf(dbgout, "%%edx = 0x" ZLISP "\n", xpGPR(xp, REG_EDX)); + fprintf(dbgout, "%%ebx = 0x" ZLISP "\n", xpGPR(xp, REG_EBX)); + fprintf(dbgout, "%%esp = 0x" ZLISP "\n", xpGPR(xp, REG_ESP)); + fprintf(dbgout, "%%ebp = 0x" ZLISP "\n", xpGPR(xp, REG_EBP)); + fprintf(dbgout, "%%esi = 0x" ZLISP "\n", xpGPR(xp, REG_ESI)); + fprintf(dbgout, "%%edi = 0x" ZLISP "\n", xpGPR(xp, REG_EDI)); + fprintf(dbgout, "%%eip = 0x" ZLISP "\n", xpGPR(xp, REG_EIP)); + fprintf(dbgout, "%%eflags = 0x" ZLISP "\n", xpGPR(xp, REG_EFL)); +#ifdef DEBUG_SHOW_X86_SEGMENT_REGISTERS + fprintf(dbgout,"\n"); + fprintf(dbgout, "%%cs = 0x%04x\n", rcs); + fprintf(dbgout, "%%ds = 0x%04x\n", rds); + fprintf(dbgout, "%%ss = 0x%04x\n", rss); + fprintf(dbgout, "%%es = 0x%04x\n", res); + fprintf(dbgout, "%%fs = 0x%04x\n", rfs); + fprintf(dbgout, "%%gs = 0x%04x\n", rgs); + +#endif + +#endif + + return debug_continue; +} + +debug_command_return +debug_show_fpu(ExceptionInformation *xp, siginfo_t *info, int arg) +{ + double *dp; + int *np, i; +#ifdef PPC + dp = xpFPRvector(xp); + np = (int *) dp; + + for (i = 0; i < 32; i++, np+=2) { + fprintf(dbgout, "f%02d : 0x%08X%08X (%f)\n", i, np[0], np[1], *dp++); + } + fprintf(dbgout, "FPSCR = %08X\n", xpFPSCR(xp)); +#endif +#ifdef X8664 +#ifdef LINUX + struct _libc_xmmreg * xmmp = &(xp->uc_mcontext.fpregs->_xmm[0]); +#endif +#ifdef DARWIN + struct xmm { + char fpdata[16]; + }; + struct xmm *xmmp = (struct xmm *)(xpFPRvector(xp)); +#endif +#ifdef WINDOWS + struct xmm { + char fpdata[16]; + }; + struct xmm *xmmp; /* XXX: actually get them */ +#endif +#ifdef FREEBSD + struct xmmacc *xmmp = xpXMMregs(xp); +#endif +#ifdef SOLARIS + upad128_t *xmmp = xpXMMregs(xp); +#endif + float *sp; + + + for (i = 0; i < 16; i++, xmmp++) { + sp = (float *) xmmp; + dp = (double *) xmmp; + np = (int *) xmmp; + fprintf(dbgout, "f%02d: 0x%08x (%e), 0x%08x%08x (%e)\n", i, *np, (double)(*sp), np[1], np[0], *dp); + } + fprintf(dbgout, "mxcsr = 0x%08x\n", +#ifdef LINUX + xp->uc_mcontext.fpregs->mxcsr +#endif +#ifdef DARWIN + UC_MCONTEXT(xp)->__fs.__fpu_mxcsr +#endif +#ifdef FREEBSD + (((struct savefpu *)(&(xp)->uc_mcontext.mc_fpstate))->sv_env.en_mxcsr) +#endif +#ifdef SOLARIS + xp->uc_mcontext.fpregs.fp_reg_set.fpchip_state.xstatus +#endif +#ifdef WINDOWS + *(xpMXCSRptr(xp)) +#endif + ); +#endif +#ifdef X8632 +#ifdef DARWIN + struct xmm { + char fpdata[8]; + }; + struct xmm *xmmp = (struct xmm *)(xpFPRvector(xp)); + + for (i = 0; i < 8; i++, xmmp++) { + float *sp = (float *)xmmp; + dp = (double *)xmmp; + np = (int *)xmmp; + fprintf(dbgout, "f%1d: 0x%08x (%e), 0x%08x%08x (%e)\n", i, *np, + (double)(*sp), np[1], np[0], *dp); + } + fprintf(dbgout, "mxcsr = 0x%08x\n", UC_MCONTEXT(xp)->__fs.__fpu_mxcsr); +#endif +#endif + + return debug_continue; +} + +debug_command_return +debug_kill_process(ExceptionInformation *xp, siginfo_t *info, int arg) { + return debug_kill; +} + +debug_command_return +debug_win(ExceptionInformation *xp, siginfo_t *info, int arg) { + return debug_exit_success; +} + +debug_command_return +debug_lose(ExceptionInformation *xp, siginfo_t *info, int arg) { + return debug_exit_fail; +} + +debug_command_return +debug_help(ExceptionInformation *xp, siginfo_t *info, int arg) { + debug_command_entry *entry; + + for (entry = debug_command_entries; entry->f; entry++) { + /* If we have an XP or don't need one, call the function */ + if (xp || !(entry->flags & DEBUG_COMMAND_FLAG_REQUIRE_XP)) { + fprintf(dbgout, "(%c) %s\n", entry->c, entry->help_text); + } + } + return debug_continue; +} + + + + +debug_command_return +debug_backtrace(ExceptionInformation *xp, siginfo_t *info, int arg) +{ + extern LispObj current_stack_pointer(); + extern void plbt_sp(LispObj); + extern void plbt(ExceptionInformation *); + + if (xp) { + plbt(xp); + } else { + plbt_sp(current_stack_pointer()); + } + return debug_continue; +} + +debug_command_return +debug_thread_reset(ExceptionInformation *xp, siginfo_t *info, int arg) +{ + reset_lisp_process(xp); + return debug_exit_success; +} + + +debug_command_entry debug_command_entries[] = +{ + {debug_set_gpr, + "Set specified GPR to new value", + DEBUG_COMMAND_FLAG_AUX_REGNO, + "GPR to set (0-31) ?", + 'G'}, +#ifdef PPC + {debug_advance_pc, + "Advance the program counter by one instruction (use with caution!)", + DEBUG_COMMAND_FLAG_REQUIRE_XP | DEBUG_COMMAND_FLAG_EXCEPTION_ENTRY_ONLY, + NULL, + 'A'}, + {debug_identify_exception, + "Describe the current exception in greater detail", + DEBUG_COMMAND_FLAG_REQUIRE_XP | DEBUG_COMMAND_FLAG_EXCEPTION_ENTRY_ONLY | + DEBUG_COMMAND_FLAG_EXCEPTION_REASON_ARG, + NULL, + 'D'}, +#endif + {debug_show_registers, + "Show raw GPR/SPR register values", + DEBUG_COMMAND_FLAG_REQUIRE_XP, + NULL, + 'R'}, + {debug_lisp_registers, + "Show Lisp values of tagged registers", + DEBUG_COMMAND_FLAG_REQUIRE_XP, + NULL, + 'L'}, + {debug_show_fpu, + "Show FPU registers", + DEBUG_COMMAND_FLAG_REQUIRE_XP, + NULL, + 'F'}, + {debug_show_symbol, + "Find and describe symbol matching specified name", + 0, + NULL, + 'S'}, + {debug_backtrace, + "Show backtrace", + 0, + NULL, + 'B'}, + {debug_thread_info, + "Show info about current thread", + 0, + NULL, + 'T'}, + {debug_win, + "Exit from this debugger, asserting that any exception was handled", + 0, + NULL, + 'X'}, +#ifdef DARWIN + {debug_lose, + "Propagate the exception to another handler (debugger or OS)", + DEBUG_COMMAND_FLAG_REQUIRE_XP | DEBUG_COMMAND_FLAG_EXCEPTION_ENTRY_ONLY, + NULL, + 'P'}, +#endif +#if 0 + {debug_thread_reset, + "Reset current thread (as if in response to stack overflow)", + DEBUG_COMMAND_FLAG_REQUIRE_XP, + NULL, + 'T'}, +#endif + {debug_kill_process, + "Kill Clozure CL process", + 0, + NULL, + 'K'}, + {debug_help, + "Show this help", + 0, + NULL, + '?'}, + /* end-of-table */ + {NULL, + NULL, + 0, + NULL, + 0} +}; + +debug_command_return +apply_debug_command(ExceptionInformation *xp, int c, siginfo_t *info, int why) +{ + if (c == EOF) { + return debug_kill; + } else { + debug_command_entry *entry; + debug_command f; + c = toupper(c); + + for (entry = debug_command_entries; (f = entry->f) != NULL; entry++) { + if (toupper(entry->c) == c) { + /* If we have an XP or don't need one, call the function */ + if ((xp || !(entry->flags & DEBUG_COMMAND_FLAG_REQUIRE_XP)) && + ((why > debug_entry_exception) || + !(entry->flags & DEBUG_COMMAND_FLAG_EXCEPTION_ENTRY_ONLY))) { + int arg = 0; + if ((entry->flags & DEBUG_COMMAND_REG_FLAGS) + == DEBUG_COMMAND_FLAG_AUX_REGNO) { + arg = debug_get_u5_value("register number"); + } + if (entry->flags & DEBUG_COMMAND_FLAG_EXCEPTION_REASON_ARG) { + arg = why; + } + return (f)(xp, info, arg); + } + break; + } + } + return debug_continue; + } +} + +debug_identify_function(ExceptionInformation *xp, siginfo_t *info) +{ +#ifdef PPC + if (xp) { + if (active_tcr_p((TCR *)(ptr_from_lispobj(xpGPR(xp, rcontext))))) { + LispObj f = xpGPR(xp, fn), codev; + pc where = xpPC(xp); + + if (!(codev = register_codevector_contains_pc(f, where))) { + f = xpGPR(xp, nfn); + codev = register_codevector_contains_pc(f, where); + } + if (codev) { + fprintf(dbgout, " While executing: %s\n", print_lisp_object(f)); + } + } else { + int disp; + char *foreign_name; + natural where = (natural)xpPC(xp); + + fprintf(dbgout, " In foreign code at address 0x" ZLISP "\n", where); + foreign_name = foreign_name_and_offset(where, &disp); + if (foreign_name) { + fprintf(dbgout, " [%s + %d]\n", foreign_name, disp); + } + } + } +#endif +} + +#ifndef WINDOWS +extern pid_t main_thread_pid; +#endif + + +OSStatus +lisp_Debugger(ExceptionInformation *xp, + siginfo_t *info, + int why, + Boolean in_foreign_code, + char *message, + ...) +{ + va_list args; + debug_command_return state = debug_continue; + + + if (stdin_is_dev_null()) { + return -1; + } + + va_start(args,message); + vfprintf(dbgout, message, args); + fprintf(dbgout, "\n"); + va_end(args); + + if (threads_initialized) { + suspend_other_threads(false); + } + + lisp_debugger_in_foreign_code = in_foreign_code; + if (in_foreign_code) { + char *foreign_name; + int disp; + fprintf(dbgout, "Exception occurred while executing foreign code\n"); + foreign_name = foreign_name_and_offset((natural)xpPC(xp), &disp); + if (foreign_name) { + fprintf(dbgout, " at %s + %d\n", foreign_name, disp); + } + } + + if (xp) { + if (why > debug_entry_exception) { + debug_identify_exception(xp, info, why); + } + debug_identify_function(xp, info); + } + if (lisp_global(BATCH_FLAG)) { +#ifdef WINDOWS + fprintf(dbgout, "Current Process Id %d\n", (int)GetCurrentProcessId()); +#else + fprintf(dbgout, "Main thread pid %d\n", main_thread_pid); +#endif + debug_thread_info(xp, info, 0); + if (xp) { + debug_show_registers(xp, info, 0); + debug_lisp_registers(xp, info, 0); + debug_show_fpu(xp, info, 0); + } + debug_backtrace(xp, info, 0); + abort(); + } + + fprintf(dbgout, "? for help\n"); + while (state == debug_continue) { +#ifdef WINDOWS + fprintf(dbgout, "[%d] Clozure CL kernel debugger: ", (int)GetCurrentProcessId()); +#else + fprintf(dbgout, "[%d] Clozure CL kernel debugger: ", main_thread_pid); +#endif + fflush(dbgout); /* dbgout should be unbuffered, so this shouldn't be necessary. But it can't hurt ... */ + state = apply_debug_command(xp, readc(), info, why); + } + switch (state) { + case debug_exit_success: + if (threads_initialized) { + resume_other_threads(false); + } + return 0; + case debug_exit_fail: + if (threads_initialized) { + resume_other_threads(false); + } + return -1; + case debug_kill: + terminate_lisp(); + default: + return 0; + } +} + +void +Bug(ExceptionInformation *xp, const char *format, ...) +{ + va_list args; + char s[512]; + + va_start(args, format); + vsnprintf(s, sizeof(s),format, args); + va_end(args); + lisp_Debugger(xp, NULL, debug_entry_bug, false, s); + +} + +void +FBug(ExceptionInformation *xp, const char *format, ...) +{ + va_list args; + char s[512]; + + va_start(args, format); + vsnprintf(s, sizeof(s),format, args); + va_end(args); + lisp_Debugger(xp, NULL, debug_entry_bug, true, s); + +} + +void +lisp_bug(char *string) +{ + Bug(NULL, "Bug in Clozure CL system code:\n%s", string); +} + Index: /branches/new-random/lisp-kernel/lisp-errors.h =================================================================== --- /branches/new-random/lisp-kernel/lisp-errors.h (revision 13309) +++ /branches/new-random/lisp-kernel/lisp-errors.h (revision 13309) @@ -0,0 +1,163 @@ +/* + Copyright (C) 2009 Clozure Associates + Copyright (C) 1994-2001 Digitool, Inc + This file is part of Clozure CL. + + Clozure CL is licensed under the terms of the Lisp Lesser GNU Public + License , known as the LLGPL and distributed with Clozure CL as the + file "LICENSE". The LLGPL consists of a preamble and the LGPL, + which is distributed with Clozure CL as the file "LGPL". Where these + conflict, the preamble takes precedence. + + Clozure CL is referenced in the preamble as the "LIBRARY." + + The LLGPL is also available online at + http://opensource.franz.com/preamble.html +*/ + +#ifndef __ERRORS_X +#define __ERRORS_X 1 + + +#define error_reg_regnum 0 +#define error_udf 1 +#define error_udf_call 2 +#define error_throw_tag_missing 3 +#define error_alloc_failed 4 +#define error_stack_overflow 5 +#define error_excised_function_call 6 +#define error_too_many_values 7 +#define error_propagate_suspend 10 +#define error_interrupt 11 +#define error_suspend 12 +#define error_suspend_all 13 +#define error_resume 14 +#define error_resume_all 15 +#define error_kill 16 +#define error_cant_call 17 +#define error_allocate_list 18 + +#define error_type_error 128 + +typedef enum { + error_object_not_array = error_type_error, + error_object_not_bignum, + error_object_not_fixnum, + error_object_not_character, + error_object_not_integer, + error_object_not_list, + error_object_not_number, + error_object_not_sequence, + error_object_not_simple_string, + error_object_not_simple_vector, + error_object_not_string, + error_object_not_symbol, + error_object_not_macptr, + error_object_not_real, + error_object_not_cons, + error_object_not_unsigned_byte, + error_object_not_radix, + error_object_not_float, + error_object_not_rational, + error_object_not_ratio, + error_object_not_short_float, + error_object_not_double_float, + error_object_not_complex, + error_object_not_vector, + error_object_not_simple_base_string, + error_object_not_function, + error_object_not_unsigned_byte_16, + error_object_not_unsigned_byte_8, + error_object_not_unsigned_byte_32, + error_object_not_signed_byte_32, + error_object_not_signed_byte_16, + error_object_not_signed_byte_8, + error_object_not_base_character, + error_object_not_bit, + error_object_not_unsigned_byte_24, + error_object_not_u64, + error_object_not_s64, + error_object_not_unsigned_byte_56, + error_object_not_simple_array_double_float_2d, + error_object_not_simple_array_single_float_2d, + error_object_not_mod_char_code_limit, + error_object_not_array_2d, + error_object_not_array_3d, + error_object_not_array_t, + error_object_not_array_bit, + error_object_not_array_s8, + error_object_not_array_u8, + error_object_not_array_s16, + error_object_not_array_u16, + error_object_not_array_s32, + error_object_not_array_u32, + error_object_not_array_s64, + error_object_not_array_u64, + error_object_not_array_fixnum, + error_object_not_array_single_float, + error_object_not_array_double_float, + error_object_not_array_char, + error_object_not_array_t_2d, + error_object_not_array_bit_2d, + error_object_not_array_s8_2d, + error_object_not_array_u8_2d, + error_object_not_array_s16_2d, + error_object_not_array_u16_2d, + error_object_not_array_s32_2d, + error_object_not_array_u32_2d, + error_object_not_array_s64_2d, + error_object_not_array_u64_2d, + error_object_not_array_fixnum_2d, + error_object_not_array_single_float_2d, + error_object_not_array_double_float_2d, + error_object_not_array_char_2d, + error_object_not_simple_array_t_2d, + error_object_not_simple_array_bit_2d, + error_object_not_simple_array_s8_2d, + error_object_not_simple_array_u8_2d, + error_object_not_simple_array_s16_2d, + error_object_not_simple_array_u16_2d, + error_object_not_simple_array_s32_2d, + error_object_not_simple_array_u32_2d, + error_object_not_simple_array_s64_2d, + error_object_not_simple_array_u64_2d, + error_object_not_simple_array_fixnum_2d, + error_object_not_simple_array_char_2d, + error_object_not_array_t_3d, + error_object_not_array_bit_3d, + error_object_not_array_s8_3d, + error_object_not_array_u8_3d, + error_object_not_array_s16_3d, + error_object_not_array_u16_3d, + error_object_not_array_s32_3d, + error_object_not_array_u32_3d, + error_object_not_array_s64_3d, + error_object_not_array_u64_3d, + error_object_not_array_fixnum_3d, + error_object_not_array_single_float_3d, + error_object_not_array_double_float_3d, + error_object_not_array_char_3d, + error_object_not_simple_array_t_3d, + error_object_not_simple_array_bit_3d, + error_object_not_simple_array_s8_3d, + error_object_not_simple_array_u8_3d, + error_object_not_simple_array_s16_3d, + error_object_not_simple_array_u16_3d, + error_object_not_simple_array_s32_3d, + error_object_not_simple_array_u32_3d, + error_object_not_simple_array_s64_3d, + error_object_not_simple_array_u64_3d, + error_object_not_simple_array_fixnum_3d, + error_object_not_simple_array_single_float_3d, + error_object_not_simple_array_double_float_3d, + error_object_not_simple_array_char_3d +} type_error; + +#define error_FPU_exception_double 1024 +#define error_FPU_exception_short 1025 + +#define error_memory_full 2048 + + + +#endif /* __ERRORS_X */ Index: /branches/new-random/lisp-kernel/lisp-exceptions.h =================================================================== --- /branches/new-random/lisp-kernel/lisp-exceptions.h (revision 13309) +++ /branches/new-random/lisp-kernel/lisp-exceptions.h (revision 13309) @@ -0,0 +1,158 @@ +/* + Copyright (C) 2009 Clozure Associates + Copyright (C) 1994-2001 Digitool, Inc + This file is part of Clozure CL. + + Clozure CL is licensed under the terms of the Lisp Lesser GNU Public + License , known as the LLGPL and distributed with Clozure CL as the + file "LICENSE". The LLGPL consists of a preamble and the LGPL, + which is distributed with Clozure CL as the file "LGPL". Where these + conflict, the preamble takes precedence. + + Clozure CL is referenced in the preamble as the "LIBRARY." + + The LLGPL is also available online at + http://opensource.franz.com/preamble.html +*/ + +#ifndef __lisp_exceptions_h__ +#define __lisp_exceptions_h__ 1 + + +#include +#include "memprotect.h" +#include "gc.h" + +#ifdef WINDOWS +#include +#endif + +typedef enum { + kDebugger, + kContinue, + kExit +} ErrAction; + + +#ifdef WINDOWS +typedef EXCEPTION_RECORD siginfo_t; /* Not even close to being the right thing to do */ +#endif + + +void +zero_page(BytePtr); + +void +zero_heap_segment(BytePtr); + +extern protected_area_ptr AllProtectedAreas; + +protected_area_ptr find_protected_area(BytePtr); + +OSStatus +lisp_Debugger(ExceptionInformation *, siginfo_t *, int, Boolean, char *, ...); + +OSStatus +handle_protection_violation(ExceptionInformation *, siginfo_t *, TCR *, int); + +protected_area_ptr +new_protected_area(BytePtr, BytePtr, lisp_protection_kind, natural, Boolean); + +void +unprotect_area_prefix(protected_area_ptr, size_t); + +void +protect_area_prefix(protected_area_ptr, size_t); + +void +protect_area(protected_area_ptr); + + +Boolean +resize_dynamic_heap(BytePtr, natural); + +OSStatus +PMCL_exception_handler(int, ExceptionInformation *, TCR *, siginfo_t *, int); + +TCR* +get_tcr(Boolean); + +ErrAction +error_action( void ); + +void +install_pmcl_exception_handlers(void); + +void +unprotect_all_areas(void); + +void +exception_cleanup(void); + +void +exception_init(); + + +#define debug_entry_exception 0 +#define debug_entry_bug -1 +#define debug_entry_dbg -2 + +#ifdef WINDOWS +#define ALLOW_EXCEPTIONS(context) // blank stare for now +#else +#define ALLOW_EXCEPTIONS(context) \ + pthread_sigmask(SIG_SETMASK, &context->uc_sigmask, NULL); +#endif + +void +Fatal(StringPtr, StringPtr); + + +Ptr +allocate(natural); + +Ptr +zalloc(natural); + +void +deallocate(Ptr); + + + +void +non_fatal_error( char * ); + +void Bug(ExceptionInformation *, const char *format_string, ...); +void FBug(ExceptionInformation *, const char *format_string, ...); +signed_natural gc_from_xp(ExceptionInformation *, signed_natural); +signed_natural purify_from_xp(ExceptionInformation *, signed_natural); +signed_natural impurify_from_xp(ExceptionInformation *, signed_natural); + + + +void +adjust_exception_pc(ExceptionInformation *, int); + +size_t +symbol_name( unsigned, char *, size_t ); + + +size_t +exception_fn_name( ExceptionInformation *, int, char *, size_t ); + + + +#ifdef PPC +#include "ppc-exceptions.h" +#endif + +#ifdef X86 +#include "x86-exceptions.h" +#endif + +void suspend_other_threads(Boolean); +void resume_other_threads(Boolean); + + +#endif /* __lisp_exceptions_h__ */ + Index: /branches/new-random/lisp-kernel/lisp.h =================================================================== --- /branches/new-random/lisp-kernel/lisp.h (revision 13309) +++ /branches/new-random/lisp-kernel/lisp.h (revision 13309) @@ -0,0 +1,135 @@ +/* + Copyright (C) 2009 Clozure Associates + Copyright (C) 1994-2001 Digitool, Inc + This file is part of Clozure CL. + + Clozure CL is licensed under the terms of the Lisp Lesser GNU Public + License , known as the LLGPL and distributed with Clozure CL as the + file "LICENSE". The LLGPL consists of a preamble and the LGPL, + which is distributed with Clozure CL as the file "LGPL". Where these + conflict, the preamble takes precedence. + + Clozure CL is referenced in the preamble as the "LIBRARY." + + The LLGPL is also available online at + http://opensource.franz.com/preamble.html +*/ + +#ifndef __lisp__ +#define __lisp__ + + + +#include "lisptypes.h" +#ifndef LOWMEM_BIAS +#define LOWMEM_BIAS 0 +#endif + +#ifdef PPC +#include "ppc-constants.h" +#endif +#ifdef X86 +#include "x86-constants.h" +#endif +#include "macros.h" + +extern Boolean use_mach_exception_handling; + +extern int page_size, log2_page_size; + +static inline natural +_align_to_power_of_2(natural n, unsigned power) +{ + natural align = (1< + +extern FILE *dbgout; Index: /branches/new-random/lisp-kernel/lisp.s =================================================================== --- /branches/new-random/lisp-kernel/lisp.s (revision 13309) +++ /branches/new-random/lisp-kernel/lisp.s (revision 13309) @@ -0,0 +1,68 @@ +/* Copyright (C) 2009 Clozure Associates */ +/* Copyright (C) 1994-2001 Digitool, Inc */ +/* This file is part of Clozure CL. */ + +/* Clozure CL is licensed under the terms of the Lisp Lesser GNU Public */ +/* License , known as the LLGPL and distributed with Clozure CL as the */ +/* file "LICENSE". The LLGPL consists of a preamble and the LGPL, */ +/* which is distributed with Clozure CL as the file "LGPL". Where these */ +/* conflict, the preamble takes precedence. */ + +/* Clozure CL is referenced in the preamble as the "LIBRARY." */ + +/* The LLGPL is also available online at */ +/* http://opensource.franz.com/preamble.html */ + + include(m4macros.m4) + ifdef([LOWMEM_BIAS],[ +[LOWMEM_BIAS] = LOWMEM_BIAS +],[ +[LOWMEM_BIAS] = 0 +]) + undefine([LOWMEM_BIAS]) + /* DWARF2 exception fsm */ + DW_CFA_advance_loc = 0x40 + DW_CFA_offset = 0x80 + DW_CFA_restore = 0xc0 + DW_CFA_nop = 0x00 + DW_CFA_set_loc = 0x01 + DW_CFA_advance_loc1 = 0x02 + DW_CFA_advance_loc2 = 0x03 + DW_CFA_advance_loc4 = 0x04 + DW_CFA_offset_extended = 0x05 + DW_CFA_restore_extended = 0x06 + DW_CFA_undefined = 0x07 + DW_CFA_same_value = 0x08 + DW_CFA_register = 0x09 + DW_CFA_remember_state = 0x0a + DW_CFA_restore_state = 0x0b + DW_CFA_def_cfa = 0x0c + DW_CFA_def_cfa_register = 0x0d + DW_CFA_def_cfa_offset = 0x0e + /* DWARF 3. */ + DW_CFA_def_cfa_expression = 0x0f + DW_CFA_expression = 0x10 + DW_CFA_offset_extended_sf = 0x11 + DW_CFA_def_cfa_sf = 0x12 + DW_CFA_def_cfa_offset_sf = 0x13 + DW_CFA_val_offset = 0x14 + DW_CFA_val_offset_sf = 0x15 + DW_CFA_val_expression = 0x16 + /* SGI/MIPS specific. */ + DW_CFA_MIPS_advance_loc8 = 0x1d + /* GNU extensions. */ + DW_CFA_GNU_window_save = 0x2d + DW_CFA_GNU_args_size = 0x2e + DW_CFA_GNU_negative_offset_extended = 0x2f + + ifdef([PPC],[ + include(ppc-constants.s) + include(ppc-macros.s) + include(ppc-uuo.s) + ]) + ifdef([X86],[ + include(x86-constants.s) + include(x86-macros.s) + include(x86-uuo.s) + ]) + Index: /branches/new-random/lisp-kernel/lisp_globals.h =================================================================== --- /branches/new-random/lisp-kernel/lisp_globals.h (revision 13309) +++ /branches/new-random/lisp-kernel/lisp_globals.h (revision 13309) @@ -0,0 +1,146 @@ +/* + Copyright (C) 2009 Clozure Associates + Copyright (C) 1994-2001 Digitool, Inc + This file is part of Clozure CL. + + Clozure CL is licensed under the terms of the Lisp Lesser GNU Public + License , known as the LLGPL and distributed with Clozure CL as the + file "LICENSE". The LLGPL consists of a preamble and the LGPL, + which is distributed with Clozure CL as the file "LGPL". Where these + conflict, the preamble takes precedence. + + Clozure CL is referenced in the preamble as the "LIBRARY." + + The LLGPL is also available online at + http://opensource.franz.com/preamble.html +*/ + +#ifndef __lisp_globals__ +#define __lisp_globals__ + + +extern LispObj lisp_nil; + +#define GET_TCR (-1) /* address of get_tcr() for callbacks */ +#define TCR_COUNT (-2) /* next tcr's tcr_id */ +#define INTERRUPT_SIGNAL (-3) /* signal to use for PROCESS-INTERRUPT */ +#define KERNEL_IMPORTS (-4) /* some things we need to have imported for us. */ +#define OBJC_2_PERSONALITY (-5) /* A good listener. Doesn't say much */ +#define SAVETOC (-6) /* Saved TOC register, for some platforms */ +#define SAVER13 (-7) /* Saved (global) r13, on some platforms */ +#define SUBPRIMS_BASE (-8) /* where the dynamic subprims wound up */ +#define RET1VALN (-9) /* magic multiple-values return address */ +#define TCR_KEY (-10) /* tsd key for per-thread tcr */ +#define TCR_AREA_LOCK (-11) /* all_areas/tcr queue lock */ +#define EXCEPTION_LOCK (-12) /* serialize exception handling */ +#define STATIC_CONSES (-13) +#define DEFAULT_ALLOCATION_QUANTUM (-14) +#define INTFLAG (-15) +#define GC_INHIBIT_COUNT (-16) +#define REFBITS (-17) +#define OLDSPACE_DNODE_COUNT (-18) /* count of dynamic dnodes older than generation 0 */ +#define ALTIVEC_PRESENT (-19) /* non-zero if AltiVec present. */ +#define FWDNUM (-20) /* fixnum: GC "forwarder" call count. */ +#define GC_NUM (-21) /* fixnum: GC call count. */ +#define GCABLE_POINTERS (-22) /* linked-list of weak macptrs. */ +#define HEAP_START (-23) /* start of lisp heap */ +#define HEAP_END (-24) /* end of lisp heap */ +#define STATICALLY_LINKED (-25) /* non-zero if -static */ +#define STACK_SIZE (-26) /* from the command line */ +#define OBJC_2_BEGIN_CATCH (-27) /* address of ObjC 2.0 objc_begin_catch() */ +#define KERNEL_PATH (-28) /* real executable name */ +#define ALL_AREAS (-29) /* doubly-linked list of stack & heap areas */ +#define LEXPR_RETURN (-30) /* magic &lexpr cleanup code */ +#define LEXPR_RETURN1V (-31) /* single-value &lexpr cleanup code */ +#define IN_GC (-32) /* non-zero when lisp addresses may be invalid */ +#define FREE_STATIC_CONSES (-33) /* length of freelist */ +#define OBJC_2_END_CACTCH (-34) /* address of ObjC 2.0 objc_end_catch() */ +#define SHORT_FLOAT_ZERO (-35) /* low half of 1.0d0 */ +#define DOUBLE_FLOAT_ONE (-36) /* high half of 1.0d0 */ +#define STATIC_CONS_AREA (-37) /* static_cons_area */ +#define LISP_EXIT_HOOK (-38) /* install foreign exception handling */ +#define OLDEST_EPHEMERAL (-39) /* doubleword address of oldest ephemeral object or 0 */ +#define TENURED_AREA (-40) /* the tenured area */ +#define REF_BASE (-41) /* start of oldest pointer-bearing area */ +#define ARGV (-42) /* pointer to &argv[0] */ +#define HOST_PLATFORM (-43) /* for platform-specific initialization */ +#define BATCH_FLAG (-44) /* -b arg */ +#define UNWIND_RESUME (-45) /* address of _Unwind_Resume from libobjc */ +#define WEAK_GC_METHOD (-46) /* weak GC algorithm */ +#define IMAGE_NAME (-47) /* --image-name arg */ +#define INITIAL_TCR (-48) /* initial thread tcr */ + +#define MIN_KERNEL_GLOBAL INITIAL_TCR + +/* These are only non-zero when an image is being saved or loaded */ + +#if (WORD_SIZE==64) +#define LISP_HEAP_THRESHOLD (-511) +#define EGC_ENABLED (-510) +#define G0_THRESHOLD (-509) +#define G1_THRESHOLD (-508) +#define G2_THRESHOLD (-507) +#else +#define LISP_HEAP_THRESHOLD (-1023) +#define EGC_ENABLED (-1022) +#define G0_THRESHOLD (-1021) +#define G1_THRESHOLD (-1020) +#define G2_THRESHOLD (-1019) +#endif + +#ifdef PPC +#ifdef PPC64 +#define lisp_global(g) (((LispObj *) (0x3000+(LOWMEM_BIAS)))[(g)]) +#define nrs_symbol(s) (((lispsymbol *) (0x3000+(LOWMEM_BIAS)))[(s)]) +#else +#define lisp_global(g) (((LispObj *) (nil_value-fulltag_nil))[(g)]) +#define nrs_symbol(s) (((lispsymbol *) (nil_value+(8-fulltag_nil)+8))[(s)]) +#endif +#endif + +#ifdef X8664 +#define lisp_global(g) (((LispObj *) (0x13000+(LOWMEM_BIAS)))[(g)]) +#define nrs_symbol(s) (((lispsymbol *) (0x13020+(LOWMEM_BIAS)))[(s)]) +#endif + +#ifdef X8632 +#define lisp_global(g) (((LispObj *) (0x13000+(LOWMEM_BIAS)))[(g)]) +#define nrs_symbol(s) (((lispsymbol *) (0x13008+(LOWMEM_BIAS)))[(s)]) +#endif + +#define nrs_T (nrs_symbol(0)) /* t */ +#define nrs_NILSYM (nrs_symbol(1)) /* nil */ +#define nrs_ERRDISP (nrs_symbol(2)) /* %err-disp */ +#define nrs_CMAIN (nrs_symbol(3)) /* cmain */ +#define nrs_EVAL (nrs_symbol(4)) /* eval */ +#define nrs_APPEVALFN (nrs_symbol(5)) /* apply-evaluated-function */ +#define nrs_ERROR (nrs_symbol(6)) /* error */ +#define nrs_DEFUN (nrs_symbol(7)) /* %defun */ +#define nrs_DEFVAR (nrs_symbol(8)) /* %defvar */ +#define nrs_DEFCONSTANT (nrs_symbol(9)) /* %defconstant */ +#define nrs_MACRO (nrs_symbol(10)) /* %macro */ +#define nrs_KERNELRESTART (nrs_symbol(11)) /* %kernel-restart */ +#define nrs_PACKAGE (nrs_symbol(12)) /* *package* */ +#define nrs_TOTAL_BYTES_FREED (nrs_symbol(13)) /* *total-bytes-freed* */ +#define nrs_KALLOWOTHERKEYS (nrs_symbol(14)) /* :allow-other-keys */ +#define nrs_TOPLCATCH (nrs_symbol(15)) /* %toplevel-catch% */ +#define nrs_TOPLFUNC (nrs_symbol(16)) /* %toplevel-function% */ +#define nrs_CALLBACKS (nrs_symbol(17)) /* %pascal-functions% */ +#define nrs_ALLMETEREDFUNS (nrs_symbol(18)) /* *all-metered-functions* */ +#define nrs_TOTAL_GC_MICROSECONDS (nrs_symbol(19)) /* *total-gc-microseconds* */ +#define nrs_BUILTIN_FUNCTIONS (nrs_symbol(20)) /* %builtin-functions% */ +#define nrs_UDF (nrs_symbol(21)) /* %unbound-function% */ +#define nrs_INIT_MISC (nrs_symbol(22)) /* %init-misc% */ +#define nrs_MACRO_CODE (nrs_symbol(23)) /* %macro-code% */ +#define nrs_CLOSURE_CODE (nrs_symbol(24)) /* %closure-code% */ +#define nrs_NEW_GCABLE_PTR (nrs_symbol(25)) /* %new-gcable-ptr */ +#define nrs_GC_EVENT_STATUS_BITS (nrs_symbol(26)) /* *gc-event-status-bits* */ +#define nrs_POST_GC_HOOK (nrs_symbol(27)) /* *post-gc-hook* */ +#define nrs_HANDLERS (nrs_symbol(28)) /* %handlers% */ +#define nrs_ALL_PACKAGES (nrs_symbol(29)) /* %all-packages% */ +#define nrs_KEYWORD_PACKAGE (nrs_symbol(30)) /* *keyword-package* */ +#define nrs_FINALIZATION_ALIST (nrs_symbol(31)) /* %finalization-alist% */ +#define nrs_FOREIGN_THREAD_CONTROL (nrs_symbol(32)) /* %foreign-thread-control */ +#define num_nilreg_symbols 33 +#define nilreg_symbols_end ((BytePtr) &(nrs_symbol(num_nilreg_symbols))) +#endif Index: /branches/new-random/lisp-kernel/lispdcmd.c =================================================================== --- /branches/new-random/lisp-kernel/lispdcmd.c (revision 13309) +++ /branches/new-random/lisp-kernel/lispdcmd.c (revision 13309) @@ -0,0 +1,47 @@ +/* + Copyright (C) 2009 Clozure Associates + Copyright (C) 1994-2001 Digitool, Inc + This file is part of Clozure CL. + + Clozure CL is licensed under the terms of the Lisp Lesser GNU Public + License , known as the LLGPL and distributed with Clozure CL as the + file "LICENSE". The LLGPL consists of a preamble and the LGPL, + which is distributed with Clozure CL as the file "LGPL". Where these + conflict, the preamble takes precedence. + + Clozure CL is referenced in the preamble as the "LIBRARY." + + The LLGPL is also available online at + http://opensource.franz.com/preamble.html +*/ + +/* + MCL-PPC dcmd utilities. +*/ + +#include "lispdcmd.h" + + + + +void +display_buffer(char *buf) +{ + fprintf(dbgout, "%s\n", buf); +} + +int +Dprintf(const char *format, ...) +{ + char buf[512]; + va_list args; + int res; + + va_start(args, format); + res = vsnprintf(buf, sizeof(buf), format, args); + if (res >= 0) { + display_buffer(buf); + } + return res; +} + Index: /branches/new-random/lisp-kernel/lispdcmd.h =================================================================== --- /branches/new-random/lisp-kernel/lispdcmd.h (revision 13309) +++ /branches/new-random/lisp-kernel/lispdcmd.h (revision 13309) @@ -0,0 +1,31 @@ +/* + Copyright (C) 2009 Clozure Associates + Copyright (C) 1994-2001 Digitool, Inc + This file is part of Clozure CL. + + Clozure CL is licensed under the terms of the Lisp Lesser GNU Public + License , known as the LLGPL and distributed with Clozure CL as the + file "LICENSE". The LLGPL consists of a preamble and the LGPL, + which is distributed with Clozure CL as the file "LGPL". Where these + conflict, the preamble takes precedence. + + Clozure CL is referenced in the preamble as the "LIBRARY." + + The LLGPL is also available online at + http://opensource.franz.com/preamble.html +*/ + +#include +#include + +#include "lisp.h" +#include "area.h" +#include "lisp-exceptions.h" +#include "lisp_globals.h" + +/* More-or-less like c printf(); */ +int Dprintf(const char *format, ...); + + +char * +print_lisp_object(LispObj); Index: /branches/new-random/lisp-kernel/lisptypes.h =================================================================== --- /branches/new-random/lisp-kernel/lisptypes.h (revision 13309) +++ /branches/new-random/lisp-kernel/lisptypes.h (revision 13309) @@ -0,0 +1,238 @@ +/* + Copyright (C) 2009 Clozure Associates + Copyright (C) 1994-2001 Digitool, Inc + This file is part of Clozure CL. + + Clozure CL is licensed under the terms of the Lisp Lesser GNU Public + License , known as the LLGPL and distributed with Clozure CL as the + file "LICENSE". The LLGPL consists of a preamble and the LGPL, + which is distributed with Clozure CL as the file "LGPL". Where these + conflict, the preamble takes precedence. + + Clozure CL is referenced in the preamble as the "LIBRARY." + + The LLGPL is also available online at + http://opensource.franz.com/preamble.html +*/ + +#ifndef __lisptypes__ +#define __lisptypes__ + +#include +#define WORD_SIZE 32 +#ifdef PPC64 +#undef WORD_SIZE +#define WORD_SIZE 64 +#endif +#ifdef X8664 +#undef WORD_SIZE +#define WORD_SIZE 64 +#endif + + +#ifdef WINDOWS +#include +typedef long long s64_t; +typedef unsigned long long u64_t; +typedef signed long s32_t; +typedef unsigned long u32_t; +typedef signed short s16_t; +typedef unsigned short u16_t; +typedef signed char s8_t; +typedef unsigned char u8_t; +#else + +#include + +#ifdef SOLARIS +/* Solaris doesn't laugh and play like the other children */ +typedef int64_t s64_t; +typedef uint64_t u64_t; +typedef int32_t s32_t; +typedef uint32_t u32_t; +typedef int16_t s16_t; +typedef uint16_t u16_t; +typedef int8_t s8_t; +typedef uint8_t u8_t; +#else +typedef int64_t s64_t; +typedef u_int64_t u64_t; +typedef int32_t s32_t; +typedef u_int32_t u32_t; +typedef int16_t s16_t; +typedef u_int16_t u16_t; +typedef int8_t s8_t; +typedef u_int8_t u8_t; +#endif +#endif + +#if WORD_SIZE == 64 +typedef u64_t LispObj; +typedef u64_t natural; +typedef s64_t signed_natural; +typedef u64_t unsigned_of_pointer_size; +#else +typedef u32_t LispObj; +typedef u32_t natural; +typedef s32_t signed_natural; +typedef u32_t unsigned_of_pointer_size; +#endif + + +#ifdef DARWIN +#include +#include +#include + +#ifdef PPC +#if MAC_OS_X_VERSION_MIN_REQUIRED <= MAC_OS_X_VERSION_10_4 +#define __ss ss +#define __es es +#define __fs fs + +#define __srr0 srr0 +#define __srr1 srr1 +#define __r0 r0 +#define __r1 r1 +#define __r3 r3 +#define __r4 r4 +#define __r5 r5 +#define __r6 r6 +#define __r13 r13 +#define __cr cr +#define __xer xer +#define __lr lr +#define __ctr ctr + +#define __dar dar +#define __dsisr dsisr +#define __exception exception + +#define __fpregs fpregs +#define __fpscr fpscr +#endif + +#if WORD_SIZE == 64 +#ifdef _STRUCT_UCONTEXT64 +typedef _STRUCT_UCONTEXT64 ExceptionInformation; +typedef _STRUCT_MCONTEXT64 *MCONTEXT_T; +#else /* _STRUCT_UCONTEXT64 */ +typedef struct ucontext64 ExceptionInformation; +typedef struct mcontext64 *MCONTEXT_T; +#endif /* _STRUCT_UCONTEXT64 */ +#define UC_MCONTEXT(UC) UC->uc_mcontext64 +#else /* WORD_SIZE */ +#ifdef _STRUCT_UCONTEXT +typedef _STRUCT_UCONTEXT ExceptionInformation; +typedef _STRUCT_MCONTEXT *MCONTEXT_T; +#else +typedef struct ucontext ExceptionInformation; +typedef struct mcontext *MCONTEXT_T; +#endif +#define UC_MCONTEXT(UC) UC->uc_mcontext +#endif /* WORD_SIZE */ + + + +#endif /* PPC */ + +#ifdef X8664 +#if MAC_OS_X_VERSION_MIN_REQUIRED <= MAC_OS_X_VERSION_10_4 +/* Broken in Mac OS 10.4u SDK */ +struct mcontext64 { + x86_exception_state64_t __es; + x86_thread_state64_t __ss; + x86_float_state64_t __fs; +}; + +typedef struct mcontext64 *MCONTEXT_T; +typedef ucontext64_t ExceptionInformation; +#define UC_MCONTEXT(UC) UC->uc_mcontext64 +#define __rax rax +#define __fpu_mxcsr fpu_mxcsr +#define __fpu_xmm0 fpu_xmm0 +#define __rsp rsp +#define __trapno trapno +#define __faultvaddr faultvaddr +#define __err err +#define __rip rip +#define __rsi rsi +#define __rdi rdi +#define __rdx rdx +#define __rcx rcx +#define __r8 r8 +#define __rflags rflags +#else /* post-10.4 */ +typedef mcontext_t MCONTEXT_T; +typedef ucontext_t ExceptionInformation; +#define UC_MCONTEXT(UC) UC->uc_mcontext +#endif +#endif + +#ifdef X8632 +/* Assume rational */ +/* Sadly, we can't make that assumption, since Apple renamed things + for Leopard. Yow! Are we standards-compliant yet ? */ +/* In the long term, we probably want to use the leopard-compliant + names (with leading __ prefixes). In the shorter term, we want + kernels compiled on Leopard to run on Tiger (and not reference + foo$UNIX2003 and similar nonsense, and that means getting the old + names (without leading __ prefixes.) Confused yet ? */ + +#if MAC_OS_X_VERSION_MIN_REQUIRED <= MAC_OS_X_VERSION_10_4 +#define __ss ss +#define __ds ds +#define __es es +#define __cs cs +#define __fs fs +#define __gs gs +#define __eax eax +#define __esp esp +#define __eip eip +#define __eflags eflags +#define __fpu_xmm0 fpu_xmm0 +#define __fpu_mxcsr fpu_mxcsr +#define __fpu_stmm0 fpu_stmm0 +#define __trapno trapno +#define __err err +#define __faultvaddr faultvaddr +#endif + +#define UC_MCONTEXT(UC) UC->uc_mcontext +typedef mcontext_t MCONTEXT_T; +typedef ucontext_t ExceptionInformation; +#endif + +#endif /* #ifdef DARWIN */ + +#ifdef LINUX +typedef struct ucontext ExceptionInformation; +#endif + +#ifdef FREEBSD +typedef struct __ucontext ExceptionInformation; +#endif + +#ifdef SOLARIS +typedef struct ucontext ExceptionInformation; +#endif + +#ifdef WINDOWS +typedef CONTEXT ExceptionInformation; +#endif + +typedef u32_t lisp_char_code; + +typedef int OSStatus, OSErr; +#define noErr ((OSErr) 0) +typedef int Boolean; +typedef void *LogicalAddress; +typedef char *Ptr, *BytePtr, *StringPtr; +typedef unsigned int UInt32; + + + +#define true 1 +#define false 0 + +#endif /*__lisptypes__ */ Index: /branches/new-random/lisp-kernel/m4macros.m4 =================================================================== --- /branches/new-random/lisp-kernel/m4macros.m4 (revision 13309) +++ /branches/new-random/lisp-kernel/m4macros.m4 (revision 13309) @@ -0,0 +1,354 @@ +changequote([,]) +changecom([/* ],[*/]) + + + +/* Copyright (C) 1994-2001 Digitool, Inc */ +/* This file is part of Clozure CL. */ + +/* Clozure CL is licensed under the terms of the Lisp Lesser GNU Public */ +/* License , known as the LLGPL and distributed with Clozure CL as the */ +/* file "LICENSE". The LLGPL consists of a preamble and the LGPL, */ +/* which is distributed with Clozure CL as the file "LGPL". Where these */ +/* conflict, the preamble takes precedence. */ + +/* Clozure CL is referenced in the preamble as the "LIBRARY." */ + +/* The LLGPL is also available online at */ +/* http://opensource.franz.com/preamble.html */ + + + +/* BSD debugging information (line numbers, etc) is a little different */ +/* from ELF/SVr4 debugging information. There are probably lots more */ +/* differences, but this helps us to distinguish between what LinuxPPC */ +/* (ELF/SVr4) wants and what Darwin(BSD) wants. */ + + +define([BSDstabs],[1]) +define([ELFstabs],[2]) +define([COFFstabs],[3]) +undefine([EABI]) +undefine([POWEROPENABI]) +undefine([rTOC]) + + +ifdef([DARWIN],[define([SYSstabs],[BSDstabs]) + define([DarwinAssembler],[]) + define([CNamesNeedUnderscores],[]) + define([LocalLabelPrefix],[L]) + define([StartTextLabel],[Ltext0]) + define([EndTextLabel],[Letext]) + ifdef([PPC],[ + define([POWEROPENABI],[])]) + ifdef([X86],[ + define([SYSCALL_SETS_CARRY_ON_ERROR],[]) + define([SSE2_MATH_LIB],[])]) +]) + +ifdef([LINUX],[define([SYSstabs],[ELFstabs]) + define([HaveWeakSymbols],[]) + define([LocalLabelPrefix],[.L]) + define([StartTextLabel],[.Ltext0]) + define([EndTextLabel],[.Letext]) + ifdef([PPC64],[ + define([POWEROPENABI],[]) + define([rTOC],[r2])], [ + define([EABI],[])])]) + +ifdef([FREEBSD],[define([SYSstabs],[ELFstabs]) + define([HaveWeakSymbols],[]) + define([LocalLabelPrefix],[.L]) + define([StartTextLabel],[.Ltext0]) + define([EndTextLabel],[.Letext])] + ifdef([X86],[ + define([SYSCALL_SETS_CARRY_ON_ERROR],[])]) +) + +ifdef([SOLARIS],[define([SYSstabs],[ELFstabs]) + define([HaveWeakSymbols],[]) + define([LocalLabelPrefix],[.L]) + define([StartTextLabel],[.Ltext0]) + define([EndTextLabel],[.Letext])]) + +ifdef([WINDOWS],[define([SYSstabs],[COFFstabs]) + define([CNamesNeedUnderscores],[]) + define([LocalLabelPrefix],[L]) + define([StartTextLabel],[Ltext0]) + define([EndTextLabel],[Letext])]) + + +/* Names exported to (or imported from) C may need leading underscores. */ +/* Still. After all these years. Why ? */ + +define([C],[ifdef([CNamesNeedUnderscores],[[_]$1],[$1])]) + +define([_linecounter_],0) + +define([_emit_BSD_source_line_stab],[ +ifdef([X86],[ +# __line__ "__file__" 1],[ + .stabd 68,0,$1 +])]) + + +/* We don't really do "weak importing" of symbols from a separate */ +/* subprims library anymore; if we ever do and the OS supports it, */ +/* here's how to say that we want it ... */ + +define([WEAK],[ifdef([HaveWeakSymbols],[ + .weak $1 +],[ + .globl $1 +])]) + +define([_emit_ELF_source_line_stab],[ + define([_linecounter_],incr(_linecounter_)) + .stabn 68,0,$1,[.LM]_linecounter_[-]__func_name +[.LM]_linecounter_: +]) + +define([_emit_COFF_source_line_stab],[ + _emit_ELF_source_line_stab($1) +]) + + +define([emit_source_line_stab],[ + ifelse(eval(SYSstabs), + eval(BSDstabs), + [_emit_BSD_source_line_stab($1)], + eval(SYSstabs), + eval(ELFstabs), + [_emit_ELF_source_line_stab($1)], + [_emit_COFF_source_line_stab($1)])]) + + + + + + +/* Assemble a reference to the high half of a 32-bit constant, */ +/* possibly adjusted for sign-extension of thw low half. */ + + +define([HA],[ifdef([DARWIN],[ha16($1)],[$1@ha])]) + + +/* Likewise for the low half, and for the high half without */ +/* concern for sign-extension of the low half. */ + +define([LO],[ifdef([DARWIN],[lo16($1)],[$1@l])]) +define([HI],[ifdef([DARWIN],[hi16($1)],[$1@hi])]) + +/* Note that m4 macros that could be expanded in the .text segment */ +/* need to advertise the current line number after they have finished */ +/* expanding. That shouldn't be too onerous, if only because there */ +/* should not be too many of them. */ + + +define([N_FUN],36) +define([N_SO],100) + +/* I wish that there was a less-dumb way of doing this. */ + +define([pwd0],esyscmd([/bin/pwd])) +define([__pwd__],substr(pwd0,0,decr(len(pwd0)))[/]) + +/* _beginfile() -- gets line/file in synch, generates N_SO for file, */ +/* starts .text section */ + + +define([_beginfile],[ + .stabs "__pwd__",N_SO,0,0,StartTextLabel() + .stabs "__file__",N_SO,0,0,StartTextLabel() +ifdef([PPC64],[ +ifdef([DARWIN],[ + .machine ppc64 +])]) + .text +StartTextLabel(): +# __line__ "__file__" +]) + +define([_endfile],[ + .stabs "",N_SO,0,0,EndTextLabel() +EndTextLabel(): +# __line__ +]) + +define([_startfn],[define([__func_name],$1) +# __line__ + ifelse(eval(SYSstabs),eval(ELFstabs),[ + .type $1,@function +]) + +$1: +ifdef([WINDOWS],[ + .def $1; .scl 2; .type 32; .endef +],[ + .stabd 68,0,__line__ +]) + .stabs "$1:F1",36,0,__line__,$1 + .set func_start,$1 +# __line__ "__file__" 1 ]) + + + +define([_exportfn],[ + .globl $1 + _startfn($1) +ifdef([PPC64],[ +ifdef([LINUX],[ + .global [.]$1 +[.]$1: +])]) +# __line__ +]) + + +define([_endfn],[ +LocalLabelPrefix[]__func_name[999]: +ifdef([WINDOWS],[ +],[ + .stabs "",36,0,0,LocalLabelPrefix[]__func_name[999]-__func_name + .line __line__ + ifelse(eval(SYSstabs),eval(ELFstabs),[ + .size __func_name,LocalLabelPrefix[]__func_name[999]-__func_name +]) +]) + undefine([__func_name]) +]) + + +/* _struct(name,start_offset) */ +/* This just generates a bunch of assembler equates; m4 */ +/* doesn't remember much of it .. */ + +define([_struct], [define([__struct_name],$1) + define([_struct_org_name], _$1_org) + define([_struct_base_name], _$1_base) + .set _struct_org_name,$2 + .set _struct_base_name,_struct_org_name + ifelse($3,[],[ + undefine([_struct_fixed_size_name]) + ],[ + define([_struct_fixed_size_name], _$1_fixed_size) + .set _struct_fixed_size_name,$3 + ]) +]) + +define([_struct_pad],[ + .set _struct_org_name,_struct_org_name + $1 +]) + +define([_struct_label],[ + .set __struct_name[.]$1, _struct_org_name +]) + +/* _field(name,size) */ +define([_field],[_struct_label($1) _struct_pad($2)]) + +define([_halfword], [_field($1, 2)]) +define([_word], [_field($1, 4)]) +define([_dword],[_field($1, 8)]) +define([_node], [_field($1, node_size)]) + +define([_ends],[ifdef([_struct_fixed_size_name],[ + .set __struct_name[.size],_struct_fixed_size_name + ],[ + .set __struct_name[.size], _struct_org_name-_struct_base_name + ]) +]) + + +/* Lisp fixed-size objects always have a 1-word header */ +/* and are always accessed from a "fulltag_misc"-tagged pointer. */ +/* We also want to define STRUCT_NAME.element_count for each */ +/* such object. */ + + +define([_structf],[ + _struct($1,ifelse($2,[],-misc_bias,$2)) + _node(header) +]) + +define([_endstructf],[ + .set __struct_name.[element_count],((_struct_org_name-node_size)-_struct_base_name)/node_size + _ends +]) + + +define([__],[emit_source_line_stab(__line__) + $@ + ]) + +define([__local_label_counter__],0) +define([__macro_label_counter__],0) + +define([new_local_labels], + [define([__local_label_counter__],incr(__local_label_counter__))]) + +define([new_macro_labels], + [define([__macro_label_counter__],incr(__macro_label_counter__))]) + +define([_local_label],[LocalLabelPrefix()[]$1]) + +define([local_label],[_local_label($1[]__local_label_counter__)]) + +define([macro_label],[_local_label($1[]__macro_label_counter__)]) + + +/* The Darwin assembler doesn't seem to support .ifdef/.ifndef, but */ +/* does understand .if. */ +/* Note that using M4's own ifdef is certainly possible, but it's */ +/* hard to generate source line information when doing so. */ + + +define([__ifdef],[ifdef([$1],[.if 1],[.if 0])]) +define([__ifndef],[ifdef([$1],[.if 0],[.if 1])]) +define([__else],[.else]) +define([__endif],[.endif]) +define([__if],[.if $1]) + +define([equate_if_defined],[ifdef($1,[ +[$1] = 1 +],[ +[$1] = 0 +])]) + +equate_if_defined([DARWIN]) +equate_if_defined([LINUX]) +equate_if_defined([FREEBSD]) +equate_if_defined([SOLARIS]) +equate_if_defined([WIN_64]) +equate_if_defined([PPC64]) +equate_if_defined([X8664]) +equate_if_defined([WIN_32]) +equate_if_defined([WINDOWS]) + +equate_if_defined([HAVE_TLS]) +/* DARWIN_GS_HACK is hopefully short-lived */ +equate_if_defined([DARWIN_GS_HACK]) + +equate_if_defined([TCR_IN_GPR]) + +/* Well, so much for that. Maybe this will go away soon ? */ +equate_if_defined([WIN32_ES_HACK]) +equate_if_defined([SYSCALL_SETS_CARRY_ON_ERROR]) + + + +/* We use (more-or-less) a PowerOpen C frame, except on LinuxPPC32 */ + +define([USE_POWEROPEN_C_FRAME],[]) +undefine([USE_EABI_C_FRAME]) + +ifdef([LINUX],[ +ifdef([PPC64],[],[ +define([USE_EABI_C_FRAME],[]) +undefine([USE_POWEROPEN_C_FRAME]) +])]) + + + + Index: /branches/new-random/lisp-kernel/macros.h =================================================================== --- /branches/new-random/lisp-kernel/macros.h (revision 13309) +++ /branches/new-random/lisp-kernel/macros.h (revision 13309) @@ -0,0 +1,116 @@ +/* + Copyright (C) 2009 Clozure Associates + Copyright (C) 1994-2001 Digitool, Inc + This file is part of Clozure CL. + + Clozure CL is licensed under the terms of the Lisp Lesser GNU Public + License , known as the LLGPL and distributed with Clozure CL as the + file "LICENSE". The LLGPL consists of a preamble and the LGPL, + which is distributed with Clozure CL as the file "LGPL". Where these + conflict, the preamble takes precedence. + + Clozure CL is referenced in the preamble as the "LIBRARY." + + The LLGPL is also available online at + http://opensource.franz.com/preamble.html +*/ + +/* Totally different content than 'macros.s' */ + + + +#ifndef __macros__ +#define __macros__ + +#define ptr_to_lispobj(p) ((LispObj)(p)) +#define ptr_from_lispobj(o) ((LispObj*)(o)) +#define lisp_reg_p(reg) ((reg) >= fn) + +#define fulltag_of(o) ((o) & fulltagmask) +#define tag_of(o) ((o) & tagmask) +#define untag(o) ((o) & ~fulltagmask) +#define node_aligned(o) ((o) & ~tagmask) +#define indirect_node(o) (*(LispObj *)(node_aligned(o))) + +#define deref(o,n) ((((LispObj*) (untag((LispObj)o))))[(n)]) +#define header_of(o) deref(o,0) + +#define header_subtag(h) ((h) & subtagmask) +#define header_element_count(h) ((h) >> num_subtag_bits) +#define make_header(subtag,element_count) ((subtag)|((element_count)<>fixnum_shift)) +#define box_fixnum(x) ((LispObj)((signed_natural)(x)<car) +#define cdr(x) (((cons *)ptr_from_lispobj(untag(x)))->cdr) + +/* "sym" is an untagged pointer to a symbol */ +#define BOUNDP(sym) ((((lispsymbol *)(sym))->vcell) != undefined) + +/* Likewise. */ +#define FBOUNDP(sym) ((((lispsymbol *)(sym))->fcell) != nrs_UDF.vcell) + +#ifdef PPC +#ifdef PPC64 +#define nodeheader_tag_p(tag) (((tag) & lowtag_mask) == lowtag_nodeheader) +#define immheader_tag_p(tag) (((tag) & lowtag_mask) == lowtag_immheader) +#else +#define nodeheader_tag_p(tag) (tag == fulltag_nodeheader) +#define immheader_tag_p(tag) (tag == fulltag_immheader) +#endif +#endif + +#ifdef X86 +#ifdef X8664 +#define NODEHEADER_MASK ((1<<(fulltag_nodeheader_0)) | \ + (1<<(fulltag_nodeheader_1))) +#define nodeheader_tag_p(tag) ((1<<(tag)) & NODEHEADER_MASK) + +#define IMMHEADER_MASK ((1<tlb_pointer))[INTERRUPT_LEVEL_BINDING_INDEX]) +#endif + +#ifdef WINDOWS +#define LSEEK(fd,offset,how) _lseeki64(fd,offset,how) +#else +#define LSEEK(fd,offset,how) lseek(fd,offset,how) +#endif + +/* We can't easily and unconditionally use format strings like "0x%lx" + to print lisp objects: the "l" might not match the word size, and + neither would (necessarily) something like "0x%llx". We can at + least exploit the fact that on all current platforms, "ll" ("long long") + is the size of a 64-bit lisp object and "l" ("long") is the size of + a 32-bit lisp object. */ + +#if (WORD_SIZE == 64) +#define LISP "%llx" +#define ZLISP "%016llx" +#define DECIMAL "%lld" +#else +#define LISP "%lx" +#define ZLISP "%08x" +#define DECIMAL "%ld" +#endif Index: /branches/new-random/lisp-kernel/memory.c =================================================================== --- /branches/new-random/lisp-kernel/memory.c (revision 13309) +++ /branches/new-random/lisp-kernel/memory.c (revision 13309) @@ -0,0 +1,980 @@ +/* + Copyright (C) 2009 Clozure Associates + Copyright (C) 1994-2001 Digitool, Inc + This file is part of Clozure CL. + + Clozure CL is licensed under the terms of the Lisp Lesser GNU Public + License , known as the LLGPL and distributed with Clozure CL as the + file "LICENSE". The LLGPL consists of a preamble and the LGPL, + which is distributed with Clozure CL as the file "LGPL". Where these + conflict, the preamble takes precedence. + + Clozure CL is referenced in the preamble as the "LIBRARY." + + The LLGPL is also available online at + http://opensource.franz.com/preamble.html +*/ + +#include "lisp.h" +#include "lisp-exceptions.h" +#include "lisp_globals.h" +#include "Threads.h" +#include +#include +#include +#include +#include +#include +#include +#include +#include +#ifdef LINUX +#include +#include +#include +#endif + +#ifndef WINDOWS +#include +#endif + +#define DEBUG_MEMORY 0 + +void +allocation_failure(Boolean pointerp, natural size) +{ + char buf[64]; + sprintf(buf, "Can't allocate %s of size " DECIMAL " bytes.", pointerp ? "pointer" : "handle", size); + Fatal(": Kernel memory allocation failure. ", buf); +} + +void +fatal_oserr(StringPtr param, OSErr err) +{ + char buf[64]; + sprintf(buf," - operating system error %d.", err); + Fatal(param, buf); +} + + +Ptr +allocate(natural size) +{ + return (Ptr) malloc(size); +} + +void +deallocate(Ptr p) +{ + free((void *)p); +} + +Ptr +zalloc(natural size) +{ + Ptr p = allocate(size); + if (p != NULL) { + memset(p, 0, size); + } + return p; +} + +#ifdef DARWIN +#if WORD_SIZE == 64 +#define vm_region vm_region_64 +#endif + +/* + Check to see if the specified address is unmapped by trying to get + information about the mapped address at or beyond the target. If + the difference between the target address and the next mapped address + is >= len, we can safely mmap len bytes at addr. +*/ +Boolean +address_unmapped_p(char *addr, natural len) +{ + vm_address_t vm_addr = (vm_address_t)addr; + vm_size_t vm_size; +#if WORD_SIZE == 64 + vm_region_basic_info_data_64_t vm_info; +#else + vm_region_basic_info_data_t vm_info; +#endif +#if WORD_SIZE == 64 + mach_msg_type_number_t vm_info_size = VM_REGION_BASIC_INFO_COUNT_64; +#else + mach_msg_type_number_t vm_info_size = VM_REGION_BASIC_INFO_COUNT; +#endif + mach_port_t vm_object_name = (mach_port_t) 0; + kern_return_t kret; + + kret = vm_region(mach_task_self(), + &vm_addr, + &vm_size, +#if WORD_SIZE == 64 + VM_REGION_BASIC_INFO_64, +#else + VM_REGION_BASIC_INFO, +#endif + (vm_region_info_t)&vm_info, + &vm_info_size, + &vm_object_name); + if (kret != KERN_SUCCESS) { + return false; + } + + return vm_addr >= (vm_address_t)(addr+len); +} +#endif + + + /* + Through trial and error, we've found that IMAGE_BASE_ADDRESS is + likely to reside near the beginning of an unmapped block of memory + that's at least 1GB in size. We'd like to load the heap image's + sections relative to IMAGE_BASE_ADDRESS; if we're able to do so, + that'd allow us to file-map those sections (and would enable us to + avoid having to relocate references in the data sections.) + + In short, we'd like to reserve 1GB starting at IMAGE_BASE_ADDRESS + by creating an anonymous mapping with mmap(). + + If we try to insist that mmap() map a 1GB block at + IMAGE_BASE_ADDRESS exactly (by specifying the MAP_FIXED flag), + mmap() will gleefully clobber any mapped memory that's already + there. (That region's empty at this writing, but some future + version of the OS might decide to put something there.) + + If we don't specify MAP_FIXED, mmap() is free to treat the address + we give it as a hint; Linux seems to accept the hint if doing so + wouldn't cause a problem. Naturally, that behavior's too useful + for Darwin (or perhaps too inconvenient for it): it'll often + return another address, even if the hint would have worked fine. + + We call address_unmapped_p() to ask Mach whether using MAP_FIXED + would conflict with anything. Until we discover a need to do + otherwise, we'll assume that if Linux's mmap() fails to take the + hint, it's because of a legitimate conflict. + + If Linux starts ignoring hints, we can parse /proc//maps + to implement an address_unmapped_p() for Linux. + */ + +LogicalAddress +ReserveMemoryForHeap(LogicalAddress want, natural totalsize) +{ + LogicalAddress start; + Boolean fixed_map_ok = false; +#ifdef DARWIN + fixed_map_ok = address_unmapped_p(want,totalsize); +#endif +#ifdef SOLARIS + fixed_map_ok = true; +#endif + raise_limit(); +#ifdef WINDOWS + start = VirtualAlloc((void *)want, + totalsize + heap_segment_size, + MEM_RESERVE, + PAGE_NOACCESS); + if (!start) { +#if DEBUG_MEMORY + fprintf(dbgout, "Can't get desired heap address at 0x" LISP "\n", want); +#endif + start = VirtualAlloc(0, + totalsize + heap_segment_size, + MEM_RESERVE, + PAGE_NOACCESS); + if (!start) { + return NULL; + } + } +#else + start = mmap((void *)want, + totalsize + heap_segment_size, + PROT_NONE, + MAP_PRIVATE | MAP_ANON | (fixed_map_ok ? MAP_FIXED : 0) | MAP_NORESERVE, + -1, + 0); + if (start == MAP_FAILED) { + return NULL; + } + + if (start != want) { + munmap(start, totalsize+heap_segment_size); + start = (void *)((((natural)start)+heap_segment_size-1) & ~(heap_segment_size-1)); + if(mmap(start, totalsize, PROT_NONE, MAP_PRIVATE | MAP_ANON | MAP_FIXED | MAP_NORESERVE, -1, 0) != start) { + return NULL; + } + } + mprotect(start, totalsize, PROT_NONE); +#endif +#if DEBUG_MEMORY + fprintf(dbgout, "Reserving heap at 0x" LISP ", size 0x" LISP "\n", start, totalsize); +#endif + return start; +} + +int +CommitMemory (LogicalAddress start, natural len) +{ + LogicalAddress rc; +#if DEBUG_MEMORY + fprintf(dbgout, "Committing memory at 0x" LISP ", size 0x" LISP "\n", start, len); +#endif +#ifdef WINDOWS + if ((start < ((LogicalAddress)nil_value)) && + (((LogicalAddress)nil_value) < (start+len))) { + /* nil area is in the executable on Windows; ensure range is + read-write */ + DWORD as_if_i_care; + if (!VirtualProtect(start,len,PAGE_EXECUTE_READWRITE,&as_if_i_care)) { + return false; + } + return true; + } + rc = VirtualAlloc(start, len, MEM_COMMIT, PAGE_EXECUTE_READWRITE); + if (!rc) { + wperror("CommitMemory VirtualAlloc"); + return false; + } + return true; +#else + int i, err; + void *addr; + + for (i = 0; i < 3; i++) { + addr = mmap(start, len, MEMPROTECT_RWX, MAP_PRIVATE|MAP_ANON|MAP_FIXED, -1, 0); + if (addr == start) { + return true; + } else { + mmap(addr, len, MEMPROTECT_NONE, MAP_PRIVATE|MAP_ANON|MAP_FIXED, -1, 0); + } + } + return false; +#endif +} + +void +UnCommitMemory (LogicalAddress start, natural len) { +#if DEBUG_MEMORY + fprintf(dbgout, "Uncommitting memory at 0x" LISP ", size 0x" LISP "\n", start, len); +#endif +#ifdef WINDOWS + int rc = VirtualFree(start, len, MEM_DECOMMIT); + if (!rc) { + wperror("UnCommitMemory VirtualFree"); + Fatal("mmap error", ""); + return; + } +#else + if (len) { + madvise(start, len, MADV_DONTNEED); + if (mmap(start, len, MEMPROTECT_NONE, MAP_PRIVATE|MAP_ANON|MAP_FIXED, -1, 0) + != start) { + int err = errno; + Fatal("mmap error", ""); + fprintf(dbgout, "errno = %d", err); + } + } +#endif +} + + +LogicalAddress +MapMemory(LogicalAddress addr, natural nbytes, int protection) +{ +#if DEBUG_MEMORY + fprintf(dbgout, "Mapping memory at 0x" LISP ", size 0x" LISP "\n", addr, nbytes); +#endif +#ifdef WINDOWS + return VirtualAlloc(addr, nbytes, MEM_RESERVE|MEM_COMMIT, MEMPROTECT_RWX); +#else + { + int flags = MAP_PRIVATE|MAP_ANON; + + if (addr > 0) flags |= MAP_FIXED; + return mmap(addr, nbytes, protection, flags, -1, 0); + } +#endif +} + +LogicalAddress +MapMemoryForStack(natural nbytes) +{ +#if DEBUG_MEMORY + fprintf(dbgout, "Mapping stack of size 0x" LISP "\n", nbytes); +#endif +#ifdef WINDOWS + return VirtualAlloc(0, nbytes, MEM_RESERVE|MEM_COMMIT, MEMPROTECT_RWX); +#else + return mmap(NULL, nbytes, MEMPROTECT_RWX, MAP_PRIVATE|MAP_ANON|MAP_GROWSDOWN, -1, 0); +#endif +} + +int +UnMapMemory(LogicalAddress addr, natural nbytes) +{ +#if DEBUG_MEMORY + fprintf(dbgout, "Unmapping memory at 0x" LISP ", size 0x" LISP "\n", addr, nbytes); +#endif +#ifdef WINDOWS + /* Can't MEM_RELEASE here because we only want to free a chunk */ + return VirtualFree(addr, nbytes, MEM_DECOMMIT); +#else + return munmap(addr, nbytes); +#endif +} + +int +ProtectMemory(LogicalAddress addr, natural nbytes) +{ +#if DEBUG_MEMORY + fprintf(dbgout, "Protecting memory at 0x" LISP ", size 0x" LISP "\n", addr, nbytes); +#endif +#ifdef WINDOWS + DWORD oldProtect; + BOOL status = VirtualProtect(addr, nbytes, MEMPROTECT_RX, &oldProtect); + + if(!status) { + wperror("ProtectMemory VirtualProtect"); + Bug(NULL, "couldn't protect " DECIMAL " bytes at 0x" LISP ", errno = %d", nbytes, addr, status); + } + return status; +#else + int status = mprotect(addr, nbytes, PROT_READ | PROT_EXEC); + + if (status) { + status = errno; + Bug(NULL, "couldn't protect " DECIMAL " bytes at " LISP ", errno = %d", nbytes, addr, status); + } + return status; +#endif +} + +int +UnProtectMemory(LogicalAddress addr, natural nbytes) +{ +#if DEBUG_MEMORY + fprintf(dbgout, "Unprotecting memory at 0x" LISP ", size 0x" LISP "\n", addr, nbytes); +#endif +#ifdef WINDOWS + DWORD oldProtect; + return VirtualProtect(addr, nbytes, MEMPROTECT_RWX, &oldProtect); +#else + return mprotect(addr, nbytes, PROT_READ|PROT_WRITE|PROT_EXEC); +#endif +} + +int +MapFile(LogicalAddress addr, natural pos, natural nbytes, int permissions, int fd) +{ +#ifdef WINDOWS +#if 0 + /* Lots of hair in here: mostly alignment issues, but also address space reservation */ + HANDLE hFile, hFileMapping; + LPVOID rc; + DWORD desiredAccess; + + if (permissions == MEMPROTECT_RWX) { + permissions |= PAGE_WRITECOPY; + desiredAccess = FILE_MAP_READ|FILE_MAP_WRITE|FILE_MAP_COPY|FILE_MAP_EXECUTE; + } else { + desiredAccess = FILE_MAP_READ|FILE_MAP_COPY|FILE_MAP_EXECUTE; + } + + hFile = _get_osfhandle(fd); + hFileMapping = CreateFileMapping(hFile, NULL, permissions, + (nbytes >> 32), (nbytes & 0xffffffff), NULL); + + if (!hFileMapping) { + wperror("CreateFileMapping"); + return false; + } + + rc = MapViewOfFileEx(hFileMapping, + desiredAccess, + (pos >> 32), + (pos & 0xffffffff), + nbytes, + addr); +#else + size_t count, total = 0; + size_t opos; + + opos = LSEEK(fd, 0, SEEK_CUR); + CommitMemory(addr, nbytes); + LSEEK(fd, pos, SEEK_SET); + + while (total < nbytes) { + count = read(fd, addr + total, nbytes - total); + total += count; + // fprintf(dbgout, "read " DECIMAL " bytes, for a total of " DECIMAL " out of " DECIMAL " so far\n", count, total, nbytes); + if (!(count > 0)) + return false; + } + + LSEEK(fd, opos, SEEK_SET); + + return true; +#endif +#else + return mmap(addr, nbytes, permissions, MAP_PRIVATE|MAP_FIXED, fd, pos) != MAP_FAILED; +#endif +} + +void +unprotect_area(protected_area_ptr p) +{ + BytePtr start = p->start; + natural nprot = p->nprot; + + if (nprot) { + UnProtectMemory(start, nprot); + p->nprot = 0; + } +} + +protected_area_ptr +new_protected_area(BytePtr start, BytePtr end, lisp_protection_kind reason, natural protsize, Boolean now) +{ + protected_area_ptr p = (protected_area_ptr) allocate(sizeof(protected_area)); + + if (p == NULL) return NULL; + p->protsize = protsize; + p->nprot = 0; + p->start = start; + p->end = end; + p->why = reason; + p->next = AllProtectedAreas; + + AllProtectedAreas = p; + if (now) { + protect_area(p); + } + + return p; +} + +/* + Un-protect the first nbytes bytes in specified area. + Note that this may cause the area to be empty. +*/ +void +unprotect_area_prefix(protected_area_ptr area, size_t delta) +{ + unprotect_area(area); + area->start += delta; + if ((area->start + area->protsize) <= area->end) { + protect_area(area); + } +} + + +/* + Extend the protected area, causing the preceding nbytes bytes + to be included and protected. +*/ +void +protect_area_prefix(protected_area_ptr area, size_t delta) +{ + unprotect_area(area); + area->start -= delta; + protect_area(area); +} + +protected_area_ptr +AllProtectedAreas = NULL; + + +/* + This does a linear search. Areas aren't created all that often; + if there get to be very many of them, some sort of tree search + might be justified. +*/ + +protected_area_ptr +find_protected_area(BytePtr addr) +{ + protected_area* p; + + for(p = AllProtectedAreas; p; p=p->next) { + if ((p->start <= addr) && (p->end > addr)) { + return p; + } + } + return NULL; +} + + +void +zero_memory_range(BytePtr start, BytePtr end) +{ +#ifdef WINDOWS + ZeroMemory(start,end-start); +#else + bzero(start,(size_t)(end-start)); +#endif +} + + + + +/* + Grow or shrink the dynamic area. Or maybe not. + Whether or not the end of (mapped space in) the heap changes, + ensure that everything between the freeptr and the heap end + is mapped and read/write. (It'll incidentally be zeroed.) +*/ +Boolean +resize_dynamic_heap(BytePtr newfree, + natural free_space_size) +{ + extern int page_size; + area *a = active_dynamic_area; + BytePtr newlimit, protptr, zptr; + int psize = page_size; + if (free_space_size) { + BytePtr lowptr = a->active; + newlimit = lowptr + align_to_power_of_2(newfree-lowptr+free_space_size, + log2_heap_segment_size); + if (newlimit > a->high) { + return grow_dynamic_area(newlimit-a->high); + } else if ((lowptr + free_space_size) < a->high) { + shrink_dynamic_area(a->high-newlimit); + return true; + } + } +} + +void +protect_area(protected_area_ptr p) +{ + BytePtr start = p->start; + natural n = p->protsize; + + if (n && ! p->nprot) { + ProtectMemory(start, n); + p->nprot = n; + } +} + + +void +zero_page(BytePtr start) +{ + extern int page_size; +#ifdef PPC + extern void zero_cache_lines(BytePtr, size_t, size_t); + zero_cache_lines(start, (page_size/cache_block_size), cache_block_size); +#else + memset(start, 0, page_size); +#endif +} + +/* area management */ + + +area * +new_area(BytePtr lowaddr, BytePtr highaddr, area_code code) +{ + area *a = (area *) (zalloc(sizeof(area))); + if (a) { + natural ndnodes = area_dnode(highaddr, lowaddr); + a->low = lowaddr; + a->high = highaddr; + a->active = (code == AREA_DYNAMIC) ? lowaddr : highaddr; + a->code = code; + a->ndnodes = ndnodes; + /* Caller must allocate markbits when allocating heap ! */ + + } + return a; +} + +static area * +add_area_before(area *new_area, area *before) +{ + area *before_before = before->pred; + + new_area->pred = before_before; + new_area->succ = before; + before_before->succ = new_area; + before->pred = new_area; + return new_area; +} + +/* + The active dynamic area comes first. + Static areas follow dynamic areas. + Stack areas follow static areas. + Readonly areas come last. +*/ + +/* + If we already own the area_lock (or during iniitalization), it's safe + to add an area. +*/ + + +void +add_area_holding_area_lock(area *new_area) +{ + area *that = all_areas; + int + thiscode = (int)(new_area->code), + thatcode; + + /* Cdr down the linked list */ + do { + that = that->succ; + thatcode = (int)(that->code); + } while (thiscode < thatcode); + add_area_before(new_area, that); +} + +/* + In general, we need to own the area lock before adding an area. +*/ +void +add_area(area *new_area, TCR *tcr) +{ + LOCK(lisp_global(TCR_AREA_LOCK),tcr); + add_area_holding_area_lock(new_area); + LOCK(lisp_global(TCR_AREA_LOCK),tcr); +} + +/* + Search areas "forward" from the header's successor, until + an area containing ADDR is found or an area with code < MINCODE + is encountered. + This walks the area list visiting heaps (dynamic, then static) + first, then stacks. + +*/ +static area * +find_area_forward(BytePtr addr, area_code mincode) +{ + area *p, *header = all_areas; + + for (p = header->succ; p != header; p = p->succ) { + area_code pcode = p->code; + if (pcode < mincode) { + return NULL; + } + if (pcode >= AREA_READONLY) { + if ((addr >= p->low) && + (addr < p->active)) { + return p; + } + } else { + if ((addr >= p->active) && + (addr < p->high)) { + return p; + } + } + } + return NULL; +} + +static area * +find_area_backward(BytePtr addr, area_code maxcode) +{ + area *p, *header = all_areas; + + for (p = header->pred; p != header; p = p->pred) { + area_code pcode = p->code; + + if (pcode > maxcode) { + return NULL; + } + if (pcode >= AREA_READONLY) { + if ((addr >= p->low) && + (addr < p->active)) { + return p; + } + } else { + if ((addr >= p->active) && + (addr < p->high)) { + return p; + } + } + } + return NULL; +} + +area * +area_containing(BytePtr addr) +{ + return find_area_forward(addr, AREA_VOID); +} + +area * +heap_area_containing(BytePtr addr) +{ + return find_area_forward(addr, AREA_READONLY); +} + +area * +stack_area_containing(BytePtr addr) +{ + return find_area_backward(addr, AREA_TSTACK); +} + +/* + Make everything "younger" than the start of the target area + belong to that area; all younger areas will become empty, and + the dynamic area will have to lose some of its markbits (they + get zeroed and become part of the tenured area's refbits.) + + The active dynamic area must have been "normalized" (e.g., its + active pointer must match the free pointer) before this is called. + + If the target area is 'tenured_area' (the oldest ephemeral generation), + zero its refbits and update YOUNGEST_EPHEMERAL. + +*/ + +void +tenure_to_area(area *target) +{ + area *a = active_dynamic_area, *child; + BytePtr + curfree = a->active, + target_low = target->low, + tenured_low = tenured_area->low; + natural + dynamic_dnodes = area_dnode(curfree, a->low), + new_tenured_dnodes = area_dnode(curfree, tenured_area->low); + bitvector + refbits = tenured_area->refbits, + markbits = a->markbits, + new_markbits; + + target->high = target->active = curfree; + target->ndnodes = area_dnode(curfree, target_low); + + for (child = target->younger; child != a; child = child->younger) { + child->high = child->low = child->active = curfree; + child->ndnodes = 0; + } + + a->low = curfree; + a->ndnodes = area_dnode(a->high, curfree); + + new_markbits = refbits + ((new_tenured_dnodes + (nbits_in_word-1)) >> bitmap_shift); + + if (target == tenured_area) { + zero_bits(refbits, new_tenured_dnodes); + lisp_global(OLDEST_EPHEMERAL) = ptr_to_lispobj(curfree); + } else { + /* Need more (zeroed) refbits & fewer markbits */ + zero_bits(markbits, ((new_markbits-markbits)<markbits = new_markbits; + lisp_global(OLDSPACE_DNODE_COUNT) = area_dnode(curfree, lisp_global(REF_BASE)); +} + + + +/* + Make everything younger than the oldest byte in 'from' belong to + the youngest generation. If 'from' is 'tenured_area', this means + that nothing's ephemeral any more (and OLDEST_EPHEMERAL can be set + to 0 to indicate this.) + + Some tenured_area refbits become dynamic area markbits in the process; + it's not necessary to zero them, since the GC will do that. +*/ + +void +untenure_from_area(area *from) +{ + if (lisp_global(OLDEST_EPHEMERAL) != 0) { + area *a = active_dynamic_area, *child; + BytePtr curlow = from->low; + natural new_tenured_dnodes = area_dnode(curlow, tenured_area->low); + + for (child = from; child != a; child = child->younger) { + child->low = child->active = child->high = curlow; + child->ndnodes = 0; + } + + a->low = curlow; + a->ndnodes = area_dnode(a->high, curlow); + + a->markbits = (tenured_area->refbits) + ((new_tenured_dnodes+(nbits_in_word-1))>>bitmap_shift); + if (from == tenured_area) { + /* Everything's in the dynamic area */ + lisp_global(OLDEST_EPHEMERAL) = 0; + lisp_global(OLDSPACE_DNODE_COUNT) = area_dnode(managed_static_area->active,managed_static_area->low); + + } + } +} + + +Boolean +egc_control(Boolean activate, BytePtr curfree) +{ + area *a = active_dynamic_area; + Boolean egc_is_active = (a->older != NULL); + + if (activate != egc_is_active) { + if (curfree != NULL) { + a->active = curfree; + } + if (activate) { + a->older = g1_area; + tenure_to_area(tenured_area); + egc_is_active = true; + } else { + untenure_from_area(tenured_area); + a->older = NULL; + egc_is_active = false; + } + } + return egc_is_active; +} + +/* + Lisp ff-calls this; it needs to set the active area's active pointer + correctly. +*/ + +Boolean +lisp_egc_control(Boolean activate) +{ + area *a = active_dynamic_area; + return egc_control(activate, (BytePtr) a->active); +} + + + + + +/* Splice the protected_area_ptr out of the list and dispose of it. */ +void +delete_protected_area(protected_area_ptr p) +{ + BytePtr start = p->start; + int nbytes = p->nprot; + protected_area_ptr *prev = &AllProtectedAreas, q; + + if (nbytes) { + UnProtectMemory((LogicalAddress)start, nbytes); + } + + while ((q = *prev) != NULL) { + if (p == q) { + *prev = p->next; + break; + } else { + prev = &(q->next); + } + } + + deallocate((Ptr)p); +} + + + + +/* + Unlink the area from all_areas. + Unprotect and dispose of any hard/soft protected_areas. + If the area has a handle, dispose of that as well. + */ + +void +condemn_area_holding_area_lock(area *a) +{ + void free_stack(void *); + area *prev = a->pred, *next = a->succ; + Ptr h = a->h; + protected_area_ptr p; + + prev->succ = next; + next->pred = prev; + + p = a->softprot; + if (p) delete_protected_area(p); + + p = a->hardprot; + + if (p) delete_protected_area(p); + + if (h) free_stack(h); + deallocate((Ptr)a); +} + + + +void +condemn_area(area *a, TCR *tcr) +{ + LOCK(lisp_global(TCR_AREA_LOCK),tcr); + condemn_area_holding_area_lock(a); + LOCK(lisp_global(TCR_AREA_LOCK),tcr); +} + + + + +/* + condemn an area and all the other areas that can be reached + via the area.older & area.younger links. + This is the function in the ppc::kernel-import-condemn-area slot, + called by free-stack-area + */ +void +condemn_area_chain(area *a, TCR *tcr) +{ + area *older; + + LOCK(lisp_global(TCR_AREA_LOCK),tcr); + + for (; a->younger; a = a->younger) ; + for (;a;) { + older = a->older; + condemn_area_holding_area_lock(a); + a = older; + } + UNLOCK(lisp_global(TCR_AREA_LOCK),tcr); +} + + +void +protect_watched_areas() +{ + area *a = active_dynamic_area; + natural code = a->code; + + while (code != AREA_VOID) { + if (code == AREA_WATCHED) { + natural size = a->high - a->low; + + ProtectMemory(a->low, size); + } + a = a->succ; + code = a->code; + } +} + +void +unprotect_watched_areas() +{ + area *a = active_dynamic_area; + natural code = a->code; + + while (code != AREA_VOID) { + if (code == AREA_WATCHED) { + natural size = a->high - a->low; + + UnProtectMemory(a->low, size); + } + a = a->succ; + code = a->code; + } +} Index: /branches/new-random/lisp-kernel/memprotect.h =================================================================== --- /branches/new-random/lisp-kernel/memprotect.h (revision 13309) +++ /branches/new-random/lisp-kernel/memprotect.h (revision 13309) @@ -0,0 +1,132 @@ +/* + Copyright (C) 2009 Clozure Associates + Copyright (C) 1994-2001 Digitool, Inc + This file is part of Clozure CL. + + Clozure CL is licensed under the terms of the Lisp Lesser GNU Public + License , known as the LLGPL and distributed with Clozure CL as the + file "LICENSE". The LLGPL consists of a preamble and the LGPL, + which is distributed with Clozure CL as the file "LGPL". Where these + conflict, the preamble takes precedence. + + Clozure CL is referenced in the preamble as the "LIBRARY." + + The LLGPL is also available online at + http://opensource.franz.com/preamble.html +*/ + +#ifndef __memprotect_h__ +#define __memprotect_h__ + + + +#include "lisptypes.h" +#ifdef PPC +#include "ppc-constants.h" +#endif +#include +#ifndef WINDOWS +#ifdef DARWIN +#include +#else +#include +#endif +#endif + +#ifdef WINDOWS +#define MAP_FAILED ((void *)(-1)) + +#define MEMPROTECT_NONE PAGE_NOACCESS +#define MEMPROTECT_RO PAGE_READONLY +#define MEMPROTECT_RW PAGE_READWRITE +#define MEMPROTECT_RX PAGE_EXECUTE_READ +#define MEMPROTECT_RWX PAGE_EXECUTE_READWRITE + +#else + +#define MEMPROTECT_NONE PROT_NONE +#define MEMPROTECT_RO PROT_READ +#define MEMPROTECT_RW (PROT_READ|PROT_WRITE) +#define MEMPROTECT_RX (PROT_READ|PROT_EXEC) +#define MEMPROTECT_RWX (PROT_READ|PROT_WRITE|PROT_EXEC) +#ifndef MAP_GROWSDOWN +#define MAP_GROWSDOWN (0) +#endif + + +#endif + +LogicalAddress +ReserveMemoryForHeap(LogicalAddress want, natural totalsize); + +int +CommitMemory (LogicalAddress start, natural len); + +void +UnCommitMemory (LogicalAddress start, natural len); + +LogicalAddress +MapMemory(LogicalAddress addr, natural nbytes, int protection); + +LogicalAddress +MapMemoryForStack(natural nbytes); + +int +UnMapMemory(LogicalAddress addr, natural nbytes); + +int +ProtectMemory(LogicalAddress, natural); + +int +UnProtectMemory(LogicalAddress, natural); + +int +MapFile(LogicalAddress addr, natural pos, natural nbytes, int permissions, int fd); + +typedef enum { + kNotProtected, /* At least not at the moment. */ + kVSPsoftguard, + kSPsoftguard, + kTSPsoftguard, + kSPhardguard, /* Touch one and die. */ + kVSPhardguard, + kTSPhardguard, + kHEAPsoft, /* Uninitialized page in the heap */ + kHEAPhard, /* The end-of-the-line in the heap */ + /* Phony last entry. */ + kNumProtectionKinds + } lisp_protection_kind; + +typedef +struct protected_area { + struct protected_area *next; + BytePtr start; /* first byte (page-aligned) that might be protected */ + BytePtr end; /* last byte (page-aligned) that could be protected */ + unsigned nprot; /* Might be 0 */ + unsigned protsize; /* number of bytes to protect */ + lisp_protection_kind why; +} protected_area, *protected_area_ptr; + + +/* Various functions that try to respond to a protection violation */ +typedef + OSStatus (protection_handler)(ExceptionInformation *, protected_area_ptr, BytePtr); + +protection_handler + do_spurious_wp_fault, + do_soft_stack_overflow, + do_hard_stack_overflow, + do_tenured_space_write, + do_heap_soft_probe, + do_heap_hard_probe; + +extern protection_handler + *protection_handlers[]; + + +void +exception_cleanup(void); + + + +#endif /* __memprotect_h__ */ Index: /branches/new-random/lisp-kernel/pad.s =================================================================== --- /branches/new-random/lisp-kernel/pad.s (revision 13309) +++ /branches/new-random/lisp-kernel/pad.s (revision 13309) @@ -0,0 +1,6 @@ + .globl openmcl_low_address +openmcl_low_address: + nop + + + Index: /branches/new-random/lisp-kernel/plbt.c =================================================================== --- /branches/new-random/lisp-kernel/plbt.c (revision 13309) +++ /branches/new-random/lisp-kernel/plbt.c (revision 13309) @@ -0,0 +1,318 @@ +/* + Copyright (C) 2009 Clozure Associates + Copyright (C) 1994-2001 Digitool, Inc + This file is part of Clozure CL. + + Clozure CL is licensed under the terms of the Lisp Lesser GNU Public + License , known as the LLGPL and distributed with Clozure CL as the + file "LICENSE". The LLGPL consists of a preamble and the LGPL, + which is distributed with Clozure CL as the file "LGPL". Where these + conflict, the preamble takes precedence. + + Clozure CL is referenced in the preamble as the "LIBRARY." + + The LLGPL is also available online at + http://opensource.franz.com/preamble.html +*/ + +#include "lispdcmd.h" +#ifdef LINUX +#define __USE_GNU 1 +#include +#endif + +#ifdef DARWIN +#if 0 +#undef undefined +#include +#include +#include + +typedef struct dl_info { + const char *dli_fname; /* Pathname of shared object */ + void *dli_fbase; /* Base address of shared object */ + const char *dli_sname; /* Name of nearest symbol */ + void *dli_saddr; /* Address of nearest symbol */ +} Dl_info; + +int +darwin_dladdr(void *p, Dl_info *info) +{ + unsigned long i; + unsigned long j; + uint32_t count = _dyld_image_count(); + struct mach_header *mh = 0; + struct load_command *lc = 0; + unsigned long addr = 0; + unsigned long table_off = (unsigned long)0; + int found = 0; + + if (!info) + return 0; + info->dli_fname = 0; + info->dli_fbase = 0; + info->dli_sname = 0; + info->dli_saddr = 0; + /* Some of this was swiped from code posted by Douglas Davidson + * to darwin-development AT lists DOT + * apple DOT com and slightly modified + */ + for (i = 0; i < count; i++) { + addr = (unsigned long)p - _dyld_get_image_vmaddr_slide(i); + mh = (struct mach_header *)_dyld_get_image_header(i); + if (mh) { + lc = (struct load_command *)((char *)mh + sizeof(struct mach_header)); + for (j = 0; j < mh->ncmds; j++, lc = (struct load_command *)((char *)lc + lc->cmdsize)) { + if (LC_SEGMENT == lc->cmd && + addr >= ((struct segment_command *)lc)->vmaddr && + addr < + ((struct segment_command *)lc)->vmaddr + ((struct segment_command *)lc)->vmsize) { + info->dli_fname = _dyld_get_image_name(i); + info->dli_fbase = (void *)mh; + found = 1; + break; + } + } + if (found) { + break; + } + } + } + if (!found) { + return 0; + } + lc = (struct load_command *)((char *)mh + sizeof(struct mach_header)); + for (j = 0; + j < mh->ncmds; + j++, lc = (struct load_command *)((char *)lc + lc->cmdsize)) { + if (LC_SEGMENT == lc->cmd) { + if (!strcmp(((struct segment_command *)lc)->segname, "__LINKEDIT")) + break; + } + } + table_off = + ((unsigned long)((struct segment_command *)lc)->vmaddr) - + ((unsigned long)((struct segment_command *)lc)->fileoff) + _dyld_get_image_vmaddr_slide(i); + + lc = (struct load_command *)((char *)mh + sizeof(struct mach_header)); + for (j = 0; + j < mh->ncmds; + j++, lc = (struct load_command *)((char *)lc + lc->cmdsize)) { + if (LC_SYMTAB == lc->cmd) { + struct nlist *symtable = (struct nlist *)(((struct symtab_command *)lc)->symoff + table_off); + unsigned long numsyms = ((struct symtab_command *)lc)->nsyms; + struct nlist *nearest = NULL; + unsigned long diff = 0xffffffff; + unsigned long strtable = (unsigned long)(((struct symtab_command *)lc)->stroff + table_off); + for (i = 0; i < numsyms; i++) { + /* fprintf(dbgout,"%s : 0x%08x, 0x%x\n",(char *)(strtable + symtable->n_un.n_strx) ,symtable->n_value, symtable->n_type); */ + /* Ignore the following kinds of Symbols */ + if ((!symtable->n_value) /* Undefined */ + || (symtable->n_type & N_STAB) /* Debug symbol */ + || ((symtable->n_type & N_TYPE) != N_SECT) /* Absolute, indirect, ... */ + ) { + symtable++; + continue; + } + if ((addr >= symtable->n_value) && + (diff >= addr - (symtable->n_value ))) { + diff = addr- (unsigned long)symtable->n_value; + nearest = symtable; + } + symtable++; + } + if (nearest) { + info->dli_saddr = nearest->n_value + ((void *)p - addr); + info->dli_sname = (char *)(strtable + nearest->n_un.n_strx); + } + } + } + return 1; +} + +#define dladdr darwin_dladdr +#else +#include +#endif +#endif + + + +extern Boolean lisp_frame_p(lisp_frame *); + +void +print_lisp_frame(lisp_frame *frame) +{ + LispObj fun = frame->savefn, pc = frame->savelr; + int delta = 0; + Dl_info info; + char *spname; + + if ((fun == 0) || (fun == fulltag_misc)) { + spname = "unknown ?"; +#ifndef STATIC + if (dladdr((void *)ptr_from_lispobj(pc), &info)) { + spname = (char *)(info.dli_sname); +#ifdef DARWIN + if (spname[-1] != '_') { + --spname; + } +#endif + } +#endif +#ifdef PPC64 + Dprintf("(#x%016lX) #x%016lX : (subprimitive %s)", frame, pc, spname); +#else + Dprintf("(#x%08X) #x%08X : (subprimitive %s)", frame, pc, spname); +#endif + } else { + if ((fulltag_of(fun) != fulltag_misc) || + (header_subtag(header_of(fun)) != subtag_function)) { +#ifdef PPC64 + Dprintf("(#x%016lX) #x%016lX : (not a function!)", frame, pc); +#else + Dprintf("(#x%08X) #x%08X : (not a function!)", frame, pc); +#endif + } else { + LispObj code_vector = deref(fun, 1); + + if ((pc >= (code_vector+misc_data_offset)) && + (pc < ((code_vector+misc_data_offset)+(header_element_count(header_of(code_vector))<<2)))) { + delta = (pc - (code_vector+misc_data_offset)); + } +#ifdef PPC64 + Dprintf("(#x%016lX) #x%016lX : %s + %d", frame, pc, print_lisp_object(fun), delta); +#else + Dprintf("(#x%08X) #x%08X : %s + %d", frame, pc, print_lisp_object(fun), delta); +#endif + } + } +} + + +void +print_foreign_frame(void *frame) +{ +#ifdef LINUX + natural pc = (natural) (((eabi_c_frame *)frame)->savelr); +#endif +#ifdef DARWIN + natural pc = (natural) (((c_frame *)frame)->savelr); +#endif + Dl_info foreign_info; + +#ifndef STATIC + if (dladdr((void *)pc, &foreign_info)) { + Dprintf( +#ifdef PPC64 +"(#x%016lx) #x%016lX : %s + %d" +#else +"(#x%08x) #x%08X : %s + %d" +#endif +, frame, pc, foreign_info.dli_sname, + pc-((long)foreign_info.dli_saddr)); + } else { +#endif + Dprintf( +#ifdef PPC64 +"(#x%016X) #x%016X : foreign code (%s)" +#else +"(#x%08X) #x%08X : foreign code (%s)" +#endif +, frame, pc, "unknown"); +#ifndef STATIC + } +#endif +} + + +/* Walk frames from "start" to "end". + Say whatever can be said about foreign frames and lisp frames. +*/ + +void +walk_stack_frames(lisp_frame *start, lisp_frame *end) +{ + lisp_frame *next; + Dprintf("\n"); + while (start < end) { + + if (lisp_frame_p(start)) { + print_lisp_frame(start); + } else { +#ifdef DARWIN + print_foreign_frame((c_frame *)start); +#else + print_foreign_frame((eabi_c_frame *)start); +#endif + } + + next = start->backlink; + if (next == 0) { + next = end; + } + if (next < start) { + fprintf(dbgout, "Bad frame! (%x < %x)\n", next, start); + break; + } + start = next; + } +} + +char * +interrupt_level_description(TCR *tcr) +{ + signed_natural level = (signed_natural) TCR_INTERRUPT_LEVEL(tcr); + if (level < 0) { + if (tcr->interrupt_pending) { + return "disabled(pending)"; + } else { + return "disabled"; + } + } else { + return "enabled"; + } +} + +void +walk_other_areas() +{ + TCR *start = (TCR *)get_tcr(true), *tcr = start->next; + area *a; + char *ilevel = interrupt_level_description(tcr); + + while (tcr != start) { + a = tcr->cs_area; + Dprintf("\n\n TCR = 0x%lx, cstack area #x%lx, native thread ID = 0x%lx, interrupts %s", tcr, a, tcr->native_thread_id, ilevel); + walk_stack_frames((lisp_frame *) (a->active), (lisp_frame *) (a->high)); + tcr = tcr->next; + } +} + +void +plbt_sp(LispObj currentSP) +{ + area *cs_area; + +{ + TCR *tcr = (TCR *)get_tcr(true); + char *ilevel = interrupt_level_description(tcr); + cs_area = tcr->cs_area; + if ((((LispObj) ptr_to_lispobj(cs_area->low)) > currentSP) || + (((LispObj) ptr_to_lispobj(cs_area->high)) < currentSP)) { + Dprintf("\nStack pointer [#x%lX] in unknown area.", currentSP); + } else { + fprintf(dbgout, "current thread: tcr = 0x%lx, native thread ID = 0x%lx, interrupts %s\n", tcr, tcr->native_thread_id, ilevel); + walk_stack_frames((lisp_frame *) ptr_from_lispobj(currentSP), (lisp_frame *) (cs_area->high)); + walk_other_areas(); + } + } +} + + +void +plbt(ExceptionInformation *xp) +{ + plbt_sp(xpGPR(xp, sp)); +} + Index: /branches/new-random/lisp-kernel/plprint.c =================================================================== --- /branches/new-random/lisp-kernel/plprint.c (revision 13309) +++ /branches/new-random/lisp-kernel/plprint.c (revision 13309) @@ -0,0 +1,30 @@ +/* + Copyright (C) 2009 Clozure Associates + Copyright (C) 1994-2001 Digitool, Inc + This file is part of Clozure CL. + + Clozure CL is licensed under the terms of the Lisp Lesser GNU Public + License , known as the LLGPL and distributed with Clozure CL as the + file "LICENSE". The LLGPL consists of a preamble and the LGPL, + which is distributed with Clozure CL as the file "LGPL". Where these + conflict, the preamble takes precedence. + + Clozure CL is referenced in the preamble as the "LIBRARY." + + The LLGPL is also available online at + http://opensource.franz.com/preamble.html +*/ + +#include "lispdcmd.h" + + +void +plprint(ExceptionInformation *xp, LispObj obj) +{ + if (lisp_nil == (LispObj) NULL) { + fprintf(dbgout,"can't find lisp NIL; lisp process not active process ?\n"); + } else { + Dprintf("\n%s", print_lisp_object(obj)); + } +} + Index: /branches/new-random/lisp-kernel/plsym.c =================================================================== --- /branches/new-random/lisp-kernel/plsym.c (revision 13309) +++ /branches/new-random/lisp-kernel/plsym.c (revision 13309) @@ -0,0 +1,128 @@ +/* + Copyright (C) 2009 Clozure Associates + Copyright (C) 1994-2001 Digitool, Inc + This file is part of Clozure CL. + + Clozure CL is licensed under the terms of the Lisp Lesser GNU Public + License , known as the LLGPL and distributed with Clozure CL as the + file "LICENSE". The LLGPL consists of a preamble and the LGPL, + which is distributed with Clozure CL as the file "LGPL". Where these + conflict, the preamble takes precedence. + + Clozure CL is referenced in the preamble as the "LIBRARY." + + The LLGPL is also available online at + http://opensource.franz.com/preamble.html +*/ + +#include "lispdcmd.h" + +void +describe_symbol(LispObj sym) +{ + lispsymbol *rawsym = (lispsymbol *)ptr_from_lispobj(untag(sym)); + LispObj function = rawsym->fcell; +#ifdef fulltag_symbol + sym += (fulltag_symbol-fulltag_misc); +#endif + Dprintf("Symbol %s at #x%llX", print_lisp_object(sym), (u64_t) sym); + Dprintf(" value : %s", print_lisp_object(rawsym->vcell)); + if (function != nrs_UDF.vcell) { + Dprintf(" function : %s", print_lisp_object(function)); + } +} + +int +compare_lisp_string_to_c_string(lisp_char_code *lisp_string, + char *c_string, + natural n) +{ + natural i; + for (i = 0; i < n; i++) { + if (lisp_string[i] != (lisp_char_code)(c_string[i])) { + return 1; + } + } + return 0; +} + +/* + Walk the heap until we find a symbol + whose pname matches "name". Return the + tagged symbol or NULL. +*/ + +LispObj +find_symbol_in_range(LispObj *start, LispObj *end, char *name) +{ + LispObj header, tag; + int n = strlen(name); + char *s = name; + lisp_char_code *p; + while (start < end) { + header = *start; + tag = fulltag_of(header); + if (header_subtag(header) == subtag_symbol) { + LispObj + pname = deref(ptr_to_lispobj(start), 1), + pname_header = header_of(pname); + if ((header_subtag(pname_header) == subtag_simple_base_string) && + (header_element_count(pname_header) == n)) { + p = (lisp_char_code *) ptr_from_lispobj(pname + misc_data_offset); + if (compare_lisp_string_to_c_string(p, s, n) == 0) { + return (ptr_to_lispobj(start))+fulltag_misc; + } + } + } + if (nodeheader_tag_p(tag)) { + start += (~1 & (2 + header_element_count(header))); + } else if (immheader_tag_p(tag)) { + start = (LispObj *) skip_over_ivector((natural)start, header); + } else { + start += 2; + } + } + return (LispObj)NULL; +} + +LispObj +find_symbol(char *name) +{ + area *a = ((area *) (ptr_from_lispobj(lisp_global(ALL_AREAS))))->succ; + area_code code; + LispObj sym = 0; + + while ((code = a->code) != AREA_VOID) { + if ((code == AREA_STATIC) || + (code == AREA_DYNAMIC)) { + sym = find_symbol_in_range((LispObj *)(a->low), (LispObj *)(a->active), name); + if (sym) { + break; + } + } + a = a->succ; + } + return sym; +} + + +void +plsym(ExceptionInformation *xp, char *pname) +{ + natural address = 0; + + address = find_symbol(pname); + if (address == 0) { + Dprintf("Can't find symbol."); + return; + } + + if ((fulltag_of(address) == fulltag_misc) && + (header_subtag(header_of(address)) == subtag_symbol)){ + describe_symbol(address); + } else { + fprintf(dbgout, "Not a symbol.\n"); + } + return; +} + Index: /branches/new-random/lisp-kernel/pmcl-kernel.c =================================================================== --- /branches/new-random/lisp-kernel/pmcl-kernel.c (revision 13309) +++ /branches/new-random/lisp-kernel/pmcl-kernel.c (revision 13309) @@ -0,0 +1,2482 @@ +/* + Copyright (C) 2009 Clozure Associates + Copyright (C) 1994-2001 Digitool, Inc + This file is part of Clozure CL. + + Clozure CL is licensed under the terms of the Lisp Lesser GNU Public + License , known as the LLGPL and distributed with Clozure CL as the + file "LICENSE". The LLGPL consists of a preamble and the LGPL, + which is distributed with Clozure CL as the file "LGPL". Where these + conflict, the preamble takes precedence. + + Clozure CL is referenced in the preamble as the "LIBRARY." + + The LLGPL is also available online at + http://opensource.franz.com/preamble.html +*/ + +#ifdef DARWIN +/* dyld.h included here because something in "lisp.h" causes + a conflict (actually I think the problem is in "constants.h") +*/ +#include + +#endif +#include "lisp.h" +#include "lisp_globals.h" +#include "gc.h" +#include "area.h" +#include +#include +#include "lisp-exceptions.h" +#include +#include +#ifndef WINDOWS +#include +#endif +#include +#include +#include +#ifndef WINDOWS +#include +#include +#endif + +#ifdef LINUX +#include +#include +#include +#include +#include +#include +#include + +/* + The version of provided by some distributions will + claim that doesn't exist. It may be present + in the Linux kernel source tree even if it's not copied to + /usr/include/asm-ppc64. Hopefully, this will be straightened out + soon (and/or the PPC_FEATURE_HAS_ALTIVEC constant will be defined + in a less volatile place.) Until that's straightened out, it may + be necessary to install a copy of the kernel header in the right + place and/or persuade to lighten up a bit. +*/ + +#ifdef PPC +#ifndef PPC64 +#include +#endif +#ifndef PPC_FEATURE_HAS_ALTIVEC +#define PPC_FEATURE_HAS_ALTIVEC 0x10000000 +#endif +#endif +#endif + +Boolean use_mach_exception_handling = +#ifdef DARWIN + true +#else + false +#endif +; + +#ifdef DARWIN +#include +#include +#include +#include +#include +#include +#include +#include +#include +#include +#endif + +#if defined(FREEBSD) || defined(SOLARIS) +#include +#include +#include +#include +#include +#endif + +#include +#ifndef WINDOWS +#include +#endif +#include "Threads.h" + +#include +#include + +#ifndef MAP_NORESERVE +#define MAP_NORESERVE (0) +#endif + +#ifdef WINDOWS +#include +#include +void +wperror(char* message) +{ + char* buffer; + DWORD last_error = GetLastError(); + + FormatMessage(FORMAT_MESSAGE_ALLOCATE_BUFFER| + FORMAT_MESSAGE_FROM_SYSTEM| + FORMAT_MESSAGE_IGNORE_INSERTS, + NULL, + last_error, + MAKELANGID(LANG_NEUTRAL, SUBLANG_DEFAULT), + (LPTSTR)&buffer, + 0, NULL); + fprintf(dbgout, "%s: 0x%x %s\n", message, (unsigned) last_error, buffer); + LocalFree(buffer); +} +#endif + +LispObj lisp_nil = (LispObj) 0; +bitvector global_mark_ref_bits = NULL, dynamic_mark_ref_bits = NULL, relocatable_mark_ref_bits = NULL; + + +/* These are all "persistent" : they're initialized when + subprims are first loaded and should never change. */ +extern LispObj ret1valn; +extern LispObj nvalret; +extern LispObj popj; + +LispObj text_start = 0; + +/* A pointer to some of the kernel's own data; also persistent. */ + +extern LispObj import_ptrs_base; + + + +void +xMakeDataExecutable(void *, unsigned long); + +void +make_dynamic_heap_executable(LispObj *p, LispObj *q) +{ + void * cache_start = (void *) p; + natural ncacheflush = (natural) q - (natural) p; + + xMakeDataExecutable(cache_start, ncacheflush); +} + +size_t +ensure_stack_limit(size_t stack_size) +{ +#ifdef WINDOWS + extern void os_get_current_thread_stack_bounds(void **, natural*); + natural totalsize; + void *ignored; + + os_get_current_thread_stack_bounds(&ignored, &totalsize); + + return (size_t)totalsize-(size_t)(CSTACK_HARDPROT+CSTACK_SOFTPROT); + +#else + struct rlimit limits; + rlim_t cur_stack_limit, max_stack_limit; + + stack_size += (CSTACK_HARDPROT+CSTACK_SOFTPROT); + getrlimit(RLIMIT_STACK, &limits); + cur_stack_limit = limits.rlim_cur; + max_stack_limit = limits.rlim_max; + if (stack_size > max_stack_limit) { + stack_size = max_stack_limit; + } + if (cur_stack_limit < stack_size) { + limits.rlim_cur = stack_size; + errno = 0; + if (setrlimit(RLIMIT_STACK, &limits)) { + int e = errno; + fprintf(dbgout, "errno = %d\n", e); + Fatal(": Stack resource limit too small", ""); + } + } +#endif + return stack_size; +} + + +/* This should write-protect the bottom of the stack. + Doing so reliably involves ensuring that everything's unprotected on exit. +*/ + +BytePtr +allocate_lisp_stack(natural useable, + unsigned softsize, + unsigned hardsize, + lisp_protection_kind softkind, + lisp_protection_kind hardkind, + Ptr *h_p, + BytePtr *base_p, + protected_area_ptr *softp, + protected_area_ptr *hardp) +{ + void *allocate_stack(natural); + void free_stack(void *); + natural size = useable+softsize+hardsize; + natural overhead; + BytePtr base, softlimit, hardlimit; + Ptr h = allocate_stack(size+4095); + protected_area_ptr hprotp = NULL, sprotp; + + if (h == NULL) { + return NULL; + } + if (h_p) *h_p = h; + base = (BytePtr) align_to_power_of_2( h, log2_page_size); + hardlimit = (BytePtr) (base+hardsize); + softlimit = hardlimit+softsize; + + overhead = (base - (BytePtr) h); + if (hardsize) { + hprotp = new_protected_area((BytePtr)base,hardlimit,hardkind, hardsize, true); + if (hprotp == NULL) { + if (base_p) *base_p = NULL; + if (h_p) *h_p = NULL; + deallocate(h); + return NULL; + } + if (hardp) *hardp = hprotp; + } + if (softsize) { + sprotp = new_protected_area(hardlimit,softlimit, softkind, softsize, true); + if (sprotp == NULL) { + if (base_p) *base_p = NULL; + if (h_p) *h_p = NULL; + if (hardp) *hardp = NULL; + if (hprotp) delete_protected_area(hprotp); + free_stack(h); + return NULL; + } + if (softp) *softp = sprotp; + } + if (base_p) *base_p = base; + return (BytePtr) ((natural)(base+size)); +} + +/* + This should only called by something that owns the area_lock, or + by the initial thread before other threads exist. +*/ +area * +allocate_lisp_stack_area(area_code stack_type, + natural usable, + unsigned softsize, + unsigned hardsize, + lisp_protection_kind softkind, + lisp_protection_kind hardkind) + +{ + BytePtr base, bottom; + Ptr h; + area *a = NULL; + protected_area_ptr soft_area=NULL, hard_area=NULL; + + bottom = allocate_lisp_stack(usable, + softsize, + hardsize, + softkind, + hardkind, + &h, + &base, + &soft_area, + &hard_area); + + if (bottom) { + a = new_area(base, bottom, stack_type); + a->hardlimit = base+hardsize; + a->softlimit = base+hardsize+softsize; + a->h = h; + a->softprot = soft_area; + a->hardprot = hard_area; + add_area_holding_area_lock(a); + } + return a; +} + +/* + Also assumes ownership of the area_lock +*/ +area* +register_cstack_holding_area_lock(BytePtr bottom, natural size) +{ + BytePtr lowlimit = (BytePtr) (((((natural)bottom)-size)+4095)&~4095); + area *a = new_area((BytePtr) bottom-size, bottom, AREA_CSTACK); + a->hardlimit = lowlimit+CSTACK_HARDPROT; + a->softlimit = a->hardlimit+CSTACK_SOFTPROT; +#ifdef USE_SIGALTSTACK + setup_sigaltstack(a); +#endif + add_area_holding_area_lock(a); + return a; +} + + +area* +allocate_vstack_holding_area_lock(natural usable) +{ + return allocate_lisp_stack_area(AREA_VSTACK, + usable > MIN_VSTACK_SIZE ? + usable : MIN_VSTACK_SIZE, + VSTACK_SOFTPROT, + VSTACK_HARDPROT, + kVSPsoftguard, + kVSPhardguard); +} + +area * +allocate_tstack_holding_area_lock(natural usable) +{ + return allocate_lisp_stack_area(AREA_TSTACK, + usable > MIN_TSTACK_SIZE ? + usable : MIN_TSTACK_SIZE, + TSTACK_SOFTPROT, + TSTACK_HARDPROT, + kTSPsoftguard, + kTSPhardguard); +} + + +/* It's hard to believe that max & min don't exist already */ +unsigned unsigned_min(unsigned x, unsigned y) +{ + if (x <= y) { + return x; + } else { + return y; + } +} + +unsigned unsigned_max(unsigned x, unsigned y) +{ + if (x >= y) { + return x; + } else { + return y; + } +} + +#if WORD_SIZE == 64 +#ifdef DARWIN +#define MAXIMUM_MAPPABLE_MEMORY (512L<<30L) +#endif +#ifdef FREEBSD +#define MAXIMUM_MAPPABLE_MEMORY (512L<<30L) +#endif +#ifdef SOLARIS +#define MAXIMUM_MAPPABLE_MEMORY (512L<<30L) +#endif +#ifdef LINUX +#ifdef X8664 +#define MAXIMUM_MAPPABLE_MEMORY (512L<<30L) +#endif +#ifdef PPC +#define MAXIMUM_MAPPABLE_MEMORY (512L<<30L) +#endif +#endif +#ifdef WINDOWS +/* Supposedly, the high-end version of Vista allow 128GB of pageable memory */ +#define MAXIMUM_MAPPABLE_MEMORY (512LL<<30LL) +#endif +#else +#ifdef DARWIN +#define MAXIMUM_MAPPABLE_MEMORY ((1U<<31)-2*heap_segment_size) +#endif +#ifdef LINUX +#ifdef X86 +#define MAXIMUM_MAPPABLE_MEMORY (9U<<28) +#else +#define MAXIMUM_MAPPABLE_MEMORY (1U<<30) +#endif +#endif +#ifdef WINDOWS +#define MAXIMUM_MAPPABLE_MEMORY (1U<<30) +#endif +#ifdef FREEBSD +#define MAXIMUM_MAPPABLE_MEMORY (1U<<30) +#endif +#ifdef SOLARIS +#define MAXIMUM_MAPPABLE_MEMORY (1U<<30) +#endif +#endif + +natural +reserved_area_size = MAXIMUM_MAPPABLE_MEMORY; + +area + *nilreg_area=NULL, + *tenured_area=NULL, + *g2_area=NULL, + *g1_area=NULL, + *managed_static_area=NULL, + *static_cons_area=NULL, + *readonly_area=NULL; + +area *all_areas=NULL; +int cache_block_size=32; + + +#if WORD_SIZE == 64 +#define DEFAULT_LISP_HEAP_GC_THRESHOLD (32<<20) +#define G2_AREA_THRESHOLD (8<<20) +#define G1_AREA_THRESHOLD (4<<20) +#define G0_AREA_THRESHOLD (2<<20) +#else +#define DEFAULT_LISP_HEAP_GC_THRESHOLD (16<<20) +#define G2_AREA_THRESHOLD (4<<20) +#define G1_AREA_THRESHOLD (2<<20) +#define G0_AREA_THRESHOLD (1<<20) +#endif + +#define MIN_DYNAMIC_SIZE (DEFAULT_LISP_HEAP_GC_THRESHOLD *2) + +#if (WORD_SIZE == 32) +#define DEFAULT_INITIAL_STACK_SIZE (1<<20) +#else +#define DEFAULT_INITIAL_STACK_SIZE (2<<20) +#endif + +natural +lisp_heap_gc_threshold = DEFAULT_LISP_HEAP_GC_THRESHOLD; + +natural +initial_stack_size = DEFAULT_INITIAL_STACK_SIZE; + +natural +thread_stack_size = 0; + + +/* + 'start' should be on a segment boundary; 'len' should be + an integral number of segments. remap the entire range. +*/ + +void +uncommit_pages(void *start, size_t len) +{ + UnCommitMemory(start, len); +} + +#define TOUCH_PAGES_ON_COMMIT 0 + +Boolean +touch_all_pages(void *start, size_t len) +{ +#if TOUCH_PAGES_ON_COMMIT + extern Boolean touch_page(void *); + char *p = (char *)start; + + while (len) { + if (!touch_page(p)) { + return false; + } + len -= page_size; + p += page_size; + } +#endif + return true; +} + +Boolean +commit_pages(void *start, size_t len) +{ + if (len != 0) { + if (CommitMemory(start, len)) { + if (touch_all_pages(start, len)) { + return true; + } + } + } + return true; +} + +area * +find_readonly_area() +{ + area *a; + + for (a = active_dynamic_area->succ; a != all_areas; a = a->succ) { + if (a->code == AREA_READONLY) { + return a; + } + } + return NULL; +} + +area * +extend_readonly_area(natural more) +{ + area *a; + unsigned mask; + BytePtr new_start, new_end; + + if ((a = find_readonly_area()) != NULL) { + if ((a->active + more) > a->high) { + return NULL; + } + mask = ((natural)a->active) & (page_size-1); + if (mask) { + UnProtectMemory(a->active-mask, page_size); + } + new_start = (BytePtr)(align_to_power_of_2(a->active,log2_page_size)); + new_end = (BytePtr)(align_to_power_of_2(a->active+more,log2_page_size)); + if (!CommitMemory(new_start, new_end-new_start)) { + return NULL; + } + return a; + } + return NULL; +} + +LispObj image_base=0; +BytePtr pure_space_start, pure_space_active, pure_space_limit; +BytePtr static_space_start, static_space_active, static_space_limit; + +void +raise_limit() +{ +#ifdef RLIMIT_AS + struct rlimit r; + if (getrlimit(RLIMIT_AS, &r) == 0) { + r.rlim_cur = r.rlim_max; + setrlimit(RLIMIT_AS, &r); + /* Could limit heaplimit to rlim_max here if smaller? */ + } +#endif +} + + +area * +create_reserved_area(natural totalsize) +{ + Ptr h; + natural base; + BytePtr + end, + lastbyte, + start, + want = (BytePtr)IMAGE_BASE_ADDRESS; + area *reserved; + Boolean fatal = false; + + totalsize = align_to_power_of_2((void *)totalsize, log2_heap_segment_size); + + if (totalsize < (PURESPACE_RESERVE + MIN_DYNAMIC_SIZE)) { + totalsize = PURESPACE_RESERVE + MIN_DYNAMIC_SIZE; + fatal = true; + } + + start = ReserveMemoryForHeap(want, totalsize); + + if (start == NULL) { + if (fatal) { + perror("minimal initial mmap"); + exit(1); + } + return NULL; + } + + h = (Ptr) start; + base = (natural) start; + image_base = base; + lastbyte = (BytePtr) (start+totalsize); + static_space_start = static_space_active = (BytePtr)STATIC_BASE_ADDRESS; + static_space_limit = static_space_start + STATIC_RESERVE; + pure_space_start = pure_space_active = start; + pure_space_limit = start + PURESPACE_SIZE; + start += PURESPACE_RESERVE; + + /* + Allocate mark bits here. They need to be 1/64 the size of the + maximum useable area of the heap (+ 3 words for the EGC.) + */ + end = lastbyte; + end = (BytePtr) ((natural)((((natural)end) - ((totalsize+63)>>6)) & ~4095)); + + global_mark_ref_bits = (bitvector)end; + end = (BytePtr) ((natural)((((natural)end) - ((totalsize+63) >> 6)) & ~4095)); + global_reloctab = (LispObj *) end; + reserved = new_area(start, end, AREA_VOID); + /* The root of all evil is initially linked to itself. */ + reserved->pred = reserved->succ = reserved; + all_areas = reserved; + return reserved; +} + +void * +allocate_from_reserved_area(natural size) +{ + area *reserved = reserved_area; + BytePtr low = reserved->low, high = reserved->high; + natural avail = high-low; + + size = align_to_power_of_2(size, log2_heap_segment_size); + + if (size > avail) { + return NULL; + } + reserved->low += size; + reserved->active = reserved->low; + reserved->ndnodes -= (size>>dnode_shift); + return low; +} + + + +BytePtr reloctab_limit = NULL, markbits_limit = NULL; +BytePtr low_relocatable_address = NULL, high_relocatable_address = NULL, + low_markable_address = NULL, high_markable_address = NULL; + +void +map_initial_reloctab(BytePtr low, BytePtr high) +{ + natural ndnodes, reloctab_size, n; + + low_relocatable_address = low; /* will never change */ + high_relocatable_address = high; + ndnodes = area_dnode(high,low); + reloctab_size = (sizeof(LispObj)*(((ndnodes+((1<>bitmap_shift)+1)); + + reloctab_limit = (BytePtr)align_to_power_of_2(((natural)global_reloctab)+reloctab_size,log2_page_size); + CommitMemory(global_reloctab,reloctab_limit-(BytePtr)global_reloctab); +} + +void +map_initial_markbits(BytePtr low, BytePtr high) +{ + natural + prefix_dnodes = area_dnode(low, pure_space_limit), + ndnodes = area_dnode(high, low), + prefix_size = (prefix_dnodes+7)>>3, + markbits_size = (3*sizeof(LispObj))+((ndnodes+7)>>3), + n; + low_markable_address = low; + high_markable_address = high; + dynamic_mark_ref_bits = (bitvector)(((BytePtr)global_mark_ref_bits)+prefix_size); + relocatable_mark_ref_bits = dynamic_mark_ref_bits; + n = align_to_power_of_2(markbits_size,log2_page_size); + markbits_limit = ((BytePtr)dynamic_mark_ref_bits)+n; + CommitMemory(dynamic_mark_ref_bits,n); +} + +void +lower_heap_start(BytePtr new_low, area *a) +{ + natural new_dnodes = area_dnode(low_markable_address,new_low); + + if (new_dnodes) { + natural n = (new_dnodes+7)>>3; + + BytePtr old_markbits = (BytePtr)dynamic_mark_ref_bits, + new_markbits = old_markbits-n; + CommitMemory(new_markbits,n); + dynamic_mark_ref_bits = (bitvector)new_markbits; + if (a->refbits) { + a->refbits= dynamic_mark_ref_bits; + } + a->static_dnodes += new_dnodes; + a->ndnodes += new_dnodes; + a->low = new_low; + low_markable_address = new_low; + lisp_global(HEAP_START) = (LispObj)new_low; + static_cons_area->ndnodes = area_dnode(static_cons_area->high,new_low); + } +} + +void +ensure_gc_structures_writable() +{ + natural + ndnodes = area_dnode(lisp_global(HEAP_END),low_relocatable_address), + markbits_size = (3*sizeof(LispObj))+((ndnodes+7)>>3), + reloctab_size = (sizeof(LispObj)*(((ndnodes+((1<>bitmap_shift)+1)), + n; + BytePtr + new_reloctab_limit = (BytePtr)align_to_power_of_2(((natural)global_reloctab)+reloctab_size,log2_page_size), + new_markbits_limit = (BytePtr)align_to_power_of_2(((natural)relocatable_mark_ref_bits)+markbits_size,log2_page_size); + + if (new_reloctab_limit > reloctab_limit) { + n = new_reloctab_limit - reloctab_limit; + CommitMemory(reloctab_limit, n); + UnProtectMemory(reloctab_limit, n); + reloctab_limit = new_reloctab_limit; + } + + if (new_markbits_limit > markbits_limit) { + n = new_markbits_limit-markbits_limit; + CommitMemory(markbits_limit, n); + UnProtectMemory(markbits_limit, n); + markbits_limit = new_markbits_limit; + } +} + + +area * +allocate_dynamic_area(natural initsize) +{ + natural totalsize = align_to_power_of_2(initsize, log2_heap_segment_size); + BytePtr start, end; + area *a; + + start = allocate_from_reserved_area(totalsize); + if (start == NULL) { + fprintf(dbgout, "reserved area too small to load heap image\n"); + exit(1); + } + end = start + totalsize; + a = new_area(start, end, AREA_DYNAMIC); + a->active = start+initsize; + add_area_holding_area_lock(a); + CommitMemory(start, end-start); + a->h = start; + a->softprot = NULL; + a->hardprot = NULL; + map_initial_reloctab(a->low, a->high); + map_initial_markbits(a->low, a->high); + lisp_global(HEAP_START) = ptr_to_lispobj(a->low); + lisp_global(HEAP_END) = ptr_to_lispobj(a->high); + return a; + } + + +Boolean +grow_dynamic_area(natural delta) +{ + area *a = active_dynamic_area, *reserved = reserved_area; + natural avail = reserved->high - reserved->low; + + delta = align_to_power_of_2(delta, log2_heap_segment_size); + if (delta > avail) { + return false; + } + + if (!commit_pages(a->high,delta)) { + return false; + } + + + if (!allocate_from_reserved_area(delta)) { + return false; + } + + + a->high += delta; + a->ndnodes = area_dnode(a->high, a->low); + lisp_global(HEAP_END) += delta; + ensure_gc_structures_writable(); + return true; +} + +/* + As above. Pages that're returned to the reserved_area are + "condemned" (e.g, we try to convince the OS that they never + existed ...) +*/ +Boolean +shrink_dynamic_area(natural delta) +{ + area *a = active_dynamic_area, *reserved = reserved_area; + + delta = align_to_power_of_2(delta, log2_heap_segment_size); + + a->high -= delta; + a->ndnodes = area_dnode(a->high, a->low); + a->hardlimit = a->high; + uncommit_pages(a->high, delta); + reserved->low -= delta; + reserved->ndnodes += (delta>>dnode_shift); + lisp_global(HEAP_END) -= delta; + return true; +} + + + +#ifndef WINDOWS +void +user_signal_handler (int signum, siginfo_t *info, ExceptionInformation *context) +{ + if (signum == SIGINT) { + lisp_global(INTFLAG) = (((signum<<8) + 1) << fixnumshift); + } + else if (signum == SIGTERM) { + lisp_global(INTFLAG) = (((signum<<8) + 2) << fixnumshift); + } + else if (signum == SIGQUIT) { + lisp_global(INTFLAG) = (((signum<<8) + 2) << fixnumshift); + } +#ifdef DARWIN + DarwinSigReturn(context); +#endif +} + +#endif + +void +register_user_signal_handler() +{ +#ifdef WINDOWS + extern BOOL CALLBACK ControlEventHandler(DWORD); + + signal(SIGINT, SIG_IGN); + + SetConsoleCtrlHandler(ControlEventHandler,TRUE); +#else + install_signal_handler(SIGINT, (void *)user_signal_handler); + install_signal_handler(SIGTERM, (void *)user_signal_handler); +#endif +} + + + +BytePtr +initial_stack_bottom() +{ +#ifndef WINDOWS + extern char **environ; + char *p = *environ; + while (*p) { + p += (1+strlen(p)); + } + return (BytePtr)((((natural) p) +4095) & ~4095); +#endif +#ifdef WINDOWS + return (BytePtr)((current_stack_pointer() + 4095) & ~ 4095); +#endif +} + + + + +Ptr fatal_spare_ptr = NULL; + + +void +Fatal(StringPtr param0, StringPtr param1) +{ + + if (fatal_spare_ptr) { + deallocate(fatal_spare_ptr); + fatal_spare_ptr = NULL; + } + fprintf(dbgout, "Fatal error: %s\n%s\n", param0, param1); + _exit(-1); +} + +OSErr application_load_err = noErr; + +area * +set_nil(LispObj); + + +/* Check for the existence of a file named by 'path'; return true + if it seems to exist, without checking size, permissions, or + anything else. */ +Boolean +probe_file(char *path) +{ + struct stat st; + + return (stat(path,&st) == 0); +} + + +#ifdef WINDOWS +/* Chop the trailing ".exe" from the kernel image name */ +wchar_t * +chop_exe_suffix(wchar_t *path) +{ + int len = wcslen(path); + wchar_t *copy = malloc((len+1)*sizeof(wchar_t)), *tail; + + wcscpy(copy,path); + tail = wcsrchr(copy, '.'); + if (tail) { + *tail = 0; + } + return copy; +} +#endif + +#ifdef WINDOWS +wchar_t * +path_by_appending_image(wchar_t *path) +{ + int len = wcslen(path) + wcslen(L".image") + 1; + wchar_t *copy = (wchar_t *) malloc(len*sizeof(wchar_t)); + + if (copy) { + wcscpy(copy, path); + wcscat(copy, L".image"); + } + return copy; +} +#else +char * +path_by_appending_image(char *path) +{ + int len = strlen(path) + strlen(".image") + 1; + char *copy = (char *) malloc(len); + + if (copy) { + strcpy(copy, path); + strcat(copy, ".image"); + } + return copy; +} +#endif + +char * +case_inverted_path(char *path) +{ + char *copy = strdup(path), *base = copy, *work = copy, c; + if (copy == NULL) { + return NULL; + } + while(*work) { + if (*work++ == '/') { + base = work; + } + } + work = base; + while ((c = *work) != '\0') { + if (islower(c)) { + *work++ = toupper(c); + } else { + *work++ = tolower(c); + } + } + return copy; +} +/* + The underlying file system may be case-insensitive (e.g., HFS), + so we can't just case-invert the kernel's name. + Tack ".image" onto the end of the kernel's name. Much better ... +*/ +#ifdef WINDOWS +wchar_t * +default_image_name(wchar_t *orig) +{ + wchar_t *path = chop_exe_suffix(orig); + wchar_t *image_name = path_by_appending_image(path); + return image_name; +} +#else +char * +default_image_name(char *orig) +{ +#ifdef WINDOWS + char *path = chop_exe_suffix(orig); +#else + char *path = orig; +#endif + char *image_name = path_by_appending_image(path); +#if !defined(WINDOWS) && !defined(DARWIN) + if (!probe_file(image_name)) { + char *legacy = case_inverted_path(path); + if (probe_file(legacy)) { + image_name = legacy; + } + } +#endif + return image_name; +} +#endif + + + +char *program_name = NULL; +#ifdef WINDOWS +wchar_t *real_executable_name = NULL; +#else +char *real_executable_name = NULL; +#endif + +#ifndef WINDOWS + +char * +ensure_real_path(char *path) +{ + char buf[PATH_MAX*2], *p, *q; + int n; + + p = realpath(path, buf); + + if (p == NULL) { + return path; + } + n = strlen(p); + q = malloc(n+1); + strcpy(q,p); + return q; +} + +char * +determine_executable_name(char *argv0) +{ +#ifdef DARWIN + uint32_t len = 1024; + char exepath[1024], *p = NULL; + + if (_NSGetExecutablePath(exepath, (void *)&len) == 0) { + p = malloc(len+1); + memmove(p, exepath, len); + p[len]=0; + return ensure_real_path(p); + } + return ensure_real_path(argv0); +#endif +#ifdef LINUX + char exepath[PATH_MAX], *p; + int n; + + if ((n = readlink("/proc/self/exe", exepath, PATH_MAX)) > 0) { + p = malloc(n+1); + memmove(p,exepath,n); + p[n]=0; + return p; + } + return argv0; +#endif +#ifdef FREEBSD + return ensure_real_path(argv0); +#endif +#ifdef SOLARIS + char exepath[PATH_MAX], proc_path[PATH_MAX], *p; + int n; + + snprintf(proc_path,PATH_MAX-1,"/proc/%d/path/a.out",getpid()); + + if ((n = readlink(proc_path, exepath, PATH_MAX)) > 0) { + p = malloc(n+1); + memmove(p,exepath,n); + p[n]=0; + return p; + } + return ensure_real_path(argv0); +#endif + return ensure_real_path(argv0); +} +#endif + +#ifdef WINDOWS +wchar_t * +determine_executable_name() +{ + DWORD nsize = 512, result; + wchar_t *buf = malloc(nsize*sizeof(wchar_t)); + + do { + result = GetModuleFileNameW(NULL, buf, nsize); + if (result == nsize) { + nsize *= 2; + buf = realloc(buf,nsize*sizeof(wchar_t)); + } else { + return buf; + } + } while (1); +} + + +wchar_t * +ensure_real_path(wchar_t *path) +{ + int bufsize = 256, n; + + do { + wchar_t buf[bufsize]; + + n = GetFullPathNameW(path,bufsize,buf,NULL); + if (n == 0) { + return path; + } + + if (n < bufsize) { + int i; + wchar_t *q = calloc(n+1,sizeof(wchar_t)); + + for (i = 0; i < n; i++) { + q[i] = buf[i]; + } + return q; + } + bufsize = n+1; + } while (1); +} +#endif + +void +usage_exit(char *herald, int exit_status, char* other_args) +{ + if (herald && *herald) { + fprintf(dbgout, "%s\n", herald); + } + fprintf(dbgout, "usage: %s \n", program_name); + fprintf(dbgout, "\t or %s \n", program_name); + fprintf(dbgout, "\t where are one or more of:\n"); + if (other_args && *other_args) { + fputs(other_args, dbgout); + } + fprintf(dbgout, "\t-R, --heap-reserve : reserve (default: %lld)\n", + (u64_t) reserved_area_size); + fprintf(dbgout, "\t\t bytes for heap expansion\n"); + fprintf(dbgout, "\t-S, --stack-size : set size of initial thread's control stack to \n"); + fprintf(dbgout, "\t-Z, --thread-stack-size : set default size of first (listener) thread's stacks based on \n"); + fprintf(dbgout, "\t-b, --batch: exit when EOF on *STANDARD-INPUT*\n"); + fprintf(dbgout, "\t--no-sigtrap : obscure option for running under GDB\n"); + fprintf(dbgout, "\t-I, --image-name \n"); +#ifndef WINDOWS + fprintf(dbgout, "\t and defaults to %s\n", + default_image_name(program_name)); +#endif + fprintf(dbgout, "\n"); + _exit(exit_status); +} + +int no_sigtrap = 0; +#ifdef WINDOWS +wchar_t *image_name = NULL; +#else +char *image_name = NULL; +#endif +int batch_flag = 0; + + +natural +parse_numeric_option(char *arg, char *argname, natural default_val) +{ + char *tail; + natural val = 0; + + val = strtoul(arg, &tail, 0); + switch(*tail) { + case '\0': + break; + + case 'M': + case 'm': + val = val << 20; + break; + + case 'K': + case 'k': + val = val << 10; + break; + + case 'G': + case 'g': + val = val << 30; + break; + + default: + fprintf(dbgout, "couldn't parse %s argument %s", argname, arg); + val = default_val; + break; + } + return val; +} + + + +/* + The set of arguments recognized by the kernel is + likely to remain pretty small and pretty simple. + This removes everything it recognizes from argv; + remaining args will be processed by lisp code. +*/ + +void +process_options(int argc, char *argv[], wchar_t *shadow[]) +{ + int i, j, k, num_elide, flag, arg_error; + char *arg, *val; + wchar_t *warg, *wval; +#ifdef DARWIN + extern int NXArgc; +#endif + + for (i = 1; i < argc;) { + arg = argv[i]; + if (shadow) { + warg = shadow[i]; + } + arg_error = 0; + if (*arg != '-') { + i++; + } else { + num_elide = 0; + val = NULL; + if ((flag = (strncmp(arg, "-I", 2) == 0)) || + (strcmp (arg, "--image-name") == 0)) { + if (flag && arg[2]) { + val = arg+2; + if (shadow) { + wval = warg+2; + } + num_elide = 1; + } else { + if ((i+1) < argc) { + val = argv[i+1]; + if (shadow) { + wval = shadow[i+1]; + } + num_elide = 2; + } else { + arg_error = 1; + } + } + if (val) { +#ifdef WINDOWS + image_name = wval; +#else + image_name = val; +#endif + } + } else if ((flag = (strncmp(arg, "-R", 2) == 0)) || + (strcmp(arg, "--heap-reserve") == 0)) { + natural reserved_size = reserved_area_size; + + if (flag && arg[2]) { + val = arg+2; + num_elide = 1; + } else { + if ((i+1) < argc) { + val = argv[i+1]; + num_elide = 2; + } else { + arg_error = 1; + } + } + + if (val) { + reserved_size = parse_numeric_option(val, + "-R/--heap-reserve", + reserved_area_size); + } + + if (reserved_size <= MAXIMUM_MAPPABLE_MEMORY) { + reserved_area_size = reserved_size; + } + + } else if ((flag = (strncmp(arg, "-S", 2) == 0)) || + (strcmp(arg, "--stack-size") == 0)) { + natural stack_size; + + if (flag && arg[2]) { + val = arg+2; + num_elide = 1; + } else { + if ((i+1) < argc) { + val = argv[i+1]; + num_elide = 2; + } else { + arg_error = 1; + } + } + + if (val) { + stack_size = parse_numeric_option(val, + "-S/--stack-size", + initial_stack_size); + + + if (stack_size >= MIN_CSTACK_SIZE) { + initial_stack_size = stack_size; + } + } + + } else if ((flag = (strncmp(arg, "-Z", 2) == 0)) || + (strcmp(arg, "--thread-stack-size") == 0)) { + natural stack_size; + + if (flag && arg[2]) { + val = arg+2; + num_elide = 1; + } else { + if ((i+1) < argc) { + val = argv[i+1]; + num_elide = 2; + } else { + arg_error = 1; + } + } + + if (val) { + stack_size = parse_numeric_option(val, + "-Z/--thread-stack-size", + thread_stack_size); + + + if (stack_size >= MIN_CSTACK_SIZE) { + thread_stack_size = stack_size; + } + if (thread_stack_size >= (1LL<<((WORD_SIZE-fixnumshift)-1))) { + thread_stack_size = (1LL<<((WORD_SIZE-fixnumshift)-1))-1; + } + + } + + } else if (strcmp(arg, "--no-sigtrap") == 0) { + no_sigtrap = 1; + num_elide = 1; + } else if ((strcmp(arg, "-b") == 0) || + (strcmp(arg, "--batch") == 0)) { + batch_flag = 1; + num_elide = 1; + } else if (strcmp(arg,"--") == 0) { + break; + } else { + i++; + } + if (arg_error) { + usage_exit("error in program arguments", 1, ""); + } + if (num_elide) { + for (j = i+num_elide, k=i; j < argc; j++, k++) { + argv[k] = argv[j]; + if (shadow) { + shadow[k] = shadow[j]; + } + } + argc -= num_elide; +#ifdef DARWIN + NXArgc -= num_elide; +#endif + argv[argc] = NULL; + if (shadow) { + shadow[argc] = NULL; + } + } + } + } +} + +#ifdef WINDOWS +void +terminate_lisp() +{ + _exit(EXIT_FAILURE); +} +#else +pid_t main_thread_pid = (pid_t)0; + +void +terminate_lisp() +{ + kill(main_thread_pid, SIGKILL); + _exit(-1); +} +#endif + +#ifdef DARWIN +#define min_os_version "8.0" /* aka Tiger */ +#endif +#ifdef LINUX +#ifdef PPC +#define min_os_version "2.2" +#endif +#ifdef X86 +#define min_os_version "2.6" +#endif +#endif +#ifdef FREEBSD +#define min_os_version "6.0" +#endif +#ifdef SOLARIS +#define min_os_version "5.10" +#endif + +#ifdef PPC +#if defined(PPC64) || !defined(DARWIN) +/* ld64 on Darwin doesn't offer anything close to reliable control + over the layout of a program in memory. About all that we can + be assured of is that the canonical subprims jump table address + (currently 0x5000) is unmapped. Map that page, and copy the + actual spjump table there. */ + + +void +remap_spjump() +{ + extern opcode spjump_start, spjump_end; + pc new, + old = &spjump_start, + limit = &spjump_end, + work; + opcode instr; + void *target; + int disp; + + if (old != (pc)SPJUMP_TARGET_ADDRESS) { + new = mmap((pc) SPJUMP_TARGET_ADDRESS, + 0x1000, + PROT_READ | PROT_WRITE | PROT_EXEC, + MAP_PRIVATE | MAP_ANON | MAP_FIXED, + -1, + 0); + if (new != (pc) SPJUMP_TARGET_ADDRESS) { + perror("remap spjump"); + _exit(1); + } + + for (work = new; old < limit; work++, old++) { + instr = *old; + disp = instr & ((1<<26)-1); + target = (void*)old+disp; + disp = target-(void *)work; + *work = ((instr >> 26) << 26) | disp; + } + xMakeDataExecutable(new, (void*)work-(void*)new); + ProtectMemory(new, 0x1000); + } +} +#endif +#endif + +#ifdef X86 +#ifdef WINDOWS + +/* By using linker tricks, we ensure there's memory between 0x11000 + and 0x21000, so we just need to fix permissions and copy the spjump + table. */ + +void +remap_spjump() +{ + extern opcode spjump_start; + DWORD old_protect; + + if ((void *)(&spjump_start) != (void *) SPJUMP_TARGET_ADDRESS) { + if (!VirtualProtect((pc) SPJUMP_TARGET_ADDRESS, + 0x1000, + PAGE_EXECUTE_READWRITE, + &old_protect)) { + wperror("VirtualProtect spjump"); + _exit(1); + } + memmove((pc) SPJUMP_TARGET_ADDRESS, &spjump_start, 0x1000); + } +} +#else +void +remap_spjump() +{ + extern opcode spjump_start; + pc new = mmap((pc) SPJUMP_TARGET_ADDRESS, + 0x1000, + PROT_READ | PROT_WRITE | PROT_EXEC, + MAP_PRIVATE | MAP_ANON | MAP_FIXED, + -1, + 0), + old = &spjump_start; + if (new == (pc)-1) { + perror("remap spjump"); + _exit(1); + } + memmove(new, old, 0x1000); +} +#endif +#endif + + +void +check_os_version(char *progname) +{ +#ifdef WINDOWS + /* We should be able to run with any version of Windows that actually gets here executing the binary, so don't do anything for now. */ +#else + struct utsname uts; + long got, want; + char *got_end,*want_end; +#ifdef X8632 + extern Boolean rcontext_readonly; +#endif + + want = strtoul(min_os_version,&want_end,10); + + uname(&uts); + got = strtoul(uts.release,&got_end,10); +#ifdef X8632 +#ifdef FREEBSD + if (!strcmp(uts.machine,"amd64")) { + rcontext_readonly = true; + } +#endif +#endif + while (got == want) { + if (*want_end == '.') { + want = strtoul(want_end+1,&want_end,10); + got = 0; + if (*got_end == '.') { + got = strtoul(got_end+1,&got_end,10); + } else { + break; + } + } else { + break; + } + } + + if (got < want) { + fprintf(dbgout, "\n%s requires %s version %s or later; the current version is %s.\n", progname, uts.sysname, min_os_version, uts.release); + exit(1); + } +#endif +} + +#ifdef X86 +/* + This should determine the cache block size. It should also + probably complain if we don't have (at least) SSE2. +*/ +extern int cpuid(natural, natural*, natural*, natural*); + +#define X86_FEATURE_CMOV (1<<15) +#define X86_FEATURE_CLFLUSH (1<<19) +#define X86_FEATURE_MMX (1<<23) +#define X86_FEATURE_SSE (1<<25) +#define X86_FEATURE_SSE2 (1<<26) + +#define X86_REQUIRED_FEATURES (X86_FEATURE_CMOV|X86_FEATURE_MMX|X86_FEATURE_SSE|X86_FEATURE_SSE2) + +Boolean +check_x86_cpu() +{ + natural eax, ebx, ecx, edx; + + eax = cpuid(0, &ebx, &ecx, &edx); + + if (eax >= 1) { + eax = cpuid(1, &ebx, &ecx, &edx); + cache_block_size = (ebx & 0xff00) >> 5; + if ((X86_REQUIRED_FEATURES & edx) == X86_REQUIRED_FEATURES) { + return true; + } + /* It's very unlikely that SSE2 would be present and other things + that we want wouldn't. If they don't have MMX or CMOV either, + might as well tell them. */ + if ((edx & X86_FEATURE_SSE2) == 0) { + fprintf(dbgout, "This CPU doesn't support the SSE2 instruction set\n"); + } + if ((edx & X86_FEATURE_MMX) == 0) { + fprintf(dbgout, "This CPU doesn't support the MMX instruction set\n"); + } + if ((edx & X86_FEATURE_CMOV) == 0) { + fprintf(dbgout, "This CPU doesn't support the CMOV instruction\n"); + } + + } + return false; +} +#endif + +void +lazarus() +{ + TCR *tcr = get_tcr(false); + if (tcr) { + /* Some threads may be dying; no threads should be created. */ + LOCK(lisp_global(TCR_AREA_LOCK),tcr); + tcr->vs_area->active = tcr->vs_area->high - node_size; + tcr->save_vsp = (LispObj *)(tcr->vs_area->active); + tcr->ts_area->active = tcr->ts_area->high; + tcr->save_tsp = (LispObj *)(tcr->ts_area->active); + tcr->catch_top = 0; + tcr->db_link = 0; + tcr->xframe = 0; + start_lisp(tcr, 0); + } +} + +#ifdef LINUX +#ifdef X8664 +#include +#include + +void +ensure_gs_available(char *progname) +{ + LispObj fs_addr = 0L, gs_addr = 0L, cur_thread = (LispObj)pthread_self(); + char *gnu_get_libc_version(void); + + arch_prctl(ARCH_GET_GS, &gs_addr); + arch_prctl(ARCH_GET_FS, &fs_addr); + if ((gs_addr == cur_thread) && (fs_addr != cur_thread)) { + fprintf(dbgout, "The installed C library - version %s - seems to be using the %%gs register for thread storage.\n\"%s\" cannot run, since it expects to be\nable to use that register for its own purposes.\n", gnu_get_libc_version(),progname); + _exit(1); + } +} +#endif +#endif + +Boolean +bogus_fp_exceptions = false; + +typedef +float (*float_arg_returns_float)(float); + +float +fcallf(float_arg_returns_float fun, float arg) +{ + return fun(arg); +} + +void +check_bogus_fp_exceptions() +{ +#ifdef X8664 + float asinf(float),result; + + + natural save_mxcsr = get_mxcsr(), post_mxcsr; + set_mxcsr(0x1f80); + + result = fcallf(asinf, 1.0); + post_mxcsr = get_mxcsr(); + set_mxcsr(save_mxcsr); + if (post_mxcsr & (FE_ALL_EXCEPT & (~FE_INEXACT))) { + bogus_fp_exceptions = true; + } +#endif +} + +#ifdef WINDOWS +char * +utf_16_to_utf_8(wchar_t *utf_16) +{ + int utf8len = WideCharToMultiByte(CP_UTF8, + 0, + utf_16, + -1, + NULL, + 0, + NULL, + NULL); + + char *utf_8 = malloc(utf8len); + + WideCharToMultiByte(CP_UTF8, + 0, + utf_16, + -1, + utf_8, + utf8len, + NULL, + NULL); + + return utf_8; +} + +char ** +wide_argv_to_utf_8(wchar_t *wide_argv[], int argc) +{ + char** argv = calloc(argc+1,sizeof(char *)); + int i; + + for (i = 0; i < argc; i++) { + if (wide_argv[i]) { + argv[i] = utf_16_to_utf_8(wide_argv[i]); + } else { + argv[i] = NULL; + } + } + return argv; +} +#endif + + + + + +int +main(int argc, char *argv[] +#ifndef WINDOWS +, char *envp[], void *aux +#endif +) +{ + extern int page_size; + natural default_g0_threshold = G0_AREA_THRESHOLD, + default_g1_threshold = G1_AREA_THRESHOLD, + default_g2_threshold = G2_AREA_THRESHOLD, + lisp_heap_threshold_from_image = 0; + Boolean egc_enabled = +#ifdef DISABLE_EGC + false +#else + true +#endif + ; + Boolean lisp_heap_threshold_set_from_command_line = false; + wchar_t **utf_16_argv = NULL; + +#ifdef PPC + extern int altivec_present; +#endif +#ifdef WINDOWS + extern LispObj load_image(wchar_t *); +#else + extern LispObj load_image(char *); +#endif + area *a; + BytePtr stack_base, current_sp = (BytePtr) current_stack_pointer(); + TCR *tcr; + + dbgout = stderr; + +#ifdef WINDOWS + { + int wide_argc; + extern void init_winsock(void); + extern void init_windows_io(void); + + _fmode = O_BINARY; + _setmode(1, O_BINARY); + _setmode(2, O_BINARY); + setvbuf(dbgout, NULL, _IONBF, 0); + init_winsock(); + init_windows_io(); + utf_16_argv = CommandLineToArgvW(GetCommandLineW(),&wide_argc); + } +#endif + + check_os_version(argv[0]); +#ifdef WINDOWS + real_executable_name = determine_executable_name(); +#else + real_executable_name = determine_executable_name(argv[0]); +#endif + page_size = getpagesize(); /* Implement with GetSystemInfo on Windows w/o MinGW */ + + check_bogus_fp_exceptions(); +#ifdef LINUX +#ifdef X8664 + ensure_gs_available(real_executable_name); +#endif +#endif +#if (defined(DARWIN) && defined(PPC64)) || (defined(LINUX) && defined(PPC))|| defined(X8664) || (defined(X8632) && !defined(DARWIN)) + remap_spjump(); +#endif + +#ifdef PPC +#ifdef LINUX + { + ElfW(auxv_t) *av = aux; + int hwcap, done = false; + + if (av) { + do { + switch (av->a_type) { + case AT_DCACHEBSIZE: + cache_block_size = av->a_un.a_val; + break; + + case AT_HWCAP: + hwcap = av->a_un.a_val; + altivec_present = ((hwcap & PPC_FEATURE_HAS_ALTIVEC) != 0); + break; + + case AT_NULL: + done = true; + break; + } + av++; + } while (!done); + } + } +#endif +#ifdef DARWIN + { + unsigned value = 0; + size_t len = sizeof(value); + int mib[2]; + + mib[0] = CTL_HW; + mib[1] = HW_CACHELINE; + if (sysctl(mib,2,&value,&len, NULL, 0) != -1) { + if (len == sizeof(value)) { + cache_block_size = value; + } + } + mib[1] = HW_VECTORUNIT; + value = 0; + len = sizeof(value); + if (sysctl(mib,2,&value,&len, NULL, 0) != -1) { + if (len == sizeof(value)) { + altivec_present = value; + } + } + } +#endif +#endif + +#ifdef X86 + if (!check_x86_cpu()) { + fprintf(dbgout, "CPU doesn't support required features\n"); + exit(1); + } +#endif + +#ifdef SOLARIS +#ifdef X8632 + { + extern void solaris_ldt_init(void); + solaris_ldt_init(); + } +#endif +#endif + +#ifndef WINDOWS + main_thread_pid = getpid(); +#endif + tcr_area_lock = (void *)new_recursive_lock(); + + program_name = argv[0]; + if ((argc == 2) && (*argv[1] != '-')) { +#ifdef WINDOWS + image_name = utf_16_argv[1]; +#else + image_name = argv[1]; +#endif + argv[1] = NULL; +#ifdef WINDOWS + utf_16_argv[1] = NULL; +#endif + } else { + process_options(argc,argv,utf_16_argv); + } + if (lisp_heap_gc_threshold != DEFAULT_LISP_HEAP_GC_THRESHOLD) { + lisp_heap_threshold_set_from_command_line = true; + } + + initial_stack_size = ensure_stack_limit(initial_stack_size); + if (image_name == NULL) { + if (check_for_embedded_image(real_executable_name)) { + image_name = real_executable_name; + } else { + image_name = default_image_name(real_executable_name); + } + } + + while (1) { + if (create_reserved_area(reserved_area_size)) { + break; + } + reserved_area_size = reserved_area_size *.9; + } + + gc_init(); + + set_nil(load_image(image_name)); + lisp_heap_threshold_from_image = lisp_global(LISP_HEAP_THRESHOLD); + if (lisp_heap_threshold_from_image) { + if ((!lisp_heap_threshold_set_from_command_line) && + (lisp_heap_threshold_from_image != lisp_heap_gc_threshold)) { + lisp_heap_gc_threshold = lisp_heap_threshold_from_image; + resize_dynamic_heap(active_dynamic_area->active,lisp_heap_gc_threshold); + } + /* If lisp_heap_threshold_from_image was set, other image params are + valid. */ + default_g0_threshold = lisp_global(G0_THRESHOLD); + default_g1_threshold = lisp_global(G1_THRESHOLD); + default_g2_threshold = lisp_global(G2_THRESHOLD); + egc_enabled = lisp_global(EGC_ENABLED); + } + + lisp_global(TCR_AREA_LOCK) = ptr_to_lispobj(tcr_area_lock); + +#ifdef X86 + lisp_global(SUBPRIMS_BASE) = (LispObj)((1<<16)+(5<<10)); +#else + lisp_global(SUBPRIMS_BASE) = (LispObj)(5<<10); +#endif + lisp_global(RET1VALN) = (LispObj)&ret1valn; + lisp_global(LEXPR_RETURN) = (LispObj)&nvalret; + lisp_global(LEXPR_RETURN1V) = (LispObj)&popj; + lisp_global(ALL_AREAS) = ptr_to_lispobj(all_areas); + lisp_global(DEFAULT_ALLOCATION_QUANTUM) = log2_heap_segment_size << fixnumshift; + lisp_global(STACK_SIZE) = thread_stack_size<low; + + /* Create these areas as AREA_STATIC, change them to AREA_DYNAMIC */ + g1_area = new_area(lowptr, lowptr, AREA_STATIC); + g2_area = new_area(lowptr, lowptr, AREA_STATIC); + tenured_area = new_area(lowptr, lowptr, AREA_STATIC); + add_area_holding_area_lock(tenured_area); + add_area_holding_area_lock(g2_area); + add_area_holding_area_lock(g1_area); + + g1_area->code = AREA_DYNAMIC; + g2_area->code = AREA_DYNAMIC; + tenured_area->code = AREA_DYNAMIC; + +/* a->older = g1_area; */ /* Not yet: this is what "enabling the EGC" does. */ + g1_area->younger = a; + g1_area->older = g2_area; + g2_area->younger = g1_area; + g2_area->older = tenured_area; + tenured_area->younger = g2_area; + tenured_area->refbits = dynamic_mark_ref_bits; + managed_static_area->refbits = global_mark_ref_bits; + a->markbits = dynamic_mark_ref_bits; + tenured_area->static_dnodes = a->static_dnodes; + a->static_dnodes = 0; + tenured_area->static_used = a->static_used; + a->static_used = 0; + lisp_global(TENURED_AREA) = ptr_to_lispobj(tenured_area); + lisp_global(STATIC_CONS_AREA) = ptr_to_lispobj(static_cons_area); + lisp_global(REFBITS) = ptr_to_lispobj(global_mark_ref_bits); + g2_area->threshold = default_g2_threshold; + g1_area->threshold = default_g1_threshold; + a->threshold = default_g0_threshold; + } + + tcr = new_tcr(initial_stack_size, MIN_TSTACK_SIZE); + stack_base = initial_stack_bottom()-xStackSpace(); + init_threads((void *)(stack_base), tcr); + thread_init_tcr(tcr, current_sp, current_sp-stack_base); + + if (lisp_global(STATIC_CONSES) == 0) { + lisp_global(STATIC_CONSES) = lisp_nil; + } + + lisp_global(EXCEPTION_LOCK) = ptr_to_lispobj(new_recursive_lock()); + enable_fp_exceptions(); + register_user_signal_handler(); + +#ifdef PPC + lisp_global(ALTIVEC_PRESENT) = altivec_present << fixnumshift; +#endif +#if STATIC + lisp_global(STATICALLY_LINKED) = 1 << fixnumshift; +#endif + tcr->prev = tcr->next = tcr; +#ifndef WINDOWS + lisp_global(INTERRUPT_SIGNAL) = (LispObj) box_fixnum(SIGNAL_FOR_PROCESS_INTERRUPT); +#endif + tcr->vs_area->active -= node_size; + *(--tcr->save_vsp) = nrs_TOPLFUNC.vcell; + nrs_TOPLFUNC.vcell = lisp_nil; +#ifdef GC_INTEGRITY_CHECKING + (nrs_GC_EVENT_STATUS_BITS.vcell |= gc_integrity_check_bit); +#endif + if (egc_enabled) { + egc_control(true, NULL); + } else { + lisp_global(OLDSPACE_DNODE_COUNT) = area_dnode(managed_static_area->active,managed_static_area->low); + } + atexit(lazarus); + start_lisp(TCR_TO_TSD(tcr), 0); + _exit(0); +} + +area * +set_nil(LispObj r) +{ + + if (lisp_nil == (LispObj)NULL) { + + lisp_nil = r; + } + return NULL; +} + + +void +xMakeDataExecutable(void *start, unsigned long nbytes) +{ +#ifndef X86 + extern void flush_cache_lines(); + natural ustart = (natural) start, base, end; + + base = (ustart) & ~(cache_block_size-1); + end = (ustart + nbytes + cache_block_size - 1) & ~(cache_block_size-1); + flush_cache_lines(base, (end-base)/cache_block_size, cache_block_size); +#endif +} + +natural +xStackSpace() +{ + return initial_stack_size+CSTACK_HARDPROT+CSTACK_SOFTPROT; +} + +#ifndef DARWIN +#ifdef WINDOWS +extern void *windows_open_shared_library(char *); + +void * +xGetSharedLibrary(char *path, int mode) +{ + return windows_open_shared_library(path); +} +#else +void * +xGetSharedLibrary(char *path, int mode) +{ + return dlopen(path, mode); +} +#endif +#else +void * +xGetSharedLibrary(char *path, int *resultType) +{ +#if 0 + NSObjectFileImageReturnCode code; + NSObjectFileImage moduleImage; + NSModule module; + const struct mach_header * header; + const char * error; + void * result; + /* not thread safe */ + /* + static struct { + const struct mach_header *header; + NSModule *module; + const char *error; + } results; + */ + result = NULL; + error = NULL; + + /* first try to open this as a bundle */ + code = NSCreateObjectFileImageFromFile(path,&moduleImage); + if (code != NSObjectFileImageSuccess && + code != NSObjectFileImageInappropriateFile && + code != NSObjectFileImageAccess) + { + /* compute error strings */ + switch (code) + { + case NSObjectFileImageFailure: + error = "NSObjectFileImageFailure"; + break; + case NSObjectFileImageArch: + error = "NSObjectFileImageArch"; + break; + case NSObjectFileImageFormat: + error = "NSObjectFileImageFormat"; + break; + case NSObjectFileImageAccess: + /* can't find the file */ + error = "NSObjectFileImageAccess"; + break; + default: + error = "unknown error"; + } + *resultType = 0; + return (void *)error; + } + if (code == NSObjectFileImageInappropriateFile || + code == NSObjectFileImageAccess ) { + /* the pathname might be a partial pathane (hence the access error) + or it might be something other than a bundle, if so perhaps + it is a .dylib so now try to open it as a .dylib */ + + /* protect against redundant loads, Gary Byers noticed possible + heap corruption if this isn't done */ + header = NSAddImage(path, NSADDIMAGE_OPTION_RETURN_ON_ERROR | + NSADDIMAGE_OPTION_WITH_SEARCHING | + NSADDIMAGE_OPTION_RETURN_ONLY_IF_LOADED); + if (!header) + header = NSAddImage(path, NSADDIMAGE_OPTION_RETURN_ON_ERROR | + NSADDIMAGE_OPTION_WITH_SEARCHING); + result = (void *)header; + *resultType = 1; + } + else if (code == NSObjectFileImageSuccess) { + /* we have a sucessful module image + try to link it, don't bind symbols privately */ + + module = NSLinkModule(moduleImage, path, + NSLINKMODULE_OPTION_RETURN_ON_ERROR | NSLINKMODULE_OPTION_BINDNOW); + NSDestroyObjectFileImage(moduleImage); + result = (void *)module; + *resultType = 2; + } + if (!result) + { + /* compute error string */ + NSLinkEditErrors ler; + int lerno; + const char* file; + NSLinkEditError(&ler,&lerno,&file,&error); + if (error) { + result = (void *)error; + *resultType = 0; + } + } + return result; +#else + const char * error; + void * result; + + result = dlopen(path, RTLD_NOW | RTLD_GLOBAL); + + if (result == NULL) { + error = dlerror(); + *resultType = 0; + return (void *)error; + } + *resultType = 1; + return result; +#endif +} +#endif + + + +int +fd_setsize_bytes() +{ + return FD_SETSIZE/8; +} + +void +do_fd_set(int fd, fd_set *fdsetp) +{ + FD_SET(fd, fdsetp); +} + +void +do_fd_clr(int fd, fd_set *fdsetp) +{ + FD_CLR(fd, fdsetp); +} + +int +do_fd_is_set(int fd, fd_set *fdsetp) +{ + return FD_ISSET(fd,fdsetp); +} + + +void +do_fd_zero(fd_set *fdsetp) +{ + FD_ZERO(fdsetp); +} + +#include "image.h" + + + +Boolean +check_for_embedded_image ( +#ifdef WINDOWS + wchar_t *path +#else + char *path +#endif + ) +{ +#ifdef WINDOWS + int fd = wopen(path, O_RDONLY); +#else + int fd = open(path, O_RDONLY); +#endif + + Boolean image_is_embedded = false; + + if (fd >= 0) { + openmcl_image_file_header h; + + if (find_openmcl_image_file_header (fd, &h)) { + image_is_embedded = true; + } + close (fd); + } + return image_is_embedded; +} + +LispObj +load_image( +#ifdef WINDOWS + wchar_t * path +#else + char *path +#endif +) +{ +#ifdef WINDOWS + int fd = wopen(path, O_RDONLY, 0666), err; +#else + int fd = open(path, O_RDONLY, 0666), err; +#endif + LispObj image_nil = 0; + + if (fd > 0) { + openmcl_image_file_header ih; + + errno = 0; + image_nil = load_openmcl_image(fd, &ih); + /* We -were- using a duplicate fd to map the file; that + seems to confuse Darwin (doesn't everything ?), so + we'll instead keep the original file open. + */ + err = errno; + if (!image_nil) { + close(fd); + } +#ifdef WINDOWS + /* We currently don't actually map the image, and leaving the file + open seems to make it difficult to write to reliably. */ + if (image_nil) { + close(fd); + } +#endif + } else { + err = errno; + } + if (image_nil == 0) { + if (err == 0) { + fprintf(dbgout, "Couldn't load lisp heap image from %s\n", path); + } else { + fprintf(dbgout, "Couldn't load lisp heap image from %s:\n%s\n", path, strerror(err)); + } + exit(-1); + } + return image_nil; +} + +int +set_errno(int val) +{ + errno = val; + return -1; +} + +/* A horrible hack to allow us to initialize a JVM instance from lisp. + On Darwin, creating a JVM instance clobbers the thread's existing + Mach exception infrastructure, so we save and restore it here. +*/ + +typedef int (*jvm_initfunc)(void*,void*,void*); + +int +jvm_init(jvm_initfunc f,void*arg0,void*arg1,void*arg2) +{ + int result = -1; + TCR *tcr = get_tcr(1); +#ifdef DARWIN + extern kern_return_t tcr_establish_lisp_exception_port(TCR *); +#endif + + result = f(arg0,arg1,arg2); +#ifdef DARWIN + tcr_establish_lisp_exception_port(tcr); +#endif + return result; +} + + + + +void * +xFindSymbol(void* handle, char *name) +{ +#if defined(LINUX) || defined(FREEBSD) || defined(SOLARIS) + return dlsym(handle, name); +#endif +#ifdef DARWIN +#if 1 + void *result; + + if ((handle == NULL) || (handle == ((void *) -1))) { + handle = RTLD_DEFAULT; + } + result = dlsym(handle, name); + if ((result == NULL) && (*name == '_')) { + result = dlsym(handle, name+1); + } + return result; +#else + natural address = 0; + + if ((handle == NULL) || + (handle == (void *)-1) || + (handle == (void *)-2)){ + if (NSIsSymbolNameDefined(name)) { /* Keep dyld_lookup from crashing */ + _dyld_lookup_and_bind(name, (void *) &address, (void*) NULL); + } + return (void *)address; + } + Bug(NULL, "How did this happen ?"); +#endif +#endif +#ifdef WINDOWS + extern void *windows_find_symbol(void *, char *); + return windows_find_symbol(handle, name); +#endif +} + +void * +get_r_debug() +{ +#if defined(LINUX) || defined(FREEBSD) || defined(SOLARIS) +#if WORD_SIZE == 64 + extern Elf64_Dyn _DYNAMIC[]; + Elf64_Dyn *dp; +#else + extern Elf32_Dyn _DYNAMIC[]; + Elf32_Dyn *dp; +#endif + int tag; + + for (dp = _DYNAMIC; (tag = dp->d_tag) != 0; dp++) { + if (tag == DT_DEBUG) { + return (void *)(dp->d_un.d_ptr); + } + } +#endif + return NULL; +} + + +#ifdef DARWIN +void +sample_paging_info(paging_info *stats) +{ + mach_msg_type_number_t count = TASK_EVENTS_INFO_COUNT; + + task_info(mach_task_self(), + TASK_EVENTS_INFO, + (task_info_t)stats, + &count); +} + +void +report_paging_info_delta(FILE *out, paging_info *start, paging_info *stop) +{ + fprintf(out,";;; %d soft faults, %d faults, %d pageins\n\n", + stop->cow_faults-start->cow_faults, + stop->faults-start->faults, + stop->pageins-start->pageins); +} + +#else +#ifdef WINDOWS +void +sample_paging_info(paging_info *stats) +{ +} + +void +report_paging_info_delta(FILE *out, paging_info *start, paging_info *stop) +{ +} +#else +void +sample_paging_info(paging_info *stats) +{ + getrusage(RUSAGE_SELF, stats); +} + +void +report_paging_info_delta(FILE *out, paging_info *start, paging_info *stop) +{ + fprintf(out,";;; %ld soft faults, %ld faults, %ld pageins\n\n", + stop->ru_minflt-start->ru_minflt, + stop->ru_majflt-start->ru_majflt, + stop->ru_nswap-start->ru_nswap); +} + +#endif +#endif + +void +allocate_static_conses(natural n) +{ + BytePtr old_low = static_cons_area->low, + new_low = old_low - (n<low = new_low; + lower_heap_start(new_low, tenured_area); + /* what a mess this is ... */ + if (active_dynamic_area->low == old_low) { + active_dynamic_area->low = new_low; + } + if (!active_dynamic_area->older) { + active_dynamic_area->markbits = tenured_area->refbits; + } + if (g1_area->low == old_low) { + g1_area->low = new_low; + } + if (g1_area->high == old_low) { + g1_area->high = new_low; + } + if (g2_area->low == old_low) { + g2_area->low = new_low; + } + if (g2_area->high == old_low) { + g2_area->high = new_low; + } + for (i=0, prev=lisp_global(STATIC_CONSES), c=(cons *)new_low; + i < n; + i++, c++) { + c->cdr = prev; + prev = ((LispObj)c)+fulltag_cons; + } + lisp_global(STATIC_CONSES)=prev; + lisp_global(FREE_STATIC_CONSES)+=(n<>dnode_shift, have; + BytePtr p = a->high-nbytes; + + if (p < a->active) { + untenure_from_area(tenured_area); + gc_from_xp(xp, 0L); + } + + have = unbox_fixnum(lisp_global(FREE_STATIC_CONSES)); + if (have < nconses) { + if ((a->high-a->active)>nbytes) { + shrink_dynamic_area(nbytes); + } + allocate_static_conses(nconses); + tcr->bytes_allocated += nbytes; + } +} + Index: /branches/new-random/lisp-kernel/ppc-asmutils.s =================================================================== --- /branches/new-random/lisp-kernel/ppc-asmutils.s (revision 13309) +++ /branches/new-random/lisp-kernel/ppc-asmutils.s (revision 13309) @@ -0,0 +1,458 @@ +/* Copyright (C) 2009 Clozure Associates */ +/* Copyright (C) 1994-2001 Digitool, Inc */ +/* This file is part of Clozure CL. */ + +/* Clozure CL is licensed under the terms of the Lisp Lesser GNU Public */ +/* License , known as the LLGPL and distributed with Clozure CL as the */ +/* file "LICENSE". The LLGPL consists of a preamble and the LGPL, */ +/* which is distributed with Clozure CL as the file "LGPL". Where these */ +/* conflict, the preamble takes precedence. */ + +/* Clozure CL is referenced in the preamble as the "LIBRARY." */ + +/* The LLGPL is also available online at */ +/* http://opensource.franz.com/preamble.html */ + + + + + include(lisp.s) + + _beginfile +/* Zero R4 cache lines, starting at address in R3. Each line is assumed to be */ +/* R5 bytes wide. */ +_exportfn(C(zero_cache_lines)) + __(cmpri(cr0,r4,0)) + __(mtctr r4) + __(beqlr) +1: + __(DCBZL(0,r3)) + __(add r3,r3,r5) + __(bdnz 1b) + __(blr) +_endfn + +/* Flush R4 cache lines, starting at address in R3. Each line is */ +/* assumed to be R5 bytes wide. */ +_exportfn(C(flush_cache_lines)) + __(cmpri(cr0,r4,0)) + __(mtctr r4) + __(mr r6,r3) + __(beqlr) +1: + __(dcbst 0,r3) + __(add r3,r3,r5) + __(bdnz 1b) + __(sync) /* wait until dcbst's get to memory */ + __(mr r3,r6) + __(mtctr r4) +2: + __(icbi 0,r3) + __(add r3,r3,r5) + __(bdnz 2b) + __(sync) + __(isync) + __(blr) +/* The strange reference to "exp" is supposed to force the kernel to */ +/* load libm, so lisp code can use it. Under Darwin, the functionality */ +/* of libm is contained in libsystem, along with libc & everything else. */ + + __ifndef([DARWIN]) + .data + __ifdef([PPC64]) + .quad exp + __else + .long exp + __endif + .text + __endif +_endfn + +_exportfn(C(touch_page)) + __(str(r3,0(r3))) + __(li r4,0) + __(str(r4,0(r3))) + __(li r3,1) /* can't assume that low 32 bits of r3 are non-zero */ + .globl C(touch_page_end) +C(touch_page_end): + __(blr) +_endfn + +_exportfn(C(current_stack_pointer)) + __(mr r3,sp) + __(blr) +_endfn + +_exportfn(C(count_leading_zeros)) + __ifdef([PPC64]) + __(cntlzd r3,r3) + __else + __(cntlzw r3,r3) + __endif + __(blr) +_endfn + +_exportfn(C(noop)) + __(blr) +_endfn + +_exportfn(C(set_fpscr)) + __(stru(sp,-32(sp))) + __(stw r3,12(sp)) + __(lfd f0,8(sp)) + __(mtfsf 0xff,f0) + __(la sp,32(sp)) + __(blr) +_endfn + + +_exportfn(C(get_fpscr)) + __(stru(sp,-32(sp))) + __(mffs f0) + __(stfd f0,8(sp)) + __(lwz r3,12(sp)) + __(la sp,32(sp)) + __(blr) +_endfn + + +/* The Linux kernel is constantly enabling and disabling the FPU and enabling */ +/* FPU exceptions. We can't touch the FPU without turning off the FPSCR[FEX] */ +/* bit and we can't turn off the FPSCR[FEX] bit without touching the FPU. */ +/* Force a distinguished exception, and let the handler for that exception */ +/* zero the fpscr in its exception context. */ + +_exportfn(C(zero_fpscr)) + __(uuo_zero_fpscr()) + __(blr) +_endfn + + +_exportfn(C(save_fp_context)) + __(subi r4,r3,8) + __(stfdu f0,8(r4)) + __(stfdu f1,8(r4)) + __(stfdu f2,8(r4)) + __(stfdu f3,8(r4)) + __(stfdu f4,8(r4)) + __(stfdu f5,8(r4)) + __(stfdu f6,8(r4)) + __(stfdu f7,8(r4)) + __(stfdu f8,8(r4)) + __(stfdu f9,8(r4)) + __(stfdu f10,8(r4)) + __(stfdu f11,8(r4)) + __(stfdu f12,8(r4)) + __(stfdu f13,8(r4)) + __(stfdu f14,8(r4)) + __(stfdu f15,8(r4)) + __(stfdu f16,8(r4)) + __(stfdu f17,8(r4)) + __(stfdu f18,8(r4)) + __(stfdu f19,8(r4)) + __(stfdu f20,8(r4)) + __(stfdu f21,8(r4)) + __(stfdu f22,8(r4)) + __(stfdu f23,8(r4)) + __(stfdu f24,8(r4)) + __(stfdu f25,8(r4)) + __(stfdu f26,8(r4)) + __(stfdu f27,8(r4)) + __(stfdu f28,8(r4)) + __(stfdu f29,8(r4)) + __(stfdu f30,8(r4)) + __(stfdu f31,8(r4)) + __(mffs f0) + __(stfd f0,8(r4)) + __(lfd f0,0(r3)) + __(blr) +_endfn + +_exportfn(C(restore_fp_context)) + __(mr r4,r3) + __(lfdu f1,8(r4)) + __(lfdu f2,8(r4)) + __(lfdu f3,8(r4)) + __(lfdu f4,8(r4)) + __(lfdu f5,8(r4)) + __(lfdu f6,8(r4)) + __(lfdu f7,8(r4)) + __(lfdu f8,8(r4)) + __(lfdu f9,8(r4)) + __(lfdu f10,8(r4)) + __(lfdu f11,8(r4)) + __(lfdu f12,8(r4)) + __(lfdu f13,8(r4)) + __(lfdu f14,8(r4)) + __(lfdu f15,8(r4)) + __(lfdu f16,8(r4)) + __(lfdu f17,8(r4)) + __(lfdu f18,8(r4)) + __(lfdu f19,8(r4)) + __(lfdu f20,8(r4)) + __(lfdu f21,8(r4)) + __(lfdu f22,8(r4)) + __(lfdu f23,8(r4)) + __(lfdu f24,8(r4)) + __(lfdu f25,8(r4)) + __(lfdu f26,8(r4)) + __(lfdu f27,8(r4)) + __(lfdu f28,8(r4)) + __(lfdu f29,8(r4)) + __(lfdu f30,8(r4)) + __(lfdu f31,8(r4)) + __(lfd f0,8(r4)) + __(mtfsf 0xff,f0) + __(lfd f0,0(r3)) + __(blr) +_endfn + + + +/* Atomically store new value (r5) in *r3, if old value == expected. */ +/* Return actual old value. */ + +_exportfn(C(store_conditional)) + __(mr r6,r3) +1: __(lrarx(r3,0,r6)) + __(cmpw r3,r4) + __(bne- 2f) + __(strcx(r5,0,r6)) + __(bne- 1b) + __(isync) + __(blr) +2: __(li r0,RESERVATION_DISCHARGE) + __(strcx(r0,0,r0)) + __(blr) +_endfn + +/* Atomically store new_value(r4) in *r3 ; return previous contents */ +/* of *r3. */ + +_exportfn(C(atomic_swap)) + __(sync) +1: __(lrarx(r5,0,r3)) + __(strcx(r4,0,r3)) + __(bne- 1b) + __(isync) + __(mr r3,r5) + __(blr) +_endfn + +/* Logior the value in *r3 with the value in r4 (presumably a bitmask with exactly 1 */ +/* bit set.) Return non-zero if any of the bits in that bitmask were already set. */ + +_exportfn(C(atomic_ior)) + __(sync) +1: __(lrarx(r5,0,r3)) + __(or r6,r4,r5) + __(strcx(r6,0,r3)) + __(bne- 1b) + __(isync) + __(and r3,r4,r5) + __(blr) +_endfn + + +/* Logand the value in *r3 with the value in r4 (presumably a bitmask with exactly 1 */ +/* bit set.) Return the value now in *r3 (for some value of "now" */ + +_exportfn(C(atomic_and)) + __(sync) +1: __(lrarx(r5,0,r3)) + __(and r6,r4,r5) + __(strcx(r6,0,r3)) + __(bne- 1b) + __(isync) + __(mr r3,r6) + __(blr) +_endfn + + + __ifdef([DARWIN]) +_exportfn(C(enable_fp_exceptions)) + __(.long 0) + __(blr) +_endfn + +_exportfn(C(disable_fp_exceptions)) + __(.long 0) + __(blr) +_endfn + +_exportfn(C(pseudo_sigreturn)) + __(.long 0) + __(b C(pseudo_sigreturn)) +_endfn + __endif + +/* Copy all 32 Altivec registers (+ VSCR & VRSAVE) to the buffer */ +/* in r3. If the buffer's non-NULL, it's aligned and big enough, */ +/* and Altivec is present. */ + +_exportfn(C(put_vector_registers)) + __(cmpri(r3,0)) + __(li r4,0) + __(beqlr) + __(stvx v0,r3,r4) + __(la r4,16(r4)) + __(stvx v1,r3,r4) + __(la r4,16(r4)) + __(stvx v2,r3,r4) + __(la r4,16(r4)) + __(stvx v3,r3,r4) + __(la r4,16(r4)) + __(stvx v4,r3,r4) + __(la r4,16(r4)) + __(stvx v5,r3,r4) + __(la r4,16(r4)) + __(stvx v6,r3,r4) + __(la r4,16(r4)) + __(stvx v7,r3,r4) + __(la r4,16(r4)) + __(stvx v8,r3,r4) + __(la r4,16(r4)) + __(stvx v9,r3,r4) + __(la r4,16(r4)) + __(stvx v10,r3,r4) + __(la r4,16(r4)) + __(stvx v11,r3,r4) + __(la r4,16(r4)) + __(stvx v12,r3,r4) + __(la r4,16(r4)) + __(stvx v13,r3,r4) + __(la r4,16(r4)) + __(stvx v14,r3,r4) + __(la r4,16(r4)) + __(stvx v15,r3,r4) + __(la r4,16(r4)) + __(stvx v16,r3,r4) + __(la r4,16(r4)) + __(stvx v17,r3,r4) + __(la r4,16(r4)) + __(stvx v18,r3,r4) + __(la r4,16(r4)) + __(stvx v19,r3,r4) + __(la r4,16(r4)) + __(stvx v20,r3,r4) + __(la r4,16(r4)) + __(stvx v21,r3,r4) + __(la r4,16(r4)) + __(stvx v22,r3,r4) + __(la r4,16(r4)) + __(stvx v23,r3,r4) + __(la r4,16(r4)) + __(stvx v24,r3,r4) + __(la r4,16(r4)) + __(stvx v25,r3,r4) + __(la r4,16(r4)) + __(stvx v26,r3,r4) + __(la r4,16(r4)) + __(stvx v27,r3,r4) + __(la r4,16(r4)) + __(stvx v28,r3,r4) + __(la r4,16(r4)) + __(stvx v29,r3,r4) + __(la r4,16(r4)) + __(stvx v30,r3,r4) + __(la r4,16(r4)) + __(stvx v31,r3,r4) + __(la r4,16(r4)) + __(mfvscr v0) + __(stvx v0,r3,r4) + __(mfspr r5,256) + __(stw r5,8(r4)) + __(blr) +_endfn + +_exportfn(C(get_vector_registers)) + __(cmpri(r3,0)) + __(li r4,32*16) + __(beqlr) + __(lvx v0,r3,r4) + __(mtvscr v0) + __(lwz r5,8(r4)) + __(mtspr 256,r5) + __(la r4,-16(r4)) + __(lvx v31,r3,r4) + __(la r4,-16(r4)) + __(lvx v30,r3,r4) + __(la r4,-16(r4)) + __(lvx v29,r3,r4) + __(la r4,-16(r4)) + __(lvx v28,r3,r4) + __(la r4,-16(r4)) + __(lvx v27,r3,r4) + __(la r4,-16(r4)) + __(lvx v26,r3,r4) + __(la r4,-16(r4)) + __(lvx v25,r3,r4) + __(la r4,-16(r4)) + __(lvx v24,r3,r4) + __(la r4,-16(r4)) + __(lvx v23,r3,r4) + __(la r4,-16(r4)) + __(lvx v22,r3,r4) + __(la r4,-16(r4)) + __(lvx v21,r3,r4) + __(la r4,-16(r4)) + __(lvx v20,r3,r4) + __(la r4,-16(r4)) + __(lvx v19,r3,r4) + __(la r4,-16(r4)) + __(lvx v18,r3,r4) + __(la r4,-16(r4)) + __(lvx v17,r3,r4) + __(la r4,-16(r4)) + __(lvx v16,r3,r4) + __(la r4,-16(r4)) + __(lvx v15,r3,r4) + __(la r4,-16(r4)) + __(lvx v14,r3,r4) + __(la r4,-16(r4)) + __(lvx v13,r3,r4) + __(la r4,-16(r4)) + __(lvx v12,r3,r4) + __(la r4,-16(r4)) + __(lvx v11,r3,r4) + __(la r4,-16(r4)) + __(lvx v10,r3,r4) + __(la r4,-16(r4)) + __(lvx v9,r3,r4) + __(la r4,-16(r4)) + __(lvx v8,r3,r4) + __(la r4,-16(r4)) + __(lvx v7,r3,r4) + __(la r4,-16(r4)) + __(lvx v6,r3,r4) + __(la r4,-16(r4)) + __(lvx v5,r3,r4) + __(la r4,-16(r4)) + __(lvx v4,r3,r4) + __(la r4,-16(r4)) + __(lvx v3,r3,r4) + __(la r4,-16(r4)) + __(lvx v2,r3,r4) + __(la r4,-16(r4)) + __(lvx v1,r3,r4) + __(la r4,-16(r4)) + __(lvx v0,r3,r4) + __(blr) +_endfn + +/* Some versions of Linux don't implement madvise(). That's */ +/* not catastrophic, but some versions of glibc will make a */ +/* big deal out of that at link time. This is here to try */ +/* to fool those versions of glibc. */ + + __ifdef([LINUX]) + .globl set_errno +_exportfn(C(madvise)) + __(li r0,205) /* _NR_madvise; see /usr/include/asm/unistd.h */ + __(sc) + __(bnslr) + __(b set_errno) +_endfn + __endif + + _endfile Index: /branches/new-random/lisp-kernel/ppc-constants.h =================================================================== --- /branches/new-random/lisp-kernel/ppc-constants.h (revision 13309) +++ /branches/new-random/lisp-kernel/ppc-constants.h (revision 13309) @@ -0,0 +1,92 @@ +/* + Copyright (C) 2009 Clozure Associates + Copyright (C) 1994-2001 Digitool, Inc + This file is part of Clozure CL. + + Clozure CL is licensed under the terms of the Lisp Lesser GNU Public + License , known as the LLGPL and distributed with Clozure CL as the + file "LICENSE". The LLGPL consists of a preamble and the LGPL, + which is distributed with Clozure CL as the file "LGPL". Where these + conflict, the preamble takes precedence. + + Clozure CL is referenced in the preamble as the "LIBRARY." + + The LLGPL is also available online at + http://opensource.franz.com/preamble.html +*/ + +#ifndef __ppc_constants__ +#define __ppc_constants__ 1 + +/* Register usage: */ +#define rzero 0 +#define sp 1 +#define linux_sys_reg 2 /* volatile reg on Darwin ; thread ptr on Linux32, TOC on + Linux64. */ +#define imm0 3 +#define imm1 4 +#define imm2 5 +#define imm3 6 +#define imm4 7 +#define imm5 8 +#define allocptr 9 +#define allocbase 10 +#define nargs 11 +#define tsp 12 +#define loc_pc 14 /* code vector locative */ +#define vsp 15 +#define fn 16 +#define temp3 17 +#define temp2 18 +#define temp1 19 +#define temp0 20 +#define arg_x 21 +#define arg_y 22 +#define arg_z 23 +#define save7 24 +#define save6 25 +#define save5 26 +#define save4 27 +#define save3 28 +#define save2 29 +#define save1 30 +#define save0 31 + +#define vfp save0 /* frame pointer if needed (stack consing). */ +#define fname temp3 +#define nfn temp2 +#define next_method_context temp1 +#define closure_data temp0 + + +#define BA_MASK ((unsigned) ((-1<<26) | (1<<1))) +#define BA_VAL ((unsigned) ((18<<26) | (1<<1))) + +#define TCR_FLAG_BIT_FOREIGN fixnumshift +#define TCR_FLAG_BIT_AWAITING_PRESET (fixnumshift+1) +#define TCR_FLAG_BIT_ALT_SUSPEND (fixnumshift+2) +#define TCR_FLAG_BIT_PROPAGATE_EXCEPTION (fixnumshift+3) +#define TCR_FLAG_BIT_SUSPEND_ACK_PENDING (fixnumshift+4) +#define TCR_FLAG_BIT_PENDING_EXCEPTION (fixnumshift+5) +#define TCR_FLAG_BIT_FOREIGN_EXCEPTION (fixnumshift+6) +#define TCR_FLAG_BIT_PENDING_SUSPEND (fixnumshift+7) + +#define TCR_STATE_FOREIGN (1) +#define TCR_STATE_LISP (0) +#define TCR_STATE_EXCEPTION_WAIT (2) +#define TCR_STATE_EXCEPTION_RETURN (4) + +#ifdef PPC64 +#include "ppc-constants64.h" +#else +#include "ppc-constants32.h" +#endif + +#define dnode_size (node_size*2) +#define dnode_shift (node_shift+1) + +#define INTERRUPT_LEVEL_BINDING_INDEX (1) + +#endif /* __ppc_constants__ */ + + Index: /branches/new-random/lisp-kernel/ppc-constants.s =================================================================== --- /branches/new-random/lisp-kernel/ppc-constants.s (revision 13309) +++ /branches/new-random/lisp-kernel/ppc-constants.s (revision 13309) @@ -0,0 +1,238 @@ +/* Copyright (C) 2004-2009 Clozure Associates */ +/* This file is part of Clozure CL. */ + +/* Clozure CL is licensed under the terms of the Lisp Lesser GNU Public */ +/* License , known as the LLGPL and distributed with Clozure CL as the */ +/* file "LICENSE". The LLGPL consists of a preamble and the LGPL, */ +/* which is distributed with Clozure CL as the file "LGPL". Where these */ +/* conflict, the preamble takes precedence. */ + +/* Clozure CL is referenced in the preamble as the "LIBRARY." */ + +/* The LLGPL is also available online at */ +/* http://opensource.franz.com/preamble.html */ + + +/* Register usage: */ + + +define([rzero],[r0]) +define([sp],[r1]) + +define([imm0],[r3]) +define([imm1],[r4]) +define([imm2],[r5]) +define([imm3],[r6]) +define([imm4],[r7]) +define([imm5],[r8]) +define([allocptr],[r9]) +define([allocbase],[r10]) +define([nargs],[r11]) +define([tsp],[r12]) /* temp-consing stack. */ + +define([loc_pc],[r14]) /* code vector locative */ +define([vsp],[r15]) +define([fn],[r16]) +define([temp3],[r17]) +define([temp2],[r18]) +define([temp1],[r19]) +define([temp0],[r20]) +define([arg_x],[r21]) +define([arg_y],[r22]) +define([arg_z],[r23]) +define([save7],[r24]) +define([save6],[r25]) +define([save5],[r26]) +define([save4],[r27]) +define([save3],[r28]) +define([save2],[r29]) +define([save1],[r30]) +define([save0],[r31]) + +define([fname],[temp3]) +define([nfn],[temp2]) +define([next_method_context],[temp1]) +define([first_nvr],[save7]) +define([second_nvr],[save6]) +define([third_nvr],[save5]) +define([fourth_nvr],[save4]) +define([fifth_nvr],[save3]) +define([sixth_nvr],[save2]) +define([seventh_nvr],[save1]) +define([eighth_nvr],[save0]) +define([nargregs],[3]) + +r0 = 0 +r1 = 1 +r2 = 2 +r3 = 3 +r4 = 4 +r5 = 5 +r6 = 6 +r7 = 7 +r8 = 8 +r9 = 9 +r10 = 10 +r11 = 11 +r12 = 12 +r13 = 13 +r14 = 14 +r15 = 15 +r16 = 16 +r17 = 17 +r18 = 18 +r19 = 19 +r20 = 20 +r21 = 21 +r22 = 22 +r23 = 23 +r24 = 24 +r25 = 25 +r26 = 26 +r27 = 27 +r28 = 28 +r29 = 29 +r30 = 30 +r31 = 31 + +/* Lisp code keeps 0.0 in fp_zero */ +define([fp_zero],[f31]) /* a non-volatile reg as far as FFI is concerned. */ +define([fp_s32conv],[f30]) /* for s32->fp conversion */ + +/* registers, as used in destrucuring-bind/macro-bind */ + +define([whole_reg],[temp1]) +define([arg_reg],[temp3]) +define([keyvect_reg],[temp2]) +define([mask_req_start],[24]) +define([mask_req_width],[8]) +define([mask_opt_start],[16]) +define([mask_opt_width],[8]) +define([mask_key_start],[8]) +define([mask_key_width],[8]) +define([mask_initopt],[7]) +define([mask_keyp],[6]) /* note that keyp can be true even when 0 keys. */ +define([mask_aok],[5]) +define([mask_restp],[4]) + +ifdef([DARWIN],[ + define([STACK_ALIGN],16) + define([STACK_ALIGN_MASK],15) +],[ + define([STACK_ALIGN],8) + define([STACK_ALIGN_MASK],7) +]) + +/* Indices in %builtin-functions% */ +_builtin_plus = 0 /* +-2 */ +_builtin_minus = 1 /* --2 */ +_builtin_times = 2 /* *-2 */ +_builtin_div = 3 /* /-2 */ +_builtin_eq = 4 /* =-2 */ +_builtin_ne = 5 /* /-2 */ +_builtin_gt = 6 /* >-2 */ +_builtin_ge = 7 /* >=-2 */ +_builtin_lt = 8 /* <-2 */ +_builtin_le = 9 /* <=-2 */ +_builtin_eql = 10 /* eql */ +_builtin_length = 11 /* length */ +_builtin_seqtype = 12 /* sequence-type */ +_builtin_assq = 13 /* assq */ +_builtin_memq = 14 /* memq */ +_builtin_logbitp = 15 /* logbitp */ +_builtin_logior = 16 /* logior-2 */ +_builtin_logand = 17 /* logand-2 */ +_builtin_ash = 18 /* ash */ +_builtin_negate = 19 /* %negate */ +_builtin_logxor = 20 /* logxor-2 */ +_builtin_aref1 = 21 /* %aref1 */ +_builtin_aset1 = 22 /* %aset1 */ + + /* FPSCR status bits */ +fpscr_FX = 0 +fpscr_FEX = 1 +fpscr_VX = 2 +fpscr_OX = 3 +fpscr_UX = 4 +fpscr_ZX = 5 +fpscr_XX = 6 + /* FPSCR control bits */ +fpscr_VE = 24 +fpscr_OE = 25 +fpscr_UE = 26 +fpscr_ZE = 27 +fpscr_XE = 28 + + +/* This should be (a) an (UNSIGNED-BYTE 16) and (b) one less than */ +/* TSTACK_SOFTPROT (defined in "area.h") */ + +tstack_alloc_limit = 0xffff + +define([TCR_STATE_FOREIGN],1) +define([TCR_STATE_LISP],0) +define([TCR_STATE_EXCEPTION_WAIT],2) +define([TCR_STATE_EXCEPTION_RETURN],4) + + + + +ifdef([PPC64],[ + include(ppc-constants64.s) +],[ + include(ppc-constants32.s) +]) + +num_lisp_globals = 48 /* MUST UPDATE THIS !!! */ + + _struct(lisp_globals,lisp_globals_limit-(num_lisp_globals*node_size)) + _node(initial_tcr) /* initial thread tcr */ + _node(image_name) /* --image-name argument */ + _node(BADfpscr_save_high) /* high word of FP reg used to save FPSCR */ + _node(unwind_resume) /* _Unwind_Resume */ + _node(batch_flag) /* -b */ + _node(host_platform) /* for runtime platform-specific stuff */ + _node(argv) /* address of argv[0] */ + _node(ref_base) /* start of oldest pointer-bearing area */ + _node(tenured_area) /* the tenured_area */ + _node(oldest_ephemeral) /* dword address of oldest ephemeral object or 0 */ + _node(lisp_exit_hook) /* install foreign exception_handling */ + _node(lisp_return_hook) /* install lisp exception_handling */ + _node(double_float_one) /* high half of 1.0d0 */ + _node(short_float_zero) /* low half of 1.0d0 */ + _node(objc2_end_catch) /* objc_end_catch() */ + _node(metering_info) /* address of lisp_metering global */ + _node(in_gc) /* non-zero when GC active */ + _node(lexpr_return1v) /* simpler when &lexpr called for single value. */ + _node(lexpr_return) /* magic &lexpr return code. */ + _node(all_areas) /* doubly-linked list of all memory areas */ + _node(kernel_path) /* real executable name */ + _node(objc2_begin_catch) /* objc_begin_catch */ + _node(stack_size) /* from command-line */ + _node(statically_linked) /* non-zero if -static */ + _node(heap_end) /* end of lisp heap */ + _node(heap_start) /* start of lisp heap */ + _node(gcable_pointers) /* linked-list of weak macptrs. */ + _node(gc_num) /* fixnum: GC call count. */ + _node(fwdnum) /* fixnum: GC "forwarder" call count. */ + _node(altivec_present) /* non-zero when AltiVec available */ + _node(oldspace_dnode_count) /* dynamic dnodes older than g0 start */ + _node(refbits) /* EGC refbits */ + _node(gc_inhibit_count) + _node(intflag) /* sigint pending */ + _node(BAD_block_tag_counter) /* counter for (immediate) block tag */ + _node(deleted_static_pairs) + _node(exception_lock) + _node(area_lock) + _node(tcr_key) /* tsd key for per-thread tcr */ + _node(ret1val_addr) /* address of "dynamic" subprims magic values return addr */ + _node(subprims_base) /* address of dynamic subprims jump table */ + _node(saveR13) /* probably don]t really need this */ + _node(saveTOC) /* where the 68K emulator stores the emulated regs */ + _node(objc_2_personality) /* exception "personality routine" address for ObjC 2.0 */ + _node(kernel_imports) /* some things we need imported for us */ + _node(interrupt_signal) /* signal used by PROCESS-INTERRUPT */ + _node(tcr_count) /* tcr_id for next tcr */ + _node(get_tcr) /* address of get_tcr() */ + _ends + Index: /branches/new-random/lisp-kernel/ppc-constants32.h =================================================================== --- /branches/new-random/lisp-kernel/ppc-constants32.h (revision 13309) +++ /branches/new-random/lisp-kernel/ppc-constants32.h (revision 13309) @@ -0,0 +1,475 @@ +/* + Copyright (C) 2009 Clozure Associates + Copyright (C) 1994-2001 Digitool, Inc + This file is part of Clozure CL. + + Clozure CL is licensed under the terms of the Lisp Lesser GNU Public + License , known as the LLGPL and distributed with Clozure CL as the + file "LICENSE". The LLGPL consists of a preamble and the LGPL, + which is distributed with Clozure CL as the file "LGPL". Where these + conflict, the preamble takes precedence. + + Clozure CL is referenced in the preamble as the "LIBRARY." + + The LLGPL is also available online at + http://opensource.franz.com/preamble.html +*/ + +#ifndef __constants32__ +#define __constants32__ 1 + +#define rcontext 13 + +#define nbits_in_word 32 +#define log2_nbits_in_word 5 +#define nbits_in_byte 8 +#define ntagbits 3 /* But only 2 are significant to lisp */ +#define nlisptagbits 2 +#define nfixnumtagbits 2 +#define num_subtag_bits 8 +#define fixnumshift 2 +#define fixnum_shift 2 +#define fulltagmask 7 +#define tagmask 3 +#define fixnummask 3 +#define subtagmask ((1< 4 (so that code-vector entry-points can be branched to, since the low */ +/* two bits of the PC are ignored) and that both FULLTAG-MISC and FULLTAG-IMM have header fulltags */ +/* that share the same TAG. */ +/* Things that walk memory (and the stack) have to be careful to look at the FULLTAG of each */ +/* object that they see. */ + +#define fulltag_even_fixnum 0 /* I suppose EVENP/ODDP might care; nothing else does. */ +#define fulltag_cons 1 /* a real (non_null) cons. Shares TAG with fulltag_nil. */ +#define fulltag_nodeheader 2 /* Header of heap_allocated object that contains lisp_object pointers */ +#define fulltag_imm 3 /* a "real" immediate object. Shares TAG with fulltag_immheader. */ +#define fulltag_odd_fixnum 4 /* */ +#define fulltag_nil 5 /* NIL and nothing but. (Note that there's still a hidden NILSYM.) */ +#define fulltag_misc 6 /* Pointer "real" tag_misc object. Shares TAG with fulltag_nodeheader. */ +#define fulltag_immheader 7 /* Header of heap-allocated object that contains unboxed data. */ + + + +/* Order of CAR and CDR doesn't seem to matter much - there aren't */ +/* too many tricks to be played with predecrement/preincrement addressing. */ +/* Keep them in the confusing MCL 3.0 order, to avoid confusion. */ + +typedef struct cons { + LispObj cdr; + LispObj car; +} cons; + + +#define misc_header_offset -fulltag_misc +#define misc_subtag_offset misc_header_offset+3 /* low byte of header */ +#define misc_data_offset misc_header_offset+4 /* first word of data */ +#define misc_dfloat_offset misc_header_offset+8 /* double-floats are doubleword-aligned */ + +#define max_64_bit_constant_index ((0x7fff + misc_dfloat_offset)>>3) +#define max_32_bit_constant_index ((0x7fff + misc_data_offset)>>2) +#define max_16_bit_constant_index ((0x7fff + misc_data_offset)>>1) +#define max_8_bit_constant_index (0x7fff + misc_data_offset) +#define max_1_bit_constant_index ((0x7fff + misc_data_offset)<<5) + +/* T is almost adjacent to NIL: since NIL is a misaligned CONS, it spans */ +/* two doublewords. The arithmetic difference between T and NIL is */ +/* such that the least-significant bit and exactly one other bit is */ +/* set in the result. */ + +#define t_offset (8+(8-fulltag_nil)+fulltag_misc) +#define t_value (lisp_nil+t_offset) + +/* The order in which various header values are defined is significant in several ways: */ +/* 1) Numeric subtags precede non-numeric ones; there are further orderings among numeric subtags. */ +/* 2) All subtags which denote CL arrays are preceded by those that don't, */ +/* with a further ordering which requires that (< header-arrayH header-vectorH ,@all-other-CL-vector-types) */ +/* 3) The element-size of ivectors is determined by the ordering of ivector subtags. */ +/* 4) All subtags are >= fulltag-immheader . */ + +#define SUBTAG(tag,subtag) ((tag) | ((subtag) << ntagbits)) +#define IMM_SUBTAG(subtag) SUBTAG(fulltag_immheader,(subtag)) +#define NODE_SUBTAG(subtag) SUBTAG(fulltag_nodeheader,(subtag)) + + +/* Numeric subtags. */ + +#define subtag_bignum IMM_SUBTAG(0) +#define min_numeric_subtag subtag_bignum + +#define subtag_ratio NODE_SUBTAG(1) +#define max_rational_subtag subtag_ratio + +#define subtag_single_float IMM_SUBTAG(1) +#define subtag_double_float IMM_SUBTAG(2) +#define min_float_subtag subtag_single_float +#define max_float_subtag subtag_double_float +#define max_real_subtag subtag_double_float + +#define subtag_complex NODE_SUBTAG(3) +#define max_numeric_subtag subtag_complex + + +/* CL array types. There are more immediate types than node types; all CL array subtags must be > than */ +/* all non-CL-array subtags. So we start by defining the immediate subtags in decreasing order, starting */ +/* with that subtag whose element size isn't an integral number of bits and ending with those whose */ +/* element size - like all non-CL-array fulltag-immheader types - is 32 bits. */ + +#define subtag_bit_vector IMM_SUBTAG(31) +#define subtag_double_float_vector IMM_SUBTAG(30) +#define subtag_s16_vector IMM_SUBTAG(29) +#define subtag_u16_vector IMM_SUBTAG(28) +#define min_16_bit_ivector_subtag subtag_u16_vector +#define max_16_bit_ivector_subtag subtag_s16_vector + +#define subtag_s8_vector IMM_SUBTAG(26) +#define subtag_u8_vector IMM_SUBTAG(25) +#define min_8_bit_ivector_subtag subtag_u8_vector +#define max_8_bit_ivector_subtag IMM_SUBTAG(27) + +#define subtag_simple_base_string IMM_SUBTAG(24) +#define subtag_fixnum_vector IMM_SUBTAG(23) +#define subtag_s32_vector IMM_SUBTAG(22) +#define subtag_u32_vector IMM_SUBTAG(21) +#define subtag_single_float_vector IMM_SUBTAG(20) +#define max_32_bit_ivector_subtag IMM_SUBTAG(24) +#define min_cl_ivector_subtag subtag_single_float_vector + + +#define subtag_vectorH NODE_SUBTAG(20) +#define subtag_arrayH NODE_SUBTAG(19) +#define subtag_simple_vector NODE_SUBTAG(21) /* Only one such subtag) */ +#define min_vector_subtag subtag_vectorH +#define min_array_subtag subtag_arrayH + +/* So, we get the remaining subtags (n: (n > max-numeric-subtag) & (n < min-array-subtag)) */ +/* for various immediate/node object types. */ + +#define subtag_macptr IMM_SUBTAG(3) +#define min_non_numeric_imm_subtag subtag_macptr + +#define subtag_dead_macptr IMM_SUBTAG(4) +#define subtag_code_vector IMM_SUBTAG(5) +#define subtag_creole IMM_SUBTAG(6) + +#define max_non_array_imm_subtag ((19<> 2) - 3) + +typedef struct doh_block { + struct doh_block *link; + unsigned size; + unsigned free; + LispObj data[doh_block_slots]; +} doh_block, *doh_block_ptr; + + +#define population_weak_list (0< call lisp_exit_hook */ + void *native_thread_info; /* platform-dependent */ + void *native_thread_id; /* mach_thread_t, pid_t, etc. */ + void *last_allocptr; + void *save_allocptr; + void *save_allocbase; + void *reset_completion; + void *activate; + int suspend_count; + ExceptionInformation *suspend_context; + ExceptionInformation *pending_exception_context; + void *suspend; /* suspension semaphore */ + void *resume; /* resumption semaphore */ + natural flags; + ExceptionInformation *gc_context; + void *termination_semaphore; + int unwinding; + unsigned tlb_limit; + LispObj *tlb_pointer; + unsigned shutdown_count; + void *safe_ref_address; +} TCR; + +/* + These were previously global variables. There are lots of implicit + assumptions about the size of a heap segment, so they might as well + be constants. +*/ + +#define heap_segment_size 0x00010000 +#define log2_heap_segment_size 16 + + +#endif + Index: /branches/new-random/lisp-kernel/ppc-constants32.s =================================================================== --- /branches/new-random/lisp-kernel/ppc-constants32.s (revision 13309) +++ /branches/new-random/lisp-kernel/ppc-constants32.s (revision 13309) @@ -0,0 +1,687 @@ +/* Copyright (C) 2009 Clozure Associates */ +/* Copyright (C) 1994-2001 Digitool, Inc */ +/* This file is part of Clozure CL. */ + +/* Clozure CL is licensed under the terms of the Lisp Lesser GNU Public */ +/* License , known as the LLGPL and distributed with Clozure CL as the */ +/* file "LICENSE". The LLGPL consists of a preamble and the LGPL, */ +/* which is distributed with Clozure CL as the file "LGPL". Where these */ +/* conflict, the preamble takes precedence. */ + +/* Clozure CL is referenced in the preamble as the "LIBRARY." */ + +/* The LLGPL is also available online at */ +/* http://opensource.franz.com/preamble.html */ + + +define([rcontext],[r13]) + +nbits_in_word = 32 +nbits_in_byte = 8 +ntagbits = 3 /* But only 2 are significant to lisp */ +nlisptagbits = 2 +nfixnumtagbits = 2 +num_subtag_bits = 8 +fixnumshift = 2 +fixnum_shift = 2 +fulltagmask = 7 +tagmask = 3 +fixnummask = 3 +ncharcodebits = 24 /* arguably, we're only using the low 8 */ +charcode_shift = nbits_in_word-ncharcodebits +word_shift = 2 +node_size = 4 +dnode_size = 8 +dnode_align_bits = 3 +dnode_shift = dnode_align_bits +bitmap_shift = 5 + + +fixnumone = (1< 4 (so that code-vector entry-points can be branched to, since the low */ +/* two bits of the PC are ignored) and that both FULLTAG-MISC and FULLTAG-IMM have header fulltags */ +/* that share the same TAG. */ +/* Things that walk memory (and the stack) have to be careful to look at the FULLTAG of each */ +/* object that they see. */ + + +fulltag_even_fixnum = 0 /* I suppose EVENP/ODDP might care; nothing else does. */ +fulltag_cons = 1 /* a real (non_null) cons. Shares TAG with fulltag_nil. */ +fulltag_nodeheader = 2 /* Header of heap_allocated object that contains lisp_object pointers */ +fulltag_imm = 3 /* a "real" immediate object. Shares TAG with fulltag_immheader. */ +fulltag_odd_fixnum = 4 /* */ +fulltag_nil = 5 /* NIL and nothing but. (Note that there]s still a hidden NILSYM.) */ +fulltag_misc = 6 /* Pointer "real" tag_misc object. Shares TAG with fulltag_nodeheader. */ +fulltag_immheader = 7 /* Header of heap-allocated object that contains unboxed data. */ + +nil_value = 0x00003015+LOWMEM_BIAS +misc_bias = fulltag_misc +cons_bias = tag_list + +/* Functions are of (conceptually) unlimited size. */ + _struct(_function,-misc_bias) + _node(header) + _node(codevector) + _ends + + _struct(tsp_frame,0) + _node(backlink) + _node(type) + _struct_label(fixed_overhead) + _struct_label(data_offset) + _ends + +/* Order of CAR and CDR doesn]t seem to matter much - there aren]t */ +/* too many tricks to be played with predecrement/preincrement addressing. */ +/* Keep them in the confusing MCL 3.0 order, to avoid confusion. */ + _struct(cons,-cons_bias) + _node(cdr) + _node(car) + _ends + +misc_header_offset = -fulltag_misc +misc_subtag_offset = misc_header_offset+3 /* low byte of header */ +misc_data_offset = misc_header_offset+4 /* first word of data */ +misc_dfloat_offset = misc_header_offset+8 /* double-floats are doubleword-aligned */ + +max_64_bit_constant_index = ((0x7fff + misc_dfloat_offset)>>3) +max_32_bit_constant_index = ((0x7fff + misc_data_offset)>>2) +max_16_bit_constant_index = ((0x7fff + misc_data_offset)>>1) +max_8_bit_constant_index = (0x7fff + misc_data_offset) +max_1_bit_constant_index = ((0x7fff + misc_data_offset)<<5) + +/* T is almost adjacent to NIL: since NIL is a misaligned CONS, it spans */ +/* two doublewords. The arithmetic difference between T and NIL is */ +/* such that the least-significant bit and exactly one other bit is */ +/* set in the result. */ + +t_offset = (8+(8-fulltag_nil)+fulltag_misc) +t_value = nil_value+t_offset + +/* The order in which various header values are defined is significant in several ways: */ +/* 1) Numeric subtags precede non-numeric ones; there are further orderings among numeric subtags. */ +/* 2) All subtags which denote CL arrays are preceded by those that don]t, */ +/* with a further ordering which requires that (< header-arrayH header-vectorH ,@all-other-CL-vector-types) */ +/* 3) The element-size of ivectors is determined by the ordering of ivector subtags. */ +/* 4) All subtags are >= fulltag-immheader . */ + +define([define_subtag],[ +subtag_$1 = $2|($3< than */ +/* all non-CL-array subtags. So we start by defining the immediate subtags in decreasing order, starting */ +/* with that subtag whose element size isn]t an integral number of bits and ending with those whose */ +/* element size - like all non-CL-array fulltag-immheader types - is 32 bits. */ + + define_imm_subtag(bit_vector,31) + define_imm_subtag(double_float_vector,30) + define_imm_subtag(s16_vector,29) + define_imm_subtag(u16_vector,28) +min_16_bit_ivector_subtag = subtag_u16_vector +max_16_bit_ivector_subtag = subtag_s16_vector + define_imm_subtag(s8_vector,26) + define_imm_subtag(u8_vector,25) +min_8_bit_ivector_subtag = subtag_u8_vector +max_8_bit_ivector_subtag = fulltag_immheader|(27< max-numeric-subtag) & (n < min-array-subtag)) */ +/* for various immediate/node object types. */ + + define_imm_subtag(macptr,3) +min_non_numeric_imm_subtag = subtag_macptr + + define_imm_subtag(dead_macptr,4) + define_imm_subtag(code_vector,5) + define_imm_subtag(creole,6) + +max_non_array_imm_subtag = (18< -> unwind-protect, else catch */ + _node(link) /* backpointer to previous catch frame */ + _node(mvflag) /* 0 if single-valued catch, fixnum 1 otherwise */ + _node(csp) /* pointer to lisp_frame on csp */ + _node(db_link) /* head of special-binding chain */ + _field(regs,8*node_size) /* save7-save0 */ + _node(xframe) /* exception frame chain */ + _node(tsp_segment) /* maybe someday; padding for now */ + _endstructf + + _structf(macptr) + _node(address) + _node(domain) + _node(type) + _endstructf + + _structf(vectorH) + _node(logsize) + _node(physsize) + _node(data_vector) + _node(displacement) + _node(flags) + _endstructf + + _structf(arrayH) + _node(rank) + _node(physsize) + _node(data_vector) + _node(displacement) + _node(flags) + _struct_label(dim0) + _endstructf + + + + _struct(c_frame,0) /* PowerOpen ABI C stack frame */ + _node(backlink) + _node(crsave) + _node(savelr) + _field(unused, 8) + _node(savetoc) + _struct_label(params) + _node(param0) + _node(param1) + _node(param2) + _node(param3) + _node(param4) + _node(param5) + _node(param6) + _node(param7) + _struct_label(minsiz) + _ends + + + _struct(eabi_c_frame,0) + _word(backlink) + _word(savelr) + _word(param0) + _word(param1) + _word(param2) + _word(param3) + _word(param4) + _word(param5) + _word(param6) + _word(param7) + _struct_label(minsiz) + _ends + + /* For entry to variable-argument-list functions */ +/* (e.g., via callback) */ + _struct(varargs_eabi_c_frame,0) + _word(backlink) + _word(savelr) + _struct_label(va_list) + _word(flags) /* gpr count byte, fpr count byte, padding */ + _word(overflow_arg_area) + _word(reg_save_area) + _field(padding,4) + _struct_label(regsave) + _field(gp_save,8*node_size) + _field(fp_save,8*8) + _word(old_backlink) + _word(old_savelr) + _struct_label(incoming_stack_args) + _ends + + _struct(lisp_frame,0) + _node(backlink) + _node(savefn) + _node(savelr) + _node(savevsp) + _ends + + _struct(vector,-fulltag_misc) + _node(header) + _struct_label(data) + _ends + + _struct(binding,0) + _node(link) + _node(sym) + _node(val) + _ends + + + +symbol_extra = symbol.size-fulltag_misc + + _struct(nrs,nil_value-fulltag_nil) + _struct_pad(fulltag_nil) + _field(nilptr,16-fulltag_nil) + + _struct_pad(fulltag_misc) + _struct_label(tsym) + _struct_pad(symbol_extra) /* t */ + + _struct_pad(fulltag_misc) + _struct_label(nilsym) + _struct_pad(symbol_extra) /* nil */ + + _struct_pad(fulltag_misc) + _struct_label(errdisp) + _struct_pad(symbol_extra) /* %err-disp */ + + _struct_pad(fulltag_misc) + _struct_label(cmain) + _struct_pad(symbol_extra) /* cmain */ + + _struct_pad(fulltag_misc) + _struct_label(eval) + _struct_pad(symbol_extra) /* eval */ + + _struct_pad(fulltag_misc) + _struct_label(appevalfn) + _struct_pad(symbol_extra) /* apply-evaluated-function */ + + _struct_pad(fulltag_misc) + _struct_label(error) + _struct_pad(symbol_extra) /* error */ + + _struct_pad(fulltag_misc) + _struct_label(defun) + _struct_pad(symbol_extra) /* %defun */ + + _struct_pad(fulltag_misc) + _struct_label(defvar) + _struct_pad(symbol_extra) /* %defvar */ + + _struct_pad(fulltag_misc) + _struct_label(defconstant) + _struct_pad(symbol_extra) /* %defconstant */ + + _struct_pad(fulltag_misc) + _struct_label(macrosym) + _struct_pad(symbol_extra) /* %macro */ + + _struct_pad(fulltag_misc) + _struct_label(kernelrestart) + _struct_pad(symbol_extra) /* %kernel-restart */ + + _struct_pad(fulltag_misc) + _struct_label(package) + _struct_pad(symbol_extra) /* *package* */ + + _struct_pad(fulltag_misc) + _struct_label(total_bytes_freed) /* *total-bytes-freed* */ + _struct_pad(symbol_extra) + + _struct_pad(fulltag_misc) + _struct_label(kallowotherkeys) + _struct_pad(symbol_extra) /* allow-other-keys */ + + _struct_pad(fulltag_misc) + _struct_label(toplcatch) + _struct_pad(symbol_extra) /* %toplevel-catch% */ + + _struct_pad(fulltag_misc) + _struct_label(toplfunc) + _struct_pad(symbol_extra) /* %toplevel-function% */ + + _struct_pad(fulltag_misc) + _struct_label(callbacks) + _struct_pad(symbol_extra) /* %pascal-functions% */ + + _struct_pad(fulltag_misc) + _struct_label(allmeteredfuns) + _struct_pad(symbol_extra) /* *all-metered-functions* */ + + _struct_pad(fulltag_misc) + _struct_label(total_gc_microseconds) /* *total-gc-microseconds* */ + _struct_pad(symbol_extra) + + _struct_pad(fulltag_misc) + _struct_label(builtin_functions) /* %builtin-functions% */ + _struct_pad(symbol_extra) + + _struct_pad(fulltag_misc) + _struct_label(udf) + _struct_pad(symbol_extra) /* %unbound-function% */ + + _struct_pad(fulltag_misc) + _struct_label(init_misc) + _struct_pad(symbol_extra) /* %init-misc */ + + _struct_pad(fulltag_misc) + _struct_label(macro_code) + _struct_pad(symbol_extra) /* %macro-code% */ + + _struct_pad(fulltag_misc) + _struct_label(closure_code) + _struct_pad(symbol_extra) /* %closure-code% */ + + _struct_pad(fulltag_misc) + _struct_label(new_gcable_ptr) /* %new-gcable-ptr */ + _struct_pad(symbol_extra) + + _struct_pad(fulltag_misc) + _struct_label(gc_event_status_bits) + _struct_pad(symbol_extra) /* *gc-event-status-bits* */ + + _struct_pad(fulltag_misc) + _struct_label(post_gc_hook) + _struct_pad(symbol_extra) /* *post-gc-hook* */ + + _struct_pad(fulltag_misc) + _struct_label(handlers) + _struct_pad(symbol_extra) /* %handlers% */ + + + _struct_pad(fulltag_misc) + _struct_label(all_packages) + _struct_pad(symbol_extra) /* %all-packages% */ + + _struct_pad(fulltag_misc) + _struct_label(keyword_package) + _struct_pad(symbol_extra) /* *keyword-package* */ + + _struct_pad(fulltag_misc) + _struct_label(finalization_alist) + _struct_pad(symbol_extra) /* %finalization-alist% */ + + _struct_pad(fulltag_misc) + _struct_label(foreign_thread_control) + _struct_pad(symbol_extra) /* %foreign-thread-control */ + + _ends + +define([def_header],[ +$1 = ($2<lisp code that needs to save/restore C NVRs in a TSP frame. */ + _struct(c_reg_save,0) + _node(tsp_link) /* backpointer */ + _node(tsp_mark) /* frame type */ + _node(save_fpscr) /* for Cs FPSCR */ + _field(save_gprs,19*4) /* r13-r31 */ + _dword(save_fp_zero) /* for fp_zero */ + _dword(save_fps32conv) + _field(save_fprs,13*8) + _ends + + +TCR_BIAS = 0 +/* TCR_BIAS = 0x7000 */ + +/* Thread context record. */ + + _struct(tcr,-TCR_BIAS) + _node(prev) /* in doubly-linked list */ + _node(next) /* in doubly-linked list */ + _node(lisp_fpscr) /* lisp thread's fpscr (in low word) */ + _node(lisp_fpscr_low) + _node(db_link) /* special binding chain head */ + _node(catch_top) /* top catch frame */ + _node(save_vsp) /* VSP when in foreign code */ + _node(save_tsp) /* TSP when in foreign code */ + _node(cs_area) /* cstack area pointer */ + _node(vs_area) /* vstack area pointer */ + _node(ts_area) /* tstack area pointer */ + _node(cs_limit) /* cstack overflow limit */ + _node(bytes_consed_high) + _node(bytes_consed_low) + _node(log2_allocation_quantum) + _node(interrupt_pending) + _node(xframe) /* per-thread exception frame list */ + _node(errno_loc) /* per-thread errno location */ + _node(ffi_exception) /* fpscr exception bits from ff-call */ + _node(osid) /* OS thread id */ + _node(valence) /* odd when in foreign code */ + _node(foreign_exception_status) + _node(native_thread_info) + _node(native_thread_id) + _node(last_allocptr) + _node(save_allocptr) + _node(save_allocbase) + _node(reset_completion) + _node(activate) + _node(suspend_count) + _node(suspend_context) + _node(pending_exception_context) + _node(suspend) /* semaphore for suspension notify */ + _node(resume) /* sempahore for resumption notify */ + _node(flags) + _node(gc_context) + _node(termination_semaphore) + _node(unwinding) + _node(tlb_limit) + _node(tlb_pointer) /* Consider using tcr+N as tlb_pointer */ + _node(shutdown_count) + _node(safe_ref_address) + _ends + +TCR_FLAG_BIT_FOREIGN = fixnum_shift +TCR_FLAG_BIT_AWAITING_PRESET = (fixnum_shift+1) +TCR_FLAG_BIT_ALT_SUSPEND = (fixnumshift+2) +TCR_FLAG_BIT_PROPAGATE_EXCEPTION = (fixnumshift+3) +TCR_FLAG_BIT_SUSPEND_ACK_PENDING = (fixnumshift+4) +TCR_FLAG_BIT_PENDING_EXCEPTION = (fixnumshift+5) +TCR_FLAG_BIT_FOREIGN_EXCEPTION = (fixnumshift+6) +TCR_FLAG_BIT_PENDING_SUSPEND = (fixnumshift+7) + +r0 = 0 +r1 = 1 +r2 = 2 +r3 = 3 +r4 = 4 +r5 = 5 +r6 = 6 +r7 = 7 +r8 = 8 +r9 = 9 +r10 = 10 +r11 = 11 +r12 = 12 +r13 = 13 +r14 = 14 +r15 = 15 +r16 = 16 +r17 = 17 +r18 = 18 +r19 = 19 +r20 = 20 +r21 = 21 +r22 = 22 +r23 = 23 +r24 = 24 +r25 = 25 +r26 = 26 +r27 = 27 +r28 = 28 +r29 = 29 +r30 = 30 +r31 = 31 + +/* Lisp code keeps 0.0 in fp_zero */ +define([fp_zero],[f31]) /* a non-volatile reg as far as FFI is concerned. */ +define([fp_s32conv],[f30]) /* for s32->fp conversion */ + +/* registers, as used in destrucuring-bind/macro-bind */ + +define([whole_reg],[temp1]) +define([arg_reg],[temp3]) +define([keyvect_reg],[temp2]) +define([mask_req_start],[24]) +define([mask_req_width],[8]) +define([mask_opt_start],[16]) +define([mask_opt_width],[8]) +define([mask_key_start],[8]) +define([mask_key_width],[8]) +define([mask_initopt],[7]) +define([mask_keyp],[6]) /* note that keyp can be true even when 0 keys. */ +define([mask_aok],[5]) +define([mask_restp],[4]) + +ifdef([DARWIN],[ + define([STACK_ALIGN],16) + define([STACK_ALIGN_MASK],15) +],[ + define([STACK_ALIGN],8) + define([STACK_ALIGN_MASK],7) +]) + +define([TCR_STATE_FOREIGN],1) +define([TCR_STATE_LISP],0) +define([TCR_STATE_EXCEPTION_WAIT],2) +define([TCR_STATE_EXCEPTION_RETURN],4) + +define([RESERVATION_DISCHARGE],0x2004) + +lisp_globals_limit = (0x3010+(LOWMEM_BIAS)) + +INTERRUPT_LEVEL_BINDING_INDEX = fixnumone Index: /branches/new-random/lisp-kernel/ppc-constants64.h =================================================================== --- /branches/new-random/lisp-kernel/ppc-constants64.h (revision 13309) +++ /branches/new-random/lisp-kernel/ppc-constants64.h (revision 13309) @@ -0,0 +1,456 @@ +/* + Copyright (C) 2003-2009, Clozure Associates. + Copyright (C) 1994-2001 Digitool, Inc + This file is part of Clozure CL. + + Clozure CL is licensed under the terms of the Lisp Lesser GNU Public + License , known as the LLGPL and distributed with Clozure CL as the + file "LICENSE". The LLGPL consists of a preamble and the LGPL, + which is distributed with Clozure CL as the file "LGPL". Where these + conflict, the preamble takes precedence. + + Clozure CL is referenced in the preamble as the "LIBRARY." + + The LLGPL is also available online at + http://opensource.franz.com/preamble.html +*/ + +#ifndef __constants64__ +#define __constants64__ 1 + +#define rcontext 2 + +#define nbits_in_word 64L +#define log2_nbits_in_word 6L +#define nbits_in_byte 8L +#define ntagbits 4L +#define nlisptagbits 3L +#define nfixnumtagbits 2L +#define num_subtag_bits 8L +#define fixnumshift 3L +#define fixnum_shift 3L +#define fulltagmask 15L +#define tagmask 7L +#define fixnummask 3 +#define subtagmask ((1L<>3) +#define max_32_bit_constant_index ((0x7fff + misc_data_offset)>>2) +#define max_16_bit_constant_index ((0x7fff + misc_data_offset)>>1) +#define max_8_bit_constant_index (0x7fff + misc_data_offset) +#define max_1_bit_constant_index ((0x7fff + misc_data_offset)<<5) + + +/* The objects themselves look something like this: */ + +/* Order of CAR and CDR doesn't seem to matter much - there aren't */ +/* too many tricks to be played with predecrement/preincrement addressing. */ +/* Keep them in the confusing MCL 3.0 order, to avoid confusion. */ + +typedef struct cons { + LispObj cdr; + LispObj car; +} cons; + + + +typedef struct lispsymbol { + LispObj header; + LispObj pname; + LispObj vcell; + LispObj fcell; + LispObj package_predicate; + LispObj flags; + LispObj plist; + LispObj binding_index; +} lispsymbol; + +typedef struct ratio { + LispObj header; + LispObj numer; + LispObj denom; +} ratio; + +typedef struct double_float { + LispObj header; + LispObj value; +} double_float; + + +typedef struct macptr { + LispObj header; + LispObj address; + LispObj class; + LispObj type; +} macptr; + +typedef struct xmacptr { + LispObj header; + LispObj address; + LispObj class; + LispObj type; + LispObj flags; + LispObj link; +} xmacptr; + + +typedef struct eabi_c_frame { + struct eabi_c_frame *backlink; + unsigned savelr; + LispObj params[8]; +} eabi_c_frame; + +/* PowerOpen ABI C frame */ + +typedef struct c_frame { + struct c_frame *backlink; + natural crsave; + natural savelr; + natural unused[2]; + natural savetoc; /* Used with CFM (and on Linux.) */ + natural params[8]; /* Space for callee to save r3-r10 */ +} c_frame; + +typedef struct lisp_frame { + struct lisp_frame *backlink; + LispObj savefn; + LispObj savelr; + LispObj savevsp; +} lisp_frame; + +typedef struct special_binding { + struct special_binding *link; + struct lispsymbol *sym; + LispObj value; +} special_binding; + +/* The GC (at least) needs to know what a + package looks like, so that it can do GCTWA. */ +typedef struct package { + LispObj header; + LispObj itab; /* itab and etab look like (vector (fixnum . fixnum) */ + LispObj etab; + LispObj used; + LispObj used_by; + LispObj names; + LispObj shadowed; +} package; + +/* + The GC also needs to know what a catch_frame looks like. +*/ + +typedef struct catch_frame { + LispObj header; + LispObj catch_tag; + LispObj link; + LispObj mvflag; + LispObj csp; + LispObj db_link; + LispObj regs[8]; + LispObj xframe; + LispObj tsp_segment; +} catch_frame; + +#define catch_frame_element_count ((sizeof(catch_frame)/sizeof(LispObj))-1) +#define catch_frame_header make_header(subtag_catch_frame,catch_frame_element_count) + + +/* + All exception frames in a thread are linked together + */ +typedef struct xframe_list { + ExceptionInformation *curr; + struct xframe_list *prev; +} xframe_list; + +#define fixnum_bitmask(n) (1LL<<((n)+fixnumshift)) + +/* + The GC (at least) needs to know about hash-table-vectors and their flag bits. +*/ + +typedef struct hash_table_vector_header { + LispObj header; + LispObj link; /* If weak */ + LispObj flags; /* a fixnum; see below */ + LispObj gc_count; /* gc-count kernel global */ + LispObj free_alist; /* preallocated conses for finalization_alist */ + LispObj finalization_alist; /* key/value alist for finalization */ + LispObj weak_deletions_count; /* incremented when GC deletes weak pair */ + LispObj hash; /* backpointer to hash-table */ + LispObj deleted_count; /* number of deleted entries [not maintained if lock-free] */ + LispObj count; /* number of valid entries [not maintained if lock-free] */ + LispObj cache_idx; /* index of last cached pair */ + LispObj cache_key; /* value of last cached key */ + LispObj cache_value; /* last cached value */ + LispObj size; /* number of entries in table */ + LispObj size_reciprocal; /* shifted reciprocal of size */ +} hash_table_vector_header; + +/* + Bits (masks) in hash_table_vector.flags: +*/ + +/* GC should track keys when addresses change */ +#define nhash_track_keys_mask fixnum_bitmask(28) + +/* GC should set when nhash_track_keys_bit & addresses change */ +#define nhash_key_moved_mask fixnum_bitmask(27) + +/* weak on key or value (need new "weak both" encoding.) */ +#define nhash_weak_mask fixnum_bitmask(12) + +/* weak on value */ +#define nhash_weak_value_mask fixnum_bitmask(11) + +/* finalizable */ +#define nhash_finalizable_mask fixnum_bitmask(10) + +/* keys frozen, i.e. don't clobber keys, only values */ +#define nhash_keys_frozen_mask fixnum_bitmask(9) + +/* Lfun bits */ + +#define lfbits_nonnullenv_mask fixnum_bitmask(0) +#define lfbits_keys_mask fixnum_bitmask(1) +#define lfbits_restv_mask fixnum_bitmask(7) +#define lfbits_optinit_mask fixnum_bitmask(14) +#define lfbits_rest_mask fixnum_bitmask(15) + +#define lfbits_aok_mask fixnum_bitmask(16) +#define lfbits_lap_mask fixnum_bitmask(23) +#define lfbits_trampoline_mask fixnum_bitmask(24) +#define lfbits_evaluated_mask fixnum_bitmask(25) +#define lfbits_cm_mask fixnum_bitmask(26) /* combined_method */ +#define lfbits_nextmeth_mask fixnum_bitmask(26) /* or call_next_method with method_mask */ +#define lfbits_gfn_mask fixnum_bitmask(27) /* generic_function */ +#define lfbits_nextmeth_with_args_mask fixnum_bitmask(27) /* or call_next_method_with_args with method_mask */ +#define lfbits_method_mask fixnum_bitmask(28) /* method function */ +/* PPC only but want it defined for xcompile */ +#define lfbits_noname_mask fixnum_bitmask(29) + + +/* Creole */ + +#define doh_quantum 400 +#define doh_block_slots ((doh_quantum >> 2) - 3) + +typedef struct doh_block { + struct doh_block *link; + unsigned size; + unsigned free; + LispObj data[doh_block_slots]; +} doh_block, *doh_block_ptr; + + +#define population_weak_list (0< call lisp_exit_hook */ + void* native_thread_info; /* platform-dependent */ + void* native_thread_id; /* mach_thread_t, pid_t, etc. */ + void* last_allocptr; + void* save_allocptr; + void* save_allocbase; + void* reset_completion; + void* activate; + signed_natural suspend_count; + ExceptionInformation* suspend_context; + ExceptionInformation* pending_exception_context; + void* suspend; /* suspension semaphore */ + void* resume; /* resumption semaphore */ + natural flags; + ExceptionInformation* gc_context; + void* termination_semaphore; + signed_natural unwinding; + natural tlb_limit; + LispObj* tlb_pointer; + natural shutdown_count; + void *safe_ref_address; +} TCR; + +#define t_offset -(sizeof(lispsymbol)) + +/* + These were previously global variables. There are lots of implicit + assumptions about the size of a heap segment, so they might as well + be constants. +*/ + +#define heap_segment_size 0x00020000L +#define log2_heap_segment_size 17L + +#endif + Index: /branches/new-random/lisp-kernel/ppc-constants64.s =================================================================== --- /branches/new-random/lisp-kernel/ppc-constants64.s (revision 13309) +++ /branches/new-random/lisp-kernel/ppc-constants64.s (revision 13309) @@ -0,0 +1,596 @@ +/* Copyright (C) 2003-2009, Clozure Associates. */ +/* Copyright (C) 1994-2001 Digitool, Inc */ +/* This file is part of Clozure CL. */ + +/* Clozure CL is licensed under the terms of the Lisp Lesser GNU Public */ +/* License , known as the LLGPL and distributed with Clozure CL as the */ +/* file "LICENSE". The LLGPL consists of a preamble and the LGPL, */ +/* which is distributed with Clozure CL as the file "LGPL". Where these */ +/* conflict, the preamble takes precedence. */ + +/* Clozure CL is referenced in the preamble as the "LIBRARY." */ + +/* The LLGPL is also available online at */ +/* http://opensource.franz.com/preamble.html */ + + +define([rcontext],[r2]) + +nbits_in_word = 64 +nbits_in_byte = 8 +ntagbits = 4 +nlisptagbits = 3 +nfixnumtagbits = 3 +nlowtagbits = 2 +num_subtag_bits = 8 +fixnumshift = 3 +fixnum_shift = 3 +fulltagmask = 15 +tagmask = 7 +fixnummask = 7 +ncharcodebits = 8 +charcode_shift = 8 +word_shift = 3 +node_size = 8 +dnode_size = 16 +dnode_align_bits = 4 +dnode_shift = dnode_align_bits +bitmap_shift = 6 + +fixnumone = (1<>3) +max_32_bit_constant_index = ((0x7fff + misc_data_offset)>>2) +max_16_bit_constant_index = ((0x7fff + misc_data_offset)>>1) +max_8_bit_constant_index = (0x7fff + misc_data_offset) +max_1_bit_constant_index = ((0x7fff + misc_data_offset)<<5) + + + +/* The objects themselves look something like this: */ + +/* Order of CAR and CDR doesn]t seem to matter much - there aren't */ +/* too many tricks to be played with predecrement/preincrement addressing. */ +/* Keep them in the confusing MCL 3.0 order, to avoid confusion. */ + _struct(cons,-cons_bias) + _node(cdr) + _node(car) + _ends + + _structf(ratio) + _node(numer) + _node(denom) + _endstructf + + _structf(double_float) + _word(value) + _word(val_low) + _endstructf + + _structf(macptr) + _node(address) + _node(domain) + _node(type) + _endstructf + +/* Functions are of (conceptually) unlimited size. */ + _struct(_function,-misc_bias) + _node(header) + _node(codevector) + _ends + + _struct(tsp_frame,0) + _node(backlink) + _node(type) + _struct_label(fixed_overhead) + _struct_label(data_offset) + _ends + + + + _structf(symbol) + _node(pname) + _node(vcell) + _node(fcell) + _node(package_predicate) + _node(flags) + _node(plist) + _node(binding_index) + _endstructf + + _structf(catch_frame) + _node(catch_tag) /* # -> unwind-protect, else catch */ + _node(link) /* backpointer to previous catch frame */ + _node(mvflag) /* 0 if single-valued catch, fixnum 1 otherwise */ + _node(csp) /* pointer to lisp_frame on csp */ + _node(db_link) /* head of special-binding chain */ + _field(regs,8*node_size) /* save7-save0 */ + _node(xframe) /* exception frame chain */ + _node(tsp_segment) /* maybe someday; padding for now */ + _endstructf + + + _structf(vectorH) + _node(logsize) + _node(physsize) + _node(data_vector) + _node(displacement) + _node(flags) + _endstructf + + _structf(arrayH) + _node(rank) + _node(physsize) + _node(data_vector) + _node(displacement) + _node(flags) + _struct_label(dim0) + _endstructf + + _struct(c_frame,0) /* PowerOpen ABI C stack frame */ + _node(backlink) + _node(crsave) + _node(savelr) + _field(unused, 16) + _node(savetoc) + _struct_label(params) + _node(param0) + _node(param1) + _node(param2) + _node(param3) + _node(param4) + _node(param5) + _node(param6) + _node(param7) + _struct_label(minsiz) + _ends + + + _struct(eabi_c_frame,0) + _word(backlink) + _word(savelr) + _word(param0) + _word(param1) + _word(param2) + _word(param3) + _word(param4) + _word(param5) + _word(param6) + _word(param7) + _struct_label(minsiz) + _ends + + /* For entry to variable-argument-list functions */ + /* (e.g., via callback) */ + _struct(varargs_eabi_c_frame,0) + _word(backlink) + _word(savelr) + _struct_label(va_list) + _word(flags) /* gpr count byte, fpr count byte, padding */ + _word(overflow_arg_area) + _word(reg_save_area) + _field(padding,4) + _struct_label(regsave) + _field(gp_save,8*4) + _field(fp_save,8*8) + _word(old_backlink) + _word(old_savelr) + _struct_label(incoming_stack_args) + _ends + + _struct(lisp_frame,0) + _node(backlink) + _node(savefn) + _node(savelr) + _node(savevsp) + _ends + + _struct(vector,-fulltag_misc) + _node(header) + _struct_label(data) + _ends + + _struct(binding,0) + _node(link) + _node(sym) + _node(val) + _ends + + +/* Nilreg-relative globals. Talking the assembler into doing something reasonable here */ +/* is surprisingly hard. */ + +symbol_extra = symbol.size-fulltag_misc + + + _struct(nrs,(0x3000+(LOWMEM_BIAS))) + _struct_pad(fulltag_misc) + _struct_label(tsym) + _struct_pad(symbol_extra) /* t */ + + _struct_pad(fulltag_misc) + _struct_label(nil) + _struct_pad(symbol_extra) /* nil */ + + _struct_pad(fulltag_misc) + _struct_label(errdisp) + _struct_pad(symbol_extra) /* %err-disp */ + + _struct_pad(fulltag_misc) + _struct_label(cmain) + _struct_pad(symbol_extra) /* cmain */ + + _struct_pad(fulltag_misc) + _struct_label(eval) + _struct_pad(symbol_extra) /* eval */ + + _struct_pad(fulltag_misc) + _struct_label(appevalfn) + _struct_pad(symbol_extra) /* apply-evaluated-function */ + + _struct_pad(fulltag_misc) + _struct_label(error) + _struct_pad(symbol_extra) /* error */ + + _struct_pad(fulltag_misc) + _struct_label(defun) + _struct_pad(symbol_extra) /* %defun */ + + _struct_pad(fulltag_misc) + _struct_label(defvar) + _struct_pad(symbol_extra) /* %defvar */ + + _struct_pad(fulltag_misc) + _struct_label(defconstant) + _struct_pad(symbol_extra) /* %defconstant */ + + _struct_pad(fulltag_misc) + _struct_label(macrosym) + _struct_pad(symbol_extra) /* %macro */ + + _struct_pad(fulltag_misc) + _struct_label(kernelrestart) + _struct_pad(symbol_extra) /* %kernel-restart */ + + _struct_pad(fulltag_misc) + _struct_label(package) + _struct_pad(symbol_extra) /* *package* */ + + _struct_pad(fulltag_misc) + _struct_label(total_bytes_freed) /* *total-bytes-freed* */ + _struct_pad(symbol_extra) + + _struct_pad(fulltag_misc) + _struct_label(kallowotherkeys) + _struct_pad(symbol_extra) /* allow-other-keys */ + + _struct_pad(fulltag_misc) + _struct_label(toplcatch) + _struct_pad(symbol_extra) /* %toplevel-catch% */ + + _struct_pad(fulltag_misc) + _struct_label(toplfunc) + _struct_pad(symbol_extra) /* %toplevel-function% */ + + _struct_pad(fulltag_misc) + _struct_label(callbacks) + _struct_pad(symbol_extra) /* %pascal-functions% */ + + _struct_pad(fulltag_misc) + _struct_label(allmeteredfuns) + _struct_pad(symbol_extra) /* *all-metered-functions* */ + + _struct_pad(fulltag_misc) + _struct_label(total_gc_microseconds) /* *total-gc-microseconds* */ + _struct_pad(symbol_extra) + + _struct_pad(fulltag_misc) + _struct_label(builtin_functions) /* %builtin-functions% */ + _struct_pad(symbol_extra) + + _struct_pad(fulltag_misc) + _struct_label(udf) + _struct_pad(symbol_extra) /* %unbound-function% */ + + _struct_pad(fulltag_misc) + _struct_label(init_misc) + _struct_pad(symbol_extra) /* %init-misc */ + + _struct_pad(fulltag_misc) + _struct_label(macro_code) + _struct_pad(symbol_extra) /* %macro-code% */ + + _struct_pad(fulltag_misc) + _struct_label(closure_code) + _struct_pad(symbol_extra) /* %closure-code% */ + + _struct_pad(fulltag_misc) + _struct_label(new_gcable_ptr) /* %new-gcable-ptr */ + _struct_pad(symbol_extra) + + _struct_pad(fulltag_misc) + _struct_label(gc_event_status_bits) + _struct_pad(symbol_extra) /* *gc-event-status-bits* */ + + _struct_pad(fulltag_misc) + _struct_label(post_gc_hook) + _struct_pad(symbol_extra) /* *post-gc-hook* */ + + _struct_pad(fulltag_misc) + _struct_label(handlers) + _struct_pad(symbol_extra) /* %handlers% */ + + + _struct_pad(fulltag_misc) + _struct_label(all_packages) + _struct_pad(symbol_extra) /* %all-packages% */ + + _struct_pad(fulltag_misc) + _struct_label(keyword_package) + _struct_pad(symbol_extra) /* *keyword-package* */ + + _struct_pad(fulltag_misc) + _struct_label(finalization_alist) + _struct_pad(symbol_extra) /* %finalization-alist% */ + + _struct_pad(fulltag_misc) + _struct_label(foreign_thread_control) + _struct_pad(symbol_extra) /* %foreign-thread-control */ + + _ends + +define([def_header],[ +$1 = ($2<lisp code that needs to save/restore C NVRs in a TSP frame. */ + _struct(c_reg_save,0) + _node(tsp_link) /* backpointer */ + _node(tsp_mark) /* frame type */ + _node(save_fpscr) /* for Cs FPSCR */ + _field(save_gprs,19*node_size) /* r13-r31 */ + _dword(save_fp_zero) /* for fp_zero */ + _dword(save_fps32conv) + _field(save_fprs,13*8) + _ends + + +TCR_BIAS = 0 + +/* Thread context record. */ + + _struct(tcr,-TCR_BIAS) + _node(prev) /* in doubly-linked list */ + _node(next) /* in doubly-linked list */ + _node(single_float_convert) /* xxxf0 */ + _word(lisp_fpscr) /* lisp thread's fpscr (in low word) */ + _word(lisp_fpscr_low) + _node(db_link) /* special binding chain head */ + _node(catch_top) /* top catch frame */ + _node(save_vsp) /* VSP when in foreign code */ + _node(save_tsp) /* TSP when in foreign code */ + _node(cs_area) /* cstack area pointer */ + _node(vs_area) /* vstack area pointer */ + _node(ts_area) /* tstack area pointer */ + _node(cs_limit) /* cstack overflow limit */ + _word(bytes_consed_high) + _word(bytes_consed_low) + _node(log2_allocation_quantum) + _node(interrupt_pending) + _node(xframe) /* per-thread exception frame list */ + _node(errno_loc) /* per-thread errno location */ + _node(ffi_exception) /* fpscr exception bits from ff-call */ + _node(osid) /* OS thread id */ + _node(valence) /* odd when in foreign code */ + _node(foreign_exception_status) + _node(native_thread_info) + _node(native_thread_id) + _node(last_allocptr) + _node(save_allocptr) + _node(save_allocbase) + _node(reset_completion) + _node(activate) + _node(suspend_count) + _node(suspend_context) + _node(pending_exception_context) + _node(suspend) /* semaphore for suspension notify */ + _node(resume) /* sempahore for resumption notify */ + _word(flags_pad) + _word(flags) + _node(gc_context) + _node(termination_semaphore) + _node(unwinding) + _node(tlb_limit) + _node(tlb_pointer) /* Consider using tcr+N as tlb_pointer */ + _node(shutdown_count) + _node(safe_ref_address) + _ends + +TCR_FLAG_BIT_FOREIGN = fixnum_shift +TCR_FLAG_BIT_AWAITING_PRESET = (fixnum_shift+1) +TCR_FLAG_BIT_ALT_SUSPEND = (fixnumshift+2) +TCR_FLAG_BIT_PROPAGATE_EXCEPTION = (fixnumshift+3) +TCR_FLAG_BIT_SUSPEND_ACK_PENDING = (fixnumshift+4) +TCR_FLAG_BIT_PENDING_EXCEPTION = (fixnumshift+5) +TCR_FLAG_BIT_FOREIGN_EXCEPTION = (fixnumshift+6) +TCR_FLAG_BIT_PENDING_SUSPEND = (fixnumshift+7) + + +nil_value = (0x3000+symbol.size+fulltag_misc+(LOWMEM_BIAS)) + +define([RESERVATION_DISCHARGE],(0x2008+(LOWMEM_BIAS))) + +lisp_globals_limit = (0x3000+(LOWMEM_BIAS)) + +INTERRUPT_LEVEL_BINDING_INDEX = fixnumone + + Index: /branches/new-random/lisp-kernel/ppc-exceptions.c =================================================================== --- /branches/new-random/lisp-kernel/ppc-exceptions.c (revision 13309) +++ /branches/new-random/lisp-kernel/ppc-exceptions.c (revision 13309) @@ -0,0 +1,3232 @@ +/* + Copyright (C) 2009 Clozure Associates + Copyright (C) 1994-2001 Digitool, Inc + This file is part of Clozure CL. + + Clozure CL is licensed under the terms of the Lisp Lesser GNU Public + License , known as the LLGPL and distributed with Clozure CL as the + file "LICENSE". The LLGPL consists of a preamble and the LGPL, + which is distributed with Clozure CL as the file "LGPL". Where these + conflict, the preamble takes precedence. + + Clozure CL is referenced in the preamble as the "LIBRARY." + + The LLGPL is also available online at + http://opensource.franz.com/preamble.html +*/ + +#include "lisp.h" +#include "lisp-exceptions.h" +#include "lisp_globals.h" +#include +#include +#include +#include +#include +#include +#include +#ifdef LINUX +#include +#include +#include +#include +#endif + +#ifdef DARWIN +#include +#define _FPU_RESERVED 0xffffff00 +#ifndef SA_NODEFER +#define SA_NODEFER 0 +#endif +#include + +/* a distinguished UUO at a distinguished address */ +extern void pseudo_sigreturn(ExceptionInformation *); +#endif + + +#include "Threads.h" + +#define MSR_FE0_MASK (((unsigned)0x80000000)>>20) +#define MSR_FE1_MASK (((unsigned)0x80000000)>>23) +#define MSR_FE0_FE1_MASK (MSR_FE0_MASK|MSR_FE1_MASK) +extern void enable_fp_exceptions(void); +extern void disable_fp_exceptions(void); + +#ifdef LINUX +/* Some relatively recent kernels support this interface. + If this prctl isn't supported, assume that we're always + running with excptions enabled and "precise". +*/ +#ifndef PR_SET_FPEXC +#define PR_SET_FPEXC 12 +#endif +#ifndef PR_FP_EXC_DISABLED +#define PR_FP_EXC_DISABLED 0 +#endif +#ifndef PR_FP_EXC_PRECISE +#define PR_FP_EXC_PRECISE 3 +#endif + +void +enable_fp_exceptions() +{ + prctl(PR_SET_FPEXC, PR_FP_EXC_PRECISE); +} + +void +disable_fp_exceptions() +{ + prctl(PR_SET_FPEXC, PR_FP_EXC_DISABLED); +} + +#endif + +/* + Handle exceptions. + +*/ + +extern LispObj lisp_nil; + +extern natural lisp_heap_gc_threshold; +extern Boolean grow_dynamic_area(natural); + + + + + + +int +page_size = 4096; + +int +log2_page_size = 12; + + + + + +/* + If the PC is pointing to an allocation trap, the previous instruction + must have decremented allocptr. Return the non-zero amount by which + allocptr was decremented. +*/ +signed_natural +allocptr_displacement(ExceptionInformation *xp) +{ + pc program_counter = xpPC(xp); + opcode instr = *program_counter, prev_instr = *(program_counter-1); + + if (instr == ALLOC_TRAP_INSTRUCTION) { + if (match_instr(prev_instr, + XO_MASK | RT_MASK | RB_MASK, + XO(major_opcode_X31,minor_opcode_SUBF, 0, 0) | + RT(allocptr) | + RB(allocptr))) { + return ((signed_natural) xpGPR(xp, RA_field(prev_instr))); + } + if (match_instr(prev_instr, + OP_MASK | RT_MASK | RA_MASK, + OP(major_opcode_ADDI) | + RT(allocptr) | + RA(allocptr))) { + return (signed_natural) -((short) prev_instr); + } + Bug(xp, "Can't determine allocation displacement"); + } + return 0; +} + + +/* + A cons cell's been successfully allocated, but the allocptr's + still tagged (as fulltag_cons, of course.) Emulate any instructions + that might follow the allocation (stores to the car or cdr, an + assignment to the "result" gpr) that take place while the allocptr's + tag is non-zero, advancing over each such instruction. When we're + done, the cons cell will be allocated and initialized, the result + register will point to it, the allocptr will be untagged, and + the PC will point past the instruction that clears the allocptr's + tag. +*/ +void +finish_allocating_cons(ExceptionInformation *xp) +{ + pc program_counter = xpPC(xp); + opcode instr; + LispObj cur_allocptr = xpGPR(xp, allocptr); + cons *c = (cons *)ptr_from_lispobj(untag(cur_allocptr)); + int target_reg; + + while (1) { + instr = *program_counter++; + + if (instr == UNTAG_ALLOCPTR_INSTRUCTION) { + xpGPR(xp, allocptr) = untag(cur_allocptr); + xpPC(xp) = program_counter; + return; + } + + switch (instr & STORE_CXR_ALLOCPTR_MASK) { + case STORE_CAR_ALLOCPTR_INSTRUCTION: + c->car = xpGPR(xp,RT_field(instr)); + break; + case STORE_CDR_ALLOCPTR_INSTRUCTION: + c->cdr = xpGPR(xp,RT_field(instr)); + break; + default: + /* Assume that this is an assignment: {rt/ra} <- allocptr. + There are several equivalent instruction forms + that might have that effect; just assign to target here. + */ + if (major_opcode_p(instr,major_opcode_X31)) { + target_reg = RA_field(instr); + } else { + target_reg = RT_field(instr); + } + xpGPR(xp,target_reg) = cur_allocptr; + break; + } + } +} + +/* + We were interrupted in the process of allocating a uvector; we + survived the allocation trap, and allocptr is tagged as fulltag_misc. + Emulate any instructions which store a header into the uvector, + assign the value of allocptr to some other register, and clear + allocptr's tag. Don't expect/allow any other instructions in + this environment. +*/ +void +finish_allocating_uvector(ExceptionInformation *xp) +{ + pc program_counter = xpPC(xp); + opcode instr; + LispObj cur_allocptr = xpGPR(xp, allocptr); + int target_reg; + + while (1) { + instr = *program_counter++; + if (instr == UNTAG_ALLOCPTR_INSTRUCTION) { + xpGPR(xp, allocptr) = untag(cur_allocptr); + xpPC(xp) = program_counter; + return; + } + if ((instr & STORE_HEADER_ALLOCPTR_MASK) == + STORE_HEADER_ALLOCPTR_INSTRUCTION) { + header_of(cur_allocptr) = xpGPR(xp, RT_field(instr)); + } else { + /* assume that this is an assignment */ + + if (major_opcode_p(instr,major_opcode_X31)) { + target_reg = RA_field(instr); + } else { + target_reg = RT_field(instr); + } + xpGPR(xp,target_reg) = cur_allocptr; + } + } +} + + +Boolean +allocate_object(ExceptionInformation *xp, + natural bytes_needed, + signed_natural disp_from_allocptr, + TCR *tcr) +{ + area *a = active_dynamic_area; + + /* Maybe do an EGC */ + if (a->older && lisp_global(OLDEST_EPHEMERAL)) { + if (((a->active)-(a->low)) >= a->threshold) { + gc_from_xp(xp, 0L); + } + } + + /* Life is pretty simple if we can simply grab a segment + without extending the heap. + */ + if (new_heap_segment(xp, bytes_needed, false, tcr)) { + xpGPR(xp, allocptr) += disp_from_allocptr; +#ifdef DEBUG + fprintf(dbgout, "New heap segment for #x%x, no GC: #x%x/#x%x, vsp = #x%x\n", + tcr,xpGPR(xp,allocbase),tcr->last_allocptr, xpGPR(xp,vsp)); +#endif + return true; + } + + /* It doesn't make sense to try a full GC if the object + we're trying to allocate is larger than everything + allocated so far. + */ + if ((lisp_global(HEAP_END)-lisp_global(HEAP_START)) > bytes_needed) { + untenure_from_area(tenured_area); /* force a full GC */ + gc_from_xp(xp, 0L); + } + + /* Try again, growing the heap if necessary */ + if (new_heap_segment(xp, bytes_needed, true, tcr)) { + xpGPR(xp, allocptr) += disp_from_allocptr; +#ifdef DEBUG + fprintf(dbgout, "New heap segment for #x%x after GC: #x%x/#x%x\n", + tcr,xpGPR(xp,allocbase),tcr->last_allocptr); +#endif + return true; + } + + return false; +} + +#ifndef XNOMEM +#define XNOMEM 10 +#endif + +void +update_bytes_allocated(TCR* tcr, void *cur_allocptr) +{ + BytePtr + last = (BytePtr) tcr->last_allocptr, + current = (BytePtr) cur_allocptr; + if (last && (cur_allocptr != ((void *)VOID_ALLOCPTR))) { + tcr->bytes_allocated += last-current; + } + tcr->last_allocptr = 0; +} + +void +lisp_allocation_failure(ExceptionInformation *xp, TCR *tcr, natural bytes_needed) +{ + /* Couldn't allocate the object. If it's smaller than some arbitrary + size (say 128K bytes), signal a "chronically out-of-memory" condition; + else signal a "allocation request failed" condition. + */ + xpGPR(xp,allocptr) = xpGPR(xp,allocbase) = VOID_ALLOCPTR; + handle_error(xp, bytes_needed < (128<<10) ? XNOMEM : error_alloc_failed, 0, 0, xpPC(xp)); +} + +/* + Allocate a large list, where "large" means "large enough to + possibly trigger the EGC several times if this was done + by individually allocating each CONS." The number of + ocnses in question is in arg_z; on successful return, + the list will be in arg_z +*/ + +Boolean +allocate_list(ExceptionInformation *xp, TCR *tcr) +{ + natural + nconses = (unbox_fixnum(xpGPR(xp,arg_z))), + bytes_needed = (nconses << dnode_shift); + LispObj + prev = lisp_nil, + current, + initial = xpGPR(xp,arg_y); + + if (nconses == 0) { + /* Silly case */ + xpGPR(xp,arg_z) = lisp_nil; + xpGPR(xp,allocptr) = lisp_nil; + return true; + } + update_bytes_allocated(tcr, (void *)(void *) tcr->save_allocptr); + if (allocate_object(xp,bytes_needed,(-bytes_needed)+fulltag_cons,tcr)) { + for (current = xpGPR(xp,allocptr); + nconses; + prev = current, current+= dnode_size, nconses--) { + deref(current,0) = prev; + deref(current,1) = initial; + } + xpGPR(xp,arg_z) = prev; + xpGPR(xp,arg_y) = xpGPR(xp,allocptr); + xpGPR(xp,allocptr)-=fulltag_cons; + } else { + lisp_allocation_failure(xp,tcr,bytes_needed); + } + return true; +} + +OSStatus +handle_alloc_trap(ExceptionInformation *xp, TCR *tcr) +{ + pc program_counter; + natural cur_allocptr, bytes_needed = 0; + opcode prev_instr; + signed_natural disp = 0; + unsigned allocptr_tag; + + cur_allocptr = xpGPR(xp,allocptr); + program_counter = xpPC(xp); + prev_instr = *(program_counter-1); + allocptr_tag = fulltag_of(cur_allocptr); + + switch (allocptr_tag) { + case fulltag_cons: + bytes_needed = sizeof(cons); + disp = -sizeof(cons) + fulltag_cons; + break; + + case fulltag_even_fixnum: + case fulltag_odd_fixnum: + break; + + case fulltag_misc: + if (match_instr(prev_instr, + XO_MASK | RT_MASK | RB_MASK, + XO(major_opcode_X31,minor_opcode_SUBF, 0, 0) | + RT(allocptr) | + RB(allocptr))) { + disp = -((signed_natural) xpGPR(xp, RA_field(prev_instr))); + } else if (match_instr(prev_instr, + OP_MASK | RT_MASK | RA_MASK, + OP(major_opcode_ADDI) | + RT(allocptr) | + RA(allocptr))) { + disp = (signed_natural) ((short) prev_instr); + } + if (disp) { + bytes_needed = (-disp) + fulltag_misc; + break; + } + /* else fall thru */ + default: + return -1; + } + + if (bytes_needed) { + update_bytes_allocated(tcr,((BytePtr)(cur_allocptr-disp))); + if (allocate_object(xp, bytes_needed, disp, tcr)) { +#if 0 + fprintf(dbgout, "alloc_trap in 0x%lx, new allocptr = 0x%lx\n", + tcr, xpGPR(xp, allocptr)); +#endif + adjust_exception_pc(xp,4); + return 0; + } + lisp_allocation_failure(xp,tcr,bytes_needed); + return -1; + } + return -1; +} + +natural gc_deferred = 0, full_gc_deferred = 0; + +signed_natural +flash_freeze(TCR *tcr, signed_natural param) +{ + return 0; +} + +OSStatus +handle_gc_trap(ExceptionInformation *xp, TCR *tcr) +{ + LispObj + selector = xpGPR(xp,imm0), + arg = xpGPR(xp,imm1); + area *a = active_dynamic_area; + Boolean egc_was_enabled = (a->older != NULL); + natural gc_previously_deferred = gc_deferred; + + + switch (selector) { + case GC_TRAP_FUNCTION_EGC_CONTROL: + egc_control(arg != 0, a->active); + xpGPR(xp,arg_z) = lisp_nil + (egc_was_enabled ? t_offset : 0); + break; + + case GC_TRAP_FUNCTION_CONFIGURE_EGC: + a->threshold = unbox_fixnum(xpGPR(xp, arg_x)); + g1_area->threshold = unbox_fixnum(xpGPR(xp, arg_y)); + g2_area->threshold = unbox_fixnum(xpGPR(xp, arg_z)); + xpGPR(xp,arg_z) = lisp_nil+t_offset; + break; + + case GC_TRAP_FUNCTION_SET_LISP_HEAP_THRESHOLD: + if (((signed_natural) arg) > 0) { + lisp_heap_gc_threshold = + align_to_power_of_2((arg-1) + + (heap_segment_size - 1), + log2_heap_segment_size); + } + /* fall through */ + case GC_TRAP_FUNCTION_GET_LISP_HEAP_THRESHOLD: + xpGPR(xp, imm0) = lisp_heap_gc_threshold; + break; + + case GC_TRAP_FUNCTION_USE_LISP_HEAP_THRESHOLD: + /* Try to put the current threshold in effect. This may + need to disable/reenable the EGC. */ + untenure_from_area(tenured_area); + resize_dynamic_heap(a->active,lisp_heap_gc_threshold); + if (egc_was_enabled) { + if ((a->high - a->active) >= a->threshold) { + tenure_to_area(tenured_area); + } + } + xpGPR(xp, imm0) = lisp_heap_gc_threshold; + break; + + case GC_TRAP_FUNCTION_ENSURE_STATIC_CONSES: + ensure_static_conses(xp,tcr,32768); + break; + + case GC_TRAP_FUNCTION_FLASH_FREEZE: + untenure_from_area(tenured_area); + gc_like_from_xp(xp,flash_freeze,0); + a->active = (BytePtr) align_to_power_of_2(a->active, log2_page_size); + tenured_area->static_dnodes = area_dnode(a->active, a->low); + if (egc_was_enabled) { + tenure_to_area(tenured_area); + } + xpGPR(xp, imm0) = tenured_area->static_dnodes << dnode_shift; + break; + + default: + update_bytes_allocated(tcr, (void *) ptr_from_lispobj(xpGPR(xp, allocptr))); + + if (selector == GC_TRAP_FUNCTION_IMMEDIATE_GC) { + if (!full_gc_deferred) { + gc_from_xp(xp, 0L); + break; + } + /* Tried to do a full GC when gc was disabled. That failed, + so try full GC now */ + selector = GC_TRAP_FUNCTION_GC; + } + + if (egc_was_enabled) { + egc_control(false, (BytePtr) a->active); + } + gc_from_xp(xp, 0L); + if (gc_deferred > gc_previously_deferred) { + full_gc_deferred = 1; + } else { + full_gc_deferred = 0; + } + if (selector > GC_TRAP_FUNCTION_GC) { + if (selector & GC_TRAP_FUNCTION_IMPURIFY) { + impurify_from_xp(xp, 0L); + /* nrs_GC_EVENT_STATUS_BITS.vcell |= gc_integrity_check_bit; */ + lisp_global(OLDSPACE_DNODE_COUNT) = 0; + gc_from_xp(xp, 0L); + } + if (selector & GC_TRAP_FUNCTION_PURIFY) { + purify_from_xp(xp, 0L); + lisp_global(OLDSPACE_DNODE_COUNT) = area_dnode(managed_static_area->active, managed_static_area->low); + gc_from_xp(xp, 0L); + } + if (selector & GC_TRAP_FUNCTION_SAVE_APPLICATION) { + OSErr err; + extern OSErr save_application(unsigned, Boolean); + TCR *tcr = TCR_FROM_TSD(xpGPR(xp, rcontext)); + area *vsarea = tcr->vs_area; + + nrs_TOPLFUNC.vcell = *((LispObj *)(vsarea->high)-1); + err = save_application(arg, egc_was_enabled); + if (err == noErr) { + _exit(0); + } + fatal_oserr(": save_application", err); + } + switch (selector) { + + + case GC_TRAP_FUNCTION_FREEZE: + a->active = (BytePtr) align_to_power_of_2(a->active, log2_page_size); + tenured_area->static_dnodes = area_dnode(a->active, a->low); + xpGPR(xp, imm0) = tenured_area->static_dnodes << dnode_shift; + break; + default: + break; + } + } + + if (egc_was_enabled) { + egc_control(true, NULL); + } + break; + + } + + adjust_exception_pc(xp,4); + return 0; +} + + + +void +signal_stack_soft_overflow(ExceptionInformation *xp, unsigned reg) +{ + /* The cstack just overflowed. Force the current thread's + control stack to do so until all stacks are well under their overflow + limits. + */ + +#if 0 + lisp_global(CS_OVERFLOW_LIMIT) = CS_OVERFLOW_FORCE_LIMIT; /* force unsigned traps to fail */ +#endif + handle_error(xp, error_stack_overflow, reg, 0, xpPC(xp)); +} + +/* + Lower (move toward 0) the "end" of the soft protected area associated + with a by a page, if we can. +*/ + +void +adjust_soft_protection_limit(area *a) +{ + char *proposed_new_soft_limit = a->softlimit - 4096; + protected_area_ptr p = a->softprot; + + if (proposed_new_soft_limit >= (p->start+16384)) { + p->end = proposed_new_soft_limit; + p->protsize = p->end-p->start; + a->softlimit = proposed_new_soft_limit; + } + protect_area(p); +} + +void +restore_soft_stack_limit(unsigned stkreg) +{ + area *a; + TCR *tcr = get_tcr(true); + + switch (stkreg) { + case sp: + a = tcr->cs_area; + if ((a->softlimit - 4096) > (a->hardlimit + 16384)) { + a->softlimit -= 4096; + } + tcr->cs_limit = (LispObj)ptr_to_lispobj(a->softlimit); + break; + case vsp: + a = tcr->vs_area; + adjust_soft_protection_limit(a); + break; + case tsp: + a = tcr->ts_area; + adjust_soft_protection_limit(a); + } +} + +/* Maybe this'll work someday. We may have to do something to + make the thread look like it's not handling an exception */ +void +reset_lisp_process(ExceptionInformation *xp) +{ + TCR *tcr = TCR_FROM_TSD(xpGPR(xp,rcontext)); + catch_frame *last_catch = (catch_frame *) ptr_from_lispobj(untag(tcr->catch_top)); + + tcr->save_allocptr = (void *) ptr_from_lispobj(xpGPR(xp, allocptr)); + tcr->save_allocbase = (void *) ptr_from_lispobj(xpGPR(xp, allocbase)); + + tcr->save_vsp = (LispObj *) ptr_from_lispobj(((lisp_frame *)ptr_from_lispobj(last_catch->csp))->savevsp); + tcr->save_tsp = (LispObj *) ptr_from_lispobj((LispObj) ptr_to_lispobj(last_catch)) - (2*node_size); /* account for TSP header */ + + start_lisp(tcr, 1); +} + +/* + This doesn't GC; it returns true if it made enough room, false + otherwise. + If "extend" is true, it can try to extend the dynamic area to + satisfy the request. +*/ + +Boolean +new_heap_segment(ExceptionInformation *xp, natural need, Boolean extend, TCR *tcr) +{ + area *a; + natural newlimit, oldlimit; + natural log2_allocation_quantum = tcr->log2_allocation_quantum; + + a = active_dynamic_area; + oldlimit = (natural) a->active; + newlimit = (align_to_power_of_2(oldlimit, log2_allocation_quantum) + + align_to_power_of_2(need, log2_allocation_quantum)); + if (newlimit > (natural) (a->high)) { + if (extend) { + signed_natural inhibit = (signed_natural)(lisp_global(GC_INHIBIT_COUNT)); + natural extend_by = inhibit ? 0 : lisp_heap_gc_threshold; + do { + if (resize_dynamic_heap(a->active, (newlimit-oldlimit)+extend_by)) { + break; + } + extend_by = align_to_power_of_2(extend_by>>1, log2_allocation_quantum); + if (extend_by < 4<<20) { + return false; + } + } while (1); + } else { + return false; + } + } + a->active = (BytePtr) newlimit; + tcr->last_allocptr = (void *)newlimit; + xpGPR(xp,allocptr) = (LispObj) newlimit; + xpGPR(xp,allocbase) = (LispObj) oldlimit; + + return true; +} + + +void +update_area_active (area **aptr, BytePtr value) +{ + area *a = *aptr; + for (; a; a = a->older) { + if ((a->low <= value) && (a->high >= value)) break; + }; + if (a == NULL) Bug(NULL, "Can't find active area"); + a->active = value; + *aptr = a; + + for (a = a->younger; a; a = a->younger) { + a->active = a->high; + } +} + +LispObj * +tcr_frame_ptr(TCR *tcr) +{ + ExceptionInformation *xp; + LispObj *bp = NULL; + + if (tcr->pending_exception_context) + xp = tcr->pending_exception_context; + else { + xp = tcr->suspend_context; + } + if (xp) { + bp = (LispObj *) xpGPR(xp, sp); + } + return bp; +} + +void +normalize_tcr(ExceptionInformation *xp, TCR *tcr, Boolean is_other_tcr) +{ + void *cur_allocptr = NULL; + LispObj freeptr = 0; + + if (xp) { + if (is_other_tcr) { + pc_luser_xp(xp, tcr, NULL); + freeptr = xpGPR(xp, allocptr); + if (fulltag_of(freeptr) == 0){ + cur_allocptr = (void *) ptr_from_lispobj(freeptr); + } + } + update_area_active((area **)&tcr->cs_area, (BytePtr) ptr_from_lispobj(xpGPR(xp, sp))); + update_area_active((area **)&tcr->vs_area, (BytePtr) ptr_from_lispobj(xpGPR(xp, vsp))); + update_area_active((area **)&tcr->ts_area, (BytePtr) ptr_from_lispobj(xpGPR(xp, tsp))); +#ifdef DEBUG + fprintf(dbgout, "TCR 0x%x in lisp code, vsp = 0x%lx, tsp = 0x%lx\n", + tcr, xpGPR(xp, vsp), xpGPR(xp, tsp)); + fprintf(dbgout, "TCR 0x%x, allocbase/allocptr were 0x%x/0x%x at #x%x\n", + tcr, + xpGPR(xp, allocbase), + xpGPR(xp, allocptr), + xpPC(xp)); + fprintf(dbgout, "TCR 0x%x, exception context = 0x%x\n", + tcr, + tcr->pending_exception_context); +#endif + } else { + /* In ff-call. No need to update cs_area */ + cur_allocptr = (void *) (tcr->save_allocptr); +#ifdef DEBUG + fprintf(dbgout, "TCR 0x%x in foreign code, vsp = 0x%lx, tsp = 0x%lx\n", + tcr, tcr->save_vsp, tcr->save_tsp); + fprintf(dbgout, "TCR 0x%x, save_allocbase/save_allocptr were 0x%x/0x%x at #x%x\n", + tcr, + tcr->save_allocbase, + tcr->save_allocptr, + xpPC(xp)); + +#endif + update_area_active((area **)&tcr->vs_area, (BytePtr) tcr->save_vsp); + update_area_active((area **)&tcr->ts_area, (BytePtr) tcr->save_tsp); + } + + + tcr->save_allocptr = tcr->save_allocbase = (void *)VOID_ALLOCPTR; + if (cur_allocptr) { + update_bytes_allocated(tcr, cur_allocptr); + if (freeptr) { + xpGPR(xp, allocptr) = VOID_ALLOCPTR; + xpGPR(xp, allocbase) = VOID_ALLOCPTR; + } + } +} + +TCR *gc_tcr = NULL; + +/* Suspend and "normalize" other tcrs, then call a gc-like function + in that context. Resume the other tcrs, then return what the + function returned */ + +signed_natural +gc_like_from_xp(ExceptionInformation *xp, + signed_natural(*fun)(TCR *, signed_natural), + signed_natural param) +{ + TCR *tcr = TCR_FROM_TSD(xpGPR(xp, rcontext)), *other_tcr; + int result; + signed_natural inhibit; + + suspend_other_threads(true); + inhibit = (signed_natural)(lisp_global(GC_INHIBIT_COUNT)); + if (inhibit != 0) { + if (inhibit > 0) { + lisp_global(GC_INHIBIT_COUNT) = (LispObj)(-inhibit); + } + resume_other_threads(true); + gc_deferred++; + return 0; + } + gc_deferred = 0; + + gc_tcr = tcr; + + xpGPR(xp, allocptr) = VOID_ALLOCPTR; + xpGPR(xp, allocbase) = VOID_ALLOCPTR; + + normalize_tcr(xp, tcr, false); + + + for (other_tcr = tcr->next; other_tcr != tcr; other_tcr = other_tcr->next) { + if (other_tcr->pending_exception_context) { + other_tcr->gc_context = other_tcr->pending_exception_context; + } else if (other_tcr->valence == TCR_STATE_LISP) { + other_tcr->gc_context = other_tcr->suspend_context; + } else { + /* no pending exception, didn't suspend in lisp state: + must have executed a synchronous ff-call. + */ + other_tcr->gc_context = NULL; + } + normalize_tcr(other_tcr->gc_context, other_tcr, true); + } + + + + result = fun(tcr, param); + + other_tcr = tcr; + do { + other_tcr->gc_context = NULL; + other_tcr = other_tcr->next; + } while (other_tcr != tcr); + + gc_tcr = NULL; + + resume_other_threads(true); + + return result; + +} + + + +/* Returns #bytes freed by invoking GC */ + +signed_natural +gc_from_tcr(TCR *tcr, signed_natural param) +{ + area *a; + BytePtr oldfree, newfree; + BytePtr oldend, newend; + +#ifdef DEBUG + fprintf(dbgout, "Start GC in 0x%lx\n", tcr); +#endif + a = active_dynamic_area; + oldend = a->high; + oldfree = a->active; + gc(tcr, param); + newfree = a->active; + newend = a->high; +#if 0 + fprintf(dbgout, "End GC in 0x%lx\n", tcr); +#endif + return ((oldfree-newfree)+(newend-oldend)); +} + +signed_natural +gc_from_xp(ExceptionInformation *xp, signed_natural param) +{ + signed_natural status = gc_like_from_xp(xp, gc_from_tcr, param); + + freeGCptrs(); + return status; +} + +signed_natural +purify_from_xp(ExceptionInformation *xp, signed_natural param) +{ + return gc_like_from_xp(xp, purify, param); +} + +signed_natural +impurify_from_xp(ExceptionInformation *xp, signed_natural param) +{ + return gc_like_from_xp(xp, impurify, param); +} + + + + + + +protection_handler + * protection_handlers[] = { + do_spurious_wp_fault, + do_soft_stack_overflow, + do_soft_stack_overflow, + do_soft_stack_overflow, + do_hard_stack_overflow, + do_hard_stack_overflow, + do_hard_stack_overflow + }; + + +Boolean +is_write_fault(ExceptionInformation *xp, siginfo_t *info) +{ + /* use the siginfo if it's available. Some versions of Linux + don't propagate the DSISR and TRAP fields correctly from + 64- to 32-bit handlers. + */ + if (info) { + /* + To confuse matters still further, the value of SEGV_ACCERR + varies quite a bit among LinuxPPC variants (the value defined + in the header files varies, and the value actually set by + the kernel also varies. So far, we're only looking at the + siginfo under Linux and Linux always seems to generate + SIGSEGV, so check for SIGSEGV and check the low 16 bits + of the si_code. + */ + return ((info->si_signo == SIGSEGV) && + ((info->si_code & 0xff) == (SEGV_ACCERR & 0xff))); + } + return(((xpDSISR(xp) & (1 << 25)) != 0) && + (xpTRAP(xp) == +#ifdef LINUX +0x0300 +#endif +#ifdef DARWIN +0x0300/0x100 +#endif +) + ); +#if 0 + /* Maybe worth keeping around; not sure if it's an exhaustive + list of PPC instructions that could cause a WP fault */ + /* Some OSes lose track of the DSISR and DSR SPRs, or don't provide + valid values of those SPRs in the context they provide to + exception handlers. Look at the opcode of the offending + instruction & recognize 32-bit store operations */ + opcode instr = *(xpPC(xp)); + + if (xp->regs->trap != 0x300) { + return 0; + } + switch (instr >> 26) { + case 47: /* STMW */ + case 36: /* STW */ + case 37: /* STWU */ + return 1; + case 31: + switch ((instr >> 1) & 1023) { + case 151: /* STWX */ + case 183: /* STWUX */ + return 1; + default: + return 0; + } + default: + return 0; + } +#endif +} + +OSStatus +handle_protection_violation(ExceptionInformation *xp, siginfo_t *info, TCR *tcr, int old_valence) +{ + BytePtr addr; + protected_area_ptr area; + protection_handler *handler; + extern Boolean touch_page(void *); + extern void touch_page_end(void); + + if (info) { + addr = (BytePtr)(info->si_addr); + } else { + addr = (BytePtr) ((natural) (xpDAR(xp))); + } + + if (addr && (addr == tcr->safe_ref_address)) { + adjust_exception_pc(xp,4); + + xpGPR(xp,imm0) = 0; + return 0; + } + + if (xpPC(xp) == (pc)touch_page) { + xpGPR(xp,imm0) = 0; + xpPC(xp) = (pc)touch_page_end; + return 0; + } + + + if (is_write_fault(xp,info)) { + area = find_protected_area(addr); + if (area != NULL) { + handler = protection_handlers[area->why]; + return handler(xp, area, addr); + } else { + if ((addr >= readonly_area->low) && + (addr < readonly_area->active)) { + UnProtectMemory((LogicalAddress)(truncate_to_power_of_2(addr,log2_page_size)), + page_size); + return 0; + } + } + } + if (old_valence == TCR_STATE_LISP) { + callback_for_trap(nrs_CMAIN.vcell, xp, (pc)xpPC(xp), SIGBUS, (natural)addr, is_write_fault(xp,info)); + } + return -1; +} + + + + + +OSStatus +do_hard_stack_overflow(ExceptionInformation *xp, protected_area_ptr area, BytePtr addr) +{ +#ifdef SUPPORT_PRAGMA_UNUSED +#pragma unused(area,addr) +#endif + reset_lisp_process(xp); + return -1; +} + +extern area* +allocate_vstack(natural useable); /* This is in "pmcl-kernel.c" */ + +extern area* +allocate_tstack(natural useable); /* This is in "pmcl-kernel.c" */ + +#ifdef EXTEND_VSTACK +Boolean +catch_frame_p(lisp_frame *spPtr) +{ + catch_frame* catch = (catch_frame *) untag(lisp_global(CATCH_TOP)); + + for (; catch; catch = (catch_frame *) untag(catch->link)) { + if (spPtr == ((lisp_frame *) catch->csp)) { + return true; + } + } + return false; +} +#endif + +Boolean +unwind_protect_cleanup_frame_p(lisp_frame *spPtr) +{ + if ((spPtr->savevsp == (LispObj)NULL) || /* The frame to where the unwind-protect will return */ + (((spPtr->backlink)->savevsp) == (LispObj)NULL)) { /* The frame that returns to the kernel from the cleanup form */ + return true; + } else { + return false; + } +} + +Boolean +lexpr_entry_frame_p(lisp_frame *spPtr) +{ + LispObj savelr = spPtr->savelr; + LispObj lexpr_return = (LispObj) lisp_global(LEXPR_RETURN); + LispObj lexpr_return1v = (LispObj) lisp_global(LEXPR_RETURN1V); + LispObj ret1valn = (LispObj) lisp_global(RET1VALN); + + return + (savelr == lexpr_return1v) || + (savelr == lexpr_return) || + ((savelr == ret1valn) && + (((spPtr->backlink)->savelr) == lexpr_return)); +} + +Boolean +lisp_frame_p(lisp_frame *spPtr) +{ + LispObj savefn; + /* We can't just look at the size of the stack frame under the EABI + calling sequence, but that's the first thing to check. */ + if (((lisp_frame *) spPtr->backlink) != (spPtr+1)) { + return false; + } + savefn = spPtr->savefn; + return (savefn == 0) || (fulltag_of(savefn) == fulltag_misc); + +} + + +int ffcall_overflow_count = 0; + +/* Find a frame that is neither a catch frame nor one of the + lexpr_entry frames We don't check for non-lisp frames here because + we'll always stop before we get there due to a dummy lisp frame + pushed by .SPcallback that masks out the foreign frames. The one + exception is that there is a non-lisp frame without a valid VSP + while in the process of ppc-ff-call. We recognize that because its + savelr is NIL. If the saved VSP itself is 0 or the savevsp in the + next frame is 0, then we're executing an unwind-protect cleanup + form, and the top stack frame belongs to its (no longer extant) + catch frame. */ + +#ifdef EXTEND_VSTACK +lisp_frame * +find_non_catch_frame_from_xp (ExceptionInformation *xp) +{ + lisp_frame *spPtr = (lisp_frame *) xpGPR(xp, sp); + if ((((natural) spPtr) + sizeof(lisp_frame)) != ((natural) (spPtr->backlink))) { + ffcall_overflow_count++; /* This is mostly so I can breakpoint here */ + } + for (; !lisp_frame_p(spPtr) || /* In the process of ppc-ff-call */ + unwind_protect_cleanup_frame_p(spPtr) || + catch_frame_p(spPtr) || + lexpr_entry_frame_p(spPtr) ; ) { + spPtr = spPtr->backlink; + }; + return spPtr; +} +#endif + +#ifdef EXTEND_VSTACK +Boolean +db_link_chain_in_area_p (area *a) +{ + LispObj *db = (LispObj *) lisp_global(DB_LINK), + *high = (LispObj *) a->high, + *low = (LispObj *) a->low; + for (; db; db = (LispObj *) *db) { + if ((db >= low) && (db < high)) return true; + }; + return false; +} +#endif + + + + +/* Note: CURRENT_VS (CURRENT_TS) is always either the area containing + the current value of VSP (TSP) or an older area. */ + +OSStatus +do_vsp_overflow (ExceptionInformation *xp, BytePtr addr) +{ + TCR* tcr = TCR_FROM_TSD(xpGPR(xp, rcontext)); + area *a = tcr->vs_area; + protected_area_ptr vsp_soft = a->softprot; + unprotect_area(vsp_soft); + signal_stack_soft_overflow(xp,vsp); + return 0; +} + + +OSStatus +do_tsp_overflow (ExceptionInformation *xp, BytePtr addr) +{ + TCR* tcr = TCR_FROM_TSD(xpGPR(xp, rcontext)); + area *a = tcr->ts_area; + protected_area_ptr tsp_soft = a->softprot; + unprotect_area(tsp_soft); + signal_stack_soft_overflow(xp,tsp); + return 0; +} + +OSStatus +do_soft_stack_overflow(ExceptionInformation *xp, protected_area_ptr prot_area, BytePtr addr) +{ + /* Trying to write into a guard page on the vstack or tstack. + Allocate a new stack segment, emulate stwu and stwux for the TSP, and + signal an error_stack_overflow condition. + */ + lisp_protection_kind which = prot_area->why; + Boolean on_TSP = (which == kTSPsoftguard); + + if (on_TSP) { + return do_tsp_overflow(xp, addr); + } else { + return do_vsp_overflow(xp, addr); + } +} + +OSStatus +do_spurious_wp_fault(ExceptionInformation *xp, protected_area_ptr area, BytePtr addr) +{ +#ifdef SUPPORT_PRAGMA_UNUSED +#pragma unused(xp,area,addr) +#endif + return -1; +} + + +/* + We have a couple of choices here. We can simply unprotect the page + and let the store happen on return, or we can try to emulate writes + that we know will involve an intergenerational reference. Both are + correct as far as EGC constraints go, but the latter approach is + probably more efficient. (This only matters in the case where the + GC runs after this exception handler returns but before the write + actually happens. If we didn't emulate node stores here, the EGC + would scan the newly-writen page, find nothing interesting, and + run to completion. This thread will try the write again afer it + resumes, the page'll be re-protected, and we'll have taken this + fault twice. The whole scenario shouldn't happen very often, but + (having already taken a fault and committed to an mprotect syscall) + we might as well emulate stores involving intergenerational references, + since they're pretty easy to identify. + + Note that cases involving two or more threads writing to the same + page (before either of them can run this handler) is benign: one + invocation of the handler will just unprotect an unprotected page in + that case. + + If there are GCs (or any other suspensions of the thread between + the time that the write fault was detected and the time that the + exception lock is obtained) none of this stuff happens. +*/ + +/* + Return true (and emulate the instruction) iff: + a) the fault was caused by an "stw rs,d(ra)" or "stwx rs,ra.rb" + instruction. + b) RS is a node register (>= fn) + c) RS is tagged as a cons or vector + d) RS is in some ephemeral generation. + This is slightly conservative, since RS may be no younger than the + EA being written to. +*/ +Boolean +is_ephemeral_node_store(ExceptionInformation *xp, BytePtr ea) +{ + if (((ptr_to_lispobj(ea)) & 3) == 0) { + opcode instr = *xpPC(xp); + + if (X_opcode_p(instr,major_opcode_X31,minor_opcode_STWX) || + major_opcode_p(instr, major_opcode_STW)) { + LispObj + rs = RS_field(instr), + rsval = xpGPR(xp,rs), + tag = fulltag_of(rsval); + + if (rs >= fn) { + if ((tag == fulltag_misc) || (tag == fulltag_cons)) { + if (((BytePtr)ptr_from_lispobj(rsval) > tenured_area->high) && + ((BytePtr)ptr_from_lispobj(rsval) < active_dynamic_area->high)) { + *(LispObj *)ea = rsval; + return true; + } + } + } + } + } + return false; +} + + + + + + + +OSStatus +handle_sigfpe(ExceptionInformation *xp, TCR *tcr) +{ + (void) zero_fpscr(tcr); + enable_fp_exceptions(); + + + tcr->lisp_fpscr.words.l = xpFPSCR(xp) & ~_FPU_RESERVED; + + /* 'handle_fpux_binop' scans back from the specified PC until it finds an FPU + operation; there's an FPU operation right at the PC, so tell it to start + looking one word beyond */ + return handle_fpux_binop(xp, (pc)((natural)(xpPC(xp))+4)); +} + + +int +altivec_present = 1; + + +/* This only tries to implement the "optional" fsqrt and fsqrts + instructions, which were generally implemented on IBM hardware + but generally not available on Motorola/Freescale systems. +*/ +OSStatus +handle_unimplemented_instruction(ExceptionInformation *xp, + opcode instruction, + TCR *tcr) +{ + (void) zero_fpscr(tcr); + enable_fp_exceptions(); + /* the rc bit (bit 0 in the instruction) is supposed to cause + some FPSCR bits to be copied to CR1. Clozure CL doesn't generate + fsqrt. or fsqrts. + */ + if (((major_opcode_p(instruction,major_opcode_FPU_DOUBLE)) || + (major_opcode_p(instruction,major_opcode_FPU_SINGLE))) && + ((instruction & ((1 << 6) -2)) == (22<<1))) { + double b, d, sqrt(double); + + b = xpFPR(xp,RB_field(instruction)); + d = sqrt(b); + xpFPSCR(xp) = ((xpFPSCR(xp) & ~_FPU_RESERVED) | + (get_fpscr() & _FPU_RESERVED)); + xpFPR(xp,RT_field(instruction)) = d; + adjust_exception_pc(xp,4); + return 0; + } + + return -1; +} + +OSStatus +PMCL_exception_handler(int xnum, + ExceptionInformation *xp, + TCR *tcr, + siginfo_t *info, + int old_valence) +{ + OSStatus status = -1; + pc program_counter; + opcode instruction = 0; + + + program_counter = xpPC(xp); + + if ((xnum == SIGILL) | (xnum == SIGTRAP)) { + instruction = *program_counter; + } + + if (instruction == ALLOC_TRAP_INSTRUCTION) { + status = handle_alloc_trap(xp, tcr); + } else if ((xnum == SIGSEGV) || + (xnum == SIGBUS)) { + status = handle_protection_violation(xp, info, tcr, old_valence); + } else if (xnum == SIGFPE) { + status = handle_sigfpe(xp, tcr); + } else if ((xnum == SIGILL) || (xnum == SIGTRAP)) { + if (instruction == GC_TRAP_INSTRUCTION) { + status = handle_gc_trap(xp, tcr); + } else if (IS_UUO(instruction)) { + status = handle_uuo(xp, instruction, program_counter); + } else if (is_conditional_trap(instruction)) { + status = handle_trap(xp, instruction, program_counter, info); + } else { + status = handle_unimplemented_instruction(xp,instruction,tcr); + } + } else if (xnum == SIGNAL_FOR_PROCESS_INTERRUPT) { + tcr->interrupt_pending = 0; + callback_for_trap(nrs_CMAIN.vcell, xp, 0, TRI_instruction(TO_GT,nargs,0),0, 0); + status = 0; + } + + return status; +} + +void +adjust_exception_pc(ExceptionInformation *xp, int delta) +{ + xpPC(xp) += (delta >> 2); +} + + +/* + This wants to scan backwards until "where" points to an instruction + whose major opcode is either 63 (double-float) or 59 (single-float) +*/ + +OSStatus +handle_fpux_binop(ExceptionInformation *xp, pc where) +{ + OSStatus err; + opcode *there = (opcode *) where, instr, errnum = 0; + int i = TRAP_LOOKUP_TRIES, delta = 0; + + while (i--) { + instr = *--there; + delta -= 4; + if (codevec_hdr_p(instr)) { + return -1; + } + if (major_opcode_p(instr, major_opcode_FPU_DOUBLE)) { + errnum = error_FPU_exception_double; + break; + } + + if (major_opcode_p(instr, major_opcode_FPU_SINGLE)) { + errnum = error_FPU_exception_short; + break; + } + } + + err = handle_error(xp, errnum, rcontext, 0, there); + /* Yeah, we said "non-continuable". In case we ever change that ... */ + + adjust_exception_pc(xp, delta); + xpFPSCR(xp) &= 0x03fff; + + return err; + +} + +OSStatus +handle_uuo(ExceptionInformation *xp, opcode the_uuo, pc where) +{ +#ifdef SUPPORT_PRAGMA_UNUSED +#pragma unused(where) +#endif + unsigned + minor = UUO_MINOR(the_uuo), + rb = 0x1f & (the_uuo >> 11), + errnum = 0x3ff & (the_uuo >> 16); + + OSStatus status = -1; + + int bump = 4; + + switch (minor) { + + case UUO_ZERO_FPSCR: + status = 0; + xpFPSCR(xp) = 0; + break; + + + case UUO_INTERR: + { + TCR * target = (TCR *)xpGPR(xp,arg_z); + status = 0; + switch (errnum) { + case error_propagate_suspend: + break; + case error_interrupt: + xpGPR(xp,imm0) = (LispObj) raise_thread_interrupt(target); + break; + case error_suspend: + xpGPR(xp,imm0) = (LispObj) lisp_suspend_tcr(target); + break; + case error_suspend_all: + lisp_suspend_other_threads(); + break; + case error_resume: + xpGPR(xp,imm0) = (LispObj) lisp_resume_tcr(target); + break; + case error_resume_all: + lisp_resume_other_threads(); + break; + case error_kill: + xpGPR(xp,imm0) = (LispObj)kill_tcr(target); + break; + case error_allocate_list: + allocate_list(xp,get_tcr(true)); + break; + default: + status = handle_error(xp, errnum, rb, 0, where); + break; + } + } + break; + + case UUO_INTCERR: + status = handle_error(xp, errnum, rb, 1, where); + if (errnum == error_udf_call) { + /* If lisp's returned from a continuable undefined-function call, + it's put a code vector in the xp's PC. Don't advance the + PC ... */ + bump = 0; + } + break; + + case UUO_FPUX_BINOP: + status = handle_fpux_binop(xp, where); + bump = 0; + break; + + default: + status = -1; + bump = 0; + } + + if ((!status) && bump) { + adjust_exception_pc(xp, bump); + } + return status; +} + +natural +register_codevector_contains_pc (natural lisp_function, pc where) +{ + natural code_vector, size; + + if ((fulltag_of(lisp_function) == fulltag_misc) && + (header_subtag(header_of(lisp_function)) == subtag_function)) { + code_vector = deref(lisp_function, 1); + size = header_element_count(header_of(code_vector)) << 2; + if ((untag(code_vector) < (natural)where) && + ((natural)where < (code_vector + size))) + return(code_vector); + } + + return(0); +} + +/* Callback to lisp to handle a trap. Need to translate the + PC (where) into one of two forms of pairs: + + 1. If PC is in fn or nfn's code vector, use the register number + of fn or nfn and the index into that function's code vector. + 2. Otherwise use 0 and the pc itself +*/ +void +callback_for_trap (LispObj callback_macptr, ExceptionInformation *xp, pc where, + natural arg1, natural arg2, natural arg3) +{ + natural code_vector = register_codevector_contains_pc(xpGPR(xp, fn), where); + unsigned register_number = fn; + natural index = (natural)where; + + if (code_vector == 0) { + register_number = nfn; + code_vector = register_codevector_contains_pc(xpGPR(xp, nfn), where); + } + if (code_vector == 0) + register_number = 0; + else + index = ((natural)where - (code_vector + misc_data_offset)) >> 2; + callback_to_lisp(callback_macptr, xp, register_number, index, arg1, arg2, arg3); +} + +void +callback_to_lisp (LispObj callback_macptr, ExceptionInformation *xp, + natural arg1, natural arg2, natural arg3, natural arg4, natural arg5) +{ + natural callback_ptr; + area *a; + + TCR *tcr = TCR_FROM_TSD(xpGPR(xp, rcontext)); + + /* Put the active stack pointer where .SPcallback expects it */ + a = tcr->cs_area; + a->active = (BytePtr) ptr_from_lispobj(xpGPR(xp, sp)); + + /* Copy globals from the exception frame to tcr */ + tcr->save_allocptr = (void *)ptr_from_lispobj(xpGPR(xp, allocptr)); + tcr->save_allocbase = (void *)ptr_from_lispobj(xpGPR(xp, allocbase)); + tcr->save_vsp = (LispObj*) ptr_from_lispobj(xpGPR(xp, vsp)); + tcr->save_tsp = (LispObj*) ptr_from_lispobj(xpGPR(xp, tsp)); + + + + /* Call back. + Lisp will handle trampolining through some code that + will push lr/fn & pc/nfn stack frames for backtrace. + */ + callback_ptr = ((macptr *)ptr_from_lispobj(untag(callback_macptr)))->address; +#ifdef DEBUG + fprintf(dbgout, "0x%x releasing exception lock for callback\n", tcr); +#endif + UNLOCK(lisp_global(EXCEPTION_LOCK), tcr); + ((void (*)())callback_ptr) (xp, arg1, arg2, arg3, arg4, arg5); + LOCK(lisp_global(EXCEPTION_LOCK), tcr); +#ifdef DEBUG + fprintf(dbgout, "0x%x acquired exception lock after callback\n", tcr); +#endif + + + + /* Copy GC registers back into exception frame */ + xpGPR(xp, allocbase) = (LispObj) ptr_to_lispobj(tcr->save_allocbase); + xpGPR(xp, allocptr) = (LispObj) ptr_to_lispobj(tcr->save_allocptr); +} + +area * +allocate_no_stack (natural size) +{ +#ifdef SUPPORT_PRAGMA_UNUSED +#pragma unused(size) +#endif + + return (area *) NULL; +} + + + + + + +/* callback to (symbol-value cmain) if it is a macptr, + otherwise report cause and function name to console. + Returns noErr if exception handled OK */ +OSStatus +handle_trap(ExceptionInformation *xp, opcode the_trap, pc where, siginfo_t *info) +{ + LispObj cmain = nrs_CMAIN.vcell; + TCR *tcr = TCR_FROM_TSD(xpGPR(xp, rcontext)); + + /* If we got here, "the_trap" is either a TRI or a TR instruction. + It's a TRI instruction iff its major opcode is major_opcode_TRI. */ + + /* If it's a "trllt" instruction where RA == sp, it's a failed + control stack overflow check. In that case: + + a) We're in "yellow zone" mode if the value of the + lisp_global(CS_OVERFLOW_LIMIT) is CS_OVERFLOW_FORCE_LIMIT. If + we're not already in yellow zone mode, attempt to create a new + thread and continue execution on its stack. If that fails, call + signal_stack_soft_overflow to enter yellow zone mode and signal + the condition to lisp. + + b) If we're already in "yellow zone" mode, then: + + 1) if the SP is past the current control-stack area's hard + overflow limit, signal a "hard" stack overflow error (e.g., throw + to toplevel as quickly as possible. If we aren't in "yellow zone" + mode, attempt to continue on another thread first. + + 2) if SP is "well" (> 4K) below its soft overflow limit, set + lisp_global(CS_OVERFLOW_LIMIT) to its "real" value. We're out of + "yellow zone mode" in this case. + + 3) Otherwise, do nothing. We'll continue to trap every time + something gets pushed on the control stack, so we should try to + detect and handle all of these cases fairly quickly. Of course, + the trap overhead is going to slow things down quite a bit. + */ + + if (X_opcode_p(the_trap,major_opcode_X31,minor_opcode_TR) && + (RA_field(the_trap) == sp) && + (TO_field(the_trap) == TO_LO)) { + area + *CS_area = tcr->cs_area, + *VS_area = tcr->vs_area; + + natural + current_SP = xpGPR(xp,sp), + current_VSP = xpGPR(xp,vsp); + + if (current_SP < (natural) (CS_area->hardlimit)) { + /* If we're not in soft overflow mode yet, assume that the + user has set the soft overflow size very small and try to + continue on another thread before throwing to toplevel */ + if ((tcr->cs_limit == CS_OVERFLOW_FORCE_LIMIT)) { + reset_lisp_process(xp); + } + } else { + if (tcr->cs_limit == CS_OVERFLOW_FORCE_LIMIT) { + /* If the control stack pointer is at least 4K away from its soft limit + and the value stack pointer is at least 4K away from its soft limit, + stop trapping. Else keep trapping. */ + if ((current_SP > (natural) ((CS_area->softlimit)+4096)) && + (current_VSP > (natural) ((VS_area->softlimit)+4096))) { + protected_area_ptr vs_soft = VS_area->softprot; + if (vs_soft->nprot == 0) { + protect_area(vs_soft); + } + tcr->cs_limit = ptr_to_lispobj(CS_area->softlimit); + } + } else { + tcr->cs_limit = ptr_to_lispobj(CS_area->hardlimit); + signal_stack_soft_overflow(xp, sp); + } + } + + adjust_exception_pc(xp, 4); + return noErr; + } else { + if (the_trap == LISP_BREAK_INSTRUCTION) { + char *message = (char *) ptr_from_lispobj(xpGPR(xp,3)); + set_xpPC(xp, xpLR(xp)); + if (message == NULL) { + message = "Lisp Breakpoint"; + } + lisp_Debugger(xp, info, debug_entry_dbg, false, message); + return noErr; + } + if (the_trap == QUIET_LISP_BREAK_INSTRUCTION) { + adjust_exception_pc(xp,4); + lisp_Debugger(xp, info, debug_entry_dbg, false, "Lisp Breakpoint"); + return noErr; + } + /* + twlle ra,rb is used to detect tlb overflow, where RA = current + limit and RB = index to use. + */ + if ((X_opcode_p(the_trap, 31, minor_opcode_TR)) && + (TO_field(the_trap) == (TO_LO|TO_EQ))) { + if (extend_tcr_tlb(tcr, xp, RA_field(the_trap), RB_field(the_trap))) { + return noErr; + } + return -1; + } + + if ((fulltag_of(cmain) == fulltag_misc) && + (header_subtag(header_of(cmain)) == subtag_macptr)) { + if (the_trap == TRI_instruction(TO_GT,nargs,0)) { + /* reset interrup_level, interrupt_pending */ + TCR_INTERRUPT_LEVEL(tcr) = 0; + tcr->interrupt_pending = 0; + } +#if 0 + fprintf(dbgout, "About to do trap callback in 0x%x\n",tcr); +#endif + callback_for_trap(cmain, xp, where, (natural) the_trap, 0, 0); + adjust_exception_pc(xp, 4); + return(noErr); + } + return -1; + } +} + + +/* Look at up to TRAP_LOOKUP_TRIES instrs before trap instr for a pattern. + Stop if subtag_code_vector is encountered. */ +unsigned +scan_for_instr( unsigned target, unsigned mask, pc where ) +{ + int i = TRAP_LOOKUP_TRIES; + + while( i-- ) { + unsigned instr = *(--where); + if ( codevec_hdr_p(instr) ) { + return 0; + } else if ( match_instr(instr, mask, target) ) { + return instr; + } + } + return 0; +} + + +void non_fatal_error( char *msg ) +{ + fprintf( dbgout, "Non-fatal error: %s.\n", msg ); + fflush( dbgout ); +} + +/* The main opcode. */ + +int +is_conditional_trap(opcode instr) +{ + unsigned to = TO_field(instr); + int is_tr = X_opcode_p(instr,major_opcode_X31,minor_opcode_TR); + +#ifndef MACOS + if ((instr == LISP_BREAK_INSTRUCTION) || + (instr == QUIET_LISP_BREAK_INSTRUCTION)) { + return 1; + } +#endif + if (is_tr || major_opcode_p(instr,major_opcode_TRI)) { + /* A "tw/td" or "twi/tdi" instruction. To be unconditional, the + EQ bit must be set in the TO mask and either the register + operands (if "tw") are the same or either both of the signed or + both of the unsigned inequality bits must be set. */ + if (! (to & TO_EQ)) { + return 1; /* Won't trap on EQ: conditional */ + } + if (is_tr && (RA_field(instr) == RB_field(instr))) { + return 0; /* Will trap on EQ, same regs: unconditional */ + } + if (((to & (TO_LO|TO_HI)) == (TO_LO|TO_HI)) || + ((to & (TO_LT|TO_GT)) == (TO_LT|TO_GT))) { + return 0; /* Will trap on EQ and either (LT|GT) or (LO|HI) : unconditional */ + } + return 1; /* must be conditional */ + } + return 0; /* Not "tw/td" or "twi/tdi". Let + debugger have it */ +} + +OSStatus +handle_error(ExceptionInformation *xp, unsigned errnum, unsigned rb, unsigned continuable, pc where) +{ + LispObj errdisp = nrs_ERRDISP.vcell; + + if ((fulltag_of(errdisp) == fulltag_misc) && + (header_subtag(header_of(errdisp)) == subtag_macptr)) { + /* errdisp is a macptr, we can call back to lisp */ + callback_for_trap(errdisp, xp, where, errnum, rb, continuable); + return(0); + } + + return(-1); +} + + +/* + Current thread has all signals masked. Before unmasking them, + make it appear that the current thread has been suspended. + (This is to handle the case where another thread is trying + to GC before this thread is able to sieze the exception lock.) +*/ +int +prepare_to_wait_for_exception_lock(TCR *tcr, ExceptionInformation *context) +{ + int old_valence = tcr->valence; + + tcr->pending_exception_context = context; + tcr->valence = TCR_STATE_EXCEPTION_WAIT; + + ALLOW_EXCEPTIONS(context); + return old_valence; +} + +void +wait_for_exception_lock_in_handler(TCR *tcr, + ExceptionInformation *context, + xframe_list *xf) +{ + + LOCK(lisp_global(EXCEPTION_LOCK), tcr); +#ifdef DEBUG + fprintf(dbgout, "0x%x has exception lock\n", tcr); +#endif + xf->curr = context; + xf->prev = tcr->xframe; + tcr->xframe = xf; + tcr->pending_exception_context = NULL; + tcr->valence = TCR_STATE_FOREIGN; +} + +void +unlock_exception_lock_in_handler(TCR *tcr) +{ + tcr->pending_exception_context = tcr->xframe->curr; + tcr->xframe = tcr->xframe->prev; + tcr->valence = TCR_STATE_EXCEPTION_RETURN; +#ifdef DEBUG + fprintf(dbgout, "0x%x releasing exception lock\n", tcr); +#endif + UNLOCK(lisp_global(EXCEPTION_LOCK),tcr); +} + +/* + If an interrupt is pending on exception exit, try to ensure + that the thread sees it as soon as it's able to run. +*/ +void +raise_pending_interrupt(TCR *tcr) +{ + if (TCR_INTERRUPT_LEVEL(tcr) > 0) { + pthread_kill((pthread_t)ptr_from_lispobj(tcr->osid), SIGNAL_FOR_PROCESS_INTERRUPT); + } +} + +void +exit_signal_handler(TCR *tcr, int old_valence) +{ + sigset_t mask; + sigfillset(&mask); + + pthread_sigmask(SIG_SETMASK,&mask, NULL); + tcr->valence = old_valence; + tcr->pending_exception_context = NULL; +} + + +void +signal_handler(int signum, siginfo_t *info, ExceptionInformation *context, TCR *tcr, int old_valence) +{ + xframe_list xframe_link; + + if (!use_mach_exception_handling) { + + tcr = (TCR *) get_interrupt_tcr(false); + + /* The signal handler's entered with all signals (notably the + thread_suspend signal) blocked. Don't allow any other signals + (notably the thread_suspend signal) to preempt us until we've + set the TCR's xframe slot to include the current exception + context. + */ + + old_valence = prepare_to_wait_for_exception_lock(tcr, context); + } + + if (tcr->flags & (1<regs at #x%lx", signum, xpPC(context), (natural)xpGPRvector(context)); + if (lisp_Debugger(context, info, signum, false, msg)) { + SET_TCR_FLAG(tcr,TCR_FLAG_BIT_PROPAGATE_EXCEPTION); + } + } + + unlock_exception_lock_in_handler(tcr); + + /* This thread now looks like a thread that was suspended while + executing lisp code. If some other thread gets the exception + lock and GCs, the context (this thread's suspend_context) will + be updated. (That's only of concern if it happens before we + can return to the kernel/to the Mach exception handler). + */ + if (!use_mach_exception_handling) { + exit_signal_handler(tcr, old_valence); + raise_pending_interrupt(tcr); + } +} + +/* + If it looks like we're in the middle of an atomic operation, make + it seem as if that operation is either complete or hasn't started + yet. + + The cases handled include: + + a) storing into a newly-allocated lisp frame on the stack. + b) marking a newly-allocated TSP frame as containing "raw" data. + c) consing: the GC has its own ideas about how this should be + handled, but other callers would be best advised to back + up or move forward, according to whether we're in the middle + of allocating a cons cell or allocating a uvector. + d) a STMW to the vsp + e) EGC write-barrier subprims. +*/ + +extern opcode + egc_write_barrier_start, + egc_write_barrier_end, + egc_store_node_conditional, + egc_store_node_conditional_test, + egc_set_hash_key, + egc_gvset, + egc_rplaca, + egc_rplacd, + egc_set_hash_key_conditional, + egc_set_hash_key_conditional_test; + + +extern opcode ffcall_return_window, ffcall_return_window_end; + +void +pc_luser_xp(ExceptionInformation *xp, TCR *tcr, signed_natural *alloc_disp) +{ + pc program_counter = xpPC(xp); + opcode instr = *program_counter; + lisp_frame *frame = (lisp_frame *)ptr_from_lispobj(xpGPR(xp,sp)); + LispObj cur_allocptr = xpGPR(xp, allocptr); + int allocptr_tag = fulltag_of(cur_allocptr); + + + + if ((program_counter < &egc_write_barrier_end) && + (program_counter >= &egc_write_barrier_start)) { + LispObj *ea = 0, val = 0, root = 0; + bitvector refbits = (bitvector)(lisp_global(REFBITS)); + Boolean need_store = true, need_check_memo = true, need_memoize_root = false; + + if (program_counter >= &egc_set_hash_key_conditional) { + if ((program_counter < &egc_set_hash_key_conditional_test) || + ((program_counter == &egc_set_hash_key_conditional_test) && + (! (xpCCR(xp) & 0x20000000)))) { + return; + } + need_store = false; + root = xpGPR(xp,arg_x); + ea = (LispObj *) (root+xpGPR(xp,arg_y)+misc_data_offset); + need_memoize_root = true; + } else if (program_counter >= &egc_store_node_conditional) { + if ((program_counter < &egc_store_node_conditional_test) || + ((program_counter == &egc_store_node_conditional_test) && + (! (xpCCR(xp) & 0x20000000)))) { + /* The conditional store either hasn't been attempted yet, or + has failed. No need to adjust the PC, or do memoization. */ + return; + } + ea = (LispObj*)(xpGPR(xp,arg_x) + xpGPR(xp,imm4)); + xpGPR(xp,arg_z) = t_value; + need_store = false; + } else if (program_counter >= &egc_set_hash_key) { + root = xpGPR(xp,arg_x); + val = xpGPR(xp,arg_z); + ea = (LispObj *) (root+xpGPR(xp,arg_y)+misc_data_offset); + need_memoize_root = true; + } else if (program_counter >= &egc_gvset) { + ea = (LispObj *) (xpGPR(xp,arg_x)+xpGPR(xp,arg_y)+misc_data_offset); + val = xpGPR(xp,arg_z); + } else if (program_counter >= &egc_rplacd) { + ea = (LispObj *) untag(xpGPR(xp,arg_y)); + val = xpGPR(xp,arg_z); + } else { /* egc_rplaca */ + ea = ((LispObj *) untag(xpGPR(xp,arg_y)))+1; + val = xpGPR(xp,arg_z); + } + if (need_store) { + *ea = val; + } + if (need_check_memo) { + natural bitnumber = area_dnode(ea, lisp_global(REF_BASE)); + if ((bitnumber < lisp_global(OLDSPACE_DNODE_COUNT)) && + ((LispObj)ea < val)) { + atomic_set_bit(refbits, bitnumber); + if (need_memoize_root) { + bitnumber = area_dnode(root, lisp_global(REF_BASE)); + atomic_set_bit(refbits, bitnumber); + } + } + } + set_xpPC(xp, xpLR(xp)); + return; + } + + + if (instr == MARK_TSP_FRAME_INSTRUCTION) { + LispObj tsp_val = xpGPR(xp,tsp); + + ((LispObj *)ptr_from_lispobj(tsp_val))[1] = tsp_val; + adjust_exception_pc(xp, 4); + return; + } + + if (frame->backlink == (frame+1)) { + if ( +#ifdef PPC64 + (major_opcode_p(instr, major_opcode_DS_STORE64)) && + (DS_VARIANT_FIELD(instr) == DS_STORE64_VARIANT_STD) && +#else + (major_opcode_p(instr, major_opcode_STW)) && +#endif + (RA_field(instr) == sp) && + /* There are a few places in the runtime that store into + a previously-allocated frame atop the stack when + throwing values around. We only care about the case + where the frame was newly allocated, in which case + there must have been a CREATE_LISP_FRAME_INSTRUCTION + a few instructions before the current program counter. + (The whole point here is that a newly allocated frame + might contain random values that we don't want the + GC to see; a previously allocated frame should already + be completely initialized.) + */ + ((program_counter[-1] == CREATE_LISP_FRAME_INSTRUCTION) || + (program_counter[-2] == CREATE_LISP_FRAME_INSTRUCTION) || + (program_counter[-3] == CREATE_LISP_FRAME_INSTRUCTION))) { +#ifdef PPC64 + int disp = DS_field(instr); +#else + int disp = D_field(instr); +#endif + + + if (disp < (4*node_size)) { +#if 0 + fprintf(dbgout, "pc-luser: finish SP frame in 0x%x, disp = %d\n",tcr, disp); +#endif + frame->savevsp = 0; + if (disp < (3*node_size)) { + frame->savelr = 0; + if (disp == node_size) { + frame->savefn = 0; + } + } + } + return; + } + } + + if (allocptr_tag != tag_fixnum) { + signed_natural disp = allocptr_displacement(xp); + + if (disp) { + /* Being architecturally "at" the alloc trap doesn't tell + us much (in particular, it doesn't tell us whether + or not the thread has committed to taking the trap + and is waiting for the exception lock (or waiting + for the Mach exception thread to tell it how bad + things are) or is about to execute a conditional + trap. + Regardless of which case applies, we want the + other thread to take (or finish taking) the + trap, and we don't want it to consider its + current allocptr to be valid. + The difference between this case (suspend other + thread for GC) and the previous case (suspend + current thread for interrupt) is solely a + matter of what happens after we leave this + function: some non-current thread will stay + suspended until the GC finishes, then take + (or start processing) the alloc trap. The + current thread will go off and do PROCESS-INTERRUPT + or something, and may return from the interrupt + and need to finish the allocation that got interrupted. + */ + + if (alloc_disp) { + *alloc_disp = disp; + xpGPR(xp,allocptr) += disp; + /* Leave the PC at the alloc trap. When the interrupt + handler returns, it'll decrement allocptr by disp + and the trap may or may not be taken. + */ + } else { + update_bytes_allocated(tcr, (void *) ptr_from_lispobj(cur_allocptr + disp)); + xpGPR(xp, allocbase) = VOID_ALLOCPTR; + xpGPR(xp, allocptr) = VOID_ALLOCPTR - disp; + } + } else { +#ifdef DEBUG + fprintf(dbgout, "tcr 0x%x is past alloc trap, finishing alloc at 0x%x\n", tcr, xpGPR(xp,allocptr)); +#endif + /* If we're already past the alloc_trap, finish allocating + the object. */ + if (allocptr_tag == fulltag_cons) { + finish_allocating_cons(xp); +#ifdef DEBUG + fprintf(dbgout, "finish allocating cons in TCR = #x%x\n", + tcr); +#endif + } else { + if (allocptr_tag == fulltag_misc) { +#ifdef DEBUG + fprintf(dbgout, "finish allocating uvector in TCR = #x%x\n", + tcr); +#endif + finish_allocating_uvector(xp); + } else { + Bug(xp, "what's being allocated here ?"); + } + } + /* Whatever we finished allocating, reset allocptr/allocbase to + VOID_ALLOCPTR */ + xpGPR(xp,allocptr) = xpGPR(xp,allocbase) = VOID_ALLOCPTR; + } + return; + } + + if ((instr & INIT_CATCH_FRAME_MASK) == INIT_CATCH_FRAME_INSTRUCTION) { + LispObj *frame = ptr_from_lispobj(untag(xpGPR(xp, nargs))); + int idx = ((int)((short)(D_field(instr))+fulltag_misc))>>fixnumshift; +#if 0 + fprintf(dbgout, "pc-luser: CATCH frame in 0x%x, idx = %d\n",tcr, idx); +#endif + + for (;idx < sizeof(catch_frame)/sizeof(LispObj); idx++) { + deref(frame,idx) = 0; + } + ((LispObj *)(xpGPR(xp, tsp)))[1] = 0; + return; + } + +#ifndef PC64 + if ((major_opcode_p(instr, 47)) && /* 47 = stmw */ + (RA_field(instr) == vsp)) { + int r; + LispObj *vspptr = ptr_from_lispobj(xpGPR(xp,vsp)); + + for (r = RS_field(instr); r <= 31; r++) { + *vspptr++ = xpGPR(xp,r); + } + adjust_exception_pc(xp, 4); + } +#endif +} + +void +interrupt_handler (int signum, siginfo_t *info, ExceptionInformation *context) +{ + TCR *tcr = get_interrupt_tcr(false); + if (tcr) { + if (TCR_INTERRUPT_LEVEL(tcr) < 0) { + tcr->interrupt_pending = 1 << fixnumshift; + } else { + LispObj cmain = nrs_CMAIN.vcell; + + if ((fulltag_of(cmain) == fulltag_misc) && + (header_subtag(header_of(cmain)) == subtag_macptr)) { + /* + This thread can (allegedly) take an interrupt now. + It's tricky to do that if we're executing + foreign code (especially Linuxthreads code, much + of which isn't reentrant.) + If we're unwinding the stack, we also want to defer + the interrupt. + */ + if ((tcr->valence != TCR_STATE_LISP) || + (tcr->unwinding != 0)) { + TCR_INTERRUPT_LEVEL(tcr) = (1 << fixnumshift); + } else { + xframe_list xframe_link; + int old_valence; + signed_natural disp=0; + + pc_luser_xp(context, tcr, &disp); + old_valence = prepare_to_wait_for_exception_lock(tcr, context); + wait_for_exception_lock_in_handler(tcr, context, &xframe_link); +#ifdef DEBUG + fprintf(dbgout, "[0x%x acquired exception lock for interrupt]\n",tcr); +#endif + PMCL_exception_handler(signum, context, tcr, info, old_valence); + if (disp) { + xpGPR(context,allocptr) -= disp; + } + unlock_exception_lock_in_handler(tcr); +#ifdef DEBUG + fprintf(dbgout, "[0x%x released exception lock for interrupt]\n",tcr); +#endif + exit_signal_handler(tcr, old_valence); + } + } + } + } +#ifdef DARWIN + DarwinSigReturn(context); +#endif +} + + + +void +install_signal_handler(int signo, void *handler) +{ + struct sigaction sa; + + sa.sa_sigaction = (void *)handler; + sigfillset(&sa.sa_mask); + sa.sa_flags = + 0 /* SA_RESTART */ + | SA_SIGINFO +#ifdef DARWIN +#ifdef PPC64 + | SA_64REGSET +#endif +#endif + ; + + sigaction(signo, &sa, NULL); +} + +void +install_pmcl_exception_handlers() +{ +#ifdef DARWIN + extern Boolean use_mach_exception_handling; +#endif + + Boolean install_signal_handlers_for_exceptions = +#ifdef DARWIN + !use_mach_exception_handling +#else + true +#endif + ; + if (install_signal_handlers_for_exceptions) { + extern int no_sigtrap; + install_signal_handler(SIGILL, (void *)signal_handler); + if (no_sigtrap != 1) { + install_signal_handler(SIGTRAP, (void *)signal_handler); + } + install_signal_handler(SIGBUS, (void *)signal_handler); + install_signal_handler(SIGSEGV, (void *)signal_handler); + install_signal_handler(SIGFPE, (void *)signal_handler); + } + + install_signal_handler(SIGNAL_FOR_PROCESS_INTERRUPT, + (void *)interrupt_handler); + signal(SIGPIPE, SIG_IGN); +} + +void +thread_kill_handler(int signum, siginfo_t info, ExceptionInformation *xp) +{ + TCR *tcr = get_tcr(false); + area *a; + sigset_t mask; + + sigemptyset(&mask); + + if (tcr) { + tcr->valence = TCR_STATE_FOREIGN; + a = tcr->vs_area; + if (a) { + a->active = a->high; + } + a = tcr->ts_area; + if (a) { + a->active = a->high; + } + a = tcr->cs_area; + if (a) { + a->active = a->high; + } + } + + pthread_sigmask(SIG_SETMASK,&mask,NULL); + pthread_exit(NULL); +} + +void +thread_signal_setup() +{ + thread_suspend_signal = SIG_SUSPEND_THREAD; + thread_kill_signal = SIG_KILL_THREAD; + + install_signal_handler(thread_suspend_signal, (void *) suspend_resume_handler); + install_signal_handler(thread_kill_signal, (void *)thread_kill_handler); +} + + + +void +unprotect_all_areas() +{ + protected_area_ptr p; + + for(p = AllProtectedAreas, AllProtectedAreas = NULL; p; p = p->next) { + unprotect_area(p); + } +} + +/* + A binding subprim has just done "twlle limit_regno,idx_regno" and + the trap's been taken. Extend the tcr's tlb so that the index will + be in bounds and the new limit will be on a page boundary, filling + in the new page(s) with 'no_thread_local_binding_marker'. Update + the tcr fields and the registers in the xp and return true if this + all works, false otherwise. + + Note that the tlb was allocated via malloc, so realloc can do some + of the hard work. +*/ +Boolean +extend_tcr_tlb(TCR *tcr, + ExceptionInformation *xp, + unsigned limit_regno, + unsigned idx_regno) +{ + unsigned + index = (unsigned) (xpGPR(xp,idx_regno)), + old_limit = tcr->tlb_limit, + new_limit = align_to_power_of_2(index+1,12), + new_bytes = new_limit-old_limit; + LispObj + *old_tlb = tcr->tlb_pointer, + *new_tlb = realloc(old_tlb, new_limit), + *work; + + if (new_tlb == NULL) { + return false; + } + + work = (LispObj *) ((BytePtr)new_tlb+old_limit); + + while (new_bytes) { + *work++ = no_thread_local_binding_marker; + new_bytes -= sizeof(LispObj); + } + tcr->tlb_pointer = new_tlb; + tcr->tlb_limit = new_limit; + xpGPR(xp, limit_regno) = new_limit; + return true; +} + + + +void +exception_init() +{ + install_pmcl_exception_handlers(); +} + + + + + +#ifdef DARWIN + + +#define TCR_FROM_EXCEPTION_PORT(p) ((TCR *)((natural)p)) +#define TCR_TO_EXCEPTION_PORT(tcr) ((mach_port_t)((natural)(tcr))) + + + +#define LISP_EXCEPTIONS_HANDLED_MASK \ + (EXC_MASK_SOFTWARE | EXC_MASK_BAD_ACCESS | EXC_MASK_BAD_INSTRUCTION | EXC_MASK_ARITHMETIC) + +/* (logcount LISP_EXCEPTIONS_HANDLED_MASK) */ +#define NUM_LISP_EXCEPTIONS_HANDLED 4 + +typedef struct { + int foreign_exception_port_count; + exception_mask_t masks[NUM_LISP_EXCEPTIONS_HANDLED]; + mach_port_t ports[NUM_LISP_EXCEPTIONS_HANDLED]; + exception_behavior_t behaviors[NUM_LISP_EXCEPTIONS_HANDLED]; + thread_state_flavor_t flavors[NUM_LISP_EXCEPTIONS_HANDLED]; +} MACH_foreign_exception_state; + + + + +/* + Mach's exception mechanism works a little better than its signal + mechanism (and, not incidentally, it gets along with GDB a lot + better. + + Initially, we install an exception handler to handle each native + thread's exceptions. This process involves creating a distinguished + thread which listens for kernel exception messages on a set of + 0 or more thread exception ports. As threads are created, they're + added to that port set; a thread's exception port is destroyed + (and therefore removed from the port set) when the thread exits. + + A few exceptions can be handled directly in the handler thread; + others require that we resume the user thread (and that the + exception thread resumes listening for exceptions.) The user + thread might eventually want to return to the original context + (possibly modified somewhat.) + + As it turns out, the simplest way to force the faulting user + thread to handle its own exceptions is to do pretty much what + signal() does: the exception handlng thread sets up a sigcontext + on the user thread's stack and forces the user thread to resume + execution as if a signal handler had been called with that + context as an argument. We can use a distinguished UUO at a + distinguished address to do something like sigreturn(); that'll + have the effect of resuming the user thread's execution in + the (pseudo-) signal context. + + Since: + a) we have miles of code in C and in Lisp that knows how to + deal with Linux sigcontexts + b) Linux sigcontexts contain a little more useful information + (the DAR, DSISR, etc.) than their Darwin counterparts + c) we have to create a sigcontext ourselves when calling out + to the user thread: we aren't really generating a signal, just + leveraging existing signal-handling code. + + we create a Linux sigcontext struct. + + Simple ? Hopefully from the outside it is ... + + We want the process of passing a thread's own context to it to + appear to be atomic: in particular, we don't want the GC to suspend + a thread that's had an exception but has not yet had its user-level + exception handler called, and we don't want the thread's exception + context to be modified by a GC while the Mach handler thread is + copying it around. On Linux (and on Jaguar), we avoid this issue + because (a) the kernel sets up the user-level signal handler and + (b) the signal handler blocks signals (including the signal used + by the GC to suspend threads) until tcr->xframe is set up. + + The GC and the Mach server thread therefore contend for the lock + "mach_exception_lock". The Mach server thread holds the lock + when copying exception information between the kernel and the + user thread; the GC holds this lock during most of its execution + (delaying exception processing until it can be done without + GC interference.) + +*/ + +#ifdef PPC64 +#define C_REDZONE_LEN 320 +#define C_STK_ALIGN 32 +#else +#define C_REDZONE_LEN 224 +#define C_STK_ALIGN 16 +#endif +#define C_PARAMSAVE_LEN 64 +#define C_LINKAGE_LEN 48 + +#define TRUNC_DOWN(a,b,c) (((((natural)a)-(b))/(c)) * (c)) + +void +fatal_mach_error(char *format, ...); + +#define MACH_CHECK_ERROR(context,x) if (x != KERN_SUCCESS) {fatal_mach_error("Mach error while %s : %d", context, x);} + + +void +restore_mach_thread_state(mach_port_t thread, ExceptionInformation *pseudosigcontext) +{ + kern_return_t kret; + MCONTEXT_T mc = UC_MCONTEXT(pseudosigcontext); + + /* Set the thread's FP state from the pseudosigcontext */ + kret = thread_set_state(thread, + PPC_FLOAT_STATE, + (thread_state_t)&(mc->__fs), + PPC_FLOAT_STATE_COUNT); + + MACH_CHECK_ERROR("setting thread FP state", kret); + + /* The thread'll be as good as new ... */ +#ifdef PPC64 + kret = thread_set_state(thread, + PPC_THREAD_STATE64, + (thread_state_t)&(mc->__ss), + PPC_THREAD_STATE64_COUNT); +#else + kret = thread_set_state(thread, + MACHINE_THREAD_STATE, + (thread_state_t)&(mc->__ss), + MACHINE_THREAD_STATE_COUNT); +#endif + MACH_CHECK_ERROR("setting thread state", kret); +} + +/* This code runs in the exception handling thread, in response + to an attempt to execute the UU0 at "pseudo_sigreturn" (e.g., + in response to a call to pseudo_sigreturn() from the specified + user thread. + Find that context (the user thread's R3 points to it), then + use that context to set the user thread's state. When this + function's caller returns, the Mach kernel will resume the + user thread. +*/ + +kern_return_t +do_pseudo_sigreturn(mach_port_t thread, TCR *tcr) +{ + ExceptionInformation *xp; + +#ifdef DEBUG_MACH_EXCEPTIONS + fprintf(dbgout, "doing pseudo_sigreturn for 0x%x\n",tcr); +#endif + xp = tcr->pending_exception_context; + if (xp) { + tcr->pending_exception_context = NULL; + tcr->valence = TCR_STATE_LISP; + restore_mach_thread_state(thread, xp); + raise_pending_interrupt(tcr); + } else { + Bug(NULL, "no xp here!\n"); + } +#ifdef DEBUG_MACH_EXCEPTIONS + fprintf(dbgout, "did pseudo_sigreturn for 0x%x\n",tcr); +#endif + return KERN_SUCCESS; +} + +ExceptionInformation * +create_thread_context_frame(mach_port_t thread, + natural *new_stack_top) +{ +#ifdef PPC64 + ppc_thread_state64_t ts; +#else + ppc_thread_state_t ts; +#endif + mach_msg_type_number_t thread_state_count; + kern_return_t result; + ExceptionInformation *pseudosigcontext; + MCONTEXT_T mc; + natural stackp, backlink; + +#ifdef PPC64 + thread_state_count = PPC_THREAD_STATE64_COUNT; + result = thread_get_state(thread, + PPC_THREAD_STATE64, + (thread_state_t)&ts, + &thread_state_count); +#else + thread_state_count = MACHINE_THREAD_STATE_COUNT; + result = thread_get_state(thread, + PPC_THREAD_STATE, /* GPRs, some SPRs */ + (thread_state_t)&ts, + &thread_state_count); +#endif + + if (result != KERN_SUCCESS) { + get_tcr(true); + Bug(NULL, "Exception thread can't obtain thread state, Mach result = %d", result); + } + stackp = ts.__r1; + backlink = stackp; + stackp = TRUNC_DOWN(stackp, C_REDZONE_LEN, C_STK_ALIGN); + stackp -= sizeof(*pseudosigcontext); + pseudosigcontext = (ExceptionInformation *) ptr_from_lispobj(stackp); + + stackp = TRUNC_DOWN(stackp, sizeof(*mc), C_STK_ALIGN); + mc = (MCONTEXT_T) ptr_from_lispobj(stackp); + memmove(&(mc->__ss),&ts,sizeof(ts)); + + thread_state_count = PPC_FLOAT_STATE_COUNT; + thread_get_state(thread, + PPC_FLOAT_STATE, + (thread_state_t)&(mc->__fs), + &thread_state_count); + + +#ifdef PPC64 + thread_state_count = PPC_EXCEPTION_STATE64_COUNT; +#else + thread_state_count = PPC_EXCEPTION_STATE_COUNT; +#endif + thread_get_state(thread, +#ifdef PPC64 + PPC_EXCEPTION_STATE64, +#else + PPC_EXCEPTION_STATE, +#endif + (thread_state_t)&(mc->__es), + &thread_state_count); + + + UC_MCONTEXT(pseudosigcontext) = mc; + stackp = TRUNC_DOWN(stackp, C_PARAMSAVE_LEN, C_STK_ALIGN); + stackp -= C_LINKAGE_LEN; + *(natural *)ptr_from_lispobj(stackp) = backlink; + if (new_stack_top) { + *new_stack_top = stackp; + } + return pseudosigcontext; +} + +/* + This code sets up the user thread so that it executes a "pseudo-signal + handler" function when it resumes. Create a linux sigcontext struct + on the thread's stack and pass it as an argument to the pseudo-signal + handler. + + Things are set up so that the handler "returns to" pseudo_sigreturn(), + which will restore the thread's context. + + If the handler invokes code that throws (or otherwise never sigreturn()'s + to the context), that's fine. + + Actually, check that: throw (and variants) may need to be careful and + pop the tcr's xframe list until it's younger than any frame being + entered. +*/ + +int +setup_signal_frame(mach_port_t thread, + void *handler_address, + int signum, + int code, + TCR *tcr) +{ +#ifdef PPC64 + ppc_thread_state64_t ts; +#else + ppc_thread_state_t ts; +#endif + ExceptionInformation *pseudosigcontext; + int old_valence = tcr->valence; + natural stackp; + +#ifdef DEBUG_MACH_EXCEPTIONS + fprintf(dbgout,"Setting up exception handling for 0x%x\n", tcr); +#endif + pseudosigcontext = create_thread_context_frame(thread, &stackp); + pseudosigcontext->uc_onstack = 0; + pseudosigcontext->uc_sigmask = (sigset_t) 0; + tcr->pending_exception_context = pseudosigcontext; + tcr->valence = TCR_STATE_EXCEPTION_WAIT; + + + /* + It seems like we've created a sigcontext on the thread's + stack. Set things up so that we call the handler (with appropriate + args) when the thread's resumed. + */ + + ts.__srr0 = (natural) handler_address; + ts.__srr1 = (int) xpMSR(pseudosigcontext) & ~MSR_FE0_FE1_MASK; + ts.__r1 = stackp; + ts.__r3 = signum; + ts.__r4 = (natural)pseudosigcontext; + ts.__r5 = (natural)tcr; + ts.__r6 = (natural)old_valence; + ts.__lr = (natural)pseudo_sigreturn; + + +#ifdef PPC64 + ts.__r13 = xpGPR(pseudosigcontext,13); + thread_set_state(thread, + PPC_THREAD_STATE64, + (thread_state_t)&ts, + PPC_THREAD_STATE64_COUNT); +#else + thread_set_state(thread, + MACHINE_THREAD_STATE, + (thread_state_t)&ts, + MACHINE_THREAD_STATE_COUNT); +#endif +#ifdef DEBUG_MACH_EXCEPTIONS + fprintf(dbgout,"Set up exception context for 0x%x at 0x%x\n", tcr, tcr->pending_exception_context); +#endif + return 0; +} + + +void +pseudo_signal_handler(int signum, ExceptionInformation *context, TCR *tcr, int old_valence) +{ + signal_handler(signum, NULL, context, tcr, old_valence); +} + + +int +thread_set_fp_exceptions_enabled(mach_port_t thread, Boolean enabled) +{ +#ifdef PPC64 + ppc_thread_state64_t ts; +#else + ppc_thread_state_t ts; +#endif + mach_msg_type_number_t thread_state_count; + +#ifdef PPC64 + thread_state_count = PPC_THREAD_STATE64_COUNT; +#else + thread_state_count = PPC_THREAD_STATE_COUNT; +#endif + thread_get_state(thread, +#ifdef PPC64 + PPC_THREAD_STATE64, /* GPRs, some SPRs */ +#else + PPC_THREAD_STATE, /* GPRs, some SPRs */ +#endif + (thread_state_t)&ts, + &thread_state_count); + if (enabled) { + ts.__srr1 |= MSR_FE0_FE1_MASK; + } else { + ts.__srr1 &= ~MSR_FE0_FE1_MASK; + } + /* + Hack-o-rama warning (isn't it about time for such a warning?): + pthread_kill() seems to want to lose the MSR's FE0/FE1 bits. + Our handler for lisp's use of pthread_kill() pushes a phony + lisp frame on the stack and force the context to resume at + the UUO in enable_fp_exceptions(); the "saveLR" field of that + lisp frame contains the -real- address that process_interrupt + should have returned to, and the fact that it's in a lisp + frame should convince the GC to notice that address if it + runs in the tiny time window between returning from our + interrupt handler and ... here. + If the top frame on the stack is a lisp frame, discard it + and set ts.srr0 to the saveLR field in that frame. Otherwise, + just adjust ts.srr0 to skip over the UUO. + */ + { + lisp_frame *tos = (lisp_frame *)ts.__r1, + *next_frame = tos->backlink; + + if (tos == (next_frame -1)) { + ts.__srr0 = tos->savelr; + ts.__r1 = (LispObj) next_frame; + } else { + ts.__srr0 += 4; + } + } + thread_set_state(thread, +#ifdef PPC64 + PPC_THREAD_STATE64, /* GPRs, some SPRs */ +#else + PPC_THREAD_STATE, /* GPRs, some SPRs */ +#endif + (thread_state_t)&ts, +#ifdef PPC64 + PPC_THREAD_STATE64_COUNT +#else + PPC_THREAD_STATE_COUNT +#endif + ); + + return 0; +} + +/* + This function runs in the exception handling thread. It's + called (by this precise name) from the library function "exc_server()" + when the thread's exception ports are set up. (exc_server() is called + via mach_msg_server(), which is a function that waits for and dispatches + on exception messages from the Mach kernel.) + + This checks to see if the exception was caused by a pseudo_sigreturn() + UUO; if so, it arranges for the thread to have its state restored + from the specified context. + + Otherwise, it tries to map the exception to a signal number and + arranges that the thread run a "pseudo signal handler" to handle + the exception. + + Some exceptions could and should be handled here directly. +*/ + +kern_return_t +catch_exception_raise(mach_port_t exception_port, + mach_port_t thread, + mach_port_t task, + exception_type_t exception, + exception_data_t code_vector, + mach_msg_type_number_t code_count) +{ + int signum = 0, code = *code_vector, code1; + TCR *tcr = TCR_FROM_EXCEPTION_PORT(exception_port); + kern_return_t kret; + +#ifdef DEBUG_MACH_EXCEPTIONS + fprintf(dbgout, "obtaining Mach exception lock in exception thread\n"); +#endif + + if (tcr->flags & (1<flags & (1<NDR = _NDR; + + out->msgh_bits = in->msgh_bits & MACH_MSGH_BITS_REMOTE_MASK; + out->msgh_remote_port = in->msgh_remote_port; + out->msgh_size = sizeof(mach_msg_header_t)+(3 * sizeof(unsigned)); + out->msgh_local_port = MACH_PORT_NULL; + out->msgh_id = in->msgh_id+100; + + /* Could handle other exception flavors in the range 2401-2403 */ + + + if (in->msgh_id != 2401) { + reply->RetCode = MIG_BAD_ID; + return FALSE; + } + handled = catch_exception_raise(req->Head.msgh_local_port, + req->thread.name, + req->task.name, + req->exception, + req->code, + req->codeCnt); + reply->RetCode = handled; + return TRUE; +} + +/* + The initial function for an exception-handling thread. +*/ + +void * +exception_handler_proc(void *arg) +{ + extern boolean_t exc_server(); + mach_port_t p = TCR_TO_EXCEPTION_PORT(arg); + + mach_msg_server(openmcl_exc_server, 2048, p, 0); + /* Should never return. */ + abort(); +} + + + +mach_port_t +mach_exception_port_set() +{ + static mach_port_t __exception_port_set = MACH_PORT_NULL; + kern_return_t kret; + if (__exception_port_set == MACH_PORT_NULL) { + kret = mach_port_allocate(mach_task_self(), + MACH_PORT_RIGHT_PORT_SET, + &__exception_port_set); + MACH_CHECK_ERROR("allocating thread exception_ports",kret); + create_system_thread(0, + NULL, + exception_handler_proc, + (void *)((natural)__exception_port_set)); + } + return __exception_port_set; +} + +/* + Setup a new thread to handle those exceptions specified by + the mask "which". This involves creating a special Mach + message port, telling the Mach kernel to send exception + messages for the calling thread to that port, and setting + up a handler thread which listens for and responds to + those messages. + +*/ + +/* + Establish the lisp thread's TCR as its exception port, and determine + whether any other ports have been established by foreign code for + exceptions that lisp cares about. + + If this happens at all, it should happen on return from foreign + code and on entry to lisp code via a callback. + + This is a lot of trouble (and overhead) to support Java, or other + embeddable systems that clobber their caller's thread exception ports. + +*/ +kern_return_t +tcr_establish_exception_port(TCR *tcr, mach_port_t thread) +{ + kern_return_t kret; + MACH_foreign_exception_state *fxs = (MACH_foreign_exception_state *)tcr->native_thread_info; + int i; + unsigned n = NUM_LISP_EXCEPTIONS_HANDLED; + mach_port_t lisp_port = TCR_TO_EXCEPTION_PORT(tcr), foreign_port; + exception_mask_t mask = 0; + + kret = thread_swap_exception_ports(thread, + LISP_EXCEPTIONS_HANDLED_MASK, + lisp_port, + EXCEPTION_DEFAULT, + THREAD_STATE_NONE, + fxs->masks, + &n, + fxs->ports, + fxs->behaviors, + fxs->flavors); + if (kret == KERN_SUCCESS) { + fxs->foreign_exception_port_count = n; + for (i = 0; i < n; i ++) { + foreign_port = fxs->ports[i]; + + if ((foreign_port != lisp_port) && + (foreign_port != MACH_PORT_NULL)) { + mask |= fxs->masks[i]; + } + } + tcr->foreign_exception_status = (int) mask; + } + return kret; +} + +kern_return_t +tcr_establish_lisp_exception_port(TCR *tcr) +{ + return tcr_establish_exception_port(tcr, (mach_port_t)((natural)tcr->native_thread_id)); +} + +/* + Do this when calling out to or returning from foreign code, if + any conflicting foreign exception ports were established when we + last entered lisp code. +*/ +kern_return_t +restore_foreign_exception_ports(TCR *tcr) +{ + exception_mask_t m = (exception_mask_t) tcr->foreign_exception_status; + + if (m) { + MACH_foreign_exception_state *fxs = + (MACH_foreign_exception_state *) tcr->native_thread_info; + int i, n = fxs->foreign_exception_port_count; + exception_mask_t tm; + + for (i = 0; i < n; i++) { + if ((tm = fxs->masks[i]) & m) { + thread_set_exception_ports((mach_port_t)((natural)tcr->native_thread_id), + tm, + fxs->ports[i], + fxs->behaviors[i], + fxs->flavors[i]); + } + } + } +} + + +/* + This assumes that a Mach port (to be used as the thread's exception port) whose + "name" matches the TCR's 32-bit address has already been allocated. +*/ + +kern_return_t +setup_mach_exception_handling(TCR *tcr) +{ + mach_port_t + thread_exception_port = TCR_TO_EXCEPTION_PORT(tcr), + task_self = mach_task_self(); + kern_return_t kret; + + kret = mach_port_insert_right(task_self, + thread_exception_port, + thread_exception_port, + MACH_MSG_TYPE_MAKE_SEND); + MACH_CHECK_ERROR("adding send right to exception_port",kret); + + kret = tcr_establish_exception_port(tcr, (mach_port_t)((natural) tcr->native_thread_id)); + if (kret == KERN_SUCCESS) { + mach_port_t exception_port_set = mach_exception_port_set(); + + kret = mach_port_move_member(task_self, + thread_exception_port, + exception_port_set); + } + return kret; +} + +void +darwin_exception_init(TCR *tcr) +{ + void tcr_monitor_exception_handling(TCR*, Boolean); + kern_return_t kret; + MACH_foreign_exception_state *fxs = + calloc(1, sizeof(MACH_foreign_exception_state)); + + tcr->native_thread_info = (void *) fxs; + + if ((kret = setup_mach_exception_handling(tcr)) + != KERN_SUCCESS) { + fprintf(dbgout, "Couldn't setup exception handler - error = %d\n", kret); + terminate_lisp(); + } +} + +/* + The tcr is the "name" of the corresponding thread's exception port. + Destroying the port should remove it from all port sets of which it's + a member (notably, the exception port set.) +*/ +void +darwin_exception_cleanup(TCR *tcr) +{ + void *fxs = tcr->native_thread_info; + extern Boolean use_mach_exception_handling; + + if (fxs) { + tcr->native_thread_info = NULL; + free(fxs); + } + if (use_mach_exception_handling) { + mach_port_deallocate(mach_task_self(),TCR_TO_EXCEPTION_PORT(tcr)); + mach_port_destroy(mach_task_self(),TCR_TO_EXCEPTION_PORT(tcr)); + } +} + + +Boolean +suspend_mach_thread(mach_port_t mach_thread) +{ + kern_return_t status; + Boolean aborted = false; + + do { + aborted = false; + status = thread_suspend(mach_thread); + if (status == KERN_SUCCESS) { + status = thread_abort_safely(mach_thread); + if (status == KERN_SUCCESS) { + aborted = true; + } else { + fprintf(dbgout, "abort failed on thread = 0x%x\n",mach_thread); + thread_resume(mach_thread); + } + } else { + return false; + } + } while (! aborted); + return true; +} + +/* + Only do this if pthread_kill indicated that the pthread isn't + listening to signals anymore, as can happen as soon as pthread_exit() + is called on Darwin. The thread could still call out to lisp as it + is exiting, so we need another way to suspend it in this case. +*/ +Boolean +mach_suspend_tcr(TCR *tcr) +{ + mach_port_t mach_thread = (mach_port_t)((natural)( tcr->native_thread_id)); + ExceptionInformation *pseudosigcontext; + Boolean result = false; + + result = suspend_mach_thread(mach_thread); + if (result) { + pseudosigcontext = create_thread_context_frame(mach_thread, NULL); + pseudosigcontext->uc_onstack = 0; + pseudosigcontext->uc_sigmask = (sigset_t) 0; + tcr->suspend_context = pseudosigcontext; + } + return result; +} + +void +mach_resume_tcr(TCR *tcr) +{ + ExceptionInformation *xp; + mach_port_t mach_thread = (mach_port_t)((natural)(tcr->native_thread_id)); + + xp = tcr->suspend_context; +#ifdef DEBUG_MACH_EXCEPTIONS + fprintf(dbgout, "resuming TCR 0x%x, pending_exception_context = 0x%x\n", + tcr, tcr->pending_exception_context); +#endif + tcr->suspend_context = NULL; + restore_mach_thread_state(mach_thread, xp); +#ifdef DEBUG_MACH_EXCEPTIONS + fprintf(dbgout, "restored state in TCR 0x%x, pending_exception_context = 0x%x\n", + tcr, tcr->pending_exception_context); +#endif + thread_resume(mach_thread); +} + +void +fatal_mach_error(char *format, ...) +{ + va_list args; + char s[512]; + + + va_start(args, format); + vsnprintf(s, sizeof(s),format, args); + va_end(args); + + Fatal("Mach error", s); +} + +void +pseudo_interrupt_handler(int signum, ExceptionInformation *context) +{ + interrupt_handler(signum, NULL, context); +} + +int +mach_raise_thread_interrupt(TCR *target) +{ + mach_port_t mach_thread = (mach_port_t)((natural)(target->native_thread_id)); + kern_return_t kret; + Boolean result = false; + TCR *current = get_tcr(false); + thread_basic_info_data_t info; + mach_msg_type_number_t info_count = THREAD_BASIC_INFO_COUNT; + + LOCK(lisp_global(TCR_AREA_LOCK), current); + + if (suspend_mach_thread(mach_thread)) { + if (thread_info(mach_thread, + THREAD_BASIC_INFO, + (thread_info_t)&info, + &info_count) == KERN_SUCCESS) { + if (info.suspend_count == 1) { + if ((target->valence == TCR_STATE_LISP) && + (!target->unwinding) && + (TCR_INTERRUPT_LEVEL(target) >= 0)) { + kret = setup_signal_frame(mach_thread, + (void *)pseudo_interrupt_handler, + SIGNAL_FOR_PROCESS_INTERRUPT, + 0, + target); + if (kret == KERN_SUCCESS) { + result = true; + } + } + } + } + if (! result) { + target->interrupt_pending = 1 << fixnumshift; + } + thread_resume(mach_thread); + + } + UNLOCK(lisp_global(TCR_AREA_LOCK), current); + return 0; +} + +#endif Index: /branches/new-random/lisp-kernel/ppc-exceptions.h =================================================================== --- /branches/new-random/lisp-kernel/ppc-exceptions.h (revision 13309) +++ /branches/new-random/lisp-kernel/ppc-exceptions.h (revision 13309) @@ -0,0 +1,440 @@ +/* + Copyright (C) 2009 Clozure Associates + Copyright (C) 1994-2001 Digitool, Inc + This file is part of Clozure CL. + + Clozure CL is licensed under the terms of the Lisp Lesser GNU Public + License , known as the LLGPL and distributed with Clozure CL as the + file "LICENSE". The LLGPL consists of a preamble and the LGPL, + which is distributed with Clozure CL as the file "LGPL". Where these + conflict, the preamble takes precedence. + + Clozure CL is referenced in the preamble as the "LIBRARY." + + The LLGPL is also available online at + http://opensource.franz.com/preamble.html +*/ +#define UUO_MASK 0xfc00000f + +#define IS_UUO(i) (((i) & UUO_MASK) == 0xb) +/* If an instruction is a UUO, the minor opcode is in bits 21:27 */ +#define UUO_MINOR(u) (((u) >> 4) & 0x7f) + +typedef u_int32_t opcode, *pc; + +OSStatus +handle_uuo(ExceptionInformation *, opcode, pc); + + + +#ifdef LINUX +/* + Different (recent) versions of glibc disagree about how + a ucontext is laid out (and about what an mcontext is.) + There's something like a pointer to a pt_regs structure + in the 12th word in both cases. (Yes, this is an extremely + ugly hack; it would be better to conditionalize on the values + of GLIBC_VERSION/GLIBC_MINOR , but the discrepancy exists + in various flavors of glibc 2.3.) +*/ +#ifdef PPC64 +#define XP_PTREGS(x) ((x)->uc_mcontext.regs) +#define xpGPRvector(x) ((natural *)(XP_PTREGS(x))) +#else +#define XP_PTREGS(x) (((struct pt_regs **)(x))[12]) +#define xpGPRvector(x) (XP_PTREGS(x)->gpr) +#endif +#define xpGPR(x,gprno) (xpGPRvector(x)[gprno]) +#define set_xpGPR(x,gpr,new) xpGPR((x),(gpr)) = (natural)(new) +#define xpPC(x) (*((pc*)(&(XP_PTREGS(x)->nip)))) +#define set_xpPC(x,new) (xpPC(x) = (pc)(new)) +#define xpLR(x) (*((pc*)(&(XP_PTREGS(x)->link)))) +#define xpCTR(x) (*(pc*)(&(XP_PTREGS(x)->ctr))) +#define xpXER(x) (XP_PTREGS(x)->xer) +#define xpCCR(x) (XP_PTREGS(x)->ccr) +#define xpMSR(x) (XP_PTREGS(x)->msr) +#define xpDSISR(x) (XP_PTREGS(x)->dsisr) +#define xpDAR(x) (XP_PTREGS(x)->dar) +#define xpTRAP(x) (XP_PTREGS(x)->trap) +#define xpFPSCR(x) (XP_PTREGS(x)->gpr[PT_FPSCR]) +#define xpFPRvector(x) ((double *)(&(XP_PTREGS(x)->gpr[PT_FPR0]))) +#define xpFPR(x,fprno) (xpFPRvector(x)[fprno]) + +/* + Work around a Darwin G5 bug (present in OSX 10.2.7, 10.2.8, and later + versions. See below for details. +*/ +#define DarwinSigReturn(context) +#define SIGRETURN(context) +#endif + +#ifdef DARWIN +#define xpGPRvector(x) (&(UC_MCONTEXT(x)->__ss.__r0)) +#define xpGPR(x,gprno) ((xpGPRvector(x))[gprno]) +#define set_xpGPR(x,gpr,new) xpGPR((x),(gpr)) = (UInt32)(new) +#define xpPC(x) (*((pc*) &(UC_MCONTEXT(x)->__ss.__srr0))) +#define set_xpPC(x,new) (xpPC(x) = (pc)(new)) +#define xpLR(x) (*((pc*)(&(UC_MCONTEXT(x)->__ss.__lr)))) +#define xpCTR(x) (*(pc*)(&(UC_MCONTEXT(x)->__ss.__ctr))) +#define xpXER(x) (UC_MCONTEXT(x)->__ss.__xer) +#define xpCCR(x) (UC_MCONTEXT(x)->__ss.__cr) +#define xpMSR(x) (UC_MCONTEXT(x)->__ss.__srr1) +#define xpDSISR(x) (UC_MCONTEXT(x)->__es.__dsisr) +#define xpDAR(x) (UC_MCONTEXT(x)->__es.__dar) +#define xpTRAP(x) (UC_MCONTEXT(x)->__es.__exception) +#define xpFPSCR(x) (UC_MCONTEXT(x)->__fs.__fpscr) +#define xpFPRvector(x) (UC_MCONTEXT(x)->__fs.__fpregs) +#define xpFPR(x,fprno) (xpFPRvector(x)[fprno]) +/* There's a bug in some versions of Darwin on G5 processors: FP context + isn't restored correctly on exit from a signal handler if the integer + context appears to be unmodified (the 64-bit context isn't set up + correctly by the kernel: only the first N bytes are copied out of + the kernel, where N = size of 32-bit context. + + If the kernel pushed both a 32-bit and 64-bit context, the C + runtime "signal trampoline" code tries to determine if the 32-bit + GPRs and user-visible SPRs in the 32-bit context contain the same + values as their 64-bit counterparts on exit; if so, it tries to + call sigreturn with an extra argument that indicates that the + thread's state should be restored from the 64-bit context. + (Apparently that's more efficient; it'd be surprising if it'd be + more efficent when the cost of comparing values in the two contexts + is factored in ...). On some OS releases, the 64-bit context can't + be reliably restored (FPRs get trashed.) + + One way to work around this is to use a deprecated, 32-bit-context-only + version of the sigreturn syscall. There seems to be reason to be + reason to believe that the old sigreturn syscall will disappear + on OS releases >10.3. + + Another way to work around this is to make a "harmless" change to + an SPR or GPR value in the 32-bit context. There are lots of + "reserved" bits in the XER that make good candidates: 1's written + to reserved XER bits can't be reliably read anyway, so this may + or may not actually change the value in the XER in a way that + can be reliably detected. + + Note that both the old, deprecated version of sigreturn and the + new version take a first argument of type "struct ucontext *", + not "struct sigcontext *" as the man page and header files claim. + The new version takes a second argument, which is a small integer + which defines what "flavor" of context should be restored from. + The meaningful values that can be used here aren't defined in + a header file; the kernel (and the libc _sigtramp() function) + have (hopefully) matching, redundant hardwired definitions in + the source. +*/ +#ifdef PPC64 +#define DarwinSigReturn(x) +#else +#define DarwinSigReturn(x) (UC_MCONTEXT(x)->__ss.__xer)^=0x80 +#endif +#define SIGRETURN(context) DarwinSigReturn(context) +#endif + + + + + + +/* + Unconditional traps (tw, twi instructions) are used by the + operating system. We use conditional traps. + */ + +int +is_conditional_trap(opcode); + +#define kNameBufLen 256 +#define TRAP_LOOKUP_TRIES 5 /* # instrs to scan before trap instr */ + +void +callback_for_trap (LispObj, ExceptionInformation *, pc, natural, natural, natural); + +natural +register_codevector_contains_pc (natural, pc); + +void +callback_to_lisp (LispObj, ExceptionInformation *, natural, natural, natural, natural, natural); + +OSStatus +handle_trap(ExceptionInformation *, opcode, pc, siginfo_t *); + +unsigned +scan_for_instr( unsigned, unsigned, pc ); + + + +#define UUO_INTERR (11) +#define UUO_INTCERR (12) +#define UUO_INTERR2 (13) +#define UUO_INTCERR2 (14) + +#define UUO_FPUX_BINOP (22) +#define UUO_ZERO_FPSCR (25) + + +/* PPC instructions */ +#define match_instr(instr, mask, target) (((instr) & (mask)) == (target)) +#define RS_field(instr) (((instr) >> 21) & 0x1f) +#define RT_field(instr) (RS_field(instr)) +#define TO_field(instr) (RT_field(instr)) +#define RA_field(instr) (((instr) >> 16) & 0x1f) +#define RB_field(instr) (((instr) >> 11) & 0x1f) +#define D_field(instr) ((instr) & 0xffff) +#define DS_field(instr) ((instr) & 0xfffc) +#define DS_VARIANT_FIELD(instr) ((instr) & 3) + +#define RT(val) ((val & 0x1f) << 21) +#define RS(val) (RT(val)) +#define RA(val) ((val & 0x1f) << 16) +#define RB(val) ((val & 0x1f) << 11) +#define D(val) (val & 0xffff) + +#define RS_MASK RS(-1) +#define RT_MASK RS_MASK +#define TO_MASK RS_MASK +#define RA_MASK RA(-1) +#define RB_MASK RB(-1) +#define D_MASK D(-1) + + + +#define OP(x) (((x) & 0x3f) << 26) +#define OP_MASK OP (0x3f) + +/* Main opcode + TO field of a D form instruction */ +#define OPTO(x,to) (OP(x) | (((to) & 0x1f) << 21)) +#define OPTO_MASK (OP_MASK | TO_MASK) +#define OPTORA(x,to,ra) (OPTO(x,to) | RA(ra)) +#define OPTORA_MASK (OP_TO_MASK | RA_MASK) + + + + +/* An X form instruction. */ +#define X(op, xop) (OP (op) | (((xop) & 0x3ff) << 1)) + +/* An X form instruction with the RC bit specified. */ +#define XRC(op, xop, rc) (X ((op), (xop)) | ((rc) & 1)) + +/* The mask for an X form instruction. */ +#define X_MASK XRC(0x3f, 0x3ff, 1) + +/* An XO form instruction */ +#define XO(op, xop, oe, rc) \ + (OP (op) | ((((unsigned long)(xop)) & 0x1ff) << 1) | ((((unsigned long)(oe)) & 1) << 10) | (((unsigned long)(rc)) & 1)) +#define XO_MASK XO (0x3f, 0x1ff, 1, 1) + + + +/* The bits in the TO field of a TW or TWI instruction */ +#define TO_LT (1<<4) /* signed < */ +#define TO_GT (1<<3) /* signed > */ +#define TO_EQ (1<<2) /* = */ +#define TO_LO (1<<1) /* unsigned < */ +#define TO_HI (1<<0) /* unsigned > */ +#define TO_NE (TO_LT|TO_GT) + +/* True if major opcode of "instr" is "op" */ +#define major_opcode_p(instr, op) match_instr((instr),OP_MASK,OP(op)) + +/* True if "instr" is an X form instruction with major opcode "major" + and minor opcode "minor" */ +#define X_opcode_p(instr,major,minor) match_instr((instr),X_MASK,X(major,minor)) + +#define major_opcode_TDI 2 +#define major_opcode_TWI 3 +#ifdef PPC64 +#define major_opcode_TRI major_opcode_TDI +#else +#define major_opcode_TRI major_opcode_TWI +#endif +#define major_opcode_ADDI 14 +#define major_opcode_RLWINM 21 +#define major_opcode_X31 31 /* an "X" form instruction; see minor opcode */ +#define major_opcode_LWZ 32 +#define major_opcode_LBZ 34 +#define major_opcode_STW 36 +#define major_opcode_STWU 37 +#define major_opcode_LD_LDU_LWA 58 +#define major_opcode_FPU_SINGLE 59 +#define major_opcode_FPU_DOUBLE 63 + +#define minor_opcode_TW 4 +#define minor_opcode_TD 68 +#ifdef PPC64 +#define minor_opcode_TR minor_opcode_TD +#else +#define minor_opcode_TR minor_opcode_TW +#endif +#define minor_opcode_SUBF 40 +#define minor_opcode_STWX 151 +#define minor_opcode_STWUX 183 + +#define major_opcode_DS_LOAD64 58 +#define DS_LOAD64_VARIANT_LD 0 + +#define major_opcode_DS_STORE64 62 +#define DS_STORE64_VARIANT_STD 0 + + + +#define D_instruction(major,rt,ra,imm) (OP(major)|((rt)<<21)|((ra)<<16)|((imm)&D_MASK)) +#define DS_instruction(major,rt,ra,imm,minor) (OP(major)|((rt)<<21)|((ra)<<16)|(((imm)&D_MASK)&~3)|((minor)&3)) +#define TRI_instruction(rt,ra,imm) D_instruction(major_opcode_TRI,rt,ra,imm) +#define LBZ_instruction(rt,ra,imm) D_instruction(major_opcode_LBZ,rt,ra,imm) +#define LWZ_instruction(rt,ra,imm) D_instruction(major_opcode_LWZ,rt,ra,imm) +#define LD_instruction(rt,ra,imm) DS_instruction(58,rt,ra,imm,0) + +#define D_RT_IMM_MASK (OP_MASK|RT_MASK|D_MASK) +#define D_RA_IMM_MASK (OP_MASK|RA_MASK|D_MASK) + +#define X_instruction(major,minor,rt,ra,rb) (X(major,minor)|((rt)<<21)|((ra)<<16)|((rb)<<11)) + +#define unmasked_register 0 + +#define LISP_BREAK_INSTRUCTION 0x7f810808 +#define QUIET_LISP_BREAK_INSTRUCTION 0x7c800008 + +#ifdef PPC64 +/* Have to use signed comparisons on PPC64; if we decrememt + allocptr and it "wraps around" address 0, that's an + attempt to allocate a large object. Note that this + means that valid heap addresses can't have the high + bit set. */ +/* tdlt allocptr,allocbase */ +#define ALLOC_TRAP_INSTRUCTION 0x7e095088 +#else +/* On PPC32, we can use an unsigned comparison, as long + as HEAP_IMAGE_BASE+PURESPACE_RESERVE is greater than + the maximum possible allocation (around 27 bits). + Decrementing allocptr may cause it to wrap around + #x80000000, but it should never wrap around 0. */ +/* twllt allocptr,allocbase */ +#define ALLOC_TRAP_INSTRUCTION 0x7c495008 +#endif + +#ifdef PPC64 +/* tdlgei allocptr,0 */ +#define GC_TRAP_INSTRUCTION 0x08a90000 +#else +/* twlgei allocptr,0 */ +#define GC_TRAP_INSTRUCTION 0x0ca90000 +#endif + +#ifdef PPC64 +/* clrrdi allocptr,allocptr,4 */ +#define UNTAG_ALLOCPTR_INSTRUCTION 0x792906e4 +#else +/* clrrwi allocptr,allocptr,3 */ +#define UNTAG_ALLOCPTR_INSTRUCTION 0x55290038 +#endif + +#ifdef PPC64 +/* std rX,misc_header_offset(allocptr) */ +#define STORE_HEADER_ALLOCPTR_INSTRUCTION 0xf809fff4 +#else +/* stw rX,misc_header_offset(allocptr) */ +#define STORE_HEADER_ALLOCPTR_INSTRUCTION 0x9009fffa +#endif +#define STORE_HEADER_ALLOCPTR_MASK D_RA_IMM_MASK + +#ifdef PPC64 +/* std rX,cons.cXr(allocptr) */ +#define STORE_CAR_ALLOCPTR_INSTRUCTION 0xf8090004 +#define STORE_CDR_ALLOCPTR_INSTRUCTION 0xf809fffc +#else +/* stw rX,cons.cXr(allocptr) */ +#define STORE_CAR_ALLOCPTR_INSTRUCTION 0x90090003 +#define STORE_CDR_ALLOCPTR_INSTRUCTION 0x9009ffff +#endif +#define STORE_CXR_ALLOCPTR_MASK D_RA_IMM_MASK + + +#ifdef PPC64 +/* stdu sp,-32(sp) */ +#define CREATE_LISP_FRAME_INSTRUCTION 0xf821ffe1 +#else +/* stwu sp,-16(sp) */ +#define CREATE_LISP_FRAME_INSTRUCTION 0x9421fff0 +#endif + +#ifdef PPC64 +/* std tsp,tsp_frame.type(tsp) */ +#define MARK_TSP_FRAME_INSTRUCTION 0xf98c0008 +#else +/* stw tsp,tsp_frame.type(tsp) */ +#define MARK_TSP_FRAME_INSTRUCTION 0x918c0004 +#endif + +#ifdef PPC64 +#define INIT_CATCH_FRAME_INSTRUCTION (0xf8000000 | RA(nargs)) +#define INIT_CATCH_FRAME_MASK (OP_MASK | RA_MASK) +#else +#define INIT_CATCH_FRAME_INSTRUCTION (0x90000000 | RA(nargs)) +#define INIT_CATCH_FRAME_MASK (OP_MASK | RA_MASK) +#endif + +OSStatus +handle_error(ExceptionInformation *, unsigned, unsigned, unsigned, pc); + +typedef char* vector_buf; + +void put_altivec_registers(vector_buf); +void get_altivec_registers(vector_buf); + + +int altivec_available; + +#ifdef DARWIN +#include +#include +#include +#include + +#endif + +/* Yet another way to look at a branch instruction ... */ +typedef union { + struct {unsigned op:6, li:24, aa:1, lk:1;} b; + unsigned opcode; +} branch_instruction; + + + + /* Enable exceptions (at least, enable another thread's attempts to + suspend this one) by restoring the signal mask. + */ + + + +#ifdef DARWIN +#define SIGNAL_FOR_PROCESS_INTERRUPT SIGUSR1 +#endif +#ifdef LINUX +#define SIGNAL_FOR_PROCESS_INTERRUPT SIGPWR +#endif + + +#ifdef LINUX +register void *current_r2 __asm__("r2"); +#endif + +Boolean +extend_tcr_tlb(TCR *, ExceptionInformation *, unsigned, unsigned); + +void +pc_luser_xp(ExceptionInformation *, TCR *, signed_natural *); + + +#ifdef PPC64 +#define codevec_hdr_p(value) ((value) == (('C'<<24)|('O'<<16)|('D'<<8)|'E')) +#else +/* top 6 bits will be zero, subtag will be subtag_code_vector */ +#define CV_HDR_MASK (OP_MASK | subtagmask) +#define CV_HDR_VALUE subtag_code_vector +#define codevec_hdr_p(value) (((value) & CV_HDR_MASK) == CV_HDR_VALUE) +#endif + + Index: /branches/new-random/lisp-kernel/ppc-gc.c =================================================================== --- /branches/new-random/lisp-kernel/ppc-gc.c (revision 13309) +++ /branches/new-random/lisp-kernel/ppc-gc.c (revision 13309) @@ -0,0 +1,2370 @@ +/* + Copyright (C) 2009 Clozure Associates + Copyright (C) 1994-2001 Digitool, Inc + This file is part of Clozure CL. + + Clozure CL is licensed under the terms of the Lisp Lesser GNU Public + License , known as the LLGPL and distributed with Clozure CL as the + file "LICENSE". The LLGPL consists of a preamble and the LGPL, + which is distributed with Clozure CL as the file "LGPL". Where these + conflict, the preamble takes precedence. + + Clozure CL is referenced in the preamble as the "LIBRARY." + + The LLGPL is also available online at + http://opensource.franz.com/preamble.html +*/ + +#include "lisp.h" +#include "lisp_globals.h" +#include "bits.h" +#include "gc.h" +#include "area.h" +#include "Threads.h" +#include +#include +#include +#include + +/* Heap sanity checking. */ + +void +check_node(LispObj n) +{ + int tag = fulltag_of(n), header_tag; + area *a; + LispObj header; + + switch (tag) { + case fulltag_even_fixnum: + case fulltag_odd_fixnum: + + +#ifdef PPC64 + case fulltag_imm_0: + case fulltag_imm_1: + case fulltag_imm_2: + case fulltag_imm_3: +#else + case fulltag_imm: +#endif + + + return; + +#ifndef PPC64 + case fulltag_nil: + if (n != lisp_nil) { + Bug(NULL,"Object tagged as nil, not nil : 0x%08x", n); + } + return; +#endif + + +#ifdef PPC64 + case fulltag_nodeheader_0: + case fulltag_nodeheader_1: + case fulltag_nodeheader_2: + case fulltag_nodeheader_3: + case fulltag_immheader_0: + case fulltag_immheader_1: + case fulltag_immheader_2: + case fulltag_immheader_3: +#else + case fulltag_nodeheader: + case fulltag_immheader: +#endif + + + Bug(NULL, "Header not expected : 0x%lx", n); + return; + + case fulltag_misc: + case fulltag_cons: + a = heap_area_containing((BytePtr)ptr_from_lispobj(n)); + + if (a == NULL) { + /* Can't do as much sanity checking as we'd like to + if object is a defunct stack-consed object. + If a dangling reference to the heap, that's + bad .. */ + a = active_dynamic_area; + if ((n > (ptr_to_lispobj(a->active))) && + (n < (ptr_to_lispobj(a->high)))) { + Bug(NULL, "Node points to heap free space: 0x%lx", n); + } + return; + } + break; + } + /* Node points to heap area, so check header/lack thereof. */ + header = header_of(n); + header_tag = fulltag_of(header); + if (tag == fulltag_cons) { + if ((nodeheader_tag_p(header_tag)) || + (immheader_tag_p(header_tag))) { + Bug(NULL, "Cons cell at 0x%lx has bogus header : 0x%lx", n, header); + } + return; + } + + if ((!nodeheader_tag_p(header_tag)) && + (!immheader_tag_p(header_tag))) { + Bug(NULL,"Vector at 0x%lx has bogus header : 0x%lx", n, header); + } + return; +} + + + + +void +check_range(LispObj *start, LispObj *end, Boolean header_allowed) +{ + LispObj node, *current = start, *prev = NULL; + int tag; + natural elements; + + while (current < end) { + prev = current; + node = *current++; + tag = fulltag_of(node); + if (immheader_tag_p(tag)) { + if (! header_allowed) { + Bug(NULL, "Header not expected at 0x%lx\n", prev); + } + current = (LispObj *)skip_over_ivector((natural)prev, node); + } else if (nodeheader_tag_p(tag)) { + if (! header_allowed) { + Bug(NULL, "Header not expected at 0x%lx\n", prev); + } + elements = header_element_count(node) | 1; + while (elements--) { + check_node(*current++); + } + } else { + check_node(node); + check_node(*current++); + } + } + + if (current != end) { + Bug(NULL, "Overran end of memory range: start = 0x%08x, end = 0x%08x, prev = 0x%08x, current = 0x%08x", + start, end, prev, current); + } +} + +void +check_all_areas(TCR *tcr) +{ + area *a = active_dynamic_area; + area_code code = a->code; + + while (code != AREA_VOID) { + switch (code) { + case AREA_DYNAMIC: + case AREA_STATIC: + case AREA_MANAGED_STATIC: + check_range((LispObj *)a->low, (LispObj *)a->active, true); + break; + + case AREA_VSTACK: + { + LispObj* low = (LispObj *)a->active; + LispObj* high = (LispObj *)a->high; + + if (((natural)low) & node_size) { + check_node(*low++); + } + check_range(low, high, false); + } + break; + + case AREA_TSTACK: + { + LispObj *current, *next, + *start = (LispObj *) a->active, + *end = start, + *limit = (LispObj *) a->high; + + for (current = start; + end != limit; + current = next) { + next = ptr_from_lispobj(*current); + end = ((next >= start) && (next < limit)) ? next : limit; + if (current[1] == 0) { + check_range(current+2, end, true); + } + } + } + break; + } + a = a->succ; + code = (a->code); + } +} + + + + + + + + + + + +/* Sooner or later, this probably wants to be in assembler */ +/* Return false if n is definitely not an ephemeral node, true if + it might be */ +void +mark_root(LispObj n) +{ + int tag_n = fulltag_of(n); + natural dnode, bits, *bitsp, mask; + + if (!is_node_fulltag(tag_n)) { + return; + } + + dnode = gc_area_dnode(n); + if (dnode >= GCndnodes_in_area) { + return; + } + set_bits_vars(GCmarkbits,dnode,bitsp,bits,mask); + if (bits & mask) { + return; + } + *bitsp = (bits | mask); + + if (tag_n == fulltag_cons) { + cons *c = (cons *) ptr_from_lispobj(untag(n)); + rmark(c->car); + rmark(c->cdr); + return; + } + { + LispObj *base = (LispObj *) ptr_from_lispobj(untag(n)); + natural + header = *((natural *) base), + subtag = header_subtag(header), + element_count = header_element_count(header), + total_size_in_bytes, /* including 4/8-byte header */ + suffix_dnodes; + tag_n = fulltag_of(header); + + +#ifdef PPC64 + if ((nodeheader_tag_p(tag_n)) || + (tag_n == ivector_class_64_bit)) { + total_size_in_bytes = 8 + (element_count<<3); + } else if (tag_n == ivector_class_8_bit) { + total_size_in_bytes = 8 + element_count; + } else if (tag_n == ivector_class_32_bit) { + total_size_in_bytes = 8 + (element_count<<2); + } else { + /* ivector_class_other_bit contains 16-bit arrays & bitvector */ + if (subtag == subtag_bit_vector) { + total_size_in_bytes = 8 + ((element_count+7)>>3); + } else { + total_size_in_bytes = 8 + (element_count<<1); + } + } +#else + if ((tag_n == fulltag_nodeheader) || + (subtag <= max_32_bit_ivector_subtag)) { + total_size_in_bytes = 4 + (element_count<<2); + } else if (subtag <= max_8_bit_ivector_subtag) { + total_size_in_bytes = 4 + element_count; + } else if (subtag <= max_16_bit_ivector_subtag) { + total_size_in_bytes = 4 + (element_count<<1); + } else if (subtag == subtag_double_float_vector) { + total_size_in_bytes = 8 + (element_count<<3); + } else { + total_size_in_bytes = 4 + ((element_count+7)>>3); + } +#endif + + + + suffix_dnodes = ((total_size_in_bytes+(dnode_size-1))>>dnode_shift) -1; + + if (suffix_dnodes) { + set_n_bits(GCmarkbits, dnode+1, suffix_dnodes); + } + + if (nodeheader_tag_p(tag_n)) { + if (subtag == subtag_hash_vector) { + /* Don't invalidate the cache here. It should get + invalidated on the lisp side, if/when we know + that rehashing is necessary. */ + LispObj flags = ((hash_table_vector_header *) base)->flags; + + if (flags & nhash_weak_mask) { + ((hash_table_vector_header *) base)->cache_key = undefined; + ((hash_table_vector_header *) base)->cache_value = lisp_nil; + mark_weak_htabv(n); + return; + } + } + + if (subtag == subtag_pool) { + deref(ptr_to_lispobj(base), 1) = lisp_nil; + } + + if (subtag == subtag_weak) { + natural weak_type = (natural) base[2]; + if (weak_type >> population_termination_bit) { + element_count -= 2; + } else { + element_count -= 1; + } + } + + base += (1+element_count); + + + while(element_count--) { + rmark(*--base); + } + if (subtag == subtag_weak) { + deref(ptr_to_lispobj(base),1) = GCweakvll; + GCweakvll = n; + } + } + } +} + + +/* + This marks the node if it needs to; it returns true if the node + is either a hash table vector header or a cons/misc-tagged pointer + to ephemeral space. + Note that it might be a pointer to ephemeral space even if it's + not pointing to the current generation. +*/ + +Boolean +mark_ephemeral_root(LispObj n) +{ + int tag_n = fulltag_of(n); + natural eph_dnode; + + if (nodeheader_tag_p(tag_n)) { + return (header_subtag(n) == subtag_hash_vector); + } + + if ((tag_n == fulltag_cons) || + (tag_n == fulltag_misc)) { + eph_dnode = area_dnode(n, GCephemeral_low); + if (eph_dnode < GCn_ephemeral_dnodes) { + mark_root(n); /* May or may not mark it */ + return true; /* but return true 'cause it's an ephemeral node */ + } + } + return false; /* Not a heap pointer or not ephemeral */ +} + + +#ifdef PPC64 +/* Any register (srr0, the lr or ctr) or stack location that + we're calling this on should have its low 2 bits clear; it'll + be tagged as a "primary" object, but the pc/lr/ctr should + never point to a tagged object or contain a fixnum. + + If the "pc" appears to be pointing into a heap-allocated + code vector that's not yet marked, back up until we find + the code-vector's prefix (the 32-bit word containing the + value 'CODE' whic precedes the code-vector's first instruction) + and mark the entire code-vector. +*/ +void +mark_pc_root(LispObj xpc) +{ + if ((xpc & 3) != 0) { + Bug(NULL, "Bad PC locative!"); + } else { + natural dnode = gc_area_dnode(xpc); + if ((dnode < GCndnodes_in_area) && + !ref_bit(GCmarkbits,dnode)) { + LispObj + *headerP, + header; + opcode *program_counter; + + for(program_counter=(opcode *)ptr_from_lispobj(xpc & ~7); + (LispObj)program_counter >= GCarealow; + program_counter-=2) { + if (*program_counter == PPC64_CODE_VECTOR_PREFIX) { + headerP = ((LispObj *)program_counter)-1; + header = *headerP; + dnode = gc_area_dnode(headerP); + set_n_bits(GCmarkbits, dnode, (8+(header_element_count(header)<<2)+(dnode_size-1))>>dnode_shift); + return; + } + } + /* + Expected to have found a header by now, but didn't. + That's a bug. + */ + Bug(NULL, "code_vector header not found!"); + } + } +} +#else /* PPC64 */ +/* + Some objects (saved LRs on the control stack, the LR, PC, and CTR + in exception frames) may be tagged as fixnums but are really + locatives into code_vectors. + + If "pc" is not tagged as a fixnum, mark it as a "normal" root. + If "pc" doesn't point at an unmarked doubleword in the area + being GCed, return. + Else back up until the code_vector's header is found and mark + all doublewords in the code_vector. +*/ +void +mark_pc_root(LispObj pc) +{ + if (tag_of(pc) != tag_fixnum) { + mark_root(pc); + } else { + natural dnode = gc_area_dnode(pc); + if ((dnode < GCndnodes_in_area) && + !ref_bit(GCmarkbits,dnode)) { + LispObj + *headerP, + header; + + for(headerP = (LispObj*)ptr_from_lispobj(untag(pc)); + dnode < GCndnodes_in_area; + headerP-=2, --dnode) { + header = *headerP; + + if ((header & code_header_mask) == subtag_code_vector) { + set_n_bits(GCmarkbits, dnode, (2+header_element_count(header))>>1); + return; + } + } + /* + Expected to have found a header by now, but didn't. + That's a bug. + */ + Bug(NULL, "code_vector header not found!"); + } + } +} +#endif /* PPC64 */ + + + +#ifdef PPC64 +#define RMARK_PREV_ROOT fulltag_imm_3 +#define RMARK_PREV_CAR fulltag_misc +#else +#define RMARK_PREV_ROOT fulltag_imm +#define RMARK_PREV_CAR fulltag_nil +#endif + + + + + +/* + This wants to be in assembler even more than "mark_root" does. + For now, it does link-inversion: hard as that is to express in C, + reliable stack-overflow detection may be even harder ... +*/ +void +rmark(LispObj n) +{ + int tag_n = fulltag_of(n); + bitvector markbits = GCmarkbits; + natural dnode, bits, *bitsp, mask; + + if (!is_node_fulltag(tag_n)) { + return; + } + + dnode = gc_area_dnode(n); + if (dnode >= GCndnodes_in_area) { + return; + } + set_bits_vars(markbits,dnode,bitsp,bits,mask); + if (bits & mask) { + return; + } + *bitsp = (bits | mask); + + if (current_stack_pointer() > GCstack_limit) { + if (tag_n == fulltag_cons) { + rmark(deref(n,1)); + rmark(deref(n,0)); + } else { + LispObj *base = (LispObj *) ptr_from_lispobj(untag(n)); + natural + header = *((natural *) base), + subtag = header_subtag(header), + element_count = header_element_count(header), + total_size_in_bytes, + suffix_dnodes; + tag_n = fulltag_of(header); +#ifdef PPC64 + if ((nodeheader_tag_p(tag_n)) || + (tag_n == ivector_class_64_bit)) { + total_size_in_bytes = 8 + (element_count<<3); + } else if (tag_n == ivector_class_8_bit) { + total_size_in_bytes = 8 + element_count; + } else if (tag_n == ivector_class_32_bit) { + total_size_in_bytes = 8 + (element_count<<2); + } else { + /* ivector_class_other_bit contains 16-bit arrays & bitvector */ + if (subtag == subtag_bit_vector) { + total_size_in_bytes = 8 + ((element_count+7)>>3); + } else { + total_size_in_bytes = 8 + (element_count<<1); + } + } +#else + if ((tag_n == fulltag_nodeheader) || + (subtag <= max_32_bit_ivector_subtag)) { + total_size_in_bytes = 4 + (element_count<<2); + } else if (subtag <= max_8_bit_ivector_subtag) { + total_size_in_bytes = 4 + element_count; + } else if (subtag <= max_16_bit_ivector_subtag) { + total_size_in_bytes = 4 + (element_count<<1); + } else if (subtag == subtag_double_float_vector) { + total_size_in_bytes = 8 + (element_count<<3); + } else { + total_size_in_bytes = 4 + ((element_count+7)>>3); + } +#endif + + + suffix_dnodes = ((total_size_in_bytes+(dnode_size-1))>>dnode_shift)-1; + + if (suffix_dnodes) { + set_n_bits(GCmarkbits, dnode+1, suffix_dnodes); + } + + if (!nodeheader_tag_p(tag_n)) return; + + if (subtag == subtag_hash_vector) { + /* Splice onto weakvll, then return */ + /* In general, there's no reason to invalidate the cached + key/value pair here. However, if the hash table's weak, + we don't want to retain an otherwise unreferenced key + or value simply because they're referenced from the + cache. Clear the cached entries iff the hash table's + weak in some sense. + */ + LispObj flags = ((hash_table_vector_header *) base)->flags; + + if ((flags & nhash_keys_frozen_mask) && + (((hash_table_vector_header *) base)->deleted_count > 0)) { + /* We're responsible for clearing out any deleted keys, since + lisp side can't do it without breaking the state machine + */ + LispObj *pairp = base + hash_table_vector_header_count; + natural + npairs = (element_count - (hash_table_vector_header_count - 1)) >> 1; + + while (npairs--) { + if ((pairp[1] == unbound) && (pairp[0] != unbound)) { + pairp[0] = slot_unbound; + } + pairp +=2; + } + ((hash_table_vector_header *) base)->deleted_count = 0; + } + + + if (flags & nhash_weak_mask) { + ((hash_table_vector_header *) base)->cache_key = undefined; + ((hash_table_vector_header *) base)->cache_value = lisp_nil; + mark_weak_htabv(n); + return; + } + } + + if (subtag == subtag_pool) { + deref(n, 1) = lisp_nil; + } + + if (subtag == subtag_weak) { + natural weak_type = (natural) base[2]; + if (weak_type >> population_termination_bit) + element_count -= 2; + else + element_count -= 1; + } + while (element_count) { + rmark(deref(n,element_count)); + element_count--; + } + + if (subtag == subtag_weak) { + deref(n, 1) = GCweakvll; + GCweakvll = n; + } + + } + } else { + LispObj prev = undefined; + LispObj this = n, next; + /* + This is an FSM. The basic states are: + (0) Just marked the cdr of a cons; mark the car next; + (1) Just marked the car of a cons; back up. + (2) Hit a gvector header. Back up. + (3) Marked a gvector element; mark the preceding one. + (4) Backed all the way up to the object that got us here. + + This is all encoded in the fulltag of the "prev" pointer. + */ + + if (tag_n == fulltag_cons) goto MarkCons; + goto MarkVector; + + ClimbCdr: + prev = deref(this,0); + deref(this,0) = next; + + Climb: + next = this; + this = prev; + tag_n = fulltag_of(prev); + switch(tag_n) { + case fulltag_odd_fixnum: + case fulltag_even_fixnum: + goto ClimbVector; + + case RMARK_PREV_ROOT: + return; + + case fulltag_cons: + goto ClimbCdr; + + case RMARK_PREV_CAR: + goto ClimbCar; + + /* default: abort() */ + } + + DescendCons: + prev = this; + this = next; + + MarkCons: + next = deref(this,1); + this += node_size; + tag_n = fulltag_of(next); + if (!is_node_fulltag(tag_n)) goto MarkCdr; + dnode = gc_area_dnode(next); + if (dnode >= GCndnodes_in_area) goto MarkCdr; + set_bits_vars(markbits,dnode,bitsp,bits,mask); + if (bits & mask) goto MarkCdr; + *bitsp = (bits | mask); + deref(this,1) = prev; + if (tag_n == fulltag_cons) goto DescendCons; + goto DescendVector; + + ClimbCar: + prev = deref(this,1); + deref(this,1) = next; + + MarkCdr: + next = deref(this, 0); + this -= node_size; + tag_n = fulltag_of(next); + if (!is_node_fulltag(tag_n)) goto Climb; + dnode = gc_area_dnode(next); + if (dnode >= GCndnodes_in_area) goto Climb; + set_bits_vars(markbits,dnode,bitsp,bits,mask); + if (bits & mask) goto Climb; + *bitsp = (bits | mask); + deref(this, 0) = prev; + if (tag_n == fulltag_cons) goto DescendCons; + /* goto DescendVector; */ + + DescendVector: + prev = this; + this = next; + + MarkVector: + { + LispObj *base = (LispObj *) ptr_from_lispobj(untag(this)); + natural + header = *((natural *) base), + subtag = header_subtag(header), + element_count = header_element_count(header), + total_size_in_bytes, + suffix_dnodes; + + tag_n = fulltag_of(header); + +#ifdef PPC64 + if ((nodeheader_tag_p(tag_n)) || + (tag_n == ivector_class_64_bit)) { + total_size_in_bytes = 8 + (element_count<<3); + } else if (tag_n == ivector_class_8_bit) { + total_size_in_bytes = 8 + element_count; + } else if (tag_n == ivector_class_32_bit) { + total_size_in_bytes = 8 + (element_count<<2); + } else { + /* ivector_class_other_bit contains 16-bit arrays & bitvector */ + if (subtag == subtag_bit_vector) { + total_size_in_bytes = 8 + ((element_count+7)>>3); + } else { + total_size_in_bytes = 8 + (element_count<<1); + } + } +#else + if ((tag_n == fulltag_nodeheader) || + (subtag <= max_32_bit_ivector_subtag)) { + total_size_in_bytes = 4 + (element_count<<2); + } else if (subtag <= max_8_bit_ivector_subtag) { + total_size_in_bytes = 4 + element_count; + } else if (subtag <= max_16_bit_ivector_subtag) { + total_size_in_bytes = 4 + (element_count<<1); + } else if (subtag == subtag_double_float_vector) { + total_size_in_bytes = 8 + (element_count<<3); + } else { + total_size_in_bytes = 4 + ((element_count+7)>>3); + } +#endif + + + suffix_dnodes = ((total_size_in_bytes+(dnode_size-1))>>dnode_shift)-1; + + if (suffix_dnodes) { + set_n_bits(GCmarkbits, dnode+1, suffix_dnodes); + } + + if (!nodeheader_tag_p(tag_n)) goto Climb; + + if (subtag == subtag_hash_vector) { + /* Splice onto weakvll, then climb */ + LispObj flags = ((hash_table_vector_header *) base)->flags; + + if (flags & nhash_weak_mask) { + ((hash_table_vector_header *) base)->cache_key = undefined; + ((hash_table_vector_header *) base)->cache_value = lisp_nil; + dws_mark_weak_htabv(this); + element_count = hash_table_vector_header_count; + } + } + + if (subtag == subtag_pool) { + deref(this, 1) = lisp_nil; + } + + if (subtag == subtag_weak) { + natural weak_type = (natural) base[2]; + if (weak_type >> population_termination_bit) + element_count -= 2; + else + element_count -= 1; + } + + this = untag(this) + ((element_count+1) << node_shift); + goto MarkVectorLoop; + } + + ClimbVector: + prev = *((LispObj *) ptr_from_lispobj(this)); + *((LispObj *) ptr_from_lispobj(this)) = next; + + MarkVectorLoop: + this -= node_size; + next = *((LispObj *) ptr_from_lispobj(this)); + tag_n = fulltag_of(next); + if (nodeheader_tag_p(tag_n)) goto MarkVectorDone; + if (!is_node_fulltag(tag_n)) goto MarkVectorLoop; + dnode = gc_area_dnode(next); + if (dnode >= GCndnodes_in_area) goto MarkVectorLoop; + set_bits_vars(markbits,dnode,bitsp,bits,mask); + if (bits & mask) goto MarkVectorLoop; + *bitsp = (bits | mask); + *(ptr_from_lispobj(this)) = prev; + if (tag_n == fulltag_cons) goto DescendCons; + goto DescendVector; + + MarkVectorDone: + /* "next" is vector header; "this" is fixnum-aligned. + If header subtag = subtag_weak_header, put it on weakvll */ + this += fulltag_misc; + + if (header_subtag(next) == subtag_weak) { + deref(this, 1) = GCweakvll; + GCweakvll = this; + } + goto Climb; + } +} + +LispObj * +skip_over_ivector(natural start, LispObj header) +{ + natural + element_count = header_element_count(header), + subtag = header_subtag(header), + nbytes; + +#ifdef PPC64 + switch (fulltag_of(header)) { + case ivector_class_64_bit: + nbytes = element_count << 3; + break; + case ivector_class_32_bit: + nbytes = element_count << 2; + break; + case ivector_class_8_bit: + nbytes = element_count; + break; + case ivector_class_other_bit: + default: + if (subtag == subtag_bit_vector) { + nbytes = (element_count+7)>>3; + } else { + nbytes = element_count << 1; + } + } + return ptr_from_lispobj(start+(~15 & (nbytes + 8 + 15))); +#else + if (subtag <= max_32_bit_ivector_subtag) { + nbytes = element_count << 2; + } else if (subtag <= max_8_bit_ivector_subtag) { + nbytes = element_count; + } else if (subtag <= max_16_bit_ivector_subtag) { + nbytes = element_count << 1; + } else if (subtag == subtag_double_float_vector) { + nbytes = 4 + (element_count << 3); + } else { + nbytes = (element_count+7) >> 3; + } + return ptr_from_lispobj(start+(~7 & (nbytes + 4 + 7))); +#endif + + + +} + + +void +check_refmap_consistency(LispObj *start, LispObj *end, bitvector refbits) +{ + LispObj x1, *base = start; + int tag; + natural ref_dnode, node_dnode; + Boolean intergen_ref; + + while (start < end) { + x1 = *start; + tag = fulltag_of(x1); + if (immheader_tag_p(tag)) { + start = skip_over_ivector(ptr_to_lispobj(start), x1); + } else { + intergen_ref = false; + if ((tag == fulltag_misc) || (tag == fulltag_cons)) { + node_dnode = gc_area_dnode(x1); + if (node_dnode < GCndnodes_in_area) { + intergen_ref = true; + } + } + if (intergen_ref == false) { + x1 = start[1]; + tag = fulltag_of(x1); + if ((tag == fulltag_misc) || (tag == fulltag_cons)) { + node_dnode = gc_area_dnode(x1); + if (node_dnode < GCndnodes_in_area) { + intergen_ref = true; + } + } + } + if (intergen_ref) { + ref_dnode = area_dnode(start, base); + if (!ref_bit(refbits, ref_dnode)) { + Bug(NULL, "Missing memoization in doublenode at 0x" LISP, start); + set_bit(refbits, ref_dnode); + } + } + start += 2; + } + } +} + + + +void +mark_memoized_area(area *a, natural num_memo_dnodes) +{ + bitvector refbits = a->refbits; + LispObj *p = (LispObj *) a->low, x1, x2; + natural inbits, outbits, bits, bitidx, *bitsp, nextbit, diff, memo_dnode = 0; + Boolean keep_x1, keep_x2; + + if (GCDebug) { + check_refmap_consistency(p, p+(num_memo_dnodes << 1), refbits); + } + + /* The distinction between "inbits" and "outbits" is supposed to help us + detect cases where "uninteresting" setfs have been memoized. Storing + NIL, fixnums, immediates (characters, etc.) or node pointers to static + or readonly areas is definitely uninteresting, but other cases are + more complicated (and some of these cases are hard to detect.) + + Some headers are "interesting", to the forwarder if not to us. + + We -don't- give anything any weak treatment here. Weak things have + to be seen by a full gc, for some value of 'full'. + */ + + /* + We need to ensure that there are no bits set at or beyond + "num_memo_dnodes" in the bitvector. (This can happen as the EGC + tenures/untenures things.) We find bits by grabbing a fullword at + a time and doing a cntlzw instruction; and don't want to have to + check for (< memo_dnode num_memo_dnodes) in the loop. + */ + + { + natural + bits_in_last_word = (num_memo_dnodes & bitmap_shift_count_mask), + index_of_last_word = (num_memo_dnodes >> bitmap_shift); + + if (bits_in_last_word != 0) { + natural mask = ~((1L<<(nbits_in_word-bits_in_last_word))-1L); + refbits[index_of_last_word] &= mask; + } + } + + set_bitidx_vars(refbits, 0, bitsp, bits, bitidx); + inbits = outbits = bits; + while (memo_dnode < num_memo_dnodes) { + if (bits == 0) { + int remain = nbits_in_word - bitidx; + memo_dnode += remain; + p += (remain+remain); + if (outbits != inbits) { + *bitsp = outbits; + } + bits = *++bitsp; + inbits = outbits = bits; + bitidx = 0; + } else { + nextbit = count_leading_zeros(bits); + if ((diff = (nextbit - bitidx)) != 0) { + memo_dnode += diff; + bitidx = nextbit; + p += (diff+diff); + } + x1 = *p++; + x2 = *p++; + bits &= ~(BIT0_MASK >> bitidx); + keep_x1 = mark_ephemeral_root(x1); + keep_x2 = mark_ephemeral_root(x2); + if ((keep_x1 == false) && + (keep_x2 == false)) { + outbits &= ~(BIT0_MASK >> bitidx); + } + memo_dnode++; + bitidx++; + } + } + if (GCDebug) { + p = (LispObj *) a->low; + check_refmap_consistency(p, p+(num_memo_dnodes << 1), refbits); + } +} + + + +void +mark_simple_area_range(LispObj *start, LispObj *end) +{ + LispObj x1, *base; + int tag; + + while (start < end) { + x1 = *start; + tag = fulltag_of(x1); + if (immheader_tag_p(tag)) { + start = (LispObj *)ptr_from_lispobj(skip_over_ivector(ptr_to_lispobj(start), x1)); + } else if (!nodeheader_tag_p(tag)) { + ++start; + mark_root(x1); + mark_root(*start++); + } else { + int subtag = header_subtag(x1); + natural element_count = header_element_count(x1); + natural size = (element_count+1 + 1) & ~1; + + if (subtag == subtag_hash_vector) { + LispObj flags = ((hash_table_vector_header *) start)->flags; + + if (flags & nhash_weak_mask) { + ((hash_table_vector_header *) start)->cache_key = undefined; + ((hash_table_vector_header *) start)->cache_value = lisp_nil; + mark_weak_htabv((LispObj)start); + element_count = 0; + } + } + if (subtag == subtag_pool) { + start[1] = lisp_nil; + } + + if (subtag == subtag_weak) { + natural weak_type = (natural) start[2]; + if (weak_type >> population_termination_bit) + element_count -= 2; + else + element_count -= 1; + start[1] = GCweakvll; + GCweakvll = (LispObj) (((natural) start) + fulltag_misc); + } + + base = start + element_count + 1; + while(element_count--) { + mark_root(*--base); + } + start += size; + } + } +} + + +/* Mark a tstack area */ +void +mark_tstack_area(area *a) +{ + LispObj + *current, + *next, + *start = (LispObj *) (a->active), + *end = start, + *limit = (LispObj *) (a->high); + + for (current = start; + end != limit; + current = next) { + next = (LispObj *) ptr_from_lispobj(*current); + end = ((next >= start) && (next < limit)) ? next : limit; + if (current[1] == 0) { + mark_simple_area_range(current+2, end); + } + } +} + +/* + It's really important that headers never wind up in tagged registers. + Those registers would (possibly) get pushed on the vstack and confuse + the hell out of this routine. + + vstacks are just treated as a "simple area range", possibly with + an extra word at the top (where the area's active pointer points.) + */ + +void +mark_vstack_area(area *a) +{ + LispObj + *start = (LispObj *) a->active, + *end = (LispObj *) a->high; + +#if 0 + fprintf(dbgout, "mark VSP range: 0x%lx:0x%lx\n", start, end); +#endif + if (((natural)start) & (sizeof(natural))) { + /* Odd number of words. Mark the first (can't be a header) */ + mark_root(*start); + ++start; + } + mark_simple_area_range(start, end); +} + + +/* + Mark lisp frames on the control stack. + Ignore emulator frames (odd backpointer) and C frames (size != 4). +*/ + +void +mark_cstack_area(area *a) +{ + BytePtr + current, + next, + limit = a->high, + low = a->low; + + for (current = a->active; (current >= low) && (current < limit); current = next) { + next = *((BytePtr *)current); +#if 0 + if (next < current) { + Bug(NULL, "Child stack frame older than parent"); + } +#endif + if (next == NULL) break; + if (((next - current) == sizeof(lisp_frame)) && + (((((lisp_frame *)current)->savefn) == 0) || + (fulltag_of(((lisp_frame *)current)->savefn) == fulltag_misc))) { + /* mark fn, then saved lr */ + mark_root(((lisp_frame *)current)->savefn); + mark_pc_root(((lisp_frame *)current)->savelr); + } else { + /* Clear low 2 bits of "next", just in case */ + next = (BytePtr) (((natural)next) & ~3); + } + } +} + + + +/* Mark the lisp objects in an exception frame */ +void +mark_xp(ExceptionInformation *xp) +{ + natural *regs = (natural *) xpGPRvector(xp); + +#ifdef PPC + int r; + /* registers >= fn should be tagged and marked as roots. + the PC, LR, loc_pc, and CTR should be treated as "pc_locatives". + + In general, marking a locative is more expensive than marking + a node is, since it may be neccessary to back up and find the + containing object's header. Since exception frames contain + many locatives, it'd be wise to mark them *after* marking the + stacks, nilreg-relative globals, etc. + */ + + for (r = fn; r < 32; r++) { + mark_root((regs[r])); + } + + + + mark_pc_root((regs[loc_pc])); + mark_pc_root(ptr_to_lispobj(xpPC(xp))); + mark_pc_root(ptr_to_lispobj(xpLR(xp))); + mark_pc_root(ptr_to_lispobj(xpCTR(xp))); +#endif /* PPC */ + +} + +/* A "pagelet" contains 32 doublewords. The relocation table contains + a word for each pagelet which defines the lowest address to which + dnodes on that pagelet will be relocated. + + The relocation address of a given pagelet is the sum of the relocation + address for the preceding pagelet and the number of bytes occupied by + marked objects on the preceding pagelet. +*/ + +LispObj +calculate_relocation() +{ + LispObj *relocptr = GCrelocptr; + LispObj current = GCareadynamiclow; + bitvector + markbits = GCdynamic_markbits; + qnode *q = (qnode *) markbits; + natural npagelets = ((GCndynamic_dnodes_in_area+(nbits_in_word-1))>>bitmap_shift); + natural thesebits; + LispObj first = 0; + + do { + *relocptr++ = current; + thesebits = *markbits++; + if (thesebits == ALL_ONES) { + current += nbits_in_word*dnode_size; + q += 4; /* sic */ + } else { + if (!first) { + first = current; + while (thesebits & BIT0_MASK) { + first += dnode_size; + thesebits += thesebits; + } + } + current += one_bits(*q++); + current += one_bits(*q++); + current += one_bits(*q++); + current += one_bits(*q++); + } + } while(--npagelets); + *relocptr++ = current; + return first ? first : current; +} + +#ifdef PPC64 +LispObj +dnode_forwarding_address(natural dnode, int tag_n) +{ + natural pagelet, nbits; + unsigned int near_bits; + LispObj new; + + if (GCDebug) { + if (! ref_bit(GCdynamic_markbits, dnode)) { + Bug(NULL, "unmarked object being forwarded!\n"); + } + } + + pagelet = dnode >> bitmap_shift; + nbits = dnode & bitmap_shift_count_mask; + near_bits = ((unsigned int *)GCdynamic_markbits)[dnode>>(dnode_shift+1)]; + + if (nbits < 32) { + new = GCrelocptr[pagelet] + tag_n;; + /* Increment "new" by the count of 1 bits which precede the dnode */ + if (near_bits == 0xffffffff) { + return (new + (nbits << 4)); + } else { + near_bits &= (0xffffffff00000000 >> nbits); + if (nbits > 15) { + new += one_bits(near_bits & 0xffff); + } + return (new + (one_bits(near_bits >> 16))); + } + } else { + new = GCrelocptr[pagelet+1] + tag_n; + nbits = 64-nbits; + + if (near_bits == 0xffffffff) { + return (new - (nbits << 4)); + } else { + near_bits &= (1< 15) { + new -= one_bits(near_bits >> 16); + } + return (new - one_bits(near_bits & 0xffff)); + } + } +} +#else +LispObj +dnode_forwarding_address(natural dnode, int tag_n) +{ + natural pagelet, nbits; + unsigned short near_bits; + LispObj new; + + if (GCDebug) { + if (! ref_bit(GCdynamic_markbits, dnode)) { + Bug(NULL, "unmarked object being forwarded!\n"); + } + } + + pagelet = dnode >> 5; + nbits = dnode & 0x1f; + near_bits = ((unsigned short *)GCdynamic_markbits)[dnode>>4]; + + if (nbits < 16) { + new = GCrelocptr[pagelet] + tag_n;; + /* Increment "new" by the count of 1 bits which precede the dnode */ + if (near_bits == 0xffff) { + return (new + (nbits << 3)); + } else { + near_bits &= (0xffff0000 >> nbits); + if (nbits > 7) { + new += one_bits(near_bits & 0xff); + } + return (new + (one_bits(near_bits >> 8))); + } + } else { + new = GCrelocptr[pagelet+1] + tag_n; + nbits = 32-nbits; + + if (near_bits == 0xffff) { + return (new - (nbits << 3)); + } else { + near_bits &= (1< 7) { + new -= one_bits(near_bits >> 8); + } + return (new - one_bits(near_bits & 0xff)); + } + } +} +#endif + + +LispObj +locative_forwarding_address(LispObj obj) +{ + int tag_n = fulltag_of(obj); + natural dnode; + + +#ifdef PPC + /* Locatives can be tagged as conses, "fulltag_misc" + objects, or as fixnums. Immediates, headers, and nil + shouldn't be "forwarded". Nil never will be, but it + doesn't hurt to check ... */ +#ifdef PPC64 + if ((tag_n & lowtag_mask) != lowtag_primary) { + return obj; + } +#else + if ((1<= GCndynamic_dnodes_in_area) || + (obj < GCfirstunmarked)) { + return obj; + } + + return dnode_forwarding_address(dnode, tag_n); +} + + + + +void +forward_range(LispObj *range_start, LispObj *range_end) +{ + LispObj *p = range_start, node, new; + int tag_n; + natural nwords; + hash_table_vector_header *hashp; + + while (p < range_end) { + node = *p; + tag_n = fulltag_of(node); + if (immheader_tag_p(tag_n)) { + p = (LispObj *) skip_over_ivector((natural) p, node); + } else if (nodeheader_tag_p(tag_n)) { + nwords = header_element_count(node); + nwords += (1 - (nwords&1)); + if ((header_subtag(node) == subtag_hash_vector) && + ((((hash_table_vector_header *)p)->flags) & nhash_track_keys_mask)) { + natural skip = (sizeof(hash_table_vector_header)/sizeof(LispObj))-1; + hashp = (hash_table_vector_header *) p; + p++; + nwords -= skip; + while(skip--) { + update_noderef(p); + p++; + } + /* "nwords" is odd at this point: there are (floor nwords 2) + key/value pairs to look at, and then an extra word for + alignment. Process them two at a time, then bump "p" + past the alignment word. */ + nwords >>= 1; + while(nwords--) { + if (update_noderef(p) && hashp) { + hashp->flags |= nhash_key_moved_mask; + hashp = NULL; + } + p++; + update_noderef(p); + p++; + } + *p++ = 0; + } else { + p++; + while(nwords--) { + update_noderef(p); + p++; + } + } + } else { + new = node_forwarding_address(node); + if (new != node) { + *p = new; + } + p++; + update_noderef(p); + p++; + } + } +} + + + + +/* Forward a tstack area */ +void +forward_tstack_area(area *a) +{ + LispObj + *current, + *next, + *start = (LispObj *) a->active, + *end = start, + *limit = (LispObj *) (a->high); + + for (current = start; + end != limit; + current = next) { + next = ptr_from_lispobj(*current); + end = ((next >= start) && (next < limit)) ? next : limit; + if (current[1] == 0) { + forward_range(current+2, end); + } + } +} + +/* Forward a vstack area */ +void +forward_vstack_area(area *a) +{ + LispObj + *p = (LispObj *) a->active, + *q = (LispObj *) a->high; + +#ifdef DEBUG + fprintf(dbgout,"Forward range 0x%x/0x%x (owner 0x%x)\n",p,q,a->owner); +#endif + if (((natural)p) & sizeof(natural)) { + update_noderef(p); + p++; + } + forward_range(p, q); +} + +void +forward_cstack_area(area *a) +{ + BytePtr + current, + next, + limit = a->high, + low = a->low; + + for (current = a->active; (current >= low) && (current < limit); current = next) { + next = *((BytePtr *)current); + if (next == NULL) break; + if (((next - current) == sizeof(lisp_frame)) && + (((((lisp_frame *)current)->savefn) == 0) || + (fulltag_of(((lisp_frame *)current)->savefn) == fulltag_misc))) { + update_noderef(&((lisp_frame *) current)->savefn); + update_locref(&((lisp_frame *) current)->savelr); + } + } +} + + + +void +forward_xp(ExceptionInformation *xp) +{ + natural *regs = (natural *) xpGPRvector(xp); + + int r; + + /* registers >= fn should be tagged and forwarded as roots. + the PC, LR, loc_pc, and CTR should be treated as "locatives". + */ + + for (r = fn; r < 32; r++) { + update_noderef((LispObj*) (&(regs[r]))); + } + + update_locref((LispObj*) (&(regs[loc_pc]))); + + update_locref((LispObj*) (&(xpPC(xp)))); + update_locref((LispObj*) (&(xpLR(xp)))); + update_locref((LispObj*) (&(xpCTR(xp)))); + +} + + +void +forward_tcr_xframes(TCR *tcr) +{ + xframe_list *xframes; + ExceptionInformation *xp; + + xp = tcr->gc_context; + if (xp) { + forward_xp(xp); + } + for (xframes = tcr->xframe; xframes; xframes = xframes->prev) { + if (xframes->curr == xp) { + Bug(NULL, "forward xframe twice ???"); + } + forward_xp(xframes->curr); + } +} + + + +/* + Compact the dynamic heap (from GCfirstunmarked through its end.) + Return the doublenode address of the new freeptr. + */ + +LispObj +compact_dynamic_heap() +{ + LispObj *src = ptr_from_lispobj(GCfirstunmarked), *dest = src, node, new; + natural + elements, + dnode = gc_area_dnode(GCfirstunmarked), + node_dnodes = 0, + imm_dnodes = 0, + bitidx, + *bitsp, + bits, + nextbit, + diff; + int tag; + bitvector markbits = GCmarkbits; + /* keep track of whether or not we saw any + code_vector headers, and only flush cache if so. */ + Boolean GCrelocated_code_vector = false; + + if (dnode < GCndnodes_in_area) { + lisp_global(FWDNUM) += (1<>1; + dnode += node_dnodes; + if ((header_subtag(node) == subtag_hash_vector) && + (((hash_table_vector_header *) (src-1))->flags & nhash_track_keys_mask)) { + hash_table_vector_header *hashp = (hash_table_vector_header *) dest; + int skip = (sizeof(hash_table_vector_header)/sizeof(LispObj))-1; + + *dest++ = node; + elements -= skip; + while(skip--) { + *dest++ = node_forwarding_address(*src++); + } + /* There should be an even number of (key/value) pairs in elements; + an extra alignment word follows. */ + elements >>= 1; + while (elements--) { + if (hashp) { + node = *src++; + new = node_forwarding_address(node); + if (new != node) { + hashp->flags |= nhash_key_moved_mask; + hashp = NULL; + *dest++ = new; + } else { + *dest++ = node; + } + } else { + *dest++ = node_forwarding_address(*src++); + } + *dest++ = node_forwarding_address(*src++); + } + *dest++ = 0; + src++; + } else { + *dest++ = node; + *dest++ = node_forwarding_address(*src++); + while(--node_dnodes) { + *dest++ = node_forwarding_address(*src++); + *dest++ = node_forwarding_address(*src++); + } + } + set_bitidx_vars(markbits,dnode,bitsp,bits,bitidx); + } else if (immheader_tag_p(tag)) { + *dest++ = node; + *dest++ = *src++; + elements = header_element_count(node); + tag = header_subtag(node); + +#ifdef PPC +#ifdef PPC64 + switch(fulltag_of(tag)) { + case ivector_class_64_bit: + imm_dnodes = ((elements+1)+1)>>1; + break; + case ivector_class_32_bit: + if (tag == subtag_code_vector) { + GCrelocated_code_vector = true; + } + imm_dnodes = (((elements+2)+3)>>2); + break; + case ivector_class_8_bit: + imm_dnodes = (((elements+8)+15)>>4); + break; + case ivector_class_other_bit: + if (tag == subtag_bit_vector) { + imm_dnodes = (((elements+64)+127)>>7); + } else { + imm_dnodes = (((elements+4)+7)>>3); + } + } +#else + if (tag <= max_32_bit_ivector_subtag) { + if (tag == subtag_code_vector) { + GCrelocated_code_vector = true; + } + imm_dnodes = (((elements+1)+1)>>1); + } else if (tag <= max_8_bit_ivector_subtag) { + imm_dnodes = (((elements+4)+7)>>3); + } else if (tag <= max_16_bit_ivector_subtag) { + imm_dnodes = (((elements+2)+3)>>2); + } else if (tag == subtag_bit_vector) { + imm_dnodes = (((elements+32)+63)>>6); + } else { + imm_dnodes = elements+1; + } +#endif +#endif + + dnode += imm_dnodes; + while (--imm_dnodes) { + *dest++ = *src++; + *dest++ = *src++; + } + set_bitidx_vars(markbits,dnode,bitsp,bits,bitidx); + } else { + *dest++ = node_forwarding_address(node); + *dest++ = node_forwarding_address(*src++); + bits &= ~(BIT0_MASK >> bitidx); + dnode++; + bitidx++; + } + } + + } + + { + natural nbytes = (natural)ptr_to_lispobj(dest) - (natural)GCfirstunmarked; + if ((nbytes != 0) && GCrelocated_code_vector) { + xMakeDataExecutable((LogicalAddress)ptr_from_lispobj(GCfirstunmarked), nbytes); + } + } + } + return ptr_to_lispobj(dest); +} + + + + + + +/* + Total the (physical) byte sizes of all ivectors in the indicated memory range +*/ + +natural +unboxed_bytes_in_range(LispObj *start, LispObj *end) +{ + natural total=0, elements, tag, subtag, bytes; + LispObj header; + + while (start < end) { + header = *start; + tag = fulltag_of(header); + + if ((nodeheader_tag_p(tag)) || + (immheader_tag_p(tag))) { + elements = header_element_count(header); + if (nodeheader_tag_p(tag)) { + start += ((elements+2) & ~1); + } else { + subtag = header_subtag(header); + +#ifdef PPC64 + switch(fulltag_of(header)) { + case ivector_class_64_bit: + bytes = 8 + (elements<<3); + break; + case ivector_class_32_bit: + bytes = 8 + (elements<<2); + break; + case ivector_class_8_bit: + bytes = 8 + elements; + break; + case ivector_class_other_bit: + default: + if (subtag == subtag_bit_vector) { + bytes = 8 + ((elements+7)>>3); + } else { + bytes = 8 + (elements<<1); + } + } +#else + if (subtag <= max_32_bit_ivector_subtag) { + bytes = 4 + (elements<<2); + } else if (subtag <= max_8_bit_ivector_subtag) { + bytes = 4 + elements; + } else if (subtag <= max_16_bit_ivector_subtag) { + bytes = 4 + (elements<<1); + } else if (subtag == subtag_double_float_vector) { + bytes = 8 + (elements<<3); + } else { + bytes = 4 + ((elements+7)>>3); + } +#endif + + + bytes = (bytes+dnode_size-1) & ~(dnode_size-1); + total += bytes; + start += (bytes >> node_shift); + } + } else { + start += 2; + } + } + return total; + } + + + /* + This assumes that it's getting called with an ivector + argument and that there's room for the object in the + destination area. + */ + + +LispObj +purify_displaced_object(LispObj obj, area *dest, natural disp) +{ + BytePtr + free = dest->active, + *old = (BytePtr *) ptr_from_lispobj(untag(obj)); + LispObj + header = header_of(obj), + new; + natural + start = (natural)old, + physbytes; + + physbytes = ((natural)(skip_over_ivector(start,header))) - start; + dest->active += physbytes; + + new = ptr_to_lispobj(free)+disp; + + memcpy(free, (BytePtr)old, physbytes); + /* Leave a trail of breadcrumbs. Or maybe just one breadcrumb. */ + /* Actually, it's best to always leave a trail, for two reasons. + a) We may be walking the same heap that we're leaving forwaring + pointers in, so we don't want garbage that we leave behind to + look like a header. + b) We'd like to be able to forward code-vector locatives, and + it's easiest to do so if we leave a {forward_marker, dnode_locative} + pair at every doubleword in the old vector. + */ + while(physbytes) { + *old++ = (BytePtr) forward_marker; + *old++ = (BytePtr) free; + free += dnode_size; + physbytes -= dnode_size; + } + return new; +} + +LispObj +purify_object(LispObj obj, area *dest) +{ + return purify_displaced_object(obj, dest, fulltag_of(obj)); +} + + + +void +copy_ivector_reference(LispObj *ref, BytePtr low, BytePtr high, area *dest) +{ + LispObj obj = *ref, header; + natural tag = fulltag_of(obj), header_tag; + + if ((tag == fulltag_misc) && + (((BytePtr)ptr_from_lispobj(obj)) > low) && + (((BytePtr)ptr_from_lispobj(obj)) < high)) { + header = deref(obj, 0); + if (header == forward_marker) { /* already copied */ + *ref = (untag(deref(obj,1)) + tag); + } else { + header_tag = fulltag_of(header); + if (immheader_tag_p(header_tag)) { + if (header_subtag(header) != subtag_macptr) { + *ref = purify_object(obj, dest); + } + } + } + } +} + +void +purify_locref(LispObj *locaddr, BytePtr low, BytePtr high, area *to) +{ +#ifdef PPC + LispObj + loc = *locaddr, + *headerP; + opcode + *p, + insn; + natural + tag = fulltag_of(loc); + + if (((BytePtr)ptr_from_lispobj(loc) > low) && + ((BytePtr)ptr_from_lispobj(loc) < high)) { + + headerP = (LispObj *)ptr_from_lispobj(untag(loc)); + switch (tag) { + case fulltag_even_fixnum: + case fulltag_odd_fixnum: +#ifdef PPC64 + case fulltag_cons: + case fulltag_misc: +#endif + if (*headerP == forward_marker) { + *locaddr = (headerP[1]+tag); + } else { + /* Grovel backwards until the header's found; copy + the code vector to to space, then treat it as if it + hasn't already been copied. */ + p = (opcode *)headerP; + do { + p -= 2; + tag += 8; + insn = *p; +#ifdef PPC64 + } while (insn != PPC64_CODE_VECTOR_PREFIX); + headerP = ((LispObj*)p)-1; + *locaddr = purify_displaced_object(((LispObj)headerP), to, tag); +#else + } while ((insn & code_header_mask) != subtag_code_vector); + *locaddr = purify_displaced_object(ptr_to_lispobj(p), to, tag); +#endif + } + break; + +#ifndef PPC64 + case fulltag_misc: + copy_ivector_reference(locaddr, low, high, to); + break; +#endif + } +} +#endif +} + +void +purify_range(LispObj *start, LispObj *end, BytePtr low, BytePtr high, area *to) +{ + LispObj header; + unsigned tag; + + while (start < end) { + header = *start; + if (header == forward_marker) { + start += 2; + } else { + tag = fulltag_of(header); + if (immheader_tag_p(tag)) { + start = (LispObj *)skip_over_ivector((natural)start, header); + } else { + if (!nodeheader_tag_p(tag)) { + copy_ivector_reference(start, low, high, to); + } + start++; + copy_ivector_reference(start, low, high, to); + start++; + } + } + } +} + +/* Purify references from tstack areas */ +void +purify_tstack_area(area *a, BytePtr low, BytePtr high, area *to) +{ + LispObj + *current, + *next, + *start = (LispObj *) (a->active), + *end = start, + *limit = (LispObj *) (a->high); + + for (current = start; + end != limit; + current = next) { + next = (LispObj *) ptr_from_lispobj(*current); + end = ((next >= start) && (next < limit)) ? next : limit; + if (current[1] == 0) { + purify_range(current+2, end, low, high, to); + } + } +} + +/* Purify a vstack area */ +void +purify_vstack_area(area *a, BytePtr low, BytePtr high, area *to) +{ + LispObj + *p = (LispObj *) a->active, + *q = (LispObj *) a->high; + + if (((natural)p) & sizeof(natural)) { + copy_ivector_reference(p, low, high, to); + p++; + } + purify_range(p, q, low, high, to); +} + + +void +purify_cstack_area(area *a, BytePtr low, BytePtr high, area *to) +{ + BytePtr + current, + next, + limit = a->high; + + for (current = a->active; current != limit; current = next) { + next = *((BytePtr *)current); + if (next == NULL) break; + if (((next - current) == sizeof(lisp_frame)) && + (((((lisp_frame *)current)->savefn) == 0) || + (fulltag_of(((lisp_frame *)current)->savefn) == fulltag_misc))) { + purify_locref(&((lisp_frame *) current)->savelr, low, high, to); + } else { + /* Clear low bits of "next", just in case */ + next = (BytePtr) (((natural)next) & ~(sizeof(natural)-1)); + } + } +} + +void +purify_xp(ExceptionInformation *xp, BytePtr low, BytePtr high, area *to) +{ + unsigned long *regs = (unsigned long *) xpGPRvector(xp); + + int r; + + /* registers >= fn should be treated as roots. + The PC, LR, loc_pc, and CTR should be treated as "locatives". + */ + + for (r = fn; r < 32; r++) { + copy_ivector_reference((LispObj*) (&(regs[r])), low, high, to); + }; + + purify_locref((LispObj*) (&(regs[loc_pc])), low, high, to); + + purify_locref((LispObj*) (&(xpPC(xp))), low, high, to); + purify_locref((LispObj*) (&(xpLR(xp))), low, high, to); + purify_locref((LispObj*) (&(xpCTR(xp))), low, high, to); +} + +void +purify_tcr_tlb(TCR *tcr, BytePtr low, BytePtr high, area *to) +{ + natural n = tcr->tlb_limit; + LispObj *start = tcr->tlb_pointer, *end = (LispObj *) ((BytePtr)start+n); + + purify_range(start, end, low, high, to); +} + +void +purify_tcr_xframes(TCR *tcr, BytePtr low, BytePtr high, area *to) +{ + xframe_list *xframes; + ExceptionInformation *xp; + + xp = tcr->gc_context; + if (xp) { + purify_xp(xp, low, high, to); + } + + for (xframes = tcr->xframe; xframes; xframes = xframes->prev) { + purify_xp(xframes->curr, low, high, to); + } +} + +void +purify_gcable_ptrs(BytePtr low, BytePtr high, area *to) +{ + LispObj *prev = &(lisp_global(GCABLE_POINTERS)), next; + + while ((*prev) != (LispObj)NULL) { + copy_ivector_reference(prev, low, high, to); + next = *prev; + prev = &(((xmacptr *)ptr_from_lispobj(untag(next)))->link); + } +} + + +void +purify_areas(BytePtr low, BytePtr high, area *target) +{ + area *next_area; + area_code code; + + for (next_area = active_dynamic_area; (code = next_area->code) != AREA_VOID; next_area = next_area->succ) { + switch (code) { + case AREA_TSTACK: + purify_tstack_area(next_area, low, high, target); + break; + + case AREA_VSTACK: + purify_vstack_area(next_area, low, high, target); + break; + + case AREA_CSTACK: + purify_cstack_area(next_area, low, high, target); + break; + + case AREA_STATIC: + case AREA_DYNAMIC: + purify_range((LispObj *) next_area->low, (LispObj *) next_area->active, low, high, target); + break; + + default: + break; + } + } +} + +/* + So far, this is mostly for save_application's benefit. + We -should- be able to return to lisp code after doing this, + however. + +*/ + + +signed_natural +purify(TCR *tcr, signed_natural param) +{ + extern area *extend_readonly_area(unsigned); + area + *a = active_dynamic_area, + *new_pure_area; + + TCR *other_tcr; + natural max_pure_size; + BytePtr new_pure_start; + + + max_pure_size = unboxed_bytes_in_range((LispObj *)(a->low + (static_dnodes_for_area(a) << dnode_shift)), + (LispObj *) a->active); + new_pure_area = extend_readonly_area(max_pure_size); + if (new_pure_area) { + new_pure_start = new_pure_area->active; + lisp_global(IN_GC) = (1<low, a->active, new_pure_area); + + other_tcr = tcr; + do { + purify_tcr_xframes(other_tcr, a->low, a->active, new_pure_area); + purify_tcr_tlb(other_tcr, a->low, a->active, new_pure_area); + other_tcr = other_tcr->next; + } while (other_tcr != tcr); + + purify_gcable_ptrs(a->low, a->active, new_pure_area); + + { + natural puresize = (unsigned) (new_pure_area->active-new_pure_start); + if (puresize != 0) { + xMakeDataExecutable(new_pure_start, puresize); + + } + } + ProtectMemory(new_pure_area->low, + align_to_power_of_2(new_pure_area->active-new_pure_area->low, + log2_page_size)); + lisp_global(IN_GC) = 0; + just_purified_p = true; + return 0; + } + return -1; +} + +void +impurify_locref(LispObj *p, LispObj low, LispObj high, int delta) +{ + LispObj q = *p; + + switch (fulltag_of(q)) { +#ifdef PPC64 + case fulltag_cons: +#endif + case fulltag_misc: + case fulltag_even_fixnum: + case fulltag_odd_fixnum: + if ((q >= low) && (q < high)) { + *p = (q+delta); + } + } +} + + +void +impurify_noderef(LispObj *p, LispObj low, LispObj high, int delta) +{ + LispObj q = *p; + + if ((fulltag_of(q) == fulltag_misc) && + (q >= low) && + (q < high)) { + *p = (q+delta); + } +} + + +#ifdef PPC +void +impurify_cstack_area(area *a, LispObj low, LispObj high, int delta) +{ + BytePtr + current, + next, + limit = a->high; + + for (current = a->active; current != limit; current = next) { + next = *((BytePtr *)current); + if (next == NULL) break; + if (((next - current) == sizeof(lisp_frame)) && + (((((lisp_frame *)current)->savefn) == 0) || + (fulltag_of(((lisp_frame *)current)->savefn) == fulltag_misc))) { + impurify_locref(&((lisp_frame *) current)->savelr, low, high, delta); + } else { + /* Clear low bits of "next", just in case */ + next = (BytePtr) (((natural)next) & ~(sizeof(natural)-1)); + } + } +} +#endif + +void +impurify_xp(ExceptionInformation *xp, LispObj low, LispObj high, int delta) +{ + natural *regs = (natural *) xpGPRvector(xp); + +#ifdef PPC + int r; + /* registers >= fn should be treated as roots. + The PC, LR, loc_pc, and CTR should be treated as "locatives". + */ + + for (r = fn; r < 32; r++) { + impurify_noderef((LispObj*) (&(regs[r])), low, high, delta); + }; + + impurify_locref((LispObj*) (&(regs[loc_pc])), low, high, delta); + + impurify_locref((LispObj*) (&(xpPC(xp))), low, high, delta); + impurify_locref((LispObj*) (&(xpLR(xp))), low, high, delta); + impurify_locref((LispObj*) (&(xpCTR(xp))), low, high, delta); +#endif + +} + + +void +impurify_range(LispObj *start, LispObj *end, LispObj low, LispObj high, int delta) +{ + LispObj header; + unsigned tag; + + while (start < end) { + header = *start; + tag = fulltag_of(header); + if (immheader_tag_p(tag)) { + start = (LispObj *)skip_over_ivector((natural)start, header); + } else { + if (!nodeheader_tag_p(tag)) { + impurify_noderef(start, low, high, delta); + } + start++; + impurify_noderef(start, low, high, delta); + start++; + } + } +} + + + + +void +impurify_tcr_tlb(TCR *tcr, LispObj low, LispObj high, int delta) +{ + unsigned n = tcr->tlb_limit; + LispObj *start = tcr->tlb_pointer, *end = (LispObj *) ((BytePtr)start+n); + + impurify_range(start, end, low, high, delta); +} + +void +impurify_tcr_xframes(TCR *tcr, LispObj low, LispObj high, int delta) +{ + xframe_list *xframes; + ExceptionInformation *xp; + + xp = tcr->gc_context; + if (xp) { + impurify_xp(xp, low, high, delta); + } + + for (xframes = tcr->xframe; xframes; xframes = xframes->prev) { + impurify_xp(xframes->curr, low, high, delta); + } +} + +void +impurify_tstack_area(area *a, LispObj low, LispObj high, int delta) +{ + LispObj + *current, + *next, + *start = (LispObj *) (a->active), + *end = start, + *limit = (LispObj *) (a->high); + + for (current = start; + end != limit; + current = next) { + next = (LispObj *) ptr_from_lispobj(*current); + end = ((next >= start) && (next < limit)) ? next : limit; + if (current[1] == 0) { + impurify_range(current+2, end, low, high, delta); + } + } +} +void +impurify_vstack_area(area *a, LispObj low, LispObj high, int delta) +{ + LispObj + *p = (LispObj *) a->active, + *q = (LispObj *) a->high; + + if (((natural)p) & sizeof(natural)) { + impurify_noderef(p, low, high, delta); + p++; + } + impurify_range(p, q, low, high, delta); +} + + +void +impurify_areas(LispObj low, LispObj high, int delta) +{ + area *next_area; + area_code code; + + for (next_area = active_dynamic_area; (code = next_area->code) != AREA_VOID; next_area = next_area->succ) { + switch (code) { + case AREA_TSTACK: + impurify_tstack_area(next_area, low, high, delta); + break; + + case AREA_VSTACK: + impurify_vstack_area(next_area, low, high, delta); + break; + + case AREA_CSTACK: +#ifdef PPC + impurify_cstack_area(next_area, low, high, delta); +#endif + break; + + case AREA_STATIC: + case AREA_DYNAMIC: + impurify_range((LispObj *) next_area->low, (LispObj *) next_area->active, low, high, delta); + break; + + default: + break; + } + } +} + +void +impurify_gcable_ptrs(LispObj low, LispObj high, signed_natural delta) +{ + LispObj *prev = &(lisp_global(GCABLE_POINTERS)), next; + + while ((*prev) != (LispObj)NULL) { + impurify_noderef(prev, low, high, delta); + next = *prev; + prev = &(((xmacptr *)ptr_from_lispobj(untag(next)))->link); + } +} + +signed_natural +impurify(TCR *tcr, signed_natural param) +{ + area *r = readonly_area; + + if (r) { + area *a = active_dynamic_area; + BytePtr ro_base = r->low, ro_limit = r->active, oldfree = a->active, + oldhigh = a->high, newhigh; + unsigned n = ro_limit - ro_base; + int delta = oldfree-ro_base; + TCR *other_tcr; + + if (n) { + lisp_global(IN_GC) = 1; + newhigh = (BytePtr) (align_to_power_of_2(oldfree+n, + log2_heap_segment_size)); + if (newhigh > oldhigh) { + grow_dynamic_area(newhigh-oldhigh); + } + a->active += n; + memmove(oldfree, ro_base, n); + munmap(ro_base, n); + a->ndnodes = area_dnode(a, a->active); + pure_space_active = r->active = r->low; + r->ndnodes = 0; + + impurify_areas(ptr_to_lispobj(ro_base), ptr_to_lispobj(ro_limit), delta); + + other_tcr = tcr; + do { + impurify_tcr_xframes(other_tcr, ptr_to_lispobj(ro_base), ptr_to_lispobj(ro_limit), delta); + impurify_tcr_tlb(other_tcr, ptr_to_lispobj(ro_base), ptr_to_lispobj(ro_limit), delta); + other_tcr = other_tcr->next; + } while (other_tcr != tcr); + + impurify_gcable_ptrs(ptr_to_lispobj(ro_base), ptr_to_lispobj(ro_limit), delta); + lisp_global(IN_GC) = 0; + } + return 0; + } + return -1; +} + Index: /branches/new-random/lisp-kernel/ppc-macros.s =================================================================== --- /branches/new-random/lisp-kernel/ppc-macros.s (revision 13309) +++ /branches/new-random/lisp-kernel/ppc-macros.s (revision 13309) @@ -0,0 +1,744 @@ +/* Copyright (C) 2009 Clozure Associates */ +/* Copyright (C) 1994-2001 Digitool, Inc */ +/* This file is part of Clozure CL. */ + +/* Clozure CL is licensed under the terms of the Lisp Lesser GNU Public */ +/* License , known as the LLGPL and distributed with Clozure CL as the */ +/* file "LICENSE". The LLGPL consists of a preamble and the LGPL, */ +/* which is distributed with Clozure CL as the file "LGPL". Where these */ +/* conflict, the preamble takes precedence. */ + +/* Clozure CL is referenced in the preamble as the "LIBRARY." */ + +/* The LLGPL is also available online at */ +/* http://opensource.franz.com/preamble.html */ + +/* The assembler has to do the arithmetic here: the expression */ +/* may not be evaluable by m4. */ +define([lwi],[ifdef([DARWIN],[ + .if ((($2) & 0xffff8000) == 0xffff8000) + li $1,($2) + .elseif ((($2) & 0xffff8000) == 0) + li $1,$2 + .else + lis $1,(($2)>>16) + .if (($2) & 0xffff) <> 0 + ori $1,$1,(($2) & 0xffff) + .endif + .endif],[ + .ifeq (($2) & 0xffff8000)-0xffff8000 + li $1,$2 + .else + .ifeq (($2) & 0xffff8000) + li $1,$2 + .else + lis $1,($2>>16) + .ifne ($2 & 0xffff) + ori $1,$1,$2 & 0xffff + .endif + .endif + .endif +])]) + +ifdef([PPC64],[ + define([clrrri],[clrrdi $@]) + define([clrlri],[clrldi $@]) + define([clrlri_],[clrldi. $@]) + define([ldr],[ld $@]) + define([ldrx],[ldx $@]) + define([ldru],[ldu $@]) + define([str],[std $@]) + define([strx],[stdx $@]) + define([stru],[stdu $@]) + define([strux],[stdux $@]) + define([cmpr],[cmpd $@]) + define([cmpri],[cmpdi $@]) + define([cmplr],[cmpld $@]) + define([cmplri],[cmpldi $@]) + define([trlge],[tdlge $@]) + define([trllt],[tdllt $@]) + define([trlt],[tdlt $@]) + define([trlle],[tdlle $@]) + define([treqi],[tdeqi $@]) + define([trnei],[tdnei $@]) + define([trgti],[tdgti $@]) + define([srari],[sradi $@]) + define([srri],[srdi $@]) + define([srr],[srd $@]) + define([slri],[sldi $@]) + define([lrarx],[ldarx $@]) + define([strcx],[stdcx. $@]) + define([load_highbit],[ + __(lis $1,0x8000) + __(sldi $1,$1,32) + ]) + define([extract_bit_shift_count],[ + __(clrldi $1,$2,64-bitmap_shift) + ]) + define([alloc_trap],[ + __(tdlt allocptr,allocbase) + ]) + define([mullr],[mulld $@]) +],[ + define([clrrri],[clrrwi $@]) + define([clrlri],[clrlwi $@]) + define([clrlri_],[clrlwi. $@]) + define([ldr],[lwz $@]) + define([ldrx],[lwzx $@]) + define([ldru],[lwzu $@]) + define([str],[stw $@]) + define([strx],[stwx $@]) + define([stru],[stwu $@]) + define([strux],[stwux $@]) + define([cmpr],[cmpw $@]) + define([cmpri],[cmpwi $@]) + define([cmplr],[cmplw $@]) + define([cmplri],[cmplwi $@]) + define([trlge],[twlge $@]) + define([trllt],[twllt $@]) + define([trlt],[twlt $@]) + define([trlle],[twlle $@]) + define([treqi],[tweqi $@]) + define([trnei],[twnei $@]) + define([trgti],[twgti $@]) + define([srari],[srawi $@]) + define([srri],[srwi $@]) + define([srr],[srw $@]) + define([slri],[slwi $@]) + define([lrarx],[lwarx $@]) + define([strcx],[stwcx. $@]) + define([load_highbit],[ + __(lis $1,0x8000) + ]) + define([extract_bit_shift_count],[ + __(clrlwi $1,$2,32-bitmap_shift) + ]) + define([alloc_trap],[ + __(twllt allocptr,allocbase) + ]) + define([mullr],[mullw $@]) +]) + +/* dnode_align(dest,src,delta) */ + define([dnode_align],[ + __(la $1,($3+(dnode_size-1))($2)) + __(clrrri($1,$1,dnode_align_bits)) +]) + +define([extract_fulltag],[ + __(clrlri($1,$2,nbits_in_word-ntagbits)) + ]) + +define([extract_lisptag],[ + __(clrlri($1,$2,nbits_in_word-nlisptagbits)) + ]) + +define([extract_lisptag_],[ + __(clrlri_($1,$2,nbits_in_word-nlisptagbits)) + ]) + +define([extract_subtag],[ + __(lbz $1,misc_subtag_offset($2)) + ]) + +ifdef([PPC64],[ +define([extract_lowtag],[ + __(clrldi $1,$2,nbits_in_word-nlowtagbits) +]) +define([trap_unless_lowtag_equal],[ + __(clrldi $3,$1,nbits_in_word-nlowtagbits) + __(tdnei $3,$2) +]) + ]) + +define([extract_lowbyte],[ + __(clrlri($1,$2,nbits_in_word-num_subtag_bits)) + ]) + +define([extract_header],[ + __(ldr($1,misc_header_offset($2))) + ]) + + +ifdef([PPC64],[ +define([extract_typecode],[ + new_macro_labels() + __(extract_fulltag($1,$2)) + __(cmpdi cr0,$1,fulltag_misc) + __(extract_lisptag($1,$1)) + __(bne cr0,macro_label(not_misc)) + __(extract_subtag($1,$2)) +macro_label(not_misc): +])],[ +define([extract_typecode],[ + new_macro_labels() + __(extract_lisptag($1,$2)) + __(cmpwi cr0,$1,tag_misc) + __(bne cr0,macro_label(not_misc)) + __(extract_subtag($1,$2)) +macro_label(not_misc): +])]) + +define([box_fixnum],[ + __(slri($1,$2,fixnumshift)) + ]) + +define([unbox_fixnum],[ + __(srari($1,$2,fixnumshift)) + ]) + +define([loaddf],[ + __(lfd $1,dfloat.value($2))]) + +define([storedf],[ + __(stfd $1,dfloat.value($2)) + ]) + +define([push],[ + __(stru($1,-node_size($2))) + ]) + + /* Generally not a great idea. */ +define([pop],[ + __(ldr($1,0($2))) + __(la $2,node_size($2)) + ]) + +define([vpush],[ + __(push($1,vsp)) + ]) + +define([vpop],[ + __(pop($1,vsp)) + ]) + + +define([unlink],[ + __(ldr($1,0($1))) + ]) + + +define([set_nargs],[ + __(lwi(nargs,($1)< nil. */ + __(li arg_z,nil_value) + __(neg imm1,imm1) + __(subi imm1,imm1,node_size) + __(bge 1f) + __(ldrx(arg_z,imm0,imm1)) +1: + __(la vsp,node_size(imm0)) + __(blr) + + +/* Come here to return multiple values when */ +/* the caller's context isn't saved in a lisp_frame. */ +/* lr, fn valid; temp0 = entry vsp */ + +_spentry(values) + __(mflr loc_pc) +local_label(return_values): + __(ref_global(imm0,ret1val_addr)) + __(li arg_z,nil_value) + /* max tsp frame is 4K. 8+8 is overhead for save_values_to_tsp below */ + /* and @do_unwind in nthrowvalues in "sp_catch.s". */ + __(cmpri(cr2,nargs,4096-(dnode_size+dnode_size))) + __(cmpr(cr1,imm0,loc_pc)) + __(cmpri(cr0,nargs,fixnum_one)) + __(bge cr2,2f) + __(beq+ cr1,3f) + __(mtlr loc_pc) + __(add imm0,nargs,vsp) + __(blt- cr0,1f) + __(ldr(arg_z,-node_size(imm0))) +1: + __(mr vsp,temp0) + __(blr) + +2: + __(uuo_interr(error_too_many_values,nargs)) + __(b 2b) + +/* Return multiple values to real caller. */ +3: + __(ldr(loc_pc,lisp_frame.savelr(sp))) + __(add imm1,nargs,vsp) + __(ldr(imm0,lisp_frame.savevsp(sp))) + __(ldr(fn,lisp_frame.savefn(sp))) + __(cmpr(cr0,imm1,imm0)) /* a fairly common case */ + __(mtlr loc_pc) + __(cmpri(cr1,nargs,fixnum_one)) /* sadly, a very common case */ + __(discard_lisp_frame()) + __(beqlr cr0) /* already in the right place */ + __(bne cr1,4f) + __(ldr(arg_z,0(vsp))) + __(mr vsp,imm0) + __(vpush(arg_z)) + __(blr) +4: + __(blt cr1,6f) + __(li imm2,fixnum_one) +5: + __(cmpr(cr0,imm2,nargs)) + __(addi imm2,imm2,fixnum_one) + __(ldru(arg_z,-node_size(imm1))) + __(push(arg_z,imm0)) + __(bne cr0,5b) +6: + __(mr vsp,imm0) + __(blr) + + .globl C(nvalret) + +/* Come here with saved context on top of stack. */ +_spentry(nvalret) +C(nvalret): + __(ldr(loc_pc,lisp_frame.savelr(sp))) + __(ldr(temp0,lisp_frame.savevsp(sp))) + __(ldr(fn,lisp_frame.savefn(sp))) + __(discard_lisp_frame()) + __(b local_label(return_values)) + +/* Provide default (NIL) values for &optional arguments; imm0 is */ +/* the (fixnum) upper limit on the total of required and &optional */ +/* arguments. nargs is preserved, all arguments wind up on the */ +/* vstack. */ +_spentry(default_optional_args) + __(cmplr( cr7,nargs,imm0)) + __(li imm5,nil_value) + __(vpush_argregs()) + __(mr imm1,nargs) + __(bgelr cr7) +1: + __(addi imm1,imm1,fixnum_one) + __(cmpr(cr0,imm1,imm0)) + __(vpush(imm5)) + __(bne cr0,1b) + __(blr) + +/* Indicate whether &optional arguments were actually supplied. nargs */ +/* contains the actual arg count (minus the number of required args); */ +/* imm0 contains the number of &optional args in the lambda list. */ +/* Note that nargs may be > imm0 if &rest/&key is involved. */ +_spentry(opt_supplied_p) + __(li imm1,0) +1: + /* (vpush (< imm1 nargs)) */ + __ifdef([PPC64]) + __(xor imm2,imm1,nargs) + __(sradi imm2,imm2,63) + __(or imm2,imm2,imm1) + __(addi imm1,imm1,fixnumone) + __(cmpr(cr0,imm1,imm0)) + __(subf imm2,nargs,imm2) + __(srdi imm2,imm2,63) + __(mulli imm2,imm2,t_offset) + __(addi imm2,imm2,nil_value) + __(vpush(imm2)) + __(bne cr0,1b) + __(blr) + __else + __(xor imm2,imm1,nargs) + __(srawi imm2,imm2,31) + __(or imm2,imm2,imm1) + __(addi imm1,imm1,fixnumone) + __(cmpr(cr0,imm1,imm0)) + __(subf imm2,nargs,imm2) + __(srwi imm2,imm2,31) + __(insrwi imm2,imm2,1,27) + __(addi imm2,imm2,nil_value) + __(vpush(imm2)) + __(bne cr0,1b) + __(blr) + __endif + + + +/* If nargs is <= imm0, vpush a nil. Otherwise, cons a list of length */ +/* (- nargs imm0) and vpush it. */ +/* Use this entry point to heap-cons a simple &rest arg. */ +_spentry(heap_rest_arg) + __(li imm0,0) + __(vpush_argregs()) + __(sub imm1,nargs,imm0) + __(cmpri(imm1,0)) + __(li arg_z,nil_value) + __(b 2f) +1: + __(ldr(temp0,0(vsp))) + __(cmpri(imm1,fixnum_one)) + __(la vsp,node_size(vsp)) + __(Cons(arg_z,temp0,arg_z)) + __(subi imm1,imm1,fixnum_one) +2: + __(bgt 1b) + __(vpush(arg_z)) + __(blr) + + +/* And this entry point when the argument registers haven't yet been */ +/* vpushed (as is typically the case when required/&rest but no */ +/* &optional/&key.) */ +_spentry(req_heap_rest_arg) + __(vpush_argregs()) + __(sub imm1,nargs,imm0) + __(cmpri(imm1,0)) + __(li arg_z,nil_value) + __(b 2f) +1: + __(ldr(temp0,0(vsp))) + __(cmpri(imm1,fixnum_one)) + __(la vsp,node_size(vsp)) + __(Cons(arg_z,temp0,arg_z)) + __(subi imm1,imm1,fixnum_one) +2: + __(bgt 1b) + __(vpush(arg_z)) + __(blr) + + +_spentry(heap_cons_rest_arg) + __(sub imm1,nargs,imm0) + __(cmpri(imm1,0)) + __(li arg_z,nil_value) + __(b 2f) +1: + __(ldr(temp0,0(vsp))) + __(cmpri(imm1,fixnum_one)) + __(la vsp,node_size(vsp)) + __(Cons(arg_z,temp0,arg_z)) + __(subi imm1,imm1,fixnum_one) +2: + __(bgt 1b) + __(vpush(arg_z)) + __(blr) + + +_spentry(simple_keywords) + __(li imm0,0) + __(vpush_argregs()) + __(b _SPkeyword_bind) + +_spentry(keyword_args) + __(vpush_argregs()) + __(b _SPkeyword_bind) + +/* Treat the last (- nargs imm0) values on the vstack as keyword/value */ +/* pairs. There'll be imm3 keyword arguments. Imm2 contains flags */ +/* that indicate whether &allow-other-keys was specified and whether */ +/* or not to leave the keyword/value pairs on the vstack for an &rest */ +/* argument. Temp3 contains a vector of keyword specifiers which we */ +/* must (in general) match. */ +/* If the number of arguments is greater than imm0, the difference must */ +/* be even. */ +/* Note that the caller hasn't yet saved its caller's context and that */ +/* the temp registers used to pass next_method_context */ +/* (temp1) may still have "live" values in them, as does nfn (temp2). */ + +define([keyword_flags],[imm2]) +define([keyword_vector],[temp3]) +define([keyword_count],[imm3]) + + + +define([varptr],[save0]) +define([valptr],[save1]) +define([limit],[save2]) + +_spentry(keyword_bind) + /* Before we can really do anything, we have to */ + /* save the caller's context. To do so, we need to know */ + /* how many args have actually been pushed. Ordinarily, that'd */ + /* be "nargs", but we may have pushed more args than we received */ + /* if we had to default any &optionals. */ + /* So, the number of args pushed so far is the larger of nargs */ + /* and the (canonical) total of required/&optional args received. */ + __(cmpr(cr0,nargs,imm0)) + __(add arg_z,vsp,nargs) + __(bge+ cr0,1f) + __(add arg_z,vsp,imm0) +1: + __(build_lisp_frame(fn,loc_pc,arg_z)) + __(mr fn,nfn) + /* If there are key/value pairs to consider, we slide them down */ + /* the vstack to make room for the value/supplied-p pairs. */ + /* The first step in that operation involves pushing imm3 pairs */ + /* of NILs. */ + /* If there aren't any such pairs, the first step is the last */ + /* step. */ + __(cmpri(cr0,imm3,0)) + __(li arg_z,0) + __(sub imm1,nargs,imm0) + __(mr imm4,vsp) /* in case odd keywords error */ + __(cmpri(cr1,imm1,0)) + __(b 3f) +2: + __(addi arg_z,arg_z,fixnum_one) + __(cmplr(cr0,arg_z,imm3)) + __(li imm5,nil_value) + __(vpush(imm5)) + __(vpush(imm5)) +3: + __(bne cr0,2b) + __(andi. arg_z,imm1,fixnum_one) + __(blelr cr1) /* no keyword/value pairs to consider. */ + __(bne cr0,odd_keywords) + /* We have key/value pairs. Move them to the top of the vstack, */ + /* then set the value/supplied-p vars to NIL. */ + /* Have to use some save regs to do this. */ + __(vpush(limit)) + __(vpush(valptr)) + __(vpush(varptr)) + /* recompute ptr to user args in case stack overflowed */ + __(add imm4,vsp,imm3) + __(add imm4,imm4,imm3) + __(addi imm4,imm4,3*node_size) + /* error if odd number of keyword/value args */ + __(mr varptr,imm4) + __(la limit,3*node_size(vsp)) + __(mr valptr,limit) + __(mr arg_z,imm1) +4: + __(li imm4,nil_value) + __(subi arg_z,arg_z,2< 1 (and we know that it was < 3), it must have */ + /* been 2. Set arg_x, then vpush the remaining args. */ + __(ble cr1,local_label(set_y_z)) +local_label(set_arg_x): + __(subi imm0,imm0,fixnum_one) + __(cmpri(cr0,imm0,0)) + __(subi imm2,imm2,fixnum_one) + __(ldrx(arg_x,nfn,imm2)) + __(addi nargs,nargs,fixnum_one) + __(bne cr0,local_label(vpush_remaining)) + __(b local_label(go)) + /* Maybe set arg_y or arg_z, preceding args */ +local_label(set_y_z): + __(bne cr1,local_label(set_arg_z)) + /* Set arg_y, maybe arg_x, preceding args */ +local_label(set_arg_y): + __(subi imm0,imm0,fixnum_one) + __(cmpri(cr0,imm0,0)) + __(subi imm2,imm2,fixnum_one) + __(ldrx(arg_y,nfn,imm2)) + __(addi nargs,nargs,fixnum_one) + __(bne cr0,local_label(set_arg_x)) + __(b local_label(go)) +local_label(set_arg_z): + __(subi imm0,imm0,fixnum_one) + __(cmpri(cr0,imm0,0)) + __(subi imm2,imm2,fixnum_one) + __(ldrx(arg_z,nfn,imm2)) + __(addi nargs,nargs,fixnum_one) + __(bne cr0,local_label(set_arg_y)) + +local_label(go): + __(vrefr(nfn,nfn,1)) + __(ldr(loc_pc,_function.codevector(nfn))) + __(mtctr loc_pc) + __(bctr) + +/* This treats anything that's either */ +/* #+ppc32 (signed-byte 32), (unsigned-byte 32) */ +/* #+ppc64 (signed-byte 64), (unsigned-byte 64) */ +/* as if it denoted a "natural-sized" value. */ +/* Argument in arg_z, result in imm0. May use temp0. */ +_spentry(getxlong) + __ifdef([PPC64]) + __else + __(extract_typecode(imm0,arg_z)) + __(cmpri(cr0,imm0,tag_fixnum)) + __(cmpri(cr1,imm0,subtag_bignum)) + __(unbox_fixnum(imm0,arg_z)) + __(beqlr cr0) + __(mr temp0,arg_z) + __(bne- cr1,local_label(error)) + __(getvheader(imm0,temp0)) + __(cmpri(cr1,imm0,one_digit_bignum_header)) + __(cmpri(cr7,imm0,two_digit_bignum_header)) + __(beq cr1,local_label(big1)) + __(beq cr7,local_label(big2)) +local_label(error): + __(uuo_interr(error_object_not_integer,arg_z)) /* not quite right but what 68K MCL said */ + + + +local_label(big2): + __(vrefr(imm0,temp0,1)) /* sign digit must be 0 */ + __(cmpri(imm0,0)) + __(bne local_label(error)) +local_label(big1): + __(vrefr(imm0,temp0,0)) + __(blr) + + + __endif + +/* Everything up to the last arg has been vpushed, nargs is set to */ +/* the (boxed) count of things already pushed. */ +/* On exit, arg_x, arg_y, arg_z, and nargs are set as per a normal */ +/* function call (this may require vpopping a few things.) */ +/* ppc2-invoke-fn assumes that temp1 is preserved here. */ +_spentry(spreadargz) + __ifdef([PPC64]) + __(extract_fulltag(imm1,arg_z)) + __(cmpri(cr1,imm1,fulltag_cons)) + __else + __(extract_lisptag(imm1,arg_z)) + __(cmpri(cr1,imm1,tag_list)) + __endif + __(cmpri(cr0,arg_z,nil_value)) + __(li imm0,0) + __(mr arg_y,arg_z) /* save in case of error */ + __(beq cr0,2f) +1: + __(bne- cr1,3f) + __(_car(arg_x,arg_z)) + __(_cdr(arg_z,arg_z)) + __(cmpri(cr0,arg_z,nil_value)) + __ifdef([PPC64]) + __(extract_fulltag(imm1,arg_z)) + __(cmpri(cr1,imm1,fulltag_cons)) + __else + __(extract_lisptag(imm1,arg_z)) + __(cmpri(cr1,imm1,tag_list)) + __endif + __(vpush(arg_x)) + __(addi imm0,imm0,fixnum_one) + __(bne cr0,1b) +2: + __(add. nargs,nargs,imm0) + __(cmpri(cr2,nargs,2< bytes */ + __(add imm2,vsp,imm2) /* imm2 points below pairs */ + __(li imm0,0) /* count unknown keywords so far */ + __(extrwi imm1,nargs,1,mask_aok) /* unknown keywords allowed */ + __(extrwi nargs,nargs,mask_key_width,mask_key_start) + /* Now, for each keyword/value pair in the list */ + /* a) if the keyword is found in the keyword vector, set the */ + /* corresponding entry on the vstack to the value and the */ + /* associated supplied-p var to T. */ + /* b) Regardless of whether or not the keyword is found, */ + /* if :ALLOW-OTHER-KEYS is provided with a non-nil value, */ + /* set the low bit of imm1 to indicate that unknown keywords */ + /* are acceptable. (This bit is pre-set above to the value */ + /* the encoded value of &allow_other_keys.) */ + /* c) If the keyword is not found (and isn't :ALLOW-OTHER-KEYS), increment */ + /* the count of unknown keywords in the high bits of imm1*/ + /* At the end of the list, signal an error if any unknown keywords were seen */ + /* but not allowed. Otherwise, return. */ + +match_keys_loop: + __(cmpri(cr0,arg_reg,nil_value)) + __(li imm0,0) + __(li imm3,misc_data_offset) + __(beq cr0,matched_keys) + __(ldr(arg_x,cons.car(arg_reg))) + __(li arg_y,nrs.kallowotherkeys) + __(cmpr(cr3,arg_x,arg_y)) /* :ALLOW-OTHER-KEYS ? */ + __(ldr(arg_reg,cons.cdr(arg_reg))) + __(ldr(arg_y,cons.car(arg_reg))) + __(cmpr(cr4,imm0,nargs)) + __(ldr(arg_reg,cons.cdr(arg_reg))) + __(b match_test) +match_loop: + __(ldrx(temp0,keyvect_reg,imm3)) + __(cmpr(cr0,arg_x,temp0)) + __(addi imm0,imm0,1) + __(cmpr(cr4,imm0,nargs)) + __(addi imm3,imm3,node_size) + __(bne cr0,match_test) + /* Got a hit. Unless this keyword's been seen already, set it. */ + __(slwi imm0,imm0,dnode_shift) + __(subf imm0,imm0,imm2) + __(ldr(temp0,0(imm0))) + __(cmpri(cr0,temp0,nil_value)) + __(li temp0,t_value) + __(bne cr0,match_keys_loop) /* already saw this */ + __(str(arg_y,node_size*1(imm0))) + __(str(temp0,node_size*0(imm0))) + __(bne cr3,match_keys_loop) + __(b match_keys_check_aok) +match_test: + __(bne cr4,match_loop) + __(beq cr3,match_keys_check_aok) + __(addi imm1,imm1,node_size) + __(b match_keys_loop) +match_keys_check_aok: + __(andi. imm0,imm1,2) /* check "seen-aok" bit in imm1 */ + __(cmpri cr1,arg_y,nil_value) /* check value */ + __(ori imm1,imm1,2) + __(bne cr0,match_keys_loop) /* duplicate aok */ + __(beq cr1,match_keys_loop) + __(ori imm1,imm1,1) + __(b match_keys_loop) +matched_keys: + __(clrrwi. imm0,imm1,2) + __(beqlr) + __(andi. imm1,imm1,1) + __(bnelr) + /* Some unrecognized keywords. Complain generically about */ + /* invalid keywords. */ +db_badkeys: + __(li arg_y,XBADKEYS) + __(b destructure_error) +toomany: + __(li arg_y,XCALLTOOMANY) + __(b destructure_error) +toofew: + __(li arg_y,XCALLTOOFEW) + __(b destructure_error) +badlist: + __(li arg_y,XCALLNOMATCH) + /* b destructure_error */ +destructure_error: + __(mr vsp,imm4) /* undo everything done to the stack */ + __(mr arg_z,whole_reg) + __(set_nargs(2)) + __(b _SPksignalerr) + +/* vpush the values in the value set atop the vsp, incrementing nargs. */ +/* Discard the tsp frame; leave values atop the vsp. */ + +_spentry(recover_values) + +/* First, walk the segments reversing the pointer to previous segment pointers */ +/* Can tell the end because that previous segment pointer is the prev tsp pointer */ + __(ldr(imm0,tsp_frame.backlink(tsp))) /* previous tsp */ + __(mr imm1,tsp) /* current segment */ + __(mr imm2,tsp) /* last segment */ +local_label(walkloop): + __(ldr(imm3,tsp_frame.fixed_overhead+node_size(imm1))) /* next segment */ + __(cmpr(cr0,imm0,imm3)) /* last segment? */ + __(str(imm2,tsp_frame.fixed_overhead+node_size(imm1))) /* reverse pointer */ + __(mr imm2,imm1) /* last segment <- current segment */ + __(mr imm1,imm3) /* current segment <- next segment */ + __(bne cr0,local_label(walkloop)) + + /* the final segment ptr is now in imm2 */ + /* walk backwards, pushing values on VSP and incrementing NARGS */ +local_label(pushloop): + __(ldr(imm0,tsp_frame.data_offset(imm2))) /* nargs in segment */ + __(cmpri(cr0,imm0,0)) + __(cmpr(cr1,imm2,tsp)) + __(la imm3,tsp_frame.data_offset+(2*node_size)(imm2)) + __(add imm3,imm3,imm0) + __(add nargs,nargs,imm0) + __(b 2f) +1: + __(ldru(arg_z,-node_size(imm3))) + __(cmpri(cr0,imm0,fixnum_one)) + __(subi imm0,imm0,fixnum_one) + __(vpush(arg_z)) +2: + __(bne cr0,1b) + __(ldr(imm2,tsp_frame.data_offset+node_size(imm2))) /* previous segment */ + __(bne cr1,local_label(pushloop)) + __(unlink(tsp)) + __(blr) + + +/* Go out of line to do this. Sheesh. */ + +_spentry(vpopargregs) + __(cmpri(cr0,nargs,0)) + __(cmpri(cr1,nargs,2<callback-index */ +/* Restore lisp context, then funcall #'%pascal-functions% with */ +/* two args: callback-index, args-ptr (a macptr pointing to the args on the stack) */ +_spentry(poweropen_callback) + __ifdef([rTOC]) + __(mr r11,rTOC) + __endif + /* Save C argument registers */ + __(str(r3,c_frame.param0(sp))) + __(str(r4,c_frame.param1(sp))) + __(str(r5,c_frame.param2(sp))) + __(str(r6,c_frame.param3(sp))) + __(str(r7,c_frame.param4(sp))) + __(str(r8,c_frame.param5(sp))) + __(str(r9,c_frame.param6(sp))) + __(str(r10,c_frame.param7(sp))) + __(mflr imm3) + __(str(imm3,c_frame.savelr(sp))) + __(mfcr imm0) + __(str(imm0,c_frame.crsave(sp))) + + /* Save the non-volatile registers on the sp stack */ + /* This is a non-standard stack frame, but noone will ever see it, */ + /* so it doesn't matter. It will look like more of the stack frame pushed below. */ + __(stru(sp,-(stack_align(c_reg_save.size))(sp))) + __(str(r13,c_reg_save.save_gprs+(0*node_size)(sp))) + __(str(r14,c_reg_save.save_gprs+(1*node_size)(sp))) + __(str(r15,c_reg_save.save_gprs+(2*node_size)(sp))) + __(str(r16,c_reg_save.save_gprs+(3*node_size)(sp))) + __(str(r17,c_reg_save.save_gprs+(4*node_size)(sp))) + __(str(r18,c_reg_save.save_gprs+(5*node_size)(sp))) + __(str(r19,c_reg_save.save_gprs+(6*node_size)(sp))) + __(str(r20,c_reg_save.save_gprs+(7*node_size)(sp))) + __(str(r21,c_reg_save.save_gprs+(8*node_size)(sp))) + __(str(r22,c_reg_save.save_gprs+(9*node_size)(sp))) + __(str(r23,c_reg_save.save_gprs+(10*node_size)(sp))) + __(str(r24,c_reg_save.save_gprs+(11*node_size)(sp))) + __(str(r25,c_reg_save.save_gprs+(12*node_size)(sp))) + __(str(r26,c_reg_save.save_gprs+(13*node_size)(sp))) + __(str(r27,c_reg_save.save_gprs+(14*node_size)(sp))) + __(str(r28,c_reg_save.save_gprs+(15*node_size)(sp))) + __(str(r29,c_reg_save.save_gprs+(16*node_size)(sp))) + __(str(r30,c_reg_save.save_gprs+(17*node_size)(sp))) + __(str(r31,c_reg_save.save_gprs+(18*node_size)(sp))) + __(stfd f1,c_reg_save.save_fprs+(0*8)(sp)) + __(stfd f2,c_reg_save.save_fprs+(1*8)(sp)) + __(stfd f3,c_reg_save.save_fprs+(2*8)(sp)) + __(stfd f4,c_reg_save.save_fprs+(3*8)(sp)) + __(stfd f5,c_reg_save.save_fprs+(4*8)(sp)) + __(stfd f6,c_reg_save.save_fprs+(5*8)(sp)) + __(stfd f7,c_reg_save.save_fprs+(6*8)(sp)) + __(stfd f8,c_reg_save.save_fprs+(7*8)(sp)) + __(stfd f9,c_reg_save.save_fprs+(8*8)(sp)) + __(stfd f10,c_reg_save.save_fprs+(9*8)(sp)) + __(stfd f11,c_reg_save.save_fprs+(10*8)(sp)) + __(stfd f12,c_reg_save.save_fprs+(11*8)(sp)) + __(stfd f13,c_reg_save.save_fprs+(12*8)(sp)) + __(check_stack_alignment(r0)) + __(mffs f0) + __(stfd f0,c_reg_save.save_fp_zero(sp)) + __(lwz r31,c_reg_save.save_fp_zero+4(sp)) /* recover FPSCR image */ + __(stw r31,c_reg_save.save_fpscr(sp)) + __(lwi(r30,0x43300000)) + __(lwi(r31,0x80000000)) + __(stw r30,c_reg_save.save_fp_zero(sp)) + __(stw r31,c_reg_save.save_fp_zero+4(sp)) + __(stfd fp_s32conv,c_reg_save.save_fps32conv(sp)) + __(lfd fp_s32conv,c_reg_save.save_fp_zero(sp)) + __(stfd fp_zero,c_reg_save.save_fp_zero(sp)) + __(lfs fp_zero,lisp_globals.short_float_zero(0)) /* ensure that fp_zero contains 0.0 */ + +/* Restore rest of Lisp context. */ +/* Could spread out the memory references here to gain a little speed */ + + __(li loc_pc,0) + __(li fn,0) /* subprim, not a lisp function */ + __(li temp3,0) + __(li temp2,0) + __(li temp1,0) + __(li temp0,0) + __(li arg_x,0) + __(box_fixnum(arg_y,r11)) /* callback-index */ + __(la arg_z,c_reg_save.save_fprs(sp)) + __(str(arg_z,stack_align(c_reg_save.size)+c_frame.unused(sp))) + __(la arg_z,stack_align(c_reg_save.size)+c_frame.param0(sp)) /* parameters (tagged as a fixnum) */ + + /* Recover lisp thread context. Have to call C code to do so. */ + __(ref_global(r12,get_tcr)) + __ifdef([rTOC]) + __(ld rTOC,8(r12)) + __(ld r12,0(r12)) + __endif + __(mtctr r12) + __(li r3,1) + __(stru(sp,-(stack_align(c_frame.minsiz))(sp))) + __(bctrl) + __(la rcontext,TCR_BIAS(r3)) + __(la sp,(stack_align(c_frame.minsiz))(sp)) + + __(ldr(vsp,tcr.save_vsp(rcontext))) + __(ldr(tsp,tcr.save_tsp(rcontext))) + __(li rzero,0) + __(li imm0,TCR_STATE_LISP) + __(mtxer rzero) /* lisp wants the overflow bit being clear */ + __(mtctr rzero) + __(li save0,0) + __(li save1,0) + __(li save2,0) + __(li save3,0) + __(li save4,0) + __(li save5,0) + __(li save6,0) + __(li save7,0) + __(lfd f0,tcr.lisp_fpscr(rcontext)) + __(mtfsf 0xff,f0) + __(li allocbase,0) + __(li allocptr,0) + __(str(imm0,tcr.valence(rcontext))) + __(ldr(allocptr,tcr.save_allocptr(rcontext))) + __(ldr(allocbase,tcr.save_allocbase(rcontext))) + + __(restore_saveregs(vsp)) + + /* load nargs and callback to the lisp */ + __(set_nargs(2)) + __(ldr(imm2,tcr.cs_area(rcontext))) + __(ldr(imm4,area.active(imm2))) + __(stru(imm4,-lisp_frame.size(sp))) + __(str(imm3,lisp_frame.savelr(sp))) + __(li fname,nrs.callbacks) /* %pascal-functions% */ + __(call_fname) + __(ldr(imm2,lisp_frame.backlink(sp))) + __(ldr(imm3,tcr.cs_area(rcontext))) + __(str(imm2,area.active(imm3))) + __(discard_lisp_frame()) + /* save_vsp will be restored from ff_call's stack frame, but */ + /* I included it here for consistency. */ + /* save_tsp is set below after we exit Lisp context. */ + __(str(allocptr,tcr.save_allocptr(rcontext))) + __(str(allocbase,tcr.save_allocbase(rcontext))) + __(str(vsp,tcr.save_vsp(rcontext))) + __(str(tsp,tcr.save_tsp(rcontext))) + /* Exit lisp context */ + __(li imm1,TCR_STATE_FOREIGN) + __(str(imm1,tcr.valence(rcontext))) + /* Restore the non-volatile registers & fpscr */ + __(lfd fp_zero,c_reg_save.save_fp_zero(sp)) + __(lwz r31,c_reg_save.save_fpscr(sp)) + __(stw r31,c_reg_save.save_fp_zero+4(sp)) + __(lfd f0,c_reg_save.save_fp_zero(sp)) + __(mtfsf 0xff,f0) + __(ldr(r13,c_reg_save.save_gprs+(0*node_size)(sp))) + __(ldr(r14,c_reg_save.save_gprs+(1*node_size)(sp))) + __(ldr(r15,c_reg_save.save_gprs+(2*node_size)(sp))) + __(ldr(r16,c_reg_save.save_gprs+(3*node_size)(sp))) + __(ldr(r17,c_reg_save.save_gprs+(4*node_size)(sp))) + __(ldr(r18,c_reg_save.save_gprs+(5*node_size)(sp))) + __(ldr(r19,c_reg_save.save_gprs+(6*node_size)(sp))) + __(ldr(r20,c_reg_save.save_gprs+(7*node_size)(sp))) + __(ldr(r21,c_reg_save.save_gprs+(8*node_size)(sp))) + __(ldr(r22,c_reg_save.save_gprs+(9*node_size)(sp))) + __(ldr(r23,c_reg_save.save_gprs+(10*node_size)(sp))) + __(ldr(r24,c_reg_save.save_gprs+(11*node_size)(sp))) + __(ldr(r25,c_reg_save.save_gprs+(12*node_size)(sp))) + __(ldr(r26,c_reg_save.save_gprs+(13*node_size)(sp))) + __(ldr(r27,c_reg_save.save_gprs+(14*node_size)(sp))) + __(ldr(r28,c_reg_save.save_gprs+(15*node_size)(sp))) + __(ldr(r29,c_reg_save.save_gprs+(16*node_size)(sp))) + __(ldr(r30,c_reg_save.save_gprs+(17*node_size)(sp))) + __(ldr(r31,c_reg_save.save_gprs+(18*node_size)(sp))) + __(lfd f1,c_reg_save.save_fprs+(0*8)(sp)) + __(lfd f2,c_reg_save.save_fprs+(1*8)(sp)) + __(lfd f3,c_reg_save.save_fprs+(2*8)(sp)) + __(lfd f4,c_reg_save.save_fprs+(3*8)(sp)) + __(lfd f5,c_reg_save.save_fprs+(4*8)(sp)) + __(lfd f6,c_reg_save.save_fprs+(5*8)(sp)) + __(lfd f7,c_reg_save.save_fprs+(6*8)(sp)) + __(lfd f8,c_reg_save.save_fprs+(7*8)(sp)) + __(lfd f9,c_reg_save.save_fprs+(8*8)(sp)) + __(lfd f10,c_reg_save.save_fprs+(9*8)(sp)) + __(lfd f11,c_reg_save.save_fprs+(10*8)(sp)) + __(lfd f12,c_reg_save.save_fprs+(11*8)(sp)) + __(lfd f13,c_reg_save.save_fprs+(12*8)(sp)) + __(lfd fp_s32conv,c_reg_save.save_fps32conv(sp)) + __(ldr(sp,0(sp))) + __(ldr(r3,c_frame.param0(sp))) + __(ldr(r4,c_frame.param1(sp))) + __(ldr(r5,c_frame.param2(sp))) + __(ldr(r6,c_frame.param3(sp))) + __(ldr(r7,c_frame.param4(sp))) + __(ldr(r8,c_frame.param5(sp))) + __(ldr(r9,c_frame.param6(sp))) + __(ldr(r10,c_frame.param7(sp))) + __(ldr(r11,c_frame.savelr(sp))) + __(mtlr r11) + __(ldr(r11,c_frame.crsave(sp))) + __(mtcr r11) + __(blr) + +/* Like misc_alloc (a LOT like it, since it does most of the work), but takes */ +/* an initial-value arg in arg_z, element_count in arg_x, subtag in arg_y. */ +/* Calls out to %init-misc, which does the rest of the work. */ + +_spentry(misc_alloc_init) + __(mflr loc_pc) + __(build_lisp_frame(fn,loc_pc,vsp)) + __(li fn,0) + __(mr temp0,arg_z) /* initval */ + __(mr arg_z,arg_y) /* subtag */ + __(mr arg_y,arg_x) /* element-count */ + __(bl _SPmisc_alloc) + __(ldr(loc_pc,lisp_frame.savelr(sp))) + __(mtlr loc_pc) + __(ldr(fn,lisp_frame.savefn(sp))) + __(ldr(vsp,lisp_frame.savevsp(sp))) + __(discard_lisp_frame()) + __(li fname,nrs.init_misc) + __(set_nargs(2)) + __(mr arg_y,temp0) + __(jump_fname()) + +/* As in stack_misc_alloc above, only with a non-default initial-value. */ + +_spentry(stack_misc_alloc_init) + __(mflr loc_pc) + __(build_lisp_frame(fn,loc_pc,vsp)) + __(li fn,0) + __(mr temp0,arg_z) /* initval */ + __(mr arg_z,arg_y) /* subtag */ + __(mr arg_y,arg_x) /* element-count */ + __(bl _SPstack_misc_alloc) + __(ldr(loc_pc,lisp_frame.savelr(sp))) + __(mtlr loc_pc) + __(ldr(fn,lisp_frame.savefn(sp))) + __(ldr(vsp,lisp_frame.savevsp(sp))) + __(discard_lisp_frame()) + __(li fname,nrs.init_misc) + __(set_nargs(2)) + __(mr arg_y,temp0) + __(jump_fname()) + + +_spentry(callbuiltin) + __(ref_nrs_value(fname,builtin_functions)) + __(la imm0,misc_data_offset(imm0)) + __(ldrx(fname,fname,imm0)) + __(jump_fname()) + +/* the value of the nilreg-relative symbol %builtin-functions% should be */ +/* a vector of symbols. Call the symbol indexed by imm0 (boxed) and */ +/* return a single value. */ + +_spentry(callbuiltin0) + __(set_nargs(0)) + __(ref_nrs_value(fname,builtin_functions)) + __(la imm0,misc_data_offset(imm0)) + __(ldrx(fname,fname,imm0)) + __(jump_fname()) + +_spentry(callbuiltin1) + __(ref_nrs_value(fname,builtin_functions)) + __(set_nargs(1)) + __(la imm0,misc_data_offset(imm0)) + __(ldrx(fname,fname,imm0)) + __(jump_fname()) + +_spentry(callbuiltin2) + __(set_nargs(2)) + __(ref_nrs_value(fname,builtin_functions)) + __(la imm0,misc_data_offset(imm0)) + __(ldrx(fname,fname,imm0)) + __(jump_fname()) + + +_spentry(callbuiltin3) + __(set_nargs(3)) + __(ref_nrs_value(fname,builtin_functions)) + __(la imm0,misc_data_offset(imm0)) + __(ldrx(fname,fname,imm0)) + __(jump_fname()) + + +_spentry(popj) + .globl C(popj) +C(popj): + __(ldr(loc_pc,lisp_frame.savelr(sp))) + __(ldr(vsp,lisp_frame.savevsp(sp))) + __(mtlr loc_pc) + __(ldr(fn,lisp_frame.savefn(sp))) + __(discard_lisp_frame()) + __(blr) + +_spentry(restorefullcontext) + __(mflr loc_pc) + __(mtctr loc_pc) + __(ldr(loc_pc,lisp_frame.savelr(sp))) + __(mtlr loc_pc) + __(ldr(vsp,lisp_frame.savevsp(sp))) + __(ldr(fn,lisp_frame.savefn(sp))) + __(discard_lisp_frame()) + __(bctr) + +_spentry(savecontextvsp) + __(ldr(imm0,tcr.cs_limit(rcontext))) + __(build_lisp_frame(fn,loc_pc,vsp)) + __(mr fn,nfn) + __(trllt(sp,imm0)) + __(blr) + +_spentry(savecontext0) + __(add imm0,vsp,imm0) + __(build_lisp_frame(fn,loc_pc,imm0)) + __(ldr(imm0,tcr.cs_limit(rcontext))) + __(mr fn,nfn) + __(trllt(sp,imm0)) + __(blr) + + +/* Like .SPrestorefullcontext, only the saved return address */ +/* winds up in loc-pc instead of getting thrashed around ... */ +_spentry(restorecontext) + __(ldr(loc_pc,lisp_frame.savelr(sp))) + __(ldr(vsp,lisp_frame.savevsp(sp))) + __(ldr(fn,lisp_frame.savefn(sp))) + __(discard_lisp_frame()) + __(blr) + + +/* Nargs is valid; all arg regs, lexpr-count pushed by caller. */ +/* imm0 = vsp to restore. */ +/* Return all values returned by caller to its caller, hiding */ +/* the variable-length arglist. */ +/* If we can detect that the caller's caller didn't expect */ +/* multiple values, then things are even simpler. */ +_spentry(lexpr_entry) + __(ref_global(imm1,ret1val_addr)) + __(cmpr(cr0,imm1,loc_pc)) + __(build_lisp_frame(fn,loc_pc,imm0)) + __(bne cr0,1f) + __(ref_global(imm0,lexpr_return)) + __(build_lisp_frame(rzero,imm0,vsp)) + __(mr loc_pc,imm1) + __(ldr(imm0,tcr.cs_limit(rcontext))) + __(trllt(sp,imm0)) + __(li fn,0) + __(blr) + + /* The single-value case just needs to return to something that'll pop */ + /* the variable-length frame off of the vstack. */ +1: + __(ref_global(loc_pc,lexpr_return1v)) + __(ldr(imm0,tcr.cs_limit(rcontext))) + __(trllt(sp,imm0)) + __(li fn,0) + __(blr) + +/* */ +/* Do a system call in Darwin. The stack is set up much as it would be */ +/* for a PowerOpen ABI ff-call: register parameters are in the stack */ +/* frame, and there are 4 extra words at the bottom of the frame that */ +/* we can carve a lisp frame out of. */ +/* */ +/* System call return conventions are a little funky in Darwin: if "@sc" */ +/* is the address of the "sc" instruction, errors return to @sc+4 and */ +/* non-error cases return to @sc+8. Error values are returned as */ +/* positive values in r3; this is true even if the system call returns */ +/* a doubleword (64-bit) result. Since r3 would ordinarily contain */ +/* the high half of a doubleword result, this has to be special-cased. */ +/* */ +/* The caller should set the c_frame.crsave field of the stack frame */ +/* to 0 if the result is to be interpreted as anything but a doubleword */ +/* and to non-zero otherwise. (This only matters on an error return.) */ + + +_spentry(poweropen_syscall) + __(mflr loc_pc) + __(vpush_saveregs()) + __(ldr(imm1,0(sp))) + __(la imm2,-lisp_frame.size(imm1)) + __(zero_doublewords imm2,0,lisp_frame.size) + __(str(imm1,lisp_frame.backlink(imm2))) + __(str(imm2,c_frame.backlink(sp))) + __(str(fn,lisp_frame.savefn(imm2))) + __(str(loc_pc,lisp_frame.savelr(imm2))) + __(str(vsp,lisp_frame.savevsp(imm2))) + __(ldr(imm3,tcr.cs_area(rcontext))) + __(str(imm2,area.active(imm3))) + __(str(allocptr,tcr.save_allocptr(rcontext))) + __(str(allocbase,tcr.save_allocbase(rcontext))) + __(str(tsp,tcr.save_tsp(rcontext))) + __(str(vsp,tcr.save_vsp(rcontext))) + __(str(rzero,tcr.ffi_exception(rcontext))) + __(mr save0,rcontext) + __(li r3,TCR_STATE_FOREIGN) + __(str(r3,tcr.valence(rcontext))) + __(li rcontext,0) + __(ldr(r3,c_frame.param0(sp))) + __(ldr(r4,c_frame.param1(sp))) + __(ldr(r5,c_frame.param2(sp))) + __(ldr(r6,c_frame.param3(sp))) + __(ldr(r7,c_frame.param4(sp))) + __(ldr(r8,c_frame.param5(sp))) + __(ldr(r9,c_frame.param6(sp))) + __(ldr(r10,c_frame.param7(sp))) + __(unbox_fixnum(r0,arg_z)) + __(sc) + __ifdef([LINUX]) + __(bns+ 9f) + __else + __(b 1f) + __(b 9f) + __endif +1: + __ifdef([PPC64]) + __(neg r3,r3) + __else + __(ldr(imm2,c_frame.crsave(sp))) + __(cmpri(cr0,imm2,0)) + __(bne cr0,2f) + /* 32-bit result */ + __(neg r3,r3) + __(b 9f) +2: + /* 64-bit result */ + __(neg r4,r3) + __(li r3,-1) + __endif +9: + __(mr imm2,save0) /* recover context */ + __(ldr(sp,c_frame.backlink(sp))) + __(li imm4,TCR_STATE_LISP) + __(li rzero,0) + __(li loc_pc,0) + __(li arg_x,nil_value) + __(li arg_y,nil_value) + __(li arg_z,nil_value) + __(li temp0,nil_value) + __(li temp1,nil_value) + __(li temp2,nil_value) + __(li temp3,nil_value) + __(li fn,nil_value) + __(mr rcontext,imm2) + __(ldr(allocptr,tcr.save_allocptr(rcontext))) + __(ldr(allocbase,tcr.save_allocbase(rcontext))) + __(ldr(tsp,tcr.save_tsp(rcontext))) + __(li save0,0) + __(li save1,0) + __(li save2,0) + __(li save3,0) + __(li save4,0) + __(li save5,0) + __(li save6,0) + __(li save7,0) + __(str(imm4,tcr.valence(rcontext))) + __(vpop_saveregs) + __(ldr(loc_pc,lisp_frame.savelr(sp))) + __(mtlr loc_pc) + __(ldr(fn,lisp_frame.savefn(sp))) + __(discard_lisp_frame) + __(mtxer rzero) + __(check_pending_interrupt([cr1])) + __(blr) + + +_spentry(builtin_plus) + __(extract_lisptag(imm0,arg_y)) + __(extract_lisptag(imm1,arg_z)) + __(cmpri(cr0,imm0,tag_fixnum)) + __(cmpri(cr1,imm1,tag_fixnum)) + __(bne- cr0,1f) + __(bne- cr1,1f) + __(addo. arg_z,arg_y,arg_z) + __(bnslr+) + __(mtxer rzero) + __(unbox_fixnum(imm1,arg_z)) + __ifdef([PPC64]) + __(li imm0,two_digit_bignum_header) + __(rotldi imm1,imm1,32) + __(xoris imm1,imm1,0xe000) + __(Misc_Alloc_Fixed(arg_z,imm0,aligned_bignum_size(2))) + __(str(imm1,misc_data_offset(arg_z))) + __else + __(li imm0,one_digit_bignum_header) + __(xoris imm1,imm1,0xc000) + __(Misc_Alloc_Fixed(arg_z,imm0,aligned_bignum_size(1))) + __(str(imm1,misc_data_offset(arg_z))) + __endif + __(blr) +1: + __(jump_builtin(_builtin_plus,2)) +_spentry(builtin_minus) + __(extract_lisptag(imm0,arg_y)) + __(extract_lisptag(imm1,arg_z)) + __(cmpri(cr0,imm0,tag_fixnum)) + __(cmpri(cr1,imm1,tag_fixnum)) + __(bne- cr0,1f) + __(bne- cr1,1f) + __(subo. arg_z,arg_y,arg_z) + __(bnslr+) + __(mtxer rzero) + __(unbox_fixnum(imm1,arg_z)) + __ifdef([PPC64]) + __(li imm0,two_digit_bignum_header) + __(rotldi imm1,imm1,32) + __(xoris imm1,imm1,0xe000) + __(Misc_Alloc_Fixed(arg_z,imm0,aligned_bignum_size(2))) + __(str(imm1,misc_data_offset(arg_z))) + __else + __(li imm0,one_digit_bignum_header) + __(xoris imm1,imm1,0xc000) + __(Misc_Alloc_Fixed(arg_z,imm0,aligned_bignum_size(1))) + __(str(imm1,misc_data_offset(arg_z))) + __endif + __(blr) +1: + __(jump_builtin(_builtin_minus,2)) +_spentry(builtin_times) + __(extract_lisptag(imm0,arg_y)) + __(extract_lisptag(imm1,arg_z)) + __(cmpri(cr0,imm0,tag_fixnum)) + __(cmpri(cr1,imm1,tag_fixnum)) + __(unbox_fixnum(imm2,arg_y)) + __(bne cr0,1f) + __(bne cr1,1f) + __ifdef([PPC64]) + __(mulldo. imm3,arg_z,imm2) + __(bso 2f) + __(mr arg_z,imm3) + __(blr) + /* Args are fixnums; result can't be */ +2: __(mtxer rzero) + __(unbox_fixnum(imm3,arg_z)) + __(mulld imm1,imm3,imm2) /* imm1 = low 64 bits */ + __(mulhd imm0,imm3,imm2) /* imm0 = high 64 bits */ + __(b _SPmakes128) + __else + __(mullwo. imm3,arg_z,imm2) + __(bso 2f) /* SO set if result would overflow a fixnum */ + __(mr arg_z,imm3) + __(blr) + /* Args are fixnums; result can't be */ +2: __(mtxer rzero) + __(unbox_fixnum(imm3,arg_z)) + __(mullw imm1,imm3,imm2) /* imm1 = low 32 bits */ + __(mulhw imm0,imm3,imm2) /* imm0 = high 32 bits */ + __(b _SPmakes64) + __endif + +1: __(jump_builtin(_builtin_times,2)) + +_spentry(builtin_div) + __(jump_builtin(_builtin_div,2)) + +_spentry(builtin_eq) + __(extract_lisptag(imm0,arg_y)) + __(extract_lisptag(imm1,arg_z)) + __(cmpri(cr0,imm0,tag_fixnum)) + __(cmpri(cr1,imm1,tag_fixnum)) + __(cmpr(cr2,arg_y,arg_z)) + __(bne- cr0,1f) + __(bne- cr1,1f) + __(li arg_z,nil_value) + __(bnelr cr2) + __(li arg_z,t_value) + __(blr) +1: + __(jump_builtin(_builtin_eq,2)) + +_spentry(builtin_ne) + __(extract_lisptag(imm0,arg_y)) + __(extract_lisptag(imm1,arg_z)) + __(cmpri(cr0,imm0,tag_fixnum)) + __(cmpri(cr1,imm1,tag_fixnum)) + __(cmpr(cr2,arg_y,arg_z)) + __(bne- cr0,1f) + __(bne- cr1,1f) + __(li arg_z,nil_value) + __(beqlr cr2) + __(li arg_z,t_value) + __(blr) +1: + __(jump_builtin(_builtin_ne,2)) + +_spentry(builtin_gt) + __(extract_lisptag(imm0,arg_y)) + __(extract_lisptag(imm1,arg_z)) + __(cmpri(cr0,imm0,tag_fixnum)) + __(cmpri(cr1,imm1,tag_fixnum)) + __(cmpr(cr2,arg_y,arg_z)) + __(bne- cr0,1f) + __(bne- cr1,1f) + __(li arg_z,nil_value) + __(bnglr cr2) + __(li arg_z,t_value) + __(blr) +1: + __(jump_builtin(_builtin_gt,2)) + +_spentry(builtin_ge) + __(extract_lisptag(imm0,arg_y)) + __(extract_lisptag(imm1,arg_z)) + __(cmpri(cr0,imm0,tag_fixnum)) + __(cmpri(cr1,imm1,tag_fixnum)) + __(cmpr(cr2,arg_y,arg_z)) + __(bne- cr0,1f) + __(bne- cr1,1f) + __(li arg_z,nil_value) + __(bltlr cr2) + __(li arg_z,t_value) + __(blr) +1: + __(jump_builtin(_builtin_ge,2)) + +_spentry(builtin_lt) + __(extract_lisptag(imm0,arg_y)) + __(extract_lisptag(imm1,arg_z)) + __(cmpri(cr0,imm0,tag_fixnum)) + __(cmpri(cr1,imm1,tag_fixnum)) + __(cmpr(cr2,arg_y,arg_z)) + __(bne- cr0,1f) + __(bne- cr1,1f) + __(li arg_z,nil_value) + __(bnllr cr2) + __(li arg_z,t_value) + __(blr) +1: + __(jump_builtin(_builtin_lt,2)) + +_spentry(builtin_le) + __(extract_lisptag(imm0,arg_y)) + __(extract_lisptag(imm1,arg_z)) + __(cmpri(cr0,imm0,tag_fixnum)) + __(cmpri(cr1,imm1,tag_fixnum)) + __(cmpr(cr2,arg_y,arg_z)) + __(bne- cr0,1f) + __(bne- cr1,1f) + __(li arg_z,nil_value) + __(bgtlr cr2) + __(li arg_z,t_value) + __(blr) +1: + __(jump_builtin(_builtin_le,2)) + + +_spentry(builtin_eql) + __(cmpr(cr1,arg_y,arg_z)) + __(extract_fulltag(imm2,arg_y)) + __(extract_fulltag(imm3,arg_z)) + __(beq cr1,1f) + __(cmpri(cr1,imm2,fulltag_misc)) + __(cmpri(cr0,imm3,fulltag_misc)) + __(bne cr1,2f) + __(extract_subtag(imm0,arg_y)) + __(bne cr0,2f) + __(extract_subtag(imm1,arg_z)) + __(cmpr(cr0,imm0,imm1)) + __(bne cr0,2f) + __(jump_builtin(_builtin_eql,2)) +1: __(li arg_z,t_value) + __(blr) +2: __(li arg_z,nil_value) + __(blr) + +_spentry(builtin_length) + __(cmpri(cr1,arg_z,nil_value)) + __(extract_typecode(imm0,arg_z)) + __(cmpri(cr0,imm0,min_vector_subtag)) + __(beq cr1,1f) + __ifdef([PPC64]) + __(cmpdi cr2,imm0,fulltag_cons) + __else + __(cmpwi cr2,imm0,tag_list) + __endif + __(beq- cr0,2f) + __(blt- cr0,3f) + /* (simple-array * (*)) */ + __(vector_length(arg_z,arg_z,imm0)) + __(blr) +1: __(li arg_z,0) + __(blr) +2: + __(ldr(arg_z,vectorH.logsize(arg_z))) + __(blr) +3: __(bne cr2,8f) + __(li temp2,-1< n */ + __(blr) +0: + __(unbox_fixnum(imm1,arg_y)) + __(unbox_fixnum(imm0,arg_z)) + __(bgt cr1,2f) + /* (ash n -count) => fixnum */ + __(neg imm2,imm0) + __(bgt cr2,1f) + __(li imm2,63) +1: + __(srad imm0,imm1,imm2) + __(box_fixnum(arg_z,imm0)) + __(blr) + /* Integer-length of arg_y/imm1 to imm2 */ +2: + __(cntlzd. imm2,imm1) + __(bne 3f) /* cr0[eq] set if negative */ + __(not imm2,imm1) + __(cntlzd imm2,imm2) +3: + __(subfic imm2,imm2,64) + __(add imm2,imm2,imm0) /* imm2 <- integer-length(imm1) + count */ + __(cmpdi cr1,imm2,63-fixnumshift) + __(cmpdi cr2,imm0,64) + __(sld imm2,imm1,imm0) + __(bgt cr1,6f) + __(box_fixnum(arg_z,imm2)) + __(blr) +6: + __(bgt cr2,9f) + __(bne cr2,7f) + /* Shift left by 64 bits exactly */ + __(mr imm0,imm1) + __(li imm1,0) + __(beq _SPmakes128) + __(b _SPmakeu128) +7: + /* Shift left by fewer than 64 bits, result not a fixnum */ + __(subfic imm0,imm0,64) + __(beq 8f) + __(srd imm0,imm1,imm0) + __(mr imm1,imm2) + __(b _SPmakeu128) +8: + __(srad imm0,imm1,imm0) + __(mr imm1,imm2) + __(b _SPmakes128) + __else + __(cmpri(cr1,arg_z,0)) + __(extract_lisptag(imm0,arg_y)) + __(extract_lisptag(imm1,arg_z)) + __(cmpri(cr0,imm0,tag_fixnum)) + __(cmpri(cr3,imm1,tag_fixnum)) + __(cmpri(cr2,arg_z,-(29<<2))) /* !! 2 = fixnumshift */ + __(bne- cr0,9f) + __(bne- cr3,9f) + __(bne cr1,0f) + __(mr arg_z,arg_y) /* (ash n 0) => n */ + __(blr) +0: + __(unbox_fixnum(imm1,arg_y)) + __(unbox_fixnum(imm0,arg_z)) + __(bgt cr1,2f) + /* (ash n -count) => fixnum */ + __(neg imm2,imm0) + __(bgt cr2,1f) + __(li imm2,31) +1: + __(sraw imm0,imm1,imm2) + __(box_fixnum(arg_z,imm0)) + __(blr) + /* Integer-length of arg_y/imm1 to imm2 */ +2: + __(cntlzw. imm2,imm1) + __(bne 3f) /* cr0[eq] set if negative */ + __(not imm2,imm1) + __(cntlzw imm2,imm2) +3: + __(subfic imm2,imm2,32) + __(add imm2,imm2,imm0) /* imm2 <- integer-length(imm1) + count */ + __(cmpri(cr1,imm2,31-fixnumshift)) + __(cmpri(cr2,imm0,32)) + __(slw imm2,imm1,imm0) + __(bgt cr1,6f) + __(box_fixnum(arg_z,imm2)) + __(blr) +6: + __(bgt cr2,9f) + __(bne cr2,7f) + /* Shift left by 32 bits exactly */ + __(mr imm0,imm1) + __(li imm1,0) + __(beq _SPmakes64) + __(b _SPmakeu64) +7: + /* Shift left by fewer than 32 bits, result not a fixnum */ + __(subfic imm0,imm0,32) + __(beq 8f) + __(srw imm0,imm1,imm0) + __(mr imm1,imm2) + __(b _SPmakeu64) +8: + __(sraw imm0,imm1,imm0) + __(mr imm1,imm2) + __(b _SPmakes64) + __endif +9: + __(jump_builtin(_builtin_ash,2)) + +_spentry(builtin_negate) + __(extract_lisptag_(imm0,arg_z)) + __(bne- cr0,1f) + __(nego. arg_z,arg_z) + __(bnslr+) + __(mtxer rzero) + __(unbox_fixnum(imm1,arg_z)) + __ifdef([PPC64]) + __(li imm0,two_digit_bignum_header) + __(rotldi imm1,imm1,32) + __(xoris imm1,imm1,0xe000) + __(Misc_Alloc_Fixed(arg_z,imm0,aligned_bignum_size(2))) + __(str(imm1,misc_data_offset(arg_z))) + __else + __(li imm0,one_digit_bignum_header) + __(xoris imm1,imm1,0xc000) + __(Misc_Alloc_Fixed(arg_z,imm0,aligned_bignum_size(1))) + __(str(imm1,misc_data_offset(arg_z))) + __endif + __(blr) +1: + __(jump_builtin(_builtin_negate,1)) + +_spentry(builtin_logxor) + __(extract_lisptag(imm0,arg_y)) + __(extract_lisptag(imm1,arg_z)) + __(cmpri(cr0,imm0,tag_fixnum)) + __(cmpri(cr1,imm1,tag_fixnum)) + __(bne- cr0,1f) + __(bne- cr1,1f) + __(xor arg_z,arg_y,arg_z) + __(blr) +1: + __(jump_builtin(_builtin_logxor,2)) + + + + +_spentry(builtin_aset1) + __(extract_typecode(imm0,arg_x)) + __(cmpri(cr0,imm0,min_vector_subtag)) + __(box_fixnum(temp0,imm0)) + __(bgt cr0,1f) + __(jump_builtin(_builtin_aset1,3)) +1: + __(b _SPsubtag_misc_set) + +/* Enter the debugger */ +_spentry(breakpoint) + __(li r3,0) + __(tw 28,sp,sp) /* 28 = lt|gt|eq (assembler bug for the latter) */ + __(blr) /* if handler didn't */ + +/* */ +/* We're entered with an eabi_c_frame on the C stack. There's a */ +/* lisp_frame reserved underneath it; we'll link it in in a minute. */ +/* Load the outgoing GPR arguments from eabi_c_frame.param[0-7], */ +/* then shrink the eabi_c_frame. */ +/* */ + +_spentry(eabi_ff_call) + __(mflr loc_pc) + __(str(sp,eabi_c_frame.savelr(sp))) + __(vpush_saveregs()) /* Now we can use save0-save7 to point to stacks */ + __(mr save0,rcontext) /* or address globals. */ + __(extract_typecode(imm0,arg_z)) + __(cmpri(imm0,subtag_macptr)) + __(ldr(save1,0(sp))) /* bottom of reserved lisp frame */ + __(la save2,-lisp_frame.size(save1)) /* top of lisp frame */ + __(zero_doublewords save2,0,lisp_frame.size) + __(str(save1,lisp_frame.backlink(save2))) + __(str(save2,c_frame.backlink(sp))) + __(str(fn,lisp_frame.savefn(save2))) + __(str(loc_pc,lisp_frame.savelr(save2))) + __(str(vsp,lisp_frame.savevsp(save2))) + __(bne 1f) + __(ldr(arg_z,macptr.address(arg_z))) +1: + __(ldr(save3,tcr.cs_area(rcontext))) + __(str(save2,area.active(save3))) + __(str(allocptr,tcr.save_allocptr(rcontext))) + __(str(allocbase,tcr.save_allocbase(rcontext))) + __(str(tsp,tcr.save_tsp(rcontext))) + __(str(vsp,tcr.save_vsp(rcontext))) + __(mtctr arg_z) + __(str(rzero,tcr.ffi_exception(rcontext))) + __(mffs f0) + __(stfd f0,tcr.lisp_fpscr(rcontext)) /* remember lisp's fpscr */ + __(mtfsf 0xff,fp_zero) /* zero foreign fpscr */ + __(li imm1,TCR_STATE_FOREIGN) + __(str(imm1,tcr.valence(rcontext))) + __(ldr(r2,tcr.native_thread_info(rcontext))) + __(ldr(r13,lisp_globals.saveR13(0))) + __(ldr(r3,eabi_c_frame.param0(sp))) + __(ldr(r4,eabi_c_frame.param1(sp))) + __(ldr(r5,eabi_c_frame.param2(sp))) + __(ldr(r6,eabi_c_frame.param3(sp))) + __(ldr(r7,eabi_c_frame.param4(sp))) + __(ldr(r8,eabi_c_frame.param5(sp))) + __(ldr(r9,eabi_c_frame.param6(sp))) + __(ldr(r10,eabi_c_frame.param7(sp))) + __(la save1,eabi_c_frame.minsiz-eabi_c_frame.param0(sp)) + __(str(rzero,eabi_c_frame.savelr(save1))) + __(str(save2,eabi_c_frame.backlink(save1))) + __(mr sp,save1) + /* If we're calling a varargs C function, it'll want to */ + /* know whether or not we've passed any args in FP regs. */ + /* Better to say that we did (and force callee to save FP */ + /* arg regs on entry) than to say that we didn't and get */ + /* garbage results */ + __(crset 6) + __(bctrl) + /* C should have preserved save0 (= rcontext) for us. */ + __(ldr(sp,0(sp))) + __(mr imm2,save0) + __(ldr(vsp,lisp_frame.savevsp(sp))) + __(li rzero,0) + __(mr loc_pc,rzero) + __(li arg_x,nil_value) + __(li arg_y,nil_value) + __(li arg_z,nil_value) + __(li temp0,nil_value) + __(li temp1,nil_value) + __(li temp2,nil_value) + __(li temp3,nil_value) + __(li fn,nil_value) + __(mr rcontext,imm2) + __(li imm2,TCR_STATE_LISP) + __(ldr(tsp,tcr.save_tsp(rcontext))) + __(li save0,0) + __(li save1,0) + __(li save2,0) + __(li save3,0) + __(li save4,0) + __(li save5,0) + __(li save6,0) + __(li save7,0) + __(li allocptr,-dnode_size) + __(li allocbase,-dnode_size) + __(str(imm2,tcr.valence(rcontext))) + __(vpop_saveregs()) + __(ldr(allocptr,tcr.save_allocptr(rcontext))) + __(ldr(allocbase,tcr.save_allocbase(rcontext))) + __(ldr(loc_pc,lisp_frame.savelr(sp))) + __(mtlr loc_pc) + __(ldr(fn,lisp_frame.savefn(sp))) + __(mffs f0) + __(stfd f0,8(sp)) + __(lwz imm3,12(sp)) /* imm3 = FPSCR after call */ + __(clrrwi imm2,imm3,8) + __(discard_lisp_frame()) + __(str(imm2,tcr.ffi_exception(rcontext))) + __(lfd f0,tcr.lisp_fpscr(rcontext)) + __(mtfsf 0xff,f0) + __(check_pending_interrupt([cr1])) + __(mtxer rzero) + __(mtctr rzero) + __(blr) + +/* */ +/* This gets called with R11 holding the unboxed callback index. */ +/* */ + +_spentry(eabi_callback) + /* First, we extend the C frame so that it has room for */ + /* incoming arg regs. */ + __(ldr(r0,eabi_c_frame.backlink(sp))) + __(stru(r0,eabi_c_frame.param0-varargs_eabi_c_frame.incoming_stack_args(sp))) + __(mflr r0) + __(str(r0,varargs_eabi_c_frame.savelr(sp))) + __(str(r3,varargs_eabi_c_frame.gp_save+(0*4)(sp))) + __(str(r4,varargs_eabi_c_frame.gp_save+(1*4)(sp))) + __(str(r5,varargs_eabi_c_frame.gp_save+(2*4)(sp))) + __(str(r6,varargs_eabi_c_frame.gp_save+(3*4)(sp))) + __(str(r7,varargs_eabi_c_frame.gp_save+(4*4)(sp))) + __(str(r8,varargs_eabi_c_frame.gp_save+(5*4)(sp))) + __(str(r9,varargs_eabi_c_frame.gp_save+(6*4)(sp))) + __(str(r10,varargs_eabi_c_frame.gp_save+(7*4)(sp))) + /* Could check the appropriate CR bit and skip saving FP regs here */ + __(stfd f1,varargs_eabi_c_frame.fp_save+(0*8)(sp)) + __(stfd f2,varargs_eabi_c_frame.fp_save+(1*8)(sp)) + __(stfd f3,varargs_eabi_c_frame.fp_save+(2*8)(sp)) + __(stfd f4,varargs_eabi_c_frame.fp_save+(3*8)(sp)) + __(stfd f5,varargs_eabi_c_frame.fp_save+(4*8)(sp)) + __(stfd f6,varargs_eabi_c_frame.fp_save+(5*8)(sp)) + __(stfd f7,varargs_eabi_c_frame.fp_save+(6*8)(sp)) + __(stfd f8,varargs_eabi_c_frame.fp_save+(7*8)(sp)) + __(la r0,varargs_eabi_c_frame.incoming_stack_args(sp)) + __(str(r0,varargs_eabi_c_frame.overflow_arg_area(sp))) + __(la r0,varargs_eabi_c_frame.regsave(sp)) + __(str(r0,varargs_eabi_c_frame.reg_save_area(sp))) + __(li r0,0) + __(str(r0,varargs_eabi_c_frame.flags(sp))) + + /* Save the non-volatile registers on the sp stack */ + /* This is a non-standard stack frame, but noone will ever see it, */ + /* so it doesn't matter. It will look like more of the stack frame pushed below. */ + __(stru(sp,-(c_reg_save.size)(sp))) + __(str(r13,c_reg_save.save_gprs+(0*node_size)(sp))) + __(str(r14,c_reg_save.save_gprs+(1*node_size)(sp))) + __(str(r15,c_reg_save.save_gprs+(2*node_size)(sp))) + __(str(r16,c_reg_save.save_gprs+(3*node_size)(sp))) + __(str(r17,c_reg_save.save_gprs+(4*node_size)(sp))) + __(str(r18,c_reg_save.save_gprs+(5*node_size)(sp))) + __(str(r19,c_reg_save.save_gprs+(6*node_size)(sp))) + __(str(r20,c_reg_save.save_gprs+(7*node_size)(sp))) + __(str(r21,c_reg_save.save_gprs+(8*node_size)(sp))) + __(str(r22,c_reg_save.save_gprs+(9*node_size)(sp))) + __(str(r23,c_reg_save.save_gprs+(10*node_size)(sp))) + __(str(r24,c_reg_save.save_gprs+(11*node_size)(sp))) + __(str(r25,c_reg_save.save_gprs+(12*node_size)(sp))) + __(str(r26,c_reg_save.save_gprs+(13*node_size)(sp))) + __(str(r27,c_reg_save.save_gprs+(14*node_size)(sp))) + __(str(r28,c_reg_save.save_gprs+(15*node_size)(sp))) + __(str(r29,c_reg_save.save_gprs+(16*node_size)(sp))) + __(str(r30,c_reg_save.save_gprs+(17*node_size)(sp))) + __(str(r31,c_reg_save.save_gprs+(18*node_size)(sp))) + __(mffs f0) + __(stfd f0,c_reg_save.save_fp_zero(sp)) + __(ldr(r31,c_reg_save.save_fp_zero+4(sp))) /* recover FPSCR image */ + __(str(r31,c_reg_save.save_fpscr(sp))) + __(lwi(r30,0x43300000)) + __(lwi(r31,0x80000000)) + __(str(r30,c_reg_save.save_fp_zero(sp))) + __(str(r31,c_reg_save.save_fp_zero+4(sp))) + __(stfd fp_s32conv,c_reg_save.save_fps32conv(sp)) + __(lfd fp_s32conv,c_reg_save.save_fp_zero(sp)) + __(stfd fp_zero,c_reg_save.save_fp_zero(sp)) + __(lfs fp_zero,lisp_globals.short_float_zero(0)) /* ensure that fp_zero contains 0.0 */ + + +/* Restore rest of Lisp context. */ +/* Could spread out the memory references here to gain a little speed */ + __(li loc_pc,0) + __(li fn,0) /* subprim, not a lisp function */ + __(li temp3,0) + __(li temp2,0) + __(li temp1,0) + __(li temp0,0) + __(li arg_x,0) + __(box_fixnum(arg_y,r11)) /* callback-index */ + __(la arg_z,c_reg_save.size+varargs_eabi_c_frame.gp_save(sp)) /* parameters (tagged as a fixnum) */ + + /* Recover lisp thread context. Have to call C code to do so. */ + __(ref_global(r12,get_tcr)) + __(mtctr r12) + __(li r3,1) + __(stru(sp,-(stack_align(eabi_c_frame.minsiz))(sp))) + __(bctrl) + __(la sp,(stack_align(eabi_c_frame.minsiz))(sp)) + __(la rcontext,TCR_BIAS(r3)) + __(li allocptr,0) + __(li allocbase,0) + __(ldr(vsp,tcr.save_vsp(rcontext))) + __(ldr(tsp,tcr.save_tsp(rcontext))) + __(li rzero,0) + __(mtxer rzero) /* lisp wants the overflow bit clear */ + __(li imm0,TCR_STATE_LISP) + __(li save0,0) + __(li save1,0) + __(li save2,0) + __(li save3,0) + __(li save4,0) + __(li save5,0) + __(li save6,0) + __(li save7,0) + __(mtctr rzero) + __(str(imm0,tcr.valence(rcontext))) + __(ldr(allocptr,tcr.save_allocptr(rcontext))) + __(ldr(allocbase,tcr.save_allocbase(rcontext))) + __(lfd f0,tcr.lisp_fpscr(rcontext)) + __(mtfsf 0xff,f0) + + __(restore_saveregs(vsp)) + /* load nargs and callback to the lisp */ + __(set_nargs(2)) + __(ldr(imm2,tcr.cs_area(rcontext))) + __(ldr(imm4,area.active(imm2))) + __(stru(imm4,-lisp_frame.size(sp))) + __(str(imm3,lisp_frame.savelr(sp))) + __(str(vsp,lisp_frame.savevsp(sp))) /* for stack overflow code */ + __(li fname,nrs.callbacks) /* %pascal-functions% */ + __(call_fname) + __(ldr(imm2,lisp_frame.backlink(sp))) + __(ldr(imm3,tcr.cs_area(rcontext))) + __(str(imm2,area.active(imm3))) + __(discard_lisp_frame()) + /* save_vsp will be restored from ff_call's stack frame, but */ + /* I included it here for consistency. */ + /* save_tsp is set below after we exit Lisp context. */ + __(str(allocptr,tcr.save_allocptr(rcontext))) + __(str(allocbase,tcr.save_allocbase(rcontext))) + __(str(vsp,tcr.save_vsp(rcontext))) + __(str(tsp,tcr.save_tsp(rcontext))) + /* Exit lisp context */ + /* This is not necessary yet, but will be once we can be interrupted */ + __(li imm1,TCR_STATE_FOREIGN) + __(str(imm1,tcr.valence(rcontext))) + /* Restore the non-volatile registers & fpscr */ + __(lfd fp_zero,c_reg_save.save_fp_zero(sp)) + __(ldr(r31,c_reg_save.save_fpscr(sp))) + __(str(r31,c_reg_save.save_fp_zero+4(sp))) + __(lfd f0,c_reg_save.save_fp_zero(sp)) + __(mtfsf 0xff,f0) + __(ldr(r13,c_reg_save.save_gprs+(0*node_size)(sp))) + __(ldr(r14,c_reg_save.save_gprs+(1*node_size)(sp))) + __(ldr(r15,c_reg_save.save_gprs+(2*node_size)(sp))) + __(ldr(r16,c_reg_save.save_gprs+(3*node_size)(sp))) + __(ldr(r17,c_reg_save.save_gprs+(4*node_size)(sp))) + __(ldr(r18,c_reg_save.save_gprs+(5*node_size)(sp))) + __(ldr(r19,c_reg_save.save_gprs+(6*node_size)(sp))) + __(ldr(r20,c_reg_save.save_gprs+(7*node_size)(sp))) + __(ldr(r21,c_reg_save.save_gprs+(8*node_size)(sp))) + __(ldr(r22,c_reg_save.save_gprs+(9*node_size)(sp))) + __(ldr(r23,c_reg_save.save_gprs+(10*node_size)(sp))) + __(ldr(r24,c_reg_save.save_gprs+(11*node_size)(sp))) + __(ldr(r25,c_reg_save.save_gprs+(12*node_size)(sp))) + __(ldr(r26,c_reg_save.save_gprs+(13*node_size)(sp))) + __(ldr(r27,c_reg_save.save_gprs+(14*node_size)(sp))) + __(ldr(r28,c_reg_save.save_gprs+(15*node_size)(sp))) + __(ldr(r29,c_reg_save.save_gprs+(16*node_size)(sp))) + __(ldr(r30,c_reg_save.save_gprs+(17*node_size)(sp))) + __(ldr(r31,c_reg_save.save_gprs+(18*node_size)(sp))) + __(lfd fp_s32conv,c_reg_save.save_fps32conv(sp)) + __(ldr(sp,0(sp))) + + __(ldr(r3,varargs_eabi_c_frame.gp_save+(0*4)(sp))) + __(ldr(r4,varargs_eabi_c_frame.gp_save+(1*4)(sp))) + __(lfd f1,varargs_eabi_c_frame.gp_save+(2*4)(sp)) + __(ldr(r5,varargs_eabi_c_frame.savelr(sp))) + __(str(r5,varargs_eabi_c_frame.old_savelr(sp))) + __(mtlr r5) + __(ldr(r5,varargs_eabi_c_frame.backlink(sp))) + __(str(r5,varargs_eabi_c_frame.old_backlink(sp))) + __(la sp,varargs_eabi_c_frame.old_backlink(sp)) + __(blr) + + +/* Do a linux system call: the system call index is (boxed) */ +/* in arg_z, and other arguments are in an eabi_c_frame on */ +/* the C stack. As is the case with an eabi_ff_call, there's */ +/* a lisp frame reserved underneath the eabi_c_frame. */ + +/* This is a little simpler than eabi_ff_call, because we */ +/* can assume that there are no synchronous callbacks to */ +/* lisp (that might cause a GC.) It's also simpler for the */ +/* caller, since we return error status atomically. */ + +/* A system call can clobber any or all of r9-r12, so we need */ +/* to save and restore allocptr, allocbase, and tsp. */ + +_spentry(eabi_syscall) +/* We're entered with an eabi_c_frame on the C stack. There's a */ +/* lisp_frame reserved underneath it; we'll link it in in a minute. */ +/* Load the outgoing GPR arguments from eabi_c_frame.param[0-7], */ +/* then shrink the eabi_c_frame. */ + + __(mflr loc_pc) + __(vpush_saveregs()) + __(str(sp,eabi_c_frame.savelr(sp))) + __(li arg_x,nil_value) + __(mr temp0,rcontext) + __(ldr(temp1,c_frame.backlink(sp))) /* bottom of reserved lisp frame */ + __(la temp2,-lisp_frame.size(temp1)) /* top of lisp frame */ + __(zero_doublewords temp2,0,lisp_frame.size) + __(str(temp1,lisp_frame.backlink(temp2))) + __(str(temp2,c_frame.backlink(sp))) + __(str(fn,lisp_frame.savefn(temp2))) + __(str(loc_pc,lisp_frame.savelr(temp2))) + __(str(vsp,lisp_frame.savevsp(temp2))) + __(ldr(temp3,tcr.cs_area(rcontext))) + __(str(temp2,area.active(temp3))) + __(str(allocptr,tcr.save_allocptr(rcontext))) + __(str(allocbase,tcr.save_allocbase(rcontext))) + __(str(tsp,tcr.save_tsp(rcontext))) + __(str(vsp,tcr.save_vsp(rcontext))) + __(str(rzero,tcr.ffi_exception(rcontext))) + __(li imm1,TCR_STATE_FOREIGN) + __(str(imm1,tcr.valence(rcontext))) + __(ldr(r13,lisp_globals.saveR13(0))) + __(ldr(r3,eabi_c_frame.param0(sp))) + __(ldr(r4,eabi_c_frame.param1(sp))) + __(ldr(r5,eabi_c_frame.param2(sp))) + __(ldr(r6,eabi_c_frame.param3(sp))) + __(ldr(r7,eabi_c_frame.param4(sp))) + __(ldr(r8,eabi_c_frame.param5(sp))) + __(ldr(r9,eabi_c_frame.param6(sp))) + __(ldr(r10,eabi_c_frame.param7(sp))) + __(la temp1,eabi_c_frame.minsiz-eabi_c_frame.param0(sp)) + __(str(rzero,eabi_c_frame.savelr(temp1))) + __(str(temp2,eabi_c_frame.backlink(temp1))) + __(mr sp,temp1) + __(unbox_fixnum(r0,arg_z)) + __(sc) + __(nop) + /* C should have preserved temp0 (= rcontext) for us. */ + __(ldr(sp,0(sp))) + __(mr imm2,temp0) + __(ldr(vsp,lisp_frame.savevsp(sp))) + __(li rzero,0) + __(mr loc_pc,rzero) + __(mr fn,rzero) + __(li arg_x,nil_value) + __(li arg_y,nil_value) + __(li arg_z,nil_value) + __(li temp0,nil_value) + __(li temp1,nil_value) + __(li temp2,nil_value) + __(li temp3,nil_value) + __(li fn,nil_value) + + __(li imm3,TCR_STATE_LISP) + __(mr rcontext,imm2) + __(li save0,0) + __(li save1,0) + __(li save2,0) + __(li save3,0) + __(li save4,0) + __(li save5,0) + __(li save6,0) + __(li save7,0) + __(str(imm3,tcr.valence(rcontext))) + __(vpop_saveregs) + __(ldr(allocptr,tcr.save_allocptr(rcontext))) + __(ldr(allocbase,tcr.save_allocbase(rcontext))) + __(ldr(tsp,tcr.save_tsp(rcontext))) + __(ldr(loc_pc,lisp_frame.savelr(sp))) + __(mtlr loc_pc) + __(ldr(fn,lisp_frame.savefn(sp))) + __(discard_lisp_frame()) + __(bns 1f) + __(neg r3,r3) +1: + __(check_pending_interrupt([cr1])) + __(mtxer rzero) + __(blr) + +/* arg_z should be of type (UNSIGNED-BYTE 64); */ +/* On PPC32, return high 32 bits in imm0, low 32 bits in imm1 */ +/* On PPC64, return unboxed value in imm0 */ + +_spentry(getu64) + __ifdef([PPC64]) + __(extract_typecode(imm0,arg_z)) + __(cmpdi cr0,imm0,tag_fixnum) + __(cmpdi cr2,arg_z,0) + __(cmpdi cr1,imm0,subtag_bignum) + __(bne cr0,1f) + __(unbox_fixnum(imm0,arg_z)) + __(bgelr cr2) +0: + __(uuo_interr(error_object_not_u64,arg_z)) + +1: __(bne cr1,0b) + __(getvheader(imm1,arg_z)) + __(ld imm0,misc_data_offset(arg_z)) + __(cmpdi cr2,imm1,two_digit_bignum_header) + __(rotldi imm0,imm0,32) + __(cmpdi cr1,imm1,three_digit_bignum_header) + __(cmpdi cr0,imm0,0) + __(beq cr2,2f) + __(lwz imm1,misc_data_offset+8(arg_z)) + __(bne cr1,0b) + __(cmpwi imm1,0) + __(bne 0b) + __(blr) +2: __(blt 0b) + __(blr) + __else + __(extract_typecode(imm0,arg_z)) + __(cmpri(cr0,imm0,tag_fixnum)) + __(cmpri(cr1,arg_z,0)) + __(cmpri(cr2,imm0,subtag_bignum)) + __(unbox_fixnum(imm1,arg_z)) + __(bne cr0,8f) + __(bgelr cr1) +9: + __(uuo_interr(error_object_not_u64,arg_z)) +8: + __(bne- cr2,9b) + __(getvheader(imm2,arg_z)) + __(cmpri(cr2,imm2,two_digit_bignum_header)) + __(vrefr(imm1,arg_z,0)) + __(cmpri(cr1,imm1,0)) + __(li imm0,0) + __(bge cr2,2f) + __(blt- cr1,9b) + __(blr) +2: + __(cmpri(cr0,imm2,three_digit_bignum_header)) + __(vrefr(imm0,arg_z,1)) + __(cmpri(cr1,imm0,0)) + __(bne cr2,3f) + __(blt- cr1,9b) + __(blr) +3: + __(vrefr(imm2,arg_z,2)) + __(cmpri(cr1,imm2,0)) + __(bne- cr0,9b) + __(bne- cr1,9b) + __(blr) + __endif + +/* arg_z should be of type (SIGNED-BYTE 64); */ +/* PPC32: return high 32 bits in imm0, low 32 bits in imm1 */ +/* PPC64: return unboxed value in imm0 */ + +_spentry(gets64) + __ifdef([PPC64]) + __(extract_typecode(imm1,arg_z)) + __(unbox_fixnum(imm0,arg_z)) + __(cmpri(cr0,imm1,tag_fixnum)) + __(cmpri(cr2,imm1,subtag_bignum)) + __(beqlr cr0) + __(bne cr2,9f) + __(ld imm1,misc_header_offset(arg_z)) + __(ld imm0,misc_data_offset(arg_z)) + __(cmpdi imm1,two_digit_bignum_header) + __(rotldi imm0,imm0,32) + __(beqlr) + __else + __(extract_typecode(imm0,arg_z)) + __(cmpri(cr0,imm0,tag_fixnum)) + __(cmpri(cr2,imm0,subtag_bignum)) + __(unbox_fixnum(imm1,arg_z)) + __(srawi imm0,imm1,31) + __(beqlr cr0) + __(bne cr2,9f) + __(getvheader(imm2,arg_z)) + __(cmpri(cr2,imm2,two_digit_bignum_header)) + __(vrefr(imm1,arg_z,0)) + __(srawi imm0,imm1,31) + __(bltlr cr2) + __(vrefr(imm0,arg_z,1)) + __(beqlr cr2) + __endif +9: + __(uuo_interr(error_object_not_s64,arg_z)) + + +/* Construct a lisp integer out of the 64-bit unsigned value in */ +/* ppc32: imm0 (high 32 bits) and imm1 (low 32 bits) */ +/* ppc64: imm0 (64 bits) . */ +_spentry(makeu64) + __ifdef([PPC64]) + __(clrrdi. imm1,imm0,63-nfixnumtagbits) + __(cmpri(cr1,imm0,0)) + __(box_fixnum(arg_z,imm0)) + __(beqlr cr0) /* A fixnum */ + __(rotldi imm1,imm0,32) + __(li imm2,two_digit_bignum_header) + __(blt cr1,2f) + __(Misc_Alloc_Fixed(arg_z,imm2,aligned_bignum_size(2))) + __(str(imm1,misc_data_offset(arg_z))) + __(blr) +2: + __(li imm2,three_digit_bignum_header) + __(Misc_Alloc_Fixed(arg_z,imm2,aligned_bignum_size(3))) + __(str(imm1,misc_data_offset(arg_z))) + __(blr) + __else + __(cmpri(cr1,imm0,0)) + __(rlwinm. imm2,imm1,0,0,fixnum_shift) + __(li imm2,three_digit_bignum_header) + __(box_fixnum(arg_z,imm1)) + __(blt cr1,3f) + __(bne cr1,2f) + __(beqlr cr0) /* A fixnum */ + __(blt cr0,2f) + __(li imm2,one_digit_bignum_header) + __(Misc_Alloc_Fixed(arg_z,imm2,aligned_bignum_size(1))) + __(str(imm1,misc_data_offset(arg_z))) + __(blr) +2: + __(li imm2,two_digit_bignum_header) + __(Misc_Alloc_Fixed(arg_z,imm2,aligned_bignum_size(2))) + __(str(imm1,misc_data_offset(arg_z))) + __(str(imm0,misc_data_offset+4(arg_z))) + __(blr) +3: + __(Misc_Alloc_Fixed(arg_z,imm2,aligned_bignum_size(3))) + __(str(imm1,misc_data_offset(arg_z))) + __(str(imm0,misc_data_offset+4(arg_z))) + __(blr) + __endif + + + +/* Construct a lisp integer out of the 64-bit signed value in */ +/* ppc32: imm0 (high 32 bits) and imm1 (low 32 bits). */ +/* ppc64: imm0 */ +_spentry(makes64) + __ifdef([PPC64]) + __(addo imm1,imm0,imm0) + __(addo imm1,imm1,imm1) + __(addo. arg_z,imm1,imm1) + __(bnslr+) + __(mtxer rzero) + __(li imm1,two_digit_bignum_header) + __(rotldi imm0,imm0,32) + __(Misc_Alloc_Fixed(arg_z,imm1,aligned_bignum_size(2))) + __(str(imm0,misc_data_offset(arg_z))) + __(blr) + __else + __(srawi imm2,imm1,31) + __(cmpr(cr1,imm2,imm0)) + __(addo imm2,imm1,imm1) + __(addo. arg_z,imm2,imm2) + __(bne cr1,2f) /* High word is significant */ + __(li imm2,one_digit_bignum_header) + __(bnslr cr0) /* No overflow: fixnum */ + __(mtxer rzero) + __(Misc_Alloc_Fixed(arg_z,imm2,aligned_bignum_size(1))) + __(str(imm1,misc_data_offset(arg_z))) + __(blr) +2: + __(mtxer rzero) + __(li imm2,two_digit_bignum_header) + __(Misc_Alloc_Fixed(arg_z,imm2,aligned_bignum_size(2))) + __(str(imm1,misc_data_offset(arg_z))) + __(str(imm0,misc_data_offset+4(arg_z))) + __(blr) + __endif + +/* imm0:imm1 constitute an unsigned integer, almost certainly a bignum. */ +/* Make a lisp integer out of those 128 bits .. */ +_spentry(makeu128) + __ifdef([PPC64]) + __(cmpdi imm0,0) + __(cmpdi cr1,imm1,0) + __(srdi imm3,imm0,32) + __(srawi imm4,imm0,31) + __(cmpdi cr3,imm3,0) + __(cmpdi cr4,imm4,0) + __(li imm2,five_digit_bignum_header) + __(blt cr1,0f) + __(beq 3f) +0: + __(bge 1f) + /* All 128 bits are significant, and the most significant */ + /* bit is set. Allocate a 5-digit bignum (with a zero */ + /* sign digit */ + __(Misc_Alloc_Fixed(arg_z,imm2,aligned_bignum_size(5))) + __(rotldi imm0,imm0,32) + __(rotldi imm1,imm1,32) + __(std imm1,misc_data_offset(arg_z)) + __(std imm0,misc_data_offset+8(arg_z)) + __(blr) +1: /* If the high word of imm0 is a zero-extension of the low */ + /* word, we only need 3 digits ; otherwise, we need 4. */ + __(li imm2,three_digit_bignum_header) + __(rotldi imm1,imm1,32) + __(bne cr3,2f) /* high word of imm0 is non-zero */ + __(bne cr4,2f) /* sign bit is on in low word of imm0 */ + __(Misc_Alloc_Fixed(arg_z,imm2,aligned_bignum_size(3))) + __(std imm1,misc_data_offset(arg_z)) + __(stw imm0,misc_data_offset+8(arg_z)) + __(blr) +2: __(li imm2,four_digit_bignum_header) + __(rotldi imm0,imm0,32) + __(Misc_Alloc_Fixed(arg_z,imm2,aligned_bignum_size(4))) + __(std imm1,misc_data_offset(arg_z)) + __(std imm0,misc_data_offset+8(arg_z)) + __(blr) +3: __(mr imm0,imm1) + __(b _SPmakeu64) + __else + __(twgei r0,r0) + __endif + +/* imm0:imm1 constitute a signed integer, almost certainly a bignum. */ +/* Make a lisp integer out of those 128 bits .. */ +_spentry(makes128) + __ifdef([PPC64]) + /* Is imm0 just a sign-extension of imm1 ? */ + __(sradi imm2,imm1,63) + /* Is the high word of imm0 just a sign-extension of the low word ? */ + __(extsw imm3,imm0) + __(cmpd imm2,imm0) + __(cmpd cr1,imm3,imm0) + __(beq 2f) + __(rotldi imm0,imm0,32) + __(rotldi imm1,imm1,32) + __(beq cr1,1f) + __(li imm2,four_digit_bignum_header) + __(Misc_Alloc_Fixed(arg_z,imm2,aligned_bignum_size(4))) + __(std imm1,misc_data_offset(arg_z)) + __(std imm0,misc_data_offset+8(arg_z)) + __(blr) +1: __(li imm2,three_digit_bignum_header) + __(Misc_Alloc_Fixed(arg_z,imm2,aligned_bignum_size(3))) + __(std imm1,misc_data_offset(arg_z)) + __(stw imm3,misc_data_offset+8(arg_z)) + __(blr) +2: __(mr imm0,imm1) + __(b _SPmakes64) + __else + __(twgei r0,r0) + __endif + +/* on entry: arg_z = symbol. On exit, arg_z = value (possibly */ +/* unbound_marker), arg_y = symbol, imm3 = symbol.binding-index */ +_spentry(specref) + __(ldr(imm3,symbol.binding_index(arg_z))) + __(ldr(imm0,tcr.tlb_limit(rcontext))) + __(cmpr(imm3,imm0)) + __(ldr(imm2,tcr.tlb_pointer(rcontext))) + __(mr arg_y,arg_z) + __(bge 1f) + __(ldrx(arg_z,imm2,imm3)) + __(cmpri(arg_z,no_thread_local_binding_marker)) + __(bnelr) +1: __(ldr(arg_z,symbol.vcell(arg_y))) + __(blr) + + +_spentry(specrefcheck) + __(ldr(imm3,symbol.binding_index(arg_z))) + __(ldr(imm0,tcr.tlb_limit(rcontext))) + __(cmpr(imm3,imm0)) + __(ldr(imm2,tcr.tlb_pointer(rcontext))) + __(mr arg_y,arg_z) + __(bge 1f) + __(ldrx(arg_z,imm2,imm3)) + __(cmpri(arg_z,no_thread_local_binding_marker)) + __(bne 2f) +1: __(ldr(arg_z,symbol.vcell(arg_y))) +2: __(treqi(arg_z,unbound_marker)) + __(blr) + +/* arg_y = special symbol, arg_z = new value. */ +_spentry(specset) + __(ldr(imm3,symbol.binding_index(arg_y))) + __(ldr(imm0,tcr.tlb_limit(rcontext))) + __(ldr(imm2,tcr.tlb_pointer(rcontext))) + __(cmpr(imm3,imm0)) + __(bge 1f) + __(ldrx(temp1,imm2,imm3)) + __(cmpri(temp1,no_thread_local_binding_marker)) + __(beq 1f) + __(strx(arg_z,imm2,imm3)) + __(blr) +1: __(mr arg_x,arg_y) + __(li arg_y,symbol.vcell-misc_data_offset) + __(b _SPgvset) + +/* Restore current thread's interrupt level to arg_z, */ +/* noting whether the tcr's interrupt_pending flag was set. */ +_spentry(restoreintlevel) + __(cmpri(cr1,arg_z,0)) + __(ldr(imm0,tcr.interrupt_pending(rcontext))) + __(cmpri(cr0,imm0,0)) + __(bne cr1,1f) + __(beq cr0,1f) + __(str(rzero,tcr.interrupt_pending(rcontext))) + __(li nargs,fixnum_one) + __(trgti(nargs,0)) + __(blr) +1: + __(ldr(nargs,tcr.tlb_pointer(rcontext))) + __(str(arg_z,INTERRUPT_LEVEL_BINDING_INDEX(nargs))) + __(blr) + + +/* Construct a lisp integer out of the 32-bit signed value in imm0 */ + + +_spentry(makes32) + __ifdef([PPC64]) + __(box_fixnum(arg_z,imm0)) + __else + __(addo imm1,imm0,imm0) + __(addo. arg_z,imm1,imm1) + __(bnslr+) + __(mtxer rzero) + __(li imm1,one_digit_bignum_header) + __(Misc_Alloc_Fixed(arg_z,imm1,aligned_bignum_size(1))) + __(str(imm0,misc_data_offset(arg_z))) + __endif + __(blr) + + +/* Construct a lisp integer out of the 32-bit unsigned value in imm0 */ + + +_spentry(makeu32) + __ifdef([PPC64]) + __(box_fixnum(arg_z,imm0)) + __(blr) + __else + __(clrrwi. imm1,imm0,31-nfixnumtagbits) + __(cmpri(cr1,imm0,0)) + __(box_fixnum(arg_z,imm0)) + __(beqlr cr0) /* A fixnum */ + __(blt cr1,2f) + __(li imm2,one_digit_bignum_header) + __(Misc_Alloc_Fixed(arg_z,imm2,aligned_bignum_size(1))) + __(str(imm0,misc_data_offset(arg_z))) + __(blr) +2: + __(li imm2,two_digit_bignum_header) + __(Misc_Alloc_Fixed(arg_z,imm2,aligned_bignum_size(2))) + __(str(imm0,misc_data_offset(arg_z))) + __(blr) + __endif + +/* */ +/* arg_z should be of type (SIGNED-BYTE 32); return unboxed result in imm0 */ +/* */ +_spentry(gets32) + __ifdef([PPC64]) + __(sldi imm1,arg_z,32-fixnumshift) + __(extract_lisptag_(imm0,arg_z)) + __(sradi imm1,imm1,32-fixnumshift) + __(box_fixnum(imm0,arg_z)) + __(cmpd cr1,imm1,arg_z) + __(bne cr0,9f) + __(beqlr cr1) + __(b 9f) + __else + __(extract_typecode(imm1,arg_z)) + __(cmpri(cr0,imm1,tag_fixnum)) + __(cmpri(cr2,imm1,subtag_bignum)) + __(unbox_fixnum(imm0,arg_z)) + __(beqlr+ cr0) + __(bne cr2,9f) + __(getvheader(imm1,arg_z)) + __(cmpri(cr1,imm1,one_digit_bignum_header)) + __(vrefr(imm0,arg_z,0)) + __(beqlr+ cr1) + __endif +9: + __(uuo_interr(error_object_not_signed_byte_32,arg_z)) + +/* */ +/* arg_z should be of type (UNSIGNED-BYTE 32); return unboxed result in imm0 */ +/* */ + +_spentry(getu32) + __(extract_typecode(imm1,arg_z)) + __(cmpri(cr0,imm1,tag_fixnum)) + __(cmpri(cr1,arg_z,0)) + __(cmpri(cr2,imm1,subtag_bignum)) + __(unbox_fixnum(imm0,arg_z)) + __(bne cr0,8f) + __(bgelr cr1) +8: + __(bne- cr2,9f) + __(getvheader(imm2,arg_z)) + __(cmpri(cr2,imm2,two_digit_bignum_header)) + __(vrefr(imm0,arg_z,0)) + __(cmpri(cr0,imm0,0)) + __(bgt cr2,9f) + __(beq cr2,2f) + __(blt cr0,9f) + __(blr) +2: + __(vrefr(imm1,arg_z,1)) + __(cmpri(cr0,imm1,0)) + __(beqlr+ cr0) + +9: + __(uuo_interr(error_object_not_unsigned_byte_32,arg_z)) + +/* */ +/* arg_z has overflowed (by one bit) as the result of an addition or subtraction. */ +/* Make a bignum out of it. */ + +_spentry(fix_overflow) + __(mtxer rzero) + __(unbox_fixnum(imm1,arg_z)) + __ifdef([PPC64]) + __(li imm0,two_digit_bignum_header) + __(rotldi imm1,imm1,32) + __(xoris imm1,imm1,0xe000) + __(Misc_Alloc_Fixed(arg_z,imm0,aligned_bignum_size(2))) + __(str(imm1,misc_data_offset(arg_z))) + __else + __(li imm0,one_digit_bignum_header) + __(xoris imm1,imm1,0xc000) + __(Misc_Alloc_Fixed(arg_z,imm0,aligned_bignum_size(1))) + __(str(imm1,misc_data_offset(arg_z))) + __endif + __(blr) + + + +/* */ +/* As per mvpass above, but in this case fname is known to be a */ +/* symbol. */ + +_spentry(mvpasssym) + __(cmpri(cr0,nargs,node_size*nargregs)) + __(mflr loc_pc) + __(mr imm0,vsp) + __(ble+ cr0,1f) + __(subi imm0,imm0,node_size*nargregs) + __(add imm0,imm0,nargs) +1: + __(build_lisp_frame(fn,loc_pc,imm0)) + __(ref_global(loc_pc,ret1val_addr)) + __(li fn,0) + __(mtlr loc_pc) + __(jump_fname()) + + + +_spentry(unbind) + __(ldr(imm1,tcr.db_link(rcontext))) + __(ldr(imm2,tcr.tlb_pointer(rcontext))) + __(ldr(imm3,binding.sym(imm1))) + __(ldr(temp1,binding.val(imm1))) + __(ldr(imm1,binding.link(imm1))) + __(strx(temp1,imm2,imm3)) + __(str(imm1,tcr.db_link(rcontext))) + __(blr) + +_spentry(unbind_n) + __(ldr(imm1,tcr.db_link(rcontext))) + __(ldr(imm2,tcr.tlb_pointer(rcontext))) +1: __(subi imm0,imm0,1) + __(ldr(imm3,binding.sym(imm1))) + __(ldr(temp1,binding.val(imm1))) + __(cmpri(imm0,0)) + __(ldr(imm1,binding.link(imm1))) + __(strx(temp1,imm2,imm3)) + __(bne 1b) + __(str(imm1,tcr.db_link(rcontext))) + __(blr) + +/* */ +/* Clobbers imm1,imm2,imm5,arg_x, arg_y */ + +_spentry(unbind_to) + __(ldr(imm1,tcr.db_link(rcontext))) + __(ldr(imm2,tcr.tlb_pointer(rcontext))) +1: __(ldr(imm5,binding.sym(imm1))) + __(ldr(arg_y,binding.val(imm1))) + __(ldr(imm1,binding.link(imm1))) + __(cmpr(imm0,imm1)) + __(strx(arg_y,imm2,imm5)) + __(bne 1b) + __(str(imm1,tcr.db_link(rcontext))) + __(blr) + + + +/* */ +/* Restore the special bindings from the top of the tstack, */ +/* leaving the tstack frame allocated. */ +/* Note that there might be 0 saved bindings, in which case */ +/* do nothing. */ +/* Note also that this is -only- called from an unwind-protect */ +/* cleanup form, and that .SPnthrowXXX is keeping one or more */ +/* values in a frame on top of the tstack. */ +/* */ + +_spentry(progvrestore) + __(ldr(imm0,tsp_frame.backlink(tsp))) /* ignore .SPnthrowXXX values frame */ + __(ldr(imm0,tsp_frame.data_offset(imm0))) + __(cmpri(cr0,imm0,0)) + __(unbox_fixnum(imm0,imm0)) + __(bne+ cr0,_SPunbind_n) + __(blr) + +/* Bind CCL::*INTERRUPT-LEVEL* to 0. If its value had been negative, check */ +/* for pending interrupts after doing so. "nargs" can be freely used for an */ +/* interrupt trap in this context. */ +_spentry(bind_interrupt_level_0) + __(ldr(imm4,tcr.tlb_pointer(rcontext))) + __(ldr(temp0,INTERRUPT_LEVEL_BINDING_INDEX(imm4))) + __(ldr(imm1,tcr.db_link(rcontext))) + __(cmpri(temp0,0)) + __(li imm3,INTERRUPT_LEVEL_BINDING_INDEX) + __(vpush(temp0)) + __(vpush(imm3)) + __(vpush(imm1)) + __(str(rzero,INTERRUPT_LEVEL_BINDING_INDEX(imm4))) + __(str(vsp,tcr.db_link(rcontext))) + __(beqlr) + __(mr nargs,temp0) + __(bgt 1f) + __(ldr(nargs,tcr.interrupt_pending(rcontext))) +1: __(trgti(nargs,0)) + __(blr) + +/* Bind CCL::*INTERRUPT-LEVEL* to the fixnum -1. (This has the effect */ +/* of disabling interrupts.) */ +_spentry(bind_interrupt_level_m1) + __(li imm2,-fixnumone) + __(li imm3,INTERRUPT_LEVEL_BINDING_INDEX) + __(ldr(imm4,tcr.tlb_pointer(rcontext))) + __(ldr(temp0,INTERRUPT_LEVEL_BINDING_INDEX(imm4))) + __(ldr(imm1,tcr.db_link(rcontext))) + __(vpush(temp0)) + __(vpush(imm3)) + __(vpush(imm1)) + __(str(imm2,INTERRUPT_LEVEL_BINDING_INDEX(imm4))) + __(str(vsp,tcr.db_link(rcontext))) + __(blr) + + +/* Bind CCL::*INTERRUPT-LEVEL* to the value in arg_z. If that value's 0, */ +/* do what _SPbind_interrupt_level_0 does */ +_spentry(bind_interrupt_level) + __(cmpri(arg_z,0)) + __(li imm3,INTERRUPT_LEVEL_BINDING_INDEX) + __(ldr(imm4,tcr.tlb_pointer(rcontext))) + __(ldr(temp0,INTERRUPT_LEVEL_BINDING_INDEX(imm4))) + __(ldr(imm1,tcr.db_link(rcontext))) + __(beq _SPbind_interrupt_level_0) + __(vpush(temp0)) + __(vpush(imm3)) + __(vpush(imm1)) + __(str(arg_z,INTERRUPT_LEVEL_BINDING_INDEX(imm4))) + __(str(vsp,tcr.db_link(rcontext))) + __(blr) + +/* Unbind CCL::*INTERRUPT-LEVEL*. If the value changes from negative to */ +/* non-negative, check for pending interrupts. This is often called in */ +/* a context where nargs is significant, so save and restore nargs around */ +/* any interrupt polling */ + +_spentry(unbind_interrupt_level) + __(ldr(imm0,tcr.flags(rcontext))) + __(ldr(imm2,tcr.tlb_pointer(rcontext))) + __(andi. imm0,imm0,1< | 11 | */ +/* +--------+-----------------------------+--------------+------+ */ +/* */ +/* e.g., the major opcode (bits 0-5) is 0, the low 4 bits (bits 28-31) */ +/* have the value "11" decimal (that's tagged as an immediate as far */ +/* as lisp is concerned, a 7-bit opcode in bits 21-27, and the format */ +/* of bits 6-20 depend on the value of the minor opcode, though typically */ +/* bits 16-20 are used to specify a register value between 0 and 31. */ +/* */ +/* There are a few cases where bits 6-15 are also used to denote registers */ +/* (RT and RA, as in an X-form PPC instruction), some where bits 6-10 are */ +/* to be interpreted as a constant (error number or type code), and some */ +/* where bits 6-15 do so. */ +/* */ +/* Since C code is typically more interested in disassembling UUOs, the */ +/* full list of UUOs is in "uuo.h". This file contains macros for creating */ +/* them. */ +/* */ +/* Of course, there -is- no such file as "uuo.h". That's a stale comment. */ +/* For all anyone knows, so is this one. */ + +UUO_TAG = 11 +UUU_MINOR_SHIFT = 4 +UUO_RB_SHIFT = 11 +UUO_RA_SHIFT = 16 +UUO_RT_SHIFT = 21 + +define([rt_ra_uuo],[ + .long (UUO_TAG|(($1)< +#include +#include + +#include "lisp.h" +#include "area.h" +#include "lisp-exceptions.h" +#include "lisp_globals.h" + +void +sprint_lisp_object(LispObj, int); + +#define PBUFLEN 252 + +char printbuf[PBUFLEN + 4]; +int bufpos = 0; + +jmp_buf escape; + +void +add_char(char c) +{ + if (bufpos >= PBUFLEN) { + longjmp(escape, 1); + } else { + printbuf[bufpos++] = c; + } +} + +void +add_string(char *s, int len) +{ + while(len--) { + add_char(*s++); + } +} + +void +add_lisp_base_string(LispObj str) +{ + lisp_char_code *src = (lisp_char_code *) (ptr_from_lispobj(str + misc_data_offset)); + natural i, n = header_element_count(header_of(str)); + + for (i=0; i < n; i++) { + add_char((char)(*src++)); + } +} + +void +add_c_string(char *s) +{ + add_string(s, strlen(s)); +} + +char numbuf[64]; + +void +sprint_signed_decimal(signed_natural n) +{ + sprintf(numbuf, "%ld", n); + add_c_string(numbuf); +} + +void +sprint_unsigned_decimal(natural n) +{ + sprintf(numbuf, "%lu", n); + add_c_string(numbuf); +} + +void +sprint_unsigned_hex(natural n) +{ +#ifdef PPC64 + sprintf(numbuf, "#x%016lx", n); +#else + sprintf(numbuf, "#x%08lx", n); +#endif + add_c_string(numbuf); +} + +void +sprint_list(LispObj o, int depth) +{ + LispObj the_cdr; + + add_char('('); + while(1) { + if (o != lisp_nil) { + sprint_lisp_object(ptr_to_lispobj(car(o)), depth); + the_cdr = ptr_to_lispobj(cdr(o)); + if (the_cdr != lisp_nil) { + add_char(' '); + if (fulltag_of(the_cdr) == fulltag_cons) { + o = the_cdr; + continue; + } + add_c_string(". "); + sprint_lisp_object(the_cdr, depth); + break; + } + } + break; + } + add_char(')'); +} + +/* + Print a list of method specializers, using the class name instead of the class object. +*/ + +void +sprint_specializers_list(LispObj o, int depth) +{ + LispObj the_cdr, the_car; + + add_char('('); + while(1) { + if (o != lisp_nil) { + the_car = car(o); + if (fulltag_of(the_car) == fulltag_misc) { + sprint_lisp_object(deref(deref(the_car,3), 4), depth); + } else { + sprint_lisp_object(the_car, depth); + } + the_cdr = cdr(o); + if (the_cdr != lisp_nil) { + add_char(' '); + if (fulltag_of(the_cdr) == fulltag_cons) { + o = the_cdr; + continue; + } + add_c_string(". "); + sprint_lisp_object(the_cdr, depth); + break; + } + } + break; + } + add_char(')'); +} + +char * +vector_subtag_name(unsigned subtag) +{ + switch (subtag) { + case subtag_bit_vector: + return "BIT-VECTOR"; + break; + case subtag_instance: + return "INSTANCE"; + break; + case subtag_bignum: + return "BIGNUM"; + break; + case subtag_u8_vector: + return "(UNSIGNED-BYTE 8)"; + break; + case subtag_s8_vector: + return "(SIGNED-BYTE 8)"; + break; + case subtag_u16_vector: + return "(UNSIGNED-BYTE 16)"; + break; + case subtag_s16_vector: + return "(SIGNED-BYTE 16)"; + break; + case subtag_u32_vector: + return "(UNSIGNED-BYTE 32)"; + break; + case subtag_s32_vector: + return "(SIGNED-BYTE 32)"; + break; +#ifdef PPC64 + case subtag_u64_vector: + return "(UNSIGNED-BYTE 64)"; + break; + case subtag_s64_vector: + return "(SIGNED-BYTE 64)"; + break; +#endif + case subtag_package: + return "PACKAGE"; + break; + case subtag_code_vector: + return "CODE-VECTOR"; + break; + case subtag_slot_vector: + return "SLOT-VECTOR"; + break; + default: + return ""; + break; + } +} + + +void +sprint_random_vector(LispObj o, unsigned subtag, natural elements) +{ + add_c_string("#<"); + sprint_unsigned_decimal(elements); + add_c_string("-element vector subtag = "); + sprintf(numbuf, "%02X @", subtag); + add_c_string(numbuf); + sprint_unsigned_hex(o); + add_c_string(" ("); + add_c_string(vector_subtag_name(subtag)); + add_c_string(")>"); +} + +void +sprint_symbol(LispObj o) +{ + lispsymbol *rawsym = (lispsymbol *) ptr_from_lispobj(untag(o)); + LispObj + pname = rawsym->pname, + package = rawsym->package_predicate; + +#ifdef PPC64 + if (o == lisp_nil) { + add_c_string("()"); + return; + } +#endif + if (fulltag_of(package) == fulltag_cons) { + package = car(package); + } + + if (package == nrs_KEYWORD_PACKAGE.vcell) { + add_char(':'); + } + add_lisp_base_string(pname); +} + +void +sprint_function(LispObj o, int depth) +{ + LispObj lfbits, header, name = lisp_nil; + natural elements; + + header = header_of(o); + elements = header_element_count(header); + lfbits = deref(o, elements); + + if ((lfbits & lfbits_noname_mask) == 0) { + name = deref(o, elements-1); + } + + add_c_string("#<"); + if (name == lisp_nil) { + add_c_string("Anonymous Function "); + } else { + if (lfbits & lfbits_method_mask) { + LispObj + slot_vector = deref(name,3), + method_name = deref(slot_vector, 6), + method_qualifiers = deref(slot_vector, 2), + method_specializers = deref(slot_vector, 3); + add_c_string("Method-Function "); + sprint_lisp_object(method_name, depth); + add_char(' '); + if (method_qualifiers != lisp_nil) { + if (cdr(method_qualifiers) == lisp_nil) { + sprint_lisp_object(car(method_qualifiers), depth); + } else { + sprint_lisp_object(method_qualifiers, depth); + } + add_char(' '); + } + sprint_specializers_list(method_specializers, depth); + add_char(' '); + } else { + add_c_string("Function "); + sprint_lisp_object(name, depth); + add_char(' '); + } + } + sprint_unsigned_hex(o); + add_char('>'); +} + +void +sprint_gvector(LispObj o, int depth) +{ + LispObj header = header_of(o); + unsigned + elements = header_element_count(header), + subtag = header_subtag(header); + + switch(subtag) { + case subtag_function: + sprint_function(o, depth); + break; + + case subtag_symbol: + sprint_symbol(o); + break; + + case subtag_struct: + case subtag_istruct: + add_c_string("#<"); + sprint_lisp_object(deref(o,1), depth); + add_c_string(" @"); + sprint_unsigned_hex(o); + add_c_string(">"); + break; + + case subtag_simple_vector: + { + int i; + add_c_string("#("); + for(i = 1; i <= elements; i++) { + if (i > 1) { + add_char(' '); + } + sprint_lisp_object(deref(o, i), depth); + } + add_char(')'); + break; + } + + default: + sprint_random_vector(o, subtag, elements); + break; + } +} + +void +sprint_ivector(LispObj o) +{ + LispObj header = header_of(o); + unsigned + elements = header_element_count(header), + subtag = header_subtag(header); + + switch(subtag) { + case subtag_simple_base_string: + add_char('"'); + add_lisp_base_string(o); + add_char('"'); + return; + + case subtag_bignum: + if (elements == 1) { + sprint_signed_decimal((signed_natural)(deref(o, 1))); + return; + } + if ((elements == 2) && (deref(o, 2) == 0)) { + sprint_unsigned_decimal(deref(o, 1)); + return; + } + break; + + case subtag_double_float: + break; + + case subtag_macptr: + add_c_string("#"); + break; + + default: + sprint_random_vector(o, subtag, elements); + } +} + +void +sprint_vector(LispObj o, int depth) +{ + LispObj header = header_of(o); + + if (immheader_tag_p(fulltag_of(header))) { + sprint_ivector(o); + } else { + sprint_gvector(o, depth); + } +} + +void +sprint_lisp_object(LispObj o, int depth) +{ + if (--depth < 0) { + add_char('#'); + } else { + switch (fulltag_of(o)) { + case fulltag_even_fixnum: + case fulltag_odd_fixnum: + sprint_signed_decimal(unbox_fixnum(o)); + break; + +#ifdef PPC64 + case fulltag_immheader_0: + case fulltag_immheader_1: + case fulltag_immheader_2: + case fulltag_immheader_3: + case fulltag_nodeheader_0: + case fulltag_nodeheader_1: + case fulltag_nodeheader_2: + case fulltag_nodeheader_3: +#else + case fulltag_immheader: + case fulltag_nodeheader: +#endif + add_c_string("#
"); + break; + +#ifdef PPC64 + case fulltag_imm_0: + case fulltag_imm_1: + case fulltag_imm_2: + case fulltag_imm_3: +#else + case fulltag_imm: +#endif + if (o == unbound) { + add_c_string("#"); + } else { + if (header_subtag(o) == subtag_character) { + unsigned c = (o >> charcode_shift); + add_c_string("#\\"); + if ((c >= ' ') && (c < 0x7f)) { + add_char(c); + } else { + sprintf(numbuf, "%o", c); + add_c_string(numbuf); + } +#ifdef PPC64 + } else if (header_subtag(o) == subtag_single_float) { + sprintf(numbuf, "%f", o>>32); + add_c_string(numbuf); +#endif + } else { + + add_c_string("#"); + } + } + break; + +#ifndef PPC64 + case fulltag_nil: +#endif + case fulltag_cons: + sprint_list(o, depth); + break; + + case fulltag_misc: + sprint_vector(o, depth); + break; + } + } +} + +char * +print_lisp_object(LispObj o) +{ + bufpos = 0; + if (setjmp(escape) == 0) { + sprint_lisp_object(o, 5); + printbuf[bufpos] = 0; + } else { + printbuf[PBUFLEN+0] = '.'; + printbuf[PBUFLEN+1] = '.'; + printbuf[PBUFLEN+2] = '.'; + printbuf[PBUFLEN+3] = 0; + } + return printbuf; +} Index: /branches/new-random/lisp-kernel/solarisx64/.gdbinit =================================================================== --- /branches/new-random/lisp-kernel/solarisx64/.gdbinit (revision 13309) +++ /branches/new-random/lisp-kernel/solarisx64/.gdbinit (revision 13309) @@ -0,0 +1,82 @@ +define x86_lisp_string +x/s $arg0-5 +end + +define gtra +br *$r10 +cont +end + +define x86pname +set $temp=*((long *)((long)($arg0-6))) +x86_lisp_string $temp +end + + +define pname + x86pname $arg0 +end + +define l + call print_lisp_object($arg0) +end + +define lw + l $r13 +end + +define clobber_breakpoint + set *(short *)($pc-2)=0x9090 +end + +define arg_z + l $rsi +end + +define arg_y + l $rdi +end + +define arg_x + l $r8 +end + +define bx + l $rbx +end + +define showlist + set $l=$arg0 + while $l != 0x200b + set $car = *((LispObj *)($l+5)) + set $l = *((LispObj *)($l-3)) + l $car + end +end + +define lbt + call plbt_sp($rbp) +end + +define ada + p/x *(all_areas->succ) +end + +define lregs + call debug_lisp_registers($arg0,0,0) +end + +break Bug + +display/i $pc + +handle SIGKILL pass nostop noprint +handle SIGILL pass nostop noprint +handle SIGSEGV pass nostop noprint +handle SIGBUS pass nostop noprint +handle SIGFPE pass nostop noprint +handle SIGUSR1 pass nostop noprint +handle SIGUSR2 pass nostop noprint +handle SIGPWR pass nostop noprint +handle SIGQUIT pass nostop noprint + Index: /branches/new-random/lisp-kernel/solarisx64/Makefile =================================================================== --- /branches/new-random/lisp-kernel/solarisx64/Makefile (revision 13309) +++ /branches/new-random/lisp-kernel/solarisx64/Makefile (revision 13309) @@ -0,0 +1,85 @@ +# +# Copyright (C) 2006 Clozure Associates and contributors +# This file is part of Clozure CL. +# +# Clozure CL is licensed under the terms of the Lisp Lesser GNU Public +# License , known as the LLGPL and distributed with Clozure CL as the +# file "LICENSE". The LLGPL consists of a preamble and the LGPL, +# which is distributed with Clozure CL as the file "LGPL". Where these +# conflict, the preamble takes precedence. +# +# Clozure CL is referenced in the preamble as the "LIBRARY." +# +# The LLGPL is also available online at +# http://opensource.franz.com/preamble.html + + +VPATH = .. +RM = /bin/rm +AS = /usr/sfw/bin/gas +# As of this writing, /usr/sfw/bin/gm4 is both more recent (1.4.2 vs 1.4) +# and more buggy than /opt/sfw/bin/gm4, which is available on the +# "Solaris companion" disk. Do you get the impression that the people +# who put this stuff together aren't paying much attention ? +# Marching forward: as of the OpenSolais 0805 (snv_86) release, there +# doesn't seem to be any way of obtaining a non-broken GNU m4 from Sun. +# I just downloaded the source to 1.4.11 and installed it in /usr/local/bin; +# I didn't try blastwave.org or sunfreeware.com; there might be working +# packages there +M4 = /usr/local/bin/m4 +CC = /usr/sfw/bin/gcc +ASFLAGS = --64 --divide +M4FLAGS = -DSOLARIS -DX86 -DX8664 +CDEFINES = -DSOLARIS -D_REENTRANT -DX86 -DX8664 -D__EXTENSIONS__ -DHAVE_TLS #-DDISABLE_EGC +CDEBUG = -g +COPT = #-O2 + + + +.s.o: + $(M4) $(M4FLAGS) -I../ $< | $(AS) $(ASFLAGS) -o $@ +.c.o: + $(CC) -c $< $(CDEFINES) $(CDEBUG) $(COPT) -m64 -o $@ + +SPOBJ = pad.o x86-spjump64.o x86-spentry64.o x86-subprims64.o +ASMOBJ = x86-asmutils64.o imports.o + +COBJ = pmcl-kernel.o gc-common.o x86-gc.o bits.o x86-exceptions.o \ + image.o thread_manager.o lisp-debug.o memory.o unix-calls.o + +DEBUGOBJ = lispdcmd.o plprint.o plsym.o xlbt.o x86_print.o +KERNELOBJ= $(COBJ) x86-asmutils64.o imports.o + +SPINC = lisp.s m4macros.m4 x86-constants.s x86-macros.s errors.s x86-uuo.s \ + x86-constants64.s + +CHEADERS = area.h bits.h x86-constants.h lisp-errors.h gc.h lisp.h \ + lisp-exceptions.h lisp_globals.h macros.h memprotect.h image.h \ + Threads.h x86-constants64.h x86-exceptions.h lisptypes.h + + +KSPOBJ = $(SPOBJ) +all: ../../sx86cl64 + + +OSLIBS = -ldl -lm -lpthread -lsocket -lnsl -lrt + + +../../sx86cl64: $(KSPOBJ) $(KERNELOBJ) $(DEBUGOBJ) Makefile + $(CC) -m64 $(CDEBUG) -o $@ $(KSPOBJ) $(KERNELOBJ) $(DEBUGOBJ) $(OSLIBS) + + +$(SPOBJ): $(SPINC) +$(ASMOBJ): $(SPINC) +$(COBJ): $(CHEADERS) +$(DEBUGOBJ): $(CHEADERS) lispdcmd.h + + +cclean: + $(RM) -f $(KERNELOBJ) $(DEBUGOBJ) ../../sx86cl64 + +clean: cclean + $(RM) -f $(SPOBJ) + +strip: ../../sx86cl64 + strip -g ../../sx86cl64 Index: /branches/new-random/lisp-kernel/solarisx86/Makefile =================================================================== --- /branches/new-random/lisp-kernel/solarisx86/Makefile (revision 13309) +++ /branches/new-random/lisp-kernel/solarisx86/Makefile (revision 13309) @@ -0,0 +1,85 @@ +# +# Copyright (C) 2006 Clozure Associates and contributors +# This file is part of Clozure CL. +# +# Clozure CL is licensed under the terms of the Lisp Lesser GNU Public +# License , known as the LLGPL and distributed with Clozure CL as the +# file "LICENSE". The LLGPL consists of a preamble and the LGPL, +# which is distributed with Clozure CL as the file "LGPL". Where these +# conflict, the preamble takes precedence. +# +# Clozure CL is referenced in the preamble as the "LIBRARY." +# +# The LLGPL is also available online at +# http://opensource.franz.com/preamble.html + + +VPATH = .. +RM = /bin/rm +AS = /usr/sfw/bin/gas +# As of this writing, /usr/sfw/bin/gm4 is both more recent (1.4.2 vs 1.4) +# and more buggy than /opt/sfw/bin/gm4, which is available on the +# "Solaris companion" disk. Do you get the impression that the people +# who put this stuff together aren't paying much attention ? +# Marching forward: as of the OpenSolais 0805 (snv_86) release, there +# doesn't seem to be any way of obtaining a non-broken GNU m4 from Sun. +# I just downloaded the source to 1.4.11 and installed it in /usr/local/bin; +# I didn't try blastwave.org or sunfreeware.com; there might be working +# packages there +M4 = /usr/local/bin/m4 +CC = /usr/sfw/bin/gcc +ASFLAGS = --32 --divide +M4FLAGS = -DSOLARIS -DX86 -DX8632 +CDEFINES = -DSOLARIS -D_REENTRANT -DX86 -DX8632 -D__EXTENSIONS__ -DHAVE_TLS #-DDISABLE_EGC +CDEBUG = -g +COPT = -O2 + + + +.s.o: + $(M4) $(M4FLAGS) -I../ $< | $(AS) $(ASFLAGS) -o $@ +.c.o: + $(CC) -c $< $(CDEFINES) $(CDEBUG) $(COPT) -m32 -o $@ + +SPOBJ = pad.o x86-spjump32.o x86-spentry32.o x86-subprims32.o +ASMOBJ = x86-asmutils32.o imports.o + +COBJ = pmcl-kernel.o gc-common.o x86-gc.o bits.o x86-exceptions.o \ + image.o thread_manager.o lisp-debug.o memory.o unix-calls.o + +DEBUGOBJ = lispdcmd.o plprint.o plsym.o xlbt.o x86_print.o +KERNELOBJ= $(COBJ) x86-asmutils32.o imports.o + +SPINC = lisp.s m4macros.m4 x86-constants.s x86-macros.s errors.s x86-uuo.s \ + x86-constants32.s + +CHEADERS = area.h bits.h x86-constants.h lisp-errors.h gc.h lisp.h \ + lisp-exceptions.h lisp_globals.h macros.h memprotect.h image.h \ + Threads.h x86-constants32.h x86-exceptions.h lisptypes.h + + +KSPOBJ = $(SPOBJ) +all: ../../sx86cl + + +OSLIBS = -ldl -lm -lpthread -lsocket -lnsl -lrt + + +../../sx86cl: $(KSPOBJ) $(KERNELOBJ) $(DEBUGOBJ) Makefile + $(CC) -m32 $(CDEBUG) -o $@ $(KSPOBJ) $(KERNELOBJ) $(DEBUGOBJ) $(OSLIBS) + + +$(SPOBJ): $(SPINC) +$(ASMOBJ): $(SPINC) +$(COBJ): $(CHEADERS) +$(DEBUGOBJ): $(CHEADERS) lispdcmd.h + + +cclean: + $(RM) -f $(KERNELOBJ) $(DEBUGOBJ) ../../sx86cl + +clean: cclean + $(RM) -f $(SPOBJ) + +strip: ../../sx86cl + strip -g ../../sx86cl Index: /branches/new-random/lisp-kernel/static-linuxppc/.cvsignore =================================================================== --- /branches/new-random/lisp-kernel/static-linuxppc/.cvsignore (revision 13309) +++ /branches/new-random/lisp-kernel/static-linuxppc/.cvsignore (revision 13309) @@ -0,0 +1,2 @@ +external-functions.h +*~.* Index: /branches/new-random/lisp-kernel/static-linuxppc/Makefile =================================================================== --- /branches/new-random/lisp-kernel/static-linuxppc/Makefile (revision 13309) +++ /branches/new-random/lisp-kernel/static-linuxppc/Makefile (revision 13309) @@ -0,0 +1,103 @@ +# +# Copyright (C) 1994-2001 Digitool, Inc +# This file is part of OpenMCL. +# +# OpenMCL is licensed under the terms of the Lisp Lesser GNU Public +# License , known as the LLGPL and distributed with OpenMCL as the +# file "LICENSE". The LLGPL consists of a preamble and the LGPL, +# which is distributed with OpenMCL as the file "LGPL". Where these +# conflict, the preamble takes precedence. +# +# OpenMCL is referenced in the preamble as the "LIBRARY." +# +# The LLGPL is also available online at +# http://opensource.franz.com/preamble.html + +OPENMCL_MAJOR_VERSION=0 +OPENMCL_MINOR_VERSION=14 + +VPATH = ../ +RM = /bin/rm +# Versions of GNU as >= 2.9.1 all seem to work +# AS = gas-2.9.1 +AS = as +M4 = m4 +ASFLAGS = -mregnames -mppc32 +M4FLAGS = -DLINUX -DPPC +CDEFINES = -DLINUX -DPPC -D_REENTRANT -DSTATIC -D_GNU_SOURCE +CDEBUG = -g +COPT = -O2 + +# The only version of GCC I have that supports both ppc32 and ppc64 +# compilation uses the -m32 option to target ppc32. This may not be +# definitive; there seem to be a bewildering array of similar options +# in other GCC versions. It's assumed here that if "-m32" is recognized, +# it's required as well. + +PPC32 = $(shell ($(CC) --help -v 2>&1 | grep -q -e "-m32 ") && /bin/echo "-m32") + +# Likewise, some versions of GAS may need a "-a32" flag, to force the +# output file to be 32-bit compatible. + +A32 = $(shell ($(AS) --help -v 2>&1 | grep -q -e "-a32") && /bin/echo "-a32") + +.s.o: + $(M4) $(M4FLAGS) -I../ $< | $(AS) $(A32) $(ASFLAGS) -o $@ +.c.o: + $(CC) -c $< $(CDEFINES) $(CDEBUG) $(COPT) $(PPC32) -o $@ + +SPOBJ = pad.o ppc-spjump.o ppc-spentry.o ppc-subprims.o +ASMOBJ = ppc-asmutils.o imports.o + +COBJ = pmcl-kernel.o ppc-gc.o bits.o ppc-exceptions.o \ + image.o thread_manager.o lisp-debug.o memory.o + +DEBUGOBJ = lispdcmd.o plprint.o plsym.o plbt.o ppc_print.o +KERNELOBJ= $(COBJ) ppc-asmutils.o imports.o +STATICOBJ= staticlib.o + +SPINC = lisp.s m4macros.m4 ppc-constants.s ppc-macros.s errors.s ppc-uuo.s ppc-constants32.s + +CHEADERS = area.h bits.h ppc-constants.h lisp-errors.h gc.h lisp.h \ + lisp-exceptions.h lisp_globals.h macros.h memprotect.h image.h \ + Threads.h ppc-constants32.h ppc-exceptions.h + +# Subprims linked into the kernel ? +# Yes: + +KSPOBJ = $(SPOBJ) +all: ../../static-ppccl + + +# No: + +# KSPOBJ= +# all: ../../static-ppccl ../../subprims.so + +OSLIBS = -lm -lpthread + + +../../static-ppccl: $(KSPOBJ) $(KERNELOBJ) $(DEBUGOBJ) $(STATICOBJ) + $(CC) $(PPC32) $(CDEBUG) -static -o $@ -T ../linux//elf32ppclinux.x $(KSPOBJ) $(KERNELOBJ) $(STATICOBJ) $(DEBUGOBJ) $(OSLIBS) + + +$(SPOBJ): $(SPINC) +$(ASMOBJ): $(SPINC) +$(COBJ): $(CHEADERS) +$(DEBUGOBJ): $(CHEADERS) lispdcmd.h +staticlib.o: external-functions.h staticlib.c + $(CC) -c staticlib.c -fno-builtin $(CDEFINES) $(CDEBUG) $(COPT) $(PPC32) -o $@ + + +external-functions.h: + echo "Must generate external-functions.h from running lisp" + + +cclean: + $(RM) -f $(KERNELOBJ) $(DEBUGOBJ) ../../ppccl + +clean: cclean + $(RM) -f $(SPOBJ) + +strip: ../../ppccl + strip -g ../../ppccl Index: /branches/new-random/lisp-kernel/static-linuxppc/staticlib.c =================================================================== --- /branches/new-random/lisp-kernel/static-linuxppc/staticlib.c (revision 13309) +++ /branches/new-random/lisp-kernel/static-linuxppc/staticlib.c (revision 13309) @@ -0,0 +1,53 @@ +typedef struct { + char *name; + void *(*func)(); +} external_function; + +#define NULL ((void *)0) +#include "external-functions.h" + +int +string_compare(char *a, char *b) +{ + char ch; + + while (ch = *a++) { + if (*b++ != ch) { + return 1; + } + } + return !!*b; +} + + +void * +dlsym(void *handle, char *name) +{ + external_function *p; + char *fname; + + for (p = external_functions; fname = p->name; p++) { + if (!string_compare(name, fname)) { + return (void *)(p->func); + } + } + return NULL; +} + +void * +dlopen(char *path, int mode) +{ + return NULL; +} + +void * +dlerror() +{ + return (void *)"No shared library support\n"; +} + +void * +dlclose() +{ + return NULL; +} Index: /branches/new-random/lisp-kernel/thread_manager.c =================================================================== --- /branches/new-random/lisp-kernel/thread_manager.c (revision 13309) +++ /branches/new-random/lisp-kernel/thread_manager.c (revision 13309) @@ -0,0 +1,2697 @@ +/* + Copyright (C) 2009 Clozure Associates + Copyright (C) 1994-2001 Digitool, Inc + This file is part of Clozure CL. + + Clozure CL is licensed under the terms of the Lisp Lesser GNU Public + License , known as the LLGPL and distributed with Clozure CL as the + file "LICENSE". The LLGPL consists of a preamble and the LGPL, + which is distributed with Clozure CL as the file "LGPL". Where these + conflict, the preamble takes precedence. + + Clozure CL is referenced in the preamble as the "LIBRARY." + + The LLGPL is also available online at + http://opensource.franz.com/preamble.html +*/ + + +#include "Threads.h" + + +typedef struct { + TCR *tcr; + natural vsize, tsize; + void *created; +} thread_activation; + +#ifdef HAVE_TLS +__thread char tcrbuf[sizeof(TCR)+16]; +__thread TCR *current_tcr; +#endif + +/* This is set to true when running a 32-bit Lisp on 64-bit FreeBSD */ +Boolean rcontext_readonly = false; + +extern natural +store_conditional(natural*, natural, natural); + +extern signed_natural +atomic_swap(signed_natural*, signed_natural); + +#ifdef USE_FUTEX +#define futex_wait(futex,val) syscall(SYS_futex,futex,FUTEX_WAIT,val) +#define futex_wake(futex,n) syscall(SYS_futex,futex,FUTEX_WAKE,n) +#define FUTEX_AVAIL (0) +#define FUTEX_LOCKED (1) +#define FUTEX_CONTENDED (2) +#endif + +#ifdef WINDOWS +extern pc spentry_start, spentry_end,subprims_start,subprims_end; +extern pc restore_windows_context_start, restore_windows_context_end, + restore_windows_context_iret; + + +extern void interrupt_handler(int, siginfo_t *, ExceptionInformation *); + +void CALLBACK +nullAPC(ULONG_PTR arg) +{ +} + +BOOL (*pCancelIoEx)(HANDLE, OVERLAPPED*) = NULL; +BOOL (*pCancelSynchronousIo)(HANDLE) = NULL; + + + +extern void *windows_find_symbol(void*, char*); + +int +raise_thread_interrupt(TCR *target) +{ + /* GCC doesn't align CONTEXT corrcectly */ + char _contextbuf[sizeof(CONTEXT)+__alignof(CONTEXT)]; + CONTEXT *pcontext; + HANDLE hthread = (HANDLE)(target->osid); + pc where; + area *cs = target->cs_area, *ts = target->cs_area; + DWORD rc; + BOOL io_pending; + + pcontext = (CONTEXT *)((((natural)&_contextbuf)+15)&~15); + rc = SuspendThread(hthread); + if (rc == -1) { + return -1; + } + /* What if the suspend count is > 1 at this point ? I don't think + that that matters, but I'm not sure */ + pcontext->ContextFlags = CONTEXT_ALL; + rc = GetThreadContext(hthread, pcontext); + if (rc == 0) { + return ESRCH; + } + + where = (pc)(xpPC(pcontext)); + + if ((target->valence != TCR_STATE_LISP) || + (TCR_INTERRUPT_LEVEL(target) < 0) || + (target->unwinding != 0) || + (!((where < (pc)lisp_global(HEAP_END)) && + (where >= (pc)lisp_global(HEAP_START))) && + !((where < spentry_end) && (where >= spentry_start)) && + !((where < subprims_end) && (where >= subprims_start)) && + !((where < (pc) 0x16000) && + (where >= (pc) 0x15000)) && + !((where < (pc) (ts->high)) && + (where >= (pc) (ts->low))))) { + + target->interrupt_pending = (1LL << (nbits_in_word - 1LL)); + +#if 0 + /* If the thread's in a blocking syscall, it'd be nice to + get it out of that state here. */ + GetThreadIOPendingFlag(hthread,&io_pending); + if (io_pending) { + pending_io * pending = (pending_io *) (target->pending_io_info); + if (pending) { + if (pCancelIoEx) { + pCancelIoEx(pending->h, pending->o); + } else { + CancelIo(pending->h); + } + } + } +#endif + if (pCancelSynchronousIo) { + pCancelSynchronousIo(hthread); + } + QueueUserAPC(nullAPC, hthread, 0); + ResumeThread(hthread); + return 0; + } else { + /* Thread is running lisp code with interupts enabled. Set it + so that it calls out and then returns to the context, + handling any necessary pc-lusering. */ + LispObj foreign_rsp = (((LispObj)(target->foreign_sp))-0x200)&~15; + CONTEXT *icontext = ((CONTEXT *) foreign_rsp) -1; + icontext = (CONTEXT *)(((LispObj)icontext)&~15); + + *icontext = *pcontext; + +#ifdef WIN_64 + xpGPR(pcontext,REG_RCX) = SIGNAL_FOR_PROCESS_INTERRUPT; + xpGPR(pcontext,REG_RDX) = 0; + xpGPR(pcontext,REG_R8) = (LispObj) icontext; + xpGPR(pcontext,REG_RSP) = (LispObj)(((LispObj *)icontext)-1); + *(((LispObj *)icontext)-1) = (LispObj)raise_thread_interrupt; +#else + { + LispObj *p = (LispObj *)icontext; + p -= 4; + p[0] = SIGNAL_FOR_PROCESS_INTERRUPT; + p[1] = 0; + p[2] = (DWORD)icontext; + *(--p) = (LispObj)raise_thread_interrupt;; + xpGPR(pcontext,Isp) = (DWORD)p; +#ifdef WIN32_ES_HACK + pcontext->SegEs = pcontext->SegDs; +#endif + } +#endif + pcontext->EFlags &= ~0x400; /* clear direction flag */ + xpPC(pcontext) = (LispObj)interrupt_handler; + SetThreadContext(hthread,pcontext); + ResumeThread(hthread); + return 0; + } +} +#else +int +raise_thread_interrupt(TCR *target) +{ + pthread_t thread = (pthread_t)target->osid; +#ifdef DARWIN_not_yet + if (use_mach_exception_handling) { + return mach_raise_thread_interrupt(target); + } +#endif + if (thread != (pthread_t) 0) { + return pthread_kill(thread, SIGNAL_FOR_PROCESS_INTERRUPT); + } + return ESRCH; +} +#endif + +signed_natural +atomic_incf_by(signed_natural *ptr, signed_natural by) +{ + signed_natural old, new; + do { + old = *ptr; + new = old+by; + } while (store_conditional((natural *)ptr, (natural) old, (natural) new) != + (natural) old); + return new; +} + +signed_natural +atomic_incf(signed_natural *ptr) +{ + return atomic_incf_by(ptr, 1); +} + +signed_natural +atomic_decf(signed_natural *ptr) +{ + signed_natural old, new; + do { + old = *ptr; + new = old == 0 ? old : old-1; + } while (store_conditional((natural *)ptr, (natural) old, (natural) new) != + (natural) old); + return old-1; +} + + +#ifndef USE_FUTEX +int spin_lock_tries = 1; + +void +get_spin_lock(signed_natural *p, TCR *tcr) +{ + int i, n = spin_lock_tries; + + while (1) { + for (i = 0; i < n; i++) { + if (atomic_swap(p,(signed_natural)tcr) == 0) { + return; + } + } +#ifndef WINDOWS + sched_yield(); +#endif + } +} +#endif + +#ifndef USE_FUTEX +int +lock_recursive_lock(RECURSIVE_LOCK m, TCR *tcr) +{ + + if (tcr == NULL) { + tcr = get_tcr(true); + } + if (m->owner == tcr) { + m->count++; + return 0; + } + while (1) { + LOCK_SPINLOCK(m->spinlock,tcr); + ++m->avail; + if (m->avail == 1) { + m->owner = tcr; + m->count = 1; + RELEASE_SPINLOCK(m->spinlock); + break; + } + RELEASE_SPINLOCK(m->spinlock); + SEM_WAIT_FOREVER(m->signal); + } + return 0; +} + +#else /* USE_FUTEX */ + +static void inline +lock_futex(signed_natural *p) +{ + + while (1) { + if (store_conditional(p,FUTEX_AVAIL,FUTEX_LOCKED) == FUTEX_AVAIL) { + return; + } + while (1) { + if (atomic_swap(p,FUTEX_CONTENDED) == FUTEX_AVAIL) { + return; + } + futex_wait(p,FUTEX_CONTENDED); + } + } +} + +static void inline +unlock_futex(signed_natural *p) +{ + if (atomic_decf(p) != FUTEX_AVAIL) { + *p = FUTEX_AVAIL; + futex_wake(p,INT_MAX); + } +} + +int +lock_recursive_lock(RECURSIVE_LOCK m, TCR *tcr) +{ + if (tcr == NULL) { + tcr = get_tcr(true); + } + if (m->owner == tcr) { + m->count++; + return 0; + } + lock_futex(&m->avail); + m->owner = tcr; + m->count = 1; + return 0; +} +#endif /* USE_FUTEX */ + + +#ifndef USE_FUTEX +int +unlock_recursive_lock(RECURSIVE_LOCK m, TCR *tcr) +{ + int ret = EPERM, pending; + + if (tcr == NULL) { + tcr = get_tcr(true); + } + + if (m->owner == tcr) { + --m->count; + if (m->count == 0) { + LOCK_SPINLOCK(m->spinlock,tcr); + m->owner = NULL; + pending = m->avail-1 + m->waiting; /* Don't count us */ + m->avail = 0; + --pending; + if (pending > 0) { + m->waiting = pending; + } else { + m->waiting = 0; + } + RELEASE_SPINLOCK(m->spinlock); + if (pending >= 0) { + SEM_RAISE(m->signal); + } + } + ret = 0; + } + return ret; +} +#else /* USE_FUTEX */ +int +unlock_recursive_lock(RECURSIVE_LOCK m, TCR *tcr) +{ + int ret = EPERM; + + if (tcr == NULL) { + tcr = get_tcr(true); + } + + if (m->owner == tcr) { + --m->count; + if (m->count == 0) { + m->owner = NULL; + unlock_futex(&m->avail); + } + ret = 0; + } + return ret; +} +#endif /* USE_FUTEX */ + +void +destroy_recursive_lock(RECURSIVE_LOCK m) +{ +#ifndef USE_FUTEX + destroy_semaphore((void **)&m->signal); +#endif + postGCfree((void *)(m->malloced_ptr)); +} + +/* + If we're already the owner (or if the lock is free), lock it + and increment the lock count; otherwise, return EBUSY without + waiting. +*/ + +#ifndef USE_FUTEX +int +recursive_lock_trylock(RECURSIVE_LOCK m, TCR *tcr, int *was_free) +{ + TCR *owner = m->owner; + + LOCK_SPINLOCK(m->spinlock,tcr); + if (owner == tcr) { + m->count++; + if (was_free) { + *was_free = 0; + RELEASE_SPINLOCK(m->spinlock); + return 0; + } + } + if (store_conditional((natural*)&(m->avail), 0, 1) == 0) { + m->owner = tcr; + m->count = 1; + if (was_free) { + *was_free = 1; + } + RELEASE_SPINLOCK(m->spinlock); + return 0; + } + + RELEASE_SPINLOCK(m->spinlock); + return EBUSY; +} +#else +int +recursive_lock_trylock(RECURSIVE_LOCK m, TCR *tcr, int *was_free) +{ + TCR *owner = m->owner; + + if (owner == tcr) { + m->count++; + if (was_free) { + *was_free = 0; + return 0; + } + } + if (store_conditional((natural*)&(m->avail), 0, 1) == 0) { + m->owner = tcr; + m->count = 1; + if (was_free) { + *was_free = 1; + } + return 0; + } + + return EBUSY; +} +#endif + +void +sem_wait_forever(SEMAPHORE s) +{ + int status; + + do { +#ifdef USE_MACH_SEMAPHORES + mach_timespec_t q = {1,0}; + status = SEM_TIMEDWAIT(s,q); +#endif +#ifdef USE_POSIX_SEMAPHORES + struct timespec q; + gettimeofday((struct timeval *)&q, NULL); + q.tv_sec += 1; + status = SEM_TIMEDWAIT(s,&q); +#endif +#ifdef USE_WINDOWS_SEMAPHORES + status = (WaitForSingleObject(s,1000L) == WAIT_TIMEOUT) ? 1 : 0; +#endif + } while (status != 0); +} + +int +wait_on_semaphore(void *s, int seconds, int millis) +{ +#ifdef USE_POSIX_SEMAPHORES + int nanos = (millis % 1000) * 1000000; + int status; + + struct timespec q; + gettimeofday((struct timeval *)&q, NULL); + q.tv_nsec *= 1000L; /* microseconds -> nanoseconds */ + + q.tv_nsec += nanos; + if (q.tv_nsec >= 1000000000L) { + q.tv_nsec -= 1000000000L; + seconds += 1; + } + q.tv_sec += seconds; + status = SEM_TIMEDWAIT(s, &q); + if (status < 0) { + return errno; + } + return status; +#endif +#ifdef USE_MACH_SEMAPHORES + int nanos = (millis % 1000) * 1000000; + mach_timespec_t q = {seconds, nanos}; + int status = SEM_TIMEDWAIT(s, q); + + + switch (status) { + case 0: return 0; + case KERN_OPERATION_TIMED_OUT: return ETIMEDOUT; + case KERN_ABORTED: return EINTR; + default: return EINVAL; + } +#endif +#ifdef USE_WINDOWS_SEMAPHORES + switch (WaitForSingleObjectEx(s, seconds*1000L+(DWORD)millis,true)) { + case WAIT_OBJECT_0: + return 0; + case WAIT_TIMEOUT: + return /* ETIMEDOUT */ WAIT_TIMEOUT; + case WAIT_IO_COMPLETION: + return EINTR; + default: + break; + } + return EINVAL; + +#endif +} + + +int +semaphore_maybe_timedwait(void *s, struct timespec *t) +{ + if (t) { + return wait_on_semaphore(s, t->tv_sec, t->tv_nsec/1000000L); + } + SEM_WAIT_FOREVER(s); + return 0; +} + +void +signal_semaphore(SEMAPHORE s) +{ + SEM_RAISE(s); +} + + +#ifdef WINDOWS +LispObj +current_thread_osid() +{ + TCR *tcr = get_tcr(false); + LispObj current = 0; + + if (tcr) { + current = tcr->osid; + } + if (current == 0) { + DuplicateHandle(GetCurrentProcess(), + GetCurrentThread(), + GetCurrentProcess(), + (LPHANDLE)(¤t), + 0, + FALSE, + DUPLICATE_SAME_ACCESS); + if (tcr) { + tcr->osid = current; + } + } + return current; +} +#else +LispObj +current_thread_osid() +{ + return (LispObj)ptr_to_lispobj(pthread_self()); +} +#endif + + +int thread_suspend_signal = 0, thread_kill_signal = 0; + + + +void +linux_exception_init(TCR *tcr) +{ +} + + +TCR * +get_interrupt_tcr(Boolean create) +{ + return get_tcr(create); +} + +void +suspend_resume_handler(int signo, siginfo_t *info, ExceptionInformation *context) +{ +#ifdef DARWIN_GS_HACK + Boolean gs_was_tcr = ensure_gs_pthread(); +#endif + TCR *tcr = get_interrupt_tcr(false); + + if (tcr == NULL) { + /* Got a suspend signal sent to the pthread. */ + extern natural initial_stack_size; + void register_thread_tcr(TCR *); + + tcr = new_tcr(initial_stack_size, MIN_TSTACK_SIZE); + tcr->suspend_count = 1; + tcr->vs_area->active -= node_size; + *(--tcr->save_vsp) = lisp_nil; + register_thread_tcr(tcr); + } + if (TCR_INTERRUPT_LEVEL(tcr) <= (-2<suspend_context = context; + SEM_RAISE(tcr->suspend); + SEM_WAIT_FOREVER(tcr->resume); + tcr->suspend_context = NULL; + } +#ifdef DARWIN_GS_HACK + if (gs_was_tcr) { + set_gs_address(tcr); + } +#endif + SIGRETURN(context); +} + + + +/* + 'base' should be set to the bottom (origin) of the stack, e.g., the + end from which it grows. +*/ + +#ifdef WINDOWS +void +os_get_current_thread_stack_bounds(void **base, natural *size) +{ + natural natbase; + MEMORY_BASIC_INFORMATION info; + void *addr = (void *)current_stack_pointer(); + + VirtualQuery(addr, &info, sizeof(info)); + natbase = (natural)info.BaseAddress+info.RegionSize; + *size = natbase - (natural)(info.AllocationBase); + *base = (void *)natbase; +} +#else +void +os_get_current_thread_stack_bounds(void **base, natural *size) +{ + pthread_t p = pthread_self(); +#ifdef DARWIN + *base = pthread_get_stackaddr_np(p); + *size = pthread_get_stacksize_np(p); +#endif +#ifdef LINUX + pthread_attr_t attr; + + pthread_getattr_np(p,&attr); + pthread_attr_getstack(&attr, base, size); + pthread_attr_destroy(&attr); + *(natural *)base += *size; +#endif +#ifdef FREEBSD + pthread_attr_t attr; + void * temp_base; + size_t temp_size; + + + pthread_attr_init(&attr); + pthread_attr_get_np(p, &attr); + pthread_attr_getstackaddr(&attr,&temp_base); + pthread_attr_getstacksize(&attr,&temp_size); + *base = (void *)((natural)temp_base + temp_size); + *size = temp_size; + pthread_attr_destroy(&attr); +#endif +#ifdef SOLARIS + stack_t st; + + thr_stksegment(&st); + *size = st.ss_size; + *base = st.ss_sp; + +#endif +} +#endif + +void * +new_semaphore(int count) +{ +#ifdef USE_POSIX_SEMAPHORES + sem_t *s = malloc(sizeof(sem_t)); + sem_init(s, 0, count); + return s; +#endif +#ifdef USE_MACH_SEMAPHORES + semaphore_t s = (semaphore_t)0; + semaphore_create(mach_task_self(),&s, SYNC_POLICY_FIFO, count); + return (void *)(natural)s; +#endif +#ifdef USE_WINDOWS_SEMAPHORES + return CreateSemaphore(NULL, count, 0x7fffL, NULL); +#endif +} + +RECURSIVE_LOCK +new_recursive_lock() +{ + extern int cache_block_size; + void *p = calloc(1,sizeof(_recursive_lock)+cache_block_size-1); + RECURSIVE_LOCK m = NULL; +#ifndef USE_FUTEX + void *signal = new_semaphore(0); +#endif + if (p) { + m = (RECURSIVE_LOCK) ((((natural)p)+cache_block_size-1) & (~(cache_block_size-1))); + m->malloced_ptr = p; + } + +#ifdef USE_FUTEX + if (m) { + return m; + } +#else + if (m && signal) { + m->signal = signal; + return m; + } + if (m) { + free(p); + } + if (signal) { + destroy_semaphore(&signal); + } +#endif + return NULL; +} + +void +destroy_semaphore(void **s) +{ + if (*s) { +#ifdef USE_POSIX_SEMAPHORES + sem_destroy((sem_t *)*s); + if (lisp_global(IN_GC)) { + postGCfree(*s); + } else { + free(*s); + } +#endif +#ifdef USE_MACH_SEMAPHORES + semaphore_destroy(mach_task_self(),((semaphore_t)(natural) *s)); +#endif +#ifdef USE_WINDOWS_SEMAPHORES + CloseHandle(*s); +#endif + *s=NULL; + } +} + +#ifdef WINDOWS +void +tsd_set(LispObj key, void *datum) +{ + TlsSetValue((DWORD)key, datum); +} + +void * +tsd_get(LispObj key) +{ + return TlsGetValue((DWORD)key); +} +#else +void +tsd_set(LispObj key, void *datum) +{ + pthread_setspecific((pthread_key_t)key, datum); +} + +void * +tsd_get(LispObj key) +{ + return pthread_getspecific((pthread_key_t)key); +} +#endif + +void +dequeue_tcr(TCR *tcr) +{ + TCR *next, *prev; + + next = tcr->next; + prev = tcr->prev; + + prev->next = next; + next->prev = prev; + tcr->prev = tcr->next = NULL; +#ifdef X8664 + tcr->linear = NULL; +#endif +} + +void +enqueue_tcr(TCR *new) +{ + TCR *head, *tail; + + LOCK(lisp_global(TCR_AREA_LOCK),new); + head = (TCR *)ptr_from_lispobj(lisp_global(INITIAL_TCR)); + tail = head->prev; + tail->next = new; + head->prev = new; + new->prev = tail; + new->next = head; + UNLOCK(lisp_global(TCR_AREA_LOCK),new); +} + +#ifdef WIN_32 +TCR * +allocate_tcr() +{ + void *p = calloc(1,sizeof(TCR)+15); + TCR *tcr = (TCR *)((((natural)p)+15)&~15); + + tcr->allocated = p; + return tcr; +} +#else +TCR * +allocate_tcr() +{ + TCR *tcr, *chain = NULL, *next; +#ifdef DARWIN + extern Boolean use_mach_exception_handling; + kern_return_t kret; + mach_port_t + thread_exception_port, + task_self = mach_task_self(); +#endif + for (;;) { + tcr = calloc(1, sizeof(TCR)); +#ifdef DARWIN +#if WORD_SIZE == 64 + if (((unsigned)((natural)tcr)) != ((natural)tcr)) { + tcr->next = chain; + chain = tcr; + continue; + } +#endif + if (use_mach_exception_handling) { + thread_exception_port = (mach_port_t)((natural)tcr); + kret = mach_port_allocate_name(task_self, + MACH_PORT_RIGHT_RECEIVE, + thread_exception_port); + } else { + kret = KERN_SUCCESS; + } + + if (kret != KERN_SUCCESS) { + tcr->next = chain; + chain = tcr; + continue; + } +#endif + for (;chain;chain = next) { + next = chain->next; + free(chain); + } + return tcr; + } +} +#endif + +#ifdef X8664 +#ifdef LINUX +#include +#include +#endif +#ifdef FREEBSD +#include +#endif + +void +setup_tcr_extra_segment(TCR *tcr) +{ +#ifdef FREEBSD + amd64_set_gsbase(tcr); +#endif +#ifdef LINUX + arch_prctl(ARCH_SET_GS, (natural)tcr); +#endif +#ifdef DARWIN + /* There's no way to do this yet. See DARWIN_GS_HACK */ + /* darwin_set_x8664_fs_reg(tcr); */ +#endif +#ifdef SOLARIS + /* Chris Curtis found this and suggested the use of syscall here */ + syscall(SYS_lwp_private,_LWP_SETPRIVATE, _LWP_GSBASE, tcr); +#endif +} + +#endif + +#ifdef X8632 + +#ifdef DARWIN +#include +#include +#include + +void setup_tcr_extra_segment(TCR *tcr) +{ + uintptr_t addr = (uintptr_t)tcr; + unsigned int size = sizeof(*tcr); + ldt_entry_t desc; + sel_t sel; + int i; + + desc.data.limit00 = (size - 1) & 0xffff; + desc.data.limit16 = ((size - 1) >> 16) & 0xf; + desc.data.base00 = addr & 0xffff; + desc.data.base16 = (addr >> 16) & 0xff; + desc.data.base24 = (addr >> 24) & 0xff; + desc.data.type = DESC_DATA_WRITE; + desc.data.dpl = USER_PRIV; + desc.data.present = 1; + desc.data.stksz = DESC_CODE_32B; + desc.data.granular = DESC_GRAN_BYTE; + + i = i386_set_ldt(LDT_AUTO_ALLOC, &desc, 1); + + if (i < 0) { + perror("i386_set_ldt"); + } else { + sel.index = i; + sel.rpl = USER_PRIV; + sel.ti = SEL_LDT; + tcr->ldt_selector = sel; + } +} + +void free_tcr_extra_segment(TCR *tcr) +{ + /* load %fs with null segement selector */ + __asm__ volatile ("mov %0,%%fs" : : "r"(0)); + if (i386_set_ldt(tcr->ldt_selector.index, NULL, 1) < 0) + perror("i386_set_ldt"); + tcr->ldt_selector = NULL_SEL; +} +#endif + +#ifdef LINUX + +#include +#include + +/* see desc_struct in kernel/include/asm-i386/processor.h */ +typedef struct { + uint32_t a; + uint32_t b; +} linux_desc_struct; + + +#define desc_avail(d) (((d)->a) == 0) + +linux_desc_struct linux_ldt_entries[LDT_ENTRIES]; + +/* We have to ask the Linux kernel for a copy of the ldt table + and manage it ourselves. It's not clear that this is + thread-safe in general, but we can at least ensure that + it's thread-safe wrt lisp threads. */ + +pthread_mutex_t ldt_lock = PTHREAD_MUTEX_INITIALIZER; /* simple, non-recursive mutex */ + +int +modify_ldt(int func, void *ptr, unsigned long bytecount) +{ + return syscall(__NR_modify_ldt, func, ptr, bytecount); +} + + +void +setup_tcr_extra_segment(TCR *tcr) +{ + int i, n; + short sel; + struct user_desc u = {1, 0, 0, 1, MODIFY_LDT_CONTENTS_DATA, 0, 0, 0, 1}; + linux_desc_struct *d = linux_ldt_entries; + + pthread_mutex_lock(&ldt_lock); + n = modify_ldt(0,d,LDT_ENTRIES*LDT_ENTRY_SIZE)/LDT_ENTRY_SIZE; + for (i = 0; i < n; i++,d++) { + if (desc_avail(d)) { + break; + } + } + if (i == LDT_ENTRIES) { + pthread_mutex_unlock(&ldt_lock); + fprintf(dbgout, "All 8192 ldt entries in use ?\n"); + _exit(1); + } + u.entry_number = i; + u.base_addr = (uint32_t)tcr; + u.limit = sizeof(TCR); + u.limit_in_pages = 0; + if (modify_ldt(1,&u,sizeof(struct user_desc)) != 0) { + pthread_mutex_unlock(&ldt_lock); + fprintf(dbgout,"Can't assign LDT entry\n"); + _exit(1); + } + sel = (i << 3) | 7; + tcr->ldt_selector = sel; + pthread_mutex_unlock(&ldt_lock); +} + +void +free_tcr_extra_segment(TCR *tcr) +{ + struct user_desc u = {0, 0, 0, 0, MODIFY_LDT_CONTENTS_DATA, 0, 0, 0, 0}; + short sel = tcr->ldt_selector; + + pthread_mutex_lock(&ldt_lock); + /* load %fs with null segment selector */ + __asm__ volatile ("mov %0,%%fs" : : "r"(0)); + tcr->ldt_selector = 0; + u.entry_number = (sel>>3); + modify_ldt(1,&u,sizeof(struct user_desc)); + pthread_mutex_unlock(&ldt_lock); + +} + +#endif + +#ifdef WINDOWS +bitvector ldt_entries_in_use = NULL; +HANDLE ldt_lock; + +typedef struct { + DWORD offset; + DWORD size; + LDT_ENTRY entry; +} win32_ldt_info; + + +int WINAPI (*NtQueryInformationProcess)(HANDLE,DWORD,VOID*,DWORD,DWORD*); +int WINAPI (*NtSetInformationProcess)(HANDLE,DWORD,VOID*,DWORD); + +void +init_win32_ldt() +{ + HANDLE hNtdll; + int status = 0xc0000002; + win32_ldt_info info; + DWORD nret; + + + ldt_entries_in_use=malloc(8192/8); + zero_bits(ldt_entries_in_use,8192); + ldt_lock = CreateMutex(NULL,0,NULL); + + hNtdll = LoadLibrary("ntdll.dll"); + NtQueryInformationProcess = (void*)GetProcAddress(hNtdll, "NtQueryInformationProcess"); + NtSetInformationProcess = (void*)GetProcAddress(hNtdll, "NtSetInformationProcess"); + if (NtQueryInformationProcess != NULL) { + info.offset = 0; + info.size = sizeof(LDT_ENTRY); + status = NtQueryInformationProcess(GetCurrentProcess(),10,&info,sizeof(info),&nret); + } + + if (status) { + fprintf(dbgout, "This application can't run under this OS version\n"); + _exit(1); + } +} + +void +setup_tcr_extra_segment(TCR *tcr) +{ + int i, status; + DWORD nret; + win32_ldt_info info; + LDT_ENTRY *entry = &(info.entry); + DWORD *words = (DWORD *)entry, tcraddr = (DWORD)tcr; + + + WaitForSingleObject(ldt_lock,INFINITE); + + for (i = 0; i < 8192; i++) { + if (!ref_bit(ldt_entries_in_use,i)) { + info.offset = i << 3; + info.size = sizeof(LDT_ENTRY); + words[0] = 0; + words[1] = 0; + status = NtQueryInformationProcess(GetCurrentProcess(),10,&info,sizeof(info),&nret); + if (status == 0) { + if ((info.size == 0) || + ((words[0] == 0) && (words[1] == 0))) { + break; + } + } + } + } + if (i == 8192) { + ReleaseMutex(ldt_lock); + fprintf(dbgout, "All 8192 ldt entries in use ?\n"); + _exit(1); + } + set_bit(ldt_entries_in_use,i); + words[0] = 0; + words[1] = 0; + entry->LimitLow = sizeof(TCR); + entry->BaseLow = tcraddr & 0xffff; + entry->HighWord.Bits.BaseMid = (tcraddr >> 16) & 0xff; + entry->HighWord.Bits.BaseHi = (tcraddr >> 24); + entry->HighWord.Bits.Pres = 1; + entry->HighWord.Bits.Default_Big = 1; + entry->HighWord.Bits.Type = 16 | 2; /* read-write data */ + entry->HighWord.Bits.Dpl = 3; /* for use by the great unwashed */ + info.size = sizeof(LDT_ENTRY); + status = NtSetInformationProcess(GetCurrentProcess(),10,&info,sizeof(info)); + if (status != 0) { + ReleaseMutex(ldt_lock); + FBug(NULL, "can't set LDT entry %d, status = 0x%x", i, status); + } +#if 1 + /* Sanity check */ + info.offset = i << 3; + info.size = sizeof(LDT_ENTRY); + words[0] = 0; + words[0] = 0; + NtQueryInformationProcess(GetCurrentProcess(),10,&info,sizeof(info),&nret); + if (((entry->BaseLow)|((entry->HighWord.Bits.BaseMid)<<16)|((entry->HighWord.Bits.BaseHi)<<24)) != tcraddr) { + Bug(NULL, "you blew it: bad address in ldt entry\n"); + } +#endif + tcr->ldt_selector = (i << 3) | 7; + ReleaseMutex(ldt_lock); +} + +void +free_tcr_extra_segment(TCR *tcr) +{ + win32_ldt_info info; + LDT_ENTRY *entry = &(info.entry); + DWORD *words = (DWORD *)entry; + int idx = tcr->ldt_selector >> 3; + + + info.offset = idx << 3; + info.size = sizeof(LDT_ENTRY); + + words[0] = 0; + words[1] = 0; + + WaitForSingleObject(ldt_lock,INFINITE); + NtSetInformationProcess(GetCurrentProcess(),10,&info,sizeof(info)); + clr_bit(ldt_entries_in_use,idx); + ReleaseMutex(ldt_lock); + + tcr->ldt_selector = 0; +} + +#endif +#ifdef FREEBSD +#include +#include + +/* It'd be tempting to use i386_set_fsbase() here, but there doesn't + seem to be any way to free the GDT entry it creates. Actually, + it's not clear that that really sets a GDT entry; let's see */ + +#define FREEBSD_USE_SET_FSBASE 1 +void +setup_tcr_extra_segment(TCR *tcr) +{ +#if !FREEBSD_USE_SET_FSBASE + struct segment_descriptor sd; + uintptr_t addr = (uintptr_t)tcr; + unsigned int size = sizeof(*tcr); + int i; + + sd.sd_lolimit = (size - 1) & 0xffff; + sd.sd_hilimit = ((size - 1) >> 16) & 0xf; + sd.sd_lobase = addr & ((1<<24)-1); + sd.sd_hibase = (addr>>24)&0xff; + + + + sd.sd_type = 18; + sd.sd_dpl = SEL_UPL; + sd.sd_p = 1; + sd.sd_def32 = 1; + sd.sd_gran = 0; + + i = i386_set_ldt(LDT_AUTO_ALLOC, (union descriptor *)&sd, 1); + + if (i < 0) { + perror("i386_set_ldt"); + exit(1); + } else { + tcr->ldt_selector = LSEL(i,SEL_UPL); + } +#else + extern unsigned short get_fs_register(void); + + if (i386_set_fsbase((void*)tcr)) { + perror("i386_set_fsbase"); + exit(1); + } + + + /* Once we've called i386_set_fsbase, we can't write to %fs. */ + tcr->ldt_selector = GSEL(GUFS_SEL, SEL_UPL); +#endif +} + +void +free_tcr_extra_segment(TCR *tcr) +{ +#if FREEBSD_USE_SET_FSBASE + /* On a 32-bit kernel, this allocates a GDT entry. It's not clear + what it would mean to deallocate that entry. */ + /* If we're running on a 64-bit kernel, we can't write to %fs */ +#else + int idx = tcr->ldt_selector >> 3; + /* load %fs with null segment selector */ + __asm__ volatile ("mov %0,%%fs" : : "r"(0)); + if (i386_set_ldt(idx, NULL, 1) < 0) + perror("i386_set_ldt"); +#endif + tcr->ldt_selector = 0; +} +#endif + +#ifdef SOLARIS +#include + +bitvector ldt_entries_in_use = NULL; +pthread_mutex_t ldt_lock = PTHREAD_MUTEX_INITIALIZER; /* simple, non-recursive mutex */ + +void +solaris_ldt_init() +{ + int fd; + struct ssd s; + + ldt_entries_in_use=malloc(8192/8); + zero_bits(ldt_entries_in_use,8192); + + fd = open("/proc/self/ldt", O_RDONLY); + + while(read(fd,&s,sizeof(s)) == sizeof(s)) { + set_bit(ldt_entries_in_use,s.sel>>3); + } + close(fd); +} + + +void +setup_tcr_extra_segment(TCR *tcr) +{ + struct ssd s; + int i; + + pthread_mutex_lock(&ldt_lock); + + for (i = 0; i < 8192; i++) { + if (!ref_bit(ldt_entries_in_use,i)) { + s.sel = (i<<3)|7; + s.bo = (unsigned int)tcr; + s.ls = sizeof(TCR); + s.acc1 = 0xf2; + s.acc2 = 4; + + if (sysi86(SI86DSCR, &s) >= 0) { + set_bit(ldt_entries_in_use,i); + tcr->ldt_selector = (i<<3)|7; + pthread_mutex_unlock(&ldt_lock); + return; + } + set_bit(ldt_entries_in_use,i); + } + } + pthread_mutex_unlock(&ldt_lock); + fprintf(dbgout, "All 8192 LDT descriptors in use\n"); + _exit(1); + + + +} + +void +free_tcr_extra_segment(TCR *tcr) +{ + struct ssd s; + int i; + + pthread_mutex_lock(&ldt_lock); + __asm__ volatile ("mov %0,%%fs" : : "r"(0)); + s.sel = tcr->ldt_selector; + i = s.sel>>3; + tcr->ldt_selector = 0; + s.bo = 0; + s.ls = 0; + s.acc1 = 0; + s.acc2 = 0; + sysi86(SI86DSCR, &s); + clr_bit(ldt_entries_in_use,i); + pthread_mutex_unlock(&ldt_lock); +} + +#endif +#endif + +/* + Caller must hold the area_lock. +*/ +TCR * +new_tcr(natural vstack_size, natural tstack_size) +{ + extern area + *allocate_vstack_holding_area_lock(natural), + *allocate_tstack_holding_area_lock(natural); + area *a; + int i; +#ifndef WINDOWS + sigset_t sigmask; + + sigemptyset(&sigmask); + pthread_sigmask(SIG_SETMASK,&sigmask, NULL); +#endif + +#ifdef HAVE_TLS + TCR *tcr = (TCR *) ((((natural)&tcrbuf)+((natural)15)) & ~((natural)15)); + current_tcr = tcr; +#else /* no TLS */ + TCR *tcr = allocate_tcr(); +#endif + +#ifdef X86 + setup_tcr_extra_segment(tcr); + tcr->linear = tcr; +#ifdef X8632 + tcr->node_regs_mask = X8632_DEFAULT_NODE_REGS_MASK; +#endif +#endif + +#if (WORD_SIZE == 64) + tcr->single_float_convert.tag = subtag_single_float; +#endif + tcr->suspend = new_semaphore(0); + tcr->resume = new_semaphore(0); + tcr->reset_completion = new_semaphore(0); + tcr->activate = new_semaphore(0); + LOCK(lisp_global(TCR_AREA_LOCK),tcr); + a = allocate_vstack_holding_area_lock(vstack_size); + tcr->vs_area = a; + a->owner = tcr; + tcr->save_vsp = (LispObj *) a->active; + a = allocate_tstack_holding_area_lock(tstack_size); + UNLOCK(lisp_global(TCR_AREA_LOCK),tcr); + tcr->ts_area = a; + a->owner = tcr; + tcr->save_tsp = (LispObj *) a->active; +#ifdef X86 + tcr->next_tsp = tcr->save_tsp; +#endif + + tcr->valence = TCR_STATE_FOREIGN; +#ifdef PPC + tcr->lisp_fpscr.words.l = 0xd0; +#endif +#ifdef X86 + tcr->lisp_mxcsr = (1 << MXCSR_DM_BIT) | +#if 1 /* Mask underflow; too hard to + deal with denorms if underflow is + enabled */ + (1 << MXCSR_UM_BIT) | +#endif + (1 << MXCSR_PM_BIT); +#endif + tcr->save_allocbase = tcr->save_allocptr = (void *) VOID_ALLOCPTR; + tcr->tlb_limit = 2048<tlb_pointer = (LispObj *)malloc(tcr->tlb_limit); + for (i = 0; i < 2048; i++) { + tcr->tlb_pointer[i] = (LispObj) no_thread_local_binding_marker; + } + TCR_INTERRUPT_LEVEL(tcr) = (LispObj) (-1<shutdown_count = PTHREAD_DESTRUCTOR_ITERATIONS; +#else + tcr->shutdown_count = 1; +#endif + return tcr; +} + +void +shutdown_thread_tcr(void *arg) +{ + TCR *tcr = TCR_FROM_TSD(arg),*current=get_tcr(0); + + area *vs, *ts, *cs; + + if (current == NULL) { + current = tcr; + } + + if (--(tcr->shutdown_count) == 0) { + if (tcr->flags & (1<address; + + tsd_set(lisp_global(TCR_KEY), TCR_TO_TSD(tcr)); + ((void (*)())ptr_from_lispobj(callback_ptr))(1); + tsd_set(lisp_global(TCR_KEY), NULL); + } +#ifdef DARWIN + darwin_exception_cleanup(tcr); +#endif + LOCK(lisp_global(TCR_AREA_LOCK),current); + vs = tcr->vs_area; + tcr->vs_area = NULL; + ts = tcr->ts_area; + tcr->ts_area = NULL; + cs = tcr->cs_area; + tcr->cs_area = NULL; + if (vs) { + condemn_area_holding_area_lock(vs); + } + if (ts) { + condemn_area_holding_area_lock(ts); + } + if (cs) { + condemn_area_holding_area_lock(cs); + } + destroy_semaphore(&tcr->suspend); + destroy_semaphore(&tcr->resume); + destroy_semaphore(&tcr->reset_completion); + destroy_semaphore(&tcr->activate); + tcr->tlb_limit = 0; + free(tcr->tlb_pointer); + tcr->tlb_pointer = NULL; + tcr->osid = 0; + tcr->interrupt_pending = 0; + tcr->termination_semaphore = NULL; +#ifdef HAVE_TLS + dequeue_tcr(tcr); +#endif +#ifdef X8632 + free_tcr_extra_segment(tcr); +#endif +#ifdef WIN32 + CloseHandle((HANDLE)tcr->io_datum); + tcr->io_datum = NULL; + free(tcr->native_thread_info); + tcr->native_thread_info = NULL; +#endif + UNLOCK(lisp_global(TCR_AREA_LOCK),current); + } else { + tsd_set(lisp_global(TCR_KEY), TCR_TO_TSD(tcr)); + } +} + +void +tcr_cleanup(void *arg) +{ + TCR *tcr = (TCR *)arg; + area *a; + + a = tcr->vs_area; + if (a) { + a->active = a->high; + } + a = tcr->ts_area; + if (a) { + a->active = a->high; + } + a = tcr->cs_area; + if (a) { + a->active = a->high; + } + tcr->valence = TCR_STATE_FOREIGN; + tcr->shutdown_count = 1; + shutdown_thread_tcr(tcr); + tsd_set(lisp_global(TCR_KEY), NULL); +} + +void * +current_native_thread_id() +{ + return ((void *) (natural) +#ifdef LINUX +#ifdef __NR_gettid + syscall(__NR_gettid) +#else + getpid() +#endif +#endif +#ifdef DARWIN + mach_thread_self() +#endif +#ifdef FREEBSD + pthread_self() +#endif +#ifdef SOLARIS + pthread_self() +#endif +#ifdef WINDOWS + GetCurrentThreadId() +#endif + ); +} + + +void +thread_init_tcr(TCR *tcr, void *stack_base, natural stack_size) +{ + area *a, *register_cstack_holding_area_lock(BytePtr, natural); + + tcr->osid = current_thread_osid(); + tcr->native_thread_id = current_native_thread_id(); + LOCK(lisp_global(TCR_AREA_LOCK),tcr); + a = register_cstack_holding_area_lock((BytePtr)stack_base, stack_size); + UNLOCK(lisp_global(TCR_AREA_LOCK),tcr); + tcr->cs_area = a; + a->owner = tcr; + if (!(tcr->flags & (1<cs_limit = (LispObj)ptr_to_lispobj(a->softlimit); + } +#ifdef LINUX +#ifdef PPC +#ifndef PPC64 + tcr->native_thread_info = current_r2; +#endif +#endif +#endif + tcr->errno_loc = &errno; + tsd_set(lisp_global(TCR_KEY), TCR_TO_TSD(tcr)); +#ifdef DARWIN + extern Boolean use_mach_exception_handling; + if (use_mach_exception_handling) { + darwin_exception_init(tcr); + } +#endif +#ifdef LINUX + linux_exception_init(tcr); +#endif +#ifdef WINDOWS + tcr->io_datum = (VOID *)CreateEvent(NULL, true, false, NULL); + tcr->native_thread_info = malloc(sizeof(CONTEXT)); +#endif + tcr->log2_allocation_quantum = unbox_fixnum(lisp_global(DEFAULT_ALLOCATION_QUANTUM)); +} + +/* + Register the specified tcr as "belonging to" the current thread. + Under Darwin, setup Mach exception handling for the thread. + Install cleanup handlers for thread termination. +*/ +void +register_thread_tcr(TCR *tcr) +{ + void *stack_base = NULL; + natural stack_size = 0; + + os_get_current_thread_stack_bounds(&stack_base, &stack_size); + thread_init_tcr(tcr, stack_base, stack_size); + enqueue_tcr(tcr); +} + + + + +#ifndef MAP_GROWSDOWN +#define MAP_GROWSDOWN 0 +#endif + +Ptr +create_stack(natural size) +{ + Ptr p; + size=align_to_power_of_2(size, log2_page_size); + p = (Ptr) MapMemoryForStack((size_t)size); + if (p != (Ptr)(-1)) { + *((size_t *)p) = size; + return p; + } + allocation_failure(true, size); + +} + +void * +allocate_stack(natural size) +{ + return create_stack(size); +} + +void +free_stack(void *s) +{ + size_t size = *((size_t *)s); + UnMapMemory(s, size); +} + +Boolean threads_initialized = false; + +#ifndef USE_FUTEX +#ifdef WINDOWS +void +count_cpus() +{ + SYSTEM_INFO si; + + GetSystemInfo(&si); + if (si.dwNumberOfProcessors > 1) { + spin_lock_tries = 1024; + } +} +#else +void +count_cpus() +{ +#ifdef DARWIN + /* As of OSX 10.4, Darwin doesn't define _SC_NPROCESSORS_ONLN */ +#include + + struct host_basic_info info; + mach_msg_type_number_t count = HOST_BASIC_INFO_COUNT; + + if (KERN_SUCCESS == host_info(mach_host_self(), HOST_BASIC_INFO,(host_info_t)(&info),&count)) { + if (info.max_cpus > 1) { + spin_lock_tries = 1024; + } + } +#else + int n = sysconf(_SC_NPROCESSORS_ONLN); + + if (n > 1) { + spin_lock_tries = 1024; + } +#endif +} +#endif +#endif + +void +init_threads(void * stack_base, TCR *tcr) +{ + lisp_global(INITIAL_TCR) = (LispObj)ptr_to_lispobj(tcr); +#ifdef WINDOWS + lisp_global(TCR_KEY) = TlsAlloc(); + pCancelIoEx = windows_find_symbol(NULL, "CancelIoEx"); + pCancelSynchronousIo = windows_find_symbol(NULL, "CancelSynchronousIo"); +#else + pthread_key_create((pthread_key_t *)&(lisp_global(TCR_KEY)), shutdown_thread_tcr); + thread_signal_setup(); +#endif + +#ifndef USE_FUTEX + count_cpus(); +#endif + threads_initialized = true; +} + + +#ifdef WINDOWS +unsigned CALLBACK +#else +void * +#endif +lisp_thread_entry(void *param) +{ + thread_activation *activation = (thread_activation *)param; + TCR *tcr = new_tcr(activation->vsize, activation->tsize); + LispObj *start_vsp; +#ifndef WINDOWS + sigset_t mask, old_mask; + + sigemptyset(&mask); + pthread_sigmask(SIG_SETMASK, &mask, &old_mask); +#endif + + register_thread_tcr(tcr); + +#ifndef WINDOWS + pthread_cleanup_push(tcr_cleanup,(void *)tcr); +#endif + tcr->vs_area->active -= node_size; + *(--tcr->save_vsp) = lisp_nil; + start_vsp = tcr->save_vsp; + enable_fp_exceptions(); + SET_TCR_FLAG(tcr,TCR_FLAG_BIT_AWAITING_PRESET); + activation->tcr = tcr; + SEM_RAISE(activation->created); + do { + SEM_RAISE(tcr->reset_completion); + SEM_WAIT_FOREVER(tcr->activate); + /* Now go run some lisp code */ + start_lisp(TCR_TO_TSD(tcr),0); + tcr->save_vsp = start_vsp; + } while (tcr->flags & (1<save_vsp; + do { + SEM_RAISE(tcr->reset_completion); + suspend_current_cooperative_thread(); + + start_lisp(tcr, 0); + tcr->save_vsp = start_vsp; + } while (tcr->flags & (1<next; + } while (p != head); + return false; +} + +#ifdef WINDOWS +OSErr +xDisposeThread(TCR *tcr) +{ + return 0; /* I don't think that this is ever called. */ +} +#else +OSErr +xDisposeThread(TCR *tcr) +{ + if (tcr != (TCR *)ptr_from_lispobj(lisp_global(INITIAL_TCR))) { + if (active_tcr_p(tcr) && (tcr != get_tcr(false))) { + pthread_cancel((pthread_t)(tcr->osid)); + return 0; + } + } + return -50; +} +#endif + +OSErr +xYieldToThread(TCR *target) +{ + Bug(NULL, "xYieldToThread ?"); + return 0; +} + +OSErr +xThreadCurrentStackSpace(TCR *tcr, unsigned *resultP) +{ + Bug(NULL, "xThreadCurrentStackSpace ?"); + return 0; +} + + +#ifdef WINDOWS +LispObj +create_system_thread(size_t stack_size, + void* stackaddr, + unsigned CALLBACK (*start_routine)(void *), + void* param) +{ + HANDLE thread_handle; + + stack_size = ((stack_size+(((1<<16)-1)))&~((1<<16)-1)); + + thread_handle = (HANDLE)_beginthreadex(NULL, + 0/*stack_size*/, + start_routine, + param, + 0, + NULL); + + if (thread_handle == NULL) { + wperror("CreateThread"); + } + return (LispObj) ptr_to_lispobj(thread_handle); +} +#else +LispObj +create_system_thread(size_t stack_size, + void* stackaddr, + void* (*start_routine)(void *), + void* param) +{ + pthread_attr_t attr; + pthread_t returned_thread = (pthread_t) 0; + TCR *current = get_tcr(true); + + pthread_attr_init(&attr); + pthread_attr_setdetachstate(&attr, PTHREAD_CREATE_DETACHED); + + if (stack_size == MINIMAL_THREAD_STACK_SIZE) { + stack_size = PTHREAD_STACK_MIN; + } + + stack_size = ensure_stack_limit(stack_size); + if (stackaddr != NULL) { + /* Size must have been specified. Sort of makes sense ... */ +#ifdef DARWIN + Fatal("no pthread_attr_setsetstack. "," Which end of stack does address refer to?"); +#else + pthread_attr_setstack(&attr, stackaddr, stack_size); +#endif + } else if (stack_size != DEFAULT_THREAD_STACK_SIZE) { + pthread_attr_setstacksize(&attr,stack_size); + } + + /* + I think that's just about enough ... create the thread. + Well ... not quite enough. In Leopard (at least), many + pthread routines grab an internal spinlock when validating + their arguments. If we suspend a thread that owns this + spinlock, we deadlock. We can't in general keep that + from happening: if arbitrary C code is suspended while + it owns the spinlock, we still deadlock. It seems that + the best that we can do is to keep -this- code from + getting suspended (by grabbing TCR_AREA_LOCK) + */ + LOCK(lisp_global(TCR_AREA_LOCK),current); + pthread_create(&returned_thread, &attr, start_routine, param); + UNLOCK(lisp_global(TCR_AREA_LOCK),current); + pthread_attr_destroy(&attr); + return (LispObj) ptr_to_lispobj(returned_thread); +} +#endif + +TCR * +get_tcr(Boolean create) +{ +#ifdef HAVE_TLS + TCR *current = current_tcr; +#else + void *tsd = (void *)tsd_get(lisp_global(TCR_KEY)); + TCR *current = (tsd == NULL) ? NULL : TCR_FROM_TSD(tsd); +#endif + + if ((current == NULL) && create) { + LispObj callback_macptr = nrs_FOREIGN_THREAD_CONTROL.vcell, + callback_ptr = ((macptr *)ptr_from_lispobj(untag(callback_macptr)))->address; + int i, nbindwords = 0; + extern natural initial_stack_size; + + /* Make one. */ + current = new_tcr(initial_stack_size, MIN_TSTACK_SIZE); + SET_TCR_FLAG(current,TCR_FLAG_BIT_FOREIGN); + register_thread_tcr(current); +#ifdef DEBUG_TCR_CREATION +#ifndef WINDOWS + fprintf(dbgout, "\ncreating TCR for pthread 0x%x", pthread_self()); +#endif +#endif + current->vs_area->active -= node_size; + *(--current->save_vsp) = lisp_nil; +#ifdef PPC +#define NSAVEREGS 8 +#endif +#ifdef X8664 +#define NSAVEREGS 4 +#endif +#ifdef X8632 +#define NSAVEREGS 0 +#endif + for (i = 0; i < NSAVEREGS; i++) { + *(--current->save_vsp) = 0; + current->vs_area->active -= node_size; + } + nbindwords = ((int (*)())ptr_from_lispobj(callback_ptr))(-1); + for (i = 0; i < nbindwords; i++) { + *(--current->save_vsp) = 0; + current->vs_area->active -= node_size; + } + current->shutdown_count = 1; + ((void (*)())ptr_from_lispobj(callback_ptr))(0); + + } + + return current; +} + +#ifdef WINDOWS +void * +pc_luser_restore_windows_context(CONTEXT *pcontext, TCR *tcr, pc where) +{ + /* Thread has started to return from an exception. */ + if (where < restore_windows_context_iret) { + /* In the process of restoring registers; context still in + %rcx. Just make our suspend_context be the context + we're trying to restore, so that we'll resume from + the suspend in the same context that we're trying to + restore */ +#ifdef WIN_64 + *pcontext = * (CONTEXT *)(pcontext->Rcx); +#else + *pcontext = * (CONTEXT *)(pcontext->Ecx); +#endif + } else { + /* Most of the context has already been restored; fix %rcx + if need be, then restore ss:rsp, cs:rip, and flags. */ +#ifdef WIN_64 + x64_iret_frame *iret_frame = (x64_iret_frame *) (pcontext->Rsp); + + pcontext->Rip = iret_frame->Rip; + pcontext->SegCs = (WORD) iret_frame->Cs; + pcontext->EFlags = (DWORD) iret_frame->Rflags; + pcontext->Rsp = iret_frame->Rsp; + pcontext->SegSs = (WORD) iret_frame->Ss; +#else + ia32_iret_frame *iret_frame = (ia32_iret_frame *) (pcontext->Esp); + + pcontext->Eip = iret_frame->Eip; + pcontext->SegCs = (WORD) iret_frame->Cs; + pcontext->EFlags = (DWORD) iret_frame->EFlags; + pcontext->Esp += sizeof(ia32_iret_frame); +#endif + } + tcr->pending_exception_context = NULL; +} + +Boolean +suspend_tcr(TCR *tcr) +{ + int suspend_count = atomic_incf(&(tcr->suspend_count)); + DWORD rc; + if (suspend_count == 1) { + CONTEXT *pcontext = (CONTEXT *)tcr->native_thread_info; + HANDLE hthread = (HANDLE)(tcr->osid); + pc where; + area *cs = tcr->cs_area; + LispObj foreign_rsp; + + if (hthread == NULL) { + return false; + } + rc = SuspendThread(hthread); + if (rc == -1) { + /* If the thread's simply dead, we should handle that here */ + return false; + } + pcontext->ContextFlags = CONTEXT_ALL; + rc = GetThreadContext(hthread, pcontext); + if (rc == 0) { + return false; + } + where = (pc)(xpPC(pcontext)); + + if (tcr->valence == TCR_STATE_LISP) { + if ((where >= restore_windows_context_start) && + (where < restore_windows_context_end)) { + pc_luser_restore_windows_context(pcontext, tcr, where); + } else { + area *ts = tcr->ts_area; + /* If we're in the lisp heap, or in x86-spentry??.o, or in + x86-subprims??.o, or in the subprims jump table at #x15000, + or on the tstack ... we're just executing lisp code. Otherwise, + we got an exception while executing lisp code, but haven't + entered the handler yet (still in Windows exception glue + or switching stacks or something.) In the latter case, we + basically want to get to he handler and have it notice + the pending exception request, and suspend the thread at that + point. */ + if (!((where < (pc)lisp_global(HEAP_END)) && + (where >= (pc)lisp_global(HEAP_START))) && + !((where < spentry_end) && (where >= spentry_start)) && + !((where < subprims_end) && (where >= subprims_start)) && + !((where < (pc) 0x16000) && + (where >= (pc) 0x15000)) && + !((where < (pc) (ts->high)) && + (where >= (pc) (ts->low)))) { + /* The thread has lisp valence, but is not executing code + where we expect lisp code to be and is not exiting from + an exception handler. That pretty much means that it's + on its way into an exception handler; we have to handshake + until it enters an exception-wait state. */ + /* There are likely race conditions here */ + SET_TCR_FLAG(tcr,TCR_FLAG_BIT_PENDING_SUSPEND); + ResumeThread(hthread); + SEM_WAIT_FOREVER(tcr->suspend); + SuspendThread(hthread); + /* The thread is either waiting for its resume semaphore to + be signaled or is about to wait. Signal it now, while + the thread's suspended. */ + SEM_RAISE(tcr->resume); + pcontext->ContextFlags = CONTEXT_ALL; + GetThreadContext(hthread, pcontext); + } + } +#if 0 + } else { + if (tcr->valence == TCR_STATE_EXCEPTION_RETURN) { + if (!tcr->pending_exception_context) { + FBug(pcontext, "we're confused here."); + } + *pcontext = *tcr->pending_exception_context; + tcr->pending_exception_context = NULL; + tcr->valence = TCR_STATE_LISP; + } +#endif + } + tcr->suspend_context = pcontext; + return true; + } + return false; +} +#else +Boolean +suspend_tcr(TCR *tcr) +{ + int suspend_count = atomic_incf(&(tcr->suspend_count)); + pthread_t thread; + if (suspend_count == 1) { + thread = (pthread_t)(tcr->osid); + if ((thread != (pthread_t) 0) && + (pthread_kill(thread, thread_suspend_signal) == 0)) { + SET_TCR_FLAG(tcr,TCR_FLAG_BIT_SUSPEND_ACK_PENDING); + } else { + /* A problem using pthread_kill. On Darwin, this can happen + if the thread has had its signal mask surgically removed + by pthread_exit. If the native (Mach) thread can be suspended, + do that and return true; otherwise, flag the tcr as belonging + to a dead thread by setting tcr->osid to 0. + */ + tcr->osid = 0; + return false; + } + return true; + } + return false; +} +#endif + +#ifdef WINDOWS +Boolean +tcr_suspend_ack(TCR *tcr) +{ + return true; +} +#else +Boolean +tcr_suspend_ack(TCR *tcr) +{ + if (tcr->flags & (1<suspend); + tcr->flags &= ~(1<osid; + + if (osid) { + result = true; +#ifdef WINDOWS + /* What we really want to de hear is (something like) + forcing the thread to run quit_handler(). For now, + mark the TCR as dead and kill thw Windows thread. */ + tcr->osid = 0; + if (!TerminateThread((HANDLE)osid, 0)) { + result = false; + } else { + shutdown_thread_tcr(tcr); + } +#else + if (pthread_kill((pthread_t)osid,thread_kill_signal)) { + result = false; + } +#endif + } + } + UNLOCK(lisp_global(TCR_AREA_LOCK), current); + return result; +} + +Boolean +lisp_suspend_tcr(TCR *tcr) +{ + Boolean suspended; + TCR *current = get_tcr(true); + + LOCK(lisp_global(TCR_AREA_LOCK),current); + suspended = suspend_tcr(tcr); + if (suspended) { + while (!tcr_suspend_ack(tcr)); + } + UNLOCK(lisp_global(TCR_AREA_LOCK),current); + return suspended; +} + +#ifdef WINDOWS +Boolean +resume_tcr(TCR *tcr) +{ + int suspend_count = atomic_decf(&(tcr->suspend_count)), err; + DWORD rc; + if (suspend_count == 0) { + CONTEXT *context = tcr->suspend_context; + HANDLE hthread = (HANDLE)(tcr->osid); + + if (context) { + context->ContextFlags = CONTEXT_ALL; + tcr->suspend_context = NULL; + SetThreadContext(hthread,context); + rc = ResumeThread(hthread); + if (rc == -1) { + wperror("ResumeThread"); + return false; + } + return true; + } + } + return false; +} +#else +Boolean +resume_tcr(TCR *tcr) +{ + int suspend_count = atomic_decf(&(tcr->suspend_count)); + if (suspend_count == 0) { + void *s = (tcr->resume); + if (s != NULL) { + SEM_RAISE(s); + return true; + } + } + return false; +} +#endif + + + + +Boolean +lisp_resume_tcr(TCR *tcr) +{ + Boolean resumed; + TCR *current = get_tcr(true); + + LOCK(lisp_global(TCR_AREA_LOCK),current); + resumed = resume_tcr(tcr); + UNLOCK(lisp_global(TCR_AREA_LOCK), current); + return resumed; +} + + +TCR *freed_tcrs = NULL; + +void +enqueue_freed_tcr (TCR *tcr) +{ +#ifndef HAVE_TLS + tcr->next = freed_tcrs; + freed_tcrs = tcr; +#endif +} + +/* It's not clear that we can safely condemn a dead tcr's areas, since + we may not be able to call free() if a suspended thread owns a + malloc lock. At least make the areas appear to be empty. +*/ + + +void +normalize_dead_tcr_areas(TCR *tcr) +{ + area *a; + + a = tcr->vs_area; + if (a) { + a->active = a->high; + } + + a = tcr->ts_area; + if (a) { + a->active = a->high; + } + + a = tcr->cs_area; + if (a) { + a->active = a->high; + } +} + +void +free_freed_tcrs () +{ + TCR *current, *next; + + for (current = freed_tcrs; current; current = next) { + next = current->next; +#ifndef HAVE_TLS +#ifdef WIN32 + free(current->allocated); +#else + free(current); +#endif +#endif + } + freed_tcrs = NULL; +} + +void +suspend_other_threads(Boolean for_gc) +{ + TCR *current = get_tcr(true), *other, *next; + int dead_tcr_count = 0; + Boolean all_acked; + + LOCK(lisp_global(TCR_AREA_LOCK), current); + for (other = current->next; other != current; other = other->next) { + if ((other->osid != 0)) { + suspend_tcr(other); + if (other->osid == 0) { + dead_tcr_count++; + } + } else { + dead_tcr_count++; + } + } + + do { + all_acked = true; + for (other = current->next; other != current; other = other->next) { + if ((other->osid != 0)) { + if (!tcr_suspend_ack(other)) { + all_acked = false; + } + } + } + } while(! all_acked); + + + + /* All other threads are suspended; can safely delete dead tcrs now */ + if (dead_tcr_count) { + for (other = current->next; other != current; other = next) { + next = other->next; + if ((other->osid == 0)) { + normalize_dead_tcr_areas(other); + dequeue_tcr(other); + enqueue_freed_tcr(other); + } + } + } +} + +void +lisp_suspend_other_threads() +{ + suspend_other_threads(false); +} + +void +resume_other_threads(Boolean for_gc) +{ + TCR *current = get_tcr(true), *other; + for (other = current->next; other != current; other = other->next) { + if ((other->osid != 0)) { + resume_tcr(other); + } + } + free_freed_tcrs(); + UNLOCK(lisp_global(TCR_AREA_LOCK), current); +} + +void +lisp_resume_other_threads() +{ + resume_other_threads(false); +} + + + +rwlock * +rwlock_new() +{ + extern int cache_block_size; + + void *p = calloc(1,sizeof(rwlock)+cache_block_size-1); + rwlock *rw = NULL;; + + if (p) { + rw = (rwlock *) ((((natural)p)+cache_block_size-1) & (~(cache_block_size-1))); + rw->malloced_ptr = p; +#ifndef USE_FUTEX + rw->reader_signal = new_semaphore(0); + rw->writer_signal = new_semaphore(0); + if ((rw->reader_signal == NULL) || (rw->writer_signal == NULL)) { + if (rw->reader_signal) { + destroy_semaphore(&(rw->reader_signal)); + } else { + destroy_semaphore(&(rw->writer_signal)); + } + free(rw); + rw = NULL; + } +#endif + } + return rw; +} + + +/* + Try to get read access to a multiple-readers/single-writer lock. If + we already have read access, return success (indicating that the + lock is held another time. If we already have write access to the + lock ... that won't work; return EDEADLK. Wait until no other + thread has or is waiting for write access, then indicate that we + hold read access once. +*/ +#ifndef USE_FUTEX +int +rwlock_rlock(rwlock *rw, TCR *tcr, struct timespec *waitfor) +{ + int err = 0; + + LOCK_SPINLOCK(rw->spin, tcr); + + if (rw->writer == tcr) { + RELEASE_SPINLOCK(rw->spin); + return EDEADLK; + } + + while (rw->blocked_writers || (rw->state > 0)) { + rw->blocked_readers++; + RELEASE_SPINLOCK(rw->spin); + err = semaphore_maybe_timedwait(rw->reader_signal,waitfor); + LOCK_SPINLOCK(rw->spin,tcr); + rw->blocked_readers--; + if (err == EINTR) { + err = 0; + } + if (err) { + RELEASE_SPINLOCK(rw->spin); + return err; + } + } + rw->state--; + RELEASE_SPINLOCK(rw->spin); + return err; +} +#else +int +rwlock_rlock(rwlock *rw, TCR *tcr, struct timespec *waitfor) +{ + natural waitval; + + lock_futex(&rw->spin); + + if (rw->writer == tcr) { + unlock_futex(&rw->spin); + return EDEADLOCK; + } + while (1) { + if (rw->writer == NULL) { + --rw->state; + unlock_futex(&rw->spin); + return 0; + } + rw->blocked_readers++; + waitval = rw->reader_signal; + unlock_futex(&rw->spin); + futex_wait(&rw->reader_signal,waitval); + lock_futex(&rw->spin); + rw->blocked_readers--; + } + return 0; +} +#endif + + +/* + Try to obtain write access to the lock. + It is an error if we already have read access, but it's hard to + detect that. + If we already have write access, increment the count that indicates + that. + Otherwise, wait until the lock is not held for reading or writing, + then assert write access. +*/ + +#ifndef USE_FUTEX +int +rwlock_wlock(rwlock *rw, TCR *tcr, struct timespec *waitfor) +{ + int err = 0; + + LOCK_SPINLOCK(rw->spin,tcr); + if (rw->writer == tcr) { + rw->state++; + RELEASE_SPINLOCK(rw->spin); + return 0; + } + + while (rw->state != 0) { + rw->blocked_writers++; + RELEASE_SPINLOCK(rw->spin); + err = semaphore_maybe_timedwait(rw->writer_signal, waitfor); + LOCK_SPINLOCK(rw->spin,tcr); + rw->blocked_writers--; + if (err == EINTR) { + err = 0; + } + if (err) { + RELEASE_SPINLOCK(rw->spin); + return err; + } + } + rw->state = 1; + rw->writer = tcr; + RELEASE_SPINLOCK(rw->spin); + return err; +} + +#else +int +rwlock_wlock(rwlock *rw, TCR *tcr, struct timespec *waitfor) +{ + int err = 0; + natural waitval; + + lock_futex(&rw->spin); + if (rw->writer == tcr) { + rw->state++; + unlock_futex(&rw->spin); + return 0; + } + + while (rw->state != 0) { + rw->blocked_writers++; + waitval = rw->writer_signal; + unlock_futex(&rw->spin); + futex_wait(&rw->writer_signal,waitval); + lock_futex(&rw->spin); + rw->blocked_writers--; + } + rw->state = 1; + rw->writer = tcr; + unlock_futex(&rw->spin); + return err; +} +#endif + +/* + Sort of the same as above, only return EBUSY if we'd have to wait. +*/ +#ifndef USE_FUTEX +int +rwlock_try_wlock(rwlock *rw, TCR *tcr) +{ + int ret = EBUSY; + + LOCK_SPINLOCK(rw->spin,tcr); + if (rw->writer == tcr) { + rw->state++; + ret = 0; + } else { + if (rw->state == 0) { + rw->writer = tcr; + rw->state = 1; + ret = 0; + } + } + RELEASE_SPINLOCK(rw->spin); + return ret; +} +#else +int +rwlock_try_wlock(rwlock *rw, TCR *tcr) +{ + int ret = EBUSY; + + lock_futex(&rw->spin); + if (rw->writer == tcr) { + rw->state++; + ret = 0; + } else { + if (rw->state == 0) { + rw->writer = tcr; + rw->state = 1; + ret = 0; + } + } + unlock_futex(&rw->spin); + return ret; +} +#endif + +#ifndef USE_FUTEX +int +rwlock_try_rlock(rwlock *rw, TCR *tcr) +{ + int ret = EBUSY; + + LOCK_SPINLOCK(rw->spin,tcr); + if (rw->state <= 0) { + --rw->state; + ret = 0; + } + RELEASE_SPINLOCK(rw->spin); + return ret; +} +#else +int +rwlock_try_rlock(rwlock *rw, TCR *tcr) +{ + int ret = EBUSY; + + lock_futex(&rw->spin); + if (rw->state <= 0) { + --rw->state; + ret = 0; + } + unlock_futex(&rw->spin); + return ret; +} +#endif + + + +#ifndef USE_FUTEX +int +rwlock_unlock(rwlock *rw, TCR *tcr) +{ + + int err = 0; + natural blocked_readers = 0; + + LOCK_SPINLOCK(rw->spin,tcr); + if (rw->state > 0) { + if (rw->writer != tcr) { + err = EINVAL; + } else { + --rw->state; + if (rw->state == 0) { + rw->writer = NULL; + } + } + } else { + if (rw->state < 0) { + ++rw->state; + } else { + err = EINVAL; + } + } + if (err) { + RELEASE_SPINLOCK(rw->spin); + return err; + } + + if (rw->state == 0) { + if (rw->blocked_writers) { + SEM_RAISE(rw->writer_signal); + } else { + blocked_readers = rw->blocked_readers; + if (blocked_readers) { + SEM_BROADCAST(rw->reader_signal, blocked_readers); + } + } + } + RELEASE_SPINLOCK(rw->spin); + return 0; +} +#else +int +rwlock_unlock(rwlock *rw, TCR *tcr) +{ + + int err = 0; + + lock_futex(&rw->spin); + if (rw->state > 0) { + if (rw->writer != tcr) { + err = EINVAL; + } else { + --rw->state; + if (rw->state == 0) { + rw->writer = NULL; + } + } + } else { + if (rw->state < 0) { + ++rw->state; + } else { + err = EINVAL; + } + } + if (err) { + unlock_futex(&rw->spin); + return err; + } + + if (rw->state == 0) { + if (rw->blocked_writers) { + ++rw->writer_signal; + unlock_futex(&rw->spin); + futex_wake(&rw->writer_signal,1); + return 0; + } + if (rw->blocked_readers) { + ++rw->reader_signal; + unlock_futex(&rw->spin); + futex_wake(&rw->reader_signal, INT_MAX); + return 0; + } + } + unlock_futex(&rw->spin); + return 0; +} +#endif + + +void +rwlock_destroy(rwlock *rw) +{ +#ifndef USE_FUTEX + destroy_semaphore((void **)&rw->reader_signal); + destroy_semaphore((void **)&rw->writer_signal); +#endif + postGCfree((void *)(rw->malloced_ptr)); +} + + + Index: /branches/new-random/lisp-kernel/unix-calls.c =================================================================== --- /branches/new-random/lisp-kernel/unix-calls.c (revision 13309) +++ /branches/new-random/lisp-kernel/unix-calls.c (revision 13309) @@ -0,0 +1,143 @@ +/* + Copyright (C) 2008-2009, Clozure Associates and contributors + This file is part of Clozure CL. + + Clozure CL is licensed under the terms of the Lisp Lesser GNU Public + License , known as the LLGPL and distributed with Clozure CL as the + file "LICENSE". The LLGPL consists of a preamble and the LGPL, + which is distributed with Clozure CL as the file "LGPL". Where these + conflict, the preamble takes precedence. + + Clozure CL is referenced in the preamble as the "LIBRARY." + + The LLGPL is also available online at + http://opensource.franz.com/preamble.html +*/ + +/* Provide wrappers around some standard C library functions that + can't easily be called from CCL's FFI for some reason (or where + we want to override/extend the function's default behavior.) + + Functions in this file should be referenced via the kernel + imports table. + + Callers should generally expect standard C library error-handling + conventions (e.g., return -1 or NULL and set errno on error.) +*/ + +#define _LARGEFILE64_SOURCE +#include +#include +#include +#include +#include +#include +#include +#include + +ssize_t +lisp_read(int fd, void *buf, size_t count) +{ + return read(fd,buf,count); +} + +ssize_t +lisp_write(int fd, void *buf, size_t count) +{ + return write(fd,buf,count); +} + +int +lisp_open(char *path, int flags, mode_t mode) +{ + return open(path,flags,mode); +} + +int +lisp_fchmod(int fd, mode_t mode) +{ + return fchmod(fd,mode); +} + +int64_t +lisp_lseek(int fd, int64_t offset, int whence) +{ +#ifdef LINUX + return lseek64(fd,offset,whence); +#else + return lseek(fd,offset,whence); +#endif +} + +int +lisp_close(int fd) +{ + return close(fd); +} + +int +lisp_ftruncate(int fd, off_t length) +{ + return ftruncate(fd,length); +} + +int +lisp_stat(char *path, void *buf) +{ + return stat(path,buf); +} + +int +lisp_fstat(int fd, void *buf) +{ + return fstat(fd,buf); +} + + +int +lisp_futex(int *uaddr, int op, int val, void *timeout, int *uaddr2, int val3) +{ +#ifdef LINUX + return syscall(SYS_futex,uaddr,op,val,timeout,uaddr2,val3); +#else + errno = ENOSYS; + return -1; +#endif +} + +DIR * +lisp_opendir(char *path) +{ + return opendir(path); +} + +struct dirent * +lisp_readdir(DIR *dir) +{ + return readdir(dir); +} + +int +lisp_closedir(DIR *dir) +{ + return closedir(dir); +} + +int +lisp_pipe(int pipefd[2]) +{ + return pipe(pipefd); +} + +int +lisp_gettimeofday(struct timeval *tp, void *tzp) +{ + return gettimeofday(tp, tzp); +} + +int +lisp_sigexit(int signum) +{ + signal(signum, SIG_DFL); + return kill(getpid(), signum); +} Index: /branches/new-random/lisp-kernel/win32/.gdbinit =================================================================== --- /branches/new-random/lisp-kernel/win32/.gdbinit (revision 13309) +++ /branches/new-random/lisp-kernel/win32/.gdbinit (revision 13309) @@ -0,0 +1,51 @@ +directory lisp-kernel + +define pl + call print_lisp_object($arg0) +end + +define showlist + set $l=$arg0 + while $l != 0x3001 + set $car = *((LispObj *)($l+3)) + set $l = *((LispObj *)($l-1)) + pl $car + end +end + + +define fn + pl $edi +end + +define arg_y + pl $esi +end + +define arg_z + pl $ebx +end + +define offset + p (int)$pc-$edi +end + + +break Bug +break FBug + +display/i $pc + +handle SIGKILL pass nostop noprint +handle SIGILL pass nostop noprint +handle SIGSEGV pass nostop noprint +handle SIGBUS pass nostop noprint +handle SIGFPE pass nostop noprint +handle SIGUSR1 pass nostop noprint +handle SIGUSR2 pass nostop noprint +handle SIGEMT pass nostop noprint +# Work around apparent Apple GDB bug +handle SIGTTIN nopass nostop noprint +# Work around Leopard bug du jour +handle SIGSYS pass nostop noprint + Index: /branches/new-random/lisp-kernel/win32/Makefile =================================================================== --- /branches/new-random/lisp-kernel/win32/Makefile (revision 13309) +++ /branches/new-random/lisp-kernel/win32/Makefile (revision 13309) @@ -0,0 +1,109 @@ +# +# Copyright (C) 2008 Clozure Associates +# This file is part of Clozure CL. +# +# Clozure CL is licensed under the terms of the Lisp Lesser GNU Public +# License , known as the LLGPL and distributed with Clozure CL as the +# file "LICENSE". The LLGPL consists of a preamble and the LGPL, +# which is distributed with Clozure CL as the file "LGPL". Where these +# conflict, the preamble takes precedence. +# +# Clozure CL is referenced in the preamble as the "LIBRARY." +# +# The LLGPL is also available online at +# http://opensource.franz.com/preamble.html + + +VPATH = ../ +RM = /bin/rm +CC = gcc +AS = as +M4 = m4 +LD = ld +ASFLAGS = -g --32 +M4FLAGS = -DWIN_32 -DWINDOWS -DX86 -DX8632 -DWIN32_ES_HACK +CDEFINES = -DWIN_32 -DWINDOWS -D_REENTRANT -DX86 -DX8632 -D_GNU_SOURCE -D__MSVCRT__ -D__MSVCRT_VERSION__=0x700 -D_WIN32_WINNT=0x0502 -DWIN32_ES_HACK +CDEBUG = -g +COPT = -O2 + +# If the linker supports a "--hash-style=" option, use traditional +# SysV hash tables. (If it doesn't support that option, assume +# that traditional hash tables will be used by default.) +ld_has_hash_style = $(shell $(LD) --help | grep "hash-style=") +ifeq ($(ld_has_hash_style),) +HASH_STYLE= +else +HASH_STYLE="-Wl,--hash-style=sysv" +endif + +CRT2 = $(shell $(CC) -mno-cygwin -print-file-name=crt2.o) + +# There may be some confusion about whether or not C symbols have +# leading underscores or not. The assembler sources seem to +# expect them to and mingw import libs seem to use them, but +# it's not clear whether or not native win64 libraries use this +# convention (and I'm not sure whether the Cygwin-hosted win64 +# toolchain behaves the same way as when hosted on Linux ... +# The compiler default seems to be to use them; if we want to +# suppress their use, uncomment the following: + +SUPPRESS_UNDERSCORES=#-fno-leading-underscore + +.s.o: + $(M4) $(M4FLAGS) -I../ $< | $(AS) $(ASFLAGS) -o $@ +.c.o: + $(CC) -c $< $(CDEFINES) $(CDEBUG) $(COPT) ${SUPPRESS_UNDERSCORES} -mno-cygwin -o $@ + +# order matters: x86-spjump32.o must be first. +SPOBJ = x86-spjump32.o x86-spentry32.o x86-subprims32.o +ASMOBJ = x86-asmutils32.o imports.o + +COBJ = pmcl-kernel.o gc-common.o x86-gc.o bits.o x86-exceptions.o \ + image.o thread_manager.o lisp-debug.o memory.o windows-calls.o + +DEBUGOBJ = lispdcmd.o plprint.o plsym.o xlbt.o x86_print.o +KERNELOBJ= $(COBJ) x86-asmutils32.o imports.o + +SPINC = lisp.s m4macros.m4 x86-constants.s x86-macros.s errors.s x86-uuo.s \ + x86-constants32.s + +CHEADERS = area.h bits.h x86-constants.h lisp-errors.h gc.h lisp.h \ + lisp-exceptions.h lisp_globals.h macros.h memprotect.h image.h \ + Threads.h x86-constants32.h x86-exceptions.h lisptypes.h + + +KSPOBJ = $(SPOBJ) +all: ../../wx86cl.exe + +# Order matters: libs that provide definitions must follow libs that +# reference them. (It's legal to use -lfoo multiple times to try to +# work around this.) +LIBGCC = $(shell $(CC) -mno-cygwin -print-libgcc-file-name) +OSLIBS = -L/usr/lib/w32api -L/mingw/lib -L/usr/lib/mingw\ + -lm -lpsapi -lws2_32 -lmingw32 $(LIBGCC) -lmoldname -lmingwex \ + -lmsvcrt -luser32 -lkernel32 -ladvapi32 -lshell32 $(GCCLIB) \ + -lmoldname -lmingwex -lmsvcrt + + + +IMAGE_BASE =--image-base=0x10000 + +../../wx86cl.exe: $(KSPOBJ) $(KERNELOBJ) $(DEBUGOBJ) Makefile + ld -o ../../wx86cl.exe $(IMAGE_BASE) --enable-auto-import \ + $(KSPOBJ) $(KERNELOBJ) $(DEBUGOBJ) $(CRT2) $(OSLIBS) $(LIBGCC) $(LATELIBS) + + +$(SPOBJ): $(SPINC) +$(ASMOBJ): $(SPINC) +$(COBJ): $(CHEADERS) +$(DEBUGOBJ): $(CHEADERS) lispdcmd.h + + +cclean: + $(RM) -f $(KERNELOBJ) $(DEBUGOBJ) ../../wx86cl.exe + +clean: cclean + $(RM) -f $(SPOBJ) + +strip: ../../wx86cl.exe + strip -g ../../wx86cl.exe Index: /branches/new-random/lisp-kernel/win32/pei-ia32.x =================================================================== --- /branches/new-random/lisp-kernel/win32/pei-ia32.x (revision 13309) +++ /branches/new-random/lisp-kernel/win32/pei-ia32.x (revision 13309) @@ -0,0 +1,205 @@ +OUTPUT_FORMAT(pei-i386) +SEARCH_DIR("=/usr/local/lib"); SEARCH_DIR("=/lib"); SEARCH_DIR("=/usr/lib"); +SECTIONS +{ + . = SIZEOF_HEADERS; + . = ALIGN(__section_alignment__); + .spfoo __image_base__ + __section_alignment__ : + { + __spfoo_start__ = . ; + . = __spfoo_start__ + 0x10000 ; + __spfoo_end__ = . ; + } + .text BLOCK(__section_alignment__) : + { + *(.init) + *(.text) + *(SORT(.text$*)) + *(.glue_7t) + *(.glue_7) + ___CTOR_LIST__ = .; __CTOR_LIST__ = . ; + LONG (-1);*(.ctors); *(.ctor); *(SORT(.ctors.*)); LONG (0); + ___DTOR_LIST__ = .; __DTOR_LIST__ = . ; + LONG (-1); *(.dtors); *(.dtor); *(SORT(.dtors.*)); LONG (0); + *(.fini) + /* ??? Why is .gcc_exc here? */ + *(.gcc_exc) + PROVIDE (etext = .); + *(.gcc_except_table) + } + /* The Cygwin32 library uses a section to avoid copying certain data + on fork. This used to be named ".data". The linker used + to include this between __data_start__ and __data_end__, but that + breaks building the cygwin32 dll. Instead, we name the section + ".data_cygwin_nocopy" and explictly include it after __data_end__. */ + .data BLOCK(__section_alignment__) : + { + __data_start__ = . ; + *(.data) + *(.data2) + *(SORT(.data$*)) + *(.jcr) + __data_end__ = . ; + *(.data_cygwin_nocopy) + } + .rdata BLOCK(__section_alignment__) : + { + *(.rdata) + *(SORT(.rdata$*)) + *(.eh_frame) + ___RUNTIME_PSEUDO_RELOC_LIST__ = .; + __RUNTIME_PSEUDO_RELOC_LIST__ = .; + *(.rdata_runtime_pseudo_reloc) + ___RUNTIME_PSEUDO_RELOC_LIST_END__ = .; + __RUNTIME_PSEUDO_RELOC_LIST_END__ = .; + } + .pdata BLOCK(__section_alignment__) : + { + *(.pdata) + } + .bss BLOCK(__section_alignment__) : + { + __bss_start__ = . ; + *(.bss) + *(COMMON) + __bss_end__ = . ; + } + .edata BLOCK(__section_alignment__) : + { + *(.edata) + } + /DISCARD/ : + { + *(.debug$S) + *(.debug$T) + *(.debug$F) + *(.drectve) + } + .idata BLOCK(__section_alignment__) : + { + /* This cannot currently be handled with grouped sections. + See pe.em:sort_sections. */ + SORT(*)(.idata$2) + SORT(*)(.idata$3) + /* These zeroes mark the end of the import list. */ + LONG (0); LONG (0); LONG (0); LONG (0); LONG (0); + SORT(*)(.idata$4) + SORT(*)(.idata$5) + SORT(*)(.idata$6) + SORT(*)(.idata$7) + } + .CRT BLOCK(__section_alignment__) : + { + ___crt_xc_start__ = . ; + *(SORT(.CRT$XC*)) /* C initialization */ + ___crt_xc_end__ = . ; + ___crt_xi_start__ = . ; + *(SORT(.CRT$XI*)) /* C++ initialization */ + ___crt_xi_end__ = . ; + ___crt_xl_start__ = . ; + *(SORT(.CRT$XL*)) /* TLS callbacks */ + /* ___crt_xl_end__ is defined in the TLS Directory support code */ + ___crt_xp_start__ = . ; + *(SORT(.CRT$XP*)) /* Pre-termination */ + ___crt_xp_end__ = . ; + ___crt_xt_start__ = . ; + *(SORT(.CRT$XT*)) /* Termination */ + ___crt_xt_end__ = . ; + } + .tls BLOCK(__section_alignment__) : + { + ___tls_start__ = . ; + *(.tls) + *(.tls$) + *(SORT(.tls$*)) + ___tls_end__ = . ; + } + .endjunk BLOCK(__section_alignment__) : + { + /* end is deprecated, don't use it */ + PROVIDE (end = .); + PROVIDE ( _end = .); + __end__ = .; + } + .rsrc BLOCK(__section_alignment__) : + { + *(.rsrc) + *(SORT(.rsrc$*)) + } + .reloc BLOCK(__section_alignment__) : + { + *(.reloc) + } + .stab BLOCK(__section_alignment__) (NOLOAD) : + { + *(.stab) + } + .stabstr BLOCK(__section_alignment__) (NOLOAD) : + { + *(.stabstr) + } + /* DWARF debug sections. + Symbols in the DWARF debugging sections are relative to the beginning + of the section. Unlike other targets that fake this by putting the + section VMA at 0, the PE format will not allow it. */ + /* DWARF 1.1 and DWARF 2. */ + .debug_aranges BLOCK(__section_alignment__) (NOLOAD) : + { + *(.debug_aranges) + } + .debug_pubnames BLOCK(__section_alignment__) (NOLOAD) : + { + *(.debug_pubnames) + } + /* DWARF 2. */ + .debug_info BLOCK(__section_alignment__) (NOLOAD) : + { + *(.debug_info) *(.gnu.linkonce.wi.*) + } + .debug_abbrev BLOCK(__section_alignment__) (NOLOAD) : + { + *(.debug_abbrev) + } + .debug_line BLOCK(__section_alignment__) (NOLOAD) : + { + *(.debug_line) + } + .debug_frame BLOCK(__section_alignment__) (NOLOAD) : + { + *(.debug_frame) + } + .debug_str BLOCK(__section_alignment__) (NOLOAD) : + { + *(.debug_str) + } + .debug_loc BLOCK(__section_alignment__) (NOLOAD) : + { + *(.debug_loc) + } + .debug_macinfo BLOCK(__section_alignment__) (NOLOAD) : + { + *(.debug_macinfo) + } + /* SGI/MIPS DWARF 2 extensions. */ + .debug_weaknames BLOCK(__section_alignment__) (NOLOAD) : + { + *(.debug_weaknames) + } + .debug_funcnames BLOCK(__section_alignment__) (NOLOAD) : + { + *(.debug_funcnames) + } + .debug_typenames BLOCK(__section_alignment__) (NOLOAD) : + { + *(.debug_typenames) + } + .debug_varnames BLOCK(__section_alignment__) (NOLOAD) : + { + *(.debug_varnames) + } + /* DWARF 3. */ + .debug_ranges BLOCK(__section_alignment__) (NOLOAD) : + { + *(.debug_ranges) + } +} Index: /branches/new-random/lisp-kernel/win64/.gdbinit =================================================================== --- /branches/new-random/lisp-kernel/win64/.gdbinit (revision 13309) +++ /branches/new-random/lisp-kernel/win64/.gdbinit (revision 13309) @@ -0,0 +1,85 @@ +directory lisp-kernel + +define x86_lisp_string +x/s $arg0-5 +end + +define gtra +br *$r10 +cont +end + +define x86pname +set $temp=*((long *)((long)($arg0-6))) +x86_lisp_string $temp +end + + +define pname + x86pname $arg0 +end + +define l + call print_lisp_object($arg0) +end + +define lw + l $r13 +end + +define clobber_breakpoint + set *(short *)($pc-2)=0x9090 +end + +define arg_z + l $rsi +end + +define arg_y + l $rdi +end + +define arg_x + l $r8 +end + +define bx + l $rbx +end + +define showlist + set $l=$arg0 + while $l != 0x200b + set $car = *((LispObj *)($l+5)) + set $l = *((LispObj *)($l-3)) + l $car + end +end + +define lbt + call plbt_sp($rbp) +end + +define ada + p/x *(all_areas->succ) +end + +define lregs + call debug_lisp_registers($arg0,0,0) +end + +break Bug + +display/i $pc + +handle SIGKILL pass nostop noprint +handle SIGILL pass nostop noprint +handle SIGSEGV pass nostop noprint +handle SIGBUS pass nostop noprint +handle SIGFPE pass nostop noprint +handle SIG40 pass nostop noprint +handle SIG41 pass nostop noprint +handle SIG42 pass nostop noprint +handle SIGPWR pass nostop noprint +handle SIGQUIT pass nostop noprint + Index: /branches/new-random/lisp-kernel/win64/Makefile =================================================================== --- /branches/new-random/lisp-kernel/win64/Makefile (revision 13309) +++ /branches/new-random/lisp-kernel/win64/Makefile (revision 13309) @@ -0,0 +1,98 @@ +# +# Copyright (C) 2007 Clozure Associates +# This file is part of Clozure CL. +# +# Clozure CL is licensed under the terms of the Lisp Lesser GNU Public +# License , known as the LLGPL and distributed with Clozure CL as the +# file "LICENSE". The LLGPL consists of a preamble and the LGPL, +# which is distributed with Clozure CL as the file "LGPL". Where these +# conflict, the preamble takes precedence. +# +# Clozure CL is referenced in the preamble as the "LIBRARY." +# +# The LLGPL is also available online at +# http://opensource.franz.com/preamble.html + + +VPATH = ../ +RM = /bin/rm +# gcc64, as64: until there's a real win64 gcc, assume that gcc and gas +# are installed under these names +CC = x86_64-w64-mingw32-gcc +AS = x86_64-w64-mingw32-as +M4 = m4 +LD = x86_64-w64-mingw32-ld +ASFLAGS = -g --64 +M4FLAGS = -DWIN_64 -DWINDOWS -DX86 -DX8664 -DHAVE_TLS -DEMUTLS -DTCR_IN_GPR +CDEFINES = -DWIN_64 -DWINDOWS -D_REENTRANT -DX86 -DX8664 -D_GNU_SOURCE -DHAVE_TLS -DEMUTLS -DTCR_IN_GPR +CDEBUG = -g +COPT = #-O2 + +# If the linker supports a "--hash-style=" option, use traditional +# SysV hash tables. (If it doesn't support that option, assume +# that traditional hash tables will be used by default.) +ld_has_hash_style = $(shell $(LD) --help | grep "hash-style=") +ifeq ($(ld_has_hash_style),) +HASH_STYLE= +else +HASH_STYLE="-Wl,--hash-style=sysv" +endif + +# There may be some confusion about whether or not C symbols have +# leading underscores or not. The assembler sources seem to +# expect them to and mingw import libs seem to use them, but +# it's not clear whether or not native win64 libraries use this +# convention (and I'm not sure whether the Cygwin-hosted win64 +# toolchain behaves the same was as when hosted on Linux ... +# The compiler default seems to be to use them; if we want to +# suppress their use, uncomment the following: + +SUPPRESS_UNDERSCORES=#-fno-leading-underscore + +.s.o: + $(M4) $(M4FLAGS) -I../ $< | $(AS) $(ASFLAGS) -o $@ +.c.o: + $(CC) -c $< $(CDEFINES) $(CDEBUG) $(COPT) ${SUPPRESS_UNDERSCORES} -m64 -o $@ + +SPOBJ = pad.o x86-spjump64.o x86-spentry64.o x86-subprims64.o +ASMOBJ = x86-asmutils64.o imports.o + +COBJ = pmcl-kernel.o gc-common.o x86-gc.o bits.o x86-exceptions.o \ + image.o thread_manager.o lisp-debug.o memory.o windows-calls.o + +DEBUGOBJ = lispdcmd.o plprint.o plsym.o xlbt.o x86_print.o +KERNELOBJ= $(COBJ) x86-asmutils64.o imports.o + +SPINC = lisp.s m4macros.m4 x86-constants.s x86-macros.s errors.s x86-uuo.s \ + x86-constants64.s + +CHEADERS = area.h bits.h x86-constants.h lisp-errors.h gc.h lisp.h \ + lisp-exceptions.h lisp_globals.h macros.h memprotect.h image.h \ + Threads.h x86-constants64.h x86-exceptions.h lisptypes.h + + +KSPOBJ = $(SPOBJ) +all: ../../wx86cl64.exe + + +OSLIBS = -lpsapi -lws2_32 + + +../../wx86cl64.exe: $(KSPOBJ) $(KERNELOBJ) $(DEBUGOBJ) Makefile pei-x86-64.x + $(CC) -Wl,--image-base=0x10000 -Wl,-script=pei-x86-64.x -m64 $(CDEBUG) -Wl,--export-dynamic $(HASH_STYLE) -o $@ $(USE_LINK_MAP) $(KSPOBJ) $(KERNELOBJ) $(DEBUGOBJ) $(OSLIBS) + + +$(SPOBJ): $(SPINC) +$(ASMOBJ): $(SPINC) +$(COBJ): $(CHEADERS) +$(DEBUGOBJ): $(CHEADERS) lispdcmd.h + + +cclean: + $(RM) -f $(KERNELOBJ) $(DEBUGOBJ) ../../wx86cl64.exe + +clean: cclean + $(RM) -f $(SPOBJ) + +strip: ../../wx86cl64.exe + strip -g ../../wx86cl64.exe Index: /branches/new-random/lisp-kernel/win64/Makefile.nmake =================================================================== --- /branches/new-random/lisp-kernel/win64/Makefile.nmake (revision 13309) +++ /branches/new-random/lisp-kernel/win64/Makefile.nmake (revision 13309) @@ -0,0 +1,83 @@ +# +# Copyright (C) 2008 Clozure Associates +# This file is part of OpenMCL. +# +# OpenMCL is licensed under the terms of the Lisp Lesser GNU Public +# License , known as the LLGPL and distributed with OpenMCL as the +# file "LICENSE". The LLGPL consists of a preamble and the LGPL, +# which is distributed with OpenMCL as the file "LGPL". Where these +# conflict, the preamble takes precedence. +# +# OpenMCL is referenced in the preamble as the "LIBRARY." +# +# The LLGPL is also available online at +# http://opensource.franz.com/preamble.html + + +# With nmake, VPATH is broken. Invoke from the directory above: +# +# Z:\ccl-source\lisp-kernel> nmake /f win64/Makefile.nmake + +RM = del +CC = cl +M4 = m4 +MV = move +LD = link +ASFLAGS = -f win64 -g cv8 -p gas +AS = yasm +M4FLAGS = -DWIN64 -DWINDOWS -DX86 -DX8664 -DHAVE_TLS -DEMUTLS +CDEFINES = /I.. /DWIN64 /DWINDOWS /D_REENTRANT /DX86 /DX8664 /D_GNU_SOURCE /DHAVE_TLS /DEMUTLS /DVC #-DDISABLE_EGC +CDEBUG = /Zi +COPT = +LDFLAGS = + +.SUFFIXES : .exe .obj .c .asm .s + +.s.asm: + $(M4) $(M4FLAGS) -I. $< > $@.temp && mv $@.temp $@ +.asm.obj: + $(AS) $(ASFLAGS) -o $@ $< +.c.obj: + $(CC) /c $< $(CDEFINES) $(CDEBUG) $(COPT) + +SPOBJ = pad.obj x86-spjump64.obj x86-spentry64.obj x86-subprims64.obj +ASMOBJ = x86-asmutils64.obj imports.obj + +COBJ = pmcl-kernel.obj gc-common.obj x86-gc.obj bits.obj x86-exceptions.obj \ + image.obj thread_manager.obj lisp-debug.obj memory.obj + +DEBUGOBJ = lispdcmd.obj plprint.obj plsym.obj xlbt.obj x86_print.obj +KERNELOBJ= $(COBJ) x86-asmutils64.obj imports.obj + +SPINC = lisp.s m4macros.m4 x86-constants.s x86-macros.s errors.s x86-uuo.s \ + x86-constants64.s + +CHEADERS = area.h bits.h x86-constants.h lisp-errors.h gc.h lisp.h \ + lisp-exceptions.h lisp_globals.h macros.h memprotect.h image.h \ + Threads.h x86-constants64.h x86-exceptions.h lisptypes.h + + +KSPOBJ = $(SPOBJ) +all: ..\wx86cl64 + +OSLIBS = bufferoverflowu.lib + +..\wx86cl64: $(KSPOBJ) $(KERNELOBJ) $(DEBUGOBJ) Makefile + $(LD) $(LDFLAGS) /out:$@ $(KSPOBJ) $(KERNELOBJ) $(DEBUGOBJ) $(OSLIBS) + +cobjs: $(COBJ) + +$(SPOBJ): $(SPINC) +$(ASMOBJ): $(SPINC) +$(COBJ): $(CHEADERS) +$(DEBUGOBJ): $(CHEADERS) lispdcmd.h + + +cclean: + $(RM) $(KERNELOBJ) $(DEBUGOBJ) ../../wx86cl64 + +clean: cclean + $(RM) $(SPOBJ) + +strip: ../../wx86cl64 + strip -g ../../wx86cl64 Index: /branches/new-random/lisp-kernel/win64/pei-x86-64.x =================================================================== --- /branches/new-random/lisp-kernel/win64/pei-x86-64.x (revision 13309) +++ /branches/new-random/lisp-kernel/win64/pei-x86-64.x (revision 13309) @@ -0,0 +1,205 @@ +OUTPUT_FORMAT(pei-x86-64) +SEARCH_DIR("=/usr/local/lib"); SEARCH_DIR("=/lib"); SEARCH_DIR("=/usr/lib"); +SECTIONS +{ + . = SIZEOF_HEADERS; + . = ALIGN(__section_alignment__); + .spfoo __image_base__ + __section_alignment__ : + { + __spfoo_start__ = . ; + . = __spfoo_start__ + 0x10000 ; + __spfoo_end__ = . ; + } + .text BLOCK(__section_alignment__) : + { + *(.init) + *(.text) + *(SORT(.text$*)) + *(.glue_7t) + *(.glue_7) + ___CTOR_LIST__ = .; __CTOR_LIST__ = . ; + LONG (-1); LONG (-1);*(.ctors); *(.ctor); *(SORT(.ctors.*)); LONG (0); LONG (0); + ___DTOR_LIST__ = .; __DTOR_LIST__ = . ; + LONG (-1); LONG (-1); *(.dtors); *(.dtor); *(SORT(.dtors.*)); LONG (0); LONG (0); + *(.fini) + /* ??? Why is .gcc_exc here? */ + *(.gcc_exc) + PROVIDE (etext = .); + *(.gcc_except_table) + } + /* The Cygwin32 library uses a section to avoid copying certain data + on fork. This used to be named ".data". The linker used + to include this between __data_start__ and __data_end__, but that + breaks building the cygwin32 dll. Instead, we name the section + ".data_cygwin_nocopy" and explictly include it after __data_end__. */ + .data BLOCK(__section_alignment__) : + { + __data_start__ = . ; + *(.data) + *(.data2) + *(SORT(.data$*)) + *(.jcr) + __data_end__ = . ; + *(.data_cygwin_nocopy) + } + .rdata BLOCK(__section_alignment__) : + { + *(.rdata) + *(SORT(.rdata$*)) + *(.eh_frame) + ___RUNTIME_PSEUDO_RELOC_LIST__ = .; + __RUNTIME_PSEUDO_RELOC_LIST__ = .; + *(.rdata_runtime_pseudo_reloc) + ___RUNTIME_PSEUDO_RELOC_LIST_END__ = .; + __RUNTIME_PSEUDO_RELOC_LIST_END__ = .; + } + .pdata BLOCK(__section_alignment__) : + { + *(.pdata) + } + .bss BLOCK(__section_alignment__) : + { + __bss_start__ = . ; + *(.bss) + *(COMMON) + __bss_end__ = . ; + } + .edata BLOCK(__section_alignment__) : + { + *(.edata) + } + /DISCARD/ : + { + *(.debug$S) + *(.debug$T) + *(.debug$F) + *(.drectve) + } + .idata BLOCK(__section_alignment__) : + { + /* This cannot currently be handled with grouped sections. + See pep.em:sort_sections. */ + SORT(*)(.idata$2) + SORT(*)(.idata$3) + /* These zeroes mark the end of the import list. */ + LONG (0); LONG (0); LONG (0); LONG (0); LONG (0); + SORT(*)(.idata$4) + SORT(*)(.idata$5) + SORT(*)(.idata$6) + SORT(*)(.idata$7) + } + .CRT BLOCK(__section_alignment__) : + { + ___crt_xc_start__ = . ; + *(SORT(.CRT$XC*)) /* C initialization */ + ___crt_xc_end__ = . ; + ___crt_xi_start__ = . ; + *(SORT(.CRT$XI*)) /* C++ initialization */ + ___crt_xi_end__ = . ; + ___crt_xl_start__ = . ; + *(SORT(.CRT$XL*)) /* TLS callbacks */ + /* ___crt_xl_end__ is defined in the TLS Directory support code */ + ___crt_xp_start__ = . ; + *(SORT(.CRT$XP*)) /* Pre-termination */ + ___crt_xp_end__ = . ; + ___crt_xt_start__ = . ; + *(SORT(.CRT$XT*)) /* Termination */ + ___crt_xt_end__ = . ; + } + .tls BLOCK(__section_alignment__) : + { + ___tls_start__ = . ; + *(.tls) + *(.tls$) + *(SORT(.tls$*)) + ___tls_end__ = . ; + } + .endjunk BLOCK(__section_alignment__) : + { + /* end is deprecated, don't use it */ + PROVIDE (end = .); + PROVIDE ( _end = .); + __end__ = .; + } + .rsrc BLOCK(__section_alignment__) : + { + *(.rsrc) + *(SORT(.rsrc$*)) + } + .reloc BLOCK(__section_alignment__) : + { + *(.reloc) + } + .stab BLOCK(__section_alignment__) (NOLOAD) : + { + *(.stab) + } + .stabstr BLOCK(__section_alignment__) (NOLOAD) : + { + *(.stabstr) + } + /* DWARF debug sections. + Symbols in the DWARF debugging sections are relative to the beginning + of the section. Unlike other targets that fake this by putting the + section VMA at 0, the PE format will not allow it. */ + /* DWARF 1.1 and DWARF 2. */ + .debug_aranges BLOCK(__section_alignment__) (NOLOAD) : + { + *(.debug_aranges) + } + .debug_pubnames BLOCK(__section_alignment__) (NOLOAD) : + { + *(.debug_pubnames) + } + /* DWARF 2. */ + .debug_info BLOCK(__section_alignment__) (NOLOAD) : + { + *(.debug_info) *(.gnu.linkonce.wi.*) + } + .debug_abbrev BLOCK(__section_alignment__) (NOLOAD) : + { + *(.debug_abbrev) + } + .debug_line BLOCK(__section_alignment__) (NOLOAD) : + { + *(.debug_line) + } + .debug_frame BLOCK(__section_alignment__) (NOLOAD) : + { + *(.debug_frame) + } + .debug_str BLOCK(__section_alignment__) (NOLOAD) : + { + *(.debug_str) + } + .debug_loc BLOCK(__section_alignment__) (NOLOAD) : + { + *(.debug_loc) + } + .debug_macinfo BLOCK(__section_alignment__) (NOLOAD) : + { + *(.debug_macinfo) + } + /* SGI/MIPS DWARF 2 extensions. */ + .debug_weaknames BLOCK(__section_alignment__) (NOLOAD) : + { + *(.debug_weaknames) + } + .debug_funcnames BLOCK(__section_alignment__) (NOLOAD) : + { + *(.debug_funcnames) + } + .debug_typenames BLOCK(__section_alignment__) (NOLOAD) : + { + *(.debug_typenames) + } + .debug_varnames BLOCK(__section_alignment__) (NOLOAD) : + { + *(.debug_varnames) + } + /* DWARF 3. */ + .debug_ranges BLOCK(__section_alignment__) (NOLOAD) : + { + *(.debug_ranges) + } +} Index: /branches/new-random/lisp-kernel/win64/yasm-redefinition.patch =================================================================== --- /branches/new-random/lisp-kernel/win64/yasm-redefinition.patch (revision 13309) +++ /branches/new-random/lisp-kernel/win64/yasm-redefinition.patch (revision 13309) @@ -0,0 +1,22 @@ +Index: libyasm/symrec.c +=================================================================== +--- libyasm/symrec.c (revision 2037) ++++ libyasm/symrec.c (working copy) +@@ -281,10 +281,15 @@ + yasm_symtab_define_equ(yasm_symtab *symtab, const char *name, yasm_expr *e, + unsigned long line) + { +- yasm_symrec *rec = symtab_define(symtab, name, SYM_EQU, 1, line); ++ yasm_symrec *rec = yasm_symtab_get(symtab, name); ++ if (rec) { ++ /* redefinition. Emit warning here. */ ++ } else { ++ rec = symtab_define(symtab, name, SYM_EQU, 1, line); ++ } + if (yasm_error_occurred()) + return rec; +- rec->value.expn = e; ++ rec->value.expn = yasm_expr_simplify(e, 1); + rec->status |= YASM_SYM_VALUED; + return rec; + } Index: /branches/new-random/lisp-kernel/windows-calls.c =================================================================== --- /branches/new-random/lisp-kernel/windows-calls.c (revision 13309) +++ /branches/new-random/lisp-kernel/windows-calls.c (revision 13309) @@ -0,0 +1,1015 @@ +/* + Copyright (C) 2008-2009, Clozure Associates and contributors, + This file is part of Clozure CL. + + Clozure CL is licensed under the terms of the Lisp Lesser GNU Public + License , known as the LLGPL and distributed with Clozure CL as the + file "LICENSE". The LLGPL consists of a preamble and the LGPL, + which is distributed with Clozure CL as the file "LGPL". Where these + conflict, the preamble takes precedence. + + Clozure CL is referenced in the preamble as the "LIBRARY." + + The LLGPL is also available online at + http://opensource.franz.com/preamble.html +*/ + +#include "lisp.h" +#include "x86-exceptions.h" +#include +#include +#include +#include +#include +#include +#include +#include +#include +#undef __argv +#include +#include + +#ifndef WIN_32 +#define _dosmaperr mingw_dosmaperr +#else +void +_dosmaperr(unsigned long oserrno) +{ + switch(oserrno) { + case ERROR_INVALID_FUNCTION: + errno = EINVAL; + break; + case ERROR_FILE_NOT_FOUND: + errno = ENOENT; + break; + case ERROR_PATH_NOT_FOUND: + errno = ENOENT; + break; + case ERROR_TOO_MANY_OPEN_FILES: + errno = EMFILE; + break; + case ERROR_ACCESS_DENIED: + errno = EACCES; + break; + case ERROR_ARENA_TRASHED: + errno = ENOMEM; + break; + case ERROR_NOT_ENOUGH_MEMORY: + errno = ENOMEM; + break; + case ERROR_INVALID_BLOCK: + errno = ENOMEM; + break; + case ERROR_BAD_ENVIRONMENT: + errno = E2BIG; + break; + case ERROR_BAD_FORMAT: + errno = ENOEXEC; + break; + case ERROR_INVALID_ACCESS: + errno = EINVAL; + break; + case ERROR_INVALID_DATA: + errno = EINVAL; + break; + case ERROR_INVALID_DRIVE: + errno = ENOENT; + break; + case ERROR_CURRENT_DIRECTORY: + errno = EACCES; + break; + case ERROR_NOT_SAME_DEVICE: + errno = EXDEV; + break; + case ERROR_NO_MORE_FILES: + errno = ENOENT; + break; + case ERROR_LOCK_VIOLATION: + errno = EACCES; + break; + case ERROR_BAD_NETPATH: + errno = ENOENT; + break; + case ERROR_NETWORK_ACCESS_DENIED: + errno = EACCES; + break; + case ERROR_BAD_NET_NAME: + errno = ENOENT; + break; + case ERROR_FILE_EXISTS: + errno = EEXIST; + break; + case ERROR_CANNOT_MAKE: + errno = EACCES; + break; + case ERROR_FAIL_I24: + errno = EACCES; + break; + case ERROR_INVALID_PARAMETER: + errno = EINVAL; + break; + case ERROR_NO_PROC_SLOTS: + errno = EAGAIN; + break; + case ERROR_DRIVE_LOCKED: + errno = EACCES; + break; + case ERROR_BROKEN_PIPE: + errno = EPIPE; + break; + case ERROR_DISK_FULL: + errno = ENOSPC; + break; + case ERROR_INVALID_TARGET_HANDLE: + errno = EBADF; + break; + case ERROR_INVALID_HANDLE: + errno = EINVAL; + break; + case ERROR_WAIT_NO_CHILDREN: + errno = ECHILD; + break; + case ERROR_CHILD_NOT_COMPLETE: + errno = ECHILD; + break; + case ERROR_DIRECT_ACCESS_HANDLE: + errno = EBADF; + break; + case ERROR_NEGATIVE_SEEK: + errno = EINVAL; + break; + case ERROR_SEEK_ON_DEVICE: + errno = EACCES; + break; + case ERROR_DIR_NOT_EMPTY: + errno = ENOTEMPTY; + break; + case ERROR_NOT_LOCKED: + errno = EACCES; + break; + case ERROR_BAD_PATHNAME: + errno = ENOENT; + break; + case ERROR_MAX_THRDS_REACHED: + errno = EAGAIN; + break; + case ERROR_LOCK_FAILED: + errno = EACCES; + break; + case ERROR_ALREADY_EXISTS: + errno = EEXIST; + break; + case ERROR_FILENAME_EXCED_RANGE: + errno = ENOENT; + break; + case ERROR_NESTING_NOT_ALLOWED: + errno = EAGAIN; + break; + case ERROR_NOT_ENOUGH_QUOTA: + errno = ENOMEM; + break; + case ERROR_OPERATION_ABORTED: + errno = EINTR; + break; + default: + errno = EINVAL; + break; + } +} + +#endif + +#define MAX_FD 32 + +HANDLE +lisp_open(wchar_t *path, int flag, int mode) +{ + HANDLE hfile; + DWORD dwDesiredAccess = 0; + DWORD dwShareMode = 0; + DWORD dwCreationDistribution = 0; + DWORD dwFlagsAndAttributes = 0; + SECURITY_ATTRIBUTES sa = {sizeof(SECURITY_ATTRIBUTES), NULL, TRUE}; + + dwShareMode = FILE_SHARE_READ | FILE_SHARE_WRITE | FILE_SHARE_DELETE; + + if ((flag & _O_WRONLY) == _O_WRONLY) { + dwDesiredAccess |= GENERIC_WRITE; + } else if ((flag & _O_RDWR) == _O_RDWR) { + dwDesiredAccess |= GENERIC_WRITE|GENERIC_READ; + } else { + dwDesiredAccess |= GENERIC_READ; + } + + + if ((flag & (_O_CREAT | _O_EXCL)) == (_O_CREAT | _O_EXCL)) { + dwCreationDistribution |= CREATE_NEW; + } else if ((flag & O_TRUNC) == O_TRUNC) { + if ((flag & O_CREAT) == O_CREAT) { + dwCreationDistribution |= CREATE_ALWAYS; + } else if ((flag & O_RDONLY) != O_RDONLY) { + dwCreationDistribution |= TRUNCATE_EXISTING; + } + } else if ((flag & _O_APPEND) == _O_APPEND) { + dwCreationDistribution |= OPEN_EXISTING; + } else if ((flag & _O_CREAT) == _O_CREAT) { + dwCreationDistribution |= OPEN_ALWAYS; + } else { + dwCreationDistribution |= OPEN_EXISTING; + } + if ((flag & _O_RANDOM) == _O_RANDOM) { + dwFlagsAndAttributes |= FILE_FLAG_RANDOM_ACCESS; + } + if ((flag & _O_SEQUENTIAL) == _O_SEQUENTIAL) { + dwFlagsAndAttributes |= FILE_FLAG_SEQUENTIAL_SCAN; + } + + if ((flag & _O_TEMPORARY) == _O_TEMPORARY) { + dwFlagsAndAttributes |= FILE_FLAG_DELETE_ON_CLOSE; + } + + if ((flag & _O_SHORT_LIVED) == _O_SHORT_LIVED) { + dwFlagsAndAttributes |= FILE_FLAG_DELETE_ON_CLOSE; + } + + if (flag & _O_NOINHERIT) { + sa.bInheritHandle = FALSE; + } + +#if 0 + dwFlagsAndAttributes |= FILE_FLAG_OVERLAPPED; +#endif + + + hfile = CreateFileW(path, + dwDesiredAccess, + dwShareMode, + &sa, + dwCreationDistribution, + dwFlagsAndAttributes, + NULL); + if (hfile == ((HANDLE)-1)) { + _dosmaperr(GetLastError()); + return (HANDLE)-1; + } + return hfile; +} + +int +wopen(wchar_t *path, int flag, int mode) +{ + HANDLE h = lisp_open(path, flag, mode); + + if (h == (HANDLE)-1) { + return -1; /* errno already set */ + } + return _open_osfhandle((intptr_t)h,0); +} + +int +lisp_close(HANDLE hfile) +{ + int err; + + if (closesocket((SOCKET)hfile) == 0) { + return 0; + } + + err = WSAGetLastError(); + if (err != WSAENOTSOCK) { + _dosmaperr(err); + return -1; + } + if (CloseHandle(hfile)) { + return 0; + } + _dosmaperr(GetLastError()); + return -1; +} + +extern TCR *get_tcr(int); + +ssize_t +lisp_standard_read(HANDLE hfile, void *buf, unsigned int count) +{ + HANDLE hevent; + OVERLAPPED overlapped; + DWORD err, nread, wait_result; + pending_io pending; + TCR *tcr; + + + memset(&overlapped,0,sizeof(overlapped)); + + if (GetFileType(hfile) == FILE_TYPE_DISK) { + overlapped.Offset = SetFilePointer(hfile, 0, &(overlapped.OffsetHigh), FILE_CURRENT); + } + + tcr = (TCR *)get_tcr(1); + pending.h = hfile; + pending.o = &overlapped; + tcr->pending_io_info = &pending; + hevent = (HANDLE)(tcr->io_datum); + overlapped.hEvent = hevent; + ResetEvent(hevent); + if (ReadFile(hfile, buf, count, &nread, &overlapped)) { + tcr->pending_io_info = NULL; + return nread; + } + + err = GetLastError(); + + if (err == ERROR_HANDLE_EOF) { + tcr->pending_io_info = NULL; + return 0; + } + + if (err != ERROR_IO_PENDING) { + _dosmaperr(err); + tcr->pending_io_info = NULL; + return -1; + } + + err = 0; + + /* We block here */ + wait_result = WaitForSingleObjectEx(hevent, INFINITE, true); + + + + tcr->pending_io_info = NULL; + if (wait_result == WAIT_OBJECT_0) { + err = overlapped.Internal; + if (err == ERROR_HANDLE_EOF) { + return 0; + } + if (err) { + _dosmaperr(err); + return -1; + } + return overlapped.InternalHigh; + } + + if (wait_result == WAIT_IO_COMPLETION) { + CancelIo(hfile); + errno = EINTR; + return -1; + } + err = GetLastError(); + + + switch (err) { + case ERROR_HANDLE_EOF: + return 0; + default: + _dosmaperr(err); + return -1; + } +} + +ssize_t +pipe_read(HANDLE hfile, void *buf, unsigned int count) +{ + DWORD navail, err;; + + do { + navail = 0; + if (PeekNamedPipe(hfile, NULL, 0, NULL, &navail, NULL) == 0) { + err = GetLastError(); + if (err = ERROR_HANDLE_EOF) { + return 0; + } else { + _dosmaperr(err); + return -1; + } + } + if (navail != 0) { + return lisp_standard_read(hfile, buf, count); + } + if (SleepEx(50, TRUE) == WAIT_IO_COMPLETION) { + errno = EINTR; + return -1; + } + } while (1); +} + +ssize_t +console_read(HANDLE hfile, void *buf, unsigned int count) +{ + DWORD err, eventcount, i, n; + INPUT_RECORD ir; + + do { + err = WaitForSingleObjectEx(hfile, INFINITE, TRUE); + switch (err) { + case WAIT_OBJECT_0: + eventcount = 0; + GetNumberOfConsoleInputEvents(hfile, &eventcount); + for (i = 0; i < eventcount; i++) { + PeekConsoleInput(hfile, &ir, 1, &n); + if (ir.EventType == KEY_EVENT) { + return lisp_standard_read(hfile, buf, count); + } else { + ReadConsoleInput(hfile, &ir, 1, &n); + } + } + break; + case WAIT_IO_COMPLETION: + errno = EINTR; + return -1; + break; + case WAIT_FAILED: + _dosmaperr(GetLastError()); + return -1; + break; + } + } while (1); +} + +ssize_t +lisp_read(HANDLE hfile, void *buf, unsigned int count) { + switch(GetFileType(hfile)) { + case FILE_TYPE_CHAR: + return console_read(hfile, buf, count); + break; + + case FILE_TYPE_PIPE: /* pipe or one of these newfangled socket things */ + { + int socktype, optlen = sizeof(int); + if ((getsockopt((SOCKET)hfile, SOL_SOCKET, SO_TYPE, (char *)&socktype, &optlen) != 0) && (GetLastError() == WSAENOTSOCK)) { + return pipe_read(hfile, buf, count); + } + } + /* It's a socket, fall through */ + + case FILE_TYPE_DISK: + return lisp_standard_read(hfile, buf, count); + break; + + default: + errno = EBADF; + return -1; + } +} + + + +ssize_t +lisp_write(HANDLE hfile, void *buf, ssize_t count) +{ + HANDLE hevent; + OVERLAPPED overlapped; + DWORD err, nwritten, wait_result; + pending_io pending; + TCR *tcr = (TCR *)get_tcr(1); + + hevent = (HANDLE)tcr->io_datum; + if (hfile == (HANDLE)1) { + hfile = GetStdHandle(STD_OUTPUT_HANDLE); + } else if (hfile == (HANDLE) 2) { + hfile = GetStdHandle(STD_ERROR_HANDLE); + } + + + memset(&overlapped,0,sizeof(overlapped)); + + if (GetFileType(hfile) == FILE_TYPE_DISK) { + overlapped.Offset = SetFilePointer(hfile, 0, &(overlapped.OffsetHigh), FILE_CURRENT); + } + + + pending.h = hfile; + pending.o = &overlapped; + tcr->pending_io_info = &pending; + overlapped.hEvent = hevent; + ResetEvent(hevent); + if (WriteFile(hfile, buf, count, &nwritten, &overlapped)) { + tcr->pending_io_info = NULL; + return nwritten; + } + + err = GetLastError(); + if (err != ERROR_IO_PENDING) { + _dosmaperr(err); + tcr->pending_io_info = NULL; + return -1; + } + err = 0; + wait_result = WaitForSingleObjectEx(hevent, INFINITE, true); + tcr->pending_io_info = NULL; + if (wait_result == WAIT_OBJECT_0) { + err = overlapped.Internal; + if (err) { + _dosmaperr(err); + return -1; + } + return overlapped.InternalHigh; + } + if (wait_result == WAIT_IO_COMPLETION) { + CancelIo(hfile); + errno = EINTR; + return -1; + } + err = GetLastError(); + _dosmaperr(err); + return -1; +} + +int +lisp_fchmod(HANDLE hfile, int mode) +{ + errno = ENOSYS; + return -1; +} + +__int64 +lisp_lseek(HANDLE hfile, __int64 offset, int whence) +{ + DWORD high, low; + + high = ((__int64)offset)>>32; + low = offset & 0xffffffff; + low = SetFilePointer(hfile, low, &high, whence); + if (low != INVALID_SET_FILE_POINTER) { + return ((((__int64)high)<<32)|low); + } + _dosmaperr(GetLastError()); + return -1; +} + +#define ALL_USERS(f) ((f) | ((f)>> 3) | ((f >> 6))) +#define STAT_READONLY ALL_USERS(_S_IREAD) +#define STAT_READWRITE ALL_USERS((_S_IREAD|_S_IWRITE)) +int +lisp_stat(wchar_t *path, struct __stat64 *buf) +{ + return _wstat64(path,buf); +} + +#define UNIX_EPOCH_IN_WINDOWS_EPOCH 116444736000000000LL + +__time64_t +filetime_to_unix_time(FILETIME *ft) +{ + __time64_t then = *((__time64_t *) ft); + + then -= UNIX_EPOCH_IN_WINDOWS_EPOCH; + return then/10000000; +} + +int +lisp_fstat(HANDLE hfile, struct __stat64 *buf) +{ + int filetype; + + filetype = GetFileType(hfile) & ~FILE_TYPE_REMOTE; + + if (filetype == FILE_TYPE_UNKNOWN) { + errno = EBADF; + return -1; + } + + memset(buf, 0, sizeof(*buf)); + buf->st_nlink = 1; + + switch(filetype) { + case FILE_TYPE_CHAR: + case FILE_TYPE_PIPE: + if (filetype == FILE_TYPE_CHAR) { + buf->st_mode = _S_IFCHR; + } else { + buf->st_mode = _S_IFIFO; + } + break; + case FILE_TYPE_DISK: + { + BY_HANDLE_FILE_INFORMATION info; + + if (!GetFileInformationByHandle(hfile, &info)) { + _dosmaperr(GetLastError()); + return -1; + } + + if (info.dwFileAttributes & FILE_ATTRIBUTE_READONLY) { + buf->st_mode = STAT_READONLY; + } else { + buf->st_mode = STAT_READWRITE; + } + buf->st_mode |= _S_IFREG; + buf->st_size = ((((__int64)(info.nFileSizeHigh))<<32LL) | + ((__int64)(info.nFileSizeLow))); + buf->st_mtime = filetime_to_unix_time(&info.ftLastWriteTime); + buf->st_atime = filetime_to_unix_time(&info.ftLastAccessTime); + buf->st_ctime = filetime_to_unix_time(&info.ftCreationTime); + } + break; + case FILE_TYPE_UNKNOWN: + default: + errno = EBADF; + return -1; + } + return 0; +} + +int +lisp_futex(int *uaddr, int op, int val, void *timeout, int *uaddr2, int val3) +{ + errno = ENOSYS; + return -1; +} + + +__int64 +lisp_ftruncate(HANDLE hfile, off_t new_size) +{ + __int64 oldpos; + + + oldpos = lisp_lseek(hfile, 0, SEEK_END); + if (oldpos == -1) { + return 0; + } + if (oldpos < new_size) { + char buf[4096]; + __int64 n = new_size-oldpos; + DWORD nwritten, to_write; + + memset(buf,0,sizeof(buf)); + while(n) { + if (n > 4096LL) { + to_write = 4096; + } else { + to_write = n; + } + if (!WriteFile(hfile,buf,to_write,&nwritten,NULL)) { + _dosmaperr(GetLastError()); + return -1; + } + n -= nwritten; + } + return 0; + } + lisp_lseek(hfile, new_size, SEEK_SET); + if (SetEndOfFile(hfile)) { + return 0; + } + _dosmaperr(GetLastError()); + return -1; +} + + +_WDIR * +lisp_opendir(wchar_t *path) +{ + return _wopendir(path); +} + +struct _wdirent * +lisp_readdir(_WDIR *dir) +{ + return _wreaddir(dir); +} + +__int64 +lisp_closedir(_WDIR *dir) +{ + return _wclosedir(dir); +} + +int +lisp_pipe(int fd[2]) +{ + HANDLE input, output; + SECURITY_ATTRIBUTES sa; + + sa.nLength= sizeof(SECURITY_ATTRIBUTES); + sa.lpSecurityDescriptor = NULL; + sa.bInheritHandle = TRUE; + + if (!CreatePipe(&input, &output, &sa, 0)) + { + wperror("CreatePipe"); + return -1; + } + fd[0] = (int) ((intptr_t)input); + fd[1] = (int) ((intptr_t)output); + return 0; +} + +int +lisp_gettimeofday(struct timeval *tp, void *tzp) +{ + __time64_t now; + + gettimeofday(tp,tzp); /* trust it to get time zone right, at least */ + GetSystemTimeAsFileTime((FILETIME*)&now); + now -= UNIX_EPOCH_IN_WINDOWS_EPOCH; + now /= 10000; /* convert time to milliseconds */ + tp->tv_sec = now/1000LL; + tp->tv_usec = 1000 * (now%1000LL); /* convert milliseconds to microseconds */ + return 0; +} + +int +lisp_sigexit(int signum) +{ + signal(signum, SIG_DFL); + return raise(signum); +} + +#ifdef WIN_64 + +/* Make sure that the lisp calls these functions, when they do something */ +/* This code is taken from the 32-bit mingw library and is in the + public domain */ +double +acosh(double x) +{ + if (isnan (x)) + return x; + + if (x < 1.0) + { + errno = EDOM; + return nan(""); + } + + if (x > 0x1p32) + /* Avoid overflow (and unnecessary calculation when + sqrt (x * x - 1) == x). GCC optimizes by replacing + the long double M_LN2 const with a fldln2 insn. */ + return log (x) + 6.9314718055994530941723E-1L; + + /* Since x >= 1, the arg to log will always be greater than + the fyl2xp1 limit (approx 0.29) so just use logl. */ + return log (x + sqrt((x + 1.0) * (x - 1.0))); +} + +float +acoshf(float x) +{ + if (isnan (x)) + return x; + if (x < 1.0f) + { + errno = EDOM; + return nan(""); + } + + if (x > 0x1p32f) + /* Avoid overflow (and unnecessary calculation when + sqrt (x * x - 1) == x). GCC optimizes by replacing + the long double M_LN2 const with a fldln2 insn. */ + return log (x) + 6.9314718055994530941723E-1L; + + /* Since x >= 1, the arg to log will always be greater than + the fyl2xp1 limit (approx 0.29) so just use logl. */ + return log (x + sqrt((x + 1.0) * (x - 1.0))); +} + +double +asinh(double x) +{ + double z; + if (!isfinite (x)) + return x; + z = fabs (x); + + /* Avoid setting FPU underflow exception flag in x * x. */ +#if 0 + if ( z < 0x1p-32) + return x; +#endif + + /* Use log1p to avoid cancellation with small x. Put + x * x in denom, so overflow is harmless. + asinh(x) = log1p (x + sqrt (x * x + 1.0) - 1.0) + = log1p (x + x * x / (sqrt (x * x + 1.0) + 1.0)) */ + + z = log1p (z + z * z / (sqrt (z * z + 1.0) + 1.0)); + + return ( x >= 0.0 ? z : -z); +} + +float +asinhf(float x) +{ + float z; + if (!isfinite (x)) + return x; + z = fabsf (x); + + /* Avoid setting FPU underflow exception flag in x * x. */ +#if 0 + if ( z < 0x1p-32) + return x; +#endif + + + /* Use log1p to avoid cancellation with small x. Put + x * x in denom, so overflow is harmless. + asinh(x) = log1p (x + sqrt (x * x + 1.0) - 1.0) + = log1p (x + x * x / (sqrt (x * x + 1.0) + 1.0)) */ + + z = log1p (z + z * z / (sqrt (z * z + 1.0) + 1.0)); + + return ( x >= 0.0 ? z : -z); +} + +double +atanh(double x) +{ + double z; + if (isnan (x)) + return x; + z = fabs (x); + if (z == 1.0) + { + errno = ERANGE; + return (x > 0 ? INFINITY : -INFINITY); + } + if (z > 1.0) + { + errno = EDOM; + return nan(""); + } + /* Rearrange formula to avoid precision loss for small x. + + atanh(x) = 0.5 * log ((1.0 + x)/(1.0 - x)) + = 0.5 * log1p ((1.0 + x)/(1.0 - x) - 1.0) + = 0.5 * log1p ((1.0 + x - 1.0 + x) /(1.0 - x)) + = 0.5 * log1p ((2.0 * x ) / (1.0 - x)) */ + z = 0.5 * log1p ((z + z) / (1.0 - z)); + return x >= 0 ? z : -z; +} + +float +atanhf(float x) +{ + float z; + if (isnan (x)) + return x; + z = fabsf (x); + if (z == 1.0) + { + errno = ERANGE; + return (x > 0 ? INFINITY : -INFINITY); + } + if ( z > 1.0) + { + errno = EDOM; + return nanf(""); + } + /* Rearrange formula to avoid precision loss for small x. + + atanh(x) = 0.5 * log ((1.0 + x)/(1.0 - x)) + = 0.5 * log1p ((1.0 + x)/(1.0 - x) - 1.0) + = 0.5 * log1p ((1.0 + x - 1.0 + x) /(1.0 - x)) + = 0.5 * log1p ((2.0 * x ) / (1.0 - x)) */ + z = 0.5 * log1p ((z + z) / (1.0 - z)); + return x >= 0 ? z : -z; +} + +#endif + +typedef struct { + char *name; + void *addr; +} math_fn_entry; + + +math_fn_entry math_fn_entries [] = { + {"acos",acos}, + {"acosf",acosf}, + {"acosh",acosh}, + {"acoshf",acoshf}, + {"asin",asin}, + {"asinf",asinf}, + {"asinh",asinh}, + {"asinhf",asinhf}, + {"atan",atan}, + {"atan2",atan2}, + {"atan2f",atan2f}, + {"atanf",atanf}, + {"atanh",atanh}, + {"atanhf",atanhf}, + {"cos",cos}, + {"cosf",cosf}, + {"cosh",cosh}, + {"coshf",coshf}, + {"exp",exp}, + {"expf",expf}, + {"log",log}, + {"logf",logf}, + {"pow",pow}, + {"powf",powf}, + {"sin",sin}, + {"sinf",sinf}, + {"sinh",sinh}, + {"sinhf",sinhf}, + {"tan",tan}, + {"tanf",tanf}, + {"tanh",tanh}, + {"tanhf",tanhf}, + {NULL, 0}}; + +void * +lookup_math_fn(char *name) +{ + math_fn_entry *p = math_fn_entries; + char *entry_name; + + while ((entry_name = p->name) != NULL) { + if (!strcmp(name, entry_name)) { + return p->addr; + } + p++; + } + return NULL; +} + +HMODULE *modules = NULL; +DWORD cbmodules = 0; +HANDLE find_symbol_lock = 0; + +void * +windows_find_symbol(void *handle, char *name) +{ + void *addr; + + if ((handle == ((void *)-2L)) || + (handle == ((void *)-1L))) { + handle = NULL; + } + if (handle != NULL) { + addr = GetProcAddress(handle, name); + } else { + DWORD cbneeded, have, i; + WaitForSingleObject(find_symbol_lock,INFINITE); + + if (cbmodules == 0) { + cbmodules = 16 * sizeof(HANDLE); + modules = malloc(cbmodules); + } + + while (1) { + EnumProcessModules(GetCurrentProcess(),modules,cbmodules,&cbneeded); + if (cbmodules >= cbneeded) { + break; + } + cbmodules = cbneeded; + modules = realloc(modules,cbmodules); + } + have = cbneeded/sizeof(HANDLE); + + for (i = 0; i < have; i++) { + addr = GetProcAddress(modules[i],name); + + if (addr) { + break; + } + } + ReleaseMutex(find_symbol_lock); + if (addr) { + return addr; + } + return lookup_math_fn(name); + } +} + +/* Note that we're using 8-bit strings here */ + +void * +windows_open_shared_library(char *path) +{ + HMODULE module = (HMODULE)0; + + /* Try to open an existing module in a way that increments its + reference count without running any initialization code in + the dll. */ + if (!GetModuleHandleExA(0,path,&module)) { + /* If that failed ... */ + module = LoadLibraryA(path); + } + return (void *)module; +} + + +void +init_windows_io() +{ +#ifdef WIN_32 + extern void init_win32_ldt(void); + init_win32_ldt(); +#endif + find_symbol_lock = CreateMutex(NULL,false,NULL); +} + +void +init_winsock() +{ + WSADATA data; + + WSAStartup((2<<8)|2,&data); +} + Index: /branches/new-random/lisp-kernel/x86-asmutils32.s =================================================================== --- /branches/new-random/lisp-kernel/x86-asmutils32.s (revision 13309) +++ /branches/new-random/lisp-kernel/x86-asmutils32.s (revision 13309) @@ -0,0 +1,285 @@ +/* Copyright (C) 2005-2009 Clozure Associates */ +/* This file is part of Clozure CL. */ + +/* Clozure CL is licensed under the terms of the Lisp Lesser GNU Public */ +/* License , known as the LLGPL and distributed with Clozure CL as the */ +/* file "LICENSE". The LLGPL consists of a preamble and the LGPL, */ +/* which is distributed with Clozure CL as the file "LGPL". Where these */ +/* conflict, the preamble takes precedence. */ + +/* Clozure CL is referenced in the preamble as the "LIBRARY." */ + +/* The LLGPL is also available online at */ +/* http://opensource.franz.com/preamble.html */ + + + + + include(lisp.s) + + _beginfile + +_exportfn(C(current_stack_pointer)) + __(movl %esp,%eax) + __(ret) +_endfn + +_exportfn(C(count_leading_zeros)) + __(bsr 4(%esp),%eax) + __(xor $31,%eax) + __(ret) +_endfn + +_exportfn(C(noop)) + __(ret) +_endfn + +_exportfn(C(set_mxcsr)) + __(ldmxcsr 4(%esp)) + __(ret) +_endfn + +_exportfn(C(get_mxcsr)) + __(push $0) + __(stmxcsr (%esp)) + __(pop %eax) + __(ret) +_endfn + +_exportfn(C(save_fp_context)) +_endfn + +_exportfn(C(restore_fp_context)) +_endfn + +/* Atomically store new in *p, if *p == old. */ +/* Return actual old value. */ +/* natural store_conditional(natural *p, natural old, natural new) */ +_exportfn(C(store_conditional)) + __(movl 12(%esp),%edx) /* new */ + __(movl 8(%esp),%eax) /* old */ + __(movl 4(%esp),%ecx) /* ptr */ + __(lock) + __(cmpxchgl %edx,(%ecx)) + __(cmovne %edx,%eax) + __(ret) +_endfn + +/* Atomically store val in *p; return previous *p */ +/* of *%rdi. */ +/* signed_natural atomic_swap(signed_natural *p, signed_natural val) */ +_exportfn(C(atomic_swap)) + __(movl 8(%esp),%eax) + __(movl 4(%esp),%edx) + __(lock) + __(xchg %eax,(%edx)) + __(ret) +_endfn + +/* Logior the value in *p with mask (presumably a */ +/* bitmask with exactly 1 bit set.) Return non-zero if any of */ +/* the bits in that bitmask were already set. */ +/* natural atomic_ior(natural *p, natural mask) */ +_exportfn(C(atomic_ior)) + __(movl 4(%esp),%edx) /* ptr */ +0: __(movl (%edx),%eax) + __(movl %eax,%ecx) + __(orl 8(%esp),%ecx) + __(lock) + __(cmpxchg %ecx,(%edx)) + __(jnz 0b) + __(andl 8(%esp),%eax) + __(ret) +_endfn + + +/* Logand the value in *p with mask (presumably a bitmask with exactly 1 */ +/* bit set.) Return the value now in *p (for some value of "now"). */ +/* natural atomic_and(natural *p, natural mask) */ +_exportfn(C(atomic_and)) + __(movl 4(%esp),%edx) +0: __(movl (%edx),%eax) + __(movl %eax,%ecx) + __(and 8(%esp),%ecx) + __(lock) + __(cmpxchg %ecx,(%edx)) + __(jnz 0b) + __(movl %ecx,%eax) + __(ret) +_endfn + + + __ifdef([DARWIN]) +_exportfn(C(pseudo_sigreturn)) + __(hlt) + __(jmp C(pseudo_sigreturn)) +_endfn + __endif + +/* int cpuid (int code, int *pebx, int *pecx, int *pedx) */ +_exportfn(C(cpuid)) + __(push %ebx) /* %ebx is non-volatile */ + __(push %esi) /* ditto here */ + __(movl 12(%esp),%eax) + __(xorl %ecx,%ecx) + __(cpuid) + __(movl 16(%esp),%esi) + __(movl %ebx,(%esi)) + __(movl 20(%esp),%esi) + __(movl %ecx,(%esi)) + __(movl 24(%esp),%esi) + __(movl %edx,(%esi)) + __(pop %esi) + __(pop %ebx) + __(ret) +_endfn + +/* switch_to_foreign_stack(new_sp, func, arg_0, arg_1, arg_2) */ +/* Not fully general, but should get us off of the signal stack */ +/* Beware: on Darwin, GDB can get very confused by this code, and + doesn't really get unconfused until the target function - the + handler - has built its stack frame + The lone caller of this function passes 3 arguments (besides + the new stack pointer and the handler address.) + On platforms where the C stack must be 16-byte aligned, pushing + a 4th word helps make the stack aligned before the return + address is (re-)pushed. + On Linux, there are severe constraints on what the top of stack + can look like when rt_sigreturn (the code at the return address) + runs, and there aren't any constraints on stack alignment, so + we don't push the extra word on the new stack.*/ +_exportfn(C(switch_to_foreign_stack)) + __(addl $4,%esp) /* discard return address, on wrong stack */ + __(pop %edi) /* new esp */ + __(pop %esi) /* handler */ + __(pop %eax) /* arg_0 */ + __(pop %ebx) /* arg_1 */ + __(pop %ecx) /* arg_2 */ + __(mov %edi,%esp) + __(pop %edi) /* Return address pushed by caller */ + __ifndef([LINUX]) + __(push $0) /* For alignment. See comment above */ + __endif + __(push %ecx) /* arg_2 */ + __(push %ebx) /* arg_1 */ + __(push %eax) /* arg_0 */ + __(push %edi) /* return address */ + __(jmp *%esi) /* On some platforms, we don't really return */ +_endfn + + __ifdef([FREEBSD]) + .globl C(sigreturn) +_exportfn(C(freebsd_sigreturn)) + __(jmp C(sigreturn)) +_endfn + __endif + + __ifdef([DARWIN]) +_exportfn(C(darwin_sigreturn)) +/* Need to set the sigreturn 'infostyle' argument, which is mostly + undocumented. On x8632 Darwin, sigtramp() sets it to 0x1e, and + since we're trying to do what sigtramp() would do if we'd returned + to it ... */ + __(movl $0x1e,8(%esp)) + __(movl $0xb8,%eax) /* SYS_sigreturn */ + __(int $0x80) + __(ret) /* shouldn't return */ + +_endfn + __endif + +_exportfn(C(get_vector_registers)) + __(ret) +_endfn + +_exportfn(C(put_vector_registers)) + __(ret) +_endfn + + __ifdef([WIN_32]) +_exportfn(C(restore_windows_context)) +Xrestore_windows_context_start: + __(movl 4(%esp),%ecx) /* context */ + __(movl 12(%esp),%edx) /* old valence */ + __(movl 8(%esp),%eax) /* tcr */ + __(movw tcr.ldt_selector(%eax), %rcontext_reg) + __(movl %edx,rcontext(tcr.valence)) + __(movl $0,rcontext(tcr.pending_exception_context)) + __(frstor win32_context.FloatSave(%ecx)) + /* Windows doesn't bother to align the context, so use + 'movupd' here */ + __(movupd win32_context.Xmm0(%ecx),%xmm0) + __(movupd win32_context.Xmm1(%ecx),%xmm1) + __(movupd win32_context.Xmm2(%ecx),%xmm2) + __(movupd win32_context.Xmm3(%ecx),%xmm3) + __(movupd win32_context.Xmm4(%ecx),%xmm4) + __(movupd win32_context.Xmm5(%ecx),%xmm5) + __(movupd win32_context.Xmm6(%ecx),%xmm6) + __(movupd win32_context.Xmm7(%ecx),%xmm7) + __(ldmxcsr win32_context.MXCSR(%ecx)) + __(movl win32_context.Ebp(%ecx),%ebp) + __(movl win32_context.Edi(%ecx),%edi) + __(movl win32_context.Esi(%ecx),%esi) + __(movl win32_context.Edx(%ecx),%edx) + __(movl win32_context.Ebx(%ecx),%ebx) + __(movl win32_context.Eax(%ecx),%eax) + __(movl win32_context.Esp(%ecx),%esp) + __(pushl win32_context.EFlags(%ecx)) + __(pushl %cs) + __(pushl win32_context.Eip(%ecx)) + /* This must be the last thing before the iret, e.g., if we're + interrupted before the iret, the context we're returning to here + is still in %ecx. If we're interrupted -at- the iret, then + everything but that which the iret will restore has been restored. */ + __(movl win32_context.Ecx(%ecx),%ecx) +Xrestore_windows_context_iret: + __(iret) +Xrestore_windows_context_end: + __(nop) +_endfn + +_exportfn(C(windows_switch_to_foreign_stack)) + __(pop %eax) + __(pop %ebx) /* new %esp */ + __(pop %ecx) /* handler */ + __(pop %edx) /* arg */ + __(movl %ebx,%esp) + __(subl $0x10,%esp) + __(movl %edx,(%esp)) + __(push %eax) + __(jmp *%ecx) +_endfn + + .data + .globl C(restore_windows_context_start) + .globl C(restore_windows_context_end) + .globl C(restore_windows_context_iret) +C(restore_windows_context_start): .long Xrestore_windows_context_start +C(restore_windows_context_end): .long Xrestore_windows_context_end +C(restore_windows_context_iret): .long Xrestore_windows_context_iret + .text + + __ifdef([WIN32_ES_HACK]) +/* Something that we shouldn't return to */ +_exportfn(C(windows_halt)) + __(hlt) +_endfn + __endif +_exportfn(C(ensure_safe_for_string_operations)) + __ifdef([WIN32_ES_HACK]) + __(movw %es,%ax) + __(movw %ds,%dx) + __(cmpw %ax,%dx) + __(jne 9f) +0: __(movw %dx,%es) + __endif + __(cld) + __(ret) + __ifdef([WIN32_ES_HACK]) +9: __(hlt) + __(jmp 0b) + __endif +_endfn + __endif + _endfile + Index: /branches/new-random/lisp-kernel/x86-asmutils64.s =================================================================== --- /branches/new-random/lisp-kernel/x86-asmutils64.s (revision 13309) +++ /branches/new-random/lisp-kernel/x86-asmutils64.s (revision 13309) @@ -0,0 +1,308 @@ +/* Copyright (C) 2005-2009 Clozure Associates */ +/* This file is part of Clozure CL. */ + +/* Clozure CL is licensed under the terms of the Lisp Lesser GNU Public */ +/* License , known as the LLGPL and distributed with Clozure CL as the */ +/* file "LICENSE". The LLGPL consists of a preamble and the LGPL, */ +/* which is distributed with Clozure CL as the file "LGPL". Where these */ +/* conflict, the preamble takes precedence. */ + +/* Clozure CL is referenced in the preamble as the "LIBRARY." */ + +/* The LLGPL is also available online at */ +/* http://opensource.franz.com/preamble.html */ + + + + + include(lisp.s) + + _beginfile + +/* Flush %carg1 cache lines, starting at address in %carg0. Each line is */ +/* assumed to be %carg2 bytes wide. */ +_exportfn(C(flush_cache_lines)) + __(cmpq $0,%carg1) + __(jmp 2f) +1: __(clflush (%carg0)) + __(addq %carg2,%carg0) + __(subq $1,%carg1) +2: __(jg 1b) + __(repret) +_endfn + +_exportfn(C(current_stack_pointer)) + __(movq %rsp,%cret) + __(ret) +_endfn + +_exportfn(C(touch_page)) + __(movq %carg0,(%carg0)) + __(movq $0,(%carg0)) + __(movl $1,%cret_l) + .globl C(touch_page_end) +C(touch_page_end): + __(ret) + +_exportfn(C(count_leading_zeros)) + __(bsrq %carg0,%cret) + __(xorq $63,%cret) + __(ret) +_endfn + +_exportfn(C(noop)) + __(retq) +_endfn + +_exportfn(C(set_mxcsr)) + __(pushq %carg0) + __(ldmxcsr (%rsp)) + __(addq $8,%rsp) + __(ret) +_endfn + +_exportfn(C(get_mxcsr)) + __(pushq $0) + __(stmxcsr (%rsp)) + __(popq %cret) + __(ret) +_endfn + +_exportfn(C(save_fp_context)) +_endfn + +_exportfn(C(restore_fp_context)) +_endfn + +/* Atomically store new value (%carg2) in *%carg0, if old value == %carg1. */ +/* Return actual old value. */ +_exportfn(C(store_conditional)) + __(mov %carg1,%cret) + __(lock) + __(cmpxchgq %carg2,(%carg0)) + __(cmovne %carg2,%cret) + __(ret) +_endfn + +/* Atomically store new_value(%carg1) in *%carg0 ; return previous contents */ +/* of *%carg0. */ + +_exportfn(C(atomic_swap)) + __(lock) + __(xchg %carg1,(%carg0)) + __(mov %carg1,%cret) + __(ret) +_endfn + +/* Logior the value in *%carg0 with the value in %carg1 (presumably a */ +/* bitmask with exactly 1 bit set.) Return non-zero if any of */ +/* the bits in that bitmask were already set. */ +_exportfn(C(atomic_ior)) +0: __(movq (%carg0),%cret) + __(movq %cret,%carg2) + __(orq %carg1,%carg2) + __(lock) + __(cmpxchg %carg2,(%carg0)) + __(jnz 0b) + __(andq %carg1,%cret) + __(ret) +_endfn + + +/* Logand the value in *carg0 with the value in carg1 (presumably a bitmask with exactly 1 */ +/* bit set.) Return the value now in *carg0 (for some value of "now" */ + +_exportfn(C(atomic_and)) +0: __(movq (%carg0),%cret) + __(movq %cret,%carg2) + __(and %carg1,%carg2) + __(lock) + __(cmpxchg %carg2,(%carg0)) + __(jnz 0b) + __(movq %carg2,%cret) + __(ret) +_endfn + + + __ifdef([DARWIN]) +_exportfn(C(pseudo_sigreturn)) + __(hlt) + __(jmp C(pseudo_sigreturn)) +_endfn + __endif + +/* int cpuid (natural code, natural *pebx, natural *pecx, natural *pedx) */ +_exportfn(C(cpuid)) + __(pushq %carg2) + __(pushq %carg3) + __(movq %carg1, %ctemp0) + __(pushq %rbx) /* non-volatile reg, clobbered by CPUID */ + __(movq %carg0, %rax) + __(xorq %rcx,%rcx) + __(cpuid) + __(movq %rbx,(%ctemp0)) + __(popq %rbx) + __(popq %ctemp0) /* recover pedx */ + __(movq %rdx,(%ctemp0)) + __(popq %ctemp0) /* recover pecx */ + __(movq %rcx,(%ctemp0)) + __(ret) +_endfn + +/* switch_to_foreign_stack(new_sp, func, arg_0, arg_1, arg_2, arg_3) */ +/* Not fully general, but should get us off of the signal stack */ + __ifndef([WINDOWS]) +_exportfn(C(switch_to_foreign_stack)) + __(movq %rdi,%rsp) + __(movq %rsi,%rax) + __(movq %rdx,%rdi) + __(movq %rcx,%rsi) + __(movq %r8,%rdx) + __(movq %r9,%rcx) + __(jmp *%rax) +_endfn + __endif + +_exportfn(C(freebsd_sigreturn)) + __(movl $417,%eax) /* SYS_sigreturn */ + __(syscall) + +_exportfn(C(get_vector_registers)) +_endfn + +_exportfn(C(put_vector_registers)) +_endfn + + __ifdef([DARWIN]) +_exportfn(C(darwin_sigreturn)) + .globl C(sigreturn) +/* Need to set the sigreturn 'infostyle' argument, which is mostly + undocumented. On x8664 Darwin, sigtramp() sets it to 0x1e, and + since we're trying to do what sigtramp() would do if we'd returned + to it ... */ + __(movl $0x1e,%esi) + __(movl $0x20000b8,%eax) + __(syscall) + __(ret) +_endfn + __endif + + + + __ifdef([DARWIN_GS_HACK]) +/* Check (in an ugly, non-portable way) to see if %gs is addressing + pthreads data. If it was, return 0; otherwise, assume that it's + addressing a lisp tcr and set %gs to point to the tcr's tcr.osid, + then return 1. */ + +thread_signature = 0x54485244 /* 'THRD' */ + +_exportfn(C(ensure_gs_pthread)) + __(cmpl $thread_signature,%gs:0) + __(movl $0,%eax) + __(je 9f) + __(movq %gs:tcr.osid,%rdi) + __(movl $0x3000003,%eax) + __(syscall) + __(movl $1,%eax) +9: __(repret) +_endfn + + /* Ensure that %gs addresses the linear address in %rdi */ + /* This incidentally returns the segment selector .*/ +_exportfn(C(set_gs_address)) + __(movl $0x3000003,%eax) + __(syscall) + __(ret) +_endfn + __endif + + __ifdef([WIN_64]) +/* %rcx = CONTEXT, %rdx = tcr, %r8 = old_valence. This pretty + much has to be uninterruptible */ +_exportfn(C(restore_windows_context)) +Xrestore_windows_context_start: + __(subq $0x38,%rsp) + __(xorl %eax,%eax) + __(movq %r8,tcr.valence(%rdx)) + __(movq %rax,tcr.pending_exception_context(%rdx)) + __(fxrstor win64_context.fpstate(%rcx)) + __(movapd win64_context.Xmm0(%rcx),%xmm0) + __(movapd win64_context.Xmm1(%rcx),%xmm1) + __(movapd win64_context.Xmm2(%rcx),%xmm2) + __(movapd win64_context.Xmm3(%rcx),%xmm3) + __(movapd win64_context.Xmm4(%rcx),%xmm4) + __(movapd win64_context.Xmm5(%rcx),%xmm5) + __(movapd win64_context.Xmm6(%rcx),%xmm6) + __(movapd win64_context.Xmm7(%rcx),%xmm7) + __(movapd win64_context.Xmm8(%rcx),%xmm8) + __(movapd win64_context.Xmm9(%rcx),%xmm9) + __(movapd win64_context.Xmm10(%rcx),%xmm10) + __(movapd win64_context.Xmm11(%rcx),%xmm11) + __(movapd win64_context.Xmm12(%rcx),%xmm12) + __(movapd win64_context.Xmm13(%rcx),%xmm13) + __(movapd win64_context.Xmm14(%rcx),%xmm14) + __(movapd win64_context.Xmm15(%rcx),%xmm15) + __(ldmxcsr win64_context.MxCsr(%rcx)) + __(movw win64_context.SegSs(%rcx),%ax) + __(movw %ax,0x20(%rsp)) + __(movq win64_context.Rsp(%rcx),%rax) + __(movq %rax,0x18(%rsp)) + __(movl win64_context.EFlags(%rcx),%eax) + __(movl %eax,0x10(%rsp)) + __(movw win64_context.SegCs(%rcx),%ax) + __(movw %ax,8(%rsp)) + __(movq win64_context.Rip(%rcx),%rax) + __(movq %rax,(%rsp)) + __(movq win64_context.Rax(%rcx),%rax) + __(movq win64_context.Rbx(%rcx),%rbx) + __(movq win64_context.Rdx(%rcx),%rdx) + __(movq win64_context.Rdi(%rcx),%rdi) + __(movq win64_context.Rsi(%rcx),%rsi) + __(movq win64_context.Rbp(%rcx),%rbp) + __(movq win64_context.R8(%rcx),%r8) + __(movq win64_context.R9(%rcx),%r9) + __(movq win64_context.R10(%rcx),%r10) + __(movq win64_context.R11(%rcx),%r11) + __(movq win64_context.R12(%rcx),%r12) + __(movq win64_context.R13(%rcx),%r13) + __(movq win64_context.R14(%rcx),%r14) + __(movq win64_context.R15(%rcx),%r15) + /* This must be the last thing before the iret, e.g., if we're + interrupted before the iret, the context we're returning to here + is still in %rcx. If we're interrupted -at- the iret, then + everything but that which the iret will restore has been restored. */ + __(movq win64_context.Rcx(%rcx),%rcx) +Xrestore_windows_context_iret: + __(iretq) +Xrestore_windows_context_end: + __(nop) +_endfn + +_exportfn(C(windows_switch_to_foreign_stack)) + __(pop %rax) + __(lea -0x20(%rcx),%rsp) + __(push %rax) + __(movq %r8,%rcx) + __(jmp *%rdx) +_endfn + + .data + .globl C(restore_windows_context_start) + .globl C(restore_windows_context_end) + .globl C(restore_windows_context_iret) +C(restore_windows_context_start): .quad Xrestore_windows_context_start +C(restore_windows_context_end): .quad Xrestore_windows_context_end +C(restore_windows_context_iret): .quad Xrestore_windows_context_iret + .text + +/* Something that we shouldn't return to */ +_exportfn(C(windows_halt)) + __(hlt) +_endfn +_exportfn(C(ensure_safe_for_string_operations)) + __(cld) + __(ret) +_endfn + __endif + _endfile Index: /branches/new-random/lisp-kernel/x86-constants.h =================================================================== --- /branches/new-random/lisp-kernel/x86-constants.h (revision 13309) +++ /branches/new-random/lisp-kernel/x86-constants.h (revision 13309) @@ -0,0 +1,63 @@ +/* + Copyright (C) 2005-2009 Clozure Associates + This file is part of Clozure CL. + + Clozure CL is licensed under the terms of the Lisp Lesser GNU Public + License , known as the LLGPL and distributed with Clozure CL as the + file "LICENSE". The LLGPL consists of a preamble and the LGPL, + which is distributed with Clozure CL as the file "LGPL". Where these + conflict, the preamble takes precedence. + + Clozure CL is referenced in the preamble as the "LIBRARY." + + The LLGPL is also available online at + http://opensource.franz.com/preamble.html +*/ + +#ifndef __x86_constants__ +#define __x86_constants__ 1 + +#define TCR_FLAG_BIT_FOREIGN fixnumshift +#define TCR_FLAG_BIT_AWAITING_PRESET (fixnumshift+1) +#define TCR_FLAG_BIT_ALT_SUSPEND (fixnumshift+2) +#define TCR_FLAG_BIT_PROPAGATE_EXCEPTION (fixnumshift+3) +#define TCR_FLAG_BIT_SUSPEND_ACK_PENDING (fixnumshift+4) +#define TCR_FLAG_BIT_PENDING_EXCEPTION (fixnumshift+5) +#define TCR_FLAG_BIT_FOREIGN_EXCEPTION (fixnumshift+6) +#define TCR_FLAG_BIT_PENDING_SUSPEND (fixnumshift+7) +#define TCR_STATE_FOREIGN (1) +#define TCR_STATE_LISP (0) +#define TCR_STATE_EXCEPTION_WAIT (2) +#define TCR_STATE_EXCEPTION_RETURN (4) + +#ifdef X8664 +#include "x86-constants64.h" +#else +#include "x86-constants32.h" +#endif + +#define dnode_size (node_size*2) +#define dnode_shift (node_shift+1) + +#define INTERRUPT_LEVEL_BINDING_INDEX (1) + +/* FP exception mask bits */ +#define MXCSR_IM_BIT (7) /* invalid masked when set*/ +#define MXCSR_DM_BIT (8) /* denormals masked when set*/ +#define MXCSR_ZM_BIT (9) /* divide-by-zero masked when set */ +#define MXCSR_OM_BIT (10) /* overflow masked when set */ +#define MXCSR_UM_BIT (11) /* underflow masked when set */ +#define MXCSR_PM_BIT (12) /* precision masked when set */ + +/* Bits in the xFLAGS register */ +#define X86_CARRY_FLAG_BIT (0) +#define X86_PARITY_FLAG_BIT (2) +#define X86_AUX_CARRY_FLAG_BIT (4) +#define X86_ZERO_FLAG_BIT (6) +#define X86_SIGN_FLAG_BIT (7) +#define X86_DIRECTION_FLAG_BIT (10) +#define X86_OVERFLOW_FLAG_BIT (11) + + +#endif /* __x86_constants__ */ + Index: /branches/new-random/lisp-kernel/x86-constants.s =================================================================== --- /branches/new-random/lisp-kernel/x86-constants.s (revision 13309) +++ /branches/new-random/lisp-kernel/x86-constants.s (revision 13309) @@ -0,0 +1,139 @@ +/* Copyright (C) 2005-2009 Clozure Associates */ +/* This file is part of Clozure CL. */ + +/* Clozure CL is licensed under the terms of the Lisp Lesser GNU Public */ +/* License , known as the LLGPL and distributed with Clozure CL as the */ +/* file "LICENSE". The LLGPL consists of a preamble and the LGPL, */ +/* which is distributed with Clozure CL as the file "LGPL". Where these */ +/* conflict, the preamble takes precedence. */ + +/* Clozure CL is referenced in the preamble as the "LIBRARY." */ + +/* The LLGPL is also available online at */ +/* http://opensource.franz.com/preamble.html */ + + + + +/* Indices in %builtin-functions% */ + +_builtin_plus = 0 /* +-2 */ +_builtin_minus = 1 /* --2 */ +_builtin_times = 2 /* *-2 */ +_builtin_div = 3 /* /-2 */ +_builtin_eq = 4 /* =-2 */ +_builtin_ne = 5 /* /-2 */ +_builtin_gt = 6 /* >-2 */ +_builtin_ge = 7 /* >=-2 */ +_builtin_lt = 8 /* <-2 */ +_builtin_le = 9 /* <=-2 */ +_builtin_eql = 10 /* eql */ +_builtin_length = 11 /* length */ +_builtin_seqtype = 12 /* sequence-type */ +_builtin_assq = 13 /* assq */ +_builtin_memq = 14 /* memq */ +_builtin_logbitp = 15 /* logbitp */ +_builtin_logior = 16 /* logior-2 */ +_builtin_logand = 17 /* logand-2 */ +_builtin_ash = 18 /* ash */ +_builtin_negate = 19 /* %negate */ +_builtin_logxor = 20 /* logxor-2 */ +_builtin_aref1 = 21 /* %aref1 */ +_builtin_aset1 = 22 /* %aset1 */ + + +ifdef([X8664],[ + include(x86-constants64.s) +],[ + include(x86-constants32.s) +]) + +/* registers, as used in destructuring-bind/macro-bind */ +ifdef([X8664],[ +define([whole_reg],[temp1]) +define([arg_reg],[temp0]) +define([keyvect_reg],[arg_x]) +],[ +define([arg_reg],[temp1]) +define([arg_reg_b],[temp1_b]) +define([keyvect_reg],[arg_y]) +]) + +define([initopt_bit],[24]) +define([keyp_bit],[25]) /* note that keyp can be true even when 0 keys. */ +define([aok_bit],[26]) +define([restp_bit],[27]) +define([seen_aok_bit],[28]) + +num_lisp_globals = 48 /* MUST UPDATE THIS !!! */ + + _struct(lisp_globals,lisp_globals_limit-(num_lisp_globals*node_size)) + _node(initial_tcr) /* initial thread tcr */ + _node(image_name) /* --image-name argument */ + _node(BADfpscr_save_high) /* high word of FP reg used to save FPSCR */ + _node(unwind_resume) /* _Unwind_Resume */ + _node(batch_flag) /* -b */ + _node(host_platform) /* for runtime platform-specific stuff */ + _node(argv) /* address of argv[0] */ + _node(ref_base) /* start of oldest pointer-bearing area */ + _node(tenured_area) /* the tenured_area */ + _node(oldest_ephemeral) /* dword address of oldest ephemeral object or 0 */ + _node(lisp_exit_hook) /* install foreign exception_handling */ + _node(lisp_return_hook) /* install lisp exception_handling */ + _node(double_float_one) /* high half of 1.0d0 */ + _node(short_float_zero) /* low half of 1.0d0 */ + _node(objc2_end_catch) /* objc_end_catch() */ + _node(metering_info) /* address of lisp_metering global */ + _node(in_gc) /* non-zero when GC active */ + _node(lexpr_return1v) /* simpler when &lexpr called for single value. */ + _node(lexpr_return) /* magic &lexpr return code. */ + _node(all_areas) /* doubly-linked list of all memory areas */ + _node(kernel_path) /* real executable name */ + _node(objc2_begin_catch) /* objc_begin_catch */ + _node(stack_size) /* from the command line */ + _node(statically_linked) /* non-zero if -static */ + _node(heap_end) /* end of lisp heap */ + _node(heap_start) /* start of lisp heap */ + _node(gcable_pointers) /* linked-list of weak macptrs. */ + _node(gc_num) /* fixnum: GC call count. */ + _node(fwdnum) /* fixnum: GC "forwarder" call count. */ + _node(altivec_present) /* non-zero when AltiVec available */ + _node(oldspace_dnode_count) /* dynamic dnodes older than g0 start */ + _node(refbits) /* EGC refbits */ + _node(gc_inhibit_count) + _node(intflag) /* sigint pending */ + _node(default_allocation_quantum) /* for per-thread allocation */ + _node(deleted_static_pairs) + _node(exception_lock) + _node(area_lock) + _node(tcr_key) /* tsd key for per-thread tcr */ + _node(ret1val_addr) /* address of "dynamic" subprims magic values return addr */ + _node(subprims_base) /* address of dynamic subprims jump table */ + _node(saveR13) /* probably don]t really need this */ + _node(saveTOC) /* where the 68K emulator stores the emulated regs */ + _node(objc_2_personality) /* exception "personality routine" address for ObjC 2.0 */ + _node(kernel_imports) /* some things we need imported for us */ + _node(interrupt_signal) /* signal used by PROCESS-INTERRUPT */ + _node(tcr_count) /* tcr_id for next tcr */ + _node(get_tcr) /* address of get_tcr() */ + _ends + + + +define([TCR_STATE_FOREIGN],1) +define([TCR_STATE_LISP],0) +define([TCR_STATE_EXCEPTION_WAIT],2) +define([TCR_STATE_EXCEPTION_RETURN],4) + +tstack_alloc_limit = 0xffff + +mxcsr_ie_bit = 0 /* invalid */ +mxcsr_de_bit = 1 /* denorm */ +mxcsr_ze_bit = 2 +mxcsr_oe_bit = 3 +mxcsr_ue_bit = 4 +mxcsr_pe_bit = 5 +num_mxcsr_exception_bits = 6 + +mxcsr_all_exceptions = ((1< +#include +#define REG_EAX EAX +#define REG_EBX EBX +#define REG_ECX ECX +#define REG_EDX EDX +#define REG_ESI ESI +#define REG_EDI EDI +#define REG_EBP EBP +#define REG_ESP UESP /* Maybe ... ESP is often 0, but who knows why ? */ +#define REG_EFL EFL +#define REG_EIP EIP +#endif + +/* Indicies of GPRs in the mcontext component of a ucontext */ +#define Iimm0 REG_EAX +#define Iarg_z REG_EBX +#define Itemp0 REG_ECX +#define Itemp1 REG_EDX +#define Ifn REG_EDI +#define Iarg_y REG_ESI +#define Iesp REG_ESP +#define Iebp REG_EBP +#define Ieip REG_EIP +#define Iflags REG_EFL + +#define Isp Iesp +#define Iip Ieip +#define Iallocptr Itemp0 +#define Ira0 Itemp0 +#define Inargs Itemp1 +#define Ixfn Itemp1 +#define Ifp Iebp + +/* MMX register offsets from where mm0 is found in uc_mcontext.fs */ +#define Imm0 0 +#define Imm1 1 + +#define nbits_in_word 32 +#define log2_nbits_in_word 5 +#define nbits_in_byte 8 +#define ntagbits 3 +#define nlisptagbits 2 +#define nfixnumtagbits 2 +#define num_subtag_bits 8 +#define fixnumshift 2 +#define fixnum_shift 2 +#define fulltagmask 7 +#define tagmask 3 +#define fixnummask 3 +#define subtagmask ((1<> 2) - 3) + +typedef struct doh_block { + struct doh_block *link; + unsigned size; + unsigned free; + LispObj data[doh_block_slots]; +} doh_block, *doh_block_ptr; + +#define population_weak_list (0< +#else +typedef unsigned short sel_t; /* for now */ +#endif + +#define TCR_BIAS 0 + +/* + * bits correspond to reg encoding used in instructions + * 7 6 5 4 3 2 1 0 + * edi esi ebp esp ebx edx ecx eax + */ + +#define X8632_DEFAULT_NODE_REGS_MASK 0xce + +typedef struct tcr { + struct tcr *next; + struct tcr *prev; + natural node_regs_mask; /* bit set means correspnding reg contains node */ + struct tcr *linear; + /* this spill area must be 16-byte aligned */ + LispObj save0; /* spill area for node registers */ + LispObj save1; + LispObj save2; + LispObj save3; + LispObj *save_fp; /* EBP when in foreign code */ + u32_t lisp_mxcsr; + u32_t foreign_mxcsr; + special_binding *db_link; /* special binding chain head */ + LispObj catch_top; /* top catch frame */ + LispObj *save_vsp; /* VSP when in foreign code */ + LispObj *save_tsp; /* TSP when in foreign code */ + LispObj *foreign_sp; + struct area *cs_area; /* cstack area pointer */ + struct area *vs_area; /* vstack area pointer */ + struct area *ts_area; /* tstack area pointer */ + LispObj cs_limit; /* stack overflow limit */ + natural bytes_allocated; + natural bytes_consed_high; + natural log2_allocation_quantum; /* for per-thread consing */ + signed_natural interrupt_pending; /* pending interrupt flag */ + xframe_list *xframe; /* exception-frame linked list */ + int *errno_loc; /* per-thread (?) errno location */ + LispObj ffi_exception; /* fpscr bits from ff-call */ + LispObj osid; /* OS thread id */ + signed_natural valence; /* odd when in foreign code */ + signed_natural foreign_exception_status; /* non-zero -> call lisp_exit_hook */ + void *native_thread_info; /* platform-dependent */ + void *native_thread_id; /* mach_thread_t, pid_t, etc. */ + void *last_allocptr; + void *save_allocptr; + void *save_allocbase; + void *reset_completion; + void *activate; + signed_natural suspend_count; + ExceptionInformation *suspend_context; + ExceptionInformation *pending_exception_context; + void *suspend; /* suspension semaphore */ + void *resume; /* resumption semaphore */ + natural flags; + ExceptionInformation *gc_context; + void *termination_semaphore; + signed_natural unwinding; + natural tlb_limit; + LispObj *tlb_pointer; + natural shutdown_count; + LispObj *next_tsp; + void *safe_ref_address; + sel_t ldt_selector; + natural scratch_mxcsr; + natural unboxed0; + natural unboxed1; + LispObj next_method_context; /* used in lieu of register */ + natural save_eflags; + void *allocated; + void *pending_io_info; + void *io_datum; +} TCR; + +#define nil_value ((0x13000 + (fulltag_cons))+(LOWMEM_BIAS)) +#define t_value ((0x13008 + (fulltag_misc))+(LOWMEM_BIAS)) +#define t_offset (t_value-nil_value) +#define misc_header_offset -fulltag_misc +#define misc_data_offset misc_header_offset + node_size + +typedef struct { + natural Eip; + natural Cs; /* in low 16 bits */ + natural EFlags; +} ia32_iret_frame; + +#define heap_segment_size 0x00010000 +#define log2_heap_segment_size 16 + +#ifndef EFL_DF +#define EFL_DF 1024 +#endif Index: /branches/new-random/lisp-kernel/x86-constants32.s =================================================================== --- /branches/new-random/lisp-kernel/x86-constants32.s (revision 13309) +++ /branches/new-random/lisp-kernel/x86-constants32.s (revision 13309) @@ -0,0 +1,626 @@ +define([eax_l],[eax]) +define([ecx_l],[ecx]) +define([edx_l],[edx]) +define([ebx_l],[ebx]) +define([esi_l],[esi]) +define([edi_l],[edi]) + +define([eax_b],[al]) +define([ecx_b],[cl]) +define([edx_b],[dl]) +define([ebx_b],[bl]) + +define([imm0],[eax]) + define([imm0_l],[eax]) + define([imm0_w],[ax]) + define([imm0_b],[al]) + define([imm0_bh],[ah]) + define([Rimm0],[0]) + +define([temp0],[ecx]) + define([temp0_l],[ecx]) + define([temp0_w],[cx]) + define([temp0_b],[cl]) + define([temp0_bh],[ch]) + define([Rtemp0],[1]) + +define([temp1],[edx]) + define([temp1_l],[edx]) + define([temp1_w],[dx]) + define([temp1_b],[dl]) + define([temp1_bh],[dh]) + define([Rtemp1],[2]) + +define([arg_z],[ebx]) + define([arg_z_l],[ebx]) + define([arg_z_w],[bx]) + define([arg_z_b],[bl]) + define([arg_z_bh],[bh]) + define([Rarg_z],[3]) + +define([arg_y],[esi]) + define([Rarg_y],[6]) + +define([fn],[edi]) + define([Rfn],[7]) + +define([rcontext_reg],[fs]) + + ifdef([WINDOWS],[ +undefine([rcontext_reg]) +define([rcontext_reg],[es]) + ]) + +define([rcontext],[%rcontext_reg:$1]) + +define([fname],[temp0]) +define([allocptr],[temp0]) + +define([nargs],[temp1]) +define([nargs_w],[temp1_w]) + +define([ra0],[temp0]) +define([xfn],[temp1]) + +define([allocptr],[temp0]) +define([stack_temp],[mm7]) + +define([fp0],[xmm0]) +define([fp1],[xmm1]) +define([fp2],[xmm2]) +define([fp3],[xmm3]) +define([fp4],[xmm4]) +define([fp5],[xmm5]) +define([fp6],[xmm6]) +define([fp7],[xmm7]) +define([fpzero],[fp7]) + +nbits_in_word = 32 +nbits_in_byte = 8 +ntagbits = 3 +nlisptagbits = 2 +nfixnumtagbits = 2 +num_subtag_bits = 8 +subtag_shift = num_subtag_bits +fixnumshift = 2 +fixnum_shift = 2 +fulltagmask = 7 +tagmask = 3 +fixnummask = 3 +ncharcodebits = 8 +charcode_shift = 8 +word_shift = 2 +node_size = 4 +dnode_size = 8 +dnode_align_bits = 3 +dnode_shift = dnode_align_bits +bitmap_shift = 5 + +fixnumone = (1< -> unwind-protect, else catch */ + _node(link) /* backpointer to previous catch frame */ + _node(mvflag) /* 0 if single-valued catch, fixnum 1 otherwise */ + _node(esp) /* saved lisp esp */ + _node(ebp) /* saved lisp ebp */ + _node(foreign_sp) /* necessary? */ + _node(db_link) /* head of special-binding chain */ + _node(xframe) /* exception frame chain */ + _node(pc) /* TRA of catch exit or cleanup form */ + _endstructf + + _struct(_function,-misc_bias) + _node(header) + _node(codevector) + _ends + + _struct(tsp_frame,0) + _node(backlink) + _node(save_ebp) + _struct_label(fixed_overhead) + _struct_label(data_offset) + _ends + + _struct(csp_frame,0) + _node(backlink) + _node(save_ebp) + _struct_label(fixed_overhead) + _struct_label(data_offset) + _ends + + _structf(symbol) + _node(pname) + _node(vcell) + _node(fcell) + _node(package_predicate) + _node(flags) + _node(plist) + _node(binding_index) + _endstructf + + _structf(vectorH) + _node(logsize) + _node(physsize) + _node(data_vector) + _node(displacement) + _node(flags) + _endstructf + + _structf(arrayH) + _node(rank) + _node(physsize) + _node(data_vector) + _node(displacement) + _node(flags) + _struct_label(dim0) + _endstructf + + _struct(lisp_frame,0) + _node(backlink) + _node(savera0) + _ends + + _struct(vector,-fulltag_misc) + _node(header) + _struct_label(data) + _ends + + _struct(binding,0) + _node(link) + _node(sym) + _node(val) + _ends + +symbol_extra = symbol.size-fulltag_misc + + _struct(nrs,(0x13008+(LOWMEM_BIAS))) + _struct_pad(fulltag_misc) + _struct_label(tsym) + _struct_pad(symbol_extra) /* t */ + + _struct_pad(fulltag_misc) + _struct_label(nilsym) + _struct_pad(symbol_extra) /* nil */ + + _struct_pad(fulltag_misc) + _struct_label(errdisp) + _struct_pad(symbol_extra) /* %err-disp */ + + _struct_pad(fulltag_misc) + _struct_label(cmain) + _struct_pad(symbol_extra) /* cmain */ + + _struct_pad(fulltag_misc) + _struct_label(eval) + _struct_pad(symbol_extra) /* eval */ + + _struct_pad(fulltag_misc) + _struct_label(appevalfn) + _struct_pad(symbol_extra) /* apply-evaluated-function */ + + _struct_pad(fulltag_misc) + _struct_label(error) + _struct_pad(symbol_extra) /* error */ + + _struct_pad(fulltag_misc) + _struct_label(defun) + _struct_pad(symbol_extra) /* %defun */ + + _struct_pad(fulltag_misc) + _struct_label(defvar) + _struct_pad(symbol_extra) /* %defvar */ + + _struct_pad(fulltag_misc) + _struct_label(defconstant) + _struct_pad(symbol_extra) /* %defconstant */ + + _struct_pad(fulltag_misc) + _struct_label(macrosym) + _struct_pad(symbol_extra) /* %macro */ + + _struct_pad(fulltag_misc) + _struct_label(kernelrestart) + _struct_pad(symbol_extra) /* %kernel-restart */ + + _struct_pad(fulltag_misc) + _struct_label(package) + _struct_pad(symbol_extra) /* *package* */ + + _struct_pad(fulltag_misc) + _struct_label(total_bytes_freed) + _struct_pad(symbol_extra) /* *total-bytes-freed* */ + + _struct_pad(fulltag_misc) + _struct_label(kallowotherkeys) + _struct_pad(symbol_extra) /* allow-other-keys */ + + _struct_pad(fulltag_misc) + _struct_label(toplcatch) + _struct_pad(symbol_extra) /* %toplevel-catch% */ + + _struct_pad(fulltag_misc) + _struct_label(toplfunc) + _struct_pad(symbol_extra) /* %toplevel-function% */ + + _struct_pad(fulltag_misc) + _struct_label(callbacks) + _struct_pad(symbol_extra) /* %pascal-functions% */ + + _struct_pad(fulltag_misc) + _struct_label(allmeteredfuns) + _struct_pad(symbol_extra) /* *all-metered-functions* */ + + _struct_pad(fulltag_misc) + _struct_label(total_gc_microseconds) + _struct_pad(symbol_extra) /* *total-gc-microseconds* */ + + _struct_pad(fulltag_misc) + _struct_label(builtin_functions) + _struct_pad(symbol_extra) /* %builtin-functions% */ + + _struct_pad(fulltag_misc) + _struct_label(udf) + _struct_pad(symbol_extra) /* %unbound-function% */ + + _struct_pad(fulltag_misc) + _struct_label(init_misc) + _struct_pad(symbol_extra) /* %init-misc */ + + _struct_pad(fulltag_misc) + _struct_label(macro_code) + _struct_pad(symbol_extra) /* %macro-code% */ + + _struct_pad(fulltag_misc) + _struct_label(closure_code) + _struct_pad(symbol_extra) /* %closure-code% */ + + _struct_pad(fulltag_misc) + _struct_label(new_gcable_ptr) + _struct_pad(symbol_extra) /* %new-gcable-ptr */ + + _struct_pad(fulltag_misc) + _struct_label(gc_event_status_bits) + _struct_pad(symbol_extra) /* *gc-event-status-bits* */ + + _struct_pad(fulltag_misc) + _struct_label(post_gc_hook) + _struct_pad(symbol_extra) /* *post-gc-hook* */ + + _struct_pad(fulltag_misc) + _struct_label(handlers) + _struct_pad(symbol_extra) /* %handlers% */ + + _struct_pad(fulltag_misc) + _struct_label(all_packages) + _struct_pad(symbol_extra) /* %all-packages% */ + + _struct_pad(fulltag_misc) + _struct_label(keyword_package) + _struct_pad(symbol_extra) /* *keyword-package* */ + + _struct_pad(fulltag_misc) + _struct_label(finalization_alist) + _struct_pad(symbol_extra) /* %finalization-alist% */ + + _struct_pad(fulltag_misc) + _struct_label(foreign_thread_control) + _struct_pad(symbol_extra) /* %foreign-thread-control */ + + _ends + +define([def_header],[$1 = ($2<Rax) */ +#define REG_RAX 0 +#define REG_RCX 1 +#define REG_RDX 2 +#define REG_RBX 3 +#define REG_RSP 4 +#define REG_RBP 5 +#define REG_RSI 6 +#define REG_RDI 7 +#define REG_R8 8 +#define REG_R9 9 +#define REG_R10 10 +#define REG_R11 11 +#define REG_R12 12 +#define REG_R13 13 +#define REG_R14 14 +#define REG_R15 15 +#define REG_RIP 16 +#endif + +/* Define indices of the GPRs in the mcontext component of a ucontext */ +#define Itemp0 REG_RBX +#define Iarg_y REG_RDI +#define Iarg_x REG_R8 +#define Iarg_z REG_RSI +#define Isave3 REG_R11 +#define Isave2 REG_R12 +#define Isave1 REG_R14 +#define Isave0 REG_R15 +#define Itemp2 REG_R10 +#define Ifn REG_R13 +#define Irbp REG_RBP +#define Iimm0 REG_RAX +#define Iimm1 REG_RDX +#define Iimm2 REG_RCX +#define Itemp1 REG_R9 +#define Isp REG_RSP +#define Iip REG_RIP +#if defined(LINUX) || defined(WINDOWS) +#define Iflags REG_EFL +#endif + +#if defined(SOLARIS) || defined(FREEBSD) || defined(DARWIN) +#define Iflags REG_RFL +#endif + + +#define Iallocptr Itemp0 +#define Ira0 Itemp2 +#define Inargs Iimm2 +#define Ixfn Itemp1 +#define Ifp Irbp + + +#define nbits_in_word 64L +#define log2_nbits_in_word 6L +#define nbits_in_byte 8L +#define ntagbits 4L +#define nlisptagbits 3L +#define nfixnumtagbits 2L +#define num_subtag_bits 8L +#define fixnumshift 3L +#define fixnum_shift 3L +#define fulltagmask 15L +#define tagmask 7L +#define fixnummask 3 +#define subtagmask ((1L<> 2) - 3) + +typedef struct doh_block { + struct doh_block *link; + unsigned size; + unsigned free; + LispObj data[doh_block_slots]; +} doh_block, *doh_block_ptr; + + +#define population_weak_list (0< call lisp_exit_hook */ + void* native_thread_info; /* platform-dependent */ + void* native_thread_id; /* mach_thread_t, pid_t, etc. */ + void* last_allocptr; + void* save_allocptr; + void* save_allocbase; + void* reset_completion; + void* activate; + signed_natural suspend_count; + ExceptionInformation* suspend_context; + ExceptionInformation* pending_exception_context; + void* suspend; /* suspension semaphore */ + void* resume; /* resumption semaphore */ + natural flags; + ExceptionInformation* gc_context; + void* termination_semaphore; + signed_natural unwinding; + natural tlb_limit; + LispObj* tlb_pointer; + natural shutdown_count; + LispObj* next_tsp; + void *safe_ref_address; + void *pending_io_info; + void *io_datum; +} TCR; + +#define t_offset (t_value-nil_value) + +typedef struct { + natural Rip; + natural Cs; /* in low 16 bits */ + natural Rflags; /* in low 32 bits */ + natural Rsp; + natural Ss; /* in low 16 bits*/ +} x64_iret_frame; + +/* + These were previously global variables. There are lots of implicit + assumptions about the size of a heap segment, so they might as well + be constants. +*/ + +#define heap_segment_size 0x00020000L +#define log2_heap_segment_size 17L + Index: /branches/new-random/lisp-kernel/x86-constants64.s =================================================================== --- /branches/new-random/lisp-kernel/x86-constants64.s (revision 13309) +++ /branches/new-random/lisp-kernel/x86-constants64.s (revision 13309) @@ -0,0 +1,1048 @@ +/* Copyright (C) 2005-2009 Clozure Associates */ +/* This file is part of Clozure CL. */ + +/* Clozure CL is licensed under the terms of the Lisp Lesser GNU Public */ +/* License , known as the LLGPL and distributed with Clozure CL as the */ +/* file "LICENSE". The LLGPL consists of a preamble and the LGPL, */ +/* which is distributed with Clozure CL as the file "LGPL". Where these */ +/* conflict, the preamble takes precedence. */ + +/* Clozure CL is referenced in the preamble as the "LIBRARY." */ + +/* The LLGPL is also available online at */ +/* http://opensource.franz.com/preamble.html */ + + +/* Register usage. This is certainly a little short of */ +/* immediate registers; we can maybe use the low bits */ +/* of mmx or xmm registers to hold immediate values and */ +/* do some unboxed arithmetic. */ + + +/* + + Register usage in C calling conventions differ between + Darwin/Linux/FreeBSD (which use the AMD-defined ABI) and + Windows64 (which uses something else). The good news is that + Win64 did away with the cdecl/stdcall/fastcall madness, there + is only one ABI left. Here's a rundown. + + AMD64^Wx86-64 ABI: + * Integer and pointer function arguments passed (from left to + right) in RDI, RSI, RDX, RCX, R8 and R9 + * FP arguments are passed in XMM0..XMM7 + * rest is passed on stack + * return value in RAX + * Callee must preserve RBP, RBX, R12..R15, MXCSR control bits + * On function entry, x87 mode and DF clear is assumed + * [RSP]..[RSP-128] must not be touched by signal handlers + + Win64 ABI: + * Integer and pointers passed in RCX, RDX, R8, R9 + * FP passed in XMM0..XMM3 + * rest is passed on stack + * Return value in RAX or XMM0 + * Caller (!) responsible for creating and cleaning stack space for + spilling integer registers + * Callee must preserve RBP, RBX, RSI, RDI, R12..R15, XMM6..XMM15 + + Both want their stack pointers to be 16 byte aligned on call, + equivalent to 8 byte offset after call due to pushed return address. + + http://msdn2.microsoft.com/en-us/library/zthk2dkh(VS.80).aspx + http://www.tortall.net/projects/yasm/manual/html/objfmt-win64-exception.html + http://www.x86-64.org/documentation/abi.pdf + + + Lisp register usage: + + Clozure CL renames the physical registers, giving them names + based on their usage. An overview: + + imm0..imm2 + temp0..temp2 + save0..save3 + arg_x, arg_y, arg_z + fn + + On top of that, further mappings are defined: + + fname, next_method_context: temp0 + nargs: imm2 + ra0: temp2 + xfn: temp1 + allocptr: temp0 + stack_temp: mm7 + + x86-64 ABI mapping: + + imm0..imm2: RAX, RDX, RCX + temp0..temp2: RBX, R9, R10 + save0..save3: R15, R14, R12, R11 + arg_x, arg_y, arg_z: R8, RDI, RSI + fn: R13 + rcontext_reg: GS + + Win64 specifics: + rcontext_reg: R11 + +*/ + + +/* Redefining these standard register names - with the same _l, _w, _b suffixes */ +/* used in lispy symbolic names - allows us to play Stupid M4 Tricks in macros */ + +define([rax_l],[eax]) +define([rax_w],[ax]) +define([rax_b],[al]) +define([rbx_l],[ebx]) +define([rbx_w],[bx]) +define([rbx_b],[bl]) +define([rcx_l],[ecx]) +define([rcx_w],[cx]) +define([rdx_l],[edx]) +define([rdx_w],[dx]) +define([rdx_b],[dl]) +define([rsi_l],[esi]) +define([rsi_w],[si]) +define([rsi_b],[sil]) +define([rdi_l],[edo]) +define([rdi_w],[di]) +define([rdi_b],[dil]) +define([r8_l],[r8d]) +define([r8_w],[r8w]) +define([r8_b],[r8b]) +define([r9_l],[r9d]) +define([r9_w],[r9w]) +define([r9_b],[r9b]) +define([r10_l],[r10d]) +define([r10_w],[r10w]) +define([r10_b],[r10b]) +define([r10_l],[r11d]) +define([r11_w],[r11w]) +define([r11_b],[r11b]) +define([r12_l],[r12d]) +define([r12_w],[r12w]) +define([r12_b],[r12b]) +define([r13_l],[r13d]) +define([r13_w],[r13w]) +define([r13_b],[r13b]) +define([r14_l],[r14d]) +define([r14_w],[r14w]) +define([r14_b],[r14b]) +define([r15_l],[r15d]) +define([r15_w],[r15w]) +define([r15_b],[r15b]) + +/* Registers when using Lisp calling conventions */ + +define([imm0],[rax]) + define([imm0_l],[eax]) + define([imm0_w],[ax]) + define([imm0_b],[al]) + define([Rimm0],[0]) + +define([temp0],[rbx]) + define([temp0_l],[ebx]) + define([temp0_w],[bx]) + define([temp0_b],[bl]) + define([Rtemp0],[3]) + +define([imm2],[rcx]) + define([imm2_l],[ecx]) + define([imm2_w],[cx]) + define([imm2_b],[cl]) + define([Rimm2],[1]) + +define([imm1],[rdx]) + define([imm1_l],[edx]) + define([imm1_w],[dx]) + define([imm1_b],[dl]) + define([Rimm1],[2]) + +define([arg_z],[rsi]) + define([arg_z_l],[esi]) + define([arg_z_w],[si]) + define([arg_z_b],[sil]) + define([Rarg_z],[6]) + +define([arg_y],[rdi]) + define([arg_y_l],[edi]) + define([arg_y_w],[di]) + define([arg_y_b],[dil]) + define([Rarg_y],[7]) + +define([arg_x],[r8]) + define([arg_x_l],[r8d]) + define([arg_x_w],[r8w]) + define([arg_x_b],[r8b]) + define([Rarg_x],[8]) + +define([temp1],[r9]) + define([temp1_l],[r9d]) + define([temp1_w],[r9w]) + define([temp1_b],[r9b]) + define([Rtemp1],[9]) + +define([temp2],[r10]) + define([temp2_l],[r10d]) + define([temp2_w],[r10w]) + define([temp2_x_b],[r10b]) + define([Rtemp2],[10]) + +define([save3],[r11]) + define([save3_l],[r11d]) + define([save3_w],[r11w]) + define([save3_b],[r11b]) + define([Rsave3],[11]) + +define([save2],[r12]) + define([save2_l],[r12d]) + define([save2_w],[r12w]) + define([save2_b],[r12b]) + define([Rsave2],[12]) + +define([fn],[r13]) /* some addressing restrictions */ + define([fn_l],[r13d]) + define([fn_w],[r13w]) + define([fn_b],[r13b]) + define([Rfn],[13]) + +define([save1],[r14]) + define([save1_l],[r14d]) + define([save1_w],[r14w]) + define([save1_b],[r14b]) + define([Rsave1],[14]) + +define([save0],[r15]) + define([save0_l],[r15d]) + define([save0_w],[r15w]) + define([save0_b],[r15b]) + define([Rsave0],[15]) + + +ifdef([TCR_IN_GPR],[ +/* We keep the TCR pointer in r11 */ + define([rcontext_reg], r11) + define([rcontext],[$1(%rcontext_reg)]) +],[ +/* The TCR can be accessed relative to %gs */ + define([rcontext_reg],[gs]) + define([rcontext],[%rcontext_reg:$1]) +]) +define([fname],[temp0]) +define([next_method_context],[temp0]) +define([nargs_b],[imm2_b]) +define([nargs_w],[imm2_w]) +define([nargs_q],[imm2]) +define([nargs],[imm2_l]) +define([ra0],[temp2]) + +define([xfn],[temp1]) + +define([allocptr],[temp0]) +define([stack_temp],[mm7]) + + +define([fp0],[xmm0]) +define([fp1],[xmm1]) +define([fp2],[xmm2]) +define([fp3],[xmm3]) +define([fp4],[xmm4]) +define([fp5],[xmm5]) +define([fp6],[xmm6]) +define([fp7],[xmm7]) +define([fp8],[xmm8]) +define([fp9],[xmm9]) +define([fp10],[xmm10]) +define([fp11],[xmm11]) +define([fp12],[xmm12]) +define([fp13],[xmm13]) +define([fp14],[xmm14]) +define([fp15],[xmm15]) +define([fpzero],[fp15]) + +/* Registers when running with native C calling conventions */ + +define([cret],[rax]) + define([cret_l],[eax]) + define([cret_w],[ax]) + define([cret_b],[al]) + define([Rcret],[0]) + +define([ctemp0],[r10]) + define([ctemp0_l],[r10d]) + define([ctemp0_w],[r10w]) + define([ctemp0_b],[r10b]) + define([Rctemp0],[10]) + +define([ctemp1],[r11]) + define([ctemp1_l],[r11d]) + define([ctemp1_w],[r11w]) + define([ctemp1_b],[r11b]) + define([Rctemp1],[11]) + +define([csave0],[rbx]) + define([csave0_l],[ebx]) + define([csave0_w],[bx]) + define([csave0_b],[bl]) + define([Rcsave0],[3]) + +define([csave1],[r12]) + define([csave1_l],[r12d]) + define([csave1_w],[r12w]) + define([csave1_b],[r12b]) + define([Rcsave1],[12]) + +define([csave2],[r13]) + define([csave2_l],[r13d]) + define([csave2_w],[r13w]) + define([csave2_b],[r13b]) + define([Rcsave2],[13]) + +define([csave3],[r14]) + define([csave3_l],[r14d]) + define([csave3_w],[r14w]) + define([csave3_b],[r14b]) + define([Rcsave3],[14]) + +define([csave4],[r15]) + define([csave4_l],[r15d]) + define([csave4_w],[r15w]) + define([csave4_b],[r15b]) + define([Rcsave4],[15]) + +ifdef([WINDOWS],[ + +define([carg0],[rcx]) + define([carg0_l],[ecx]) + define([carg0_w],[cx]) + define([carg0_b],[cl]) + define([Rcarg0],[1]) + +define([carg1],[rdx]) + define([carg1_l],[edx]) + define([carg1_w],[dx]) + define([carg1_b],[dl]) + define([Rcarg1],[2]) + +define([carg2],[r8]) + define([carg2_l],[r8d]) + define([carg2_w],[r8w]) + define([carg2_b],[r8b]) + define([Rcarg2],[8]) + +define([carg3],[r9]) + define([carg3_l],[r9d]) + define([carg3_w],[r9w]) + define([carg3_b],[r9b]) + define([Rcarg3],[9]) + +define([csave5],[rsi]) + define([csave5_l],[esi]) + define([csave5_w],[si]) + define([csave5_b],[sil]) + define([csave5_z],[6]) + +define([csave6],[rdi]) + define([csave6_l],[edi]) + define([csave6_w],[di]) + define([csave6_b],[dil]) + define([Rcsave6],[7]) + +],[ + +define([carg0],[rdi]) + define([carg0_l],[edi]) + define([carg0_w],[di]) + define([carg0_b],[dil]) + define([Rcarg0],[7]) + +define([carg1],[rsi]) + define([carg1_l],[esi]) + define([carg1_w],[si]) + define([carg1_b],[sil]) + define([carg1_z],[6]) + +define([carg2],[rdx]) + define([carg2_l],[edx]) + define([carg2_w],[dx]) + define([carg2_b],[dl]) + define([Rcarg2],[2]) + +define([carg3],[rcx]) + define([carg3_l],[ecx]) + define([carg3_w],[cx]) + define([carg3_b],[cl]) + define([Rcarg3],[1]) + +define([carg4],[r8]) + define([carg4_l],[r8d]) + define([carg4_w],[r8w]) + define([carg4_b],[r8b]) + define([Rcarg4],[8]) + +define([carg5],[r9]) + define([carg5_l],[r9d]) + define([carg5_w],[r9w]) + define([carg5_b],[r9b]) + define([Rcarg5],[9]) +]) + +nbits_in_word = 64 +nbits_in_byte = 8 +ntagbits = 4 +nlisptagbits = 3 +nfixnumtagbits = 3 +nlowtagbits = 2 +num_subtag_bits = 8 +subtag_shift = num_subtag_bits +fixnumshift = 3 +fixnum_shift = 3 +fulltagmask = 15 +tagmask = 7 +fixnummask = 7 +ncharcodebits = 8 +charcode_shift = 8 +word_shift = 3 +node_size = 8 +dnode_size = 16 +dnode_align_bits = 4 +dnode_shift = dnode_align_bits +bitmap_shift = 6 + +fixnumone = (1< -> unwind-protect, else catch */ + _node(link) /* backpointer to previous catch frame */ + _node(mvflag) /* 0 if single-valued catch, fixnum 1 otherwise */ + _node(rsp) /* saved lisp sp */ + _node(rbp) /* saved lisp rbp */ + _node(foreign_sp) /* necessary ? */ + _node(db_link) /* head of special-binding chain */ + _node(_save3) + _node(_save2) + _node(_save1) + _node(_save0) + _node(xframe) /* exception frame chain */ + _node(pc) /* TRA of catch exit or cleanup form */ + _endstructf + + + _structf(vectorH) + _node(logsize) + _node(physsize) + _node(data_vector) + _node(displacement) + _node(flags) + _endstructf + + _structf(arrayH) + _node(rank) + _node(physsize) + _node(data_vector) + _node(displacement) + _node(flags) + _struct_label(dim0) + _endstructf + + + _struct(c_frame,0) /* PowerOpen ABI C stack frame */ + _node(backlink) + _node(crsave) + _node(savelr) + _field(unused, 16) + _node(savetoc) + _struct_label(params) + _node(param0) + _node(param1) + _node(param2) + _node(param3) + _node(param4) + _node(param5) + _node(param6) + _node(param7) + _struct_label(minsiz) + _ends + + + _struct(eabi_c_frame,0) + _word(backlink) + _word(savelr) + _word(param0) + _word(param1) + _word(param2) + _word(param3) + _word(param4) + _word(param5) + _word(param6) + _word(param7) + _struct_label(minsiz) + _ends + + /* For entry to variable-argument-list functions */ + /* (e.g., via callback) */ + _struct(varargs_eabi_c_frame,0) + _word(backlink) + _word(savelr) + _struct_label(va_list) + _word(flags) /* gpr count byte, fpr count byte, padding */ + _word(overflow_arg_area) + _word(reg_save_area) + _field(padding,4) + _struct_label(regsave) + _field(gp_save,8*4) + _field(fp_save,8*8) + _word(old_backlink) + _word(old_savelr) + _struct_label(incoming_stack_args) + _ends + + _struct(lisp_frame,0) + _node(backlink) + _node(savera0) + _ends + + _struct(vector,-fulltag_misc) + _node(header) + _struct_label(data) + _ends + + _struct(binding,0) + _node(link) + _node(sym) + _node(val) + _ends + + +/* Nilreg-relative globals. Talking the assembler into doing */ +/* something reasonable here */ +/* is surprisingly hard. */ + +symbol_extra = symbol.size-fulltag_symbol + + + _struct(nrs,0x13020) + _struct_pad(fulltag_symbol) + _struct_label(tsym) + _struct_pad(symbol_extra) /* t */ + + _struct_pad(fulltag_symbol) + _struct_label(nil) + _struct_pad(symbol_extra) /* nil */ + + _struct_pad(fulltag_symbol) + _struct_label(errdisp) + _struct_pad(symbol_extra) /* %err-disp */ + + _struct_pad(fulltag_symbol) + _struct_label(cmain) + _struct_pad(symbol_extra) /* cmain */ + + _struct_pad(fulltag_symbol) + _struct_label(eval) + _struct_pad(symbol_extra) /* eval */ + + _struct_pad(fulltag_symbol) + _struct_label(appevalfn) + _struct_pad(symbol_extra) /* apply-evaluated-function */ + + _struct_pad(fulltag_symbol) + _struct_label(error) + _struct_pad(symbol_extra) /* error */ + + _struct_pad(fulltag_symbol) + _struct_label(defun) + _struct_pad(symbol_extra) /* %defun */ + + _struct_pad(fulltag_symbol) + _struct_label(defvar) + _struct_pad(symbol_extra) /* %defvar */ + + _struct_pad(fulltag_symbol) + _struct_label(defconstant) + _struct_pad(symbol_extra) /* %defconstant */ + + _struct_pad(fulltag_symbol) + _struct_label(macrosym) + _struct_pad(symbol_extra) /* %macro */ + + _struct_pad(fulltag_symbol) + _struct_label(kernelrestart) + _struct_pad(symbol_extra) /* %kernel-restart */ + + _struct_pad(fulltag_symbol) + _struct_label(package) + _struct_pad(symbol_extra) /* *package* */ + + _struct_pad(fulltag_symbol) + _struct_label(total_bytes_freed) /* *total-bytes-freed* */ + _struct_pad(symbol_extra) + + _struct_pad(fulltag_symbol) + _struct_label(kallowotherkeys) + _struct_pad(symbol_extra) /* allow-other-keys */ + + _struct_pad(fulltag_symbol) + _struct_label(toplcatch) + _struct_pad(symbol_extra) /* %toplevel-catch% */ + + _struct_pad(fulltag_symbol) + _struct_label(toplfunc) + _struct_pad(symbol_extra) /* %toplevel-function% */ + + _struct_pad(fulltag_symbol) + _struct_label(callbacks) + _struct_pad(symbol_extra) /* %pascal-functions% */ + + _struct_pad(fulltag_symbol) + _struct_label(allmeteredfuns) + _struct_pad(symbol_extra) /* *all-metered-functions* */ + + _struct_pad(fulltag_symbol) + _struct_label(total_gc_microseconds) /* *total-gc-microseconds* */ + _struct_pad(symbol_extra) + + _struct_pad(fulltag_symbol) + _struct_label(builtin_functions) /* %builtin-functions% */ + _struct_pad(symbol_extra) + + _struct_pad(fulltag_symbol) + _struct_label(udf) + _struct_pad(symbol_extra) /* %unbound-function% */ + + _struct_pad(fulltag_symbol) + _struct_label(init_misc) + _struct_pad(symbol_extra) /* %init-misc */ + + _struct_pad(fulltag_symbol) + _struct_label(macro_code) + _struct_pad(symbol_extra) /* %macro-code% */ + + _struct_pad(fulltag_symbol) + _struct_label(closure_code) + _struct_pad(symbol_extra) /* %closure-code% */ + + _struct_pad(fulltag_symbol) + _struct_label(new_gcable_ptr) /* %new-gcable-ptr */ + _struct_pad(symbol_extra) + + _struct_pad(fulltag_symbol) + _struct_label(gc_event_status_bits) + _struct_pad(symbol_extra) /* *gc-event-status-bits* */ + + _struct_pad(fulltag_symbol) + _struct_label(post_gc_hook) + _struct_pad(symbol_extra) /* *post-gc-hook* */ + + _struct_pad(fulltag_symbol) + _struct_label(handlers) + _struct_pad(symbol_extra) /* %handlers% */ + + + _struct_pad(fulltag_symbol) + _struct_label(all_packages) + _struct_pad(symbol_extra) /* %all-packages% */ + + _struct_pad(fulltag_symbol) + _struct_label(keyword_package) + _struct_pad(symbol_extra) /* *keyword-package* */ + + _struct_pad(fulltag_symbol) + _struct_label(finalization_alist) + _struct_pad(symbol_extra) /* %finalization-alist% */ + + _struct_pad(fulltag_symbol) + _struct_label(foreign_thread_control) + _struct_pad(symbol_extra) /* %foreign-thread-control */ + + _ends + +define([def_header],[ +$1 = ($2< +#include +#include +#include +#include +#include +#include +#ifdef LINUX +#include +#include +#include +#include +#endif +#ifdef DARWIN +#include +#endif +#ifndef WINDOWS +#include +#endif +#ifdef WINDOWS +#include +#ifdef WIN_64 +#include +#include +#endif +#ifndef EXCEPTION_WRITE_FAULT +#define EXCEPTION_WRITE_FAULT 1 +#endif +#endif + +int +page_size = 4096; + +int +log2_page_size = 12; + + +void +update_bytes_allocated(TCR* tcr, void *cur_allocptr) +{ + BytePtr + last = (BytePtr) tcr->last_allocptr, + current = (BytePtr) cur_allocptr; + if (last && (tcr->save_allocbase != ((void *)VOID_ALLOCPTR))) { + tcr->bytes_allocated += last-current; + } + tcr->last_allocptr = 0; +} + + + +// This doesn't GC; it returns true if it made enough room, false +// otherwise. +// If "extend" is true, it can try to extend the dynamic area to +// satisfy the request. + + +Boolean +new_heap_segment(ExceptionInformation *xp, natural need, Boolean extend, TCR *tcr) +{ + area *a; + natural newlimit, oldlimit; + natural log2_allocation_quantum = tcr->log2_allocation_quantum; + + a = active_dynamic_area; + oldlimit = (natural) a->active; + newlimit = (align_to_power_of_2(oldlimit, log2_allocation_quantum) + + align_to_power_of_2(need, log2_allocation_quantum)); + if (newlimit > (natural) (a->high)) { + if (extend) { + signed_natural inhibit = (signed_natural)(lisp_global(GC_INHIBIT_COUNT)); + natural extend_by = inhibit ? 0 : lisp_heap_gc_threshold; + do { + if (resize_dynamic_heap(a->active, (newlimit-oldlimit)+extend_by)) { + break; + } + extend_by = align_to_power_of_2(extend_by>>1,log2_allocation_quantum); + if (extend_by < 4<<20) { + return false; + } + } while (1); + } else { + return false; + } + } + a->active = (BytePtr) newlimit; + tcr->last_allocptr = (void *)newlimit; + tcr->save_allocptr = (void *)newlimit; + xpGPR(xp,Iallocptr) = (LispObj) newlimit; + tcr->save_allocbase = (void *) oldlimit; + + return true; +} + +Boolean +allocate_object(ExceptionInformation *xp, + natural bytes_needed, + signed_natural disp_from_allocptr, + TCR *tcr) +{ + area *a = active_dynamic_area; + + /* Maybe do an EGC */ + if (a->older && lisp_global(OLDEST_EPHEMERAL)) { + if (((a->active)-(a->low)) >= a->threshold) { + gc_from_xp(xp, 0L); + } + } + + /* Life is pretty simple if we can simply grab a segment + without extending the heap. + */ + if (new_heap_segment(xp, bytes_needed, false, tcr)) { + xpGPR(xp, Iallocptr) -= disp_from_allocptr; + tcr->save_allocptr = (void *) (xpGPR(xp, Iallocptr)); + return true; + } + + /* It doesn't make sense to try a full GC if the object + we're trying to allocate is larger than everything + allocated so far. + */ + if ((lisp_global(HEAP_END)-lisp_global(HEAP_START)) > bytes_needed) { + untenure_from_area(tenured_area); /* force a full GC */ + gc_from_xp(xp, 0L); + } + + /* Try again, growing the heap if necessary */ + if (new_heap_segment(xp, bytes_needed, true, tcr)) { + xpGPR(xp, Iallocptr) -= disp_from_allocptr; + tcr->save_allocptr = (void *) (xpGPR(xp, Iallocptr)); + return true; + } + + return false; +} + +natural gc_deferred = 0, full_gc_deferred = 0; + +signed_natural +flash_freeze(TCR *tcr, signed_natural param) +{ + return 0; +} + + +Boolean +handle_gc_trap(ExceptionInformation *xp, TCR *tcr) +{ + LispObj selector = xpGPR(xp,Iimm0); +#ifdef X8664 + LispObj arg = xpGPR(xp,Iimm1); +#else + LispObj arg = xpMMXreg(xp,Imm0); +#endif + area *a = active_dynamic_area; + Boolean egc_was_enabled = (a->older != NULL); + + natural gc_previously_deferred = gc_deferred; + + switch (selector) { + case GC_TRAP_FUNCTION_EGC_CONTROL: + egc_control(arg != 0, a->active); + xpGPR(xp,Iarg_z) = lisp_nil + (egc_was_enabled ? t_offset : 0); + break; + + case GC_TRAP_FUNCTION_CONFIGURE_EGC: +#ifdef X8664 + a->threshold = unbox_fixnum(xpGPR(xp, Iarg_x)); +#else + a->threshold = unbox_fixnum(xpGPR(xp, Itemp0)); +#endif + g1_area->threshold = unbox_fixnum(xpGPR(xp, Iarg_y)); + g2_area->threshold = unbox_fixnum(xpGPR(xp, Iarg_z)); + xpGPR(xp,Iarg_z) = lisp_nil+t_offset; + break; + + case GC_TRAP_FUNCTION_SET_LISP_HEAP_THRESHOLD: + if (((signed_natural) arg) > 0) { + lisp_heap_gc_threshold = + align_to_power_of_2((arg-1) + + (heap_segment_size - 1), + log2_heap_segment_size); + } + /* fall through */ + case GC_TRAP_FUNCTION_GET_LISP_HEAP_THRESHOLD: + xpGPR(xp, Iimm0) = lisp_heap_gc_threshold; + break; + + case GC_TRAP_FUNCTION_USE_LISP_HEAP_THRESHOLD: + /* Try to put the current threshold in effect. This may + need to disable/reenable the EGC. */ + untenure_from_area(tenured_area); + resize_dynamic_heap(a->active,lisp_heap_gc_threshold); + if (egc_was_enabled) { + if ((a->high - a->active) >= a->threshold) { + tenure_to_area(tenured_area); + } + } + xpGPR(xp, Iimm0) = lisp_heap_gc_threshold; + break; + + case GC_TRAP_FUNCTION_ENSURE_STATIC_CONSES: + ensure_static_conses(xp, tcr, 32768); + break; + + case GC_TRAP_FUNCTION_FLASH_FREEZE: /* Like freeze below, but no GC */ + untenure_from_area(tenured_area); + gc_like_from_xp(xp,flash_freeze,0); + a->active = (BytePtr) align_to_power_of_2(a->active, log2_page_size); + tenured_area->static_dnodes = area_dnode(a->active, a->low); + if (egc_was_enabled) { + tenure_to_area(tenured_area); + } + xpGPR(xp, Iimm0) = tenured_area->static_dnodes << dnode_shift; + break; + + default: + update_bytes_allocated(tcr, (void *) tcr->save_allocptr); + + if (selector == GC_TRAP_FUNCTION_IMMEDIATE_GC) { + if (!full_gc_deferred) { + gc_from_xp(xp, 0L); + break; + } + /* Tried to do a full GC when gc was disabled. That failed, + so try full GC now */ + selector = GC_TRAP_FUNCTION_GC; + } + + if (egc_was_enabled) { + egc_control(false, (BytePtr) a->active); + } + gc_from_xp(xp, 0L); + if (gc_deferred > gc_previously_deferred) { + full_gc_deferred = 1; + } else { + full_gc_deferred = 0; + } + if (selector > GC_TRAP_FUNCTION_GC) { + if (selector & GC_TRAP_FUNCTION_IMPURIFY) { + impurify_from_xp(xp, 0L); + /* nrs_GC_EVENT_STATUS_BITS.vcell |= gc_integrity_check_bit; */ + lisp_global(OLDSPACE_DNODE_COUNT) = 0; + gc_from_xp(xp, 0L); + } + if (selector & GC_TRAP_FUNCTION_PURIFY) { + purify_from_xp(xp, 1); + lisp_global(OLDSPACE_DNODE_COUNT) = area_dnode(managed_static_area->active, managed_static_area->low); + gc_from_xp(xp, 0L); + } + if (selector & GC_TRAP_FUNCTION_SAVE_APPLICATION) { + OSErr err; + extern OSErr save_application(unsigned, Boolean); + area *vsarea = tcr->vs_area; + +#ifdef WINDOWS + arg = _open_osfhandle(arg,0); +#endif + nrs_TOPLFUNC.vcell = *((LispObj *)(vsarea->high)-1); + err = save_application(arg, egc_was_enabled); + if (err == noErr) { + _exit(0); + } + fatal_oserr(": save_application", err); + } + switch (selector) { + case GC_TRAP_FUNCTION_FREEZE: + a->active = (BytePtr) align_to_power_of_2(a->active, log2_page_size); + tenured_area->static_dnodes = area_dnode(a->active, a->low); + xpGPR(xp, Iimm0) = tenured_area->static_dnodes << dnode_shift; + break; + default: + break; + } + } + if (egc_was_enabled) { + egc_control(true, NULL); + } + break; + } + return true; +} + + + + + +void +push_on_lisp_stack(ExceptionInformation *xp, LispObj value) +{ + LispObj *vsp = (LispObj *)xpGPR(xp,Isp); + *--vsp = value; + xpGPR(xp,Isp) = (LispObj)vsp; +} + + +/* Hard to know if or whether this is necessary in general. For now, + do it when we get a "wrong number of arguments" trap. +*/ +void +finish_function_entry(ExceptionInformation *xp) +{ + natural nargs = xpGPR(xp,Inargs)>>fixnumshift; + signed_natural disp = nargs - nargregs; + LispObj *vsp = (LispObj *) xpGPR(xp,Isp), ra = *vsp++; + + xpGPR(xp,Isp) = (LispObj) vsp; + + if (disp > 0) { /* implies that nargs > nargregs */ + vsp[disp] = xpGPR(xp,Ifp); + vsp[disp+1] = ra; + xpGPR(xp,Ifp) = (LispObj)(vsp+disp); +#ifdef X8664 + push_on_lisp_stack(xp,xpGPR(xp,Iarg_x)); +#endif + push_on_lisp_stack(xp,xpGPR(xp,Iarg_y)); + push_on_lisp_stack(xp,xpGPR(xp,Iarg_z)); + } else { + push_on_lisp_stack(xp,ra); + push_on_lisp_stack(xp,xpGPR(xp,Ifp)); + xpGPR(xp,Ifp) = xpGPR(xp,Isp); +#ifdef X8664 + if (nargs == 3) { + push_on_lisp_stack(xp,xpGPR(xp,Iarg_x)); + } +#endif + if (nargs >= 2) { + push_on_lisp_stack(xp,xpGPR(xp,Iarg_y)); + } + if (nargs >= 1) { + push_on_lisp_stack(xp,xpGPR(xp,Iarg_z)); + } + } +} + +Boolean +object_contains_pc(LispObj container, LispObj addr) +{ + if (fulltag_of(container) >= fulltag_misc) { + natural elements = header_element_count(header_of(container)); + if ((addr >= container) && + (addr < ((LispObj)&(deref(container,1+elements))))) { + return true; + } + } + return false; +} + +LispObj +create_exception_callback_frame(ExceptionInformation *xp, TCR *tcr) +{ + LispObj containing_uvector = 0, + relative_pc, + nominal_function = lisp_nil, + f, tra, tra_f = 0, abs_pc; + + f = xpGPR(xp,Ifn); + tra = *(LispObj*)(xpGPR(xp,Isp)); + +#ifdef X8664 + if (tag_of(tra) == tag_tra) { + if ((*((unsigned short *)tra) == RECOVER_FN_FROM_RIP_WORD0) && + (*((unsigned char *)(tra+2)) == RECOVER_FN_FROM_RIP_BYTE2)) { + int sdisp = (*(int *) (tra+3)); + tra_f = RECOVER_FN_FROM_RIP_LENGTH+tra+sdisp; + } + if (fulltag_of(tra_f) != fulltag_function) { + tra_f = 0; + } + } else { + tra = 0; + } +#endif +#ifdef X8632 + if (fulltag_of(tra) == fulltag_tra) { + if (*(unsigned char *)tra == RECOVER_FN_OPCODE) { + tra_f = (LispObj)*(LispObj *)(tra + 1); + } + if (tra_f && header_subtag(header_of(tra_f)) != subtag_function) { + tra_f = 0; + } + } else { + tra = 0; + } +#endif + + abs_pc = (LispObj)xpPC(xp); + +#ifdef X8664 + if (fulltag_of(f) == fulltag_function) +#else + if (fulltag_of(f) == fulltag_misc && + header_subtag(header_of(f)) == subtag_function) +#endif + { + nominal_function = f; + } else { + if (tra_f) { + nominal_function = tra_f; + } + } + + f = xpGPR(xp,Ifn); + if (object_contains_pc(f, abs_pc)) { + containing_uvector = untag(f)+fulltag_misc; + } else { + f = xpGPR(xp,Ixfn); + if (object_contains_pc(f, abs_pc)) { + containing_uvector = untag(f)+fulltag_misc; + } else { + if (tra_f) { + f = tra_f; + if (object_contains_pc(f, abs_pc)) { + containing_uvector = untag(f)+fulltag_misc; + relative_pc = (abs_pc - f) << fixnumshift; + } + } + } + } + if (containing_uvector) { + relative_pc = (abs_pc - (LispObj)&(deref(containing_uvector,1))) << fixnumshift; + } else { + containing_uvector = lisp_nil; + relative_pc = abs_pc << fixnumshift; + } + push_on_lisp_stack(xp,(LispObj)(tcr->xframe->prev)); + push_on_lisp_stack(xp,(LispObj)(tcr->foreign_sp)); + push_on_lisp_stack(xp,tra); + push_on_lisp_stack(xp,(LispObj)xp); + push_on_lisp_stack(xp,containing_uvector); + push_on_lisp_stack(xp,relative_pc); + push_on_lisp_stack(xp,nominal_function); + push_on_lisp_stack(xp,0); + push_on_lisp_stack(xp,xpGPR(xp,Ifp)); + xpGPR(xp,Ifp) = xpGPR(xp,Isp); + return xpGPR(xp,Isp); +} + +#ifndef XMEMFULL +#define XMEMFULL (76) +#endif + +void +lisp_allocation_failure(ExceptionInformation *xp, TCR *tcr, natural bytes_needed ) +{ + LispObj xcf = create_exception_callback_frame(xp, tcr), + cmain = nrs_CMAIN.vcell; + int skip; + + tcr->save_allocptr = tcr->save_allocbase = (void *)VOID_ALLOCPTR; + xpGPR(xp,Iallocptr) = VOID_ALLOCPTR; + + skip = callback_to_lisp(tcr, cmain, xp, xcf, -1, XMEMFULL, 0, 0); + xpPC(xp) += skip; +} + +/* + Allocate a large list, where "large" means "large enough to + possibly trigger the EGC several times if this was done + by individually allocating each CONS." The number of + ocnses in question is in arg_z; on successful return, + the list will be in arg_z +*/ + +Boolean +allocate_list(ExceptionInformation *xp, TCR *tcr) +{ + natural + nconses = (unbox_fixnum(xpGPR(xp,Iarg_z))), + bytes_needed = (nconses << dnode_shift); + LispObj + prev = lisp_nil, + current, + initial = xpGPR(xp,Iarg_y); + + if (nconses == 0) { + /* Silly case */ + xpGPR(xp,Iarg_z) = lisp_nil; + xpGPR(xp,Iallocptr) = lisp_nil; + return true; + } + update_bytes_allocated(tcr, (void *)tcr->save_allocptr); + if (allocate_object(xp,bytes_needed,bytes_needed-fulltag_cons,tcr)) { + tcr->save_allocptr -= fulltag_cons; + for (current = xpGPR(xp,Iallocptr); + nconses; + prev = current, current+= dnode_size, nconses--) { + deref(current,0) = prev; + deref(current,1) = initial; + } + xpGPR(xp,Iarg_z) = prev; + } else { + lisp_allocation_failure(xp,tcr,bytes_needed); + } + return true; +} + +Boolean +handle_alloc_trap(ExceptionInformation *xp, TCR *tcr) +{ + natural cur_allocptr, bytes_needed; + unsigned allocptr_tag; + signed_natural disp; + + cur_allocptr = xpGPR(xp,Iallocptr); + allocptr_tag = fulltag_of(cur_allocptr); + if (allocptr_tag == fulltag_misc) { +#ifdef X8664 + disp = xpGPR(xp,Iimm1); +#else + disp = xpGPR(xp,Iimm0); +#endif + } else { + disp = dnode_size-fulltag_cons; + } + bytes_needed = disp+allocptr_tag; + + update_bytes_allocated(tcr,((BytePtr)(cur_allocptr+disp))); + if (allocate_object(xp, bytes_needed, disp, tcr)) { + return true; + } + + lisp_allocation_failure(xp,tcr,bytes_needed); + + return true; +} + + +int +callback_to_lisp (TCR * tcr, LispObj callback_macptr, ExceptionInformation *xp, + natural arg1, natural arg2, natural arg3, natural arg4, natural arg5) +{ + natural callback_ptr; + int delta; + unsigned old_mxcsr = get_mxcsr(); +#ifdef X8632 + natural saved_node_regs_mask = tcr->node_regs_mask; + natural saved_unboxed0 = tcr->unboxed0; + natural saved_unboxed1 = tcr->unboxed1; + LispObj *vsp = (LispObj *)xpGPR(xp, Isp); +#endif + + set_mxcsr(0x1f80); + + /* Put the active stack pointers where .SPcallback expects them */ +#ifdef X8632 + tcr->node_regs_mask = X8632_DEFAULT_NODE_REGS_MASK; + + *--vsp = tcr->save0; + *--vsp = tcr->save1; + *--vsp = tcr->save2; + *--vsp = tcr->save3; + *--vsp = tcr->next_method_context; + xpGPR(xp, Isp) = (LispObj)vsp; +#endif + tcr->save_vsp = (LispObj *)xpGPR(xp, Isp); + tcr->save_fp = (LispObj *)xpGPR(xp, Ifp); + + /* Call back. The caller of this function may have modified stack/frame + pointers (and at least should have called prepare_for_callback()). + */ + callback_ptr = ((macptr *)ptr_from_lispobj(untag(callback_macptr)))->address; + UNLOCK(lisp_global(EXCEPTION_LOCK), tcr); + delta = ((int (*)())callback_ptr) (xp, arg1, arg2, arg3, arg4, arg5); + LOCK(lisp_global(EXCEPTION_LOCK), tcr); + +#ifdef X8632 + tcr->next_method_context = *vsp++; + tcr->save3 = *vsp++; + tcr->save2 = *vsp++; + tcr->save1 = *vsp++; + tcr->save0 = *vsp++; + xpGPR(xp, Isp) = (LispObj)vsp; + + tcr->node_regs_mask = saved_node_regs_mask; + tcr->unboxed0 = saved_unboxed0; + tcr->unboxed1 = saved_unboxed1; +#endif + set_mxcsr(old_mxcsr); + return delta; +} + +void +callback_for_interrupt(TCR *tcr, ExceptionInformation *xp) +{ + LispObj *save_vsp = (LispObj *)xpGPR(xp,Isp), + word_beyond_vsp = save_vsp[-1], + save_fp = xpGPR(xp,Ifp), + xcf = create_exception_callback_frame(xp, tcr); + int save_errno = errno; + + callback_to_lisp(tcr, nrs_CMAIN.vcell,xp, xcf, 0, 0, 0, 0); + xpGPR(xp,Ifp) = save_fp; + xpGPR(xp,Isp) = (LispObj)save_vsp; + save_vsp[-1] = word_beyond_vsp; + errno = save_errno; +} + +Boolean +handle_error(TCR *tcr, ExceptionInformation *xp) +{ + pc program_counter = (pc)xpPC(xp); + unsigned char op0 = program_counter[0], op1 = program_counter[1]; + LispObj rpc, errdisp = nrs_ERRDISP.vcell, + save_vsp = xpGPR(xp,Isp), xcf0, + save_fp = xpGPR(xp,Ifp); + int skip; + + if ((fulltag_of(errdisp) == fulltag_misc) && + (header_subtag(header_of(errdisp)) == subtag_macptr)) { + + if ((op0 == 0xcd) && (op1 >= 0xc0) && (op1 <= 0xc2)) { + finish_function_entry(xp); + } + xcf0 = create_exception_callback_frame(xp, tcr); + skip = callback_to_lisp(tcr, errdisp, xp, xcf0, 0, 0, 0, 0); + if (skip == -1) { + xcf *xcf1 = (xcf *)xcf0; + LispObj container = xcf1->containing_uvector; + + rpc = xcf1->relative_pc >> fixnumshift; + if (container == lisp_nil) { + xpPC(xp) = rpc; + } else { + xpPC(xp) = (LispObj)(&(deref(container, +#ifdef X8664 + 1 +#else + 0 +#endif +)))+rpc; + } + + skip = 0; + } + xpGPR(xp,Ifp) = save_fp; + xpGPR(xp,Isp) = save_vsp; + if ((op0 == 0xcd) && (op1 == 0xc7)) { + /* Continue after an undefined function call. The function + that had been undefined has already been called (in the + break loop), and a list of the values that it returned + in in the xp's %arg_z. A function that returns those + values in in the xp's %fn; we just have to adjust the + stack (keeping the return address in the right place + and discarding any stack args/reserved stack frame), + then set nargs and the PC so that that function's + called when we resume. + */ + LispObj *vsp =(LispObj *)save_vsp, ra = *vsp; + int nargs = xpGPR(xp, Inargs)>>fixnumshift; + +#ifdef X8664 + if (nargs > 3) { + xpGPR(xp,Isp)=(LispObj) (vsp + (1 + 2 + (nargs - 3))); + push_on_lisp_stack(xp,ra); + } +#else + if (nargs > 2) { + xpGPR(xp,Isp)=(LispObj) (vsp + (1 + 2 + (nargs - 2))); + push_on_lisp_stack(xp,ra); + } +#endif + xpPC(xp) = xpGPR(xp,Ifn); + xpGPR(xp,Inargs) = 1<why; + Boolean on_TSP = (which == kTSPsoftguard); + LispObj save_fp = xpGPR(xp,Ifp); + LispObj save_vsp = xpGPR(xp,Isp), + xcf, + cmain = nrs_CMAIN.vcell; + area *a; + protected_area_ptr soft; + TCR *tcr = get_tcr(false); + int skip; + + if ((fulltag_of(cmain) == fulltag_misc) && + (header_subtag(header_of(cmain)) == subtag_macptr)) { + if (on_TSP) { + a = tcr->ts_area; + } else { + a = tcr->vs_area; + } + soft = a->softprot; + unprotect_area(soft); + xcf = create_exception_callback_frame(xp, tcr); + skip = callback_to_lisp(tcr, cmain, xp, xcf, SIGSEGV, on_TSP, 0, 0); + xpGPR(xp,Ifp) = save_fp; + xpGPR(xp,Isp) = save_vsp; + xpPC(xp) += skip; + return true; + } + return false; +} + +Boolean +is_write_fault(ExceptionInformation *xp, siginfo_t *info) +{ +#ifdef DARWIN + return (UC_MCONTEXT(xp)->__es.__err & 0x2) != 0; +#endif +#if defined(LINUX) || defined(SOLARIS) + return (xpGPR(xp,REG_ERR) & 0x2) != 0; +#endif +#ifdef FREEBSD + return (xp->uc_mcontext.mc_err & 0x2) != 0; +#endif +#ifdef WINDOWS + return (info->ExceptionFlags == EXCEPTION_WRITE_FAULT); +#endif +} + +Boolean +handle_fault(TCR *tcr, ExceptionInformation *xp, siginfo_t *info, int old_valence) +{ +#ifdef FREEBSD +#ifdef X8664 + BytePtr addr = (BytePtr) xp->uc_mcontext.mc_addr; +#else + BytePtr addr = (BytePtr) info->si_addr; +#endif +#else +#ifdef WINDOWS + BytePtr addr = (BytePtr) info->ExceptionInformation[1]; +#else + BytePtr addr = (BytePtr) info->si_addr; +#endif +#endif + Boolean valid = IS_PAGE_FAULT(info,xp); + + if (valid) { + if (addr && (addr == tcr->safe_ref_address)) { + xpGPR(xp,Iimm0) = 0; + xpPC(xp) = xpGPR(xp,Ira0); + return true; + } + + { + protected_area *a = find_protected_area(addr); + protection_handler *handler; + + if (a) { + handler = protection_handlers[a->why]; + return handler(xp, a, addr); + } + } + + if ((addr >= readonly_area->low) && + (addr < readonly_area->active)) { + UnProtectMemory((LogicalAddress)(truncate_to_power_of_2(addr,log2_page_size)), + page_size); + return true; + } + + { + area *a = area_containing(addr); + + if (a && a->code == AREA_WATCHED && addr < a->high) { + /* caught a write to a watched object */ + LispObj *p = (LispObj *)a->low; + LispObj node = *p; + unsigned tag_n = fulltag_of(node); + LispObj cmain = nrs_CMAIN.vcell; + LispObj obj; + + if (immheader_tag_p(tag_n) || nodeheader_tag_p(tag_n)) + obj = (LispObj)p + fulltag_misc; + else + obj = (LispObj)p + fulltag_cons; + + if ((fulltag_of(cmain) == fulltag_misc) && + (header_subtag(header_of(cmain)) == subtag_macptr)) { + LispObj save_vsp = xpGPR(xp, Isp); + LispObj save_fp = xpGPR(xp, Ifp); + LispObj xcf; + natural offset = (LispObj)addr - obj; + int skip; + + push_on_lisp_stack(xp, obj); + xcf = create_exception_callback_frame(xp, tcr); + + /* The magic 2 means this was a write to a watchd object */ + skip = callback_to_lisp(tcr, cmain, xp, xcf, SIGSEGV, 2, + (natural)addr, offset); + xpPC(xp) += skip; + xpGPR(xp, Ifp) = save_fp; + xpGPR(xp, Isp) = save_vsp; + return true; + } + } + } + } + + if (old_valence == TCR_STATE_LISP) { + LispObj cmain = nrs_CMAIN.vcell, + xcf; + if ((fulltag_of(cmain) == fulltag_misc) && + (header_subtag(header_of(cmain)) == subtag_macptr)) { + xcf = create_exception_callback_frame(xp, tcr); + callback_to_lisp(tcr, cmain, xp, xcf, SIGBUS, valid ? is_write_fault(xp,info) : (natural)-1, valid ? (natural)addr : 0, 0); + } + } + return false; +} + +Boolean +handle_floating_point_exception(TCR *tcr, ExceptionInformation *xp, siginfo_t *info) +{ + int code,skip; + LispObj xcf, cmain = nrs_CMAIN.vcell, + save_vsp = xpGPR(xp,Isp), + save_fp = xpGPR(xp,Ifp); +#ifdef WINDOWS + code = info->ExceptionCode; +#else + code = info->si_code; +#endif + + if ((fulltag_of(cmain) == fulltag_misc) && + (header_subtag(header_of(cmain)) == subtag_macptr)) { + xcf = create_exception_callback_frame(xp, tcr); + skip = callback_to_lisp(tcr, cmain, xp, xcf, SIGFPE, code, 0, 0); + xpPC(xp) += skip; + xpGPR(xp,Ifp) = save_fp; + xpGPR(xp,Isp) = save_vsp; + return true; + } else { + return false; + } +} + + +Boolean +extend_tcr_tlb(TCR *tcr, ExceptionInformation *xp) +{ + LispObj index, old_limit = tcr->tlb_limit, new_limit, new_bytes; + LispObj *old_tlb = tcr->tlb_pointer, *new_tlb, *work, *tos; + + tos = (LispObj*)(xpGPR(xp,Isp)); + index = *tos++; + (xpGPR(xp,Isp))=(LispObj)tos; + + new_limit = align_to_power_of_2(index+1,12); + new_bytes = new_limit-old_limit; + new_tlb = realloc(old_tlb, new_limit); + + if (new_tlb == NULL) { + return false; + } + work = (LispObj *) ((BytePtr)new_tlb+old_limit); + + while (new_bytes) { + *work++ = no_thread_local_binding_marker; + new_bytes -= sizeof(LispObj); + } + tcr->tlb_pointer = new_tlb; + tcr->tlb_limit = new_limit; + return true; +} + + +#if defined(FREEBSD) || defined(DARWIN) +static +char mxcsr_bit_to_fpe_code[] = { + FPE_FLTINV, /* ie */ + 0, /* de */ + FPE_FLTDIV, /* ze */ + FPE_FLTOVF, /* oe */ + FPE_FLTUND, /* ue */ + FPE_FLTRES /* pe */ +}; + +void +decode_vector_fp_exception(siginfo_t *info, uint32_t mxcsr) +{ + /* If the exception appears to be an XMM FP exception, try to + determine what it was by looking at bits in the mxcsr. + */ + int xbit, maskbit; + + for (xbit = 0, maskbit = MXCSR_IM_BIT; xbit < 6; xbit++, maskbit++) { + if ((mxcsr & (1 << xbit)) && + !(mxcsr & (1 << maskbit))) { + info->si_code = mxcsr_bit_to_fpe_code[xbit]; + return; + } + } +} + +#ifdef FREEBSD +void +freebsd_decode_vector_fp_exception(siginfo_t *info, ExceptionInformation *xp) +{ + if (info->si_code == 0) { +#ifdef X8664 + struct savefpu *fpu = (struct savefpu *) &(xp->uc_mcontext.mc_fpstate); +#else + struct ccl_savexmm *fpu = (struct ccl_savexmm *) &(xp->uc_mcontext.mc_fpstate); +#endif + uint32_t mxcsr = fpu->sv_env.en_mxcsr; + + decode_vector_fp_exception(info, mxcsr); + } +} +#endif + +#ifdef DARWIN +void +darwin_decode_vector_fp_exception(siginfo_t *info, ExceptionInformation *xp) +{ + if (info->si_code == EXC_I386_SSEEXTERR) { + uint32_t mxcsr = UC_MCONTEXT(xp)->__fs.__fpu_mxcsr; + + decode_vector_fp_exception(info, mxcsr); + } +} + +#endif + +#endif + +void +get_lisp_string(LispObj lisp_string, char *c_string, natural max) +{ + lisp_char_code *src = (lisp_char_code *) (ptr_from_lispobj(lisp_string + misc_data_offset)); + natural i, n = header_element_count(header_of(lisp_string)); + + if (n > max) { + n = max; + } + + for (i = 0; i < n; i++) { + c_string[i] = 0xff & (src[i]); + } + c_string[n] = 0; +} + +Boolean +handle_exception(int signum, siginfo_t *info, ExceptionInformation *context, TCR *tcr, int old_valence) +{ + pc program_counter = (pc)xpPC(context); + + switch (signum) { + case SIGNUM_FOR_INTN_TRAP: + if (IS_MAYBE_INT_TRAP(info,context)) { + /* Something mapped to SIGSEGV/SIGBUS that has nothing to do with + a memory fault. On x86, an "int n" instruction that's + not otherwise implemented causes a "protecton fault". Of + course that has nothing to do with accessing protected + memory; of course, most Unices act as if it did.*/ + if ((program_counter != NULL) && + (*program_counter == INTN_OPCODE)) { + program_counter++; + switch (*program_counter) { + case UUO_ALLOC_TRAP: + if (handle_alloc_trap(context, tcr)) { + xpPC(context) += 2; /* we might have GCed. */ + return true; + } + break; + case UUO_GC_TRAP: + if (handle_gc_trap(context, tcr)) { + xpPC(context) += 2; + return true; + } + break; + case UUO_WATCH_TRAP: + /* add or remove watched object */ + if (handle_watch_trap(context, tcr)) { + xpPC(context) += 2; + return true; + } + break; + case UUO_DEBUG_TRAP: + xpPC(context) = (natural) (program_counter+1); + lisp_Debugger(context, info, debug_entry_dbg, false, "Lisp Breakpoint"); + return true; + + case UUO_DEBUG_TRAP_WITH_STRING: + xpPC(context) = (natural) (program_counter+1); + { + char msg[512]; + + get_lisp_string(xpGPR(context,Iarg_z),msg, sizeof(msg)-1); + lisp_Debugger(context, info, debug_entry_dbg, false, msg); + } + return true; + + default: + return handle_error(tcr, context); + } + } else { + return false; + } + + } else { + return handle_fault(tcr, context, info, old_valence); + } + break; + + case SIGNAL_FOR_PROCESS_INTERRUPT: + tcr->interrupt_pending = 0; + callback_for_interrupt(tcr, context); + return true; + break; + + + case SIGILL: + if ((program_counter[0] == XUUO_OPCODE_0) && + (program_counter[1] == XUUO_OPCODE_1)) { + TCR *target = (TCR *)xpGPR(context, Iarg_z); + + switch (program_counter[2]) { + case XUUO_TLB_TOO_SMALL: + if (extend_tcr_tlb(tcr,context)) { + xpPC(context)+=3; + return true; + } + break; + + case XUUO_INTERRUPT_NOW: + callback_for_interrupt(tcr,context); + xpPC(context)+=3; + return true; + + case XUUO_SUSPEND_NOW: + xpPC(context)+=3; + return true; + + case XUUO_INTERRUPT: + raise_thread_interrupt(target); + xpPC(context)+=3; + return true; + + case XUUO_SUSPEND: + xpGPR(context,Iimm0) = (LispObj) lisp_suspend_tcr(target); + xpPC(context)+=3; + return true; + + case XUUO_SUSPEND_ALL: + lisp_suspend_other_threads(); + xpPC(context)+=3; + return true; + + + case XUUO_RESUME: + xpGPR(context,Iimm0) = (LispObj) lisp_resume_tcr(target); + xpPC(context)+=3; + return true; + + case XUUO_RESUME_ALL: + lisp_resume_other_threads(); + xpPC(context)+=3; + return true; + + case XUUO_KILL: + xpGPR(context,Iimm0) = (LispObj)kill_tcr(target); + xpPC(context)+=3; + return true; + + case XUUO_ALLOCATE_LIST: + allocate_list(context,tcr); + xpPC(context)+=3; + return true; + + default: + return false; + } + } else { + return false; + } + break; + + case SIGFPE: +#ifdef FREEBSD + /* As of 6.1, FreeBSD/AMD64 doesn't seem real comfortable + with this newfangled XMM business (and therefore info->si_code + is often 0 on an XMM FP exception. + Try to figure out what really happened by decoding mxcsr + bits. + */ + freebsd_decode_vector_fp_exception(info,context); +#endif +#ifdef DARWIN + /* Same general problem with Darwin as of 8.7.2 */ + darwin_decode_vector_fp_exception(info,context); +#endif + + return handle_floating_point_exception(tcr, context, info); + +#if SIGBUS != SIGNUM_FOR_INTN_TRAP + case SIGBUS: + return handle_fault(tcr, context, info, old_valence); +#endif + +#if SIGSEGV != SIGNUM_FOR_INTN_TRAP + case SIGSEGV: + return handle_fault(tcr, context, info, old_valence); +#endif + + default: + return false; + } +} + + +/* + Current thread has all signals masked. Before unmasking them, + make it appear that the current thread has been suspended. + (This is to handle the case where another thread is trying + to GC before this thread is able to seize the exception lock.) +*/ +int +prepare_to_wait_for_exception_lock(TCR *tcr, ExceptionInformation *context) +{ + int old_valence = tcr->valence; + + tcr->pending_exception_context = context; + tcr->valence = TCR_STATE_EXCEPTION_WAIT; + +#ifdef WINDOWS + if (tcr->flags & (1<suspend); + SEM_WAIT_FOREVER(tcr->resume); + } +#else + ALLOW_EXCEPTIONS(context); +#endif + return old_valence; +} + +void +wait_for_exception_lock_in_handler(TCR *tcr, + ExceptionInformation *context, + xframe_list *xf) +{ + + LOCK(lisp_global(EXCEPTION_LOCK), tcr); +#if 0 + fprintf(dbgout, "0x" LISP " has exception lock\n", tcr); +#endif + xf->curr = context; +#ifdef X8632 + xf->node_regs_mask = tcr->node_regs_mask; +#endif + xf->prev = tcr->xframe; + tcr->xframe = xf; + tcr->pending_exception_context = NULL; + tcr->valence = TCR_STATE_FOREIGN; +} + +void +unlock_exception_lock_in_handler(TCR *tcr) +{ + tcr->pending_exception_context = tcr->xframe->curr; +#ifdef X8632 + tcr->node_regs_mask = tcr->xframe->node_regs_mask; +#endif + tcr->xframe = tcr->xframe->prev; + tcr->valence = TCR_STATE_EXCEPTION_RETURN; + UNLOCK(lisp_global(EXCEPTION_LOCK),tcr); +#if 0 + fprintf(dbgout, "0x" LISP " released exception lock\n", tcr); +#endif +} + +/* + If an interrupt is pending on exception exit, try to ensure + that the thread sees it as soon as it's able to run. +*/ +#ifdef WINDOWS +void +raise_pending_interrupt(TCR *tcr) +{ +} +void +exit_signal_handler(TCR *tcr, int old_valence) +{ +} +void +signal_handler(int signum, siginfo_t *info, ExceptionInformation *context, TCR *tcr, int old_valence) +{ +} +#else +void +raise_pending_interrupt(TCR *tcr) +{ + if ((TCR_INTERRUPT_LEVEL(tcr) >= 0) && + (tcr->interrupt_pending)) { + pthread_kill((pthread_t)(tcr->osid), SIGNAL_FOR_PROCESS_INTERRUPT); + } +} + +void +exit_signal_handler(TCR *tcr, int old_valence) +{ + sigset_t mask; + sigfillset(&mask); +#ifdef FREEBSD + sigdelset(&mask,SIGTRAP); +#endif + + pthread_sigmask(SIG_SETMASK,&mask, NULL); + tcr->valence = old_valence; + tcr->pending_exception_context = NULL; +} + +void +signal_handler(int signum, siginfo_t *info, ExceptionInformation *context +#ifdef DARWIN + , TCR *tcr, int old_valence +#endif +) +{ +#ifdef DARWIN_GS_HACK + Boolean gs_was_tcr = ensure_gs_pthread(); +#endif + xframe_list xframe_link; +#ifndef DARWIN + TCR *tcr = get_tcr(false); + + int old_valence = prepare_to_wait_for_exception_lock(tcr, context); +#endif + if (tcr->flags & (1<regs at #x" LISP "", signum, xpPC(context), (natural)xpGPRvector(context)); + + if (lisp_Debugger(context, info, signum, foreign, msg)) { + SET_TCR_FLAG(tcr,TCR_FLAG_BIT_PROPAGATE_EXCEPTION); + } + } + unlock_exception_lock_in_handler(tcr); +#ifndef DARWIN_USE_PSEUDO_SIGRETURN + exit_signal_handler(tcr, old_valence); +#endif + /* raise_pending_interrupt(tcr); */ +#ifdef DARWIN_GS_HACK + if (gs_was_tcr) { + set_gs_address(tcr); + } +#endif +#ifndef DARWIN_USE_PSEUDO_SIGRETURN + SIGRETURN(context); +#endif +} +#endif + + + + +#ifdef LINUX +/* type of pointer to saved fp state */ +#ifdef X8664 +typedef fpregset_t FPREGS; +#else +typedef struct _fpstate *FPREGS; +#endif +LispObj * +copy_fpregs(ExceptionInformation *xp, LispObj *current, FPREGS *destptr) +{ + FPREGS src = (FPREGS)(xp->uc_mcontext.fpregs), dest; + + if (src) { + dest = ((FPREGS)current)-1; + *dest = *src; + *destptr = dest; + current = (LispObj *) dest; + } + return current; +} +#endif + +#ifdef DARWIN +LispObj * +copy_darwin_mcontext(MCONTEXT_T context, + LispObj *current, + MCONTEXT_T *out) +{ + MCONTEXT_T dest = ((MCONTEXT_T)current)-1; + dest = (MCONTEXT_T) (((LispObj)dest) & ~15); + + *dest = *context; + *out = dest; + return (LispObj *)dest; +} +#endif + +LispObj * +copy_siginfo(siginfo_t *info, LispObj *current) +{ + siginfo_t *dest = ((siginfo_t *)current) - 1; +#if !defined(LINUX) || !defined(X8632) + dest = (siginfo_t *) (((LispObj)dest)&~15); +#endif + *dest = *info; + return (LispObj *)dest; +} + +#ifdef LINUX +typedef FPREGS copy_ucontext_last_arg_t; +#else +typedef void * copy_ucontext_last_arg_t; +#endif + +#ifndef WINDOWS +LispObj * +copy_ucontext(ExceptionInformation *context, LispObj *current, copy_ucontext_last_arg_t fp) +{ + ExceptionInformation *dest = ((ExceptionInformation *)current)-1; +#if !defined(LINUX) || !defined(X8632) + dest = (ExceptionInformation *) (((LispObj)dest) & ~15); +#endif + + *dest = *context; + /* Fix it up a little; where's the signal mask allocated, if indeed + it is "allocated" ? */ +#ifdef LINUX + dest->uc_mcontext.fpregs = (fpregset_t)fp; +#endif + dest->uc_stack.ss_sp = 0; + dest->uc_stack.ss_size = 0; + dest->uc_stack.ss_flags = 0; + dest->uc_link = NULL; + return (LispObj *)dest; +} +#endif + + +LispObj * +tcr_frame_ptr(TCR *tcr) +{ + ExceptionInformation *xp; + LispObj *fp; + + if (tcr->pending_exception_context) + xp = tcr->pending_exception_context; + else if (tcr->valence == TCR_STATE_LISP) { + xp = tcr->suspend_context; + } else { + xp = NULL; + } + if (xp) { + fp = (LispObj *)xpGPR(xp, Ifp); + } else { + fp = tcr->save_fp; + } + return fp; +} + + +LispObj * +find_foreign_rsp(LispObj rsp, area *foreign_area, TCR *tcr) +{ + + if (((BytePtr)rsp < foreign_area->low) || + ((BytePtr)rsp > foreign_area->high)) { + rsp = (LispObj)(tcr->foreign_sp); + } + return (LispObj *) (((rsp-128) & ~15)); +} + +#ifdef X8632 +#ifdef LINUX +/* This is here for debugging. On entry to a signal handler that + receives info and context arguments, the stack should look exactly + like this. The "pretcode field" of the structure is the address + of code that does an rt_sigreturn syscall, and rt_sigreturn expects + %esp at the time of that syscall to be pointing just past the + pretcode field. + handle_signal_on_foreign_stack() and helpers have to be very + careful to duplicate this "structure" exactly. + Note that on x8664 Linux, rt_sigreturn expects a ucontext to + be on top of the stack (with a siginfo_t underneath it.) + It sort of half-works to do sigreturn via setcontext() on + x8632 Linux, but (a) it may not be available on some distributions + and (b) even a relatively modern version of it uses "fldenv" to + restore FP context, and "fldenv" isn't nearly good enough. +*/ + +struct rt_sigframe { + char *pretcode; + int sig; + siginfo_t *pinfo; + void *puc; + siginfo_t info; + struct ucontext uc; + struct _fpstate fpstate; + char retcode[8]; +}; +struct rt_sigframe *rtsf = 0; + +#endif +#endif + + +#ifndef WINDOWS +/* x8632 Linux requires that the stack-allocated siginfo is nearer + the top of stack than the stack-allocated ucontext. If other + platforms care, they expect the ucontext to be nearer the top + of stack. +*/ + +#if defined(LINUX) && defined(X8632) +#define UCONTEXT_ON_TOP_OF_STACK 0 +#else +#define UCONTEXT_ON_TOP_OF_STACK 1 +#endif +void +handle_signal_on_foreign_stack(TCR *tcr, + void *handler, + int signum, + siginfo_t *info, + ExceptionInformation *context, + LispObj return_address +#ifdef DARWIN_GS_HACK + , Boolean gs_was_tcr +#endif + ) +{ +#ifdef LINUX + FPREGS fpregs = NULL; +#else + void *fpregs = NULL; +#endif +#ifdef DARWIN + MCONTEXT_T mcontextp = NULL; +#endif + siginfo_t *info_copy = NULL; + ExceptionInformation *xp = NULL; + LispObj *foreign_rsp = find_foreign_rsp(xpGPR(context,Isp), tcr->cs_area, tcr); + +#ifdef LINUX + foreign_rsp = copy_fpregs(context, foreign_rsp, &fpregs); +#endif +#ifdef DARWIN + foreign_rsp = copy_darwin_mcontext(UC_MCONTEXT(context), foreign_rsp, &mcontextp); +#endif +#if UCONTEXT_ON_TOP_OF_STACK + /* copy info first */ + foreign_rsp = copy_siginfo(info, foreign_rsp); + info_copy = (siginfo_t *)foreign_rsp; + foreign_rsp = copy_ucontext(context, foreign_rsp, fpregs); + xp = (ExceptionInformation *)foreign_rsp; +#else + foreign_rsp = copy_ucontext(context, foreign_rsp, fpregs); + xp = (ExceptionInformation *)foreign_rsp; + foreign_rsp = copy_siginfo(info, foreign_rsp); + info_copy = (siginfo_t *)foreign_rsp; +#endif +#ifdef DARWIN + UC_MCONTEXT(xp) = mcontextp; +#endif + *--foreign_rsp = return_address; +#ifdef DARWIN_GS_HACK + if (gs_was_tcr) { + set_gs_address(tcr); + } +#endif + switch_to_foreign_stack(foreign_rsp,handler,signum,info_copy,xp); +} +#endif + + +#ifndef WINDOWS +#ifndef USE_SIGALTSTACK +void +arbstack_signal_handler(int signum, siginfo_t *info, ExceptionInformation *context) +{ + TCR *tcr = get_interrupt_tcr(false); +#if 1 + if (tcr->valence != TCR_STATE_LISP) { + FBug(context, "exception in foreign context"); + } +#endif + { + area *vs = tcr->vs_area; + BytePtr current_sp = (BytePtr) current_stack_pointer(); + + + if ((current_sp >= vs->low) && + (current_sp < vs->high)) { + handle_signal_on_foreign_stack(tcr, + signal_handler, + signum, + info, + context, + (LispObj)__builtin_return_address(0) +#ifdef DARWIN_GS_HACK + , false +#endif + + ); + } else { + signal_handler(signum, info, context, tcr, 0); + } + } +} + +#else +void +altstack_signal_handler(int signum, siginfo_t *info, ExceptionInformation *context) +{ + TCR* tcr = get_tcr(true); +#if 1 + if (tcr->valence != TCR_STATE_LISP) { + FBug(context, "exception in foreign context"); + } +#endif + handle_signal_on_foreign_stack(tcr,signal_handler,signum,info,context,(LispObj)__builtin_return_address(0) +#ifdef DARWIN_GS_HACK + , false +#endif +); +} +#endif +#endif + +Boolean +stack_pointer_on_vstack_p(LispObj stack_pointer, TCR *tcr) +{ + area *a = tcr->vs_area; + + return (((BytePtr)stack_pointer <= a->high) && + ((BytePtr)stack_pointer > a->low)); +} + + +#ifdef WINDOWS +extern DWORD restore_windows_context(ExceptionInformation *, TCR *, int); +#endif + +void +interrupt_handler (int signum, siginfo_t *info, ExceptionInformation *context) +{ +#ifdef DARWIN_GS_HACK + Boolean gs_was_tcr = ensure_gs_pthread(); +#endif + TCR *tcr = get_interrupt_tcr(false); + int old_valence = tcr->valence; + + if (tcr) { + if ((TCR_INTERRUPT_LEVEL(tcr) < 0) || + (tcr->valence != TCR_STATE_LISP) || + (tcr->unwinding != 0) || + ! stack_pointer_on_vstack_p(xpGPR(context,Isp), tcr) || + ! stack_pointer_on_vstack_p(xpGPR(context,Ifp), tcr)) { + tcr->interrupt_pending = (((natural) 1)<< (nbits_in_word - ((natural)1))); + } else { + LispObj cmain = nrs_CMAIN.vcell; + + if ((fulltag_of(cmain) == fulltag_misc) && + (header_subtag(header_of(cmain)) == subtag_macptr)) { + /* + This thread can (allegedly) take an interrupt now. + */ + + xframe_list xframe_link; + signed_natural alloc_displacement = 0; + LispObj + *next_tsp = tcr->next_tsp, + *save_tsp = tcr->save_tsp, + *p, + q; + natural old_foreign_exception = tcr->flags & (1 << TCR_FLAG_BIT_FOREIGN_EXCEPTION); + + tcr->flags &= ~(1 << TCR_FLAG_BIT_FOREIGN_EXCEPTION); + + if (next_tsp != save_tsp) { + tcr->next_tsp = save_tsp; + } else { + next_tsp = NULL; + } + /* have to do this before allowing interrupts */ + pc_luser_xp(context, tcr, &alloc_displacement); + old_valence = prepare_to_wait_for_exception_lock(tcr, context); + wait_for_exception_lock_in_handler(tcr, context, &xframe_link); + handle_exception(signum, info, context, tcr, old_valence); + if (alloc_displacement) { + tcr->save_allocptr -= alloc_displacement; + } + if (next_tsp) { + tcr->next_tsp = next_tsp; + p = next_tsp; + while (p != save_tsp) { + *p++ = 0; + } + q = (LispObj)save_tsp; + *next_tsp = q; + } + tcr->flags |= old_foreign_exception; + unlock_exception_lock_in_handler(tcr); +#ifndef WINDOWS + exit_signal_handler(tcr, old_valence); +#endif + } + } + } +#ifdef DARWIN_GS_HACK + if (gs_was_tcr) { + set_gs_address(tcr); + } +#endif +#ifdef WINDOWS + restore_windows_context(context,tcr,old_valence); +#else + SIGRETURN(context); +#endif +} + + +#ifndef WINDOWS +#ifndef USE_SIGALTSTACK +void +arbstack_interrupt_handler (int signum, siginfo_t *info, ExceptionInformation *context) +{ +#ifdef DARWIN_GS_HACK + Boolean gs_was_tcr = ensure_gs_pthread(); +#endif + TCR *tcr = get_interrupt_tcr(false); + area *vs = tcr->vs_area; + BytePtr current_sp = (BytePtr) current_stack_pointer(); + + if ((current_sp >= vs->low) && + (current_sp < vs->high)) { + handle_signal_on_foreign_stack(tcr, + interrupt_handler, + signum, + info, + context, + (LispObj)__builtin_return_address(0) +#ifdef DARWIN_GS_HACK + ,gs_was_tcr +#endif + ); + } else { + /* If we're not on the value stack, we pretty much have to be on + the C stack. Just run the handler. */ +#ifdef DARWIN_GS_HACK + if (gs_was_tcr) { + set_gs_address(tcr); + } +#endif + interrupt_handler(signum, info, context); + } +} + +#else /* altstack works */ + +void +altstack_interrupt_handler (int signum, siginfo_t *info, ExceptionInformation *context) +{ +#ifdef DARWIN_GS_HACK + Boolean gs_was_tcr = ensure_gs_pthread(); +#endif + TCR *tcr = get_interrupt_tcr(false); + handle_signal_on_foreign_stack(tcr,interrupt_handler,signum,info,context,(LispObj)__builtin_return_address(0) +#ifdef DARWIN_GS_HACK + ,gs_was_tcr +#endif + ); +} + +#endif +#endif + +#ifndef WINDOWS +void +install_signal_handler(int signo, void * handler) +{ + struct sigaction sa; + + sa.sa_sigaction = (void *)handler; + sigfillset(&sa.sa_mask); +#ifdef FREEBSD + /* Strange FreeBSD behavior wrt synchronous signals */ + sigdelset(&sa.sa_mask,SIGTRAP); /* let GDB work */ +#endif + sa.sa_flags = + 0 /* SA_RESTART */ +#ifdef USE_SIGALTSTACK + | SA_ONSTACK +#endif + | SA_SIGINFO; + + sigaction(signo, &sa, NULL); +} +#endif + +#ifdef WINDOWS +BOOL +CALLBACK ControlEventHandler(DWORD event) +{ + switch(event) { + case CTRL_C_EVENT: + lisp_global(INTFLAG) = (1 << fixnumshift); + return TRUE; + break; + default: + return FALSE; + } +} + +static +DWORD mxcsr_bit_to_fpe_code[] = { + EXCEPTION_FLT_INVALID_OPERATION, /* ie */ + 0, /* de */ + EXCEPTION_FLT_DIVIDE_BY_ZERO, /* ze */ + EXCEPTION_FLT_OVERFLOW, /* oe */ + EXCEPTION_FLT_UNDERFLOW, /* ue */ + EXCEPTION_FLT_INEXACT_RESULT /* pe */ +}; + +#ifndef STATUS_FLOAT_MULTIPLE_FAULTS +#define STATUS_FLOAT_MULTIPLE_FAULTS 0xc00002b4 +#endif + +#ifndef STATUS_FLOAT_MULTIPLE_TRAPS +#define STATUS_FLOAT_MULTIPLE_TRAPS 0xc00002b5 +#endif + +int +map_windows_exception_code_to_posix_signal(DWORD code, siginfo_t *info, ExceptionInformation *context) +{ + switch (code) { +#ifdef WIN_32 + case STATUS_FLOAT_MULTIPLE_FAULTS: + case STATUS_FLOAT_MULTIPLE_TRAPS: + { + int xbit, maskbit; + DWORD mxcsr = *(xpMXCSRptr(context)); + + for (xbit = 0, maskbit = MXCSR_IM_BIT; xbit < 6; xbit++, maskbit++) { + if ((mxcsr & (1 << xbit)) && + !(mxcsr & (1 << maskbit))) { + info->ExceptionCode = mxcsr_bit_to_fpe_code[xbit]; + break; + } + } + } + return SIGFPE; +#endif + + case EXCEPTION_ACCESS_VIOLATION: + return SIGSEGV; + case EXCEPTION_FLT_DENORMAL_OPERAND: + case EXCEPTION_FLT_DIVIDE_BY_ZERO: + case EXCEPTION_FLT_INEXACT_RESULT: + case EXCEPTION_FLT_INVALID_OPERATION: + case EXCEPTION_FLT_OVERFLOW: + case EXCEPTION_FLT_STACK_CHECK: + case EXCEPTION_FLT_UNDERFLOW: + case EXCEPTION_INT_DIVIDE_BY_ZERO: + case EXCEPTION_INT_OVERFLOW: + return SIGFPE; + case EXCEPTION_PRIV_INSTRUCTION: + case EXCEPTION_ILLEGAL_INSTRUCTION: + return SIGILL; + case EXCEPTION_IN_PAGE_ERROR: + return SIGBUS; + default: + return -1; + } +} + + +LONG +windows_exception_handler(EXCEPTION_POINTERS *exception_pointers, TCR *tcr) +{ + DWORD code = exception_pointers->ExceptionRecord->ExceptionCode; + int old_valence, signal_number; + ExceptionInformation *context = exception_pointers->ContextRecord; + siginfo_t *info = exception_pointers->ExceptionRecord; + xframe_list xframes; + + old_valence = prepare_to_wait_for_exception_lock(tcr, context); + wait_for_exception_lock_in_handler(tcr, context, &xframes); + + signal_number = map_windows_exception_code_to_posix_signal(code, info, context); + + if (!handle_exception(signal_number, info, context, tcr, old_valence)) { + char msg[512]; + Boolean foreign = (old_valence != TCR_STATE_LISP); + + snprintf(msg, sizeof(msg), "Unhandled exception %d (windows code 0x%x) at 0x%Ix, context->regs at 0x%Ix", signal_number, code, xpPC(context), (natural)xpGPRvector(context)); + + if (lisp_Debugger(context, info, signal_number, foreign, msg)) { + SET_TCR_FLAG(tcr,TCR_FLAG_BIT_PROPAGATE_EXCEPTION); + } + } + unlock_exception_lock_in_handler(tcr); + return restore_windows_context(context, tcr, old_valence); +} + +void +setup_exception_handler_call(CONTEXT *context, + LispObj new_sp, + void *handler, + EXCEPTION_POINTERS *new_ep, + TCR *tcr) +{ + extern void windows_halt(void); + LispObj *p = (LispObj *)new_sp; +#ifdef WIN_64 + p-=4; /* win64 abi argsave nonsense */ + *(--p) = (LispObj)windows_halt; + context->Rsp = (DWORD64)p; + context->Rip = (DWORD64)handler; + context->Rcx = (DWORD64)new_ep; + context->Rdx = (DWORD64)tcr; +#else + p-=4; /* args on stack, stack aligned */ + p[0] = (LispObj)new_ep; + p[1] = (LispObj)tcr; + *(--p) = (LispObj)windows_halt; + context->Esp = (DWORD)p; + context->Eip = (DWORD)handler; +#ifdef WIN32_ES_HACK + context->SegEs = context->SegDs; +#endif +#endif + context->EFlags &= ~0x400; /* clear direction flag */ +} + +void +prepare_to_handle_windows_exception_on_foreign_stack(TCR *tcr, + CONTEXT *context, + void *handler, + EXCEPTION_POINTERS *original_ep) +{ + LispObj foreign_rsp = + (LispObj) (tcr->foreign_sp - 128) & ~15; + CONTEXT *new_context; + siginfo_t *new_info; + EXCEPTION_POINTERS *new_ep; + + new_context = ((CONTEXT *)(foreign_rsp&~15))-1; + *new_context = *context; + foreign_rsp = (LispObj)new_context; + new_info = ((siginfo_t *)(foreign_rsp&~15))-1; + *new_info = *original_ep->ExceptionRecord; + foreign_rsp = (LispObj)new_info; + new_ep = ((EXCEPTION_POINTERS *)(foreign_rsp&~15))-1; + foreign_rsp = (LispObj)new_ep & ~15; + new_ep->ContextRecord = new_context; + new_ep->ExceptionRecord = new_info; + setup_exception_handler_call(context,foreign_rsp,handler,new_ep, tcr); +} + +LONG CALLBACK +windows_arbstack_exception_handler(EXCEPTION_POINTERS *exception_pointers) +{ + extern void ensure_safe_for_string_operations(void); + DWORD code = exception_pointers->ExceptionRecord->ExceptionCode; + + + + if ((code & 0x80000000L) == 0) { + return EXCEPTION_CONTINUE_SEARCH; + } else { + TCR *tcr = get_interrupt_tcr(false); + area *cs = tcr->cs_area; + BytePtr current_sp = (BytePtr) current_stack_pointer(); + CONTEXT *context = exception_pointers->ContextRecord; + + ensure_safe_for_string_operations(); + + if ((current_sp >= cs->low) && + (current_sp < cs->high)) { + debug_show_registers(context, exception_pointers->ExceptionRecord, 0); + FBug(context, "Exception on foreign stack\n"); + return EXCEPTION_CONTINUE_EXECUTION; + } + + prepare_to_handle_windows_exception_on_foreign_stack(tcr, + context, + windows_exception_handler, + exception_pointers); + return EXCEPTION_CONTINUE_EXECUTION; + } +} + + +void +install_pmcl_exception_handlers() +{ + AddVectoredExceptionHandler(1,windows_arbstack_exception_handler); +} +#else +void +install_pmcl_exception_handlers() +{ +#ifndef DARWIN + void *handler = (void *) +#ifdef USE_SIGALTSTACK + altstack_signal_handler +#else + arbstack_signal_handler; +#endif + ; + install_signal_handler(SIGILL, handler); + + install_signal_handler(SIGBUS, handler); + install_signal_handler(SIGSEGV,handler); + install_signal_handler(SIGFPE, handler); +#endif + + install_signal_handler(SIGNAL_FOR_PROCESS_INTERRUPT, +#ifdef USE_SIGALTSTACK + altstack_interrupt_handler +#else + arbstack_interrupt_handler +#endif +); + signal(SIGPIPE, SIG_IGN); +} +#endif + +#ifndef WINDOWS +#ifndef USE_SIGALTSTACK +void +arbstack_suspend_resume_handler(int signum, siginfo_t *info, ExceptionInformation *context) +{ +#ifdef DARWIN_GS_HACK + Boolean gs_was_tcr = ensure_gs_pthread(); +#endif + TCR *tcr = get_interrupt_tcr(false); + if (tcr != NULL) { + area *vs = tcr->vs_area; + BytePtr current_sp = (BytePtr) current_stack_pointer(); + + if ((current_sp >= vs->low) && + (current_sp < vs->high)) { + return + handle_signal_on_foreign_stack(tcr, + suspend_resume_handler, + signum, + info, + context, + (LispObj)__builtin_return_address(0) +#ifdef DARWIN_GS_HACK + ,gs_was_tcr +#endif + ); + } else { + /* If we're not on the value stack, we pretty much have to be on + the C stack. Just run the handler. */ +#ifdef DARWIN_GS_HACK + if (gs_was_tcr) { + set_gs_address(tcr); + } +#endif + } + } + suspend_resume_handler(signum, info, context); +} + + +#else /* altstack works */ +void +altstack_suspend_resume_handler(int signum, siginfo_t *info, ExceptionInformation *context) +{ +#ifdef DARWIN_GS_HACK + Boolean gs_was_tcr = ensure_gs_pthread(); +#endif + TCR* tcr = get_tcr(true); + handle_signal_on_foreign_stack(tcr, + suspend_resume_handler, + signum, + info, + context, + (LispObj)__builtin_return_address(0) +#ifdef DARWIN_GS_HACK + ,gs_was_tcr +#endif + ); +} +#endif +#endif + + +/* This should only be called when the tcr_area_lock is held */ +void +empty_tcr_stacks(TCR *tcr) +{ + if (tcr) { + area *a; + + tcr->valence = TCR_STATE_FOREIGN; + a = tcr->vs_area; + if (a) { + a->active = a->high; + } + a = tcr->ts_area; + if (a) { + a->active = a->high; + } + a = tcr->cs_area; + if (a) { + a->active = a->high; + } + } +} + +#ifdef WINDOWS +void +thread_kill_handler(int signum, siginfo_t *info, ExceptionInformation *xp) +{ +} +#else +void +thread_kill_handler(int signum, siginfo_t *info, ExceptionInformation *xp) +{ +#ifdef DARWIN_GS_HACK + Boolean gs_was_tcr = ensure_gs_pthread(); +#endif + TCR *tcr = get_tcr(false); + sigset_t mask; + + sigemptyset(&mask); + + empty_tcr_stacks(tcr); + + pthread_sigmask(SIG_SETMASK,&mask,NULL); + pthread_exit(NULL); +} +#endif + +#ifndef WINDOWS +#ifndef USE_SIGALTSTACK +void +arbstack_thread_kill_handler(int signum, siginfo_t *info, ExceptionInformation *context) +{ +#ifdef DARWIN_GS_HACK + Boolean gs_was_tcr = ensure_gs_pthread(); +#endif + TCR *tcr = get_interrupt_tcr(false); + area *vs = tcr->vs_area; + BytePtr current_sp = (BytePtr) current_stack_pointer(); + + if ((current_sp >= vs->low) && + (current_sp < vs->high)) { + handle_signal_on_foreign_stack(tcr, + thread_kill_handler, + signum, + info, + context, + (LispObj)__builtin_return_address(0) +#ifdef DARWIN_GS_HACK + ,gs_was_tcr +#endif + ); + } else { + /* If we're not on the value stack, we pretty much have to be on + the C stack. Just run the handler. */ +#ifdef DARWIN_GS_HACK + if (gs_was_tcr) { + set_gs_address(tcr); + } +#endif + thread_kill_handler(signum, info, context); + } +} + + +#else +void +altstack_thread_kill_handler(int signum, siginfo_t *info, ExceptionInformation *context) +{ +#ifdef DARWIN_GS_HACK + Boolean gs_was_tcr = ensure_gs_pthread(); +#endif + TCR* tcr = get_tcr(true); + handle_signal_on_foreign_stack(tcr, + thread_kill_handler, + signum, + info, + context, + (LispObj)__builtin_return_address(0) +#ifdef DARWIN_GS_HACK + ,gs_was_tcr +#endif + ); +} +#endif +#endif + +#ifdef USE_SIGALTSTACK +#define SUSPEND_RESUME_HANDLER altstack_suspend_resume_handler +#define THREAD_KILL_HANDLER altstack_thread_kill_handler +#else +#define SUSPEND_RESUME_HANDLER arbstack_suspend_resume_handler +#define THREAD_KILL_HANDLER arbstack_thread_kill_handler +#endif + +#ifdef WINDOWS +void +thread_signal_setup() +{ +} +#else +void +thread_signal_setup() +{ + thread_suspend_signal = SIG_SUSPEND_THREAD; + thread_kill_signal = SIG_KILL_THREAD; + + install_signal_handler(thread_suspend_signal, (void *)SUSPEND_RESUME_HANDLER); + install_signal_handler(thread_kill_signal, (void *)THREAD_KILL_HANDLER); +} +#endif + +void +enable_fp_exceptions() +{ +} + +void +exception_init() +{ + install_pmcl_exception_handlers(); +} + +void +adjust_exception_pc(ExceptionInformation *xp, int delta) +{ + xpPC(xp) += delta; +} + +/* + Lower (move toward 0) the "end" of the soft protected area associated + with a by a page, if we can. +*/ + +void + +adjust_soft_protection_limit(area *a) +{ + char *proposed_new_soft_limit = a->softlimit - 4096; + protected_area_ptr p = a->softprot; + + if (proposed_new_soft_limit >= (p->start+16384)) { + p->end = proposed_new_soft_limit; + p->protsize = p->end-p->start; + a->softlimit = proposed_new_soft_limit; + } + protect_area(p); +} + +void +restore_soft_stack_limit(unsigned restore_tsp) +{ + TCR *tcr = get_tcr(false); + area *a; + + if (restore_tsp) { + a = tcr->ts_area; + } else { + a = tcr->vs_area; + } + adjust_soft_protection_limit(a); +} + + +#ifdef USE_SIGALTSTACK +void +setup_sigaltstack(area *a) +{ + stack_t stack; + stack.ss_sp = a->low; + a->low += SIGSTKSZ*8; + stack.ss_size = SIGSTKSZ*8; + stack.ss_flags = 0; + mmap(stack.ss_sp,stack.ss_size, PROT_READ|PROT_WRITE|PROT_EXEC,MAP_FIXED|MAP_ANON|MAP_PRIVATE,-1,0); + if (sigaltstack(&stack, NULL) != 0) { + perror("sigaltstack"); + exit(-1); + } +} +#endif + +extern opcode egc_write_barrier_start, egc_write_barrier_end, + egc_set_hash_key_conditional, egc_set_hash_key_conditional_success_test, + egc_set_hash_key_conditional_retry, + egc_store_node_conditional_success_end, egc_store_node_conditional_retry, + egc_store_node_conditional_success_test,egc_store_node_conditional, + egc_set_hash_key, egc_gvset, egc_rplacd; + +/* We use (extremely) rigidly defined instruction sequences for consing, + mostly so that 'pc_luser_xp()' knows what to do if a thread is interrupted + while consing. + + Note that we can usually identify which of these instructions is about + to be executed by a stopped thread without comparing all of the bytes + to those at the stopped program counter, but we generally need to + know the sizes of each of these instructions. +*/ + +#ifdef X8664 +opcode load_allocptr_reg_from_tcr_save_allocptr_instruction[] = +#ifdef TCR_IN_GPR + {0x49,0x8b,0x9b,0xd8,0x00,0x00,0x00} +#else + {0x65,0x48,0x8b,0x1c,0x25,0xd8,0x00,0x00,0x00} +#endif +; +opcode compare_allocptr_reg_to_tcr_save_allocbase_instruction[] = +#ifdef TCR_IN_GPR + {0x49,0x3b,0x9b,0xe0,0x00,0x00,0x00} +#else + {0x65,0x48,0x3b,0x1c,0x25,0xe0,0x00,0x00,0x00} +#endif + +; +opcode branch_around_alloc_trap_instruction[] = + {0x77,0x02}; +opcode alloc_trap_instruction[] = + {0xcd,0xc5}; +opcode clear_tcr_save_allocptr_tag_instruction[] = +#ifdef TCR_IN_GPR + {0x41,0x80,0xa3,0xd8,0x00,0x00,0x00,0xf0} +#else + {0x65,0x80,0x24,0x25,0xd8,0x00,0x00,0x00,0xf0} +#endif +; +opcode set_allocptr_header_instruction[] = + {0x48,0x89,0x43,0xf3}; + + +alloc_instruction_id +recognize_alloc_instruction(pc program_counter) +{ + switch(program_counter[0]) { + case 0xcd: return ID_alloc_trap_instruction; + /* 0x7f is jg, which we used to use here instead of ja */ + case 0x7f: + case 0x77: return ID_branch_around_alloc_trap_instruction; + case 0x48: return ID_set_allocptr_header_instruction; +#ifdef TCR_IN_GPR + case 0x41: return ID_clear_tcr_save_allocptr_tag_instruction; + case 0x49: + switch(program_counter[1]) { + case 0x8b: return ID_load_allocptr_reg_from_tcr_save_allocptr_instruction; + case 0x3b: return ID_compare_allocptr_reg_to_tcr_save_allocbase_instruction; + } +#else + case 0x65: + switch(program_counter[1]) { + case 0x80: return ID_clear_tcr_save_allocptr_tag_instruction; + case 0x48: + switch(program_counter[2]) { + case 0x3b: return ID_compare_allocptr_reg_to_tcr_save_allocbase_instruction; + case 0x8b: return ID_load_allocptr_reg_from_tcr_save_allocptr_instruction; + } + } +#endif + default: break; + } + return ID_unrecognized_alloc_instruction; +} +#endif +#ifdef X8632 +/* The lisp assembler might use both a modrm byte and a sib byte to + encode a memory operand that contains a displacement but no + base or index. Using the sib byte is necessary for 64-bit code, + since the sib-less form is used to indicate %rip-relative addressing + on x8664. On x8632, it's not necessary, slightly suboptimal, and + doesn't match what we expect; until that's fixed, we may need to + account for this extra byte when adjusting the PC */ +#define LISP_ASSEMBLER_EXTRA_SIB_BYTE +#ifdef WIN32_ES_HACK +/* Win32 keeps the TCR in %es */ +#define TCR_SEG_PREFIX 0x26 /* %es: */ +#else +/* Other platfroms use %fs */ +#define TCR_SEG_PREFIX 0x64 /* %fs: */ +#endif +opcode load_allocptr_reg_from_tcr_save_allocptr_instruction[] = + {TCR_SEG_PREFIX,0x8b,0x0d,0x84,0x00,0x00,0x00}; /* may have extra SIB byte */ +opcode compare_allocptr_reg_to_tcr_save_allocbase_instruction[] = + {TCR_SEG_PREFIX,0x3b,0x0d,0x88,0x00,0x00,0x00}; /* may have extra SIB byte */ +opcode branch_around_alloc_trap_instruction[] = + {0x77,0x02}; /* no SIB byte issue */ +opcode alloc_trap_instruction[] = + {0xcd,0xc5}; /* no SIB byte issue */ +opcode clear_tcr_save_allocptr_tag_instruction[] = + {TCR_SEG_PREFIX,0x80,0x25,0x84,0x00,0x00,0x00,0xf8}; /* maybe SIB byte */ +opcode set_allocptr_header_instruction[] = + {0x0f,0x7e,0x41,0xfa}; /* no SIB byte issue */ + +alloc_instruction_id +recognize_alloc_instruction(pc program_counter) +{ + switch(program_counter[0]) { + case 0xcd: return ID_alloc_trap_instruction; + /* 0x7f is jg, which we used to use here instead of ja */ + case 0x7f: + case 0x77: return ID_branch_around_alloc_trap_instruction; + case 0x0f: return ID_set_allocptr_header_instruction; + case TCR_SEG_PREFIX: + switch(program_counter[1]) { + case 0x80: return ID_clear_tcr_save_allocptr_tag_instruction; + case 0x3b: return ID_compare_allocptr_reg_to_tcr_save_allocbase_instruction; + case 0x8b: return ID_load_allocptr_reg_from_tcr_save_allocptr_instruction; + } + } + return ID_unrecognized_alloc_instruction; +} +#endif + +void +pc_luser_xp(ExceptionInformation *xp, TCR *tcr, signed_natural *interrupt_displacement) +{ + pc program_counter = (pc)xpPC(xp); + int allocptr_tag = fulltag_of((LispObj)(tcr->save_allocptr)); + + if (allocptr_tag != 0) { + alloc_instruction_id state = recognize_alloc_instruction(program_counter); + signed_natural + disp = (allocptr_tag == fulltag_cons) ? + sizeof(cons) - fulltag_cons : +#ifdef X8664 + xpGPR(xp,Iimm1) +#else + xpGPR(xp,Iimm0) +#endif + ; + LispObj new_vector; + + if ((state == ID_unrecognized_alloc_instruction) || + ((state == ID_set_allocptr_header_instruction) && + (allocptr_tag != fulltag_misc))) { + Bug(xp, "Can't determine state of thread 0x" LISP ", interrupted during memory allocation", tcr); + } + switch(state) { + case ID_set_allocptr_header_instruction: + /* We were consing a vector and we won. Set the header of the + new vector (in the allocptr register) to the header in %rax + (%mm0 on ia32) and skip over this instruction, then fall into + the next case. */ + new_vector = xpGPR(xp,Iallocptr); + deref(new_vector,0) = +#ifdef X8664 + xpGPR(xp,Iimm0) +#else + xpMMXreg(xp,Imm0) +#endif + ; + + xpPC(xp) += sizeof(set_allocptr_header_instruction); + + /* Fall thru */ + case ID_clear_tcr_save_allocptr_tag_instruction: + tcr->save_allocptr = (void *)(((LispObj)tcr->save_allocptr) & ~fulltagmask); +#ifdef LISP_ASSEMBLER_EXTRA_SIB_BYTE + if (((pc)(xpPC(xp)))[2] == 0x24) { + xpPC(xp) += 1; + } +#endif + xpPC(xp) += sizeof(clear_tcr_save_allocptr_tag_instruction); + + break; + case ID_alloc_trap_instruction: + /* If we're looking at another thread, we're pretty much committed to + taking the trap. We don't want the allocptr register to be pointing + into the heap, so make it point to (- VOID_ALLOCPTR disp), where 'disp' + was determined above. + */ + if (interrupt_displacement == NULL) { + xpGPR(xp,Iallocptr) = VOID_ALLOCPTR - disp; + tcr->save_allocptr = (void *)(VOID_ALLOCPTR - disp); + } else { + /* Back out, and tell the caller how to resume the allocation attempt */ + *interrupt_displacement = disp; + xpGPR(xp,Iallocptr) = VOID_ALLOCPTR; + tcr->save_allocptr += disp; +#ifdef LISP_ASSEMBLER_EXTRA_SIB_BYTE + /* This assumes that TCR_SEG_PREFIX can't appear + anywhere but at the beginning of one of these + magic allocation-sequence instructions. */ + xpPC(xp) -= (sizeof(branch_around_alloc_trap_instruction)+ + sizeof(compare_allocptr_reg_to_tcr_save_allocbase_instruction)); + if (*((pc)(xpPC(xp))) == TCR_SEG_PREFIX) { + xpPC(xp) -= sizeof(load_allocptr_reg_from_tcr_save_allocptr_instruction); + } else { + xpPC(xp) -= (sizeof(load_allocptr_reg_from_tcr_save_allocptr_instruction) + 2); + } + +#else + xpPC(xp) -= (sizeof(branch_around_alloc_trap_instruction)+ + sizeof(compare_allocptr_reg_to_tcr_save_allocbase_instruction) + + sizeof(load_allocptr_reg_from_tcr_save_allocptr_instruction)); +#endif + } + break; + case ID_branch_around_alloc_trap_instruction: + /* If we'd take the branch - which is a "ja" - around the alloc trap, + we might as well finish the allocation. Otherwise, back out of the + attempt. */ + { + int flags = (int)eflags_register(xp); + + if ((!(flags & (1 << X86_ZERO_FLAG_BIT))) && + (!(flags & (1 << X86_CARRY_FLAG_BIT)))) { + /* The branch (ja) would have been taken. Emulate taking it. */ + xpPC(xp) += (sizeof(branch_around_alloc_trap_instruction)+ + sizeof(alloc_trap_instruction)); + if (allocptr_tag == fulltag_misc) { + /* Slap the header on the new uvector */ + new_vector = xpGPR(xp,Iallocptr); + deref(new_vector,0) = xpGPR(xp,Iimm0); + xpPC(xp) += sizeof(set_allocptr_header_instruction); + } + tcr->save_allocptr = (void *)(((LispObj)tcr->save_allocptr) & ~fulltagmask); +#ifdef LISP_ASSEMBLER_EXTRA_SIB_BYTE + if (((pc)xpPC(xp))[2] == 0x24) { + xpPC(xp) += 1; + } +#endif + xpPC(xp) += sizeof(clear_tcr_save_allocptr_tag_instruction); + } else { + /* Back up */ + xpPC(xp) -= (sizeof(compare_allocptr_reg_to_tcr_save_allocbase_instruction) + + sizeof(load_allocptr_reg_from_tcr_save_allocptr_instruction)); +#ifdef LISP_ASSEMBLER_EXTRA_SIB_BYTE + if (*((pc)(xpPC(xp))) != TCR_SEG_PREFIX) { + /* skipped two instructions with extra SIB byte */ + xpPC(xp) -= 2; + } +#endif + xpGPR(xp,Iallocptr) = VOID_ALLOCPTR; + if (interrupt_displacement) { + *interrupt_displacement = disp; + tcr->save_allocptr += disp; + } else { + tcr->save_allocptr = (void *)(VOID_ALLOCPTR-disp); + } + } + } + break; + case ID_compare_allocptr_reg_to_tcr_save_allocbase_instruction: + xpGPR(xp,Iallocptr) = VOID_ALLOCPTR; + xpPC(xp) -= sizeof(load_allocptr_reg_from_tcr_save_allocptr_instruction); +#ifdef LISP_ASSEMBLER_EXTRA_SIB_BYTE + if (*((pc)xpPC(xp)) != TCR_SEG_PREFIX) { + xpPC(xp) -= 1; + } +#endif + /* Fall through */ + case ID_load_allocptr_reg_from_tcr_save_allocptr_instruction: + if (interrupt_displacement) { + tcr->save_allocptr += disp; + *interrupt_displacement = disp; + } else { + tcr->save_allocptr = (void *)(VOID_ALLOCPTR-disp); + } + break; + default: + break; + } + return; + } + if ((program_counter >= &egc_write_barrier_start) && + (program_counter < &egc_write_barrier_end)) { + LispObj *ea = 0, val, root = 0; + bitvector refbits = (bitvector)(lisp_global(REFBITS)); + Boolean need_store = true, need_check_memo = true, need_memoize_root = false; + + if (program_counter >= &egc_set_hash_key_conditional) { + if (program_counter <= &egc_set_hash_key_conditional_retry) { + return; + } + if ((program_counter < &egc_set_hash_key_conditional_success_test) || + ((program_counter == &egc_set_hash_key_conditional_success_test) && + !(eflags_register(xp) & (1 << X86_ZERO_FLAG_BIT)))) { + /* Back up the PC, try again */ + xpPC(xp) = (LispObj) &egc_set_hash_key_conditional_retry; + return; + } + /* The conditional store succeeded. Set the refbit, return to ra0 */ + val = xpGPR(xp,Iarg_z); +#ifdef X8664 + root = xpGPR(xp,Iarg_x); + ea = (LispObj*)(root + (unbox_fixnum((signed_natural) xpGPR(xp,Itemp0)))); +#else + root = xpGPR(xp,Itemp1); + ea = (LispObj *)(root + misc_data_offset + xpGPR(xp,Itemp0)); +#endif + need_memoize_root = true; + need_store = false; + xpGPR(xp,Iarg_z) = t_value; + } else if (program_counter >= &egc_store_node_conditional) { + if (program_counter <= &egc_store_node_conditional_retry) { + return; + } + if ((program_counter < &egc_store_node_conditional_success_test) || + ((program_counter == &egc_store_node_conditional_success_test) && + !(eflags_register(xp) & (1 << X86_ZERO_FLAG_BIT)))) { + /* Back up the PC, try again */ + xpPC(xp) = (LispObj) &egc_store_node_conditional_retry; + return; + } + if (program_counter >= &egc_store_node_conditional_success_end) { + return; + } + + /* The conditional store succeeded. Set the refbit, return to ra0 */ + val = xpGPR(xp,Iarg_z); +#ifdef X8664 + ea = (LispObj*)(xpGPR(xp,Iarg_x) + (unbox_fixnum((signed_natural) + xpGPR(xp,Itemp0)))); +#else + ea = (LispObj *)(misc_data_offset + xpGPR(xp,Itemp1) + xpGPR(xp,Itemp0)); +#endif + xpGPR(xp,Iarg_z) = t_value; + need_store = false; + } else if (program_counter >= &egc_set_hash_key) { +#ifdef X8664 + root = xpGPR(xp,Iarg_x); +#else + root = xpGPR(xp,Itemp0); +#endif + ea = (LispObj *) (root+xpGPR(xp,Iarg_y)+misc_data_offset); + val = xpGPR(xp,Iarg_z); + need_memoize_root = true; + } else if (program_counter >= &egc_gvset) { +#ifdef X8664 + ea = (LispObj *) (xpGPR(xp,Iarg_x)+xpGPR(xp,Iarg_y)+misc_data_offset); +#else + ea = (LispObj *) (xpGPR(xp,Itemp0)+xpGPR(xp,Iarg_y)+misc_data_offset); +#endif + val = xpGPR(xp,Iarg_z); + } else if (program_counter >= &egc_rplacd) { + ea = (LispObj *) untag(xpGPR(xp,Iarg_y)); + val = xpGPR(xp,Iarg_z); + } else { /* egc_rplaca */ + ea = ((LispObj *) untag(xpGPR(xp,Iarg_y)))+1; + val = xpGPR(xp,Iarg_z); + } + if (need_store) { + *ea = val; + } + if (need_check_memo) { + natural bitnumber = area_dnode(ea, lisp_global(REF_BASE)); + if ((bitnumber < lisp_global(OLDSPACE_DNODE_COUNT)) && + ((LispObj)ea < val)) { + atomic_set_bit(refbits, bitnumber); + if (need_memoize_root) { + bitnumber = area_dnode(root, lisp_global(REF_BASE)); + atomic_set_bit(refbits, bitnumber); + } + } + } + { + /* These subprimitives are called via CALL/RET; need + to pop the return address off the stack and set + the PC there. */ + LispObj *sp = (LispObj *)xpGPR(xp,Isp), ra = *sp++; + xpPC(xp) = ra; + xpGPR(xp,Isp)=(LispObj)sp; + } + return; + } +} + + +void +normalize_tcr(ExceptionInformation *xp, TCR *tcr, Boolean is_other_tcr) +{ + void *cur_allocptr = (void *)(tcr->save_allocptr); + LispObj lisprsp; + area *a; + + if (xp) { + if (is_other_tcr) { + pc_luser_xp(xp, tcr, NULL); + } + a = tcr->vs_area; + lisprsp = xpGPR(xp, Isp); + if (((BytePtr)lisprsp >= a->low) && + ((BytePtr)lisprsp < a->high)) { + a->active = (BytePtr)lisprsp; + } else { + a->active = (BytePtr) tcr->save_vsp; + } + a = tcr->ts_area; + a->active = (BytePtr) tcr->save_tsp; + } else { + /* In ff-call; get area active pointers from tcr */ + tcr->vs_area->active = (BytePtr) tcr->save_vsp; + tcr->ts_area->active = (BytePtr) tcr->save_tsp; + } + if (cur_allocptr) { + update_bytes_allocated(tcr, cur_allocptr); + } + tcr->save_allocbase = (void *)VOID_ALLOCPTR; + if (fulltag_of((LispObj)(tcr->save_allocptr)) == 0) { + tcr->save_allocptr = (void *)VOID_ALLOCPTR; + } +} + + +/* Suspend and "normalize" other tcrs, then call a gc-like function + in that context. Resume the other tcrs, then return what the + function returned */ + +TCR *gc_tcr = NULL; + + +signed_natural +gc_like_from_xp(ExceptionInformation *xp, + signed_natural(*fun)(TCR *, signed_natural), + signed_natural param) +{ + TCR *tcr = get_tcr(false), *other_tcr; + int result; + signed_natural inhibit; + + suspend_other_threads(true); + inhibit = (signed_natural)(lisp_global(GC_INHIBIT_COUNT)); + if (inhibit != 0) { + if (inhibit > 0) { + lisp_global(GC_INHIBIT_COUNT) = (LispObj)(-inhibit); + } + resume_other_threads(true); + gc_deferred++; + return 0; + } + gc_deferred = 0; + + gc_tcr = tcr; + + /* This is generally necessary if the current thread invoked the GC + via an alloc trap, and harmless if the GC was invoked via a GC + trap. (It's necessary in the first case because the "allocptr" + register - %rbx - may be pointing into the middle of something + below tcr->save_allocbase, and we wouldn't want the GC to see + that bogus pointer.) */ + xpGPR(xp, Iallocptr) = VOID_ALLOCPTR; + + normalize_tcr(xp, tcr, false); + + + for (other_tcr = tcr->next; other_tcr != tcr; other_tcr = other_tcr->next) { + if (other_tcr->pending_exception_context) { + other_tcr->gc_context = other_tcr->pending_exception_context; + } else if (other_tcr->valence == TCR_STATE_LISP) { + other_tcr->gc_context = other_tcr->suspend_context; + } else { + /* no pending exception, didn't suspend in lisp state: + must have executed a synchronous ff-call. + */ + other_tcr->gc_context = NULL; + } + normalize_tcr(other_tcr->gc_context, other_tcr, true); + } + + + + result = fun(tcr, param); + + other_tcr = tcr; + do { + other_tcr->gc_context = NULL; + other_tcr = other_tcr->next; + } while (other_tcr != tcr); + + gc_tcr = NULL; + + resume_other_threads(true); + + return result; + +} + +signed_natural +purify_from_xp(ExceptionInformation *xp, signed_natural param) +{ + return gc_like_from_xp(xp, purify, param); +} + +signed_natural +impurify_from_xp(ExceptionInformation *xp, signed_natural param) +{ + return gc_like_from_xp(xp, impurify, param); +} + +/* Returns #bytes freed by invoking GC */ + +signed_natural +gc_from_tcr(TCR *tcr, signed_natural param) +{ + area *a; + BytePtr oldfree, newfree; + BytePtr oldend, newend; + +#if 0 + fprintf(dbgout, "Start GC in 0x" LISP "\n", tcr); +#endif + a = active_dynamic_area; + oldend = a->high; + oldfree = a->active; + gc(tcr, param); + newfree = a->active; + newend = a->high; +#if 0 + fprintf(dbgout, "End GC in 0x" LISP "\n", tcr); +#endif + return ((oldfree-newfree)+(newend-oldend)); +} + +signed_natural +gc_from_xp(ExceptionInformation *xp, signed_natural param) +{ + signed_natural status = gc_like_from_xp(xp, gc_from_tcr, param); + + freeGCptrs(); + return status; +} + +#ifdef DARWIN + +#define TCR_FROM_EXCEPTION_PORT(p) ((TCR *)((natural)p)) +#define TCR_TO_EXCEPTION_PORT(tcr) ((mach_port_t)((natural)(tcr))) + +extern void pseudo_sigreturn(void); + + + +#define LISP_EXCEPTIONS_HANDLED_MASK \ + (EXC_MASK_SOFTWARE | EXC_MASK_BAD_ACCESS | EXC_MASK_BAD_INSTRUCTION | EXC_MASK_ARITHMETIC) + +/* (logcount LISP_EXCEPTIONS_HANDLED_MASK) */ +#define NUM_LISP_EXCEPTIONS_HANDLED 4 + +typedef struct { + int foreign_exception_port_count; + exception_mask_t masks[NUM_LISP_EXCEPTIONS_HANDLED]; + mach_port_t ports[NUM_LISP_EXCEPTIONS_HANDLED]; + exception_behavior_t behaviors[NUM_LISP_EXCEPTIONS_HANDLED]; + thread_state_flavor_t flavors[NUM_LISP_EXCEPTIONS_HANDLED]; +} MACH_foreign_exception_state; + + + + +/* + Mach's exception mechanism works a little better than its signal + mechanism (and, not incidentally, it gets along with GDB a lot + better. + + Initially, we install an exception handler to handle each native + thread's exceptions. This process involves creating a distinguished + thread which listens for kernel exception messages on a set of + 0 or more thread exception ports. As threads are created, they're + added to that port set; a thread's exception port is destroyed + (and therefore removed from the port set) when the thread exits. + + A few exceptions can be handled directly in the handler thread; + others require that we resume the user thread (and that the + exception thread resumes listening for exceptions.) The user + thread might eventually want to return to the original context + (possibly modified somewhat.) + + As it turns out, the simplest way to force the faulting user + thread to handle its own exceptions is to do pretty much what + signal() does: the exception handlng thread sets up a sigcontext + on the user thread's stack and forces the user thread to resume + execution as if a signal handler had been called with that + context as an argument. We can use a distinguished UUO at a + distinguished address to do something like sigreturn(); that'll + have the effect of resuming the user thread's execution in + the (pseudo-) signal context. + + Since: + a) we have miles of code in C and in Lisp that knows how to + deal with Linux sigcontexts + b) Linux sigcontexts contain a little more useful information + (the DAR, DSISR, etc.) than their Darwin counterparts + c) we have to create a sigcontext ourselves when calling out + to the user thread: we aren't really generating a signal, just + leveraging existing signal-handling code. + + we create a Linux sigcontext struct. + + Simple ? Hopefully from the outside it is ... + + We want the process of passing a thread's own context to it to + appear to be atomic: in particular, we don't want the GC to suspend + a thread that's had an exception but has not yet had its user-level + exception handler called, and we don't want the thread's exception + context to be modified by a GC while the Mach handler thread is + copying it around. On Linux (and on Jaguar), we avoid this issue + because (a) the kernel sets up the user-level signal handler and + (b) the signal handler blocks signals (including the signal used + by the GC to suspend threads) until tcr->xframe is set up. + + The GC and the Mach server thread therefore contend for the lock + "mach_exception_lock". The Mach server thread holds the lock + when copying exception information between the kernel and the + user thread; the GC holds this lock during most of its execution + (delaying exception processing until it can be done without + GC interference.) + +*/ + +#ifdef PPC64 +#define C_REDZONE_LEN 320 +#define C_STK_ALIGN 32 +#else +#define C_REDZONE_LEN 224 +#define C_STK_ALIGN 16 +#endif +#define C_PARAMSAVE_LEN 64 +#define C_LINKAGE_LEN 48 + +#define TRUNC_DOWN(a,b,c) (((((natural)a)-(b))/(c)) * (c)) + +void +fatal_mach_error(char *format, ...); + +#define MACH_CHECK_ERROR(context,x) if (x != KERN_SUCCESS) {fatal_mach_error("Mach error while %s : %d", context, x);} + + +void +restore_mach_thread_state(mach_port_t thread, ExceptionInformation *pseudosigcontext) +{ + kern_return_t kret; +#if WORD_SIZE == 64 + MCONTEXT_T mc = UC_MCONTEXT(pseudosigcontext); +#else + mcontext_t mc = UC_MCONTEXT(pseudosigcontext); +#endif + + /* Set the thread's FP state from the pseudosigcontext */ +#if WORD_SIZE == 64 + kret = thread_set_state(thread, + x86_FLOAT_STATE64, + (thread_state_t)&(mc->__fs), + x86_FLOAT_STATE64_COUNT); +#else + kret = thread_set_state(thread, + x86_FLOAT_STATE32, + (thread_state_t)&(mc->__fs), + x86_FLOAT_STATE32_COUNT); +#endif + MACH_CHECK_ERROR("setting thread FP state", kret); + + /* The thread'll be as good as new ... */ +#if WORD_SIZE == 64 + kret = thread_set_state(thread, + x86_THREAD_STATE64, + (thread_state_t)&(mc->__ss), + x86_THREAD_STATE64_COUNT); +#else + kret = thread_set_state(thread, + x86_THREAD_STATE32, + (thread_state_t)&(mc->__ss), + x86_THREAD_STATE32_COUNT); +#endif + MACH_CHECK_ERROR("setting thread state", kret); +} + +/* This code runs in the exception handling thread, in response + to an attempt to execute the UU0 at "pseudo_sigreturn" (e.g., + in response to a call to pseudo_sigreturn() from the specified + user thread. + Find that context (the user thread's R3 points to it), then + use that context to set the user thread's state. When this + function's caller returns, the Mach kernel will resume the + user thread. +*/ + +kern_return_t +do_pseudo_sigreturn(mach_port_t thread, TCR *tcr) +{ + ExceptionInformation *xp; + +#ifdef DEBUG_MACH_EXCEPTIONS + fprintf(dbgout, "doing pseudo_sigreturn for 0x%x\n",tcr); +#endif + xp = tcr->pending_exception_context; + if (xp) { + tcr->pending_exception_context = NULL; + tcr->valence = TCR_STATE_LISP; + restore_mach_thread_state(thread, xp); + raise_pending_interrupt(tcr); + } else { + Bug(NULL, "no xp here!\n"); + } +#ifdef DEBUG_MACH_EXCEPTIONS + fprintf(dbgout, "did pseudo_sigreturn for 0x%x\n",tcr); +#endif + return KERN_SUCCESS; +} + +ExceptionInformation * +create_thread_context_frame(mach_port_t thread, + natural *new_stack_top, + siginfo_t **info_ptr, + TCR *tcr, +#ifdef X8664 + x86_thread_state64_t *ts +#else + x86_thread_state32_t *ts +#endif + ) +{ + mach_msg_type_number_t thread_state_count; + ExceptionInformation *pseudosigcontext; +#ifdef X8664 + MCONTEXT_T mc; +#else + mcontext_t mc; +#endif + natural stackp; + +#ifdef X8664 + stackp = (LispObj) find_foreign_rsp(ts->__rsp,tcr->cs_area,tcr); + stackp = TRUNC_DOWN(stackp, C_REDZONE_LEN, C_STK_ALIGN); +#else + stackp = (LispObj) find_foreign_rsp(ts->__esp, tcr->cs_area, tcr); +#endif + stackp = TRUNC_DOWN(stackp, sizeof(siginfo_t), C_STK_ALIGN); + if (info_ptr) { + *info_ptr = (siginfo_t *)stackp; + } + stackp = TRUNC_DOWN(stackp,sizeof(*pseudosigcontext), C_STK_ALIGN); + pseudosigcontext = (ExceptionInformation *) ptr_from_lispobj(stackp); + + stackp = TRUNC_DOWN(stackp, sizeof(*mc), C_STK_ALIGN); + mc = (MCONTEXT_T) ptr_from_lispobj(stackp); + + memmove(&(mc->__ss),ts,sizeof(*ts)); + +#ifdef X8664 + thread_state_count = x86_FLOAT_STATE64_COUNT; + thread_get_state(thread, + x86_FLOAT_STATE64, + (thread_state_t)&(mc->__fs), + &thread_state_count); + + thread_state_count = x86_EXCEPTION_STATE64_COUNT; + thread_get_state(thread, + x86_EXCEPTION_STATE64, + (thread_state_t)&(mc->__es), + &thread_state_count); +#else + thread_state_count = x86_FLOAT_STATE32_COUNT; + thread_get_state(thread, + x86_FLOAT_STATE32, + (thread_state_t)&(mc->__fs), + &thread_state_count); + + thread_state_count = x86_EXCEPTION_STATE32_COUNT; + thread_get_state(thread, + x86_EXCEPTION_STATE32, + (thread_state_t)&(mc->__es), + &thread_state_count); +#endif + + + UC_MCONTEXT(pseudosigcontext) = mc; + if (new_stack_top) { + *new_stack_top = stackp; + } + return pseudosigcontext; +} + +/* + This code sets up the user thread so that it executes a "pseudo-signal + handler" function when it resumes. Create a fake ucontext struct + on the thread's stack and pass it as an argument to the pseudo-signal + handler. + + Things are set up so that the handler "returns to" pseudo_sigreturn(), + which will restore the thread's context. + + If the handler invokes code that throws (or otherwise never sigreturn()'s + to the context), that's fine. + + Actually, check that: throw (and variants) may need to be careful and + pop the tcr's xframe list until it's younger than any frame being + entered. +*/ + +int +setup_signal_frame(mach_port_t thread, + void *handler_address, + int signum, + int code, + TCR *tcr, +#ifdef X8664 + x86_thread_state64_t *ts +#else + x86_thread_state32_t *ts +#endif + ) +{ +#ifdef X8664 + x86_thread_state64_t new_ts; +#else + x86_thread_state32_t new_ts; +#endif + ExceptionInformation *pseudosigcontext; + int old_valence = tcr->valence; + natural stackp, *stackpp; + siginfo_t *info; + +#ifdef DEBUG_MACH_EXCEPTIONS + fprintf(dbgout,"Setting up exception handling for 0x%x\n", tcr); +#endif + pseudosigcontext = create_thread_context_frame(thread, &stackp, &info, tcr, ts); + bzero(info, sizeof(*info)); + info->si_code = code; + info->si_addr = (void *)(UC_MCONTEXT(pseudosigcontext)->__es.__faultvaddr); + info->si_signo = signum; + pseudosigcontext->uc_onstack = 0; + pseudosigcontext->uc_sigmask = (sigset_t) 0; + pseudosigcontext->uc_stack.ss_sp = 0; + pseudosigcontext->uc_stack.ss_size = 0; + pseudosigcontext->uc_stack.ss_flags = 0; + pseudosigcontext->uc_link = NULL; + pseudosigcontext->uc_mcsize = sizeof(*UC_MCONTEXT(pseudosigcontext)); + tcr->pending_exception_context = pseudosigcontext; + tcr->valence = TCR_STATE_EXCEPTION_WAIT; + + + /* + It seems like we've created a sigcontext on the thread's + stack. Set things up so that we call the handler (with appropriate + args) when the thread's resumed. + */ + +#ifdef X8664 + new_ts.__rip = (natural) handler_address; + stackpp = (natural *)stackp; + *--stackpp = (natural)pseudo_sigreturn; + stackp = (natural)stackpp; + new_ts.__rdi = signum; + new_ts.__rsi = (natural)info; + new_ts.__rdx = (natural)pseudosigcontext; + new_ts.__rcx = (natural)tcr; + new_ts.__r8 = (natural)old_valence; + new_ts.__rsp = stackp; + new_ts.__rflags = ts->__rflags; +#else +#define USER_CS 0x17 +#define USER_DS 0x1f + bzero(&new_ts, sizeof(new_ts)); + new_ts.__cs = ts->__cs; + new_ts.__ss = ts->__ss; + new_ts.__ds = ts->__ds; + new_ts.__es = ts->__es; + new_ts.__fs = ts->__fs; + new_ts.__gs = ts->__gs; + + new_ts.__eip = (natural)handler_address; + stackpp = (natural *)stackp; + *--stackpp = 0; /* alignment */ + *--stackpp = 0; + *--stackpp = 0; + *--stackpp = (natural)old_valence; + *--stackpp = (natural)tcr; + *--stackpp = (natural)pseudosigcontext; + *--stackpp = (natural)info; + *--stackpp = (natural)signum; + *--stackpp = (natural)pseudo_sigreturn; + stackp = (natural)stackpp; + new_ts.__esp = stackp; + new_ts.__eflags = ts->__eflags; +#endif + +#ifdef X8664 + thread_set_state(thread, + x86_THREAD_STATE64, + (thread_state_t)&new_ts, + x86_THREAD_STATE64_COUNT); +#else + thread_set_state(thread, + x86_THREAD_STATE32, + (thread_state_t)&new_ts, + x86_THREAD_STATE32_COUNT); +#endif +#ifdef DEBUG_MACH_EXCEPTIONS + fprintf(dbgout,"Set up exception context for 0x%x at 0x%x\n", tcr, tcr->pending_exception_context); +#endif + return 0; +} + + + + + + +/* + This function runs in the exception handling thread. It's + called (by this precise name) from the library function "exc_server()" + when the thread's exception ports are set up. (exc_server() is called + via mach_msg_server(), which is a function that waits for and dispatches + on exception messages from the Mach kernel.) + + This checks to see if the exception was caused by a pseudo_sigreturn() + UUO; if so, it arranges for the thread to have its state restored + from the specified context. + + Otherwise, it tries to map the exception to a signal number and + arranges that the thread run a "pseudo signal handler" to handle + the exception. + + Some exceptions could and should be handled here directly. +*/ + +/* We need the thread's state earlier on x86_64 than we did on PPC; + the PC won't fit in code_vector[1]. We shouldn't try to get it + lazily (via catch_exception_raise_state()); until we own the + exception lock, we shouldn't have it in userspace (since a GCing + thread wouldn't know that we had our hands on it.) +*/ + +#ifdef X8664 +#define ts_pc(t) t.__rip +#else +#define ts_pc(t) t.__eip +#endif + + +#define DARWIN_EXCEPTION_HANDLER signal_handler + + +kern_return_t +catch_exception_raise(mach_port_t exception_port, + mach_port_t thread, + mach_port_t task, + exception_type_t exception, + exception_data_t code_vector, + mach_msg_type_number_t code_count) +{ + int signum = 0, code = *code_vector; + TCR *tcr = TCR_FROM_EXCEPTION_PORT(exception_port); + kern_return_t kret, call_kret; +#ifdef X8664 + x86_thread_state64_t ts; +#else + x86_thread_state32_t ts; +#endif + mach_msg_type_number_t thread_state_count; + + + + +#ifdef DEBUG_MACH_EXCEPTIONS + fprintf(dbgout, "obtaining Mach exception lock in exception thread\n"); +#endif + + + if (1) { +#ifdef X8664 + do { + thread_state_count = x86_THREAD_STATE64_COUNT; + call_kret = thread_get_state(thread, + x86_THREAD_STATE64, + (thread_state_t)&ts, + &thread_state_count); + } while (call_kret == KERN_ABORTED); + MACH_CHECK_ERROR("getting thread state",call_kret); +#else + thread_state_count = x86_THREAD_STATE32_COUNT; + call_kret = thread_get_state(thread, + x86_THREAD_STATE32, + (thread_state_t)&ts, + &thread_state_count); + MACH_CHECK_ERROR("getting thread state",call_kret); +#endif + if (tcr->flags & (1<flags & (1<native_thread_info; + int i; + unsigned n = NUM_LISP_EXCEPTIONS_HANDLED; + mach_port_t lisp_port = TCR_TO_EXCEPTION_PORT(tcr), foreign_port; + exception_mask_t mask = 0; + + kret = thread_swap_exception_ports(thread, + LISP_EXCEPTIONS_HANDLED_MASK, + lisp_port, + EXCEPTION_DEFAULT, + THREAD_STATE_NONE, + fxs->masks, + &n, + fxs->ports, + fxs->behaviors, + fxs->flavors); + if (kret == KERN_SUCCESS) { + fxs->foreign_exception_port_count = n; + for (i = 0; i < n; i ++) { + foreign_port = fxs->ports[i]; + + if ((foreign_port != lisp_port) && + (foreign_port != MACH_PORT_NULL)) { + mask |= fxs->masks[i]; + } + } + tcr->foreign_exception_status = (int) mask; + } + return kret; +} + +kern_return_t +tcr_establish_lisp_exception_port(TCR *tcr) +{ + return tcr_establish_exception_port(tcr, (mach_port_t)((natural)tcr->native_thread_id)); +} + +/* + Do this when calling out to or returning from foreign code, if + any conflicting foreign exception ports were established when we + last entered lisp code. +*/ +kern_return_t +restore_foreign_exception_ports(TCR *tcr) +{ + exception_mask_t m = (exception_mask_t) tcr->foreign_exception_status; + + if (m) { + MACH_foreign_exception_state *fxs = + (MACH_foreign_exception_state *) tcr->native_thread_info; + int i, n = fxs->foreign_exception_port_count; + exception_mask_t tm; + + for (i = 0; i < n; i++) { + if ((tm = fxs->masks[i]) & m) { + thread_set_exception_ports((mach_port_t)((natural)tcr->native_thread_id), + tm, + fxs->ports[i], + fxs->behaviors[i], + fxs->flavors[i]); + } + } + } +} + + +/* + This assumes that a Mach port (to be used as the thread's exception port) whose + "name" matches the TCR's 32-bit address has already been allocated. +*/ + +kern_return_t +setup_mach_exception_handling(TCR *tcr) +{ + mach_port_t + thread_exception_port = TCR_TO_EXCEPTION_PORT(tcr), + task_self = mach_task_self(); + kern_return_t kret; + + kret = mach_port_insert_right(task_self, + thread_exception_port, + thread_exception_port, + MACH_MSG_TYPE_MAKE_SEND); + MACH_CHECK_ERROR("adding send right to exception_port",kret); + + kret = tcr_establish_exception_port(tcr, (mach_port_t)((natural) tcr->native_thread_id)); + if (kret == KERN_SUCCESS) { + mach_port_t exception_port_set = mach_exception_port_set(); + + kret = mach_port_move_member(task_self, + thread_exception_port, + exception_port_set); + } + return kret; +} + +void +darwin_exception_init(TCR *tcr) +{ + void tcr_monitor_exception_handling(TCR*, Boolean); + kern_return_t kret; + MACH_foreign_exception_state *fxs = + calloc(1, sizeof(MACH_foreign_exception_state)); + + tcr->native_thread_info = (void *) fxs; + + if ((kret = setup_mach_exception_handling(tcr)) + != KERN_SUCCESS) { + fprintf(dbgout, "Couldn't setup exception handler - error = %d\n", kret); + terminate_lisp(); + } +} + +/* + The tcr is the "name" of the corresponding thread's exception port. + Destroying the port should remove it from all port sets of which it's + a member (notably, the exception port set.) +*/ +void +darwin_exception_cleanup(TCR *tcr) +{ + void *fxs = tcr->native_thread_info; + extern Boolean use_mach_exception_handling; + + if (fxs) { + tcr->native_thread_info = NULL; + free(fxs); + } + if (use_mach_exception_handling) { + mach_port_deallocate(mach_task_self(),TCR_TO_EXCEPTION_PORT(tcr)); + mach_port_destroy(mach_task_self(),TCR_TO_EXCEPTION_PORT(tcr)); + } +} + + +Boolean +suspend_mach_thread(mach_port_t mach_thread) +{ + kern_return_t status; + Boolean aborted = false; + + do { + aborted = false; + status = thread_suspend(mach_thread); + if (status == KERN_SUCCESS) { + status = thread_abort_safely(mach_thread); + if (status == KERN_SUCCESS) { + aborted = true; + } else { + fprintf(dbgout, "abort failed on thread = 0x%x\n",mach_thread); + thread_resume(mach_thread); + } + } else { + return false; + } + } while (! aborted); + return true; +} + +/* + Only do this if pthread_kill indicated that the pthread isn't + listening to signals anymore, as can happen as soon as pthread_exit() + is called on Darwin. The thread could still call out to lisp as it + is exiting, so we need another way to suspend it in this case. +*/ +Boolean +mach_suspend_tcr(TCR *tcr) +{ + mach_port_t mach_thread = (mach_port_t)((natural)( tcr->native_thread_id)); + ExceptionInformation *pseudosigcontext; + Boolean result = false; + + result = suspend_mach_thread(mach_thread); + if (result) { + mach_msg_type_number_t thread_state_count; +#ifdef X8664 + x86_thread_state64_t ts; + thread_state_count = x86_THREAD_STATE64_COUNT; + thread_get_state(mach_thread, + x86_THREAD_STATE64, + (thread_state_t)&ts, + &thread_state_count); +#else + x86_thread_state32_t ts; + thread_state_count = x86_THREAD_STATE_COUNT; + thread_get_state(mach_thread, + x86_THREAD_STATE, + (thread_state_t)&ts, + &thread_state_count); +#endif + + pseudosigcontext = create_thread_context_frame(mach_thread, NULL, NULL,tcr, &ts); + pseudosigcontext->uc_onstack = 0; + pseudosigcontext->uc_sigmask = (sigset_t) 0; + tcr->suspend_context = pseudosigcontext; + } + return result; +} + +void +mach_resume_tcr(TCR *tcr) +{ + ExceptionInformation *xp; + mach_port_t mach_thread = (mach_port_t)((natural)(tcr->native_thread_id)); + + xp = tcr->suspend_context; +#ifdef DEBUG_MACH_EXCEPTIONS + fprintf(dbgout, "resuming TCR 0x%x, pending_exception_context = 0x%x\n", + tcr, tcr->pending_exception_context); +#endif + tcr->suspend_context = NULL; + restore_mach_thread_state(mach_thread, xp); +#ifdef DEBUG_MACH_EXCEPTIONS + fprintf(dbgout, "restored state in TCR 0x%x, pending_exception_context = 0x%x\n", + tcr, tcr->pending_exception_context); +#endif + thread_resume(mach_thread); +} + +void +fatal_mach_error(char *format, ...) +{ + va_list args; + char s[512]; + + + va_start(args, format); + vsnprintf(s, sizeof(s),format, args); + va_end(args); + + Fatal("Mach error", s); +} + + + + +#endif + +/* watchpoint stuff */ + +area * +new_watched_area(natural size) +{ + void *p; + + p = MapMemory(NULL, size, MEMPROTECT_RWX); + if ((signed_natural)p == -1) { + allocation_failure(true, size); + } + return new_area(p, p + size, AREA_WATCHED); +} + +void +delete_watched_area(area *a, TCR *tcr) +{ + natural nbytes = a->high - a->low; + char *base = a->low; + + condemn_area_holding_area_lock(a); + + if (nbytes) { + int err; + +/* can't use UnMapMemory() beacuse it only uses MEM_DECOMMIT */ +#ifdef WINDOWS + err = VirtualFree(base, nbytes, MEM_RELEASE); +#else + err = munmap(base, nbytes); +#endif + if (err != 0) + Fatal("munmap in delete_watched_area", ""); + } +} + +natural +uvector_total_size_in_bytes(LispObj *u) +{ + LispObj header = header_of(u); + natural header_tag = fulltag_of(header); + natural subtag = header_subtag(header); + natural element_count = header_element_count(header); + natural nbytes = 0; + +#ifdef X8632 + if ((nodeheader_tag_p(header_tag)) || + (subtag <= max_32_bit_ivector_subtag)) { + nbytes = element_count << 2; + } else if (subtag <= max_8_bit_ivector_subtag) { + nbytes = element_count; + } else if (subtag <= max_16_bit_ivector_subtag) { + nbytes = element_count << 1; + } else if (subtag == subtag_double_float_vector) { + nbytes = element_count << 3; + } else { + nbytes = (element_count + 7) >> 3; + } + /* add 4 byte header and round up to multiple of 8 bytes */ + return ~7 & (4 + nbytes + 7); +#endif +#ifdef X8664 + if ((nodeheader_tag_p(header_tag)) || (header_tag == ivector_class_64_bit)) { + nbytes = element_count << 3; + } else if (header_tag == ivector_class_32_bit) { + nbytes = element_count << 2; + } else { + /* ivector_class_other_bit contains 8, 16-bit arrays & bit vector */ + if (subtag == subtag_bit_vector) { + nbytes = (element_count + 7) >> 3; + } else if (subtag >= min_8_bit_ivector_subtag) { + nbytes = element_count; + } else { + nbytes = element_count << 1; + } + } + /* add 8 byte header and round up to multiple of 16 bytes */ + return ~15 & (8 + nbytes + 15); +#endif +} + +extern void wp_update_references(TCR *, LispObj, LispObj); + +/* + * Other threads are suspended and pc-lusered. + * + * param contains a tagged pointer to a uvector or a cons cell + */ +signed_natural +watch_object(TCR *tcr, signed_natural param) +{ + LispObj object = (LispObj)param; + unsigned tag = fulltag_of(object); + LispObj *noderef = (LispObj *)untag(object); + area *object_area = area_containing((BytePtr)noderef); + natural size; + + if (tag == fulltag_cons) + size = 2 * node_size; + else + size = uvector_total_size_in_bytes(noderef); + + if (object_area && object_area->code == AREA_DYNAMIC) { + area *a = new_watched_area(size); + LispObj old = object; + LispObj new = (LispObj)((natural)a->low + tag); + + add_area_holding_area_lock(a); + + /* move object to watched area */ + memcpy(a->low, noderef, size); + ProtectMemory(a->low, size); + memset(noderef, 0, size); + wp_update_references(tcr, old, new); + check_all_areas(tcr); + return 1; + } + return 0; +} + +/* + * We expect the watched object in arg_y, and the new uninitialized + * object (which is just zeroed) in arg_z. + */ +signed_natural +unwatch_object(TCR *tcr, signed_natural param) +{ + ExceptionInformation *xp = tcr->xframe->curr; + LispObj old = xpGPR(xp, Iarg_y); + unsigned tag = fulltag_of(old); + LispObj new = xpGPR(xp, Iarg_z); + LispObj *oldnode = (LispObj *)untag(old); + LispObj *newnode = (LispObj *)untag(new); + area *a = area_containing((BytePtr)old); + + if (a && a->code == AREA_WATCHED) { + natural size; + + if (tag == fulltag_cons) + size = 2 * node_size; + else + size = uvector_total_size_in_bytes(oldnode); + + memcpy(newnode, oldnode, size); + delete_watched_area(a, tcr); + wp_update_references(tcr, old, new); + /* because wp_update_references doesn't update refbits */ + tenure_to_area(tenured_area); + /* Unwatching can (re-)introduce managed_static->dynamic references */ + zero_bits(managed_static_area->refbits,managed_static_area->ndnodes); + update_managed_refs(managed_static_area, low_markable_address, area_dnode(active_dynamic_area->active, low_markable_address)); + check_all_areas(tcr); + xpGPR(xp, Iarg_z) = new; + } + return 0; +} + +Boolean +handle_watch_trap(ExceptionInformation *xp, TCR *tcr) +{ + LispObj selector = xpGPR(xp,Iimm0); + LispObj object = xpGPR(xp, Iarg_z); + signed_natural result; + + switch (selector) { + case WATCH_TRAP_FUNCTION_WATCH: + result = gc_like_from_xp(xp, watch_object, object); + if (result == 0) + xpGPR(xp,Iarg_z) = lisp_nil; + break; + case WATCH_TRAP_FUNCTION_UNWATCH: + gc_like_from_xp(xp, unwatch_object, 0); + break; + default: + break; + } + return true; +} + Index: /branches/new-random/lisp-kernel/x86-exceptions.h =================================================================== --- /branches/new-random/lisp-kernel/x86-exceptions.h (revision 13309) +++ /branches/new-random/lisp-kernel/x86-exceptions.h (revision 13309) @@ -0,0 +1,269 @@ +/* + Copyright (C) 2005-2009 Clozure Associates + This file is part of Clozure CL. + + Clozure CL is licensed under the terms of the Lisp Lesser GNU Public + License , known as the LLGPL and distributed with Clozure CL as the + file "LICENSE". The LLGPL consists of a preamble and the LGPL, + which is distributed with Clozure CL as the file "LGPL". Where these + conflict, the preamble takes precedence. + + Clozure CL is referenced in the preamble as the "LIBRARY." + + The LLGPL is also available online at + http://opensource.franz.com/preamble.html +*/ + +#ifndef X86_EXCEPTIONS_H +#define X86_EXCEPTIONS_H 1 + +typedef u8_t opcode, *pc; + +#ifdef LINUX +#define xpGPRvector(x) ((natural *)(&((x)->uc_mcontext.gregs))) +#define xpGPR(x,gprno) (xpGPRvector(x)[gprno]) +#define set_xpGPR(x,gpr,new) xpGPR((x),(gpr)) = (natural)(new) +#define xpPC(x) (xpGPR(x,Iip)) +#define xpMMXreg(x,n) *((natural *)(&((x)->uc_mcontext.fpregs->_st[n]))) +#define eflags_register(xp) xpGPR(xp,Iflags) +#endif + +#ifdef DARWIN +#define DARWIN_USE_PSEUDO_SIGRETURN 1 +#include +#define DarwinSigReturn(context) do {\ + darwin_sigreturn(context);\ + Bug(context,"sigreturn returned");\ + } while (0) + +#define xpGPRvector(x) ((natural *)(&(UC_MCONTEXT(x)->__ss))) +#define xpGPR(x,gprno) (xpGPRvector(x)[gprno]) +#define set_xpGPR(x,gpr,new) xpGPR((x),(gpr)) = (natural)(new) +#define xpPC(x) (xpGPR(x,Iip)) +#define eflags_register(xp) xpGPR(xp,Iflags) +#define xpFPRvector(x) ((natural *)(&(UC_MCONTEXT(x)->__fs.__fpu_xmm0))) +#define xpMMXvector(x) (&(UC_MCONTEXT(x)->__fs.__fpu_stmm0)) +/* Note that this yields only the lower half of the MMX reg on x8632 */ +#define xpMMXreg(x,n) *(natural *)&(xpMMXvector(x)[n]) + +#include +#include +#include +#include + +pthread_mutex_t *mach_exception_lock; + +#endif + +#ifdef FREEBSD +#ifdef X8664 +#include +#else +#include "freebsdx8632/fpu.h" +#endif +#define xpGPRvector(x) ((natural *)(&((x)->uc_mcontext))) +#define xpGPR(x,gprno) (xpGPRvector(x)[gprno]) +#define set_xpGPR(x,gpr,new) xpGPR((x),(gpr)) = (natural)(new) +#define eflags_register(xp) xpGPR(xp,Iflags) +#define xpPC(x) xpGPR(x,Iip) +#ifdef X8664 +#define xpMMXreg(x,n) *((natural *)(&(((struct savefpu *)(&(x)->uc_mcontext.mc_fpstate))->sv_fp[n]))) +#define xpXMMregs(x)(&(((struct savefpu *)(&(x)->uc_mcontext.mc_fpstate))->sv_xmm[0])) +#else +#define xpMMXreg(x,n) *((natural *)(&(((struct ccl_savexmm *)(&(x)->uc_mcontext.mc_fpstate))->sv_fp[n]))) +#define xpXMMregs(x)(&(((struct ccl_savexmm *)(&(x)->uc_mcontext.mc_fpstate))->sv_xmm[0])) +#endif +#endif + +#ifdef SOLARIS +#define xpGPRvector(x) ((x)->uc_mcontext.gregs) +#define xpGPR(x,gprno) (xpGPRvector(x)[gprno]) +#define set_xpGPR(x,gpr,new) xpGPR((x),(gpr)) = (natural)(new) +#define xpPC(x) xpGPR(x,Iip) +#define eflags_register(xp) xpGPR(xp,Iflags) +#define xpXMMregs(x)(&((x)->uc_mcontext.fpregs.fp_reg_set.fpchip_state.xmm[0])) +#ifdef X8632 +#define xpMMXreg(x,n)*(natural *)(&(((struct fnsave_state *)(&(((x)->uc_mcontext.fpregs))))->f_st[n])) +#endif +#endif + +#ifdef WINDOWS +#ifdef X8664 +#define xpGPRvector(x) ((DWORD64 *)(&(x)->Rax)) +#define xpGPR(x,gprno) (xpGPRvector(x)[gprno]) +#define xpPC(x) xpGPR(x,Iip) +#define eflags_register(xp) xp->EFlags +#define xpMXCSRptr(x) (DWORD *)(&(x->MxCsr)) +#else +#define xpGPRvector(x) ((DWORD *)(&(x)->Edi)) +#define xpGPR(x,gprno) (xpGPRvector(x)[gprno]) +#define xpPC(x) xpGPR(x,Iip) +#define eflags_register(xp) xp->EFlags +#define xpFPRvector(x) ((natural *)(&(x->ExtendedRegisters[10*16]))) +#define xpMMXreg(x,n) (*((u64_t *)(&(x->FloatSave.RegisterArea[10*(n)])))) +#define xpMXCSRptr(x) (DWORD *)(&(x->ExtendedRegisters[24])) +#endif +#endif + +#ifdef DARWIN +#define SIGNAL_FOR_PROCESS_INTERRUPT SIGUSR1 +#endif +#ifdef LINUX +#define SIGNAL_FOR_PROCESS_INTERRUPT SIGPWR +#endif +#ifdef FREEBSD +#define SIGNAL_FOR_PROCESS_INTERRUPT SIGEMT +#endif +#ifdef SOLARIS +#define SIGNAL_FOR_PROCESS_INTERRUPT SIGUSR1 +#endif +#ifdef WINDOWS +#define SIGNAL_FOR_PROCESS_INTERRUPT SIGINT +#ifndef SIGBUS +#define SIGBUS 10 +#endif +#ifndef CONTEXT_ALL +#define CONTEXT_ALL (CONTEXT_CONTROL | CONTEXT_INTEGER | CONTEXT_SEGMENTS | CONTEXT_FLOATING_POINT | CONTEXT_DEBUG_REGISTERS | CONTEXT_EXTENDED_REGISTERS) +#endif +#endif + + + +void switch_to_foreign_stack(void*, ...); + +#define INTN_OPCODE 0xcd + +#define UUO_GC_TRAP 0xc4 +#define UUO_ALLOC_TRAP 0xc5 +#define UUO_DEBUG_TRAP 0xca +#define UUO_DEBUG_TRAP_WITH_STRING 0xcd +#define UUO_WATCH_TRAP 0xce + #define WATCH_TRAP_FUNCTION_WATCH 0 + #define WATCH_TRAP_FUNCTION_UNWATCH 1 + +#define XUUO_OPCODE_0 0x0f +#define XUUO_OPCODE_1 0x0b + +#define XUUO_TLB_TOO_SMALL 1 +#define XUUO_INTERRUPT_NOW 2 +#define XUUO_SUSPEND_NOW 3 +#define XUUO_INTERRUPT 4 +#define XUUO_SUSPEND 5 +#define XUUO_SUSPEND_ALL 6 +#define XUUO_RESUME 7 +#define XUUO_RESUME_ALL 8 +#define XUUO_KILL 9 +#define XUUO_ALLOCATE_LIST 10 + +void +pc_luser_xp(ExceptionInformation*, TCR*, signed_natural*); + + +typedef enum { + ID_unrecognized_alloc_instruction, + ID_load_allocptr_reg_from_tcr_save_allocptr_instruction, + ID_compare_allocptr_reg_to_tcr_save_allocbase_instruction, + ID_branch_around_alloc_trap_instruction, + ID_alloc_trap_instruction, + ID_set_allocptr_header_instruction, + ID_clear_tcr_save_allocptr_tag_instruction +} alloc_instruction_id; + +#ifdef LINUX +#define SIGNUM_FOR_INTN_TRAP SIGSEGV +#define IS_MAYBE_INT_TRAP(info,xp) ((xpGPR(xp,REG_TRAPNO)==0xd)&&((xpGPR(xp,REG_ERR)&7)==2)) +#define IS_PAGE_FAULT(info,xp) (xpGPR(xp,REG_TRAPNO)==0xe) +#define SIGRETURN(context) +#endif + +#ifdef FREEBSD +extern void freebsd_sigreturn(ExceptionInformation *); +#define SIGNUM_FOR_INTN_TRAP SIGBUS +#define IS_MAYBE_INT_TRAP(info,xp) ((xp->uc_mcontext.mc_trapno == T_PROTFLT) && ((xp->uc_mcontext.mc_err & 7) == 2)) +#define IS_PAGE_FAULT(info,xp) (xp->uc_mcontext.mc_trapno == T_PAGEFLT) +#define SIGRETURN(context) freebsd_sigreturn(context) +#endif + +#ifdef DARWIN +#define SIGNUM_FOR_INTN_TRAP SIGSEGV /* Not really, but our Mach handler fakes that */ +#define IS_MAYBE_INT_TRAP(info,xp) ((UC_MCONTEXT(xp)->__es.__trapno == 0xd) && (((UC_MCONTEXT(xp)->__es.__err)&7)==2)) +#define IS_PAGE_FAULT(info,xp) (UC_MCONTEXT(xp)->__es.__trapno == 0xe) +/* The x86 version of sigreturn just needs the context argument; the + hidden, magic "flavor" argument that sigtramp uses is ignored. */ +#define SIGRETURN(context) DarwinSigReturn(context) +#endif + +#ifdef SOLARIS +#define SIGNUM_FOR_INTN_TRAP SIGSEGV +#ifdef X8664 +#define IS_MAYBE_INT_TRAP(info,xp) ((xpGPR(xp,REG_TRAPNO)==0xd)&&((xpGPR(xp,REG_ERR)&7)==2)) +#define IS_PAGE_FAULT(info,xp) (xpGPR(xp,REG_TRAPNO)==0xe) +#else +#define IS_MAYBE_INT_TRAP(info,xp) ((xpGPR(xp,TRAPNO)==0xd)&&((xpGPR(xp,ERR)&7)==2)) +#define IS_PAGE_FAULT(info,xp) (xpGPR(xp,TRAPNO)==0xe) +#endif +#define SIGRETURN(context) setcontext(context) +#endif + +#ifdef WINDOWS +#define SIGNUM_FOR_INTN_TRAP SIGSEGV /* Also fake */ +#define IS_MAYBE_INT_TRAP(info,xp) \ + ((info->ExceptionCode == EXCEPTION_ACCESS_VIOLATION) && \ + (info->ExceptionInformation[0]==0) && \ + (info->ExceptionInformation[1]==(ULONG_PTR)(-1L))) +#define IS_PAGE_FAULT(info,xp) (1) +#define SIGRETURN(context) /* for now */ +#endif + +/* Please go away. */ +#ifdef DARWIN_GS_HACK +extern Boolean ensure_gs_pthread(void); +extern void set_gs_address(void *); +#endif + + +/* sigaltstack isn't thread-specific on The World's Most Advanced OS */ +#ifdef DARWIN +#undef USE_SIGALTSTACK +#else +#ifdef WINDOWS +#undef USE_SIGALTSTACK +#else +#define USE_SIGALTSTACK 1 +#endif +#endif + +#ifdef USE_SIGALTSTACK +void setup_sigaltstack(area *); +#endif + +/* recognizing the function associated with a tagged return address */ +/* now involves recognizinig an "(lea (@ disp (% rip)) (% rn))" */ +/* instruction at the tra */ + +#define RECOVER_FN_FROM_RIP_LENGTH 7 /* the instruction is 7 bytes long */ +#define RECOVER_FN_FROM_RIP_DISP_OFFSET 3 /* displacement word is 3 bytes in */ +#define RECOVER_FN_FROM_RIP_WORD0 0x8d4c /* 0x4c 0x8d, little-endian */ +#define RECOVER_FN_FROM_RIP_BYTE2 0x2d /* third byte of opcode */ + +extern natural get_mxcsr(); +extern void set_mxcsr(natural); + +#ifdef WINDOWS +typedef struct { + HANDLE h; + OVERLAPPED *o; +} pending_io; +#endif + +#ifdef X8632 +/* The 32-bit immediate value in the instruction + * "(mov ($ 0x12345678) (% fn))" at a tagged return address + * refers to the associated function. + */ +#define RECOVER_FN_OPCODE 0xbf +#define RECOVER_FN_LENGTH 5 +#endif + +#endif /* X86_EXCEPTIONS_H */ + Index: /branches/new-random/lisp-kernel/x86-gc.c =================================================================== --- /branches/new-random/lisp-kernel/x86-gc.c (revision 13309) +++ /branches/new-random/lisp-kernel/x86-gc.c (revision 13309) @@ -0,0 +1,3335 @@ +/* + Copyright (C) 2009 Clozure Associates + Copyright (C) 1994-2001 Digitool, Inc + This file is part of Clozure CL. + + Clozure CL is licensed under the terms of the Lisp Lesser GNU Public + License , known as the LLGPL and distributed with Clozure CL as the + file "LICENSE". The LLGPL consists of a preamble and the LGPL, + which is distributed with Clozure CL as the file "LGPL". Where these + conflict, the preamble takes precedence. + + Clozure CL is referenced in the preamble as the "LIBRARY." + + The LLGPL is also available online at + http://opensource.franz.com/preamble.html +*/ + +#include "lisp.h" +#include "lisp_globals.h" +#include "bits.h" +#include "gc.h" +#include "area.h" +#include "Threads.h" +#include +#include +#include +#include + +#ifdef X8632 +inline natural +imm_word_count(LispObj fn) +{ + natural w = ((unsigned short *)fn)[-1]; + + if (w & 0x8000) { + /* + * The low 15 bits encode the number of contants. + * Compute and return the immediate word count. + */ + LispObj header = header_of(fn); + natural element_count = header_element_count(header); + + return element_count - (w & 0x7fff); + } else { + /* The immediate word count is encoded directly. */ + return w; + } +} +#endif + +/* Heap sanity checking. */ + +void +check_node(LispObj n) +{ + int tag = fulltag_of(n), header_tag; + area *a; + LispObj header; + + if (n == (n & 0xff)) { + return; + } + + switch (tag) { + case fulltag_even_fixnum: + case fulltag_odd_fixnum: +#ifdef X8632 + case fulltag_imm: +#endif +#ifdef X8664 + case fulltag_imm_0: + case fulltag_imm_1: +#endif + return; + +#ifdef X8664 + case fulltag_nil: + if (n != lisp_nil) { + Bug(NULL,"Object tagged as nil, not nil : " LISP, n); + } + return; +#endif + +#ifdef X8632 + case fulltag_nodeheader: + case fulltag_immheader: +#endif +#ifdef X8664 + case fulltag_nodeheader_0: + case fulltag_nodeheader_1: + case fulltag_immheader_0: + case fulltag_immheader_1: + case fulltag_immheader_2: +#endif + Bug(NULL, "Header not expected : 0x" LISP, n); + return; + +#ifdef X8632 + case fulltag_tra: +#endif +#ifdef X8664 + case fulltag_tra_0: + case fulltag_tra_1: +#endif + a = heap_area_containing((BytePtr)ptr_from_lispobj(n)); + if (a == NULL) { + a = active_dynamic_area; + if ((n > (ptr_to_lispobj(a->active))) && + (n < (ptr_to_lispobj(a->high)))) { + Bug(NULL, "TRA points to heap free space: 0x" LISP, n); + } + return; + } + /* tra points into the heap. Check displacement, then + check the function it (should) identify. + */ +#ifdef X8632 + { + LispObj fun = 0; + + if (*(unsigned char *)n == RECOVER_FN_OPCODE) + fun = *(LispObj *)(n + 1); + if (fun == 0 || + (header_subtag(header_of(fun)) != subtag_function) || + (heap_area_containing((BytePtr)ptr_from_lispobj(fun)) != a)) { + Bug(NULL, "TRA at 0x" LISP " has bad function address 0x" LISP "\n", n, fun); + } + n = fun; + } +#endif +#ifdef X8664 + { + int disp = 0; + LispObj m = n; + + if ((*((unsigned short *)n) == RECOVER_FN_FROM_RIP_WORD0) && + (*((unsigned char *)(n+2)) == RECOVER_FN_FROM_RIP_BYTE2)) { + disp = (*(int *) (n+3)); + n = RECOVER_FN_FROM_RIP_LENGTH+m+disp; + } + if ((disp == 0) || + (fulltag_of(n) != fulltag_function) || + (heap_area_containing((BytePtr)ptr_from_lispobj(n)) != a)) { + Bug(NULL, "TRA at 0x" LISP " has bad displacement %d\n", n, disp); + } + } +#endif + /* Otherwise, fall through and check the header on the function + that the tra references */ + + case fulltag_misc: + case fulltag_cons: +#ifdef X8664 + case fulltag_symbol: + case fulltag_function: +#endif + a = heap_area_containing((BytePtr)ptr_from_lispobj(n)); + + if (a == NULL) { + /* Can't do as much sanity checking as we'd like to + if object is a defunct stack-consed object. + If a dangling reference to the heap, that's + bad .. */ + a = active_dynamic_area; + if ((n > (ptr_to_lispobj(a->active))) && + (n < (ptr_to_lispobj(a->high)))) { + Bug(NULL, "Node points to heap free space: 0x" LISP, n); + } + return; + } + break; + } + /* Node points to heap area, so check header/lack thereof. */ + header = header_of(n); + header_tag = fulltag_of(header); + if (tag == fulltag_cons) { + if ((nodeheader_tag_p(header_tag)) || + (immheader_tag_p(header_tag))) { + Bug(NULL, "Cons cell at 0x" LISP " has bogus header : 0x" LISP, n, header); + } + return; + } + + if ((!nodeheader_tag_p(header_tag)) && + (!immheader_tag_p(header_tag))) { + Bug(NULL,"Vector at 0x" LISP " has bogus header : 0x" LISP, n, header); + } + return; +} + +void +check_all_mark_bits(LispObj *nodepointer) +{ +} + + + + + +void +check_range(LispObj *start, LispObj *end, Boolean header_allowed) +{ + LispObj node, *current = start, *prev = NULL; + int tag; + natural elements; + + while (current < end) { + prev = current; + node = *current++; + tag = fulltag_of(node); + if (immheader_tag_p(tag)) { + if (! header_allowed) { + Bug(NULL, "Header not expected at 0x" LISP "\n", prev); + } + current = (LispObj *)skip_over_ivector((natural)prev, node); + } else if (nodeheader_tag_p(tag)) { + if (! header_allowed) { + Bug(NULL, "Header not expected at 0x" LISP "\n", prev); + } + elements = header_element_count(node) | 1; + if (header_subtag(node) == subtag_function) { +#ifdef X8632 + int skip = *(unsigned short *)current; + + /* XXX bootstrapping */ + if (skip & 0x8000) + skip = elements - (skip & 0x7fff); +#else + int skip = *(int *)current; +#endif + current += skip; + elements -= skip; + } + while (elements--) { + check_node(*current++); + } + } else { + check_node(node); + check_node(*current++); + } + } + + if (current != end) { + Bug(NULL, "Overran end of memory range: start = 0x%08x, end = 0x%08x, prev = 0x%08x, current = 0x%08x", + start, end, prev, current); + } +} + +#ifdef X8632 +void +check_xp(ExceptionInformation *xp, natural node_regs_mask) +{ + natural *regs = (natural *) xpGPRvector(xp), dnode; + + if (node_regs_mask & (1<<0)) check_node(regs[REG_EAX]); + if (node_regs_mask & (1<<1)) check_node(regs[REG_ECX]); + if (regs[REG_EFL] & EFL_DF) { + /* DF set means EDX should be treated as an imm reg */ + ; + } else + if (node_regs_mask & (1<<2)) check_node(regs[REG_EDX]); + + if (node_regs_mask & (1<<3)) check_node(regs[REG_EBX]); + if (node_regs_mask & (1<<4)) check_node(regs[REG_ESP]); + if (node_regs_mask & (1<<5)) check_node(regs[REG_EBP]); + if (node_regs_mask & (1<<6)) check_node(regs[REG_ESI]); + if (node_regs_mask & (1<<7)) check_node(regs[REG_EDI]); +} +#else +void +check_xp(ExceptionInformation *xp) +{ + natural *regs = (natural *) xpGPRvector(xp), dnode; + + check_node(regs[Iarg_z]); + check_node(regs[Iarg_y]); + check_node(regs[Iarg_x]); + check_node(regs[Isave3]); + check_node(regs[Isave2]); + check_node(regs[Isave1]); + check_node(regs[Isave0]); + check_node(regs[Ifn]); + check_node(regs[Itemp0]); + check_node(regs[Itemp1]); + check_node(regs[Itemp2]); +} +#endif + +void +check_tcrs(TCR *first) +{ + xframe_list *xframes; + ExceptionInformation *xp; + + TCR *tcr = first; + LispObj *tlb_start,*tlb_end; + + do { + xp = tcr->gc_context; + if (xp) { +#ifdef X8632 + check_xp(xp,tcr->node_regs_mask); +#else + check_xp(xp); +#endif + } +#ifdef X8632 + check_node(tcr->save0); + check_node(tcr->save1); + check_node(tcr->save2); + check_node(tcr->save3); + check_node(tcr->next_method_context); +#endif + for (xframes = (xframe_list *) tcr->xframe; + xframes; + xframes = xframes->prev) { +#ifndef X8632 + check_xp(xframes->curr); +#else + check_xp(xframes->curr, xframes->node_regs_mask); +#endif + } + tlb_start = tcr->tlb_pointer; + if (tlb_start) { + tlb_end = tlb_start + ((tcr->tlb_limit)>>fixnumshift); + check_range(tlb_start,tlb_end,false); + } + tcr = tcr->next; + } while (tcr != first); +} + + +void +check_all_areas(TCR *tcr) +{ + area *a = active_dynamic_area; + area_code code = a->code; + + while (code != AREA_VOID) { + switch (code) { + case AREA_DYNAMIC: + case AREA_WATCHED: + case AREA_STATIC: + case AREA_MANAGED_STATIC: + check_range((LispObj *)a->low, (LispObj *)a->active, true); + break; + + case AREA_VSTACK: + { + LispObj* low = (LispObj *)a->active; + LispObj* high = (LispObj *)a->high; + + if (((natural)low) & node_size) { + check_node(*low++); + } + check_range(low, high, false); + } + break; + + case AREA_TSTACK: + { + LispObj *current, *next, + *start = (LispObj *) a->active, + *end = start, + *limit = (LispObj *) a->high; + + for (current = start; + end != limit; + current = next) { + next = ptr_from_lispobj(*current); + end = ((next >= start) && (next < limit)) ? next : limit; + check_range(current+2, end, true); + } + } + break; + } + a = a->succ; + code = (a->code); + } + + check_tcrs(tcr); +} + + + + + + + + +/* Sooner or later, this probably wants to be in assembler */ +/* Return false if n is definitely not an ephemeral node, true if + it might be */ +void +mark_root(LispObj n) +{ + int tag_n = fulltag_of(n); + natural dnode, bits, *bitsp, mask; + + if (!is_node_fulltag(tag_n)) { + return; + } + + dnode = gc_area_dnode(n); + if (dnode >= GCndnodes_in_area) { + return; + } + +#ifdef X8632 + if (tag_n == fulltag_tra) { + if (*(unsigned char *)n == RECOVER_FN_OPCODE) { + n = *(LispObj *)(n + 1); + tag_n = fulltag_misc; + dnode = gc_area_dnode(n); + } else + return; + } +#endif +#ifdef X8664 + if (tag_of(n) == tag_tra) { + if ((*((unsigned short *)n) == RECOVER_FN_FROM_RIP_WORD0) && + (*((unsigned char *)(n+2)) == RECOVER_FN_FROM_RIP_BYTE2)) { + int sdisp = (*(int *) (n+3)); + n = RECOVER_FN_FROM_RIP_LENGTH+n+sdisp; + tag_n = fulltag_function; + dnode = gc_area_dnode(n); + } + else { + return; + } + } +#endif + + set_bits_vars(GCmarkbits,dnode,bitsp,bits,mask); + if (bits & mask) { + return; + } + *bitsp = (bits | mask); + + if (tag_n == fulltag_cons) { + cons *c = (cons *) ptr_from_lispobj(untag(n)); + + rmark(c->car); + rmark(c->cdr); + return; + } + { + LispObj *base = (LispObj *) ptr_from_lispobj(untag(n)); + natural + header = *((natural *) base), + subtag = header_subtag(header), + element_count = header_element_count(header), + total_size_in_bytes, /* including 4/8-byte header */ + suffix_dnodes; + natural prefix_nodes = 0; + + tag_n = fulltag_of(header); + +#ifdef X8664 + if ((nodeheader_tag_p(tag_n)) || + (tag_n == ivector_class_64_bit)) { + total_size_in_bytes = 8 + (element_count<<3); + } else if (tag_n == ivector_class_32_bit) { + total_size_in_bytes = 8 + (element_count<<2); + } else { + /* ivector_class_other_bit contains 8, 16-bit arrays & bitvector */ + if (subtag == subtag_bit_vector) { + total_size_in_bytes = 8 + ((element_count+7)>>3); + } else if (subtag >= min_8_bit_ivector_subtag) { + total_size_in_bytes = 8 + element_count; + } else { + total_size_in_bytes = 8 + (element_count<<1); + } + } +#endif +#ifdef X8632 + if ((tag_n == fulltag_nodeheader) || + (subtag <= max_32_bit_ivector_subtag)) { + total_size_in_bytes = 4 + (element_count<<2); + } else if (subtag <= max_8_bit_ivector_subtag) { + total_size_in_bytes = 4 + element_count; + } else if (subtag <= max_16_bit_ivector_subtag) { + total_size_in_bytes = 4 + (element_count<<1); + } else if (subtag == subtag_double_float_vector) { + total_size_in_bytes = 8 + (element_count<<3); + } else { + total_size_in_bytes = 4 + ((element_count+7)>>3); + } +#endif + + + suffix_dnodes = ((total_size_in_bytes+(dnode_size-1))>>dnode_shift) -1; + + if (suffix_dnodes) { + set_n_bits(GCmarkbits, dnode+1, suffix_dnodes); + } + + if (nodeheader_tag_p(tag_n)) { + if (subtag == subtag_hash_vector) { + /* Don't invalidate the cache here. It should get + invalidated on the lisp side, if/when we know + that rehashing is necessary. */ + LispObj flags = ((hash_table_vector_header *) base)->flags; + + if ((flags & nhash_keys_frozen_mask) && + (((hash_table_vector_header *) base)->deleted_count > 0)) { + /* We're responsible for clearing out any deleted keys, since + lisp side can't do it without breaking the state machine + */ + LispObj *pairp = base + hash_table_vector_header_count; + natural + npairs = (element_count - (hash_table_vector_header_count - 1)) >> 1; + + while (npairs--) { + if ((pairp[1] == unbound) && (pairp[0] != unbound)) { + pairp[0] = slot_unbound; + } + pairp +=2; + } + ((hash_table_vector_header *) base)->deleted_count = 0; + } + + if (flags & nhash_weak_mask) { + ((hash_table_vector_header *) base)->cache_key = undefined; + ((hash_table_vector_header *) base)->cache_value = lisp_nil; + mark_weak_htabv(n); + return; + } + } + + if (subtag == subtag_pool) { + deref(base, 1) = lisp_nil; + } + + if (subtag == subtag_weak) { + natural weak_type = (natural) base[2]; + if (weak_type >> population_termination_bit) { + element_count -= 2; + } else { + element_count -= 1; + } + } + + if (subtag == subtag_function) { +#ifdef X8632 + prefix_nodes = (natural) ((unsigned short) deref(base,1)); + + /* XXX bootstrapping */ + if (prefix_nodes & 0x8000) + prefix_nodes = element_count - (prefix_nodes & 0x7fff); +#else + prefix_nodes = (natural) ((int) deref(base,1)); +#endif + if (prefix_nodes > element_count) { + Bug(NULL, "Function 0x" LISP " trashed",n); + } + } + base += (1+element_count); + + element_count -= prefix_nodes; + + while(element_count--) { + rmark(*--base); + } + if (subtag == subtag_weak) { + deref(ptr_to_lispobj(base),1) = GCweakvll; + GCweakvll = n; + } + } + } +} + + +/* + This marks the node if it needs to; it returns true if the node + is either a hash table vector header or a cons/misc-tagged pointer + to ephemeral space. + Note that it might be a pointer to ephemeral space even if it's + not pointing to the current generation. +*/ + +Boolean +mark_ephemeral_root(LispObj n) +{ + int tag_n = fulltag_of(n); + natural eph_dnode; + + if (nodeheader_tag_p(tag_n)) { + return (header_subtag(n) == subtag_hash_vector); + } + + if (is_node_fulltag (tag_n)) { + eph_dnode = area_dnode(n, GCephemeral_low); + if (eph_dnode < GCn_ephemeral_dnodes) { + mark_root(n); /* May or may not mark it */ + return true; /* but return true 'cause it's an ephemeral node */ + } + } + return false; /* Not a heap pointer or not ephemeral */ +} + + + +#ifdef X8664 +#define RMARK_PREV_ROOT fulltag_imm_1 /* fulltag of 'undefined' value */ +#define RMARK_PREV_CAR fulltag_nil /* fulltag_cons + node_size. Coincidence ? I think not. */ +#else +#define RMARK_PREV_ROOT fulltag_imm /* fulltag of 'undefined' value */ +#define RMARK_PREV_CAR fulltag_odd_fixnum +#endif + + +/* + This wants to be in assembler even more than "mark_root" does. + For now, it does link-inversion: hard as that is to express in C, + reliable stack-overflow detection may be even harder ... +*/ +void +rmark(LispObj n) +{ + int tag_n = fulltag_of(n); + bitvector markbits = GCmarkbits; + natural dnode, bits, *bitsp, mask; + + if (!is_node_fulltag(tag_n)) { + return; + } + + dnode = gc_area_dnode(n); + if (dnode >= GCndnodes_in_area) { + return; + } + +#ifdef X8632 + if (tag_n == fulltag_tra) { + if (*(unsigned char *)n == RECOVER_FN_OPCODE) { + n = *(LispObj *)(n + 1); + tag_n = fulltag_misc; + dnode = gc_area_dnode(n); + } else { + return; + } + } +#endif +#ifdef X8664 + if (tag_of(n) == tag_tra) { + if ((*((unsigned short *)n) == RECOVER_FN_FROM_RIP_WORD0) && + (*((unsigned char *)(n+2)) == RECOVER_FN_FROM_RIP_BYTE2)) { + int sdisp = (*(int *) (n+3)); + n = RECOVER_FN_FROM_RIP_LENGTH+n+sdisp; + tag_n = fulltag_function; + dnode = gc_area_dnode(n); + } else { + return; + } + } +#endif + + set_bits_vars(markbits,dnode,bitsp,bits,mask); + if (bits & mask) { + return; + } + *bitsp = (bits | mask); + + if (current_stack_pointer() > GCstack_limit) { + if (tag_n == fulltag_cons) { + rmark(deref(n,1)); + rmark(deref(n,0)); + } else { + LispObj *base = (LispObj *) ptr_from_lispobj(untag(n)); + natural + header = *((natural *) base), + subtag = header_subtag(header), + element_count = header_element_count(header), + total_size_in_bytes, + suffix_dnodes, + nmark; + + tag_n = fulltag_of(header); + +#ifdef X8664 + if ((nodeheader_tag_p(tag_n)) || + (tag_n == ivector_class_64_bit)) { + total_size_in_bytes = 8 + (element_count<<3); + } else if (tag_n == ivector_class_32_bit) { + total_size_in_bytes = 8 + (element_count<<2); + } else { + /* ivector_class_other_bit contains 16-bit arrays & bitvector */ + if (subtag == subtag_bit_vector) { + total_size_in_bytes = 8 + ((element_count+7)>>3); + } else if (subtag >= min_8_bit_ivector_subtag) { + total_size_in_bytes = 8 + element_count; + } else { + total_size_in_bytes = 8 + (element_count<<1); + } + } +#else + if ((tag_n == fulltag_nodeheader) || + (subtag <= max_32_bit_ivector_subtag)) { + total_size_in_bytes = 4 + (element_count<<2); + } else if (subtag <= max_8_bit_ivector_subtag) { + total_size_in_bytes = 4 + element_count; + } else if (subtag <= max_16_bit_ivector_subtag) { + total_size_in_bytes = 4 + (element_count<<1); + } else if (subtag == subtag_double_float_vector) { + total_size_in_bytes = 8 + (element_count<<3); + } else { + total_size_in_bytes = 4 + ((element_count+7)>>3); + } +#endif + + suffix_dnodes = ((total_size_in_bytes+(dnode_size-1))>>dnode_shift)-1; + + if (suffix_dnodes) { + set_n_bits(GCmarkbits, dnode+1, suffix_dnodes); + } + + if (!nodeheader_tag_p(tag_n)) return; + + if (subtag == subtag_hash_vector) { + /* Splice onto weakvll, then return */ + /* In general, there's no reason to invalidate the cached + key/value pair here. However, if the hash table's weak, + we don't want to retain an otherwise unreferenced key + or value simply because they're referenced from the + cache. Clear the cached entries iff the hash table's + weak in some sense. + */ + LispObj flags = ((hash_table_vector_header *) base)->flags; + + if (flags & nhash_weak_mask) { + ((hash_table_vector_header *) base)->cache_key = undefined; + ((hash_table_vector_header *) base)->cache_value = lisp_nil; + mark_weak_htabv(n); + return; + } + } + + if (subtag == subtag_pool) { + deref(n, 1) = lisp_nil; + } + + if (subtag == subtag_weak) { + natural weak_type = (natural) base[2]; + if (weak_type >> population_termination_bit) + element_count -= 2; + else + element_count -= 1; + } + + nmark = element_count; + + if (subtag == subtag_function) { +#ifdef X8664 + int code_words = (int)base[1]; +#else + int code_words = (unsigned short)base[1]; + + /* XXX bootstrapping */ + if (code_words & 0x8000) + code_words = element_count - (code_words & 0x7fff); +#endif + if (code_words >= nmark) { + Bug(NULL,"Bad function at 0x" LISP,n); + } + nmark -= code_words; + } + + while (nmark--) { + rmark(deref(n,element_count)); + element_count--; + } + + if (subtag == subtag_weak) { + deref(n, 1) = GCweakvll; + GCweakvll = n; + } + + } + } else { + /* This is all a bit more complicated than the PPC version: + + - a symbol-vector can be referenced via either a FULLTAG-MISC + pointer or a FULLTAG-SYMBOL pointer. When we've finished + marking the symbol-vector's elements, we need to know which tag + the object that pointed to the symbol-vector had originally. + + - a function-vector can be referenced via either a FULLTAG-MISC + pointer or a FULLTAG-FUNCTION pointer. That introduces pretty + much the same set of issues, but ... + + - a function-vector can also be referenced via a TRA; the + offset from the TRA to the function header is arbitrary (though + we can probably put an upper bound on it, and it's certainly + not going to be more than 32 bits.) + + - function-vectors contain a mixture of code and constants, + with a "boundary" word (that doesn't look like a valid + constant) in between them. There are 56 unused bits in the + boundary word; the low 8 bits must be = to the constant + 'function_boundary_marker'. We can store the byte displacement + from the address of the object which references the function + (tagged fulltag_misc, fulltag_function, or tra) to the address + of the boundary marker when the function vector is first marked + and recover that offset when we've finished marking the + function vector. (Note that the offset is signed; it's + probably simplest to keep it in the high 32 bits of the + boundary word.) + + So: + + - while marking a CONS, the 'this' pointer as a 3-bit tag of + tag_list; the 4-bit fulltag indicates which cell is being + marked. + + - while marking a gvector (other than a symbol-vector or + function-vector), the 'this' pointer is tagged tag_misc. + (Obviously, it alternates between fulltag_misc and + fulltag_nodeheader_0, arbitrarily.) When we encounter the + gvector header when the 'this' pointer has been tagged as + fulltag_misc, we can restore 'this' to the header's address + + fulltag_misc and enter the 'climb' state. (Note that this + value happens to be exactly what's in 'this' when the header's + encountered.) + + - if we encounter a symbol-vector via the FULLTAG-MISC pointer + to the symbol (not very likely, but legal and possible), it's + treated exactly like the gvector case above. + + - in the more likely case where a symbol-vector is referenced + via a FULLTAG-SYMBOL, we do the same loop as in the general + gvector case, backing up through the vector with 'this' tagged + as 'tag_symbol' (or fulltag_nodeheader_1); when we encounter + the symbol header, 'this' gets fulltag_symbol added to the + dnode-aligned address of the header, and we climb. + + - if anything (fulltag_misc, fulltag_function, tra) references + an unmarked function function vector, we store the byte offfset + from the tagged reference to the address of the boundary word + in the high 32 bits of the boundary word, then we back up + through the function-vector's constants, with 'this' tagged + tag_function/ fulltag_immheader_0, until the (specially-tagged) + boundary word is encountered. The displacement stored in the boundary + word is added to the aligned address of the boundary word (restoring + the original 'this' pointer, and we climb. + + Not that bad. + */ + + LispObj prev = undefined, this = n, next, *base; + natural header, subtag, element_count, total_size_in_bytes, suffix_dnodes, *boundary; + + if (tag_n == fulltag_cons) goto MarkCons; + goto MarkVector; + + ClimbCdr: + prev = deref(this,0); + deref(this,0) = next; + + Climb: + next = this; + this = prev; + tag_n = fulltag_of(prev); + switch(tag_n) { + case tag_misc: + case fulltag_misc: +#ifdef X8664 + case tag_symbol: + case fulltag_symbol: + case tag_function: + case fulltag_function: +#endif + goto ClimbVector; + + case RMARK_PREV_ROOT: + return; + + case fulltag_cons: + goto ClimbCdr; + + case RMARK_PREV_CAR: + goto ClimbCar; + + default: abort(); + } + + DescendCons: + prev = this; + this = next; + + MarkCons: + next = deref(this,1); +#ifdef X8632 + this += (RMARK_PREV_CAR-fulltag_cons); +#else + this += node_size; +#endif + tag_n = fulltag_of(next); + if (!is_node_fulltag(tag_n)) goto MarkCdr; + dnode = gc_area_dnode(next); + if (dnode >= GCndnodes_in_area) goto MarkCdr; + set_bits_vars(markbits,dnode,bitsp,bits,mask); + if (bits & mask) goto MarkCdr; + *bitsp = (bits | mask); + deref(this,1) = prev; + if (tag_n == fulltag_cons) goto DescendCons; + goto DescendVector; + + ClimbCar: + prev = deref(this,1); + deref(this,1) = next; + + MarkCdr: + next = deref(this, 0); +#ifdef X8632 + this -= (RMARK_PREV_CAR-fulltag_cons); +#else + this -= node_size; +#endif + tag_n = fulltag_of(next); + if (!is_node_fulltag(tag_n)) goto Climb; + dnode = gc_area_dnode(next); + if (dnode >= GCndnodes_in_area) goto Climb; + set_bits_vars(markbits,dnode,bitsp,bits,mask); + if (bits & mask) goto Climb; + *bitsp = (bits | mask); + deref(this, 0) = prev; + if (tag_n == fulltag_cons) goto DescendCons; + /* goto DescendVector; */ + + DescendVector: + prev = this; + this = next; + + MarkVector: +#ifdef X8664 + if ((tag_n == fulltag_tra_0) || + (tag_n == fulltag_tra_1)) { + int disp = (*(int *) (n+3)) + RECOVER_FN_FROM_RIP_LENGTH; + + base = (LispObj *) (untag(n-disp)); + header = *((natural *) base); + subtag = header_subtag(header); + boundary = base + (int)(base[1]); + (((int *)boundary)[1]) = (int)(this-((LispObj)boundary)); + this = (LispObj)(base)+fulltag_function; + /* Need to set the initial markbit here */ + dnode = gc_area_dnode(this); + set_bit(markbits,dnode); + } else { + base = (LispObj *) ptr_from_lispobj(untag(this)); + header = *((natural *) base); + subtag = header_subtag(header); + if (subtag == subtag_function) { + boundary = base + (int)(base[1]); + (((int *)boundary)[1]) = (int)(this-((LispObj)boundary)); + } + } + element_count = header_element_count(header); + tag_n = fulltag_of(header); + + if ((nodeheader_tag_p(tag_n)) || + (tag_n == ivector_class_64_bit)) { + total_size_in_bytes = 8 + (element_count<<3); + } else if (tag_n == ivector_class_32_bit) { + total_size_in_bytes = 8 + (element_count<<2); + } else { + /* ivector_class_other_bit contains 16-bit arrays & bitvector */ + if (subtag == subtag_bit_vector) { + total_size_in_bytes = 8 + ((element_count+7)>>3); + } else if (subtag >= min_8_bit_ivector_subtag) { + total_size_in_bytes = 8 + element_count; + } else { + total_size_in_bytes = 8 + (element_count<<1); + } + } +#else + if (tag_n == fulltag_tra) { + LispObj fn = *(LispObj *)(n + 1); + + base = (LispObj *)untag(fn); + header = *(natural *)base; + subtag = header_subtag(header); + boundary = base + imm_word_count(fn); + + /* + * On x8632, the upper 24 bits of the boundary word are zero. + * Functions on x8632 can be no more than 2^16 words (or 2^24 + * bytes) long (including the self-reference table but excluding + * any constants). Therefore, we can do the same basic thing + * that the x8664 port does: namely, we keep the byte + * displacement from the address of the object (tagged tra or + * fulltag_misc) that references the function to the address of + * the boundary marker in those 24 bits, recovering it when + * we've finished marking the function vector. + */ + *((int *)boundary) &= 0xff; + *((int *)boundary) |= ((this-(LispObj)boundary) << 8); + this = (LispObj)(base)+fulltag_misc; + dnode = gc_area_dnode(this); + set_bit(markbits,dnode); + } else { + base = (LispObj *) ptr_from_lispobj(untag(this)); + header = *((natural *) base); + subtag = header_subtag(header); + if (subtag == subtag_function) { + boundary = base + imm_word_count(this); + + *((int *)boundary) &= 0xff; + *((int *)boundary) |= ((this-((LispObj)boundary)) << 8); + } + } + element_count = header_element_count(header); + tag_n = fulltag_of(header); + + if ((tag_n == fulltag_nodeheader) || + (subtag <= max_32_bit_ivector_subtag)) { + total_size_in_bytes = 4 + (element_count<<2); + } else if (subtag <= max_8_bit_ivector_subtag) { + total_size_in_bytes = 4 + element_count; + } else if (subtag <= max_16_bit_ivector_subtag) { + total_size_in_bytes = 4 + (element_count<<1); + } else if (subtag == subtag_double_float_vector) { + total_size_in_bytes = 8 + (element_count<<3); + } else { + total_size_in_bytes = 4 + ((element_count+7)>>3); + } +#endif + + suffix_dnodes = ((total_size_in_bytes+(dnode_size-1))>>dnode_shift)-1; + + if (suffix_dnodes) { + set_n_bits(GCmarkbits, dnode+1, suffix_dnodes); + } + + if (!nodeheader_tag_p(tag_n)) goto Climb; + + if (subtag == subtag_hash_vector) { + /* Splice onto weakvll, then climb */ + LispObj flags = ((hash_table_vector_header *) base)->flags; + + if (flags & nhash_weak_mask) { + ((hash_table_vector_header *) base)->cache_key = undefined; + ((hash_table_vector_header *) base)->cache_value = lisp_nil; + dws_mark_weak_htabv(this); + element_count = hash_table_vector_header_count; + } + } + + if (subtag == subtag_pool) { + deref(this, 1) = lisp_nil; + } + + if (subtag == subtag_weak) { + natural weak_type = (natural) base[2]; + if (weak_type >> population_termination_bit) + element_count -= 2; + else + element_count -= 1; + } + + this = (LispObj)(base) + (tag_of(this)) + ((element_count+1) << node_shift); + goto MarkVectorLoop; + + ClimbVector: + prev = indirect_node(this); + indirect_node(this) = next; + + MarkVectorLoop: + this -= node_size; + next = indirect_node(this); +#ifdef X8664 + if ((tag_of(this) == tag_function) && + (header_subtag(next) == function_boundary_marker)) goto MarkFunctionDone; +#else + if ((tag_of(this) == tag_misc) && + (header_subtag(next) == function_boundary_marker)) goto MarkFunctionDone; +#endif + + tag_n = fulltag_of(next); + if (nodeheader_tag_p(tag_n)) goto MarkVectorDone; + if (!is_node_fulltag(tag_n)) goto MarkVectorLoop; + dnode = gc_area_dnode(next); + if (dnode >= GCndnodes_in_area) goto MarkVectorLoop; + set_bits_vars(markbits,dnode,bitsp,bits,mask); + if (bits & mask) goto MarkVectorLoop; + *bitsp = (bits | mask); + indirect_node(this) = prev; + if (tag_n == fulltag_cons) goto DescendCons; + goto DescendVector; + + MarkVectorDone: + /* "next" is vector header; "this" tagged tag_misc or tag_symbol. + If header subtag = subtag_weak_header, put it on weakvll */ + this += node_size; /* make it fulltag_misc/fulltag_symbol */ + + if (header_subtag(next) == subtag_weak) { + deref(this, 1) = GCweakvll; + GCweakvll = this; + } + goto Climb; + + MarkFunctionDone: + boundary = (LispObj *)(node_aligned(this)); +#ifdef X8664 + this = ((LispObj)boundary) + (((int *)boundary)[1]); + (((int *)boundary)[1]) = 0; +#else + this = ((LispObj)boundary) + ((*((int *)boundary)) >> 8); + ((int *)boundary)[0] &= 0xff; +#endif + goto Climb; + } +} + +LispObj * +skip_over_ivector(natural start, LispObj header) +{ + natural + element_count = header_element_count(header), + subtag = header_subtag(header), + nbytes; + + +#ifdef X8664 + switch (fulltag_of(header)) { + case ivector_class_64_bit: + nbytes = element_count << 3; + break; + case ivector_class_32_bit: + nbytes = element_count << 2; + break; + case ivector_class_other_bit: + default: + if (subtag == subtag_bit_vector) { + nbytes = (element_count+7)>>3; + } else if (subtag >= min_8_bit_ivector_subtag) { + nbytes = element_count; + } else { + nbytes = element_count << 1; + } + } + return ptr_from_lispobj(start+(~15 & (nbytes + 8 + 15))); +#else + if (subtag <= max_32_bit_ivector_subtag) { + nbytes = element_count << 2; + } else if (subtag <= max_8_bit_ivector_subtag) { + nbytes = element_count; + } else if (subtag <= max_16_bit_ivector_subtag) { + nbytes = element_count << 1; + } else if (subtag == subtag_double_float_vector) { + nbytes = 4 + (element_count << 3); + } else { + nbytes = (element_count+7) >> 3; + } + return ptr_from_lispobj(start+(~7 & (nbytes + 4 + 7))); +#endif +} + + +void +check_refmap_consistency(LispObj *start, LispObj *end, bitvector refbits) +{ + LispObj x1, *base = start, *prev = start; + int tag; + natural ref_dnode, node_dnode; + Boolean intergen_ref; + + while (start < end) { + x1 = *start; + prev = start; + tag = fulltag_of(x1); + if (immheader_tag_p(tag)) { + start = skip_over_ivector(ptr_to_lispobj(start), x1); + } else { + if (header_subtag(x1) == subtag_function) { +#ifdef X8632 + int skip = (unsigned short)deref(start,1); + /* XXX bootstrapping */ + if (skip & 0x8000) + skip = header_element_count(x1) - (skip & 0x7fff); +#else + int skip = (int) deref(start,1); +#endif + start += ((1+skip)&~1); + x1 = *start; + tag = fulltag_of(x1); + } + intergen_ref = false; + if (is_node_fulltag(tag)) { + node_dnode = gc_area_dnode(x1); + if (node_dnode < GCndnodes_in_area) { + intergen_ref = true; + } + } + if (intergen_ref == false) { + x1 = start[1]; + tag = fulltag_of(x1); + if (is_node_fulltag(tag)) { + node_dnode = gc_area_dnode(x1); + if (node_dnode < GCndnodes_in_area) { + intergen_ref = true; + } + } + } + if (intergen_ref) { + ref_dnode = area_dnode(start, base); + if (!ref_bit(refbits, ref_dnode)) { + Bug(NULL, "Missing memoization in doublenode at 0x" LISP, start); + set_bit(refbits, ref_dnode); + } + } + start += 2; + } + } + if (start > end) { + Bug(NULL, "Overran end of range!"); + } +} + + + +void +mark_memoized_area(area *a, natural num_memo_dnodes) +{ + bitvector refbits = a->refbits; + LispObj *p = (LispObj *) a->low, x1, x2; + natural inbits, outbits, bits, bitidx, *bitsp, nextbit, diff, memo_dnode = 0; + Boolean keep_x1, keep_x2; + + if (GCDebug) { + check_refmap_consistency(p, p+(num_memo_dnodes << 1), refbits); + } + + /* The distinction between "inbits" and "outbits" is supposed to help us + detect cases where "uninteresting" setfs have been memoized. Storing + NIL, fixnums, immediates (characters, etc.) or node pointers to static + or readonly areas is definitely uninteresting, but other cases are + more complicated (and some of these cases are hard to detect.) + + Some headers are "interesting", to the forwarder if not to us. + + We -don't- give anything any weak treatment here. Weak things have + to be seen by a full gc, for some value of 'full'. + */ + + /* + We need to ensure that there are no bits set at or beyond + "num_memo_dnodes" in the bitvector. (This can happen as the EGC + tenures/untenures things.) We find bits by grabbing a fullword at + a time and doing a cntlzw instruction; and don't want to have to + check for (< memo_dnode num_memo_dnodes) in the loop. + */ + + { + natural + bits_in_last_word = (num_memo_dnodes & bitmap_shift_count_mask), + index_of_last_word = (num_memo_dnodes >> bitmap_shift); + + if (bits_in_last_word != 0) { + natural mask = ~((NATURAL1<<(nbits_in_word-bits_in_last_word))- NATURAL1); + refbits[index_of_last_word] &= mask; + } + } + + set_bitidx_vars(refbits, 0, bitsp, bits, bitidx); + inbits = outbits = bits; + while (memo_dnode < num_memo_dnodes) { + if (bits == 0) { + int remain = nbits_in_word - bitidx; + memo_dnode += remain; + p += (remain+remain); + if (outbits != inbits) { + *bitsp = outbits; + } + bits = *++bitsp; + inbits = outbits = bits; + bitidx = 0; + } else { + nextbit = count_leading_zeros(bits); + if ((diff = (nextbit - bitidx)) != 0) { + memo_dnode += diff; + bitidx = nextbit; + p += (diff+diff); + } + x1 = *p++; + x2 = *p++; + bits &= ~(BIT0_MASK >> bitidx); + keep_x1 = mark_ephemeral_root(x1); + keep_x2 = mark_ephemeral_root(x2); + if ((keep_x1 == false) && + (keep_x2 == false)) { + outbits &= ~(BIT0_MASK >> bitidx); + } + memo_dnode++; + bitidx++; + } + } + if (GCDebug) { + p = (LispObj *) a->low; + check_refmap_consistency(p, p+(num_memo_dnodes << 1), refbits); + } +} + +void +mark_headerless_area_range(LispObj *start, LispObj *end) +{ + while (start < end) { + mark_root(*start++); + } +} + +void +mark_simple_area_range(LispObj *start, LispObj *end) +{ + LispObj x1, *base; + int tag; + + while (start < end) { + x1 = *start; + tag = fulltag_of(x1); + if (immheader_tag_p(tag)) { + start = (LispObj *)ptr_from_lispobj(skip_over_ivector(ptr_to_lispobj(start), x1)); + } else if (!nodeheader_tag_p(tag)) { + ++start; + mark_root(x1); + mark_root(*start++); + } else { + int subtag = header_subtag(x1); + natural element_count = header_element_count(x1); + natural size = (element_count+1 + 1) & ~1; + + if (subtag == subtag_hash_vector) { + LispObj flags = ((hash_table_vector_header *) start)->flags; + + if (flags & nhash_weak_mask) { + ((hash_table_vector_header *) start)->cache_key = undefined; + ((hash_table_vector_header *) start)->cache_value = lisp_nil; + mark_weak_htabv((LispObj)start); + element_count = 0; + } + } + if (subtag == subtag_pool) { + start[1] = lisp_nil; + } + + if (subtag == subtag_weak) { + natural weak_type = (natural) start[2]; + if (weak_type >> population_termination_bit) + element_count -= 2; + else + element_count -= 1; + start[1] = GCweakvll; + GCweakvll = (LispObj) (((natural) start) + fulltag_misc); + } + + base = start + element_count + 1; + if (subtag == subtag_function) { +#ifdef X8632 + natural skip = (unsigned short)start[1]; + + /* XXX bootstrapping */ + if (skip & 0x8000) + skip = element_count - (skip & 0x7fff); + + element_count -= skip; + +#else + element_count -= (int)start[1]; +#endif + } + while(element_count--) { + mark_root(*--base); + } + start += size; + } + } +} + + +/* Mark a tstack area */ +void +mark_tstack_area(area *a) +{ + LispObj + *current, + *next, + *start = (LispObj *) (a->active), + *end = start, + *limit = (LispObj *) (a->high); + + for (current = start; + end != limit; + current = next) { + next = (LispObj *) ptr_from_lispobj(*current); + end = ((next >= start) && (next < limit)) ? next : limit; + mark_simple_area_range(current+2, end); + } +} + +/* + It's really important that headers never wind up in tagged registers. + Those registers would (possibly) get pushed on the vstack and confuse + the hell out of this routine. + + vstacks are just treated as a "simple area range", possibly with + an extra word at the top (where the area's active pointer points.) + */ + +void +mark_vstack_area(area *a) +{ + LispObj + *start = (LispObj *) a->active, + *end = (LispObj *) a->high; + +#if 0 + fprintf(dbgout, "mark VSP range: 0x" LISP ":0x" LISP "\n", start, end); +#endif + mark_headerless_area_range(start, end); +} + +/* No lisp objects on cstack on x86, at least x86-64 */ +void +mark_cstack_area(area *a) +{ +} + + +/* Mark the lisp objects in an exception frame */ +#ifdef X8664 +void +mark_xp(ExceptionInformation *xp) +{ + natural *regs = (natural *) xpGPRvector(xp), dnode; + LispObj rip; + + + + mark_root(regs[Iarg_z]); + mark_root(regs[Iarg_y]); + mark_root(regs[Iarg_x]); + mark_root(regs[Isave3]); + mark_root(regs[Isave2]); + mark_root(regs[Isave1]); + mark_root(regs[Isave0]); + mark_root(regs[Ifn]); + mark_root(regs[Itemp0]); + mark_root(regs[Itemp1]); + mark_root(regs[Itemp2]); + /* If the RIP isn't pointing into a marked function, + we can -maybe- recover from that if it's tagged as + a TRA. */ + rip = regs[Iip]; + dnode = gc_area_dnode(rip); + if ((dnode < GCndnodes_in_area) && + (! ref_bit(GCmarkbits,dnode))) { + if (tag_of(rip) == tag_tra) { + mark_root(rip); + } else if ((fulltag_of(rip) == fulltag_function) && + (*((unsigned short *)rip) == RECOVER_FN_FROM_RIP_WORD0) && + (*((unsigned char *)(rip+2)) == RECOVER_FN_FROM_RIP_BYTE2) && + ((*(int *) (rip+3))) == -RECOVER_FN_FROM_RIP_LENGTH) { + mark_root(rip); + } else { + Bug(NULL, "Can't find function for rip 0x%16lx",rip); + } + } +} +#else +void +mark_xp(ExceptionInformation *xp, natural node_regs_mask) +{ + natural *regs = (natural *) xpGPRvector(xp), dnode; + LispObj eip; + int i; + + if (node_regs_mask & (1<<0)) mark_root(regs[REG_EAX]); + if (node_regs_mask & (1<<1)) mark_root(regs[REG_ECX]); + if (regs[REG_EFL] & EFL_DF) { + /* DF set means EDX should be treated as an imm reg */ + ; + } else + if (node_regs_mask & (1<<2)) mark_root(regs[REG_EDX]); + + if (node_regs_mask & (1<<3)) mark_root(regs[REG_EBX]); + if (node_regs_mask & (1<<4)) mark_root(regs[REG_ESP]); + if (node_regs_mask & (1<<5)) mark_root(regs[REG_EBP]); + if (node_regs_mask & (1<<6)) mark_root(regs[REG_ESI]); + if (node_regs_mask & (1<<7)) mark_root(regs[REG_EDI]); + + /* If the EIP isn't pointing into a marked function, we're probably + in trouble. We can -maybe- recover from that if it's tagged as a + TRA. */ + eip = regs[Ieip]; + dnode = gc_area_dnode(eip); + if ((dnode < GCndnodes_in_area) && + (! ref_bit(GCmarkbits,dnode))) { + if (fulltag_of(eip) == fulltag_tra) { + mark_root(eip); + } else if ((fulltag_of(eip) == fulltag_misc) && + (header_subtag(header_of(eip)) == subtag_function) && + (*(unsigned char *)eip == RECOVER_FN_OPCODE) && + (*(LispObj *)(eip + 1)) == eip) { + mark_root(eip); + } else { + Bug(NULL, "Can't find function for eip 0x%4x", eip); + } + } +} +#endif + +/* A "pagelet" contains 32 doublewords. The relocation table contains + a word for each pagelet which defines the lowest address to which + dnodes on that pagelet will be relocated. + + The relocation address of a given pagelet is the sum of the relocation + address for the preceding pagelet and the number of bytes occupied by + marked objects on the preceding pagelet. +*/ + +LispObj +calculate_relocation() +{ + LispObj *relocptr = GCrelocptr; + LispObj current = GCareadynamiclow; + bitvector + markbits = GCdynamic_markbits; + qnode *q = (qnode *) markbits; + natural npagelets = ((GCndynamic_dnodes_in_area+(nbits_in_word-1))>>bitmap_shift); + natural thesebits; + LispObj first = 0; + + if (npagelets) { + do { + *relocptr++ = current; + thesebits = *markbits++; + if (thesebits == ALL_ONES) { + current += nbits_in_word*dnode_size; + q += 4; /* sic */ + } else { + if (!first) { + first = current; + while (thesebits & BIT0_MASK) { + first += dnode_size; + thesebits += thesebits; + } + } + /* We're counting bits in qnodes in the wrong order here, but + that's OK. I think ... */ + current += one_bits(*q++); + current += one_bits(*q++); + current += one_bits(*q++); + current += one_bits(*q++); + } + } while(--npagelets); + } + *relocptr++ = current; + return first ? first : current; +} + + +#if 0 +LispObj +dnode_forwarding_address(natural dnode, int tag_n) +{ + natural pagelet, nbits; + unsigned int near_bits; + LispObj new; + + if (GCDebug) { + if (! ref_bit(GCdynamic_markbits, dnode)) { + Bug(NULL, "unmarked object being forwarded!\n"); + } + } + + pagelet = dnode >> bitmap_shift; + nbits = dnode & bitmap_shift_count_mask; + near_bits = ((unsigned int *)GCdynamic_markbits)[dnode>>(dnode_shift+1)]; + + if (nbits < 32) { + new = GCrelocptr[pagelet] + tag_n;; + /* Increment "new" by the count of 1 bits which precede the dnode */ + if (near_bits == 0xffffffff) { + return (new + (nbits << 4)); + } else { + near_bits &= (0xffffffff00000000 >> nbits); + if (nbits > 15) { + new += one_bits(near_bits & 0xffff); + } + return (new + (one_bits(near_bits >> 16))); + } + } else { + new = GCrelocptr[pagelet+1] + tag_n; + nbits = 64-nbits; + + if (near_bits == 0xffffffff) { + return (new - (nbits << 4)); + } else { + near_bits &= (1< 15) { + new -= one_bits(near_bits >> 16); + } + return (new - one_bits(near_bits & 0xffff)); + } + } +} +#else +#ifdef X8664 +/* Quicker, dirtier */ +LispObj +dnode_forwarding_address(natural dnode, int tag_n) +{ + natural pagelet, nbits, marked; + LispObj new; + + if (GCDebug) { + if (! ref_bit(GCdynamic_markbits, dnode)) { + Bug(NULL, "unmarked object being forwarded!\n"); + } + } + + pagelet = dnode >> bitmap_shift; + nbits = dnode & bitmap_shift_count_mask; + new = GCrelocptr[pagelet] + tag_n;; + if (nbits) { + marked = (GCdynamic_markbits[dnode>>bitmap_shift]) >> (64-nbits); + while (marked) { + new += one_bits((qnode)marked); + marked >>=16; + } + } + return new; +} +#endif +#ifdef X8632 +LispObj +dnode_forwarding_address(natural dnode, int tag_n) +{ + natural pagelet, nbits; + unsigned short near_bits; + LispObj new; + + if (GCDebug) { + if (! ref_bit(GCdynamic_markbits, dnode)) { + Bug(NULL, "unmarked object being forwarded!\n"); + } + } + + pagelet = dnode >> 5; + nbits = dnode & 0x1f; + /* On little-endian x86, we have to flip the low bit of dnode>>4 to + get the near_bits from the appropriate half-word. */ + near_bits = ((unsigned short *)GCdynamic_markbits)[(dnode>>4)^1]; + + if (nbits < 16) { + new = GCrelocptr[pagelet] + tag_n;; + /* Increment "new" by the count of 1 bits which precede the dnode */ + if (near_bits == 0xffff) { + return (new + (nbits << 3)); + } else { + near_bits &= (0xffff0000 >> nbits); + if (nbits > 7) { + new += one_bits(near_bits & 0xff); + } + return (new + (one_bits(near_bits >> 8))); + } + } else { + new = GCrelocptr[pagelet+1] + tag_n; + nbits = 32-nbits; + + if (near_bits == 0xffff) { + return (new - (nbits << 3)); + } else { + near_bits &= (1< 7) { + new -= one_bits(near_bits >> 8); + } + return (new - one_bits(near_bits & 0xff)); + } + } +} +#endif +#endif + +LispObj +locative_forwarding_address(LispObj obj) +{ + int tag_n = fulltag_of(obj); + natural dnode = gc_dynamic_area_dnode(obj); + + + if ((dnode >= GCndynamic_dnodes_in_area) || + (obj < GCfirstunmarked)) { + return obj; + } + + return dnode_forwarding_address(dnode, tag_n); +} + + +void +forward_headerless_range(LispObj *range_start, LispObj *range_end) +{ + LispObj *p = range_start; + + while (p < range_end) { + update_noderef(p); + p++; + } +} + +void +forward_range(LispObj *range_start, LispObj *range_end) +{ + LispObj *p = range_start, node, new; + int tag_n; + natural nwords; + hash_table_vector_header *hashp; + + while (p < range_end) { + node = *p; + tag_n = fulltag_of(node); + if (immheader_tag_p(tag_n)) { + p = (LispObj *) skip_over_ivector((natural) p, node); + } else if (nodeheader_tag_p(tag_n)) { + nwords = header_element_count(node); + nwords += (1 - (nwords&1)); + if ((header_subtag(node) == subtag_hash_vector) && + ((((hash_table_vector_header *)p)->flags) & nhash_track_keys_mask)) { + natural skip = hash_table_vector_header_count-1; + hashp = (hash_table_vector_header *) p; + p++; + nwords -= skip; + while(skip--) { + update_noderef(p); + p++; + } + /* "nwords" is odd at this point: there are (floor nwords 2) + key/value pairs to look at, and then an extra word for + alignment. Process them two at a time, then bump "p" + past the alignment word. */ + nwords >>= 1; + while(nwords--) { + if (update_noderef(p) && hashp) { + hashp->flags |= nhash_key_moved_mask; + hashp = NULL; + } + p++; + update_noderef(p); + p++; + } + *p++ = 0; + } else { + if (header_subtag(node) == subtag_function) { +#ifdef X8632 + int skip = (unsigned short)(p[1]); + + /* XXX bootstrapping */ + if (skip & 0x8000) + skip = header_element_count(node) - (skip & 0x7fff); + +#else + int skip = (int)(p[1]); +#endif + p += skip; + nwords -= skip; + } + p++; + while(nwords--) { + update_noderef(p); + p++; + } + } + } else { + new = node_forwarding_address(node); + if (new != node) { + *p = new; + } + p++; + update_noderef(p); + p++; + } + } +} + + + + + + +/* Forward a tstack area */ +void +forward_tstack_area(area *a) +{ + LispObj + *current, + *next, + *start = (LispObj *) a->active, + *end = start, + *limit = (LispObj *) (a->high); + + for (current = start; + end != limit; + current = next) { + next = ptr_from_lispobj(*current); + end = ((next >= start) && (next < limit)) ? next : limit; + forward_range(current+2, end); + } +} + +/* Forward a vstack area */ +void +forward_vstack_area(area *a) +{ + LispObj + *p = (LispObj *) a->active, + *q = (LispObj *) a->high; + + forward_headerless_range(p, q); +} + +/* Nothing of interest on x86 cstack */ +void +forward_cstack_area(area *a) +{ +} + +#ifdef X8664 +void +forward_xp(ExceptionInformation *xp) +{ + natural *regs = (natural *) xpGPRvector(xp); + + update_noderef(&(regs[Iarg_z])); + update_noderef(&(regs[Iarg_y])); + update_noderef(&(regs[Iarg_x])); + update_noderef(&(regs[Isave3])); + update_noderef(&(regs[Isave2])); + update_noderef(&(regs[Isave1])); + update_noderef(&(regs[Isave0])); + update_noderef(&(regs[Ifn])); + update_noderef(&(regs[Itemp0])); + update_noderef(&(regs[Itemp1])); + update_noderef(&(regs[Itemp2])); + update_locref(&(regs[Iip])); +} +#else +void +forward_xp(ExceptionInformation *xp, natural node_regs_mask) +{ + natural *regs = (natural *) xpGPRvector(xp); + + if (node_regs_mask & (1<<0)) update_noderef(®s[REG_EAX]); + if (node_regs_mask & (1<<1)) update_noderef(®s[REG_ECX]); + + if (regs[REG_EFL] & EFL_DF) { + /* then EDX is an imm reg */ + ; + } else + if (node_regs_mask & (1<<2)) update_noderef(®s[REG_EDX]); + + if (node_regs_mask & (1<<3)) update_noderef(®s[REG_EBX]); + if (node_regs_mask & (1<<4)) update_noderef(®s[REG_ESP]); + if (node_regs_mask & (1<<5)) update_noderef(®s[REG_EBP]); + if (node_regs_mask & (1<<6)) update_noderef(®s[REG_ESI]); + if (node_regs_mask & (1<<7)) update_noderef(®s[REG_EDI]); + + update_locref(&(regs[Iip])); +} +#endif + + +void +forward_tcr_xframes(TCR *tcr) +{ + xframe_list *xframes; + ExceptionInformation *xp; + + xp = tcr->gc_context; + if (xp) { +#ifdef X8664 + forward_xp(xp); +#else + forward_xp(xp, tcr->node_regs_mask); + + update_noderef(&tcr->save0); + update_noderef(&tcr->save1); + update_noderef(&tcr->save2); + update_noderef(&tcr->save3); + update_noderef(&tcr->next_method_context); +#endif + } + for (xframes = tcr->xframe; xframes; xframes = xframes->prev) { +#ifdef X8664 + forward_xp(xframes->curr); +#else + forward_xp(xframes->curr, xframes->node_regs_mask); +#endif + } +} + + +#ifdef X8632 +void +update_self_references(LispObj *node) +{ + LispObj fn = fulltag_misc + (LispObj)node; + unsigned char *p = (unsigned char *)node; + natural i = imm_word_count(fn); + + if (i) { + natural offset = node[--i]; + + while (offset) { + *(LispObj *)(p + offset) = fn; + offset = node[--i]; + } + } +} +#endif + +/* + Compact the dynamic heap (from GCfirstunmarked through its end.) + Return the doublenode address of the new freeptr. + */ + +LispObj +compact_dynamic_heap() +{ + LispObj *src = ptr_from_lispobj(GCfirstunmarked), *dest = src, node, new, *current, *prev = NULL; + natural + elements, + dnode = gc_area_dnode(GCfirstunmarked), + node_dnodes = 0, + imm_dnodes = 0, + bitidx, + *bitsp, + bits, + nextbit, + diff; + int tag; + bitvector markbits = GCmarkbits; + + if (dnode < GCndnodes_in_area) { + lisp_global(FWDNUM) += (1<>1; + dnode += node_dnodes; + if (header_subtag(node) == subtag_function) { +#ifdef X8632 + LispObj *f = dest; + int skip = imm_word_count(fulltag_misc + (LispObj)current); +#else + int skip = *((int *)src); +#endif + *dest++ = node; + if (skip) { + elements -= skip; + while(skip--) { + *dest++ = *src++; + } +#ifdef X8632 + update_self_references(f); +#endif + } + while(elements--) { + *dest++ = node_forwarding_address(*src++); + } + if (((LispObj)src) & node_size) { + src++; + *dest++ = 0; + } + } else { + if ((header_subtag(node) == subtag_hash_vector) && + (((hash_table_vector_header *) (src-1))->flags & nhash_track_keys_mask)) { + hash_table_vector_header *hashp = (hash_table_vector_header *) dest; + int skip = (sizeof(hash_table_vector_header)/sizeof(LispObj))-1; + + *dest++ = node; + elements -= skip; + while(skip--) { + *dest++ = node_forwarding_address(*src++); + } + /* There should be an even number of (key/value) pairs in elements; + an extra alignment word follows. */ + elements >>= 1; + while (elements--) { + if (hashp) { + node = *src++; + new = node_forwarding_address(node); + if (new != node) { + hashp->flags |= nhash_key_moved_mask; + hashp = NULL; + *dest++ = new; + } else { + *dest++ = node; + } + } else { + *dest++ = node_forwarding_address(*src++); + } + *dest++ = node_forwarding_address(*src++); + } + *dest++ = 0; + src++; + } else { + *dest++ = node; + *dest++ = node_forwarding_address(*src++); + while(--node_dnodes) { + *dest++ = node_forwarding_address(*src++); + *dest++ = node_forwarding_address(*src++); + } + } + } + set_bitidx_vars(markbits,dnode,bitsp,bits,bitidx); + } else if (immheader_tag_p(tag)) { + *dest++ = node; + *dest++ = *src++; + elements = header_element_count(node); + tag = header_subtag(node); + +#ifdef X8664 + switch(fulltag_of(tag)) { + case ivector_class_64_bit: + imm_dnodes = ((elements+1)+1)>>1; + break; + case ivector_class_32_bit: + imm_dnodes = (((elements+2)+3)>>2); + break; + case ivector_class_other_bit: + if (tag == subtag_bit_vector) { + imm_dnodes = (((elements+64)+127)>>7); + } else if (tag >= min_8_bit_ivector_subtag) { + imm_dnodes = (((elements+8)+15)>>4); + } else { + imm_dnodes = (((elements+4)+7)>>3); + } + } +#endif +#ifdef X8632 + if (tag <= max_32_bit_ivector_subtag) { + imm_dnodes = (((elements+1)+1)>>1); + } else if (tag <= max_8_bit_ivector_subtag) { + imm_dnodes = (((elements+4)+7)>>3); + } else if (tag <= max_16_bit_ivector_subtag) { + imm_dnodes = (((elements+2)+3)>>2); + } else if (tag == subtag_bit_vector) { + imm_dnodes = (((elements+32)+63)>>6); + } else { + imm_dnodes = elements+1; + } +#endif + + dnode += imm_dnodes; + while (--imm_dnodes) { + *dest++ = *src++; + *dest++ = *src++; + } + set_bitidx_vars(markbits,dnode,bitsp,bits,bitidx); + } else { + *dest++ = node_forwarding_address(node); + *dest++ = node_forwarding_address(*src++); + bits &= ~(BIT0_MASK >> bitidx); + dnode++; + bitidx++; + } + } + } + } + return ptr_to_lispobj(dest); +} + + +#define PURIFY_IVECTORS (1<<0) +#define PURIFY_FUNCTIONS (1<<1) +#define PURIFY_ALL (-1) +#define PURIFY_NOTHING (0) /* update forwarding pointers, don't copy */ + + + +Boolean +immutable_function_p(LispObj thing) +{ + LispObj header = header_of(thing), lfbits; + if (header_subtag(header) == subtag_function) { + lfbits = deref(thing,header_element_count(header)); + if (((lfbits & (lfbits_cm_mask | lfbits_method_mask)) != + lfbits_cm_mask) && + ((lfbits & (lfbits_gfn_mask | lfbits_method_mask)) != + lfbits_gfn_mask)) { + return true; + } + } + return false; +} + + +/* + Total the (physical) byte sizes of all ivectors in the indicated memory range +*/ + +natural +unboxed_bytes_in_range(LispObj *start, LispObj *end, Boolean include_functions) +{ + natural total=0, elements, tag, subtag, bytes; + LispObj header; + + while (start < end) { + header = *start; + tag = fulltag_of(header); + + if ((nodeheader_tag_p(tag)) || + (immheader_tag_p(tag))) { + elements = header_element_count(header); + if (nodeheader_tag_p(tag)) { + if (include_functions && immutable_function_p((LispObj)start)) { + total += (((elements+2)&~1)<>3); + } else if (subtag >= min_8_bit_ivector_subtag) { + bytes = 8 + elements; + } else { + bytes = 8 + (elements<<1); + } + } +#endif +#ifdef X8632 + if (subtag <= max_32_bit_ivector_subtag) { + bytes = 4 + (elements<<2); + } else if (subtag <= max_8_bit_ivector_subtag) { + bytes = 4 + elements; + } else if (subtag <= max_16_bit_ivector_subtag) { + bytes = 4 + (elements<<1); + } else if (subtag == subtag_double_float_vector) { + bytes = 8 + (elements<<3); + } else { + bytes = 4 + ((elements+7)>>3); + } +#endif + + bytes = (bytes+dnode_size-1) & ~(dnode_size-1); + total += bytes; + start += (bytes >> node_shift); + } + } else { + start += 2; + } + } + return total; +} + + +void +ensure_writable_space(area *target, natural need) +{ + BytePtr + oldlimit = (BytePtr)align_to_power_of_2(target->active,log2_page_size), + newlimit = (BytePtr)align_to_power_of_2(target->active+need,log2_page_size); + if (newlimit > oldlimit) { + CommitMemory(oldlimit,newlimit-oldlimit); + } +} + +LispObj +purify_displaced_object(LispObj obj, area *dest, natural disp) +{ + BytePtr + free = dest->active, + *old = (BytePtr *) ptr_from_lispobj(untag(obj)); + LispObj + header = header_of(obj), + new; + natural + start = (natural)old, + physbytes; + int + header_tag = fulltag_of(header); +#ifdef X8632 + Boolean + is_function = (header_subtag(header)==subtag_function); +#endif + + if (immheader_tag_p(header_tag)) { + physbytes = ((natural)(skip_over_ivector(start,header))) - start; + } else if (nodeheader_tag_p(header_tag)) { + physbytes = ((header_element_count(header)+2)&~1) << node_shift; + } else { + physbytes = dnode_size; + } + + ensure_writable_space(dest, physbytes); + dest->active += physbytes; + + new = ptr_to_lispobj(free)+disp; + + memcpy(free, (BytePtr)old, physbytes); + +#ifdef X8632 + if (is_function) { + update_self_references((LispObj *)free); + } +#endif + + + while(physbytes) { + *old++ = (BytePtr) forward_marker; + *old++ = (BytePtr) free; + free += dnode_size; + physbytes -= dnode_size; + } + return new; +} + +LispObj +purify_object(LispObj obj, area *dest) +{ + return purify_displaced_object(obj, dest, fulltag_of(obj)); +} + +Boolean +purify_locref(LispObj *ref, BytePtr low, BytePtr high, area *dest, int what) +{ + LispObj obj = *ref, header, new; + natural tag = fulltag_of(obj), header_tag; + Boolean changed = false; + + if ((((BytePtr)ptr_from_lispobj(obj)) > low) && + (((BytePtr)ptr_from_lispobj(obj)) < high)) { + header = deref(obj, 0); + if (header == forward_marker) { /* already copied */ + *ref = (untag(deref(obj,1)) + tag); + changed = true; + } else { + header_tag = fulltag_of(header); + if ((what == PURIFY_ALL) || + ((what & PURIFY_IVECTORS) && + immheader_tag_p(header_tag) && + header_subtag(header) != subtag_macptr) || + ((what & PURIFY_FUNCTIONS) && + immutable_function_p(obj))) { + new = purify_object(obj, dest); + *ref = new; + changed = (new != obj); + } + } + } + return changed; +} + +Boolean +copy_reference(LispObj *ref, BytePtr low, BytePtr high, area *dest, int what) +{ + LispObj obj = *ref; + natural tag = fulltag_of(obj); + + if ( +#ifdef X8664 + (tag == fulltag_tra_0) || (tag == fulltag_tra_1) +#endif +#ifdef X8632 + tag == fulltag_tra +#endif + ) { + what = PURIFY_NOTHING; + } + if (is_node_fulltag(tag)) { + return purify_locref(ref,low,high,dest,what); + } + return false; +} + + + +void +purify_gcable_ptrs(BytePtr low, BytePtr high, area *to, int what) +{ + LispObj *prev = &(lisp_global(GCABLE_POINTERS)), next; + + while ((*prev) != (LispObj)NULL) { + copy_reference(prev, low, high, to, what); + next = *prev; + prev = &(((xmacptr *)ptr_from_lispobj(untag(next)))->link); + } +} + +void +purify_headerless_range(LispObj *start, LispObj *end, BytePtr low, BytePtr high, area *to, int what) +{ + while (start < end) { + copy_reference(start, low, high, to, what); + start++; + } +} + +void +purify_range(LispObj *start, LispObj *end, BytePtr low, BytePtr high, area *to, int what) +{ + LispObj header; + unsigned tag; + natural nwords; + hash_table_vector_header *hashp; + + while (start < end) { + header = *start; + if (header == forward_marker) { + start += 2; + } else { + tag = fulltag_of(header); + if (immheader_tag_p(tag)) { + start = (LispObj *)skip_over_ivector((natural)start, header); + } else if (nodeheader_tag_p(tag)) { + nwords = header_element_count(header); + nwords += (1 - (nwords&1)); + if ((header_subtag(header) == subtag_hash_vector) && + ((((hash_table_vector_header *)start)->flags) & + nhash_track_keys_mask)) { + natural skip = (sizeof(hash_table_vector_header)/sizeof(LispObj))-1; + + hashp = (hash_table_vector_header *) start; + start++; + nwords -= skip; + while(skip--) { + copy_reference(start, low, high, to, what); + start++; + } + /* "nwords" is odd at this point: there are (floor nwords 2) + key/value pairs to look at, and then an extra word for + alignment. Process them two at a time, then bump "start" + past the alignment word. */ + nwords >>= 1; + while(nwords--) { + if (copy_reference(start, low, high, to, what) && hashp) { + hashp->flags |= nhash_key_moved_mask; + hashp = NULL; + } + start++; + copy_reference(start, low, high, to, what); + start++; + } + *start++ = 0; + } else { + if (header_subtag(header) == subtag_function) { +#ifdef X8632 + int skip = (unsigned short)(start[1]); + + /* XXX bootstrapping */ + if (skip & 0x8000) + skip = header_element_count(header) - (skip & 0x7fff); +#else + int skip = (int)(start[1]); +#endif + start += skip; + nwords -= skip; + } + start++; + while(nwords--) { + copy_reference(start, low, high, to, what); + start++; + } + } + } else { + /* Not a header, just a cons cell */ + copy_reference(start, low, high, to, what); + start++; + copy_reference(start, low, high, to, what); + start++; + } + } + } +} + +/* Purify references from tstack areas */ +void +purify_tstack_area(area *a, BytePtr low, BytePtr high, area *to, int what) +{ + LispObj + *current, + *next, + *start = (LispObj *) (a->active), + *end = start, + *limit = (LispObj *) (a->high); + + for (current = start; + end != limit; + current = next) { + next = (LispObj *) ptr_from_lispobj(*current); + end = ((next >= start) && (next < limit)) ? next : limit; + purify_range(current+2, end, low, high, to, what); + } +} + +/* Purify a vstack area */ +void +purify_vstack_area(area *a, BytePtr low, BytePtr high, area *to, int what) +{ + LispObj + *p = (LispObj *) a->active, + *q = (LispObj *) a->high; + + purify_headerless_range(p, q, low, high, to, what); +} + + +void +purify_xp(ExceptionInformation *xp, BytePtr low, BytePtr high, area *to, int what +#ifdef X8632 + ,natural node_regs_mask +#endif +) +{ + natural *regs = (natural *) xpGPRvector(xp); + + +#ifdef X8664 + copy_reference(&(regs[Iarg_z]), low, high, to, what); + copy_reference(&(regs[Iarg_y]), low, high, to, what); + copy_reference(&(regs[Iarg_x]), low, high, to, what); + copy_reference(&(regs[Isave3]), low, high, to, what); + copy_reference(&(regs[Isave2]), low, high, to, what); + copy_reference(&(regs[Isave1]), low, high, to, what); + copy_reference(&(regs[Isave0]), low, high, to, what); + copy_reference(&(regs[Ifn]), low, high, to, what); + copy_reference(&(regs[Itemp0]), low, high, to, what); + copy_reference(&(regs[Itemp1]), low, high, to, what); + copy_reference(&(regs[Itemp2]), low, high, to, what); + + purify_locref(&(regs[Iip]), low, high, to, PURIFY_NOTHING); + +#else + if (node_regs_mask & (1<<0)) { + copy_reference(&(regs[REG_EAX]), low, high, to, what); + } + if (node_regs_mask & (1<<1)) { + copy_reference(&(regs[REG_ECX]), low, high, to, what); + } + if (! (regs[REG_EFL] & EFL_DF)) { + if (node_regs_mask & (1<<2)) { + copy_reference(&(regs[REG_EDX]), low, high, to, what); + } + } + if (node_regs_mask & (1<<3)) { + copy_reference(&(regs[REG_EBX]), low, high, to, what); + } + if (node_regs_mask & (1<<4)) { + copy_reference(&(regs[REG_ESP]), low, high, to, what); + } + if (node_regs_mask & (1<<5)) { + copy_reference(&(regs[REG_EBP]), low, high, to, what); + } + if (node_regs_mask & (1<<6)) { + copy_reference(&(regs[REG_ESI]), low, high, to, what); + } + if (node_regs_mask & (1<<7)) { + copy_reference(&(regs[REG_EDI]), low, high, to, what); + } + purify_locref(®s[REG_EIP], low, high, to, what); +#endif +} + +void +purify_tcr_tlb(TCR *tcr, BytePtr low, BytePtr high, area *to, int what) +{ + natural n = tcr->tlb_limit; + LispObj *start = tcr->tlb_pointer, *end = (LispObj *) ((BytePtr)start+n); + + purify_range(start, end, low, high, to, what); +} + +void +purify_tcr_xframes(TCR *tcr, BytePtr low, BytePtr high, area *to, int what) +{ + xframe_list *xframes; + ExceptionInformation *xp; + + xp = tcr->gc_context; + if (xp) { +#ifdef X8632 + purify_xp(xp, low, high, to, what, tcr->node_regs_mask); +#else + purify_xp(xp, low, high, to, what); +#endif + } +#ifdef X8632 + copy_reference(&tcr->save0, low, high, to, what); + copy_reference(&tcr->save1, low, high, to, what); + copy_reference(&tcr->save2, low, high, to, what); + copy_reference(&tcr->save3, low, high, to, what); + copy_reference(&tcr->next_method_context, low, high, to, what); +#endif + + for (xframes = tcr->xframe; xframes; xframes = xframes->prev) { + purify_xp(xframes->curr, low, high, to, what +#ifdef X8632 + , xframes->node_regs_mask +#endif + ); + } +} + + +void +purify_areas(BytePtr low, BytePtr high, area *target, int what) +{ + area *next_area; + area_code code; + + for (next_area = active_dynamic_area; (code = next_area->code) != AREA_VOID; next_area = next_area->succ) { + switch (code) { + case AREA_TSTACK: + purify_tstack_area(next_area, low, high, target, what); + break; + + case AREA_VSTACK: + purify_vstack_area(next_area, low, high, target, what); + break; + + case AREA_CSTACK: + break; + + case AREA_STATIC: + case AREA_DYNAMIC: + case AREA_MANAGED_STATIC: + purify_range((LispObj *) next_area->low, (LispObj *) next_area->active, low, high, target, what); + break; + + default: + break; + } + } +} + +void +update_managed_refs(area *a, BytePtr low_dynamic_address, natural ndynamic_dnodes) +{ + LispObj + *start = (LispObj *)a->low, + *end = (LispObj *)a->active, + x1, + *base = start, *prev = start; + int tag; + bitvector refbits = a->refbits; + natural ref_dnode, node_dnode; + Boolean intergen_ref; + + while (start < end) { + x1 = *start; + prev = start; + tag = fulltag_of(x1); + if (immheader_tag_p(tag)) { + start = skip_over_ivector(ptr_to_lispobj(start), x1); + } else { + if (header_subtag(x1) == subtag_function) { +#ifdef X8632 + int skip = (unsigned short)deref(start,1); + /* XXX bootstrapping */ + if (skip & 0x8000) + skip = header_element_count(x1) - (skip & 0x7fff); +#else + int skip = (int) deref(start,1); +#endif + start += ((1+skip)&~1); + x1 = *start; + tag = fulltag_of(x1); + } + intergen_ref = false; + if (is_node_fulltag(tag)) { + node_dnode = area_dnode(x1, low_dynamic_address); + if (node_dnode < ndynamic_dnodes) { + intergen_ref = true; + } + } + if (intergen_ref == false) { + x1 = start[1]; + tag = fulltag_of(x1); + if (is_node_fulltag(tag)) { + node_dnode = area_dnode(x1, low_dynamic_address); + if (node_dnode < ndynamic_dnodes) { + intergen_ref = true; + } + } + } + if (intergen_ref) { + ref_dnode = area_dnode(start, base); + set_bit(refbits, ref_dnode); + } + start += 2; + } + } + if (start > end) { + Bug(NULL, "Overran end of range!"); + } +} + +/* + So far, this is mostly for save_application's benefit. + We -should- be able to return to lisp code after doing this, + however. + +*/ + + +signed_natural +purify(TCR *tcr, signed_natural param) +{ + extern area *extend_readonly_area(natural); + area + *a = active_dynamic_area, + *pure_area; + + TCR *other_tcr; + natural max_pure_size; + BytePtr new_pure_start, + low = (a->low + (static_dnodes_for_area(a) << dnode_shift)), + high = a->active; + Boolean purify_functions = (param != 0); + int flags = PURIFY_IVECTORS | (purify_functions ? PURIFY_FUNCTIONS : 0); + + max_pure_size = unboxed_bytes_in_range((LispObj *) low, (LispObj *) high, purify_functions); + pure_area = extend_readonly_area(max_pure_size); + if (pure_area) { + new_pure_start = pure_area->active; + lisp_global(IN_GC) = (1<next; + } while (other_tcr != tcr); + + purify_gcable_ptrs(low, high, pure_area, flags); + if (purify_functions) { + /* We're likely to copy a lot of symbols to the managed static + area. Lots of symbols will have incidental references to + a relatively small number of things that happen to initialy + be in dynamic space: the UNDEFINED-FUNCTION object, packages, + etc. Doing a shallow copy of those things to the managed-static + area will reduce the number of static->dynamic references. */ + LispObj package_list; + + copy_reference(&nrs_UDF.vcell,low,high,managed_static_area,PURIFY_ALL); + for (package_list = nrs_ALL_PACKAGES.vcell; + package_list != lisp_nil; + package_list = deref(package_list,0)) { + copy_reference(&(deref(package_list,1)),low,high,managed_static_area,PURIFY_ALL); + } + + + + /* Do a shallow copy of the constants of all purified functions + from the dynamic area to the managed static area */ + purify_range((LispObj*)(pure_area->low), + (LispObj*)(pure_area->active), + low, + high, + managed_static_area, + PURIFY_ALL); + /* Go back through all areas, resolving forwarding pointers + (but without copying anything.) */ + purify_areas(low, high, NULL, PURIFY_NOTHING); + other_tcr = tcr; + do { + purify_tcr_xframes(other_tcr, low, high, NULL, PURIFY_NOTHING); + purify_tcr_tlb(other_tcr, low, high, NULL, PURIFY_NOTHING); + other_tcr = other_tcr->next; + } while (other_tcr != tcr); + + purify_gcable_ptrs(low, high, NULL, PURIFY_NOTHING); + + /* Update refbits for managed static area */ + { + natural + managed_dnodes = area_dnode(managed_static_area->active, + managed_static_area->low), + refbytes = align_to_power_of_2((managed_dnodes+7)>>3,log2_page_size); + + managed_static_area->ndnodes = managed_dnodes; + CommitMemory(managed_static_area->refbits, refbytes); /* zeros them */ + update_managed_refs(managed_static_area, low_markable_address, area_dnode(a->active,low_markable_address)); + } + } + ProtectMemory(pure_area->low, + align_to_power_of_2(pure_area->active-pure_area->low, + log2_page_size)); + lisp_global(IN_GC) = 0; + just_purified_p = true; + return 0; + } + return -1; +} + +Boolean +impurify_locref(LispObj *p, LispObj low, LispObj high, signed_natural delta) +{ + LispObj q = *p; + + if ((q >= low) && + (q < high)) { + *p = (q+delta); + return true; + } + return false; +} + +Boolean +impurify_noderef(LispObj *p, LispObj low, LispObj high, signed_natural delta) +{ + LispObj q = *p; + + if (is_node_fulltag(fulltag_of(q)) && + (q >= low) && + (q < high)) { + *p = (q+delta); + return true; + } + return false; +} + + +void +impurify_gcable_ptrs(LispObj low, LispObj high, signed_natural delta) +{ + LispObj *prev = &(lisp_global(GCABLE_POINTERS)), next; + + while ((*prev) != (LispObj)NULL) { + impurify_noderef(prev, low, high, delta); + next = *prev; + prev = &(((xmacptr *)ptr_from_lispobj(untag(next)))->link); + } +} + + +void +impurify_xp(ExceptionInformation *xp, LispObj low, LispObj high, signed_natural delta +#ifdef X8632 + ,natural node_regs_mask +#endif +) +{ + natural *regs = (natural *) xpGPRvector(xp); + + +#ifdef X8664 + impurify_noderef(&(regs[Iarg_z]), low, high, delta); + impurify_noderef(&(regs[Iarg_y]), low, high, delta); + impurify_noderef(&(regs[Iarg_x]), low, high, delta); +#ifndef TCR_IN_GPR + impurify_noderef(&(regs[Isave3]), low, high, delta); +#endif + impurify_noderef(&(regs[Isave2]), low, high, delta); + impurify_noderef(&(regs[Isave1]), low, high, delta); + impurify_noderef(&(regs[Isave0]), low, high, delta); + impurify_noderef(&(regs[Ifn]), low, high, delta); + impurify_noderef(&(regs[Itemp0]), low, high, delta); + impurify_noderef(&(regs[Itemp1]), low, high, delta); + + impurify_locref(&(regs[Iip]), low, high, delta); +#else + if (node_regs_mask & (1<<0)) { + impurify_noderef(&(regs[REG_EAX]), low, high, delta); + } + if (node_regs_mask & (1<<1)) { + impurify_noderef(&(regs[REG_ECX]), low, high, delta); + } + if (! (regs[REG_EFL] & EFL_DF)) { + if (node_regs_mask & (1<<2)) { + impurify_noderef(&(regs[REG_EDX]), low, high, delta); + } + } + if (node_regs_mask & (1<<3)) { + impurify_noderef(&(regs[REG_EBX]), low, high, delta); + } + if (node_regs_mask & (1<<4)) { + impurify_noderef(&(regs[REG_ESP]), low, high, delta); + } + if (node_regs_mask & (1<<5)) { + impurify_noderef(&(regs[REG_EBP]), low, high, delta); + } + if (node_regs_mask & (1<<6)) { + impurify_noderef(&(regs[REG_ESI]), low, high, delta); + } + if (node_regs_mask & (1<<7)) { + impurify_noderef(&(regs[REG_EDI]), low, high, delta); + } + impurify_locref(&(regs[REG_EIP]), low, high, delta); + +#endif + +} + +void +impurify_headerless_range(LispObj *start, LispObj *end, LispObj low, LispObj high, signed_natural delta) +{ + while (start < end) { + impurify_noderef(start, low, high, delta); + start++; + } +} + + +void +impurify_range(LispObj *start, LispObj *end, LispObj low, LispObj high, signed_natural delta) +{ + LispObj header; + unsigned tag; + natural nwords; + hash_table_vector_header *hashp; + + while (start < end) { + header = *start; + if (header == forward_marker) { + start += 2; + } else { + tag = fulltag_of(header); + if (immheader_tag_p(tag)) { + start = (LispObj *)skip_over_ivector((natural)start, header); + } else if (nodeheader_tag_p(tag)) { + nwords = header_element_count(header); + nwords += (1 - (nwords&1)); + if ((header_subtag(header) == subtag_hash_vector) && + ((((hash_table_vector_header *)start)->flags) & + nhash_track_keys_mask)) { + natural skip = (sizeof(hash_table_vector_header)/sizeof(LispObj))-1; + + hashp = (hash_table_vector_header *) start; + start++; + nwords -= skip; + while(skip--) { + impurify_noderef(start, low, high, delta); + start++; + } + /* "nwords" is odd at this point: there are (floor nwords 2) + key/value pairs to look at, and then an extra word for + alignment. Process them two at a time, then bump "start" + past the alignment word. */ + nwords >>= 1; + while(nwords--) { + if (impurify_noderef(start, low, high, delta) && hashp) { + hashp->flags |= nhash_key_moved_mask; + hashp = NULL; + } + start++; + impurify_noderef(start, low, high, delta); + start++; + } + *start++ = 0; + } else { + if (header_subtag(header) == subtag_function) { +#ifdef X8632 + int skip = (unsigned short)start[1]; +#else + int skip = (int)(start[1]); +#endif + start += skip; + nwords -= skip; + } + start++; + while(nwords--) { + impurify_noderef(start, low, high, delta); + start++; + } + } + } else { + /* Not a header, just a cons cell */ + impurify_noderef(start, low, high, delta); + start++; + impurify_noderef(start, low, high, delta); + start++; + } + } + } +} + + + + +void +impurify_tcr_tlb(TCR *tcr, LispObj low, LispObj high, signed_natural delta) +{ + unsigned n = tcr->tlb_limit; + LispObj *start = tcr->tlb_pointer, *end = (LispObj *) ((BytePtr)start+n); + + impurify_range(start, end, low, high, delta); +} + +void +impurify_tcr_xframes(TCR *tcr, LispObj low, LispObj high, signed_natural delta) +{ + xframe_list *xframes; + ExceptionInformation *xp; + + xp = tcr->gc_context; + if (xp) { +#ifdef X8632 + impurify_xp(xp, low, high, delta, tcr->node_regs_mask); +#else + impurify_xp(xp, low, high, delta); +#endif + } + +#ifdef X8632 + impurify_noderef(&tcr->save0, low, high, delta); + impurify_noderef(&tcr->save1, low, high, delta); + impurify_noderef(&tcr->save2, low, high, delta); + impurify_noderef(&tcr->save3, low, high, delta); + impurify_noderef(&tcr->next_method_context, low, high, delta); +#endif + + for (xframes = tcr->xframe; xframes; xframes = xframes->prev) { + impurify_xp(xframes->curr, low, high, delta +#ifdef X8632 + ,xframes->node_regs_mask +#endif +); + } +} + +void +impurify_tstack_area(area *a, LispObj low, LispObj high, signed_natural delta) +{ + LispObj + *current, + *next, + *start = (LispObj *) (a->active), + *end = start, + *limit = (LispObj *) (a->high); + + for (current = start; + end != limit; + current = next) { + next = (LispObj *) ptr_from_lispobj(*current); + end = ((next >= start) && (next < limit)) ? next : limit; + impurify_range(current+2, end, low, high, delta); + } +} +void +impurify_vstack_area(area *a, LispObj low, LispObj high, signed_natural delta) +{ + LispObj + *p = (LispObj *) a->active, + *q = (LispObj *) a->high; + + impurify_headerless_range(p, q, low, high, delta); +} + + +void +impurify_areas(LispObj low, LispObj high, signed_natural delta) +{ + area *next_area; + area_code code; + + for (next_area = active_dynamic_area; (code = next_area->code) != AREA_VOID; next_area = next_area->succ) { + switch (code) { + case AREA_TSTACK: + impurify_tstack_area(next_area, low, high, delta); + break; + + case AREA_VSTACK: + impurify_vstack_area(next_area, low, high, delta); + break; + + case AREA_CSTACK: + break; + + case AREA_STATIC: + case AREA_DYNAMIC: + case AREA_MANAGED_STATIC: + impurify_range((LispObj *) next_area->low, (LispObj *) next_area->active, low, high, delta); + break; + + default: + break; + } + } +} + +void +impurify_from_area(TCR *tcr, area *src) +{ + area *a = active_dynamic_area; + BytePtr base = src->low, limit = src->active, oldfree = a->active, + oldhigh = a->high, newhigh; + natural n = limit-base; + signed_natural delta = oldfree-base; + TCR *other_tcr; + + newhigh = (BytePtr) (align_to_power_of_2(oldfree+n, + log2_heap_segment_size)); + if (newhigh > oldhigh) { + grow_dynamic_area(newhigh-oldhigh); + } + a->active += n; + memmove(oldfree, base, n); + UnCommitMemory((void *)base, n); + a->ndnodes = area_dnode(a, a->active); + src->active = src->low; + if (src == readonly_area) { + pure_space_active = src->low; + } + src->ndnodes = 0; + + impurify_areas(ptr_to_lispobj(base), ptr_to_lispobj(limit), delta); + + other_tcr = tcr; + do { + impurify_tcr_xframes(other_tcr, ptr_to_lispobj(base), ptr_to_lispobj(limit), delta); + impurify_tcr_tlb(other_tcr, ptr_to_lispobj(base), ptr_to_lispobj(limit), delta); + other_tcr = other_tcr->next; + } while (other_tcr != tcr); + + impurify_gcable_ptrs(ptr_to_lispobj(base), ptr_to_lispobj(limit), delta); +} + +signed_natural +impurify(TCR *tcr, signed_natural param) +{ + lisp_global(IN_GC)=1; + impurify_from_area(tcr, readonly_area); + impurify_from_area(tcr, managed_static_area); + lisp_global(IN_GC)=0; + return 0; +} + +/* + * This stuff is all adapted from the forward_xxx functions for use by + * the watchpoint code. It's a lot of duplicated code, and it would + * be nice to generalize it somehow. + */ + +static inline int +wp_maybe_update(LispObj *p, LispObj old, LispObj new) +{ + if (*p == old) { + *p = new; + return true; + } + return false; +} + +static void +wp_update_headerless_range(LispObj *start, LispObj *end, + LispObj old, LispObj new) +{ + LispObj *p = start; + + while (p < end) { + wp_maybe_update(p, old, new); + p++; + } +} + +static void +wp_update_range(LispObj *start, LispObj *end, LispObj old, LispObj new) +{ + LispObj *p = start, node; + int tag_n; + natural nwords; + + while (p < end) { + node = *p; + tag_n = fulltag_of(node); + + if (immheader_tag_p(tag_n)) { + p = (LispObj *)skip_over_ivector(ptr_to_lispobj(p), node); + } else if (nodeheader_tag_p(tag_n)) { + nwords = header_element_count(node); + nwords += 1 - (nwords & 1); + + if ((header_subtag(node) == subtag_hash_vector) && + ((((hash_table_vector_header *)p)->flags) & nhash_track_keys_mask)) { + natural skip = hash_table_vector_header_count - 1; + hash_table_vector_header *hashp = (hash_table_vector_header *)p; + + p++; + nwords -= skip; + while(skip--) { + wp_maybe_update(p, old, new); + p++; + } + /* "nwords" is odd at this point: there are (floor nwords 2) + key/value pairs to look at, and then an extra word for + alignment. Process them two at a time, then bump "p" + past the alignment word. */ + nwords >>= 1; + while(nwords--) { + if (wp_maybe_update(p, old, new) && hashp) { + hashp->flags |= nhash_key_moved_mask; + hashp = NULL; + } + p++; + wp_maybe_update(p, old, new); + p++; + } + *p++ = 0; + } else { + if (header_subtag(node) == subtag_function) { +#ifdef X8632 + int skip = (unsigned short)(p[1]); + + /* XXX bootstrapping */ + if (skip & 0x8000) + skip = header_element_count(node) - (skip & 0x7fff); + +#else + int skip = (int)(p[1]); +#endif + p += skip; + nwords -= skip; + } + p++; + while(nwords--) { + wp_maybe_update(p, old, new); + p++; + } + } + } else { + /* a cons cell */ + wp_maybe_update(p, old, new); + p++; + wp_maybe_update(p, old, new); + p++; + } + } +} + +#ifdef X8664 +static void +wp_update_xp(ExceptionInformation *xp, LispObj old, LispObj new) +{ + natural *regs = (natural *)xpGPRvector(xp); + + wp_maybe_update(®s[Iarg_z], old, new); + wp_maybe_update(®s[Iarg_y], old, new); + wp_maybe_update(®s[Iarg_x], old, new); + wp_maybe_update(®s[Isave3], old, new); + wp_maybe_update(®s[Isave2], old, new); + wp_maybe_update(®s[Isave1], old, new); + wp_maybe_update(®s[Isave0], old, new); + wp_maybe_update(®s[Ifn], old, new); + wp_maybe_update(®s[Itemp0], old, new); + wp_maybe_update(®s[Itemp1], old, new); + wp_maybe_update(®s[Itemp2], old, new); + +#if 0 + /* + * We don't allow watching functions, so this presumably doesn't + * matter. + */ + update_locref(&(regs[Iip])); +#endif +} +#else +static void +wp_update_xp(ExceptionInformation *xp, LispObj old, LispObj new, natural node_regs_mask) +{ + natural *regs = (natural *)xpGPRvector(xp); + + if (node_regs_mask & (1<<0)) wp_maybe_update(®s[REG_EAX], old, new); + if (node_regs_mask & (1<<1)) wp_maybe_update(®s[REG_ECX], old, new); + + if (regs[REG_EFL] & EFL_DF) { + /* then EDX is an imm reg */ + ; + } else + if (node_regs_mask & (1<<2)) wp_maybe_update(®s[REG_EDX], old, new); + + if (node_regs_mask & (1<<3)) wp_maybe_update(®s[REG_EBX], old, new); + if (node_regs_mask & (1<<4)) wp_maybe_update(®s[REG_ESP], old, new); + if (node_regs_mask & (1<<5)) wp_maybe_update(®s[REG_EBP], old, new); + if (node_regs_mask & (1<<6)) wp_maybe_update(®s[REG_ESI], old, new); + if (node_regs_mask & (1<<7)) wp_maybe_update(®s[REG_EDI], old, new); + /* we shouldn't watch functions, so no need to update PC */ +} +#endif + +static void +wp_update_tcr_xframes(TCR *tcr, LispObj old, LispObj new) +{ + xframe_list *xframes; + ExceptionInformation *xp; + + xp = tcr->gc_context; + if (xp) { +#ifdef X8664 + wp_update_xp(xp, old, new); +#else + wp_update_xp(xp, old, new, tcr->node_regs_mask); + wp_maybe_update(&tcr->save0, old, new); + wp_maybe_update(&tcr->save1, old, new); + wp_maybe_update(&tcr->save2, old, new); + wp_maybe_update(&tcr->save3, old, new); + wp_maybe_update(&tcr->next_method_context, old, new); +#endif + } + for (xframes = tcr->xframe; xframes; xframes = xframes->prev) { +#ifdef X8664 + wp_update_xp(xframes->curr, old, new); +#else + wp_update_xp(xframes->curr, old, new, xframes->node_regs_mask); +#endif + } +} + +/* + * Scan all pointer-bearing areas, updating all references to + * "old" to "new". + */ +static void +wp_update_all_areas(LispObj old, LispObj new) +{ + area *a = active_dynamic_area; + natural code = a->code; + + while (code != AREA_VOID) { + switch (code) { + case AREA_DYNAMIC: + case AREA_STATIC: + case AREA_MANAGED_STATIC: + case AREA_WATCHED: + wp_update_range((LispObj *)a->low, (LispObj *)a->active, old, new); + break; + case AREA_VSTACK: + { + LispObj *low = (LispObj *)a->active; + LispObj *high = (LispObj *)a->high; + + wp_update_headerless_range(low, high, old, new); + } + break; + case AREA_TSTACK: + { + LispObj *current, *next; + LispObj *start = (LispObj *)a->active, *end = start; + LispObj *limit = (LispObj *)a->high; + + for (current = start; end != limit; current = next) { + next = ptr_from_lispobj(*current); + end = ((next >= start) && (next < limit)) ? next : limit; + wp_update_range(current+2, end, old, new); + } + break; + } + default: + break; + } + a = a->succ; + code = a->code; + } +} + +static void +wp_update_tcr_tlb(TCR *tcr, LispObj old, LispObj new) +{ + natural n = tcr->tlb_limit; + LispObj *start = tcr->tlb_pointer; + LispObj *end = start + (n >> fixnumshift); + + while (start < end) { + wp_maybe_update(start, old, new); + start++; + } +} + +void +wp_update_references(TCR *tcr, LispObj old, LispObj new) +{ + TCR *other_tcr = tcr; + + do { + wp_update_tcr_xframes(other_tcr, old, new); + wp_update_tcr_tlb(other_tcr, old, new); + other_tcr = other_tcr->next; + } while (other_tcr != tcr); + unprotect_watched_areas(); + wp_update_all_areas(old, new); + protect_watched_areas(); +} Index: /branches/new-random/lisp-kernel/x86-macros.s =================================================================== --- /branches/new-random/lisp-kernel/x86-macros.s (revision 13309) +++ /branches/new-random/lisp-kernel/x86-macros.s (revision 13309) @@ -0,0 +1,765 @@ +/* Copyright (C) 2005-2009 Clozure Associates */ +/* This file is part of Clozure CL. */ + +/* Clozure CL is licensed under the terms of the Lisp Lesser GNU Public */ +/* License , known as the LLGPL and distributed with Clozure CL as the */ +/* file "LICENSE". The LLGPL consists of a preamble and the LGPL, */ +/* which is distributed with Clozure CL as the file "LGPL". Where these */ +/* conflict, the preamble takes precedence. */ + +/* Clozure CL is referenced in the preamble as the "LIBRARY." */ + +/* The LLGPL is also available online at */ +/* http://opensource.franz.com/preamble.html */ + + +/* Try to make macros follow GAS/ATT conventions, where source precedes */ +/* destination. */ + +define([lisp_global],[lisp_globals.$1]) + +define([ref_global],[ + __(mov lisp_global($1),$2) +]) + +define([set_global],[ + __(mov $1,lisp_global($2)) +]) + +define([ref_nrs_value],[ + __(mov nrs.$1+symbol.vcell,$2) +]) + +define([set_nrs_value],[ + __(mov $1,nrs.$2+symbol.vcell) +]) + +define([unbox_fixnum],[ + __(mov $1,$2) + __(sar [$]fixnumshift,$2) +]) + +define([box_fixnum],[ + __(imul [$]fixnumone,$1,$2) +]) + + +/* box_fixnum, with no effect on flags */ +define([box_fixnum_no_flags],[ + __(lea (,$1,fixnumone),$2) +]) + + +/* Zero $3 bytes worth of dnodes, starting at offset $2 relative */ +/* to the base register $1. */ + + +ifdef([DarwinAssembler],[ + .macro zero_dnodes + .if $2 + ifdef([X8664],[ + __(movapd %fpzero,$1($0)) + ],[ + __(movsd %fpzero,$1($0)) + ]) + __(zero_dnodes $0,$1+dnode_size,$2-dnode_size) + .endif + .endmacro +],[ + .macro zero_dnodes base,disp,nbytes + .ifgt \nbytes + ifdef([X8664],[ + movapd %fpzero,\disp(\base) + ],[ + movsd %fpzero,\disp(\base) + ]) + zero_dnodes \base,"\disp+dnode_size","\nbytes-dnode_size" + .endif + .endm +]) + + +/* Allocate $1+dnode_size zeroed bytes on the tstack, using $2 as a temp */ +/* reg. */ + +ifdef([X8632],[ +define([TSP_Alloc_Fixed],[ + define([TSP_Alloc_Size],[((($1+node_size) & ~(dnode_size-1))+dnode_size)]) + __(subl [$]TSP_Alloc_Size,rcontext(tcr.next_tsp)) + __(movd rcontext(tcr.save_tsp),%stack_temp) + __(movl rcontext(tcr.next_tsp),$2) + zero_dnodes $2,0,TSP_Alloc_Size + __(movd %stack_temp,($2)) + __(movl %ebp,tsp_frame.save_ebp($2)) + __(movl $2,rcontext(tcr.save_tsp)) + undefine([TSP_Alloc_Size]) +])],[ +define([TSP_Alloc_Fixed],[ + define([TSP_Alloc_Size],[((($1+node_size) & ~(dnode_size-1))+dnode_size)]) + __(subq [$]TSP_Alloc_Size,rcontext(tcr.next_tsp)) + __(movq rcontext(tcr.save_tsp),%stack_temp) + __(movq rcontext(tcr.next_tsp),$2) + zero_dnodes $2,0,TSP_Alloc_Size + __(movq %stack_temp,($2)) + __(movq %rbp,tsp_frame.save_rbp($2)) + __(movq $2,rcontext(tcr.save_tsp)) + undefine([TSP_Alloc_Size]) +])]) + +/* $1 = size (dnode-aligned, including tsp overhead, $2 scratch. */ +/* Modifies both $1 and $2; on exit, $2 = new_tsp+tsp_overhead, $1 = old tsp */ + +ifdef([X8632],[ +define([TSP_Alloc_Var],[ + new_macro_labels() + __(subl $1,rcontext(tcr.next_tsp)) + __(movd rcontext(tcr.save_tsp),%stack_temp) + __(movl rcontext(tcr.next_tsp),$2) + __(jmp macro_label(test)) +macro_label(loop): + __(movsd %fpzero,0($2)) + __(addl $dnode_size,$2) +macro_label(test): + __(subl $dnode_size,$1) + __(jge macro_label(loop)) + __(movl rcontext(tcr.next_tsp),$2) + __(movd %stack_temp,$1) + __(movl $1,($2)) + __(movl %ebp,tsp_frame.save_ebp($2)) + __(movl $2,rcontext(tcr.save_tsp)) + __(addl $dnode_size,$2) +])],[ +define([TSP_Alloc_Var],[ + new_macro_labels() + subq $1,rcontext(tcr.next_tsp) + __(movq rcontext(tcr.save_tsp),%stack_temp) + __(movq rcontext(tcr.next_tsp),$2) + __(jmp macro_label(test)) +macro_label(loop): + __(movapd %fpzero,0($2)) + __(addq $dnode_size,$2) +macro_label(test): + __(subq $dnode_size,$1) + __(jge macro_label(loop)) + __(movq rcontext(tcr.next_tsp),$2) + __(movd %stack_temp,$1) + __(movq $1,($2)) + __(movq %rbp,tsp_frame.save_rbp($2)) + __(movq $2,rcontext(tcr.save_tsp)) + __(addq $dnode_size,$2) +])]) + + +ifdef([X8632],[ +define([Allocate_Catch_Frame],[ + TSP_Alloc_Fixed(catch_frame.size,$1) + __(movl [$](catch_frame.element_count<15),1,[ + __(movl [$]$1< %arg_y %arg_z). */ +_spentry(builtin_gt) + __(movl %arg_y,%imm0) + __(orb %arg_z_b,%imm0_b) + __(testb $fixnummask,%imm0_b) + __(jne 1f) + __(rcmpl(%arg_y,%arg_z)) + __(condition_to_boolean(g,%imm0,%arg_z)) + __(ret) +1: __(jump_builtin(_builtin_gt,2)) +_endsubp(builtin_gt) + +/* %arg_z <- (>= %arg_y %arg_z). */ +_spentry(builtin_ge) + __(movl %arg_y,%imm0) + __(orb %arg_z_b,%imm0_b) + __(testb $fixnummask,%imm0_b) + __(jne 1f) + __(rcmpl(%arg_y,%arg_z)) + __(condition_to_boolean(ge,%imm0,%arg_z)) + __(ret) +1: __(jump_builtin(_builtin_ge,2)) +_endsubp(builtin_ge) + +/* %arg_z <- (< %arg_y %arg_z). */ +_spentry(builtin_lt) + __(movl %arg_y,%imm0) + __(orb %arg_z_b,%imm0_b) + __(testb $fixnummask,%imm0_b) + __(jne 1f) + __(rcmpl(%arg_y,%arg_z)) + __(condition_to_boolean(l,%imm0,%arg_z)) + __(ret) +1: __(jump_builtin(_builtin_lt,2)) +_endsubp(builtin_lt) + +/* %arg_z <- (<= %arg_y %arg_z). */ +_spentry(builtin_le) + __(movl %arg_y,%imm0) + __(orb %arg_z_b,%imm0_b) + __(testb $fixnummask,%imm0_b) + __(jne 1f) + __(rcmpl(%arg_y,%arg_z)) + __(condition_to_boolean(le,%imm0,%arg_z)) + __(ret) +1: __(jump_builtin(_builtin_le,2)) +_endsubp(builtin_le) + +_spentry(builtin_eql) + __(cmpl %arg_y,%arg_z) + __(je 1f) + /* Not EQ. Could only possibly be EQL if both are tag-misc */ + /* and both have the same subtag. */ + __(movl %arg_y,%imm0) + __(andb $tagmask,%imm0_b) + __(cmpb $tag_misc,%imm0_b) + __(jne 2f) + __(movb %arg_z_b,%imm0_bh) + __(andb $tagmask,%imm0_bh) + __(cmpb %imm0_bh,%imm0_b) + __(jne 2f) + __(extract_subtag(%arg_y,%imm0_b)) + __(extract_subtag(%arg_z,%imm0_bh)) + __(cmpb %imm0_b,%imm0_bh) + __(jne 2f) + __(jump_builtin(_builtin_eql,2)) +1: __(movl $t_value,%arg_z) + __(ret) +2: __(movl $nil_value,%arg_z) + __(ret) +_endsubp(builtin_eql) + +_spentry(builtin_length) + __(extract_fulltag(%arg_z,%imm0)) + __(cmpl $tag_list,%imm0) + __(jz 2f) + __(andl $tagmask,%imm0) + __(cmpl $tag_misc,%imm0) + __(jnz 8f) + __(extract_subtag(%arg_z,%imm0_b)) + __(rcmpb(%imm0_b,$min_vector_subtag)) + __(jb 8f) + __(je 1f) + /* (simple-array * (*)) */ + __(movl %arg_z,%arg_y) + __(vector_length(%arg_y,%arg_z)) + __(ret) +1: /* vector header */ + __(movl vectorH.logsize(%arg_z),%arg_z) + __(ret) +2: /* list. Maybe null, maybe dotted or circular. */ + __(movl $-fixnumone,%arg_y) + __(movl %arg_z,%temp0) /* fast pointer */ + __(movl %arg_z,%temp1) /* slow pointer */ +3: __(movb %temp0_b,%al) + __(andb $fulltagmask,%al) + __(addl $fixnumone,%arg_y) + __(compare_reg_to_nil(%temp0)) + __(je 9f) + __(cmpb $fulltag_cons,%al) + __(jne 8f) + __(movb %temp1_b,%ah) + __(andb $fulltagmask,%ah) + __(_cdr(%temp0,%temp0)) + __(testl $fixnumone,%arg_y) + __(je 3b) + __(cmpb $fulltag_cons,%ah) + __(jne 8f) + __(_cdr(%temp1,%temp1)) + __(cmpl %temp0,%temp1) + __(jne 3b) +8: + __(jump_builtin(_builtin_length,1)) +9: + __(movl %arg_y,%arg_z) + __(ret) +_endsubp(builtin_length) + +_spentry(builtin_seqtype) + __(extract_fulltag(%arg_z,%imm0)) + __(cmpb $fulltag_cons,%imm0_b) + __(jz 1f) + __(cmpb $tag_misc,%imm0_b) + __(jne 2f) + __(movb misc_subtag_offset(%arg_z),%imm0_b) + __(rcmpb(%imm0_b,$min_vector_subtag)) + __(jb 2f) + __(movl $nil_value,%arg_z) + __(ret) +1: __(movl $t_value,%arg_z) + __(ret) +2: + __(jump_builtin(_builtin_seqtype,1)) +_endsubp(builtin_seqtype) + +_spentry(builtin_assq) + __(cmpl $nil_value,%arg_z) + __(je 5f) +1: __(movl %arg_z,%imm0) + __(andb $fulltagmask,%imm0_b) + __(cmpb $fulltag_cons,%imm0_b) + __(jne 2f) + __(_car(%arg_z,%temp0)) + __(_cdr(%arg_z,%arg_z)) + __(cmpl $nil_value,%temp0) + __(je 4f) + __(movl %temp0,%imm0) + __(andb $fulltagmask,%imm0_b) + __(cmpb $fulltag_cons,%imm0_b) + __(jne 3f) + __(_car(%temp0,%temp1)) + __(cmpl %temp1,%arg_y) + __(jne 4f) + __(movl %temp0,%arg_z) + __(ret) +4: __(cmpl $nil_value,%arg_z) +5: __(jnz 1b) + __(repret) +2: __(uuo_error_reg_not_list(Rarg_z)) +3: __(uuo_error_reg_not_list(Rtemp0)) +_endsubp(builtin_assq) + +_spentry(builtin_memq) + __(cmpl $nil_value,%arg_z) + __(jmp 3f) +1: __(movb $fulltagmask,%imm0_b) + __(andb %arg_z_b,%imm0_b) + __(cmpb $fulltag_cons,%imm0_b) + __(jne 2f) + __(_car(%arg_z,%temp1)) + __(_cdr(%arg_z,%temp0)) + __(cmpl %temp1,%arg_y) + __(jz 4f) + __(cmpl $nil_value,%temp0) + __(movl %temp0,%arg_z) +3: __(jnz 1b) +4: __(repret) +2: __(uuo_error_reg_not_list(Rarg_z)) +_endsubp(builtin_memq) + +logbitp_max_bit = 30 + +_spentry(builtin_logbitp) + /* Call out unless: both args fixnums, arg_y in [0, logbitp_max_bit) */ + __(movl %arg_z,%imm0) + __(orl %arg_y,%imm0) + __(testb $fixnummask,%imm0_b) + __(jnz 1f) + __(unbox_fixnum(%arg_y,%imm0)) + __(js 1f) /* bit number negative */ + __(addb $fixnumshift,%imm0_b) + __(cmpl $logbitp_max_bit<

2005-09-27		Small change for compatibility with future OpenMCL versions (thanks to Bryan O'Connor)
2005-07-14		Updated note about CLISP (thanks to Henri Lenzi)
2005-06-01		Added proxy authentication code (thanks to Sean Ross)
2005-02-16		More OpenMCL details (thanks to Jim Thompson)
2004-12-29		Added COPYRIGHT file to distribution
2004-09-13		Added information about AllegroCL 7.0 and OpenMCL 0.14.1
2004-09-08		Fixed typo in `GET-ENV-VAR` and added special variable `GNU-TAR-PROGRAM` (both thanks to Raymond Toy)
2004-05-20		Changed hyphens to underlines in names of environment variables (thanks to Robert P. Goldman)
2004-05-19		Mentioned Alex Mizrahi's notes, added version number for MK:DEFSYSTEM in docs and SPLIT-SEQUENCE dependency in ASDF system definition (thanks to Robert P. Goldman and Robert Lehr)
2004-04-28		Fixed `asdf-install.asd` so that it still works and you're not forced to use `load-asdf-install.lisp`
2004-04-25		MK:DEFSYSTEM clarification
2004-04-24		Patches by Marco Antoniotti for MK:DEFSYSTEM compatibility
2004-03-27		Bugfixes by Kiyoshi Mizumaru
2004-01-28		Improved MCL support (James Anderson)
2004-01-21		Support for MCL by James Anderson
2004-01-16		Minor edits, Cygwin CLISP support, download location for `asdf.fas`
2004-01-15		Preliminary Windows support, described how to uninstall a library, added `PREFERRED-LOCATION`, removed `ln` bug in CLISP code
2004-01-13		Mentioned OpenMCL support (Marco Baringer), added some SBCL exceptions, added clarification about Windows, minor edits, changes by Dan Barlow
2004-01-12		Initial version

Portable Hemlock

Download

CVS access

News/History

Random Notes

Future

The (still preliminary) Cocoa-based development environment for OpenMCL

General information

Random technical issues & to-do list

Lisp-awareness

Modularity

OpenMCL Help

TRIVIAL-LDAP v0.91

WARNING:

Introduction

Changes

Acknowledgments

License

Requirements

Limitations

API

Clozure CL Documentation

ChapterÂ 1.Â About Clozure CL

1.1.Â Introduction to Clozure CL

ChapterÂ 2.Â Obtaining, Installing, and Running Clozure CL

2.1.Â Releases and System Requirements

2.1.1.Â LinuxPPC

2.1.2.Â Linux x86

2.1.3.Â FreeBSD x86

2.1.4.Â Mac OS X (ppc and x86)

2.2.Â Obtaining Clozure CL

2.2.1.Â The Mac Way

2.2.2.Â Getting Clozure CL with Subversion

2.2.2.1.Â Checking Subversion Installation

2.2.3.Â Tarballs

2.3.Â Command Line Set Up

2.3.1.Â The ccl Shell Script

Warning

2.3.2.Â Invocation

2.4.Â Personal Customization with the Init File

2.5.Â Command Line Options

2.6.Â Using Clozure CL with GNU Emacs and SLIME

2.6.1.Â Assumptions and Requirements

2.6.2.Â Getting SLIME

2.6.3.Â Installing SLIME

2.6.4.Â Telling Emacs About SLIME

Warning

2.6.5.Â Running Clozure CL with SLIME

2.6.6.Â What if a New Version of Clozure CL Breaks SLIME?

2.6.7.Â Known Bugs

2.7.Â Example Programs

ChapterÂ 3.Â Building Clozure CL from its Source Code

3.1.Â Building Definitions

3.1.1.Â Platform-specific filename conventions

3.2.Â Setting Up to Build

3.3.Â Building Everything

3.4.Â Building the kernel

3.4.1.Â Kernel build prerequisites

Note

3.4.2.Â Using "make" to build the lisp kernel

3.5.Â Building the heap image

3.5.1.Â Development cycle

3.5.2.Â Generating a bootstrapping image

3.5.3.Â Generating fasl files

3.5.4.Â Building a full image from a bootstrapping image

ChapterÂ 4.Â Using Clozure CL

4.1.Â Introduction

4.2.Â Trace

4.3.Â Unicode

4.3.1.Â Characters

4.3.2.Â External Formats

4.3.3.Â Line Termination Keywords

4.3.4.Â Character Encodings

4.3.4.1.Â Encoding Problems

4.3.4.2.Â Byte Order Marks

4.3.4.3.Â DESCRIBE-CHARACTER-ENCODINGS

4.3.4.4.Â Supported Character Encodings

4.3.4.5.Â Encoding and Decoding Strings

4.4.Â Pathnames

4.4.1.Â Pathname Expansion