-
Notifications
You must be signed in to change notification settings - Fork 3
/
portable.lisp
129 lines (110 loc) · 3.99 KB
/
portable.lisp
1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
75
76
77
78
79
80
81
82
83
84
85
86
87
88
89
90
91
92
93
94
95
96
97
98
99
100
101
102
103
104
105
106
107
108
109
110
111
112
113
114
115
116
117
118
119
120
121
122
123
124
125
126
127
128
129
;;; -*- Mode: Lisp; indent-tabs-mode: nil -*-
;;; This software is in the public domain and is
;;; provided with absolutely no warranty.
(in-package :swap-bytes)
#-(and sbcl x86)
(declaim (inline swap-bytes-16))
#-(and sbcl x86)
(defun swap-bytes-16 (integer)
(declare (type (unsigned-byte 16) integer)
(optimize (speed 3) (safety 0) (debug 0)))
(logior (ash (logand #xFF integer) 8)
(ash integer -8)))
#-(and sbcl (or x86 x86-64))
(declaim (inline swap-bytes-32))
#-(and sbcl (or x86 x86-64))
(defun swap-bytes-32 (integer)
(declare (type (unsigned-byte 32) integer)
(optimize (speed 3) (safety 0) (debug 0)))
(logior (ash (logand #x0000FF integer) 24)
(ash (logand #x00FF00 integer) 8)
(ash (logand #xFF0000 integer) -8)
(ash integer -24)))
#-(and sbcl x86-64)
(declaim (inline swap-bytes-64))
#-(and sbcl x86-64)
(defun swap-bytes-64 (integer)
(declare (type (unsigned-byte 64) integer)
(optimize (speed 3) (safety 0) (debug 0)))
(macrolet ((shift (mask shift)
`(ash (logand ,mask integer) ,shift)))
(logior
(shift #x000000000000FF 56)
(shift #x0000000000FF00 40)
(shift #x00000000FF0000 24)
(shift #x000000FF000000 8)
(shift #x0000FF00000000 -8)
(shift #x00FF0000000000 -24)
(shift #xFF000000000000 -40)
(ash integer -56))))
(declaim (inline htons))
(defun htons (integer)
"Convert (unsigned-byte 16) from host order(little- or big-endian)
to network order(always big-endian)."
(declare (type (unsigned-byte 16) integer)
(optimize (speed 3) (safety 0) (debug 0)))
#+little-endian (swap-bytes-16 integer)
#+big-endian integer)
(declaim (inline ntohs))
(defun ntohs (integer)
"Convert (unsigned-byte 16) from network order(always big-endian) to
host order(little- or big-endian)."
(declare (type (unsigned-byte 16) integer)
(optimize (speed 3) (safety 0) (debug 0)))
#+little-endian (swap-bytes-16 integer)
#+big-endian integer)
(declaim (inline htonl))
(defun htonl (integer)
"Convert (unsigned-byte 32) from host order(little- or big-endian)
to network order(always big-endian)."
(declare (type (unsigned-byte 32) integer)
(optimize (speed 3) (safety 0) (debug 0)))
#+little-endian (swap-bytes-32 integer)
#+big-endian integer)
(declaim (inline ntohl))
(defun ntohl (integer)
"Convert (unsigned-byte 32) from network order(always big-endian) to
host order(little- or big-endian)."
(declare (type (unsigned-byte 32) integer)
(optimize (speed 3) (safety 0) (debug 0)))
#+little-endian (swap-bytes-32 integer)
#+big-endian integer)
(declaim (inline htonq))
(defun htonq (integer)
"Convert (unsigned-byte 64) from host order(little- or big-endian)
to network order(always big-endian)."
(declare (type (unsigned-byte 64) integer)
(optimize (speed 3) (safety 0) (debug 0)))
#+little-endian (swap-bytes-64 integer)
#+big-endian integer)
(declaim (inline ntohq))
(defun ntohq (integer)
"Convert (unsigned-byte 64) from network order(always big-endian) to
host order(little- or big-endian)."
(declare (type (unsigned-byte 64) integer)
(optimize (speed 3) (safety 0) (debug 0)))
#+little-endian (swap-bytes-64 integer)
#+big-endian integer)
(deftype endianness ()
'(member :big-endian :little-endian))
(deftype endianness-designator ()
'(member :big-endian :little-endian :network :local))
(defconstant +endianness+
#+big-endian :big-endian
#+little-endian :little-endian)
(defun endianness (endianness)
(check-type endianness endianness-designator)
(case endianness
(:local +endianness+)
(:network :big-endian)
(t endianness)))
(defun find-swap-byte-function (&key size from (to :local))
(let ((from (endianness from))
(to (endianness to)))
(if (eql from to)
'identity
(ecase size
(1 'identity)
(2 'swap-bytes-16)
(4 'swap-bytes-32)
(8 'swap-bytes-64)))))