Skip to content
GitLab
Projects
Groups
Snippets
Help
Loading...
Help
Help
Support
Community forum
Keyboard shortcuts
?
Submit feedback
Contribute to GitLab
Sign in / Register
Toggle navigation
M
movitz
Project overview
Project overview
Details
Activity
Releases
Repository
Repository
Files
Commits
Branches
Tags
Contributors
Graph
Compare
Issues
0
Issues
0
List
Boards
Labels
Service Desk
Milestones
Merge Requests
0
Merge Requests
0
CI / CD
CI / CD
Pipelines
Jobs
Schedules
Operations
Operations
Incidents
Environments
Analytics
Analytics
CI / CD
Repository
Value Stream
Wiki
Wiki
Members
Members
Collapse sidebar
Close sidebar
Activity
Graph
Create a new issue
Jobs
Commits
Issue Boards
Open sidebar
movitz
movitz
Commits
deb98f82
Commit
deb98f82
authored
May 24, 2004
by
Frode Vatvedt Fjeld
Browse files
Options
Browse Files
Download
Email Patches
Plain Diff
Starting to add some bignum support.
parent
2d2a56f2
Changes
14
Hide whitespace changes
Inline
Side-by-side
Showing
14 changed files
with
412 additions
and
119 deletions
+412
-119
compiler.lisp
compiler.lisp
+4
-7
image.lisp
image.lisp
+12
-5
losp/los0-gc.lisp
losp/los0-gc.lisp
+32
-1
losp/los0.lisp
losp/los0.lisp
+19
-1
losp/muerte/arrays.lisp
losp/muerte/arrays.lisp
+37
-31
losp/muerte/integers.lisp
losp/muerte/integers.lisp
+140
-28
losp/muerte/los-closette.lisp
losp/muerte/los-closette.lisp
+2
-2
losp/muerte/primitive-functions.lisp
losp/muerte/primitive-functions.lisp
+43
-22
losp/muerte/print.lisp
losp/muerte/print.lisp
+7
-5
losp/muerte/typep.lisp
losp/muerte/typep.lisp
+63
-9
movitz-mode.el
movitz-mode.el
+2
-1
packages.lisp
packages.lisp
+2
-1
storage-types.lisp
storage-types.lisp
+44
-3
stream-image.lisp
stream-image.lisp
+5
-3
No files found.
compiler.lisp
View file @
deb98f82
...
...
@@ -8,7 +8,7 @@
;;;; Created at: Wed Oct 25 12:30:49 2000
;;;; Distribution: See the accompanying file COPYING.
;;;;
;;;; $Id: compiler.lisp,v 1.5
8 2004/04/21 15:06:16
ffjeld Exp $
;;;; $Id: compiler.lisp,v 1.5
9 2004/04/23 14:58:52
ffjeld Exp $
;;;;
;;;;------------------------------------------------------------------
...
...
@@ -4786,12 +4786,9 @@ Return arg-init-code, need-normalized-ecx-p."
:provider
provider
))
(
:untagged-fixnum-ecx
(
case
(
result-mode-type
desired-result
)
((
:eax
:ebx
:ecx
:edx
)
(
values
(
append
code
`
((
:cmpl
,
+movitz-most-positive-fixnum+
:ecx
)
(
:ja
'
(
:sub-program
()
(
:int
4
)))
(
:leal
((
:ecx
,
+movitz-fixnum-factor+
)
:edi
,
(
edi-offset
))
,
desired-result
)))
((
:eax
:single-value
)
(
values
(
append
code
`
((
:call
(
:edi
,
(
global-constant-offset
'normalize-u32-ecx
)))))
desired-result
))
(
t
(
make-result-and-returns-glue
desired-result
:eax
(
make-result-and-returns-glue
:eax
:untagged-fixnum-ecx
code
...
...
image.lisp
View file @
deb98f82
...
...
@@ -9,7 +9,7 @@
;;;; Created at: Sun Oct 22 00:22:43 2000
;;;; Distribution: See the accompanying file COPYING.
;;;;
;;;; $Id: image.lisp,v 1.2
8 2004/05/19 14:59
:52 ffjeld Exp $
;;;; $Id: image.lisp,v 1.2
9 2004/05/21 09:38
:52 ffjeld Exp $
;;;;
;;;;------------------------------------------------------------------
...
...
@@ -226,6 +226,11 @@
:map-binary-write
'movitz-intern-code-vector
:map-binary-read-delayed
'movitz-word-code-vector
:binary-tag
:primitive-function
)
(
normalize-u32-ecx
:binary-type
code-vector-word
:map-binary-write
'movitz-intern-code-vector
:map-binary-read-delayed
'movitz-word-code-vector
:binary-tag
:primitive-function
)
(
malloc
:binary-type
code-vector-word
:map-binary-write
'movitz-intern-code-vector
...
...
@@ -543,6 +548,7 @@
(
defmethod
image-classes-map
((
image
symbolic-image
))
'
(
muerte.cl:null
muerte.cl:cons
muerte.cl:fixnum
muerte.cl:symbol
muerte.cl:character
muerte.cl:function
muerte.cl:condition
muerte.cl:integer
muerte.cl:ratio
muerte.cl:vector
muerte.cl:string
muerte.cl:array
muerte.cl:class
muerte.cl:standard-class
muerte.cl:standard-generic-function
...
...
@@ -553,9 +559,10 @@
muerte:illegal-object
))
(
defun
class-object-offset
(
name
)
(
+
(
bt:slot-offset
'movitz-vector
'data
)
(
*
4
(
1+
(
or
(
position
name
(
image-classes-map
*image*
))
(
error
"No class named ~S in class-map."
name
))))))
(
let
((
name
(
translate-program
name
:cl
:muerte.cl
)))
(
+
(
bt:slot-offset
'movitz-vector
'data
)
(
*
4
(
1+
(
or
(
position
name
(
image-classes-map
*image*
))
(
error
"No class named ~S in class-map."
name
)))))))
(
defun
unbound-value
()
(
declare
(
special
*image*
))
...
...
@@ -1361,7 +1368,7 @@ this image will not be Multiboot compatible."
(
null
*movitz-nil*
)
((
member
t
)
(
movitz-read
'muerte.cl:t
))
(
symbol
(
intern-movitz-symbol
expr
))
(
integer
(
make-movitz-
fixnum
expr
))
(
integer
(
make-movitz-
integer
expr
))
(
character
(
make-movitz-character
expr
))
(
string
(
or
(
gethash
expr
(
image-string-constants
*image*
))
(
setf
(
gethash
expr
(
image-string-constants
*image*
))
...
...
losp/los0-gc.lisp
View file @
deb98f82
...
...
@@ -10,7 +10,7 @@
;;;; Author: Frode Vatvedt Fjeld <frodef@acm.org>
;;;; Created at: Sat Feb 21 17:48:32 2004
;;;;
;;;; $Id: los0-gc.lisp,v 1.
9 2004/04/15 15:23:31
ffjeld Exp $
;;;; $Id: los0-gc.lisp,v 1.
10 2004/04/16 14:44:42
ffjeld Exp $
;;;;
;;;;------------------------------------------------------------------
...
...
@@ -72,6 +72,33 @@
(
:movl
:ecx
(
:edx
2
))
(
:ret
)))
(
define-primitive-function
los0-normalize-u32-ecx
()
"Make u32 in ECX into a fixnum or bignum."
(
macrolet
((
do-it
()
`
(
with-inline-assembly
(
:returns
:multiple-values
)
(
:cmpl
,
movitz:+movitz-most-positive-fixnum+
:ecx
)
(
:ja
'not-fixnum
)
(
:leal
((
:ecx
,
movitz:+movitz-fixnum-factor+
))
:eax
)
(
:ret
)
not-fixnum
retry-cons
(
:locally
(
:movl
(
:edi
(
:edi-offset
nursery-space
))
:edx
))
(
:movl
(
:edx
2
)
:eax
)
(
:cmpl
#x3fff4
:eax
)
(
:jge
'
(
:sub-program
()
(
:int
113
)
; This interrupt can be retried.
(
:jmp
'retry-cons
)))
(
:movl
,
(
dpb
1
(
byte
16
16
)
(
movitz:tag
:bignum
0
))
(
:edx
:eax
2
))
(
:movl
:ecx
(
:edx
:eax
6
))
(
:addl
8
:eax
)
(
:movl
:eax
(
:edx
2
))
(
:leal
(
:edx
:eax
)
:eax
)
(
:ret
)
(
:int
107
))))
(
do-it
)))
(
defun
los0-malloc-clumps
(
clumps
)
(
check-type
clumps
(
integer
0
4000
))
(
with-inline-assembly
(
:returns
:eax
)
...
...
@@ -130,6 +157,10 @@
(
check-type
conser
vector
)
(
setf
(
%run-time-context-slot
'muerte::fast-cons
)
conser
))
(
let
((
conser
(
symbol-value
'los0-normalize-u32-ecx
)))
(
check-type
conser
vector
)
(
setf
(
%run-time-context-slot
'muerte::normalize-u32-ecx
)
conser
))
(
let
((
old-malloc
(
symbol-function
'muerte:malloc-clumps
)))
(
setf
(
symbol-function
'muerte:malloc-clumps
)
(
symbol-function
'los0-malloc-clumps
))
...
...
losp/los0.lisp
View file @
deb98f82
...
...
@@ -9,7 +9,7 @@
;;;; Created at: Fri Dec 1 18:08:32 2000
;;;; Distribution: See the accompanying file COPYING.
;;;;
;;;; $Id: los0.lisp,v 1.1
2 2004/04/23 13:00:08
ffjeld Exp $
;;;; $Id: los0.lisp,v 1.1
3 2004/04/23 15:04:07
ffjeld Exp $
;;;;
;;;;------------------------------------------------------------------
...
...
@@ -263,6 +263,24 @@
(
warn
"exited: ~S"
c
)))
(
defun
test-bignum
()
123456789123456
)
(
defun
ff32
()
#xffffffff
)
(
defun
one32
()
#x100000000
)
(
defun
test-nbignum
()
-123456789123456
)
(
defun
gt5
(
x
)
(
<=
x
5
))
(
defun
xplus
(
x
)
(
typep
x
'
(
integer
0
*
)))
(
defstruct
xxx
x
y
(
z
'init-z
))
...
...
losp/muerte/arrays.lisp
View file @
deb98f82
...
...
@@ -10,7 +10,7 @@
;;;; Author: Frode Vatvedt Fjeld <frodef@acm.org>
;;;; Created at: Sun Feb 11 23:14:04 2001
;;;;
;;;; $Id: arrays.lisp,v 1.
19 2004/05/20 17:41:46
ffjeld Exp $
;;;; $Id: arrays.lisp,v 1.
20 2004/05/21 09:41:58
ffjeld Exp $
;;;;
;;;;------------------------------------------------------------------
...
...
@@ -204,34 +204,34 @@
(
:shrl
,
movitz:+movitz-fixnum-shift+
:ebx
)
(
:movzxw
(
:eax
,
movitz:+other-type-offset+
)
:ecx
)
(
:cmpw
(
:eax
#.
(
bt:slot-offset
'movitz:movitz-vector
'movitz::num-elements
))
:bx
)
(
:cmpw
(
:eax
,
(
bt:slot-offset
'movitz:movitz-vector
'movitz::num-elements
))
:bx
)
(
:jae
'
(
:sub-program
()
(
:compile-form
(
:result-mode
:ignore
)
(
error
"Index ~D out of bounds ~D."
index
(
length
vector
)))))
(
:cmpl
#.
(
movitz:vector-type-tag
:any-t
)
:ecx
)
(
:cmpl
,
(
movitz:vector-type-tag
:any-t
)
:ecx
)
(
:jne
'not-any-t
)
(
:movl
(
:eax
(
:ebx
4
)
2
)
:eax
)
(
:jmp
'done
)
not-any-t
(
:cmpl
#.
(
movitz:vector-type-tag
:character
)
:ecx
)
(
:cmpl
,
(
movitz:vector-type-tag
:character
)
:ecx
)
(
:jne
'not-character
)
(
:movb
(
:eax
:ebx
2
)
:bl
)
(
:xorl
:eax
:eax
)
(
:movb
:bl
:ah
)
(
:movb
#.
(
movitz::tag
:character
)
:al
)
; character
(
:movb
,
(
movitz::tag
:character
)
:al
)
; character
(
:jmp
'done
)
not-character
(
:cmpl
#.
(
movitz:vector-type-tag
:u8
)
:ecx
)
(
:cmpl
,
(
movitz:vector-type-tag
:u8
)
:ecx
)
(
:jne
'not-u8
)
(
:movzxb
(
:eax
:ebx
2
)
:eax
)
; u8
(
:shll
#.
movitz::+movitz-fixnum-shift+
:eax
)
(
:shll
,
movitz::+movitz-fixnum-shift+
:eax
)
(
:jmp
'done
)
not-u8
(
:cmpl
#.
(
movitz:vector-type-tag
:u16
)
:ecx
)
(
:cmpl
,
(
movitz:vector-type-tag
:u16
)
:ecx
)
(
:jne
'not-u16
)
(
:movzxw
(
:eax
(
:ebx
2
)
2
)
:eax
)
; u16
(
:jmp
'done
)
...
...
@@ -265,7 +265,7 @@
(
:compile-form
(
:result-mode
:ebx
)
value
)
(
:compile-form
(
:result-mode
:eax
)
vector
)
(
:leal
(
:eax
#.
(
cl:-
(
movitz:
:tag
:other
)))
:ecx
)
(
:leal
(
:eax
,
(
-
(
movitz
:tag
:other
)))
:ecx
)
(
:testb
7
:cl
)
(
:jnz
'
(
:sub-program
()
(
:compile-form
(
:result-mode
:ignore
)
...
...
@@ -273,24 +273,24 @@
(
:movzxw
(
:eax
,
movitz:+other-type-offset+
)
:edx
)
(
:compile-form
(
:result-mode
:ecx
)
index
)
(
:testb
#.
movitz::+movitz-fixnum-zmask+
:cl
)
(
:testb
,
movitz::+movitz-fixnum-zmask+
:cl
)
(
:jnz
'
(
:sub-program
()
(
:int
107
)))
; index not fixnum
(
:andl
#.
(
cl:
ash
#xffff
movitz::+movitz-fixnum-shift+
)
:ecx
)
(
:shrl
#.
movitz::+movitz-fixnum-shift+
:ecx
)
(
:andl
,
(
ash
#xffff
movitz::+movitz-fixnum-shift+
)
:ecx
)
(
:shrl
,
movitz::+movitz-fixnum-shift+
:ecx
)
(
:cmpw
(
:eax
#.
(
bt:slot-offset
'movitz:movitz-vector
'movitz::num-elements
))
:cx
)
(
:cmpw
(
:eax
,
(
bt:slot-offset
'movitz:movitz-vector
'movitz::num-elements
))
:cx
)
(
:jae
'
(
:sub-program
()
(
:int
61
)
(
:jmp
(
:pc+
-4
))))
; index out of bounds
(
:cmpl
#.
(
movitz:vector-type-tag
:any-t
)
:edx
)
(
:cmpl
,
(
movitz:vector-type-tag
:any-t
)
:edx
)
(
:jnz
'not-any-t
)
(
:movl
:ebx
(
:eax
(
:ecx
4
)
2
))
(
:jmp
'done
)
not-any-t
(
:cmpl
#.
(
movitz:vector-type-tag
:character
)
:edx
)
(
:cmpl
,
(
movitz:vector-type-tag
:character
)
:edx
)
(
:jnz
'not-character
)
(
:cmpb
#.
(
movitz:tag
:character
)
:bl
)
(
:cmpb
,
(
movitz:tag
:character
)
:bl
)
(
:jnz
'
(
:sub-program
(
not-character-value
)
(
:compile-form
(
:result-mode
:ignore
)
(
error
"Value not character: ~S"
value
))))
...
...
@@ -298,40 +298,46 @@
(
:jmp
'done
)
not-character
(
:cmpl
#.
(
movitz:vector-type-tag
:u8
)
:edx
)
(
:cmpl
,
(
movitz:vector-type-tag
:u8
)
:edx
)
(
:jnz
'not-u8
)
(
:testl
#.
(
cl:ldb
(
cl:byte
32
0
)
(
cl:-
-1
(
cl:*
#xff
movitz:+movitz-fixnum-factor+
)))
:ebx
)
(
:testl
,
(
cl:ldb
(
cl:byte
32
0
)
(
-
-1
(
*
#xff
movitz:+movitz-fixnum-factor+
)))
:ebx
)
(
:jnz
'
(
:sub-program
(
not-u8-value
)
(
:compile-form
(
:result-mode
:ignore
)
(
error
"Value not (unsigned-byte 8): ~S"
value
))))
(
:shrl
#.
movitz:+movitz-fixnum-shift+
:ebx
)
(
:movb
:bl
(
:eax
(
:ecx
1
)
#.
(
bt:slot-offset
'movitz:movitz-vector
'movitz::data
)))
(
:leal
((
:ebx
#.
movitz:+movitz-fixnum-factor+
))
:ebx
)
(
:shrl
,
movitz:+movitz-fixnum-shift+
:ebx
)
(
:movb
:bl
(
:eax
(
:ecx
1
)
,
(
bt:slot-offset
'movitz:movitz-vector
'movitz::data
)))
(
:leal
((
:ebx
,
movitz:+movitz-fixnum-factor+
))
:ebx
)
(
:jmp
'done
)
not-u8
(
:cmpl
#.
(
movitz:vector-type-tag
:u16
)
:edx
)
(
:cmpl
,
(
movitz:vector-type-tag
:u16
)
:edx
)
(
:jnz
'not-u16
)
(
:testl
#.
(
cl:ldb
(
cl:byte
32
0
)
(
cl:-
-1
(
cl:*
#xffff
movitz:+movitz-fixnum-factor+
)))
:ebx
)
(
:testl
,
(
ldb
(
byte
32
0
)
(
-
-1
(
*
#xffff
movitz:+movitz-fixnum-factor+
)))
:ebx
)
(
:jnz
'
(
:sub-program
(
not-u16-value
)
(
:compile-form
(
:result-mode
:ignore
)
(
error
"Value not (unsigned-byte 16): ~S"
value
))))
(
:shrl
#.
movitz:+movitz-fixnum-shift+
:ebx
)
(
:movw
:bx
(
:eax
(
:ecx
2
)
#.
(
bt:slot-offset
'movitz:movitz-vector
'movitz::data
)))
(
:leal
((
:ebx
#.
movitz:+movitz-fixnum-factor+
))
:ebx
)
(
:shrl
,
movitz:+movitz-fixnum-shift+
:ebx
)
(
:movw
:bx
(
:eax
(
:ecx
2
)
,
(
bt:slot-offset
'movitz:movitz-vector
'movitz::data
)))
(
:leal
((
:ebx
,
movitz:+movitz-fixnum-factor+
))
:ebx
)
(
:jmp
'done
)
not-u16
(
:cmpl
#.
(
movitz:vector-type-tag
:u32
)
:edx
)
(
:cmpl
,
(
movitz:vector-type-tag
:u32
)
:edx
)
(
:jnz
'not-u32
)
(
:testl
#.
(
cl:ldb
(
cl:byte
32
0
)
(
cl:-
-1
(
cl:*
#xffffffff
movitz:+movitz-fixnum-factor+
)))
:ebx
)
(
:testl
,
(
ldb
(
byte
32
0
)
(
-
-1
(
*
#xffffffff
movitz:+movitz-fixnum-factor+
)))
:ebx
)
(
:jnz
'
(
:sub-program
(
not-u32-value
)
(
:compile-form
(
:result-mode
:ignore
)
(
error
"Value not (unsigned-byte 32): ~S"
value
))))
(
:shrl
#.
movitz:+movitz-fixnum-shift+
:ebx
)
(
:movl
:ebx
(
:eax
(
:ecx
4
)
#.
(
bt:slot-offset
'movitz:movitz-vector
'movitz::data
)))
(
:leal
((
:ebx
#.
movitz:+movitz-fixnum-factor+
))
:ebx
)
(
:shrl
,
movitz:+movitz-fixnum-shift+
:ebx
)
(
:movl
:ebx
(
:eax
(
:ecx
4
)
,
(
bt:slot-offset
'movitz:movitz-vector
'movitz::data
)))
(
:leal
((
:ebx
,
movitz:+movitz-fixnum-factor+
))
:ebx
)
(
:jmp
'done
)
not-u32
...
...
losp/muerte/integers.lisp
View file @
deb98f82
...
...
@@ -9,7 +9,7 @@
;;;; Created at: Wed Nov 8 18:44:57 2000
;;;; Distribution: See the accompanying file COPYING.
;;;;
;;;; $Id: integers.lisp,v 1.
9 2004/05/19 15:09:05
ffjeld Exp $
;;;; $Id: integers.lisp,v 1.
10 2004/05/19 15:42:08
ffjeld Exp $
;;;;
;;;;------------------------------------------------------------------
...
...
@@ -22,6 +22,12 @@
(
defconstant
most-positive-fixnum
#.
movitz::+movitz-most-positive-fixnum+
)
(
defconstant
most-negative-fixnum
#.
movitz::+movitz-most-negative-fixnum+
)
(
deftype
positive-fixnum
()
`
(
integer
0
,
movitz:+movitz-most-positive-fixnum+
))
(
deftype
positive-bignum
()
`
(
integer
,
(
1+
movitz:+movitz-most-positive-fixnum+
)
*
))
(
defun
fixnump
(
x
)
(
typep
x
'fixnum
))
...
...
@@ -242,10 +248,26 @@
"Compare real <n1> with fixnum <n2>."
(
with-inline-assembly
(
:returns
:nothing
)
; unspecified
(
:testb
#.
movitz::+movitz-fixnum-zmask+
:al
)
(
:jnz
'not-fixnum
)
(
:cmpl
:ebx
:eax
)
(
:ret
)
not-fixnum
(
:leal
(
:eax
#.
(
cl:-
(
movitz:tag
:other
)))
:ecx
)
(
:testb
7
:cl
)
(
:jnz
'
(
:sub-program
(
not-integer
)
(
:int
107
)
(
:jmp
'not-integer
)))
(
:cmpl
:ebx
:eax
)
(
:movl
(
:eax
#.
movitz:+other-type-offset+
)
:ecx
)
(
:cmpw
#.
(
movitz:tag
:bignum
0
)
:cx
)
(
:jne
'not-plusbignum
)
;; compare ebx with something bigger
(
:cmpl
#x-10000000
:edi
)
(
:ret
)
not-plusbignum
(
:cmpw
#.
(
movitz:tag
:bignum
#xff
)
:cx
)
(
:jne
'not-integer
)
;; compare ebx with something bigger
(
:cmpl
#x10000000
:edi
)
(
:ret
)))
;;;
...
...
@@ -256,8 +278,8 @@
(
movitz:movitz-constantp
max
env
))
(
let
((
min
(
movitz:movitz-eval
min
env
))
(
max
(
movitz:movitz-eval
max
env
)))
(
check-type
min
integer
)
(
check-type
max
integer
)
(
check-type
min
fixnum
)
(
check-type
max
fixnum
)
;; (warn "~D -- ~D" min max)
(
cond
((
movitz:movitz-constantp
x
env
)
...
...
@@ -296,7 +318,7 @@
#+
ignore
; this is buggy.
((
movitz:movitz-constantp
min
env
)
(
let
((
min
(
movitz:movitz-eval
min
env
)))
(
check-type
min
integer
)
(
check-type
min
fixnum
)
(
cond
((
minusp
min
)
`
(
let
((
x
,
x
))
...
...
@@ -372,7 +394,7 @@
(
declare
(
dynamic-extent
more-numbers
))
(
cond
((
null
more-numbers
)
(
check-type
number
integer
)
(
check-type
number
fixnum
)
t
)
((
not
(
cdr
more-numbers
))
(
,
2op-name
number
(
first
more-numbers
)))
...
...
@@ -514,7 +536,7 @@
(
if
(
<
number1
number2
)
number2
number1
))
(
let
((
label
(
gensym
)))
`
(
with-inline-assembly
(
:returns
:eax
:type
integer
)
`
(
with-inline-assembly
(
:returns
:eax
:type
fixnum
)
(
:compile-two-forms
(
:eax
:ebx
)
,
number1
,
number2
)
(
:movl
:ebx
:ecx
)
(
:orl
:eax
:ecx
)
...
...
@@ -650,7 +672,7 @@
`
(
*%2op
,
(
movitz:movitz-eval
factor2
env
)
,
factor1
))
((
movitz:movitz-constantp
factor1
env
)
(
let
((
f1
(
movitz:movitz-eval
factor1
env
)))
(
check-type
f1
integer
)
(
check-type
f1
fixnum
)
(
case
f1
(
0
`
(
progn
,
factor2
0
))
(
1
factor2
)
...
...
@@ -708,9 +730,9 @@
`
(
do-result-mode-case
()
(
:plural
(
no-macro-call
,@
form
))
(
t
(
truncate%
2ops%
1ret
,
number
,
divisor
))))
(
t
(
truncate%1ret
,
number
,
divisor
))))
(
defun
truncate%
2ops%
1ret
(
number
divisor
)
(
defun
truncate%1ret
(
number
divisor
)
(
with-inline-assembly
(
:returns
:multiple-values
)
(
:compile-form
(
:result-mode
:eax
)
number
)
(
:compile-form
(
:result-mode
:ebx
)
divisor
)
...
...
@@ -723,7 +745,7 @@
(
:shll
#.
movitz::+movitz-fixnum-shift+
:eax
)
(
:clc
)))
(
define-compiler-macro
truncate%
2ops%
1ret
(
&whole
form
&environment
env
number
divisor
)
(
define-compiler-macro
truncate%1ret
(
&whole
form
&environment
env
number
divisor
)
(
cond
((
movitz:movitz-constantp
divisor
env
)
(
let
((
d
(
movitz:movitz-eval
divisor
env
)))
...
...
@@ -731,7 +753,7 @@
(
case
d
(
0
(
error
"Truncate by zero."
))
(
1
number
)
(
t
`
(
with-inline-assembly
(
:returns
:eax
:type
integer
)
(
t
`
(
with-inline-assembly
(
:returns
:eax
:type
fixnum
)
(
:compile-form
(
:result-mode
:eax
)
,
number
)
(
:compile-form
(
:result-mode
:ebx
)
,
divisor
)
(
:testb
#.
movitz::+movitz-fixnum-zmask+
:al
)
...
...
@@ -741,26 +763,116 @@
(
:shll
#.
movitz::+movitz-fixnum-shift+
:eax
))))))
(
t
form
)))
(
defmacro
number-double-dispatch
((
x
y
)
&rest
clauses
)
`
(
let
((
x
,
x
)
(
y
,
y
))
(
cond
,@
(
loop
for
((
x-type
y-type
)
.
then-body
)
in
clauses
collect
`
((
and
(
typep
x
',x-type
)
(
typep
y
',y-type
))
,@
then-body
))
(
t
(
error
"Not numbers: ~S or ~S."
x
y
)))))
(
defun
truncate
(
number
&optional
(
divisor
1
))
(
numargs-case
(
1
(
number
)
(
values
number
0
))
(
t
(
number
divisor
)
(
with-inline-assembly
(
:returns
:multiple-values
)
(
:compile-form
(
:result-mode
:eax
)
number
)
(
:compile-form
(
:result-mode
:ebx
)
divisor
)
(
:movl
:eax
:ecx
)
(
:orl
:ebx
:ecx
)
(
:testb
#.
movitz::+movitz-fixnum-zmask+
:cl
)
(
:jnz
'
(
:sub-program
(
not-integer
)
(
:int
107
)))
(
:cdq
:eax
:edx
)
(
:idivl
:ebx
:eax
:edx
)
(
:shll
#.
movitz::+movitz-fixnum-shift+
:eax
)
(
:movl
:edx
:ebx
)
(
:xorl
:ecx
:ecx
)
(
:movb
2
:cl
)
; return values: qutient, remainder.
(
:stc
)))))
(
number-double-dispatch
(
number
divisor
)
((
fixnum
fixnum
)
(
with-inline-assembly
(
:returns
:multiple-values
)
(
:compile-form
(
:result-mode
:eax
)
number
)
(
:compile-form
(
:result-mode
:ebx
)
divisor
)
(
:std
)
(
:cdq
:eax
:edx
)
(
:idivl
:ebx
:eax
:edx
)
(
:shll
#.
movitz::+movitz-fixnum-shift+
:eax
)
(
:cld
)
(
:movl
:edx
:ebx
)
(
:xorl
:ecx
:ecx
)
(
:movb
2
:cl
)
; return values: qutient, remainder.
(
:stc
)))
((
positive-bignum
positive-fixnum
)
(
let
(
r
n
)
(
with-inline-assembly
(
:returns
:multiple-values
)
(
:compile-form
(
:result-mode
:ebx
)
number
)
(
:movzxw
(
:ebx
#.
(
bt:slot-offset
'movitz::movitz-bignum
'movitz::length
))
:ecx
)
(
:cmpl
1
:ecx
)
(
:jne
'not-size1
)
(
:compile-form
(
:result-mode
:ecx
)
divisor
)
(
:shrl
#.
movitz:+movitz-fixnum-shift+
:ecx
)
(
:std
)
(
:movl
(
:ebx
#.
(
bt:slot-offset
'movitz::movitz-bignum
'movitz::bigit0
))
:eax
)
(
:xorl
:edx
:edx
)
(
:divl
:ecx
:eax
:edx
)
(
:movl
:eax
:ecx
)
(
:shll
#.
movitz:+movitz-fixnum-shift+
:edx
)
(
:movl
:edi
:eax
)
(
:cld
)
(
:pushl
:edx
)
(
:call-global-constant
normalize-u32-ecx
)
(
:popl
:ebx
)
(
:jmp
'done
)
not-size1
(
:cmpl
2
:ecx
)
(
:jne
'not-size2
)
(
:compile-form
(
:result-mode
:ecx
)
divisor
)
(
:shrl
#.
movitz:+movitz-fixnum-shift+
:ecx
)
(
:std
)
(
:movl
(
:ebx
#.
(
cl:+
4
(
bt:slot-offset
'movitz::movitz-bignum
'movitz::bigit0
)))
:edx
)
(
:cmpl
:ecx
:edx
)
(
:jae
'not-size2
)
(
:movl
(
:ebx
#.
(
bt:slot-offset
'movitz::movitz-bignum
'movitz::bigit0
))
:eax
)
(
:divl
:ecx
:eax
:edx
)
(
:movl
:eax
:ecx
)
(
:shll
#.
movitz:+movitz-fixnum-shift+
:edx
)
(
:movl
:edi
:eax
)
(
:cld
)
(
:pushl
:edx
)
(
:call-global-constant
normalize-u32-ecx
)
(
:popl
:ebx
)
(
:jmp
'done
)
not-size2
(
:cmpl
:ecx
(
:ebx
#.
(
bt:slot-offset
'movitz::movitz-bignum
'movitz::bigit0
)
-4
(
:ecx
4
)))
(
:jc
'shrink-not-size2
)
not-shrink
(
:leal
((
:ecx
#.
movitz:+movitz-fixnum-factor+
))
:eax
)
(
:compile-form
(
:result-mode
:eax
)
(
malloc-words
(
with-inline-assembly
(
:returns
:eax
))))
(
:store-lexical
(
:lexical-binding
r
)
:eax
:type
t
)
(
:compile-form
(
:result-mode
:ebx
)
number
)
(
:movl
(
:ebx
#.
movitz:+other-type-offset+
)
:ecx
)
(
:movl
:ecx
(
:eax
#.
movitz:+other-type-offset+
))
(
:shrl
16
:ecx
)
(
:xorl
:edx
:edx
)
; edx=hi-digit=0
; eax=lo-digit=msd(number)
(
:std
)
(
:compile-form
(
:result-mode
:esi
)
divisor
)
(
:shrl
#.
movitz:+movitz-fixnum-shift+
:esi
)
divide-loop
(
:load-lexical
(
:lexical-binding
number
)
:ebx
)
(
:movl
(
:ebx
#.
(
bt:slot-offset
'movitz::movitz-bignum
'movitz::bigit0
)
-4
(
:ecx
4
))
:eax
)
(
:divl
:esi
:eax
:edx
)
(
:load-lexical
(
:lexical-binding
r
)
:ebx
)
(
:movl
:eax
(
:ebx
#.
(
bt:slot-offset
'movitz::movitz-bignum
'movitz::bigit0
)
-4
(
:ecx
4
)))
(
:subl
1
:ecx
)
(
:jnz
'divide-loop
)
(
:movl
:ebx
:eax
)
(
:leal
((
:edx
#.
movitz:+movitz-fixnum-factor+
))
:ebx
)
(
:movl
:edi
:edx
)
(
:movl
(
:ebp
-4
)
:esi
)
(
:cld
)
(
:jmp
'done
)
shrink-not-size2
(
:int
107
)
done
(
:movl
2
:ecx
)
(
:stc
))))
))))
(
defun
round
(
number
&optional
(
divisor
1
))
"Mathematical rounding."
...
...
@@ -1147,4 +1259,4 @@
(
values
q
0
))
(
t
(
values
(
1-
q
)
(
+
r
divisor
))))))
(
t
(
n
&optional
(
divisor
1
))
(
floor
n
divisor
))))
\ No newline at end of file
(
floor
n
divisor
))))
losp/muerte/los-closette.lisp
View file @
deb98f82
...
...
@@ -10,7 +10,7 @@
;;;; Author: Frode Vatvedt Fjeld <frodef@acm.org>
;;;; Created at: Tue Jul 23 14:29:10 2002
;;;;
;;;; $Id: los-closette.lisp,v 1.
9 2004/04/19 22:38
:27 ffjeld Exp $
;;;; $Id: los-closette.lisp,v 1.
10 2004/04/21 15:07
:27 ffjeld Exp $
;;;;
;;;;------------------------------------------------------------------
...
...
@@ -908,7 +908,7 @@ for a slot at position i.")
(
assert
slot
(
slot-name
)
"No slot named ~S in class ~S."
slot-name
class
)
(
let
((
slot-location
(
slot-definition-location
slot
)))
(
check-type
slot-location
(
integer
0
*
))
(
check-type
slot-location
(
integer
0
#xffff
))
(
etypecase
class
(
standard-class
(
if
(
and
(
<
slot-location
(
length
*standard-effective-slot-readers*
))
...
...
losp/muerte/primitive-functions.lisp
View file @
deb98f82
...
...
@@ -10,7 +10,7 @@
;;;; Author: Frode Vatvedt Fjeld <frodef@acm.org>
;;;; Created at: Tue Oct 2 21:02:18 2001
;;;;
;;;; $Id: primitive-functions.lisp,v 1.1
6 2004/04/21 15:08:36
ffjeld Exp $
;;;; $Id: primitive-functions.lisp,v 1.1
7 2004/05/21 09:41:11
ffjeld Exp $
;;;;
;;;;------------------------------------------------------------------
...
...
@@ -441,8 +441,8 @@ Returns list in EAX and preserves numargs in ECX."
(
defun
malloc-initialize
(
buffer-start
buffer-size
)
"BUFFER-START: the (fixnum) 4K address. BUFFER-SIZE: The size in 4K units."
(
check-type
buffer-start
integer
)
(
check-type
buffer-size
integer
)
(
check-type
buffer-start
fixnum
)
(
check-type
buffer-size
fixnum
)
(
with-inline-assembly
(
:returns
:nothing
)
(
:compile-form
(
:result-mode
:eax
)
buffer-start
)
(
:shll
#.
(
cl:-
12
movitz::+movitz-fixnum-shift+
)
:eax
)
...
...
@@ -504,6 +504,17 @@ Returns list in EAX and preserves numargs in ECX."
return-ok
(
:ret
)))
(
define-primitive-function
normalize-u32-ecx
()
"Make u32 in ECX into a fixnum or bignum."
(
with-inline-assembly
(
:returns
:multiple-values
)
(
:cmpl
#.
movitz:+movitz-most-positive-fixnum+
:ecx
)
(
:ja
'not-fixnum
)
(
:leal
((
:ecx
#.
movitz:+movitz-fixnum-factor+
))
:eax
)
(
:ret
)
not-fixnum
(
:int
107
)))
; not implemented by default!
;;;;
(
define-primitive-function
fast-class-of-even-fixnum
()
...
...
@@ -566,32 +577,42 @@ Returns list in EAX and preserves numargs in ECX."
(
:globally
(
:movl
(
:edi
(
:edi-offset
classes
))
:ebx
))
(
:cmpl
:edi
:eax
)
(
:je
'null
)