changeset 0:95785e4bcc1b

moved from darcs repo
author John Leuner <jewel@subvert-the-dominant-paradigm.net>
date Fri, 25 Apr 2008 02:54:05 +0530
parents
children 465aac549a11
files Emakefile README erlang/slurp.hrl erlang/slurp_decode.erl erlang/slurp_encode.erl javascript/slurp.js lisp/slurp.asd lisp/slurp.lisp
diffstat 8 files changed, 1048 insertions(+), 0 deletions(-) [+]
line wrap: on
line diff
--- /dev/null	Thu Jan 01 00:00:00 1970 +0000
+++ b/Emakefile	Fri Apr 25 02:54:05 2008 +0530
@@ -0,0 +1,2 @@
+['erlang/*'].
+{'*',[debug_info]}.
--- /dev/null	Thu Jan 01 00:00:00 1970 +0000
+++ b/README	Fri Apr 25 02:54:05 2008 +0530
@@ -0,0 +1,1 @@
+Slurp is an object serialization library, currently implemented for Common Lisp, Erlang and Javascript.
--- /dev/null	Thu Jan 01 00:00:00 1970 +0000
+++ b/erlang/slurp.hrl	Fri Apr 25 02:54:05 2008 +0530
@@ -0,0 +1,24 @@
+-define(Byte, 1).
+-define(Unsigned_integer, 2).
+-define(Unicode_string, 4).
+-define(Cons, 7).
+-define(KeyValue, 8).
+-define(Nil, 9).
+-define(Object, 10).
+-define(Array_Mask, 16).
+
+-define(Byte_array, ?Array_Mask bor ?Byte).
+-define(Utf_8_array, ?Array_Mask bor ?Utf_8).
+-define(KeyValue_array, ?Array_Mask bor ?KeyValue).
+-define(Object_array, ?Array_Mask bor ?Object).
+
+
+
+-define(MarshalDirective, 0).
+-define(MarshalDirective_LoadStateDescriptor, 2).
+
+-define(Has_Named_Slots, 1).
+-define(StateDescriptorBase, 64).
+
+-record(state_descriptor, {code, shape, package_string, name, slots}).
+
--- /dev/null	Thu Jan 01 00:00:00 1970 +0000
+++ b/erlang/slurp_decode.erl	Fri Apr 25 02:54:05 2008 +0530
@@ -0,0 +1,117 @@
+-module(slurp_decode).
+-include("slurp.hrl").
+-export([ read_object/0 ]).
+
+read_object( ) -> ClassCode = read_unsigned_integer(),
+		  %log:log("handling type ~p", [ClassCode]),
+					 if (ClassCode == 0) ->
+						 "load meta",
+						 MarshalCode = read_unsigned_integer(),
+						 case MarshalCode of
+						     ?MarshalDirective_LoadStateDescriptor -> StateDescriptor = read_state_descriptor(),
+									       put(state_descriptors, dict:store( StateDescriptor#state_descriptor.code,
+														  StateDescriptor, get(state_descriptors))),
+									       read_object()
+						 end;
+					    true -> read_datum(ClassCode)
+					 end.
+
+read_state_descriptor() ->
+    Code = read_unsigned_integer(),
+    Shape = read_unsigned_integer(),
+    PackageString = read_unicode_string(),
+    Name = list_to_atom(read_unicode_string()),
+    SlotCount = read_unsigned_integer(),
+    Slots = case SlotCount of
+		0 -> [];
+		_Else -> lists:map( fun(Item) -> read_unicode_string() end, lists:seq(1, SlotCount))
+	    end, 
+    %log:log("read state descriptor ~p", [Name]),
+    #state_descriptor { code = Code,
+			shape = Shape,
+			package_string = PackageString,
+			name = Name,
+			slots = Slots }.
+
+read_datum(Type) ->    
+    case Type of 
+	?Byte_array -> read_byte_array();
+	?Unsigned_integer -> read_unsigned_integer();
+	?Unicode_string -> read_unicode_string();
+%	?Utf_8_array -> read_utf8_array();
+%	?Utf_8 -> read_utf8();
+	?Cons -> read_cons( );
+	?KeyValue_array -> read_key_value_array( );
+	?KeyValue -> read_key_value( );
+	?Object -> read_object();
+	?Object_array -> read_object_array();
+	?Nil -> [];
+	_Else -> if Type >= ?StateDescriptorBase -> read_object_state( dict:fetch(Type, get(state_descriptors)));
+		    true -> throw("unknown type") %abort
+		 end
+    end.
+
+read_object_state( StateDescriptor ) -> 
+    Tuple_items = [ StateDescriptor#state_descriptor.name | lists:map( fun(SlotName) ->
+									      read_object( ) end, StateDescriptor#state_descriptor.slots)],
+    Record = list_to_tuple(Tuple_items),
+    Record.
+    
+read_datums(_, 0) -> [];
+read_datums( Type, Count ) -> Obj = read_datum( Type),
+				    [Obj] ++ read_datums( Type, Count - 1 ).
+
+
+read_unicode_string() ->    
+    Length = read_unsigned_integer(),
+    read_datums(?Unsigned_integer, Length).
+
+read_byte_array() ->
+    Length = read_unsigned_integer(),
+    %log:log("read byte array ~p", [Length]),
+    list_to_binary(read_bytes(Length)).
+
+read_bytes(0) -> [];
+read_bytes(Count) -> [apply(get(reader_function), []) | read_bytes(Count - 1)].
+		
+     
+read_object_array() ->
+    Dimensions = read_cons(),
+    if length(Dimensions) == 1 ->
+	    list_to_tuple(read_datums(?Object, element(1, Dimensions)));
+       true ->
+	    throw("unhandled object array with dimension size != 1" ++ Dimensions)
+    end.
+
+read_string() ->
+    Length = read_unsigned_integer(),
+    read_datums(?Unsigned_integer, Length).
+
+read_symbol_array() ->
+    Length = read_unsigned_integer(),
+    list_to_atom(read_datums(?Unsigned_integer, Length)).
+
+read_cons( ) ->
+    A = read_object( ),
+    B = read_object( ),
+    [A | B].
+
+read_key_value( ) ->
+    A = read_object( ),
+    B = read_object( ),
+    { A, B }.
+
+read_key_value_array( ) ->
+    Length = read_unsigned_integer(),
+    Datums = read_datums( ?KeyValue, Length),
+    dict:from_list(Datums).
+
+read_unsigned_integer() ->
+     read_unsigned_integer(1).
+
+read_unsigned_integer( Multiplier) -> Byte = apply(get(reader_function), []),
+				      %io:format("byte is ~p~n", [Byte]),
+				      <<HighBit:1, LowBits:7>> = Byte,
+				      if HighBit == 1 -> (Multiplier * LowBits) + read_unsigned_integer( Multiplier * 128);
+					 true-> (Multiplier * LowBits)
+				      end.
--- /dev/null	Thu Jan 01 00:00:00 1970 +0000
+++ b/erlang/slurp_encode.erl	Fri Apr 25 02:54:05 2008 +0530
@@ -0,0 +1,126 @@
+-module(slurp_encode).
+-include("slurp.hrl").
+-export([write_object/1]).
+
+
+map_outbound_object(Object) ->
+    RecordDescriptions = get(record_descriptions),
+    case Object of 
+	Object when (is_tuple(Object) and size(Object) >= 1) and (element(1, Object) == slurp_string) ->
+	    write_integer(?Unicode_string),
+	    write_unicode_string(element(2,Object)),
+	    { mapped, Object };
+	Object when (is_list(Object) and (length(Object) > 0)) ->
+	    IsAString = lists:all( fun(X) -> is_integer(X) end, Object),
+	    if IsAString ->
+		    write_integer(?Unicode_string),
+		    write_unicode_string(Object),
+		    { mapped, Object };
+	       true -> { unmapped, Object }
+	    end;
+	Object when (is_tuple(Object) and (size(Object) >= 1) and is_atom(element(1,Object))) ->
+	    RecordName = list_to_atom(replaceDashWithUnderscore(atom_to_list(element(1, Object)))),
+	    %log:log("finding ~p in ~p", [RecordName, RecordDescriptions]),
+	    IsARecord = dict:find(RecordName, RecordDescriptions),
+%	    io:format("isarecord ~p ~p~n", [RecordName, IsARecord]),
+	    case IsARecord of
+		{ ok, RecordFieldNames } -> { write_record, RecordName, RecordFieldNames, Object}; 
+		error -> { unmapped, Object }
+	    end;
+	_Else -> %yio:format("else ~p ~p ~p ~p ~n",[is_tuple(Object), size(Object), element(1,Object), Object]),
+		 { unmapped, Object }
+    end.
+
+replaceDashWithUnderscore(String) ->
+    lists:map( fun(Char) -> case Char of
+				$- -> $_;
+				_ -> Char
+			    end
+	       end,
+	       String).
+
+replaceUnderscoreWithDash(String) ->
+    lists:map( fun(Char) -> case Char of
+				$_ -> $-;
+				_ -> Char
+			    end
+	       end,
+	       String).
+
+write_object(Object) ->
+  %log:log("writing object ~p~n", [ Object ]),
+    case map_outbound_object(Object) of
+	{unmapped, MappedObject} ->
+	    case MappedObject of
+		[] -> write_integer( ?Nil);
+		MappedObject when is_binary(MappedObject) -> write_integer( ?Byte_array),
+							     write_byte_array( MappedObject);
+		MappedObject when is_integer(MappedObject) -> write_integer( ?Unsigned_integer),
+							      write_integer( MappedObject);
+		MappedObject when is_list(MappedObject) -> write_integer( ?Cons),
+							   write_cons( MappedObject);
+		MappedObject when is_tuple(MappedObject) -> write_integer( ?Object_array),
+							    write_object_array( MappedObject);
+		MappedObject when is_atom(MappedObject) -> write_integer( ?Unicode_string),
+							   write_unicode_string( atom_to_list(MappedObject));
+		_Else  -> log:log("cannot encode ~p", [MappedObject]),
+				  throw("unhandled " ++ MappedObject)
+	    end;
+	{mapped, _ } -> Object;
+	{write_record, RecordName, RecordFieldNames, Record} -> %io:format("writing record~n",[]),
+								write_record(RecordName, RecordFieldNames, Record)
+    end.
+
+write_record(RecordName, RecordFieldNames, Record) ->
+    write_integer(?MarshalDirective),
+    write_integer(?MarshalDirective_LoadStateDescriptor),
+    DescriptorCode = getNextStateDescriptorCode(),
+    write_integer(DescriptorCode),
+    write_integer(?Has_Named_Slots), 
+    write_unicode_string("furax"),
+    write_unicode_string(replaceUnderscoreWithDash(atom_to_list(RecordName))),
+    write_integer( length(RecordFieldNames) ),
+    lists:foreach( fun(F) ->
+			   write_unicode_string(replaceUnderscoreWithDash(atom_to_list(F))) end, RecordFieldNames),
+    write_integer(DescriptorCode),
+    lists:foreach( fun write_object/1, tl(tuple_to_list(Record))).
+    
+
+write_symbol( String_as_atom) ->
+    CharList = atom_to_list(String_as_atom),
+    write_integer( length(CharList)),
+    lists:foreach( fun write_integer/1, CharList).
+
+write_unicode_string( String) ->
+    %io:format("wus ~p~n", [String]),
+    write_integer( length(String)),
+    lists:foreach( fun write_integer/1, String).
+
+
+write_byte_array( Binary) ->
+    write_integer( size(Binary)),
+    write_bytes( Binary).
+		  
+write_bytes( <<>>) -> ok;
+write_bytes( <<Byte:8,Rest/binary>>) -> apply(get(writer_function), [<<Byte>>]),
+						      write_bytes( Rest).
+    
+write_byte( Byte) ->
+    apply(get(writer_function), [Byte]).
+
+write_object_array( Tuple) ->
+    write_cons( [ size(Tuple) ] ),
+    lists:foreach(fun write_object/1, tuple_to_list(Tuple)).
+
+write_integer( Integer) when Integer >= 128 -> apply(get(writer_function), [ <<((Integer rem 128) + 128):8>> ]),
+					       write_integer( Integer div 128);
+write_integer( Integer) -> apply(get(writer_function), [ <<Integer:8>> ]).
+
+write_cons( [A|B]) ->
+    write_object( A),
+    write_object( B).
+	    
+getNextStateDescriptorCode() ->	  
+    Code = get(next_state_descriptor),
+    put(next_state_descriptor, Code + 1),
+    Code.
--- /dev/null	Thu Jan 01 00:00:00 1970 +0000
+++ b/javascript/slurp.js	Fri Apr 25 02:54:05 2008 +0530
@@ -0,0 +1,316 @@
+var slurp_state_descriptor_map = new Object();
+
+function slurp_error(message) {
+    this.message = message;
+    console.warn("slurp error %s", message);
+}
+
+function slurp_Nil() {}
+function slurp_Cons(A, B) { this.A = A; this.B = B;}
+
+slurp_Cons.prototype['SLURP_TYPE'] = "SLURP_CONS";
+
+var reader_function = null;
+
+function string_to_array(str) {
+    var array = new Array();
+    var len = str.length;
+    for(var c = 0; c < len; c++) {
+	array[c] = str.charCodeAt(c);
+    }
+    return array;
+}
+
+function slurp_decode(encoded_string) {
+    if (encoded_string == "") {
+	return null;
+    }
+    var array = string_to_array(encoded_string);
+    return slurp_decode_array ( array );
+}
+
+function slurp_decode_array(byteArray) {
+    var read_index = -1;
+    
+    reader_function = function () {
+	read_index++;
+	var byte = byteArray[read_index];
+//	console.log("b %s", byte);
+	return byte;
+    };
+    var obj = slurp_read_object();
+    return obj;
+}
+
+function slurp_read_object() {
+    var classCode = 0;
+    while( (classCode = slurp_read_unsigned_int()) == 0) {
+	var marshalDirective = slurp_read_unsigned_int();
+	switch (marshalDirective) {
+	    case slurp_marshal_directive_load_state_descriptor: slurp_read_state_descriptor(); break;
+	   default: return new slurp_error("can't handle marshal dir");
+	}
+    }
+//    console.log("reading datum class code %s" , classCode);
+    return slurp_read_datum(classCode);
+}
+
+var slurp_marshal_directive = 0;
+var slurp_marshal_directive_load_state_descriptor = 2;
+
+var slurp_array_mask = 16;
+
+var slurp_byte = 1;
+var slurp_unsigned_integer = 2;
+var slurp_unicode_string = 4;
+var slurp_cons = 7;
+var slurp_nil = 9;
+var slurp_object = 10;
+
+var slurp_byte_array = slurp_byte + slurp_array_mask;
+var slurp_object_array = slurp_object + slurp_array_mask;
+
+function slurp_read_unsigned_int() {
+    var readValue, answer = 0, shifter = 1;
+    var finished = 0;
+    //    var count = 5;
+    while(finished != 1) {
+	readValue = reader_function();
+	//	writeError("read val is " + readValue, true);
+	if (readValue < 128) {
+	    finished = 1;
+	}
+	if(finished != 1) {
+	    readValue = readValue - 128;
+	}
+	answer = answer + (readValue * shifter);
+	shifter = shifter * 128;
+	//	count--;
+	//	if (count == 0) return "FAILED";
+    }
+    return answer;
+}
+
+function slurp_read_datum(classCode) {
+    switch(classCode) {
+    case slurp_unsigned_integer:
+	return slurp_read_unsigned_int();
+    case slurp_unicode_string:
+	return slurp_read_unicode_string();
+    case slurp_cons:
+	return slurp_read_cons();
+    case slurp_nil:
+	return null;
+    case slurp_byte_array:
+	return slurp_read_byte_array();
+    case slurp_object_array:
+	return slurp_read_object_array();
+    default:
+	if (classCode >= 64) {
+	    return slurp_read_state_object(classCode);
+	}
+    }
+    return new slurp_error("read invalid class code " + classCode);
+}
+
+function slurp_read_byte_array() {
+	var length = slurp_read_unsigned_int();
+	var array = new Array();
+	for(var i = 0; i < length; i++) {
+	    array[i] = reader_function(); 
+	}	
+  return array;
+}
+
+function slurp_read_object_array() {
+	var dimensions = slurp_read_cons();
+	dimensions = slurp_cons_to_list(dimensions);
+	if (dimensions.length != 1) {
+		var SlurpError = new Error("bad dimensions read in read_object_array");
+		throw SlurpError;
+	}
+	var array = new Array();
+//	console.log("reading array length %s", dimensions[0]);
+	for(var i = 0; i < dimensions[0]; i++) {
+	 array[i] = slurp_read_object();
+//	console.log("at %s read %s", i, Dumper(array[i]));
+	}	
+  return array;
+}
+
+function slurp_read_cons() {
+    var A = slurp_read_object();
+    var B = slurp_read_object();
+//	Dumper.popup(B);
+//	console.log("tail is null %s %s", B, B == null);
+    return new slurp_Cons(A, B);
+}
+
+function slurp_cons_to_list(cons) {
+    var acc = new Array();
+    walk_cons_helper(cons, acc);
+    return acc.reverse();	
+}
+
+function walk_cons_helper(cons, acc) {
+    if( cons instanceof slurp_Cons ) {
+	//	writeError("A is " + cons.A + "<br/>",true);
+	acc.push(cons.A); 
+	walk_cons_helper( cons.B, acc);
+    }
+}
+
+function slurp_read_unicode_string() {
+    var length = slurp_read_unsigned_int();
+    var result = "";
+    for(var i = 0; i < length; i++) {
+	result = result + String.fromCharCode( slurp_read_unsigned_int());
+    }
+//    console.log("read unicode %s", result);
+    return result;
+}
+
+
+function slurp_read_state_descriptor() {
+    var code = slurp_read_unsigned_int();
+    var shape = slurp_read_unsigned_int();
+    var package_string = slurp_read_unicode_string();
+    var name = slurp_read_unicode_string();
+    var slot_count = slurp_read_unsigned_int();
+    var slots = new Array();
+    for(var i = 0; i < slot_count; i++) {
+	slots[i] = slurp_read_unicode_string();
+    }
+    var sd = new state_descriptor(code, shape, package_string, name, slot_count, slots);
+    slurp_state_descriptor_map[ '' + code ] = sd;
+//    console.log("read state desc %s", Dumper.popup(sd));
+    return sd;
+}
+
+function state_descriptor(code, shape, package_string, name, slot_count, slots) {
+    this.code = code;
+    this.shape = shape;
+    this.package_string = package_string;
+    this.name = name;
+    this.slot_count = slot_count;
+    this.slots = slots;
+    return this;
+}
+
+function slurp_read_state_object(classCode) {
+    var sd = slurp_state_descriptor_map[ classCode ];
+    if (sd == null)
+	return new slurp_error("missing state descriptor for class " + classCode);
+    var obj = new Object();
+    for(var i = 0; i < sd.slot_count; i++)
+	{
+	    obj[ sd.slots['' + i ] ] = slurp_read_object();
+	}
+    obj["SLURP_TYPE"] = sd.name;	
+	//   console.log("loaded %s object", sd.name);
+    return obj;
+}
+
+var last_class_code = 64;
+
+var writer_function = null;
+
+function slurp_encode(obj) {
+ var outputArray = new Array();
+ writer_function = function (newByte) {
+     outputArray.push(newByte);
+ }
+ slurp_write_object(obj);
+
+return String.fromCharCode.apply( null, outputArray);
+}
+
+function slurp_write_object(obj) {
+  if (typeof(obj) == "number") {
+	slurp_write_unsigned_int(slurp_unsigned_integer);
+	slurp_write_unsigned_int(obj);
+  }
+  else if(typeof(obj) == "string") {
+	slurp_write_unsigned_int(slurp_unicode_string);
+	slurp_write_unicode_string(obj);
+  }
+  else if ((obj == null) || (obj == undefined)) { 
+//		  console.log("writing %s", obj);
+//		  debugger;	
+		  slurp_write_unsigned_int(slurp_nil);
+  }
+  else {	
+  var type = obj['SLURP_TYPE'];
+  if (type == 'undefined') {
+	console.log('type of ' + obj + ' is undefined');
+	}
+	else if (type == "SLURP_CONS") {
+	  slurp_write_unsigned_int(slurp_cons);
+	  slurp_write_object( obj.A );
+	  slurp_write_object( obj.B );
+	} else {
+	  var slots = new Array();
+	  for (var property in obj) {
+	    if (!((property == 'SLURP_TYPE') || (property == 'SLURP_PACKAGE'))) {
+	 	   slots.push(property);
+		}
+	  }
+	  var sd = new state_descriptor(last_class_code++, 1, obj['SLURP_PACKAGE'], type, slots.length, slots);
+
+	  slurp_write_unsigned_int( slurp_marshal_directive );
+	  slurp_write_unsigned_int( slurp_marshal_directive_load_state_descriptor );
+
+	  slurp_write_state_descriptor(sd);
+	  slurp_write_state_object(sd, obj);
+	}
+   }
+}
+
+function slurp_write_state_descriptor(sd) {
+	with(sd) {
+		slurp_write_unsigned_int(code);
+		slurp_write_unsigned_int(shape);
+	        slurp_write_unicode_string(package_string);
+		slurp_write_unicode_string(name);
+		slurp_write_unsigned_int(slot_count);
+
+		for (var idx = 0; idx < slot_count; idx++) {
+		  slurp_write_unicode_string(slots[idx]);
+		}	
+	}	
+}
+
+function slurp_write_state_object(sd, obj) {
+//	 console.log("writing object %s", obj);
+//	 Dumper.popup(obj);
+	slurp_write_unsigned_int(sd.code);
+	for (var idx = 0; idx < sd.slot_count; idx++) {
+	 var slot = sd.slots[idx];
+	// console.log("writing slot %s with %s", slot, obj[slot]);
+	 slurp_write_object( obj[slot] );
+	}
+}
+
+//or use Math.floor instead of parseInt
+
+function slurp_write_unsigned_int(num) {
+	var carry = parseInt(num / 128);
+	var writeValue = (num % 128);
+	while (carry != 0) {
+	 writer_function (writeValue + 128);
+	 writeValue = carry % 128;
+	 carry = parseInt(carry / 128);
+	}
+	writer_function(writeValue);
+}
+
+function slurp_write_unicode_string(str) {
+//	console.log("writing %s", str);
+	var len = str.length;
+	slurp_write_unsigned_int(len);
+	for (var c = 0; c < len; c++) {
+	  slurp_write_unsigned_int( str.charCodeAt(c));
+	}
+}
+
+
--- /dev/null	Thu Jan 01 00:00:00 1970 +0000
+++ b/lisp/slurp.asd	Fri Apr 25 02:54:05 2008 +0530
@@ -0,0 +1,8 @@
+(defsystem slurp
+  :description "SLURP"
+  :version "0.01"
+  :author "John Leuner"
+  :licence "MIT License"
+  :components ((:file "slurp" ))
+  :depends-on (flexi-streams))
+
--- /dev/null	Thu Jan 01 00:00:00 1970 +0000
+++ b/lisp/slurp.lisp	Fri Apr 25 02:54:05 2008 +0530
@@ -0,0 +1,454 @@
+(defpackage #:slurp
+  (:use #:cl  :flexi-streams)
+  (:export :writer :reader :decode :encode :make-slurp-writer :make-slurp-reader)
+)
+(defpackage #:test-slurp
+  (:use #:cl :slurp))
+
+(in-package :slurp)
+
+(declaim (optimize (speed 0) (safety 3) (debug 3)))
+
+(defconstant +byte+ 1)
+(defconstant +unsigned-integer+ 2)
+(defconstant +signed-integer+ 3)
+(defconstant +unicode-string+ 4)
+(defconstant +cons+ 7)
+(defconstant +key-value+ 8)
+(defconstant +nil+ 9)
+(defconstant +object+ 10) ; used for object array
+
+(defconstant +array-mask+ 16)
+
+(defconstant +byte-array+ (logior +byte+ +array-mask+))
+(defconstant +key-value-array+ (logior +key-value+ +array-mask+))
+(defconstant +object-array+ (logior +object+ +array-mask+)) 
+
+(defconstant +state-descriptor-base+ 64) ; all state descriptors have a code greater than or equal to this
+
+(defconstant +marshal-directive+ 0)
+
+(defconstant +marshal-directive-load-relative-offset+ 1) ; directive to load an object that has already been loaded previously
+(defconstant +marshal-directive-load-metastate+ 2) ; directive to load a metastate description from the stream
+(defconstant +marshal-directive-skip-bytes+ 3) ; directive to load an array of bytes and ignore them
+(defconstant +marshal-directive-ignore-object+ 3) ; directive to load an object from the stream, but ignore it
+
+(defconstant HAS-NAMED-SLOTS 1)
+(defconstant HAS-TYPED-NAMED-SLOTS 2)
+(defconstant HAS-INDEXED-PART 4)
+(defconstant HAS-VERSION-NUMBER-ARRAY 8)
+(defconstant IS_STATELESS 16)
+(defconstant IS_NAMED 32)
+(defconstant IS_TYPED 64)
+
+(defclass state-descriptor () ((code :initarg :code :reader code)
+			       (shape :initarg :shape :reader shape)
+			       (package-string :initarg :package-string :reader package-string)
+			       (name :initarg :name :reader name)
+			       (named-slots :initarg :named-slots :reader named-slots)))
+
+(defgeneric has-named-slots (state-descriptor))
+(defmethod has-named-slots ((state-descriptor state-descriptor))
+  (not (null (named-slots state-descriptor))))
+
+(defclass placeholder () ((base-object :initarg :base-object :accessor base-object)))
+
+(defclass writer ()
+  ((lisp-stream :initarg :stream :accessor lisp-stream)
+   (save-stack :initform (make-array 10 :adjustable t :fill-pointer 0) :accessor save-stack)
+   (state-descriptors :initform (make-hash-table) :accessor state-descriptors)))
+
+(defclass reader ()
+  ((lisp-stream :initarg :stream :accessor lisp-stream)
+   (load-stack :initform (make-array 10 :adjustable t :fill-pointer 0) :accessor load-stack)
+   (state-descriptors :initform (make-hash-table) :accessor state-descriptors)))
+
+(defclass input-stream () ())
+
+(defgeneric slurp-type (object))
+(defgeneric read-datum (stream type-indicator))
+(defgeneric write-datum (stream type-indicator object))
+
+(defgeneric make-slurp-input-stream (underlying))
+(defgeneric make-slurp-output-stream (underlying))
+
+(defun make-slurp-reader (stream)
+  (make-instance 'reader :stream stream))
+
+(defun make-slurp-writer (stream)
+  (make-instance 'writer :stream stream))
+
+(defun decode (buffer)
+  (let* ((reader (make-slurp-reader (flexi-streams:make-in-memory-input-stream buffer))))
+    (read-object reader)))
+
+(defun encode (object)
+  (let* ((writer (make-slurp-writer (flexi-streams:make-in-memory-output-stream))))
+    (write-object writer object)
+    (flexi-streams:get-output-stream-sequence (lisp-stream writer))))
+
+(defvar *writer*)
+(defvar *save-stack*)
+
+(defvar *reader*)
+(defvar *load-stack*)
+(defvar *state-descriptors*)
+
+(defgeneric discard-placeholders (placeholder-or-object recursion-set))
+; reading and writing lisp objects from a slurp stream
+(defgeneric read-object (reader))
+(defgeneric write-object (writer object))
+
+(defmethod read-object ((reader reader))
+  (let* ((stream (lisp-stream reader))
+	 (*reader* reader)
+	 (*load-stack* (load-stack reader))
+	 (*state-descriptors* (state-descriptors reader))
+	 (placeholder (do ((class-code (read-datum stream +unsigned-integer+)
+				       (read-datum stream +unsigned-integer+)))
+		     ((not (eq class-code 0)) (read-datum stream class-code))
+		   (let ((marshal-directive (read-datum stream +unsigned-integer+)))
+		     (cond ((eq marshal-directive +marshal-directive-load-metastate+) 
+			    (let ((state-descriptor (read-state-descriptor stream)))
+			      ;(break state-descriptor)
+			      (setf (gethash (code state-descriptor) *state-descriptors*) state-descriptor)
+			      ))
+			   (t (error (format nil "unknown marshal directive ~A ~A" marshal-directive +marshal-directive-load-metastate+)))
+			   )
+		     ))))
+    (discard-placeholders  placeholder (make-hash-table))))
+
+(defmethod read-object :around ((reader reader))
+  (let ((foo (call-next-method reader)))
+    ;    (format t "ro ~A~%" foo)
+    foo))
+
+ (defmethod write-object ((writer writer) object)
+  (let ((stream (lisp-stream writer))
+	(*writer* writer)
+	(*state-descriptors* (state-descriptors writer)))
+    (if (null object)
+	  (write-datum stream +unsigned-integer+ +nil+)
+	  (typecase object
+	    (cons (progn (write-datum stream +unsigned-integer+ +cons+)
+			 (write-datum stream +cons+ object)
+			 ))
+	    (integer (progn (write-datum stream +unsigned-integer+ +unsigned-integer+)
+			    (write-datum stream +unsigned-integer+ object)))
+	    (symbol (progn (write-datum stream +unsigned-integer+ +unicode-string+)
+			   (write-datum stream +unicode-string+ (string object))))
+	    (string (progn (write-datum stream +unsigned-integer+ +unicode-string+)
+			   (write-datum stream +unicode-string+ object)))
+	    (hash-table (progn (write-datum stream +unsigned-integer+ +key-value-array+)
+			       (write-datum stream +unsigned-integer+ (hash-table-count object))
+			       (loop for k being the hash-keys in object using (hash-value v) 
+				     do (write-datum writer +key-value+ (cons k v)))))
+	    ((vector (unsigned-byte 8)) (progn (write-datum stream +unsigned-integer+ +byte-array+)
+					       (write-datum stream +unsigned-integer+ (length object))
+					       (write-sequence object stream)))
+	    ((vector t) 
+	     (progn
+	       (write-datum stream +unsigned-integer+ +object-array+)
+	       (write-datum stream +object-array+ object)))
+	     ((simple-array t) 
+	      (progn
+		(write-datum stream +unsigned-integer+ +object-array+)
+		(write-datum stream +object-array+ object)))
+	    (t (let ((state-descriptor (find-state-descriptor-by-class (class-of object))))
+		 (when (null state-descriptor)
+;		   (format t "could not find sd for obj ~A of class ~A~%" object (class-of object))
+		   (setf state-descriptor (make-state-descriptor (class-of object)))
+		   (write-state-descriptor stream state-descriptor))
+		 (write-datum stream +unsigned-integer+ (code state-descriptor))
+		 (write-datum stream state-descriptor object)
+		 ))))))
+
+(defmethod discard-placeholders ((placeholder placeholder) recursion-set)
+  (let ((lookup (gethash placeholder recursion-set)))
+    (if lookup
+	(base-object placeholder)
+	(progn 
+	  (setf (gethash placeholder recursion-set) placeholder)
+	  (discard-placeholders (base-object placeholder) recursion-set)))))
+
+(defmethod discard-placeholders ((object t) recursion-set)
+  (let ((lookup (gethash object recursion-set)))
+    (if lookup
+	object
+	(let* ((class (class-of object))
+	       (slots (sb-pcl:class-slots class)))
+	  (setf (gethash object recursion-set) object)
+	  (loop for s in slots do (let ((name (sb-pcl:slot-definition-name s)))
+				    (setf (slot-value object name) 
+					  (discard-placeholders (slot-value object name) recursion-set))))
+	  object))))
+
+(defun make-state-descriptor (class)
+  (let* ((code (+ 1 (hash-table-count *state-descriptors*) +state-descriptor-base+))
+	 (slots (sb-pcl:class-slots class))
+	 (state-descriptor (make-instance 'state-descriptor 
+					  :code code
+					  :shape (logior (if slots
+							     HAS-NAMED-SLOTS
+							     0))
+					  :package-string (package-name (symbol-package (class-name class)))
+					  :name (symbol-name (class-name class))
+					  :named-slots (loop for slot in slots collect (string (sb-pcl:slot-definition-name slot))))))
+    (setf (gethash class *state-descriptors*) state-descriptor)
+;    (break "state descriptors ~A" *state-descriptors*)
+    state-descriptor))
+
+(defun find-state-descriptor-by-code (code)
+  (let ((lookup (gethash code *state-descriptors*)))
+    (if (not lookup)
+	(error (format nil "missing state-descriptor for code ~A" code) )
+	lookup)))
+
+(defun find-state-descriptor-by-class (class)
+  (let ((lookup (gethash class *state-descriptors*)))
+    lookup))
+
+(defun write-state-descriptor (stream state-descriptor)
+;  (format t "writing state descriptor ~A~%" state-descriptor)
+  (write-datum stream +unsigned-integer+ +marshal-directive+)
+  (write-datum stream +unsigned-integer+ +marshal-directive-load-metastate+)
+  (write-datum stream +unsigned-integer+ (code state-descriptor))
+  (write-datum stream +unsigned-integer+ (shape state-descriptor))
+  (write-datum stream +unicode-string+ (package-string state-descriptor))
+  (write-datum stream +unicode-string+ (name state-descriptor))
+  (write-datum stream +unsigned-integer+ (list-length (named-slots state-descriptor)))
+  (loop for slot in (named-slots state-descriptor) do (write-datum stream +unicode-string+ slot)))
+
+(defun read-state-descriptor (stream)
+  (let* ((code (read-datum stream +unsigned-integer+))
+	 (shape (read-datum stream +unsigned-integer+))
+	 (package-string (read-datum stream +unicode-string+))
+	 (name (read-datum stream +unicode-string+))
+	 (slot-count (read-datum stream +unsigned-integer+))
+	 (slots (loop for s from 1 to slot-count collect (read-datum stream +unicode-string+))))
+    (make-instance 'state-descriptor :code code :shape shape :package-string package-string :name name :named-slots slots)))
+
+; mapping lisp objects to slurp types
+
+(defmethod slurp-type ((object integer))
+  +unsigned-integer+)
+
+(defmethod slurp-type ((object cons))
+  +cons+)
+
+(defmethod slurp-type ((object string))
+  +unicode-string+)
+
+; reading and writing slurp data
+(defgeneric modify-decoded-slot (object slot value))
+(defmethod modify-decoded-slot  (object slot value)
+  value)
+  
+
+(defmethod read-datum (stream (state-descriptor-code integer))
+  (assert (>= state-descriptor-code +state-descriptor-base+))
+  (let* ((state-descriptor (find-state-descriptor-by-code state-descriptor-code))
+	 (package (find-package (intern (string-upcase (package-string state-descriptor)) :keyword)))
+	 (class-name (intern (name state-descriptor) package))
+	 (newobject (make-instance class-name)) ; make an instance
+	 (placeholder (make-instance 'placeholder :base-object newobject)))   ; make a placeholder 
+;    (break placeholder newobject state-descriptor)
+    (when (has-named-slots state-descriptor) 					; read the slots
+      (loop for slot in (named-slots state-descriptor) do
+	    (let ((slot-name (intern (string-upcase slot) package))
+		  (value (read-object *reader*)))
+	      (handler-case
+		  (setf (slot-value newobject slot-name) (modify-decoded-slot newobject slot-name value))
+		(simple-error (condition)
+		   (format t "error ~A setting slot ~A in class ~A with value ~A~%" condition slot-name class-name value))))))
+    placeholder))
+
+(defmethod write-datum (stream (state-descriptor state-descriptor) object)
+;  (break state-descriptor)
+  (when (has-named-slots state-descriptor)
+    ;    (format t "writing state descriptor slots ~A ~%" (name state-descriptor))
+    (loop for slot in (named-slots state-descriptor) do
+	  (write-object *writer*
+			(handler-case (slot-value object (intern slot (find-package (intern (package-string state-descriptor)))))
+			  (unbound-slot () nil))))))
+
+(defmethod read-datum (stream (data-type (eql +nil+))) nil)
+
+(defmethod read-datum (stream (data-type (eql +byte+)))
+  (read-byte stream))
+
+(defmethod write-datum (stream (data-type (eql +byte+)) obj)
+  (write-byte obj stream))
+
+(defmethod write-datum (stream (data-type (eql +cons+)) obj)
+  (write-object *writer* (first obj))
+  (write-object *writer* (rest obj)))
+
+(defmethod write-datum (stream (data-type (eql +key-value+)) obj)
+  (write-object *writer* (first obj))
+  (write-object *writer* (rest obj)))
+
+(defmethod write-datum (stream (data-type (eql +object-array+)) (obj vector))
+  (write-datum *writer* +cons+ (list (length obj)))
+  (let ((length (length obj)))
+    (loop for index from 0 below length 
+	  do (write-object *writer* (elt obj index)))))
+
+(defmethod write-datum (stream (data-type (eql +object-array+)) obj)
+  (write-datum *writer* +cons+ (array-dimensions obj))
+  (let ((length (array-total-size obj)))
+    (loop for index from 0 below length 
+	  do (write-object *writer* (row-major-aref obj index)))))
+
+(defmethod read-datum (stream (data-type (eql +cons+)))
+  (let ((A (read-object *reader*))
+	(B (read-object *reader*)))
+    (cons A B)))
+
+(defmethod read-datum (stream (data-type (eql +object-array+)))
+  (let* ((dimensions (read-datum stream +cons+))
+	 (buffer (make-array dimensions :element-type t))
+	 (length (array-total-size buffer)))
+    (loop for index from 0 below length do
+	  (setf (row-major-aref buffer index) (read-object *reader*)))
+    buffer))
+
+(defmethod read-datum (stream (data-type (eql +byte-array+)))
+  (let* ((length (read-datum stream +unsigned-integer+))
+	 (buffer (make-array length :element-type '(unsigned-byte 8))))
+    (loop for index from 0 to (- length 1) do
+	  (setf (aref buffer index) (read-byte stream)))
+    buffer))
+
+(defmethod read-datum (stream (data-type (eql +unicode-string+)))
+  (let* ((length (read-datum stream +unsigned-integer+))
+	 (str (make-array length :element-type 'character)))
+    (loop for index from 0 to (- (length str) 1) do 
+	  (setf (char str index)
+		(code-char (read-datum stream +unsigned-integer+))
+		))
+    (string str)))
+
+(defmethod read-datum (stream (data-type (eql +key-value-array+)))
+  (let* ((count (read-datum stream +unsigned-integer+))
+	 (ht (make-hash-table :size count)))
+    (dotimes (counter count)
+      (let ((key (read-object *reader*))
+	    (value (read-object *reader*)))
+	(setf (gethash (if (stringp key)
+			   (intern key)
+			   key)
+		       ht) value))) ; hack, we turn string keys into symbols
+    ht))
+
+(defmethod write-datum (stream (data-type (eql +unicode-string+)) (str string))
+  (write-datum stream +unsigned-integer+ (length str))
+  (loop for char across str do (write-datum stream +unsigned-integer+ (char-code char))))
+
+(defmethod write-datum (stream (data-type (eql +unsigned-integer+)) (num integer))
+  (assert (>= num 0))
+  (do ((carry (truncate num 128)) 
+       (writeValue (rem num 128))) 
+      ((equal carry 0) (write-byte writeValue stream))
+    (write-byte (+ writeValue 128) stream)
+;    (format t "write ~A carry ~A writing ~A~%" writeValue carry (+ writeValue 128))
+    (setf writeValue (rem carry 128))
+    (setf carry (truncate carry 128))))
+
+(defmethod read-datum (stream (data-type (eql +unsigned-integer+)))
+  (do ((answer 0)
+       (shifter 1)
+       (atLast nil)
+       (readValue))
+      (atLast (progn
+;		(format t "done ~A~%" answer)
+		answer))
+    (setf readValue (let ((val (read-byte stream)))
+		      (if (typep val 'character)
+			  (char-code val)
+			  val)))
+    (setf atLast (< readValue 128)) ; (equal (rem readValue 128) 0))
+    (if (not atLast)
+	(setf readValue (- readValue 128)))
+    (setf answer (+ answer (* readValue shifter)))
+    (setf shifter (* shifter 128))))
+
+; tests
+
+(defclass testA ()
+  ((a)
+   (b)
+   (c)
+   (d)))
+
+(defclass testB ()
+  ((|apple|)
+   (|bean|)
+   (|cattle|)
+   (|dog|)))
+
+(defun check-equal (A B)
+  (if (not (equal A B))
+      (break "~A is does not equal ~A" A B)))
+
+(defun testArray ()
+  (let* ((array (make-array '(19 19) :initial-element nil))
+	 (bytes (slurp::encode array)))
+    bytes
+    ;
+  ;
+   ;    (check-equal (decode bytes) array))
+  ))
+
+
+(defun test ()
+  (simple-test)
+  (with-open-file (stream "slurp-test.slurp" :direction :output :if-exists :overwrite :if-does-not-exist :create)
+    (let ((objA (make-instance 'testA)))
+      (setf (slot-value objA 'a) 22)
+      (setf (slot-value objA 'b) "mohab")
+      (setf (slot-value objA 'c) '(1 2 3))
+      (setf (slot-value objA 'd) (make-array 3 :element-type '(unsigned-byte 8)
+					     :initial-contents '(1 99 254)))
+      (write-sequence (encode objA) stream) 
+      )
+    (with-open-file (file "/home/jewel/dev/furax/test-packet.slurp" :direction :input)
+      (let ((s (make-string (file-length file))))
+	(read-sequence s file)
+	(let ((objB (decode s)))
+	  (check-equal (first objB) 22))))))
+
+(defun simple-test ()
+  (let ((objA (make-instance 'testA))
+	(objB (make-instance 'testB)))
+
+    (setf (slot-value objA 'a) 22)
+    (setf (slot-value objA 'b) "mohab")
+    (setf (slot-value objA 'c) '(1 2 3))
+    (setf (slot-value objA 'd) (make-array 3 :initial-contents '("a" "b" "c")))
+    
+    (setf (slot-value objB '|apple|) objA)
+    (setf (slot-value objB '|bean|) 2)
+    (setf (slot-value objB '|cattle|) 'grimace)
+    (setf (slot-value objB '|dog|) :bumper)
+
+    (let* ((encA (encode objA))
+	   (encB (encode objB))
+	   (decA (decode encA))
+	   (decB (decode encB)))
+      (check-equal (slot-value objA 'a) (slot-value decA 'a))
+      (check-equal (slot-value objA 'b) (slot-value decA 'b))
+      (check-equal (slot-value objA 'c) (slot-value decA 'c))
+      (check-equal (length (slot-value objA 'd))
+		   (length (slot-value decA 'd)))
+      (check-equal (class-of (slot-value decB '|apple|)) (class-of objA))
+      (check-equal (slot-value objB '|bean|) (slot-value decB '|bean|))
+      (check-equal (string (slot-value objB '|cattle|)) (slot-value decB '|cattle|))
+      (check-equal (string (slot-value objB '|dog|)) (slot-value decB '|dog|)))))
+
+
+
+
+    
+
+