source: branches/working-0711/ccl/compiler/nx1.lisp @ 9391

Last change on this file since 9391 was 9391, checked in by gz, 12 years ago

Let the load-time-value form access the definition environment, so it at least knows about special decls. A little iffy but I'm hoping it's ok in practice.

  • Property svn:eol-style set to native
  • Property svn:keywords set to Author Date Id Revision
File size: 86.5 KB
Line 
1;;;-*-Mode: LISP; Package: CCL -*-
2;;;
3;;;   Copyright (C) 1994-2001 Digitool, Inc
4;;;   This file is part of OpenMCL. 
5;;;
6;;;   OpenMCL is licensed under the terms of the Lisp Lesser GNU Public
7;;;   License , known as the LLGPL and distributed with OpenMCL as the
8;;;   file "LICENSE".  The LLGPL consists of a preamble and the LGPL,
9;;;   which is distributed with OpenMCL as the file "LGPL".  Where these
10;;;   conflict, the preamble takes precedence. 
11;;;
12;;;   OpenMCL 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;;; Wimp out, but don't choke on (the (values ...) form)
20(defnx1 nx1-the the (&whole call typespec form &environment env)
21  (if (and (self-evaluating-p form)
22               (not (typep form typespec))
23               (progn (nx1-whine :type call) t))
24    (setq typespec t))
25  ;; Allow VALUES types here (or user-defined types that
26  ;; expand to VALUES types).
27  (let* ((ctype (values-specifier-type typespec)))
28    (if (typep ctype 'values-ctype)
29      (setq typespec '*)
30      (setq typespec (nx-target-type (type-specifier ctype)))))
31  (let* ((*nx-form-type* typespec))
32    (make-acode
33     (%nx1-operator typed-form)
34     typespec
35     (nx1-transformed-form (let ((transformed (nx-transform form env)))
36                             (if (and (consp transformed)
37                                      (eq (car transformed) 'the))
38                               form
39                               transformed))
40                           env form))))
41
42(defnx1 nx1-struct-ref struct-ref (&whole whole structure offset)
43  (if (not (fixnump (setq offset (nx-get-fixnum offset))))
44    (nx1-treat-as-call whole)
45    (make-acode (%nx1-operator struct-ref)
46                (nx1-form structure)
47                (nx1-form offset))))
48
49(defnx1 nx1-struct-set struct-set (&whole whole structure offset newval)
50  (if (not (fixnump (setq offset (nx-get-fixnum offset))))
51    (nx1-treat-as-call whole)
52    (make-acode
53     (%nx1-operator struct-set)
54     (nx1-form structure)
55     (nx1-form offset)
56     (nx1-form newval))))
57
58(defnx1 nx1-istruct-typep ((istruct-typep)) (&whole whole thing type &environment env)
59  (if (and (quoted-form-p type) (symbolp (cadr type)))
60    (make-acode (%nx1-operator istruct-typep)
61                (nx1-immediate :eq)
62                (nx1-form thing)
63                (nx1-form type))
64    (nx1-treat-as-call whole)))
65
66(defnx1 nx1-make-list make-list (&whole whole size &rest keys &environment env)
67  (if (and keys 
68             (or 
69              (neq (list-length keys) 2)
70              (neq (nx-transform (%car keys) env) :initial-element)))
71    (nx1-treat-as-call whole)
72    (make-acode
73     (%nx1-operator make-list)
74     (nx1-form size)
75     (nx1-form (%cadr keys)))))
76
77;;; New semantics: expansion functions are defined in current lexical environment
78;;; vice null environment.  May be meaningless ...
79(defnx1 nx1-macrolet macrolet (defs &body body)
80  (let* ((old-env *nx-lexical-environment*)
81         (new-env (new-lexical-environment old-env)))
82    (dolist (def defs)
83      (destructuring-bind (name arglist &body mbody) def
84        (push 
85         (cons 
86          name
87          (cons
88           'macro
89           (multiple-value-bind (function warnings)
90               (compile-named-function (parse-macro name arglist mbody old-env) :name name :env old-env)
91             (setq *nx-warnings* (append *nx-warnings* warnings))
92             function)))
93         (lexenv.functions new-env))))
94    (let* ((*nx-lexical-environment* new-env))
95      (with-nx-declarations (pending)
96        (multiple-value-bind (body decls) (parse-body body new-env)
97          (nx-process-declarations pending decls)
98          (nx1-progn-body body))))))
99
100;;; Does SYMBOL-MACROLET allow declarations ?  Yes ...
101(defnx1 nx1-symbol-macrolet symbol-macrolet (defs &body forms)
102  (let* ((old-env *nx-lexical-environment*))
103    (with-nx-declarations (pending)
104      (multiple-value-bind (body decls)
105                           (parse-body forms old-env nil)
106        (nx-process-declarations pending decls)
107        (let ((env *nx-lexical-environment*)
108              (*nx-bound-vars* *nx-bound-vars*))
109          (dolist (def defs)
110            (destructuring-bind (sym expansion) def
111              (let* ((var (nx-new-var pending sym))
112                     (bits (nx-var-bits var)))
113                (when (%ilogbitp $vbitspecial bits)
114                  (nx-error "SPECIAL declaration applies to symbol macro ~s" sym))
115                (nx-set-var-bits var (%ilogior (%ilsl $vbitignoreunused 1) bits))
116                (setf (var-ea var) (cons :symbol-macro expansion)))))
117          (nx-effect-other-decls pending env)
118          (nx1-env-body body old-env))))))
119
120(defnx1 nx1-progn progn (&body args)
121  (nx1-progn-body args))
122
123(defnx1 nx1-with-c-frame with-c-frame (var &body body)
124  (make-acode (%nx1-operator with-c-frame)
125              (nx1-form `(let* ((,var (%foreign-stack-pointer)))
126                          ,@body))))
127
128(defnx1 nx1-with-variable-c-frame with-variable-c-frame (size var &body body)
129  (make-acode (%nx1-operator with-variable-c-frame)
130              (nx1-form size)
131              (nx1-form `(let* ((,var (%foreign-stack-pointer)))
132                          ,@body))))
133
134
135(defun nx1-progn-body (args)
136  (if (null (cdr args))
137    (nx1-form (%car args))
138    (make-acode (%nx1-operator progn) (nx1-formlist args))))
139
140(defnx1 nx1-unaryop ((%word-to-int) (uvsize)  (%reference-external-entry-point)
141                     (%symbol->symptr))
142        (arg)
143  (make-acode
144   (%nx1-default-operator) (nx1-form arg)))
145
146(defnx1 nx1-nullaryop ((%current-tcr) (%interrupt-poll) (%foreign-stack-pointer) (%current-frame-ptr)) ()
147  (make-acode (%nx1-default-operator)))
148
149(defnx1 nx1-fixnum-ref ((%fixnum-ref) (%fixnum-ref-natural)) (base &optional (offset 0))
150  (make-acode (%nx1-default-operator)
151              (nx1-form base)
152              (nx1-form offset)))
153
154(defnx1 nx1-type-unaryop ((typecode) (lisptag) (fulltag))
155  (arg)
156  (let* ((operator
157          (case *nx-sfname*
158            ((typecode) (%nx1-operator typecode))
159            ((lisptag) (%nx1-operator lisptag))
160            (( fulltag) (%nx1-operator fulltag)))))
161    (make-acode
162     operator (nx1-form arg))))
163       
164
165(defnx1 nx1-code-char ((code-char)) (arg &environment env)
166  (make-acode (if (nx-form-typep arg '(unsigned-byte 8) env)
167                (%nx1-operator %code-char)
168                (%nx1-operator code-char))
169              (nx1-form arg)))
170
171(defnx1 nx1-char-code ((char-code)) (arg &environment env)
172  (make-acode (if (nx-form-typep arg 'character env)
173                (%nx1-operator %char-code)
174                (%nx1-operator char-code))
175              (nx1-form arg)))
176
177(defnx1 nx1-cXr ((car) (cdr)) (arg &environment env)
178  (let* ((op (if (eq *nx-sfname* 'car) (%nx1-operator car) (%nx1-operator cdr)))
179         (inline-op (if (eq op (%nx1-operator car)) (%nx1-operator %car) (%nx1-operator %cdr))))
180    (make-acode (if (or (nx-inline-car-cdr env) (nx-form-typep arg 'list env))
181                  inline-op
182                  op)
183                (nx1-prefer-areg arg env))))
184
185(defnx1 nx1-rplacX ((rplaca) (rplacd)) (pairform valform &environment env)
186  (let* ((op (if (eq *nx-sfname* 'rplaca) (%nx1-operator rplaca) (%nx1-operator rplacd)))
187         (inline-op (if (eq op (%nx1-operator rplaca)) (%nx1-operator %rplaca) (%nx1-operator %rplacd))))
188    (make-acode (if (or (nx-inline-car-cdr env)
189                                 (and (nx-trust-declarations env)
190                                      (or (subtypep *nx-form-type* 'cons)
191                                          (nx-form-typep pairform 'cons env))))
192                  inline-op
193                  op)
194                (nx1-prefer-areg pairform env)
195                (nx1-form valform))))
196
197(defnx1 nx1-set-cXr ((set-car) (set-cdr)) (pairform valform &environment env)
198  (let* ((op (if (eq *nx-sfname* 'set-car) (%nx1-operator set-car) (%nx1-operator set-cdr)))
199         (inline-op (if (eq op (%nx1-operator set-car)) (%nx1-operator %rplaca) (%nx1-operator %rplacd)))
200         (inline-p (or (nx-inline-car-cdr env)
201                            (and (nx-trust-declarations env)
202                                 (or (subtypep *nx-form-type* 'cons)
203                                     (nx-form-typep pairform 'cons env)))))
204         (acode (make-acode (if inline-p inline-op op)
205                            (nx1-prefer-areg pairform env)
206                            (nx1-form valform))))
207    (if inline-p
208      (make-acode (if (eq op (%nx1-operator set-car)) (%nx1-operator %car) (%nx1-operator %cdr)) acode)
209      acode)))
210
211(defun nx1-cc-binaryop (op cc form1 form2)
212  (make-acode op (nx1-immediate cc) (nx1-form form1) (nx1-form form2)))
213
214(defnx1 nx1-ccEQ-unaryop ((characterp)  (endp) (consp) (base-char-p)) (arg)
215  (make-acode (%nx1-default-operator) (nx1-immediate :EQ) (nx1-form arg)))
216
217
218
219(defnx1 nx1-ccEQ-binaryop ( (%ptr-eql) (eq))
220        (form1 form2)
221  (nx1-cc-binaryop (%nx1-default-operator) :eq form1 form2))
222
223
224(defnx1 nx1-ccNE-binaryop ((neq))
225        (form1 form2)
226  (nx1-cc-binaryop (%nx1-default-operator) :ne form1 form2))
227
228(defnx1 nx1-logbitp ((logbitp)) (&whole w bitnum int &environment env)
229  (if (and (nx-form-typep bitnum
230                          (target-word-size-case (32 '(integer 0 29))
231                                                 (64 '(integer 0 60))) env)
232           (nx-form-typep int 'fixnum env))
233    (nx1-cc-binaryop (%nx1-operator %ilogbitp) :ne bitnum int)
234    (make-acode (%nx1-operator logbitp) (nx1-form bitnum) (nx1-form int))))
235
236
237 
238(defnx1 nx1-ccGT-unaryop ((int>0-p)) (arg)
239  (make-acode (%nx1-default-operator) (nx1-immediate :gt) (nx1-form arg)))
240
241(defnx1 nx1-macro-unaryop (multiple-value-list) (arg)
242  (make-acode
243   (%nx1-default-operator) (nx1-form arg)))
244
245(defnx1 nx1-atom ((atom)) (arg)
246  (nx1-form `(not (consp ,arg))))
247
248(defnx1 nx1-locally locally (&body forms)
249  (with-nx-declarations (pending)
250    (let ((env *nx-lexical-environment*))
251      (multiple-value-bind (body decls) (parse-body forms env  nil)
252        (nx-process-declarations pending decls)
253        (nx-effect-other-decls pending env)
254         (setq body (nx1-progn-body body))
255         (if decls
256           (make-acode (%nx1-operator %decls-body) body *nx-new-p2decls*)
257           body)))))
258
259(defnx1 nx1-%new-ptr (%new-ptr) (&whole whole size clear-p)
260  (make-acode (%nx1-operator %new-ptr) (nx1-form size) (nx1-form clear-p)))
261
262;;; This might also want to look at, e.g., the last form in a progn:
263;;;  (not (progn ... x)) => (progn ... (not x)), etc.
264(defnx1 nx1-negation ((not) (null)) (arg)
265  (if (nx1-negate-form (setq arg (nx1-form arg)))
266    arg
267    (make-acode (%nx1-operator not) (nx1-immediate :eq) arg)))
268
269(defun nx1-negate-form (form)
270  (let* ((subform (nx-untyped-form form)))
271    (when (and (acode-p subform) (typep (acode-operator subform) 'fixnum)) 
272      (let* ((op (acode-operator subform)))
273        (declare (fixnum op))
274        (when (logbitp operator-cc-invertable-bit op)
275          (%rplaca 
276           (%cdr (%cadr subform))
277           (acode-invert-condition-keyword (%cadr (%cadr subform))))
278          t)))))
279
280;;; This is called from pass 1, and therefore shouldn't mess with "puntable bindings"
281;;; (assuming, of course, that anyone should ...)
282(defun nx-untyped-form (form)
283  (while (and (consp form)
284              (eq (%car form) (%nx1-operator typed-form)))
285    (setq form (%caddr form)))
286  form)
287
288
289
290(defnx1 nx1-cxxr ((caar) (cadr) (cdar) (cddr)) (form)
291  (let* ((op *nx-sfname*))
292    (let* ((inner (case op 
293                       ((cdar caar) 'car)
294                       (t 'cdr)))
295              (outer (case op
296                       ((cdar cddr) 'cdr)
297                       (t 'car))))
298         (nx1-form `(,outer (,inner ,form))))))     
299
300(defnx1 nx1-%int-to-ptr ((%int-to-ptr)) (int)
301  (make-acode 
302   (%nx1-operator %consmacptr%)
303   (make-acode (%nx1-operator %immediate-int-to-ptr) 
304               (nx1-form int))))
305
306(defnx1 nx1-%ptr-to-int ((%ptr-to-int)) (ptr)
307  (make-acode 
308   (%nx1-operator %immediate-ptr-to-int)
309   (make-acode (%nx1-operator %macptrptr%) 
310               (nx1-form ptr))))
311
312(defnx1 nx1-%null-ptr-p ((%null-ptr-p)) (ptr)
313  (nx1-form `(%ptr-eql ,ptr (%int-to-ptr 0))))
314
315(defnx1 nx1-binop ( (%ilsl) (%ilsr) (%iasr)
316                   (cons) (%temp-cons))
317        (arg1 arg2)
318  (make-acode (%nx1-default-operator) (nx1-form arg1) (nx1-form arg2)))
319
320
321
322(defnx1 nx1-%misc-ref ((%misc-ref)) (v i)
323  (make-acode (%nx1-operator uvref) (nx1-form v) (nx1-form i)))
324
325
326
327
328(defnx1 nx1-schar ((schar)) (s i &environment env)
329  (make-acode (%nx1-operator %sbchar) (nx1-form s env) (nx1-form i env)))
330
331
332;;; This has to be ultra-bizarre because %schar is a macro.
333;;; %schar shouldn't be a macro.
334(defnx1 nx1-%schar ((%schar)) (&whole w arg idx &environment env)
335  (let* ((arg (nx-transform arg env))
336         (idx (nx-transform idx env))
337         (argvar (make-symbol "STRING"))
338         (idxvar (make-symbol "INDEX")))
339    (nx1-form `(let* ((,argvar ,arg)
340                      (,idxvar ,idx))
341                 (declare (optimize (speed 3) (safety 0)))
342                 (declare (simple-base-string ,argvar))
343                 (schar ,argvar ,idxvar)) env)))
344       
345(defnx1 nx1-%scharcode ((%scharcode)) (arg idx &environment env)
346  (make-acode (%nx1-operator %scharcode) (nx1-form arg)(nx1-form idx)))
347
348
349(defnx1 nx1-svref ((svref) (%svref)) (&environment env v i)
350  (make-acode (if (nx-inhibit-safety-checking env)
351                (%nx1-operator %svref)
352                (%nx1-default-operator))
353              (nx1-prefer-areg v env)
354              (nx1-form i)))
355
356(defnx1 nx1-%slot-ref ((%slot-ref)) (instance idx)
357  (make-acode (%nx1-default-operator)
358              (nx1-form instance)
359              (nx1-form idx)))
360
361
362(defnx1 nx1-%err-disp ((%err-disp)) (&rest args)
363  (make-acode (%nx1-operator %err-disp)
364              (nx1-arglist args)))                       
365             
366(defnx1 nx1-macro-binop ((nth-value)) (arg1 arg2)
367  (make-acode (%nx1-default-operator) (nx1-form arg1) (nx1-form arg2)))
368
369(defnx1 nx1-%typed-miscref ((%typed-miscref) (%typed-misc-ref)) (subtype uvector index)
370  (make-acode (%nx1-operator %typed-uvref) 
371                (nx1-form subtype) 
372                (nx1-form uvector) 
373                (nx1-form index)))
374
375
376
377(defnx1 nx1-%typed-miscset ((%typed-miscset) (%typed-misc-set)) (subtype uvector index newvalue)
378  (make-acode (%nx1-operator %typed-uvset) 
379                (nx1-form subtype) 
380                (nx1-form uvector) 
381                (nx1-form index) 
382                (nx1-form newvalue)))
383
384(defnx1 nx1-logior-2 ((logior-2)) (&whole w &environment env arg-1 arg-2)
385  (nx-binary-boole-op w 
386                      env 
387                      arg-1 
388                      arg-2 
389                      (%nx1-operator %ilogior2)
390                      (%nx1-operator logior2)
391                      (%nx1-operator %natural-logior)))
392
393(defnx1 nx1-logxor-2 ((logxor-2)) (&whole w &environment env arg-1 arg-2)
394  (nx-binary-boole-op w 
395                      env 
396                      arg-1 
397                      arg-2 
398                      (%nx1-operator %ilogxor2)
399                      (%nx1-operator logxor2)
400                      (%nx1-operator %natural-logxor)))
401
402(defnx1 nx1-logand-2 ((logand-2)) (&whole w &environment env arg-1 arg-2)
403  (nx-binary-boole-op w 
404                      env 
405                      arg-1 
406                      arg-2 
407                      (%nx1-operator %ilogand2)
408                      (%nx1-operator logand2)
409                      (%nx1-operator %natural-logand)))
410
411(defnx1 nx1-require ((require-simple-vector) (require-simple-string) (require-integer) (require-list)
412                     (require-fixnum) (require-real) (require-character) (require-number) (require-symbol) (require-s8) (require-u8) (require-s16) (require-u16) (require-s32) (require-u32) (require-s64) (require-u64))
413        (arg)
414  (make-acode (%nx1-default-operator) (nx1-form arg)))
415
416(defnx1 nx1-%marker-marker ((%unbound-marker) (%slot-unbound-marker) (%illegal-marker)) ()
417  (make-acode (%nx1-default-operator)))
418
419(defnx1 nx1-throw (throw) (tag valuesform)
420  (make-acode (%nx1-operator throw) (nx1-form tag) (nx1-form valuesform)))
421
422
423;;; This is still used in inlining/lambda application.
424;;; The tricky parts of handling inlining reasonably have to do with
425;;; processing the body (including &optional/&key forms) in the environment
426;;; in which the lambda was defined (e.g., macros and symbol-macros.)
427;;; (I'm not sure that the traditional MCL/OpenMCL frontend handles
428;;; these cases 100% correctly, but it seems difficult to do this
429;;;  correctly without being able to jerk around with the environment,
430;;; for a variety of reasons.)
431;;; A lambda application - ((lambda ()) ...) is applied in the same
432;;; environment it's defined in, so the hard case involves inlining
433;;; functions whose environment may contain syntactic constructs
434;;; not present in the current environment (and which does -not- generally
435;;; contain whatever randomness is floating around at the point of
436;;; application.)
437(defun nx1-destructure (lambda-list bindform cdr-p &whole-allowed-p forms &optional (body-env *nx-lexical-environment*))
438  (let* ((old-env body-env)
439         (*nx-bound-vars* *nx-bound-vars*)
440         (bindform (nx1-form bindform)))
441    (if (not (verify-lambda-list lambda-list t &whole-allowed-p))
442      (nx-error "Invalid lambda-list ~s" lambda-list)
443      (let* ((*nx-lexical-environment* body-env))
444        (with-nx-declarations (pending)
445          (multiple-value-bind (body decls)
446                               (parse-body forms *nx-lexical-environment*)
447            (nx-process-declarations pending decls)
448            (multiple-value-bind (req opt rest keys auxen whole)
449                                 (nx-parse-structured-lambda-list pending lambda-list nil &whole-allowed-p)
450              (nx-effect-other-decls pending *nx-lexical-environment*)
451              (make-acode
452               (%nx1-operator debind)
453               nil
454               bindform
455               req
456               opt
457               rest
458               keys
459               auxen
460               whole
461               (nx1-env-body body old-env)
462               *nx-new-p2decls*
463               cdr-p))))))))
464
465
466
467(defnx1 nx1-%setf-macptr ((%setf-macptr)) (ptr newval)
468  (let* ((arg1 (nx1-form ptr))
469         (arg2 (nx1-form newval)))
470    (if (and (consp arg1) (eq (%car arg1) (%nx1-operator %consmacptr%)))
471      ;e.g. (%setf-macptr (%null-ptr) <foo>)
472      (make-acode (%nx1-operator %consmacptr%)
473                  (make-acode (%nx1-operator progn)
474                              (list arg1 (make-acode (%nx1-operator %macptrptr%) arg2))))
475      (make-acode (%nx1-operator %setf-macptr) arg1 arg2))))
476
477(defnx1 nx1-%setf-double-float ((%setf-double-float)) (double-node double-val)
478  (make-acode (%nx1-operator %setf-double-float) (nx1-form double-node) (nx1-form double-val)))
479
480(defnx1 nx1-%setf-short-float ((%setf-short-float) (%setf-single-float)) (short-node short-val)
481  (target-word-size-case
482   (32
483    (make-acode (%nx1-operator %setf-short-float) (nx1-form short-node) (nx1-form short-val)))
484   (64
485    (error "%SETF-SHORT-FLOAT makes no sense on 64-bit platforms."))))
486
487   
488(defnx1 nx1-%inc-ptr ((%inc-ptr)) (ptr &optional (increment 1))
489  (make-acode (%nx1-operator %consmacptr%)
490              (make-acode (%nx1-operator %immediate-inc-ptr)
491                          (make-acode (%nx1-operator %macptrptr%) (nx1-form ptr))
492                          (nx1-form increment))))
493
494(defnx1 nx1-svset ((svset) (%svset)) (&environment env vector index value)
495  (make-acode (if (nx-inhibit-safety-checking env)
496                (%nx1-operator %svset)
497                (%nx1-default-operator))
498              (nx1-prefer-areg vector env) (nx1-form index) (nx1-form value)))
499
500(defnx1 nx1-+ ((+-2)) (&whole whole &environment env num1 num2)
501  (let* ((f1 (nx1-form num1))
502         (f2 (nx1-form num2)))
503    (if (nx-binary-fixnum-op-p num1 num2 env t)
504      (let* ((fixadd (make-acode (%nx1-operator %i+) f1 f2))
505             (small-enough (target-word-size-case
506                            (32 '(signed-byte 28))
507                            (64 '(signed-byte 59)))))
508        (if (or (and (nx-acode-form-typep f1 small-enough env)
509                     (nx-acode-form-typep f2 small-enough env))
510                (nx-binary-fixnum-op-p num1 num2 env nil))
511          fixadd
512          (make-acode (%nx1-operator typed-form) 'integer (make-acode (%nx1-operator fixnum-overflow) fixadd))))
513      (if (and (nx-form-typep num1 'double-float env)
514               (nx-form-typep num2 'double-float env))
515        (nx1-form `(%double-float+-2 ,num1 ,num2))
516        (if (and (nx-form-typep num1 'short-float env)
517                 (nx-form-typep num2 'short-float env))
518          (nx1-form `(%short-float+-2 ,num1 ,num2))
519          (if (nx-binary-natural-op-p num1 num2 env nil)
520            (make-acode (%nx1-operator typed-form)
521                        (target-word-size-case
522                         (32 '(unsigned-byte 32))
523                         (64 '(unsigned-byte 64)))
524                        (make-acode (%nx1-operator %natural+) f1 f2))
525            (make-acode (%nx1-operator typed-form) 'number 
526                        (make-acode (%nx1-operator add2) f1 f2))))))))
527 
528(defnx1 nx1-%double-float-x-2 ((%double-float+-2) (%double-float--2) (%double-float*-2) (%double-float/-2 ))
529        (f0 f1)
530  (make-acode (%nx1-operator typed-form) 'double-float
531              (make-acode (%nx1-default-operator) (nx1-form f0) (nx1-form f1))))
532
533
534(defnx1 nx1-%short-float-x-2 ((%short-float+-2) (%short-float--2) (%short-float*-2) (%short-float/-2 ))
535        (f0 f1)
536  (make-acode (%nx1-operator typed-form) 'short-float
537              (make-acode (%nx1-default-operator) (nx1-form f0) (nx1-form f1))))
538
539
540(defnx1 nx1-*-2 ((*-2)) (&whole whole &environment env num1 num2)
541  (if (nx-binary-fixnum-op-p num1 num2 env)
542    (make-acode (%nx1-operator %i*) (nx1-form num1 env) (nx1-form num2 env))
543    (if (and (nx-form-typep num1 'double-float env)
544             (nx-form-typep num2 'double-float env))
545      (nx1-form `(%double-float*-2 ,num1 ,num2))
546      (if (and (nx-form-typep num1 'short-float env)
547               (nx-form-typep num2 'short-float env))
548        (nx1-form `(%short-float*-2 ,num1 ,num2))
549        (make-acode (%nx1-operator mul2) (nx1-form num1 env) (nx1-form num2 env))))))
550
551(defnx1 nx1-%negate ((%negate)) (&whole whole num &environment env)
552  (if (nx-form-typep num 'fixnum env)
553    (if (subtypep *nx-form-type* 'fixnum)
554      (make-acode (%nx1-operator %%ineg)(nx1-form num))
555      (make-acode (%nx1-operator %ineg) (nx1-form num)))
556    (make-acode (%nx1-operator minus1) (nx1-form num))))
557
558       
559(defnx1 nx1--2 ((--2)) (&whole whole &environment env num0 num1)       
560  (if (nx-binary-fixnum-op-p num0 num1 env t)
561    (let* ((f0 (nx1-form num0))
562           (f1 (nx1-form num1))
563           (fixsub (make-acode (%nx1-operator %i-) f0 f1))
564           (small-enough (target-word-size-case
565                          (32 '(signed-byte 28))
566                          (64 '(signed-byte 59)))))
567      (if (or (and (nx-acode-form-typep f0 small-enough env)
568                   (nx-acode-form-typep f1 small-enough env))
569              (nx-binary-fixnum-op-p num0 num1 env nil))
570        fixsub
571        (make-acode (%nx1-operator fixnum-overflow) fixsub)))
572    (if (and (nx-form-typep num0 'double-float env)
573             (nx-form-typep num1 'double-float env))
574      (nx1-form `(%double-float--2 ,num0 ,num1))
575      (if (and (nx-form-typep num0 'short-float env)
576               (nx-form-typep num1 'short-float env))
577        (nx1-form `(%short-float--2 ,num0 ,num1))
578        (if (nx-binary-natural-op-p num0 num1 env nil)
579          (make-acode (%nx1-operator %natural-)
580                      (nx1-form num0)
581                      (nx1-form num1))
582          (make-acode (%nx1-operator sub2)
583                      (nx1-form num0)
584                      (nx1-form num1)))))))
585     
586(defnx1 nx1-/-2 ((/-2)) (num0 num1 &environment env)
587  (if (and (nx-form-typep num0 'double-float env)
588           (nx-form-typep num1 'double-float env))
589    (nx1-form `(%double-float/-2 ,num0 ,num1))
590    (if (and (nx-form-typep num0 'short-float env)
591             (nx-form-typep num1 'short-float env))
592      (nx1-form `(%short-float/-2 ,num0 ,num1))
593      (make-acode (%nx1-operator div2) (nx1-form num0) (nx1-form num1)))))
594
595
596
597(defnx1 nx1-numcmp ((<-2) (>-2) (<=-2) (>=-2)) (&whole whole &environment env num1 num2)
598  (let* ((op *nx-sfname*)
599         (both-fixnums (nx-binary-fixnum-op-p num1 num2 env t))
600         (both-natural (nx-binary-natural-op-p num1 num2 env ))
601         (both-double-floats
602          (let* ((dfloat-1 (nx-form-typep num1 'double-float env))
603                 (dfloat-2 (nx-form-typep num2 'double-float env)))
604            (if dfloat-1 
605              (or dfloat-2 (if (typep num2 'fixnum) (setq num2 (coerce num2 'double-float))))
606              (if dfloat-2 (if (typep num1 'fixnum) (setq num1 (coerce num1 'double-float)))))))
607         (both-short-floats
608          (let* ((sfloat-1 (nx-form-typep num1 'short-float env))
609                 (sfloat-2 (nx-form-typep num2 'short-float env)))
610            (if sfloat-1 
611              (or sfloat-2 (if (typep num2 'fixnum) (setq num2 (coerce num2 'short-float))))
612              (if sfloat-2 (if (typep num1 'fixnum) (setq num1 (coerce num1 'short-float))))))))
613
614    (if (or both-fixnums both-double-floats both-short-floats both-natural)
615      (make-acode
616       (if both-fixnums
617         (%nx1-operator %i<>)
618         (if both-natural
619           (%nx1-operator %natural<>)
620           (if both-double-floats
621             (%nx1-operator double-float-compare)
622             (%nx1-operator short-float-compare))))
623       (make-acode
624        (%nx1-operator immediate)
625        (if (eq op '<-2)
626          :LT
627          (if (eq op '>=-2)
628            :GE
629            (if (eq op '<=-2)
630              :LE
631              :GT))))
632       (nx1-form num1)
633       (nx1-form num2))
634      (make-acode (%nx1-operator numcmp)
635                  (make-acode
636                   (%nx1-operator immediate)
637                   (if (eq op '<-2)
638                     :LT
639                     (if (eq op '>=-2)
640                       :GE
641                       (if (eq op '<=-2)
642                         :LE
643                         :GT))))
644                  (nx1-form num1)
645                  (nx1-form num2)))))
646
647(defnx1 nx1-num= ((=-2) (/=-2)) (&whole whole &environment env num1 num2 )
648  (let* ((op *nx-sfname*)
649         (2-fixnums (nx-binary-fixnum-op-p num1 num2 env t))
650         (2-naturals (nx-binary-natural-op-p num1 num2 env))
651         (2-rats (and (nx-form-typep num1 'rational env)
652                      (nx-form-typep num2 'rational env)))
653         (2-dfloats (let* ((dfloat-1 (nx-form-typep num1 'double-float env))
654                           (dfloat-2 (nx-form-typep num2 'double-float env)))
655                      (if dfloat-1 
656                        (or dfloat-2 (if (typep num2 'fixnum) (setq num2 (coerce num2 'double-float))))
657                        (if dfloat-2 (if (typep num1 'fixnum) (setq num1 (coerce num1 'double-float)))))))
658         (2-sfloats (let* ((sfloat-1 (nx-form-typep num1 'short-float env))
659                           (sfloat-2 (nx-form-typep num2 'short-float env)))
660                      (if sfloat-1 
661                        (or sfloat-2 (if (typep num2 'fixnum) (setq num2 (coerce num2 'short-float))))
662                        (if sfloat-2 (if (typep num1 'fixnum) (setq num1 (coerce num1 'short-float)))))))
663         )
664    (if (and 2-naturals (not 2-fixnums))
665      (make-acode
666       (%nx1-operator %natural<>)
667       (make-acode
668        (%nx1-operator immediate)
669        (if (eq op '=-2)
670          :EQ
671          :NE))
672       (nx1-form num1)
673       (nx1-form num2))
674      (if 2-rats
675        (let* ((form `(,(if 2-fixnums 'eq 'eql) ,num1 ,num2))) 
676          (nx1-form (if (eq op '=-2) form `(not ,form))))
677        (if (or  2-dfloats 2-sfloats)
678          (make-acode 
679           (if 2-dfloats
680             (%nx1-operator double-float-compare)
681             (%nx1-operator short-float-compare))
682           (make-acode
683            (%nx1-operator immediate)     
684            (if (eq op '=-2)
685              :EQ
686              :NE))
687           (nx1-form num1)
688           (nx1-form num2))
689          (make-acode (%nx1-operator numcmp)
690                      (make-acode
691                       (%nx1-operator immediate)     
692                       (if (eq op '=-2)
693                         :EQ
694                         :NE))
695                      (nx1-form num1)
696                      (nx1-form num2)))))))
697             
698
699(defnx1 nx1-uvset ((uvset) (%misc-set)) (vector index value &environment env)
700  (make-acode (%nx1-operator uvset)
701              (nx1-form vector)
702              (nx1-form index)
703              (nx1-form value)))
704
705(defnx1 nx1-set-schar ((set-schar)) (&whole w s i v &environment env)
706  (make-acode (%nx1-operator %set-sbchar) (nx1-form s) (nx1-form i) (nx1-form v)))
707
708
709
710(defnx1 nx1-%set-schar ((%set-schar)) (arg idx char &environment env)
711  (let* ((arg (nx-transform arg env))
712         (idx (nx-transform idx env))
713         (char (nx-transform char env))
714         (argvar (make-symbol "ARG"))
715         (idxvar (make-symbol "IDX"))
716         (charvar (make-symbol "CHAR")))
717    (nx1-form `(let* ((,argvar ,arg)
718                      (,idxvar ,idx)
719                      (,charvar ,char))
720                 (declare (optimize (speed 3) (safety 0)))
721                 (declare (simple-base-string ,argvar))
722                 (setf (schar ,argvar ,idxvar) ,charvar))
723              env)))
724
725(defnx1 nx1-%set-scharcode ((%set-scharcode)) (&whole w s i v)
726    (make-acode (%nx1-operator %set-scharcode)
727                (nx1-form s)
728                (nx1-form i)
729                (nx1-form v)))
730             
731
732(defnx1 nx1-list-vector-values ((list) (vector) (values) (%temp-list)) (&rest args)
733  (make-acode (%nx1-default-operator) (nx1-formlist args)))
734
735
736
737(defnx1 nx1-%gvector ( (%gvector)) (&rest args)
738  (make-acode (%nx1-operator %gvector) (nx1-arglist args)))
739
740(defnx1 nx1-quote quote (form)
741  (nx1-immediate form))
742
743(defnx1 nx1-list* ((list*)) (first &rest rest)
744  (make-acode (%nx1-operator list*) (nx1-arglist (cons first rest) 1)))
745
746
747#|
748(defnx1 nx1-append ((append)) (&rest args)
749  (make-acode (%nx1-operator append) (nx1-arglist args 2)))
750
751
752|#
753
754(defnx1 nx1-or or (&whole whole &optional (firstform nil firstform-p) &rest moreforms)
755  (if (not firstform-p)
756    (nx1-form nil)
757    (if (null moreforms)
758      (nx1-form firstform)
759      (progn
760        (make-acode (%nx1-operator or) (nx1-formlist (%cdr whole)))))))
761
762(defun nx1-1d-vref (env arr dim0 &optional uvref-p)
763  (let* ((simple-vector-p (nx-form-typep arr 'simple-vector env))
764         (string-p (unless simple-vector-p 
765                     (if (nx-form-typep arr 'string env)
766                       (or (nx-form-typep arr 'simple-string env)
767                           (return-from nx1-1d-vref (nx1-form `(char ,arr ,dim0)))))))
768         (simple-1d-array-p (unless (or simple-vector-p string-p) 
769                              (nx-form-typep arr '(simple-array * (*)) env)))
770         
771         (array-type (specifier-type  (nx-form-type arr env)))
772         (type-keyword (funcall
773                        (arch::target-array-type-name-from-ctype-function
774                         (backend-target-arch *target-backend*))
775                        array-type)))
776    (if (and simple-1d-array-p type-keyword)
777      (make-acode (%nx1-operator %typed-uvref) 
778                  (nx1-immediate type-keyword)
779                  (nx1-form arr)
780                  (nx1-form dim0))
781      (let* ((op (cond (simple-1d-array-p (%nx1-operator uvref))
782                       (string-p (%nx1-operator %sbchar))
783                       (simple-vector-p 
784                        (if (nx-inhibit-safety-checking env) (%nx1-operator %svref) (%nx1-operator svref)))
785                       (uvref-p (%nx1-operator uvref))
786                       (t (%nx1-operator %aref1)))))
787        (make-acode op (nx1-form arr) (nx1-form dim0))))))
788 
789(defnx1 nx1-aref ((aref)) (&whole whole &environment env arr &optional (dim0 nil dim0-p)
790                                  &rest other-dims)
791   (if (and dim0-p (null other-dims))
792     (nx1-1d-vref env arr dim0)
793     (nx1-treat-as-call whole)))
794
795(defnx1 nx1-uvref ((uvref)) (&environment env arr dim0)
796  (nx1-1d-vref env arr dim0 t))
797
798(defnx1 nx1-%aref2 ((%aref2)) (&whole whole &environment env arr i j)
799  (let* ((arch (backend-target-arch *target-backend*))
800         (ctype (specifier-type (nx-form-type arr env)))
801         (atype (if (csubtypep ctype (specifier-type '(array * (* *)))) ctype))
802         (simple-atype (if (and atype
803                                (csubtypep atype (specifier-type '(simple-array * (* *)))))
804                         atype))
805         (type-keyword (if atype
806                         (funcall
807                          (arch::target-array-type-name-from-ctype-function arch)
808                          atype))))
809    (if (and type-keyword simple-atype)
810      (let* ((dims (array-ctype-dimensions atype))
811             (dim0 (car dims))
812             (dim1 (cadr dims)))
813        (make-acode (%nx1-operator simple-typed-aref2)
814                    (nx1-form type-keyword)
815                    (nx1-form arr)
816                    (nx1-form i)
817                    (nx1-form j)
818                    (nx1-form (if (typep dim0 'fixnum) dim0))
819                    (nx1-form (if (typep dim1 'fixnum) dim1))))
820      (make-acode (%nx1-operator general-aref2)
821                  (nx1-form arr)
822                  (nx1-form i)
823                  (nx1-form j)))))
824
825(defnx1 nx1-%aref3 ((%aref3)) (&whole whole &environment env arr i j k)
826  (let* ((arch (backend-target-arch *target-backend*))
827         (ctype (specifier-type (nx-form-type arr env)))
828         (atype (if (csubtypep ctype (specifier-type '(array * (* * *)))) ctype))
829         (simple-atype (if (and atype
830                                (csubtypep atype (specifier-type '(simple-array * (* * *)))))
831                         atype))
832         (type-keyword (if atype
833                         (funcall
834                          (arch::target-array-type-name-from-ctype-function arch)
835                          atype))))
836    (if (and type-keyword simple-atype)
837      (let* ((dims (array-ctype-dimensions atype))
838             (dim0 (car dims))
839             (dim1 (cadr dims))
840             (dim2 (caddr dims)))
841        (make-acode (%nx1-operator simple-typed-aref3)
842                    (nx1-form type-keyword)
843                    (nx1-form arr)
844                    (nx1-form i)
845                    (nx1-form j)
846                    (nx1-form k)
847                    (nx1-form (if (typep dim0 'fixnum) dim0))
848                    (nx1-form (if (typep dim1 'fixnum) dim1))
849                    (nx1-form (if (typep dim2 'fixnum) dim2))))
850      (make-acode (%nx1-operator general-aref3)
851                  (nx1-form arr)
852                  (nx1-form i)
853                  (nx1-form j)
854                  (nx1-form k)))))
855
856(defun nx1-1d-vset (arr newval dim0 env)
857  (let* ((simple-vector-p (nx-form-typep arr 'simple-vector env))
858         (string-p (unless simple-vector-p 
859                     (if (nx-form-typep arr 'string env)
860                       (or (nx-form-typep arr 'simple-string env)
861                           (return-from nx1-1d-vset (nx1-form `(set-char ,arr ,newval ,dim0)))))))
862         (simple-1d-array-p (unless (or simple-vector-p string-p) 
863                              (nx-form-typep arr '(simple-array * (*)) env)))
864         (array-type (specifier-type  (nx-form-type arr env)))
865         (type-keyword (funcall
866                        (arch::target-array-type-name-from-ctype-function
867                         (backend-target-arch *target-backend*))
868                        array-type)))
869         (if (and type-keyword simple-1d-array-p)
870             (make-acode (%nx1-operator %typed-uvset) 
871                         (nx1-immediate type-keyword)
872                         (nx1-form arr)
873                         (nx1-form newval)
874                         (nx1-form dim0))
875             (let* ((op (cond (simple-1d-array-p (%nx1-operator uvset))
876                              (string-p (%nx1-operator %set-sbchar))
877                              (simple-vector-p (if (nx-inhibit-safety-checking env) (%nx1-operator %svset) (%nx1-operator svset)))
878                              (t (%nx1-operator aset1)))))
879               (if op
880                   (make-acode
881                    op
882                    (nx1-form arr)
883                    (nx1-form newval)
884                    (nx1-form dim0))
885                   (nx1-form `(,(if string-p 'set-schar '%aset1) ,arr ,newval ,dim0)))))))
886
887(defnx1 nx1-aset ((aset)) (&whole whole 
888                                  arr newval 
889                                  &optional (dim0 nil dim0-p)
890                                  &environment env
891                                  &rest other-dims)
892   (if (and dim0-p (null other-dims))
893       (nx1-1d-vset arr newval dim0 env)
894       (nx1-treat-as-call whole)))
895           
896(defnx1 nx1-%aset2 ((%aset2)) (&whole whole &environment env arr i j new)
897  (let* ((arch (backend-target-arch *target-backend*))
898         (ctype (specifier-type (nx-form-type arr env)))
899         (atype (if (csubtypep ctype (specifier-type '(array * (* *)))) ctype))
900         (simple-atype (if (and atype
901                                (csubtypep atype (specifier-type '(simple-array * (* *)))))
902                         atype))
903         (type-keyword (if atype
904                         (funcall
905                          (arch::target-array-type-name-from-ctype-function arch)
906                          atype))))
907
908    (if (and type-keyword simple-atype)
909      (let* ((dims (array-ctype-dimensions atype))
910             (dim0 (car dims))
911             (dim1 (cadr dims)))
912        (make-acode (%nx1-operator simple-typed-aset2)
913                    (nx1-form type-keyword)
914                    (nx1-form arr)
915                    (nx1-form i)
916                    (nx1-form j)
917                    (nx1-form new)
918                    (nx1-form (if (typep dim0 'fixnum) dim0))
919                    (nx1-form (if (typep dim1 'fixnum) dim1))))
920            (make-acode (%nx1-operator general-aset2)
921                  (nx1-form arr)
922                  (nx1-form i)
923                  (nx1-form j)
924                  (nx1-form new)))))
925
926(defnx1 nx1-%aset3 ((%aset3)) (&whole whole &environment env arr i j k new)
927  (let* ((arch (backend-target-arch *target-backend*))
928         (ctype (specifier-type (nx-form-type arr env)))
929         (atype (if (csubtypep ctype (specifier-type '(array * (* * *)))) ctype))
930         (simple-atype (if (and atype
931                                (csubtypep atype (specifier-type '(simple-array * (* * *)))))
932                         atype))
933         (type-keyword (if atype
934                         (funcall
935                          (arch::target-array-type-name-from-ctype-function arch)
936                          atype))))
937
938    (if (and type-keyword simple-atype)
939      (let* ((dims (array-ctype-dimensions atype))
940             (dim0 (car dims))
941             (dim1 (cadr dims))
942             (dim2 (caddr dims)))
943        (make-acode (%nx1-operator simple-typed-aset3)
944                    (nx1-form type-keyword)
945                    (nx1-form arr)
946                    (nx1-form i)
947                    (nx1-form j)
948                    (nx1-form k)
949                    (nx1-form new)
950                    (nx1-form (if (typep dim0 'fixnum) dim0))
951                    (nx1-form (if (typep dim1 'fixnum) dim1))
952                    (nx1-form (if (typep dim2 'fixnum) dim2))))
953            (make-acode (%nx1-operator general-aset3)
954                  (nx1-form arr)
955                  (nx1-form i)
956                  (nx1-form j)
957                  (nx1-form k)
958                  (nx1-form new)))))
959
960(defnx1 nx1-prog1 (prog1 multiple-value-prog1) (save &body args 
961                                                     &aux (l (list (nx1-form save))))
962  (make-acode 
963   (%nx1-default-operator) 
964   (dolist (arg args (nreverse l))
965     (push (nx1-form arg) l))))
966
967(defnx1 nx1-if if (test true &optional false)
968  (if (null true)
969    (if (null false)
970      (return-from nx1-if (nx1-form `(progn ,test nil)))
971      (psetq test `(not ,test) true false false true)))
972  (make-acode (%nx1-operator if)  (nx1-form test) (nx1-form true) (nx1-form false)))
973
974(defnx1 nx1-%debug-trap dbg (&optional arg)
975  (make-acode (%nx1-operator %debug-trap) (nx1-form arg)))
976       
977(defnx1 nx1-setq setq (&whole whole &rest args &environment env &aux res)
978  (when (%ilogbitp 0 (length args))
979    (nx-error "Odd number of forms in ~s ." whole))
980  (while args
981    (let ((sym (nx-need-var (%car args) nil))
982          (val (%cadr args)))
983      (multiple-value-bind (expansion win) (macroexpand-1 sym env)
984        (if win
985            (push (nx1-form `(setf ,expansion ,val)) res)
986            (multiple-value-bind (info inherited catchp)
987                (nx-lex-info sym)
988              (push
989               (if (eq info :symbol-macro)
990                   (progn
991                     (nx-set-var-bits catchp
992                                      (%ilogior
993                                       (%ilsl $vbitsetq 1)
994                                       (%ilsl $vbitreffed 1)
995                                       (nx-var-bits catchp)))
996                     (nx1-form `(setf ,inherited ,val)))
997                   (let* ((valtype (nx-form-type val env))
998                          (declared-type (nx-declared-type sym)))
999                     (let ((*nx-form-type* declared-type))
1000                       (setq val (nx1-typed-form val env)))
1001                     (if (and info (neq info :special))
1002                         (progn
1003                           (nx1-check-assignment sym env)
1004                           (let ((inittype (var-inittype info)))
1005                             (if (and inittype (not (subtypep valtype inittype)))
1006                                 (setf (var-inittype info) nil)))
1007                           (if inherited
1008                               (nx-set-var-bits info (%ilogior (%ilsl $vbitsetq 1)
1009                                                               (%ilsl $vbitnoreg 1) ; I know, I know ... Someday ...
1010                                                               (nx-var-bits info)))
1011                               (nx-set-var-bits info (%ilogior2 (%ilsl $vbitsetq 1) (nx-var-bits info))))
1012                           (nx-adjust-setq-count info 1 catchp) ; In the hope that that day will come ...
1013                           (make-acode (%nx1-operator setq-lexical) info val))
1014                         (make-acode
1015                          (if (nx1-check-special-ref sym info)
1016                              (progn
1017                                (nx-record-xref-info :references sym)
1018                                (nx-record-xref-info :sets sym)
1019                                (if (nx-global-p sym env)
1020                                  (%nx1-operator global-setq)
1021                                  (%nx1-operator setq-special)))
1022                            (%nx1-operator setq-free)) ; Screw: no object lisp.  Still need setq-free ? For constants ?
1023                          (nx1-note-vcell-ref sym)
1024                          val))))
1025               res)))
1026        (setq args (%cddr args)))))
1027  (make-acode (%nx1-operator progn) (nreverse res)))
1028
1029;;; See if we're trying to setq something that's currently declared "UNSETTABLE"; whine if so.
1030;;; If we find a contour in which a "SETTABLE NIL" vdecl for the variable exists, whine.
1031;;; If we find a contour in which a "SETTABLE T" vdecl for the variable exists. or
1032;;;    the contour in which the variable's bound, return nil.
1033;;; Should find something ...
1034(defun nx1-check-assignment (sym env)
1035  (loop
1036    (unless (and env (istruct-typep env 'lexical-environment))
1037      (return))
1038    (dolist (decl (lexenv.vdecls env))
1039      (when (and (eq (car decl) sym)
1040               (eq (cadr decl) 'settable))
1041        (unless (cddr decl)
1042          (nx1-whine :unsettable sym))
1043        (return-from nx1-check-assignment nil)))
1044    (let ((vars (lexenv.variables env)))
1045      (unless (atom vars)
1046        (dolist (var vars)
1047          (when (eq (var-name var) sym) (return-from nx1-check-assignment nil)))))
1048    (setq env (lexenv.parent-env env))))
1049
1050;;; The cleanup issue is a little vague (ok, it's a -lot- vague) about the environment in
1051;;; which the load-time form is defined, although it apparently gets "executed in a null
1052;;; lexical environment".  Ignoring the fact that it's meaningless to talk of executing
1053;;; something in a lexical environment, we can sort of infer that it must also be defined
1054;;; in a null lexical environment.
1055
1056(defnx1 nx1-load-time-value (load-time-value) (&environment env form &optional read-only-p)
1057  ; Validate the "read-only-p" argument
1058  (if (and read-only-p (neq read-only-p t)) (require-type read-only-p '(member t nil)))
1059  ; Then ignore it.
1060  (if *nx-load-time-eval-token*
1061    (multiple-value-bind (function warnings)
1062                         (compile-named-function 
1063                          `(lambda () ,form)
1064                          ;; pass in the definition env for special decls
1065                          :env (definition-environment env)
1066                          :load-time-eval-token *nx-load-time-eval-token*
1067                          :target (backend-name *target-backend*))
1068      (setq *nx-warnings* (append *nx-warnings* warnings))
1069      (nx1-immediate (list *nx-load-time-eval-token* `(funcall ,function))))
1070    (nx1-immediate (eval form))))
1071
1072(defnx1 nx1-catch (catch) (operation &body body)
1073  (make-acode (%nx1-operator catch) (nx1-form operation) (nx1-catch-body body)))
1074
1075(defnx1 nx1-%badarg ((%badarg)) (badthing right-type)
1076  (make-acode (%nx1-operator %badarg2) 
1077              (nx1-form badthing) 
1078              (nx1-form (or (if (quoted-form-p right-type) (%typespec-id (cadr right-type))) right-type))))
1079
1080(defnx1 nx1-unwind-protect (unwind-protect) (protected-form &body cleanup-form)
1081  (if cleanup-form
1082    (make-acode (%nx1-operator unwind-protect) 
1083                (nx1-catch-body (list protected-form))
1084                (nx1-progn-body cleanup-form))
1085    (nx1-form protected-form)))
1086
1087(defnx1 nx1-progv progv (symbols values &body body)
1088  (make-acode (%nx1-operator progv) 
1089              (nx1-form `(check-symbol-list ,symbols))
1090              (nx1-form values) 
1091              (nx1-catch-body body)))
1092
1093(defun nx1-catch-body (body)
1094  (let* ((temp (new-lexical-environment *nx-lexical-environment*)))
1095    (setf (lexenv.variables temp) 'catch)
1096    (let* ((*nx-lexical-environment* (new-lexical-environment temp)))
1097      (nx1-progn-body body))))
1098
1099
1100
1101
1102                         
1103
1104(defnx1 nx1-apply ((apply)) (&whole call fn arg &rest args &aux (orig args) (spread-p t))
1105  (if (null (%car (last (push arg args))))
1106    (setq spread-p nil args (butlast args)))
1107  (let ((name (nx1-func-name fn))
1108        (global nil))
1109    (if name
1110      (if (eq (%car fn) 'quote)
1111        (setq global t name (nx1-form fn))
1112        (let*  ((afunc (nth-value 1 (nx-lexical-finfo name))))
1113          (when (and afunc (eq afunc *nx-call-next-method-function*))
1114            (setq name (if (or arg orig) 
1115                         '%call-next-method-with-args
1116                         '%call-next-method)
1117                         global t
1118                         args (cons (var-name *nx-next-method-var*) args)))))
1119      (setq name (nx1-form fn)))
1120    (nx1-call name args spread-p global)))
1121
1122(defnx1 nx1-%apply-lexpr ((%apply-lexpr)) (&whole call fn arg &rest args &aux (orig args))
1123  (push arg args)
1124  (let ((name (nx1-func-name fn))
1125        (global nil))
1126    (if name
1127      (if (eq (%car fn) 'quote)
1128        (setq global t name (nx1-form fn))
1129        (let*  ((afunc (nth-value 1 (nx-lexical-finfo name))))
1130          (when (and afunc (eq afunc *nx-call-next-method-function*))
1131            (setq name (if (or arg orig) 
1132                         '%call-next-method-with-args
1133                         '%call-next-method)
1134                  global t
1135                  args (cons (var-name *nx-next-method-var*) args)))))
1136      (setq name (nx1-form fn)))
1137    (nx1-call name args 0 global)))
1138
1139
1140
1141(defnx1 nx1-%defun %defun (&whole w def &optional (doc nil doc-p) &environment env)
1142  (declare (ignorable doc doc-p))
1143  ; Pretty bogus.
1144  (if (and (consp def)
1145           (eq (%car def) 'nfunction)
1146           (consp (%cdr def))
1147           (symbolp (%cadr def)))
1148    (note-function-info (%cadr def) nil env))
1149  (nx1-treat-as-call w))
1150
1151
1152(defnx1 nx1-function function (arg &aux fn afunc)
1153  (if (symbolp arg)
1154    (progn
1155      (when (macro-function arg *nx-lexical-environment*)
1156        (nx-error
1157         "~S can't be used to reference lexically visible macro ~S." 
1158         'function arg))
1159      (if (multiple-value-setq (fn afunc) (nx-lexical-finfo arg))
1160        (progn
1161          (when afunc 
1162            (incf (afunc-fn-refcount afunc))
1163            (when (%ilogbitp $fbitbounddownward (afunc-bits afunc))
1164              (incf (afunc-fn-downward-refcount afunc))))
1165          (nx1-symbol (%cddr fn)))
1166        (progn
1167          (while (setq fn (assq arg *nx-synonyms*))
1168            (setq arg (%cdr fn)))
1169          (nx1-form `(%function ',arg)))))
1170    (if (and (consp arg) (eq (%car arg) 'setf))
1171      (nx1-form `(function ,(nx-need-function-name arg)))
1172      (nx1-ref-inner-function nil arg))))
1173
1174(defnx1 nx1-nfunction nfunction (name def)
1175 (nx1-ref-inner-function name def))
1176
1177(defun nx1-ref-inner-function (name def &optional afunc)
1178  (setq afunc (nx1-compile-inner-function name def nil afunc))
1179  (setf (afunc-fn-refcount afunc) 1)
1180  (nx1-afunc-ref afunc))
1181
1182(defun nx1-compile-inner-function (name def original p
1183                                        &optional (env *nx-lexical-environment*)
1184                                        &aux (q *nx-current-function*))
1185  (unless p (setq p (make-afunc)))
1186  (setf (afunc-parent p) q)
1187  (setf (afunc-parent q) *nx-parent-function*)
1188  (setf (afunc-tags q) *nx-tags*)
1189  (setf (afunc-blocks q) *nx-blocks*)
1190  (setf (afunc-inner-functions q) (push p *nx-inner-functions*))
1191  (setf (lexenv.lambda env) q)
1192  (if *nx-current-code-note*
1193    (let* ((*nx-current-code-note* (nx-ensure-code-note def original *nx-current-code-note*)))
1194      (nx1-compile-lambda name def p q env *nx-current-compiler-policy* *nx-load-time-eval-token*)) ;returns p.
1195    (nx1-compile-lambda name def p q env *nx-current-compiler-policy* *nx-load-time-eval-token*)))
1196
1197(defun nx1-afunc-ref (afunc)
1198  (let ((op (if (afunc-inherited-vars afunc)
1199              (%nx1-operator closed-function)
1200              (%nx1-operator simple-function)))
1201        (ref (afunc-ref-form afunc)))
1202    (if ref
1203      (%rplaca ref op) ; returns ref
1204      (setf (afunc-ref-form afunc)
1205            (make-acode
1206             op
1207             afunc)))))
1208   
1209(defnx1 nx1-%function %function (form &aux symbol)
1210  (let ((sym (nx1-form form)))
1211    (if (and (eq (car sym) (%nx1-operator immediate))
1212             (setq symbol (cadr sym))
1213             (symbolp symbol))
1214      (progn
1215        (nx1-call-result-type symbol)   ; misnamed.  Checks for (un-)definedness.
1216        (make-acode (%nx1-default-operator) symbol))
1217      (make-acode (%nx1-operator call) (nx1-immediate '%function) (list nil (list sym))))))
1218
1219(defnx1 nx1-tagbody tagbody (&rest args)
1220  (let* ((newtags nil)
1221         (*nx-lexical-environment* (new-lexical-environment *nx-lexical-environment*))
1222         (pending (make-pending-declarations))
1223         (*nx-bound-vars* *nx-bound-vars*)
1224         (catchvar (nx-new-temp-var pending "tagbody-catch-tag"))
1225         (indexvar (nx-new-temp-var pending "tagbody-tag-index"))
1226         (counter (list 0))
1227         (looplabel (cons nil nil))
1228         (*nx-tags* *nx-tags*))
1229    (dolist (form args)
1230      (when (atom form)
1231        (if (or (symbolp form) (integerp form))
1232          (if (assoc form newtags)
1233            (nx-error "Duplicate tag in TAGBODY: ~S." form)
1234            (push (list form nil counter catchvar nil nil) newtags))
1235          (nx-error "Illegal form in TAGBODY: ~S." form))))
1236    (dolist (tag (setq newtags (nreverse newtags)))
1237      (push tag *nx-tags*))
1238    (let* ((body nil)
1239           (*nx-loop-nesting-level* (1+ *nx-loop-nesting-level*)))
1240      (dolist (form args (setq body (nreverse body)))
1241        (push 
1242         (if (atom form)
1243           (let ((info (nx-tag-info form)))
1244             (%rplaca (%cdr (%cdr (%cdr (%cdr info)))) t)
1245             (cons (%nx1-operator tag-label) info))
1246           (nx1-form form))
1247         body))
1248      (if (eq 0 (%car counter))
1249        (make-acode (%nx1-operator local-tagbody) newtags body)
1250        (progn
1251          (nx-set-var-bits catchvar (logior (nx-var-bits catchvar)
1252                                            (%ilsl $vbitdynamicextent 1)))
1253          (nx-inhibit-register-allocation)   ; There are alternatives ...
1254          (dolist (tag (reverse newtags))
1255            (when (%cadr tag)
1256              (push 
1257               (nx1-form `(if (eql ,(var-name indexvar) ,(%cadr tag)) (go ,(%car tag))))
1258               body)))
1259          (make-acode
1260           (%nx1-operator let*)
1261           (list catchvar indexvar)
1262           (list (make-acode (%nx1-operator cons) *nx-nil* *nx-nil*) *nx-nil*)
1263           (make-acode
1264            (%nx1-operator local-tagbody)
1265            (list looplabel)
1266            (list
1267             (cons (%nx1-operator tag-label) looplabel)
1268             (make-acode
1269              (%nx1-operator if)
1270              (make-acode 
1271               (%nx1-operator setq-lexical)
1272               indexvar
1273               (make-acode 
1274                (%nx1-operator catch)
1275                (nx1-form (var-name catchvar)) 
1276                (make-acode
1277                 (%nx1-operator local-tagbody)
1278                 newtags
1279                 body)))
1280              (make-acode (%nx1-operator local-go) looplabel)
1281              *nx-nil*)))
1282           0))))))
1283
1284
1285
1286(defnx1 nx1-go go (tag)
1287  (multiple-value-bind (info closed)
1288                       (nx-tag-info tag)
1289    (unless info (nx-error "Can't GO to tag ~S." tag))
1290    (if (not closed)
1291      (let ((defnbackref (cdr (cdr (cdr (cdr info))))))
1292        (if (car defnbackref) 
1293          (rplaca (cdr defnbackref) t))
1294        (make-acode (%nx1-operator local-go) info))
1295      (progn
1296
1297        (make-acode
1298         (%nx1-operator throw) (nx1-symbol (var-name (cadddr info))) (nx1-form closed))))))
1299
1300
1301
1302
1303;;; address-expression should return a fixnum; that's our little
1304;;; secret.  result spec can be NIL, :void, or anything that an
1305;;; arg-spec can be.  arg-spec can be :double, :single, :address,
1306;;; :signed-doubleword, :unsigned-doubleword, :signed-fullword,
1307;;; :unsigned-fullword, :signed-halfword, :unsigned-halfword,
1308;;; :signed-byte, or :unsigned-byte
1309;;; On ppc64, :hybrid-int-float, :hybrid-float-float, and :hybrid-float-int
1310;;; can also be used to express some struct-by-value cases.
1311
1312(defparameter *arg-spec-keywords*
1313  '(:double-float :single-float :address :signed-doubleword
1314    :unsigned-doubleword :signed-fullword :unsigned-fullword
1315    :signed-halfword :unsigned-halfword :signed-byte :unsigned-byte
1316    :hybrid-int-float :hybrid-float-int :hybrid-float-float))
1317
1318
1319(defnx1 nx1-ff-call ((%ff-call)) (address-expression &rest arg-specs-and-result-spec)
1320   (nx1-ff-call-internal
1321    address-expression arg-specs-and-result-spec
1322    (ecase (backend-name *target-backend*)
1323      (:linuxppc32 (%nx1-operator eabi-ff-call))
1324      ((:darwinppc32 :linuxppc64 :darwinppc64) (%nx1-operator poweropen-ff-call))
1325      ((:linuxx8664 :freebsdx8664 :darwinx8664) (%nx1-operator ff-call)))))
1326
1327(defnx1 nx1-syscall ((%syscall)) (idx &rest arg-specs-and-result-spec)
1328  (flet ((map-to-representation-types (list)
1329           (collect ((out))
1330             (do* ((l list (cddr l)))
1331                  ((null (cdr l))
1332                   (if l
1333                     (progn
1334                       (out (foreign-type-to-representation-type (car l)))
1335                       (out))
1336                     (error "Missing result type in ~s" list)))
1337               (out (foreign-type-to-representation-type (car l)))
1338               (out (cadr l))))))
1339          (nx1-ff-call-internal 
1340           idx (map-to-representation-types arg-specs-and-result-spec)
1341           (ecase (backend-name *target-backend*)
1342             (:linuxppc32 (%nx1-operator eabi-syscall))
1343             ((:darwinppc32 :darwinppc64 :linuxppc64)
1344              (%nx1-operator poweropen-syscall))
1345             ((:linuxx8664 :freebsdx8664 :darwinx8664) (%nx1-operator syscall))))))
1346
1347(defun nx1-ff-call-internal (address-expression arg-specs-and-result-spec operator )
1348  (let* ((specs ())         
1349         (vals ())
1350         (register-spec-seen nil)
1351         (monitor (eq (car arg-specs-and-result-spec) :monitor-exception-ports))
1352         (arg-specs (butlast arg-specs-and-result-spec))
1353         (result-spec (car (last arg-specs-and-result-spec))))
1354    (if monitor
1355      (setq arg-specs (cdr arg-specs)))
1356    (unless (evenp (length arg-specs))
1357      (error "odd number of arg-specs"))
1358    (loop
1359      (when (null arg-specs) (return))
1360      (let* ((arg-keyword (pop arg-specs))
1361             (value (pop arg-specs)))
1362        (if (or (memq arg-keyword *arg-spec-keywords*)
1363                (typep arg-keyword 'unsigned-byte))
1364          (progn 
1365            (push arg-keyword specs)
1366            (push value vals))
1367          (if (eq arg-keyword :registers)
1368            (if register-spec-seen
1369              (error "duplicate :registers in ~s" arg-specs-and-result-spec)
1370              (progn
1371                (setq register-spec-seen t)
1372                (push arg-keyword specs)
1373                (push value vals)))
1374            (error "Unknown argument spec: ~s" arg-keyword)))))
1375    (unless (or (eq result-spec :void)
1376                (memq result-spec *arg-spec-keywords*))
1377      (error "Unknown result spec: ~s" result-spec))
1378    (make-acode operator
1379                (nx1-form address-expression)
1380                (nreverse specs)
1381                (mapcar #'nx1-form (nreverse vals))
1382                result-spec
1383                monitor)))
1384 
1385(defnx1 nx1-block block (blockname &body forms)
1386  (let* ((*nx-blocks* *nx-blocks*)
1387         (*nx-lexical-environment* (new-lexical-environment *nx-lexical-environment*))
1388         (*nx-bound-vars* *nx-bound-vars*)
1389         (tagvar (nx-new-temp-var (make-pending-declarations)))
1390         (thisblock (cons (setq blockname (nx-need-sym blockname)) tagvar))
1391         (body nil))
1392    (push thisblock *nx-blocks*)
1393    (setq body (nx1-progn-body forms))
1394    (%rplacd thisblock nil)
1395    (let ((tagbits (nx-var-bits tagvar)))
1396      (if (not (%ilogbitp $vbitclosed tagbits))
1397        (if (neq 0 (%ilogand $vrefmask tagbits))
1398          (make-acode 
1399           (%nx1-operator local-block)
1400           thisblock
1401           body)
1402          body)
1403        (progn
1404          (nx-set-var-bits tagvar (%ilogior (%ilsl $vbitdynamicextent 1) tagbits))
1405          (nx-inhibit-register-allocation)   ; Could also set $vbitnoreg in all setqed vars, or keep track better
1406          (make-acode
1407           (%nx1-operator local-block)
1408           thisblock
1409           (make-acode
1410            (%nx1-operator let)
1411            (list tagvar)
1412            (list (make-acode (%nx1-operator cons) (nx1-form nil) (nx1-form nil)))
1413            (make-acode
1414             (%nx1-operator catch)
1415             (make-acode (%nx1-operator lexical-reference) tagvar)
1416             body)
1417            0)))))))
1418
1419(defnx1 nx1-return-from return-from (blockname &optional value)
1420  (multiple-value-bind (info closed)
1421                       (nx-block-info (setq blockname (nx-need-sym blockname)))
1422    (unless info (nx-error "Can't RETURN-FROM block : ~S." blockname))
1423    (unless closed (nx-adjust-ref-count (cdr info)))
1424    (make-acode 
1425     (if closed
1426       (%nx1-operator throw)
1427       (%nx1-operator local-return-from))
1428     (if closed
1429       (nx1-symbol (var-name (cdr info)))
1430       info)
1431     (nx1-form value))))
1432
1433(defnx1 nx1-funcall ((funcall)) (func &rest args)
1434  (let ((name func))
1435    (if (and (consp name)
1436             (eq (%car name) 'function)
1437             (consp (%cdr name))
1438             (null (%cddr name))
1439             (or
1440              (if (symbolp (setq name (%cadr name)))
1441                (or (not (macro-function name *nx-lexical-environment*))
1442                    (nx-error "Can't funcall macro function ~s ." name)))
1443              (and (consp name) 
1444                   (or (eq (%car name) 'lambda)
1445                       (setq name (nx-need-function-name name))))))
1446      (nx1-form (cons name args))  ; This picks up call-next-method evil.
1447      (nx1-call (nx1-form func) args nil t))))
1448
1449(defnx1 nx1-multiple-value-call multiple-value-call (value-form &rest args)
1450  (make-acode (%nx1-default-operator)
1451              (nx1-form value-form)
1452              (nx1-formlist args)))
1453
1454#|
1455(defun nx1-call-name (fn &aux (name (nx1-func-name fn)))
1456  (if (and name (or (eq (%car fn) 'quote) (null (nx-lexical-finfo name))))
1457    (make-acode (%nx1-operator immediate) name)
1458    (or name (nx1-form fn))))
1459|#
1460
1461(defnx1 nx1-compiler-let compiler-let (bindings &body forms)
1462  (let* ((vars nil)
1463         (varinits nil))
1464    (dolist (pair bindings)
1465      (push (nx-pair-name pair) vars)
1466      (push (eval (nx-pair-initform pair)) varinits))
1467   (progv (nreverse vars) (nreverse varinits) (nx1-catch-body forms))))
1468
1469(defnx1 nx1-fbind fbind (fnspecs &body body &environment old-env)
1470  (let* ((fnames nil)
1471         (vars nil)
1472         (vals nil))
1473    (dolist (spec fnspecs (setq vals (nreverse vals)))
1474      (destructuring-bind (fname initform) spec
1475        (push (setq fname (nx-need-function-name fname)) fnames)
1476        (push (nx1-form initform) vals)))
1477    (let* ((new-env (new-lexical-environment old-env))
1478           (*nx-bound-vars* *nx-bound-vars*)
1479           (*nx-lexical-environment* new-env)
1480           (pending (make-pending-declarations)))
1481      (dolist (fname fnames)       
1482        (let ((var (nx-new-var pending (make-symbol (symbol-name fname)))))
1483          (nx-set-var-bits var (%ilogior (%ilsl $vbitignoreunused 1)
1484                                         (nx-var-bits var)))
1485          (let ((afunc (make-afunc)))
1486            (setf (afunc-bits afunc) (%ilsl $fbitruntimedef 1))
1487            (setf (afunc-lfun afunc) var)
1488            (push var vars)
1489            (push (cons fname (cons 'function (cons afunc (var-name var)))) (lexenv.functions new-env)))))
1490      (make-acode
1491       (%nx1-operator let)
1492       vars
1493       vals
1494       (nx1-env-body body old-env)
1495       *nx-new-p2decls*))))
1496
1497(defun maybe-warn-about-nx1-alphatizer-binding (funcname)
1498  (when (and (symbolp funcname)
1499             (gethash funcname *nx1-alphatizers*))
1500    (nx1-whine :special-fbinding funcname)))
1501
1502(defnx1 nx1-flet flet (defs &body forms)
1503  (with-nx-declarations (pending)
1504    (let* ((env *nx-lexical-environment*)
1505           (*nx-lexical-environment* env)
1506           (*nx-bound-vars* *nx-bound-vars*)
1507           (new-env (new-lexical-environment env))
1508           (names nil)
1509           (funcs nil)
1510           (pairs nil)
1511           (fname nil)
1512           (name nil))
1513      (multiple-value-bind (body decls) (parse-body forms env nil)
1514        (nx-process-declarations pending decls)
1515        (dolist (def defs (setq names (nreverse names) funcs (nreverse funcs)))
1516          (destructuring-bind (funcname lambda-list &body flet-function-body) def
1517            (setq fname (nx-need-function-name funcname))
1518            (maybe-warn-about-nx1-alphatizer-binding funcname)
1519            (multiple-value-bind (body decls)
1520                                 (parse-body flet-function-body env)
1521              (let ((func (make-afunc)))
1522                (setf (afunc-environment func) env
1523                      (afunc-lambdaform func) `(lambda ,lambda-list
1524                                                     ,@decls
1525                                                     (block ,(if (consp funcname) (%cadr funcname) funcname)
1526                                                       ,@body)))
1527                (push func funcs)
1528                (when (and *nx-next-method-var*
1529                             (eq funcname 'call-next-method)
1530                             (null *nx-call-next-method-function*))
1531                    (setq *nx-call-next-method-function* func))             
1532                (push (cons def func) pairs)
1533                (if (consp funcname)
1534                  (setq funcname fname))
1535                (push (setq name (make-symbol (symbol-name funcname))) names)
1536                (push (cons funcname (cons 'function (cons func name))) (lexenv.functions new-env))))))
1537        (let ((vars nil)
1538              (rvars nil)
1539              (rfuncs nil))
1540          (dolist (sym names vars) (push (nx-new-var pending sym) vars))
1541          (nx-effect-other-decls pending new-env)
1542          (setq body (let* ((*nx-lexical-environment* new-env))
1543                       (nx1-dynamic-extent-functions vars new-env)
1544                       (nx1-env-body body env)))
1545          (dolist (pair pairs)
1546            (let ((afunc (cdr pair))
1547                  (var (pop vars)))
1548              (when (or (afunc-callers afunc)
1549                        (neq 0 (afunc-fn-refcount afunc))
1550                        (neq 0 (afunc-fn-downward-refcount afunc)))
1551                (push (nx1-compile-inner-function (%caar pair)
1552                                                  (afunc-lambdaform afunc) (%car pair)
1553                                                  afunc
1554                                                  (afunc-environment afunc))
1555                      rfuncs)
1556                (push var rvars))))
1557          (nx-reconcile-inherited-vars rfuncs)
1558          (dolist (f rfuncs) (nx1-afunc-ref f))
1559          (make-acode
1560           (%nx1-operator flet)
1561           rvars
1562           rfuncs
1563           body
1564           *nx-new-p2decls*))))))
1565
1566(defun nx1-dynamic-extent-functions (vars env)
1567  (let ((bits nil)
1568        (varinfo nil))
1569    (dolist (decl (lexenv.fdecls env))
1570      (let ((downward-guy (if (eq (cadr decl) 'dynamic-extent) (car decl))))
1571        (when downward-guy
1572          (multiple-value-bind (finfo afunc) (nx-lexical-finfo downward-guy)
1573            (when (and afunc 
1574                       (not (%ilogbitp $fbitdownward (setq bits (afunc-bits afunc))))
1575                       (setq varinfo (and (consp (%cdr finfo)) (nx-lex-info (%cddr finfo))))
1576                       (memq varinfo vars))
1577              (setf (afunc-bits afunc) 
1578                    (%ilogior 
1579                     bits 
1580                     (%ilsl $fbitdownward 1)
1581                     (%ilsl $fbitbounddownward 1)))
1582              (nx-set-var-bits varinfo (%ilogior (%ilsl $vbitdynamicextent 1) (nx-var-bits varinfo))))))))))
1583         
1584(defnx1 nx1-labels labels (defs &body forms)
1585  (with-nx-declarations (pending)
1586    (let* ((env *nx-lexical-environment*)
1587           (old-env (lexenv.parent-env env))
1588           (*nx-bound-vars* *nx-bound-vars*)
1589           (func nil)
1590           (funcs nil)
1591           (funcrefs nil)
1592           (bodies nil)
1593           (vars nil)
1594           (blockname nil)
1595           (fname nil)
1596           (name nil))
1597      (multiple-value-bind (body decls) (parse-body forms env nil)
1598        (dolist (def defs (setq funcs (nreverse funcs) bodies (nreverse bodies)))
1599          (destructuring-bind (funcname lambda-list &body labels-function-body) def
1600            (maybe-warn-about-nx1-alphatizer-binding funcname)
1601            (push (setq func (make-afunc)) funcs)
1602            (setq blockname funcname)
1603            (setq fname (nx-need-function-name funcname))
1604            (when (consp funcname)
1605              (setq blockname (%cadr funcname) funcname fname))
1606            (let ((var (nx-new-var pending (setq name (make-symbol (symbol-name funcname))))))
1607              (nx-set-var-bits var (%ilsl $vbitignoreunused 1))
1608              (push var vars))
1609            (push func funcrefs)
1610            (multiple-value-bind (body decls)
1611                                 (parse-body labels-function-body old-env)
1612              (push (cons funcname (cons 'function (cons func name))) (lexenv.functions env))
1613              (let* ((expansion `(lambda ,lambda-list 
1614                                   ,@decls 
1615                                   (block ,blockname
1616                                     ,@body))))
1617                (setf (afunc-lambdaform func) expansion
1618                      (afunc-environment func) env)
1619                (push (list* funcname expansion def)
1620                      bodies)))))
1621        (nx1-dynamic-extent-functions vars env)
1622        (dolist (def bodies)
1623          (nx1-compile-inner-function (car def) (cadr def) (%cddr def) (setq func (pop funcs))))
1624        (nx-process-declarations pending decls)
1625        (nx-effect-other-decls pending env)
1626        (setq body (nx1-env-body body old-env))
1627        (nx-reconcile-inherited-vars funcrefs)
1628        (dolist (f funcrefs) (nx1-afunc-ref f))
1629        (make-acode
1630         (%nx1-operator labels)
1631         (nreverse vars)
1632         (nreverse funcrefs)
1633         body
1634         *nx-new-p2decls*)))))
1635
1636
1637
1638(defnx1 nx1-set-bit ((%set-bit)) (ptr offset &optional (newval nil newval-p))
1639  (unless newval-p (setq newval offset offset 0))
1640  (make-acode
1641   (%nx1-operator %set-bit)
1642   (make-acode (%nx1-operator %macptrptr%) (nx1-form ptr))
1643   (nx1-form offset)
1644   (nx1-form newval)))
1645               
1646(defnx1 nx1-set-xxx ((%set-ptr) (%set-long)  (%set-word) (%set-byte)
1647                     (%set-unsigned-long) (%set-unsigned-word) (%set-unsigned-byte))
1648        (ptr offset &optional (newval nil new-val-p) &aux (op *nx-sfname*))
1649  (unless new-val-p (setq newval offset offset 0))
1650  (make-acode
1651   (%nx1-operator %immediate-set-xxx)
1652   (case op
1653     (%set-ptr 0)
1654     (%set-word 2)
1655     (%set-unsigned-word (logior 32 2))
1656     (%set-byte 1)
1657     (%set-unsigned-byte (logior 32 1))
1658     (%set-unsigned-long (logior 32 4))
1659     (t 4))
1660   (make-acode (%nx1-operator %macptrptr%) (nx1-form ptr))
1661   (nx1-form offset)
1662   (nx1-form newval)))
1663
1664(defnx1 nx1-set-64-xxx ((%%set-unsigned-longlong) (%%set-signed-longlong)) 
1665        (&whole w ptr offset newval &aux (op *nx-sfname*))
1666  (target-word-size-case
1667   (32 (nx1-treat-as-call w))
1668   (64
1669    (make-acode
1670     (%nx1-operator %immediate-set-xxx)
1671     (case op
1672       (%%set-signed-longlong 8)
1673       (t (logior 32 8)))
1674     (make-acode (%nx1-operator %macptrptr%) (nx1-form ptr))
1675     (nx1-form offset)
1676     (nx1-form newval)))))
1677
1678
1679(defnx1 nx1-get-bit ((%get-bit)) (ptrform &optional (offset 0))
1680  (make-acode
1681   (%nx1-operator typed-form)
1682   'bit
1683   (make-acode
1684    (%nx1-operator %get-bit)
1685    (make-acode (%nx1-operator %macptrptr%) (nx1-form ptrform))
1686    (nx1-form offset))))
1687
1688(defnx1 nx1-get-64-xxx ((%%get-unsigned-longlong) (%%get-signed-longlong))
1689  (&whole w ptrform offsetform)
1690  (target-word-size-case
1691   (32 (nx1-treat-as-call w))
1692   (64
1693    (let* ((flagbits (case *nx-sfname*
1694                       (%%get-unsigned-longlong 8)
1695                       (%%get-signed-longlong (logior 32 8))))
1696           (signed (logbitp 5 flagbits)))
1697      (make-acode (%nx1-operator typed-form)
1698                  (if signed
1699                    '(signed-byte 64)
1700                    '(unsigned-byte 64))
1701                (make-acode 
1702                 (%nx1-operator immediate-get-xxx)
1703                 flagbits
1704                 (make-acode (%nx1-operator %macptrptr%) (nx1-form ptrform))
1705                 (nx1-form offsetform)))))))
1706
1707(defnx1 nx1-get-xxx ((%get-long)  (%get-full-long)  (%get-signed-long)
1708                     (%get-fixnum) 
1709                     (%get-word) (%get-unsigned-word)
1710                     (%get-byte) (%get-unsigned-byte)
1711                     (%get-signed-word) 
1712                     (%get-signed-byte) 
1713                     (%get-unsigned-long))
1714  (ptrform &optional (offset 0))
1715  (let* ((sfname *nx-sfname*)
1716         (flagbits (case sfname
1717                     ((%get-long %get-full-long  %get-signed-long) (logior 4 32))
1718                     (%get-fixnum (logior 4 32 64))
1719                     
1720                     ((%get-word %get-unsigned-word) 2)
1721                     (%get-signed-word (logior 2 32))
1722                     ((%get-byte %get-unsigned-byte) 1)
1723                     (%get-signed-byte (logior 1 32))
1724                     (%get-unsigned-long 4)))
1725         (signed (logbitp 5 flagbits)))
1726    (declare (fixnum flagbits))
1727    (make-acode (%nx1-operator typed-form)
1728                (case (logand 15 flagbits)
1729                  (4 (if (logbitp 6 flagbits)
1730                       'fixnum
1731                       (if signed
1732                         '(signed-byte 32)
1733                         '(unsigned-byte 32))))
1734                  (2 (if signed
1735                       '(signed-byte 16)
1736                       '(unsigned-byte 16)))
1737                  (1 (if signed
1738                       '(signed-byte 8)
1739                       '(unsigned-byte 8))))
1740                (make-acode 
1741                 (%nx1-operator immediate-get-xxx)
1742                 flagbits
1743                 (make-acode (%nx1-operator %macptrptr%) (nx1-form ptrform))
1744                 (nx1-form offset)))))
1745
1746(defnx1 nx1-%get-ptr ((%get-ptr) ) (ptrform &optional (offset 0))
1747  (make-acode
1748   (%nx1-operator %consmacptr%)
1749   (make-acode
1750    (%nx1-operator immediate-get-ptr)
1751    (make-acode (%nx1-operator %macptrptr%) (nx1-form ptrform))
1752    (nx1-form offset))))
1753
1754(defnx1 nx1-%get-float ((%get-single-float)
1755                        (%get-double-float)) (ptrform &optional (offset 0))
1756  (make-acode
1757   (%nx1-operator typed-form)
1758   (if (eq *nx-sfname* '%get-single-float)
1759     'single-float
1760     'double-float)
1761   (make-acode
1762    (%nx1-default-operator)
1763    (make-acode (%nx1-operator %macptrptr%) (nx1-form ptrform))
1764    (nx1-form offset))))
1765
1766(defnx1 nx1-%set-float ((%set-single-float)
1767                        (%set-double-float)) (&whole whole ptrform offset &optional (newval nil newval-p))
1768  (unless newval-p
1769    (setq newval offset
1770          offset 0))
1771    (make-acode
1772     (%nx1-operator typed-form)
1773     (if (eq *nx-sfname* '%set-single-float)
1774       'single-float
1775       'double-float)
1776     (make-acode
1777      (%nx1-default-operator)
1778      (make-acode (%nx1-operator %macptrptr%) (nx1-form ptrform))
1779      (nx1-form offset)
1780      (nx1-form newval))))
1781
1782(defnx1 nx1-let let (pairs &body forms &environment old-env)
1783  (collect ((vars)
1784            (vals)
1785            (varbindings))
1786    (with-nx-declarations (pending)
1787      (multiple-value-bind (body decls)
1788                           (parse-body forms *nx-lexical-environment* nil)
1789        (nx-process-declarations pending decls)
1790        ;; Make sure that the initforms are processed in the outer
1791        ;; environment (in case any declaration handlers side-effected
1792        ;; the environment.)
1793       
1794        (let* ((*nx-lexical-environment* old-env))
1795          (dolist (pair pairs)
1796            (let* ((sym (nx-need-var (nx-pair-name pair)))
1797                   (var (nx-cons-var sym))
1798                   (val (nx1-typed-var-initform pending sym (nx-pair-initform pair)))
1799                   (binding (nx1-note-var-binding var val)))
1800              (vars var)
1801              (vals val)
1802              (when binding (varbindings binding)))))
1803        (let* ((*nx-bound-vars* *nx-bound-vars*)
1804               (varbindings (varbindings)))
1805          (dolist (v (vars)) (nx-init-var pending v))
1806          (let* ((form 
1807                  (make-acode 
1808                   (%nx1-operator let)
1809                   (vars)
1810                   (vals)
1811                   (progn
1812                     (nx-effect-other-decls pending *nx-lexical-environment*)
1813                     (nx1-env-body body old-env))
1814                 *nx-new-p2decls*)))
1815          (nx1-check-var-bindings varbindings)
1816          (nx1-punt-bindings (vars) (vals))
1817          form))))))
1818
1819
1820
1821;((lambda (lambda-list) . body) . args)
1822(defun nx1-lambda-bind (lambda-list args body &optional (body-environment *nx-lexical-environment*))
1823  (let* ((old-env body-environment)
1824         (arg-env *nx-lexical-environment*)
1825         (arglist nil)
1826         var-bound-vars
1827         vars vals vars* vals*)
1828    ;; If the lambda list contains &LEXPR, we can't do it.  Yet.
1829    (multiple-value-bind (ok req opttail resttail) (verify-lambda-list lambda-list)
1830      (declare (ignore req opttail))
1831      (when (and ok (eq (%car resttail) '&lexpr))
1832        (return-from nx1-lambda-bind (nx1-call (nx1-form `(lambda ,lambda-list ,@body)) args))))
1833    (let* ((*nx-lexical-environment* body-environment)
1834           (*nx-bound-vars* *nx-bound-vars*))
1835      (with-nx-declarations (pending)
1836        (multiple-value-bind (body decls) (parse-body body *nx-lexical-environment*)
1837          (nx-process-declarations pending decls)
1838          (multiple-value-bind (req opt rest keys auxen)
1839                               (nx-parse-simple-lambda-list pending lambda-list)
1840            (let* ((*nx-lexical-environment* arg-env))
1841              (setq arglist (nx1-formlist args)))
1842            (nx-effect-other-decls pending *nx-lexical-environment*)
1843            (setq body (nx1-env-body body old-env))
1844            (while req
1845              (when (null arglist)
1846                (nx-error "Not enough args in Lambda form: ~S ~S." lambda-list args))
1847              (let* ((var (pop req))
1848                     (val (pop arglist))
1849                     (binding (nx1-note-var-binding var val)))
1850                (push var vars)
1851                (push val vals)
1852                (when binding (push binding var-bound-vars))))
1853            (nx1-check-var-bindings var-bound-vars)
1854            (nx1-punt-bindings vars vals)
1855            (destructuring-bind (&optional optvars inits spvars) opt
1856              (while optvars
1857                (if arglist
1858                  (progn
1859                    (push (%car optvars) vars) (push (%car arglist) vals)
1860                    (when (%car spvars) (push (%car spvars) vars) (push *nx-t* vals)))
1861                  (progn
1862                    (push (%car optvars) vars*) (push (%car inits) vals*)
1863                    (when (%car spvars) (push (%car spvars) vars*) (push *nx-nil* vals*))))
1864                (setq optvars (%cdr optvars) spvars (%cdr spvars) inits (%cdr inits)
1865                      arglist (%cdr arglist))))
1866            (if arglist
1867              (when (and (not keys) (not rest))
1868                (nx-error "Extra args in Lambda form: ~S ~S." lambda-list args))
1869              (when rest
1870                (push rest vars*) (push *nx-nil* vals*)
1871                (nx1-punt-bindings (cons rest nil) (cons *nx-nil* nil))
1872                (setq rest nil)))
1873            (when keys
1874              (let* ((punt nil))
1875                (destructuring-bind (kallowother keyvars spvars inits keyvect) keys
1876                  (do* ((pairs arglist (%cddr pairs)))
1877                       ((null pairs))
1878                    (let* ((keyword (car pairs)))
1879                      (when (or (not (acode-p keyword))
1880                                (neq (acode-operator keyword) (%nx1-operator immediate))
1881                                (eq (%cadr keyword) :allow-other-keys))
1882                        (return (setq punt t)))))
1883                  (do* ((nkeys (length keyvect))
1884                        (keyargs (make-array  nkeys :initial-element nil))
1885                        (argl arglist (%cddr argl))
1886                        (n 0 (%i+ n 1))
1887                        idx arg hit)
1888                       ((null argl)
1889                        (unless rest
1890                          (while arglist
1891                            (push (%cadr arglist) vals)
1892                            (setq arglist (%cddr arglist))))
1893                        (dotimes (i (the fixnum nkeys))                     
1894                          (push (%car keyvars) vars*)
1895                          (push (or (%svref keyargs i) (%car inits)) vals*)
1896                          (when (%car spvars)
1897                            (push (%car spvars) vars*)
1898                            (push (if (%svref keyargs i) *nx-t* *nx-nil*) vals*))
1899                          (setq keyvars (%cdr keyvars) inits (%cdr inits) spvars (%cdr spvars)))
1900                        (setq keys hit))
1901                    (setq arg (%car argl))
1902                    (unless (and (not punt)
1903                                 (%cdr argl))
1904                      (let ((var (nx-new-temp-var pending)))
1905                        (when (or (null rest) (%ilogbitp $vbitdynamicextent (nx-var-bits rest)))
1906                          (nx-set-var-bits var (%ilogior (%ilsl $vbitdynamicextent 1) (nx-var-bits var))))
1907                        (setq body (make-acode
1908                                    (%nx1-operator debind)
1909                                    nil
1910                                    (make-acode 
1911                                     (%nx1-operator lexical-reference) var)
1912                                    nil 
1913                                    nil 
1914                                    rest 
1915                                    keys 
1916                                    auxen 
1917                                    nil 
1918                                    body 
1919                                    *nx-new-p2decls* 
1920                                    nil)
1921                              rest var keys nil auxen nil)
1922                        (return nil)))
1923                    (unless (or (setq idx (position (%cadr arg) keyvect))
1924                                (eq (%cadr arg) :allow-other-keys)
1925                                (and kallowother (symbolp (%cadr arg))))
1926                      (nx-error "Invalid keyword in Lambda form: ~S ~S."
1927                                lambda-list args))
1928                    (when (and idx (null (%svref keyargs idx)))
1929                      (setq hit t)
1930                      (%svset keyargs idx n))))))
1931            (destructuring-bind (&optional auxvars auxvals) auxen
1932              (let ((vars!% (nreconc vars* auxvars))
1933                    (vals!& (nreconc vals* auxvals)))
1934                (make-acode (%nx1-operator lambda-bind)
1935                            (append (nreverse vals) arglist)
1936                            (nreverse vars)
1937                            rest
1938                            keys
1939                            (list vars!% vals!&)
1940                            body
1941                            *nx-new-p2decls*)))))))))
1942
1943(defun nx-inhibit-register-allocation (&optional (why 0))
1944  (let ((afunc *nx-current-function*))
1945    (setf (afunc-bits afunc)
1946          (%ilogior (%ilsl $fbitnoregs 1)
1947                    why
1948                    (afunc-bits afunc)))))
1949
1950
1951
1952(defnx1 nx1-lap-function (ppc-lap-function) (name bindings &body body)
1953  (declare (ftype (function (t t t)) %define-ppc-lap-function))
1954  (require "PPC-LAP" "ccl:compiler;ppc;ppc-lap")
1955  (setf (afunc-lfun *nx-current-function*) 
1956        (%define-ppc-lap-function name `((let ,bindings ,@body))
1957                                  (dpb (length bindings) $lfbits-numreq 0))))
1958
1959(defnx1 nx1-x86-lap-function (x86-lap-function) (name bindings &body body)
1960  (declare (ftype (function (t t t t)) %define-x86-lap-function))
1961  (require "X86-LAP")
1962  (setf (afunc-lfun *nx-current-function*) 
1963        (%define-x86-lap-function name `((let ,bindings ,@body))
1964                                    (dpb (length bindings) $lfbits-numreq 0))))
1965
1966
1967
1968(defun nx1-env-body (body old-env)
1969  (do* ((form (nx1-progn-body body))
1970        (env *nx-lexical-environment* (lexenv.parent-env env)))
1971       ((or (eq env old-env) (null env)) form)
1972    (let ((vars (lexenv.variables env)))
1973      (if (consp vars)
1974        (dolist (var vars)
1975          (nx-check-var-usage var))))))
1976
1977(defnx1 nx1-let* (let*) (varspecs &body forms)
1978  (let* ((vars nil)
1979         (vals nil)
1980         (val nil)
1981         (var-bound-vars nil)
1982         (*nx-bound-vars* *nx-bound-vars*)
1983         (old-env *nx-lexical-environment*))
1984    (with-nx-declarations (pending)
1985      (multiple-value-bind (body decls)
1986                           (parse-body forms *nx-lexical-environment* nil)
1987        (nx-process-declarations pending decls)
1988        (dolist (pair varspecs)         
1989          (let* ((sym (nx-need-var (nx-pair-name pair)))
1990                 (var (progn 
1991                        (push (setq val (nx1-typed-var-initform pending sym (nx-pair-initform pair))) vals)
1992                        (nx-new-var pending sym)))
1993                 (binding (nx1-note-var-binding var val)))
1994            (when binding (push binding var-bound-vars))
1995            (push var vars)))
1996        (nx-effect-other-decls pending *nx-lexical-environment*)
1997        (let* ((result
1998                (make-acode 
1999                 (%nx1-default-operator)
2000                 (setq vars (nreverse vars))
2001                 (setq vals (nreverse vals))
2002                 (nx1-env-body body old-env)
2003                 *nx-new-p2decls*)))
2004          (nx1-check-var-bindings var-bound-vars)
2005          (nx1-punt-bindings vars vals)
2006          result)))))
2007
2008(defnx1 nx1-multiple-value-bind multiple-value-bind 
2009        (varspecs bindform &body forms)
2010  (if (= (length varspecs) 1)
2011    (nx1-form `(let* ((,(car varspecs) ,bindform)) ,@forms))
2012    (let* ((vars nil)
2013           (*nx-bound-vars* *nx-bound-vars*)
2014           (old-env *nx-lexical-environment*)
2015           (mvform (nx1-form bindform)))
2016      (with-nx-declarations (pending)
2017        (multiple-value-bind (body decls)
2018                             (parse-body forms *nx-lexical-environment* nil)
2019          (nx-process-declarations pending decls)
2020          (dolist (sym varspecs)
2021            (push (nx-new-var pending sym t) vars))
2022          (nx-effect-other-decls pending *nx-lexical-environment*)
2023          (make-acode 
2024           (%nx1-operator multiple-value-bind)
2025           (nreverse vars)
2026           mvform
2027           (nx1-env-body body old-env)
2028           *nx-new-p2decls*))))))
2029
2030
2031;;; This isn't intended to be user-visible; there isn't a whole lot of
2032;;; sanity-checking applied to the subtag.
2033(defnx1 nx1-%alloc-misc ((%alloc-misc)) (element-count subtag &optional (init nil init-p))
2034  (if init-p                            ; ensure that "init" is evaluated before miscobj is created.
2035    (make-acode (%nx1-operator %make-uvector)
2036                (nx1-form element-count)
2037                (nx1-form subtag)
2038                (nx1-form init))
2039    (make-acode (%nx1-operator %make-uvector)
2040                (nx1-form element-count)
2041                (nx1-form subtag))))
2042
2043(defnx1 nx1-%lisp-word-ref (%lisp-word-ref) (base offset)
2044  (make-acode (%nx1-operator %lisp-word-ref)
2045              (nx1-form base)
2046              (nx1-form offset)))
2047
2048(defnx1 nx1-%single-to-double ((%single-to-double)) (arg)
2049  (make-acode (%nx1-operator %single-to-double)
2050              (nx1-form arg)))
2051
2052(defnx1 nx1-%double-to-single ((%double-to-single)) (arg)
2053  (make-acode (%nx1-operator %double-to-single)
2054              (nx1-form arg)))
2055
2056(defnx1 nx1-%fixnum-to-double ((%fixnum-to-double)) (arg)
2057  (make-acode (%nx1-operator %fixnum-to-double)
2058              (nx1-form arg)))
2059
2060(defnx1 nx1-%fixnum-to-single ((%fixnum-to-single)) (arg)
2061  (make-acode (%nx1-operator %fixnum-to-single)
2062              (nx1-form arg)))
2063
2064(defnx1 nx1-%double-float ((%double-float)) (&whole whole arg &optional (result nil result-p))
2065  (declare (ignore result))
2066  (if result-p
2067    (nx1-treat-as-call whole)
2068    (make-acode (%nx1-operator %double-float) (nx1-form arg))))
2069
2070(defnx1 nx1-%short-float ((%short-float)) (&whole whole arg &optional (result nil result-p))
2071  (declare (ignore result))       
2072  (if result-p
2073    (nx1-treat-as-call whole)
2074    (make-acode (%nx1-operator %single-float) (nx1-form arg))))
2075
2076
2077(defnx1 nx1-symvector ((%symptr->symvector) (%symvector->symptr)) (arg)
2078  (make-acode (%nx1-default-operator) (nx1-form arg)))
2079       
2080(defnx1 nx1-ash (ash) (&whole call &environment env num amt)
2081  (let* ((unsigned-natural-type (target-word-size-case
2082                                 (32 '(unsigned-byte 32))
2083                                 (64 '(unsigned-byte 64))))
2084         (max (target-word-size-case (32 32) (64 64)))
2085         (maxbits (target-word-size-case
2086                   (32 29)
2087                   (64 60))))
2088    (cond ((eq amt 0) (nx1-form `(require-type ,num 'integer) env))
2089          ((and (fixnump amt)
2090                (< amt 0))
2091           (if (nx-form-typep num 'fixnum env)
2092             (make-acode (%nx1-operator %iasr)
2093                         (make-acode (%nx1-operator fixnum)
2094                                     (- amt))
2095                         (nx1-form num))
2096             (if (nx-form-typep num unsigned-natural-type env)
2097               (make-acode (%nx1-operator natural-shift-right)
2098                           (nx1-form num)
2099                           (make-acode (%nx1-operator fixnum)
2100                                       (- amt)))
2101               (nx1-treat-as-call call))))
2102          ((and (fixnump amt)
2103                (<= 0 amt maxbits)
2104                (or (nx-form-typep num `(signed-byte ,(- (1+ maxbits) amt)) env)
2105                    (and (nx-form-typep num 'fixnum env)
2106                         (nx-trust-declarations env)
2107                         (subtypep *nx-form-type* 'fixnum))))
2108           (nx1-form `(%ilsl ,amt ,num)))
2109          ((and (fixnump amt)
2110                (< amt max)
2111                (nx-form-typep num unsigned-natural-type env)
2112                (nx-trust-declarations env)
2113                (subtypep *nx-form-type* unsigned-natural-type))
2114           (make-acode (%nx1-operator natural-shift-left)
2115                       (nx1-form num)
2116                       (nx1-form amt)))
2117          (t (nx1-treat-as-call call)))))
2118
2119   
2120       
2121(defun nx-badformat (&rest args)
2122 (nx-error "Bad argument format in ~S ." args))
2123
2124(defnx1 nx1-eval-when eval-when (when &body body)
2125  (nx1-progn-body (if (or (memq 'eval when) (memq :execute when)) body)))
2126
2127(defnx1 nx1-misplaced (declare) (&rest args)
2128  (nx-error "~S not expected in ~S." *nx-sfname* (cons *nx-sfname* args)))
2129
Note: See TracBrowser for help on using the repository browser.