source: trunk/source/level-0/ARM/arm-pred.lisp @ 15601

Last change on this file since 15601 was 15294, checked in by gb, 8 years ago

Don't call out in .SPbuiltin_eql. Implement #'EQL for ARM in terms
of .SPbuiltin_eql.

Note that running the old kernel with a new image will cause an
infinite loop in EQL in some cases. Don't do that; do
(REBUILD-CCL :FULL T) to avoid the issue.

File size: 2.5 KB
Line 
1;;;-*- Mode: Lisp; Package: CCL -*-
2;;;
3;;;   Copyright (C) 2010 Clozure Associates
4;;;   This file is part of Clozure CL. 
5;;;
6;;;   Clozure CL is licensed under the terms of the Lisp Lesser GNU Public
7;;;   License , known as the LLGPL and distributed with Clozure CL as the
8;;;   file "LICENSE".  The LLGPL consists of a preamble and the LGPL,
9;;;   which is distributed with Clozure CL as the file "LGPL".  Where these
10;;;   conflict, the preamble takes precedence. 
11;;;
12;;;   Clozure CL is referenced in the preamble as the "LIBRARY."
13;;;
14;;;   The LLGPL is also available online at
15;;;   http://opensource.franz.com/preamble.html
16
17(in-package "CCL")
18
19(eval-when (:compile-toplevel :execute)
20  (require "ARM-LAPMACROS"))
21
22(defarmlapfunction eql ((x arg_y) (y arg_z))
23  "Return T if OBJ1 and OBJ2 represent the same object, otherwise NIL."
24  (check-nargs 2)
25  (spjump .SPbuiltin-eql))
26
27
28 
29
30(defarmlapfunction equal ((x arg_y) (y arg_z))
31  "Return T if X and Y are EQL or if they are structured components
32  whose elements are EQUAL. Strings and bit-vectors are EQUAL if they
33  are the same length and have identical components. Other arrays must be
34  EQ to be EQUAL.  Pathnames are EQUAL if their components are."
35  (check-nargs 2)
36  @top
37  (cmp x y)
38  (extract-fulltag imm0 x)
39  (extract-fulltag imm1 y)
40  (beq @win)
41  (cmp imm0 imm1)
42  (bne @lose)
43  (cmp imm0 (:$ arm::fulltag-cons))
44  (beq @cons)
45  (cmp imm0 (:$ arm::fulltag-misc))
46  (beq @misc)
47  @lose
48  (mov arg_z 'nil)
49  (bx lr)
50  @win
51  (mov arg_z 'nil)
52  (add arg_z arg_z (:$ arm::t-offset))
53  (bx lr)
54  @cons
55  (%car temp0 x)
56  (%car temp1 y)
57  (cmp temp0 temp1)
58  (bne @recurse)
59  (%cdr x x)
60  (%cdr y y)
61  (b @top)
62  @recurse
63  (vpush1 x)
64  (vpush1 y)
65  (build-lisp-frame imm0)
66  (mov fn nfn)
67  (mov x temp0)
68  (mov y temp1)
69  (bl @top)
70  (cmp arg_z 'nil) 
71  (mov nfn fn)
72  (restore-lisp-frame imm0)           ; gets old fn to fn 
73  (vpop1 y)
74  (vpop1 x)
75  (beq  @lose)
76  (%cdr x x)
77  (%cdr y y)
78  (b @top)
79  @misc
80  (extract-subtag imm0 x)
81  (extract-subtag imm1 y)
82  (cmp imm0 (:$ arm::subtag-vectorH))
83  (cmpne imm1 (:$ arm::subtag-vectorH))
84  (beq @hairy)
85  (cmp imm0 (:$ arm::subtag-macptr))
86  (bgt @same)
87  (set-nargs 2)
88  (ldr fname (:@ nfn 'eql))
89  (ldr nfn (:@ fname (:$ arm::symbol.fcell)))
90  (ldr pc (:@ nfn (:$ arm::function.entrypoint)))
91  @same
92  (cmp imm1 imm0)
93  (bne @lose)
94  @hairy
95  (set-nargs 2)
96  (ldr fname (:@ nfn 'hairy-equal))
97  (ldr nfn (:@ fname (:$ arm::symbol.fcell)))
98  (ldr pc (:@ nfn (:$ arm::function.entrypoint))))
Note: See TracBrowser for help on using the repository browser.