Skip to content
GitLab
Projects
Groups
Snippets
Help
Loading...
Help
What's new
7
Help
Support
Community forum
Keyboard shortcuts
?
Submit feedback
Contribute to GitLab
Sign in / Register
Toggle navigation
Open sidebar
Hayley Patton
netfarm
Commits
d6753367
Commit
d6753367
authored
Mar 20, 2020
by
Hayley Patton
🐢
Browse files
Options
Browse Files
Download
Email Patches
Plain Diff
Don't bother rewriting references if no source was provided, introduce binary format
parent
514a715f
Changes
4
Hide whitespace changes
Inline
Side-by-side
Showing
4 changed files
with
108 additions
and
4 deletions
+108
-4
Code/Binary-format/parser.lisp
Code/Binary-format/parser.lisp
+55
-0
Code/Binary-format/renderer.lisp
Code/Binary-format/renderer.lisp
+48
-0
Code/Objects/rewrite-references.lisp
Code/Objects/rewrite-references.lisp
+2
-1
Code/Scripts/Script-machine/objects.lisp
Code/Scripts/Script-machine/objects.lisp
+3
-3
No files found.
Code/Binary-format/parser.lisp
0 → 100644
View file @
d6753367
(
in-package
:netfarm
)
(
defun
read-integer
(
function
)
(
let
((
byte-count
(
funcall
function
))
(
accumulator
0
))
(
dotimes
(
n
byte-count
)
(
setf
accumulator
(
logior
(
funcall
function
)
(
ash
accumulator
8
))))
accumulator
))
(
defgeneric
binary-parse-from-type-tag
(
type-tag
function
)
(
:method
((
tag
(
eql
1
))
function
)
(
let*
((
byte-length
(
read-integer
function
))
(
bytes
(
make-array
byte-length
:element-type
'
(
unsigned-byte
8
))))
(
dotimes
(
n
byte-length
)
(
setf
(
aref
bytes
n
)
(
funcall
function
)))
(
babel:octets-to-string
bytes
:encoding
:utf-8
)))
(
:method
((
tag
(
eql
2
))
function
)
(
let*
((
vector-length
(
read-integer
function
))
(
vector
(
make-array
vector-length
:element-type
'
(
unsigned-byte
8
))))
(
dotimes
(
n
byte-length
)
(
setf
(
aref
vector
n
)
(
funcall
function
)))
vector
))
(
:method
((
tag
(
eql
3
))
function
)
(
read-integer
function
))
(
:method
((
tag
(
eql
4
))
function
)
(
let
((
integer
(
read-integer
function
)))
(
if
(
zerop
integer
)
(
error
"Don't use the negative-integer tag for zeroes"
)
(
-
integer
))))
(
:method
((
tag
(
eql
5
))
function
)
(
let
((
length
(
read-integer
function
)))
(
loop
repeat
length
collect
(
binary-parse-from-function
function
))))
(
:method
((
tag
(
eql
6
))
function
)
(
let
((
hash
(
make-array
32
:element-type
'
(
unsigned-byte
8
))))
(
dotimes
(
n
32
)
(
setf
(
aref
hash
n
)
(
funcall
function
)))
(
make-instance
'reference
:hash
hash
))))
(
defun
binary-parse-from-function
(
function
)
(
binary-parse-from-type-tag
(
funcall
function
)
function
))
(
defun
binary-parse
(
function-or-vector
)
(
if
(
vectorp
function-or-vector
)
(
let
((
position
0
)
(
vector
function-or-vector
))
(
binary-parse-from-function
(
lambda
()
(
prog1
(
aref
vector
position
)
(
incf
position
)))))
(
binary-parse-from-function
function-or-vector
)))
Code/Binary-format/renderer.lisp
0 → 100644
View file @
d6753367
(
in-package
:netfarm
)
(
defun
write-integer
(
integer
function
)
(
let
((
byte-count
(
ceiling
(
integer-length
integer
)
8
)))
(
assert
(
<
byte-count
256
))
(
flet
((
get-byte
(
n
)
(
ldb
(
byte
8
(
*
n
8
))
integer
)))
(
funcall
function
(
vector
byte-count
))
(
loop
with
buffer
=
(
make-array
byte-count
:element-type
'
(
unsigned-byte
8
))
for
byte-position
from
(
1-
byte-count
)
downto
0
for
buffer-position
from
0
do
(
setf
(
aref
buffer
buffer-position
)
(
get-byte
byte-position
))
finally
(
funcall
function
buffer
)))))
(
defun
write-type-tag
(
tag
function
)
(
funcall
function
(
vector
tag
)))
(
defgeneric
binary-render-to-function
(
object
function
)
(
:method
((
s
string
)
function
)
(
let
((
bytes
(
babel:string-to-octets
s
:encoding
:utf-8
)))
(
write-type-tag
1
function
)
(
write-integer
(
length
bytes
)
function
)
(
funcall
function
bytes
)))
(
:method
((
v
vector
)
function
)
(
write-type-tag
2
function
)
(
write-integer
(
length
v
)
function
)
(
funcall
function
v
))
(
:method
((
i
integer
)
function
)
(
write-type-tag
(
if
(
minusp
i
)
4
3
)
function
)
(
write-integer
(
abs
i
)
function
))
(
:method
((
l
list
)
function
)
(
write-type-tag
5
function
)
(
write-integer
(
length
l
)
function
)
(
dolist
(
element
l
)
(
binary-render-to-function
element
function
)))
(
:method
((
r
reference
)
function
)
(
write-type-tag
6
function
)
(
funcall
function
(
reference-hash
function
))))
(
defun
binary-render
(
object
&optional
function
)
(
if
(
null
function
)
(
flexi-streams:with-output-to-sequence
(
s
)
(
binary-render-to-function
object
(
lambda
(
bytes
)
(
write-sequence
bytes
s
))))
(
binary-render-to-function
object
function
)))
Code/Objects/rewrite-references.lisp
View file @
d6753367
...
...
@@ -33,7 +33,8 @@
(
defun
maybe-rewrite-graph
(
object
graph-cons
)
(
when
(
and
(
not
(
car
graph-cons
))
*rewrite-references?*
)
(
rewrite-graph
(
cdr
graph-cons
)
(
object-source
object
))
(
unless
(
null
(
object-source
object
))
(
rewrite-graph
(
cdr
graph-cons
)
(
object-source
object
)))
(
setf
(
car
graph-cons
)
t
))
(
cdr
graph-cons
))
...
...
Code/Scripts/Script-machine/objects.lisp
View file @
d6753367
...
...
@@ -49,9 +49,9 @@
(
incf
cons-count
(
length
signatures
))
(
mapcar
#'
car
signatures
)))
(
define-opcode
135
send
((
:capabilities
capabilities
:side-effects
side-effects
)
target
message
)
(
define-opcode
*
135
send
((
:capabilities
capabilities
:side-effects
side-effects
)
target
message
)
()
(
if
(
member
:send
capabilities
)
(
push
(
list
'send
:target
target
...
...
Write
Preview
Markdown
is supported
0%
Try again
or
attach a new file
.
Attach a file
Cancel
You are about to add
0
people
to the discussion. Proceed with caution.
Finish editing this message first!
Cancel
Please
register
or
sign in
to comment