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)))) |
---|