Changeset 12534
- Timestamp:
- Aug 5, 2009, 11:51:47 PM (11 years ago)
- Location:
- branches/working-0711/ccl
- Files:
-
- 4 edited
Legend:
- Unmodified
- Added
- Removed
-
branches/working-0711/ccl/compiler/nx1.lisp
r12515 r12534 263 263 (nx1-cc-binaryop (%nx1-default-operator) :ne form1 form2)) 264 264 265 (defnx1 nx1-logbitp ((logbitp)) ( &whole wbitnum int &environment env)265 (defnx1 nx1-logbitp ((logbitp)) (bitnum int &environment env) 266 266 (if (and (nx-form-typep bitnum 267 267 (target-word-size-case (32 '(integer 0 29)) … … 294 294 body))))) 295 295 296 (defnx1 nx1-%new-ptr (%new-ptr) ( &whole wholesize &optional clear-p)296 (defnx1 nx1-%new-ptr (%new-ptr) (size &optional clear-p) 297 297 (make-acode (%nx1-operator %new-ptr) (nx1-form size) (nx1-form clear-p))) 298 298 … … 370 370 ;;; This has to be ultra-bizarre because %schar is a macro. 371 371 ;;; %schar shouldn't be a macro. 372 (defnx1 nx1-%schar ((%schar)) ( &whole warg idx &environment env)372 (defnx1 nx1-%schar ((%schar)) (arg idx &environment env) 373 373 (let* ((arg (nx-transform arg env)) 374 374 (idx (nx-transform idx env)) … … 381 381 (schar ,argvar ,idxvar)) env))) 382 382 383 (defnx1 nx1-%scharcode ((%scharcode)) (arg idx &environment env)383 (defnx1 nx1-%scharcode ((%scharcode)) (arg idx) 384 384 (make-acode (%nx1-operator %scharcode) (nx1-form arg)(nx1-form idx))) 385 385 … … 536 536 (nx1-prefer-areg vector env) (nx1-form index) (nx1-form value))) 537 537 538 (defnx1 nx1-+ ((+-2)) (& whole whole &environment env num1 num2)538 (defnx1 nx1-+ ((+-2)) (&environment env num1 num2) 539 539 (let* ((f1 (nx1-form num1)) 540 540 (f2 (nx1-form num2))) … … 576 576 577 577 578 (defnx1 nx1-*-2 ((*-2)) (& whole whole &environment env num1 num2)578 (defnx1 nx1-*-2 ((*-2)) (&environment env num1 num2) 579 579 (if (nx-binary-fixnum-op-p num1 num2 env) 580 580 (make-acode (%nx1-operator %i*) (nx1-form num1 env) (nx1-form num2 env)) … … 587 587 (make-acode (%nx1-operator mul2) (nx1-form num1 env) (nx1-form num2 env)))))) 588 588 589 (defnx1 nx1-%negate ((%negate)) ( &whole wholenum &environment env)589 (defnx1 nx1-%negate ((%negate)) (num &environment env) 590 590 (if (nx-form-typep num 'fixnum env) 591 591 (if (subtypep *nx-form-type* 'fixnum) … … 595 595 596 596 597 (defnx1 nx1--2 ((--2)) (& whole whole &environment env num0 num1)597 (defnx1 nx1--2 ((--2)) (&environment env num0 num1) 598 598 (if (nx-binary-fixnum-op-p num0 num1 env t) 599 599 (let* ((f0 (nx1-form num0)) … … 633 633 634 634 635 (defnx1 nx1-numcmp ((<-2) (>-2) (<=-2) (>=-2)) (& whole whole &environment env num1 num2)635 (defnx1 nx1-numcmp ((<-2) (>-2) (<=-2) (>=-2)) (&environment env num1 num2) 636 636 (let* ((op *nx-sfname*) 637 637 (both-fixnums (nx-binary-fixnum-op-p num1 num2 env t)) … … 683 683 (nx1-form num2))))) 684 684 685 (defnx1 nx1-num= ((=-2) (/=-2)) (& whole whole &environment env num1 num2 )685 (defnx1 nx1-num= ((=-2) (/=-2)) (&environment env num1 num2 ) 686 686 (let* ((op *nx-sfname*) 687 687 (2-fixnums (nx-binary-fixnum-op-p num1 num2 env t)) … … 735 735 736 736 737 (defnx1 nx1-uvset ((uvset) (%misc-set)) (vector index value &environment env)737 (defnx1 nx1-uvset ((uvset) (%misc-set)) (vector index value) 738 738 (make-acode (%nx1-operator uvset) 739 739 (nx1-form vector) … … 741 741 (nx1-form value))) 742 742 743 (defnx1 nx1-set-schar ((set-schar)) ( &whole w s i v &environment env)743 (defnx1 nx1-set-schar ((set-schar)) (s i v) 744 744 (make-acode (%nx1-operator %set-sbchar) (nx1-form s) (nx1-form i) (nx1-form v))) 745 745 … … 761 761 env))) 762 762 763 (defnx1 nx1-%set-scharcode ((%set-scharcode)) ( &whole ws i v)763 (defnx1 nx1-%set-scharcode ((%set-scharcode)) (s i v) 764 764 (make-acode (%nx1-operator %set-scharcode) 765 765 (nx1-form s) … … 1812 1812 1813 1813 (defnx1 nx1-%set-float ((%set-single-float) 1814 (%set-double-float)) ( &whole wholeptrform offset &optional (newval nil newval-p))1814 (%set-double-float)) (ptrform offset &optional (newval nil newval-p)) 1815 1815 (unless newval-p 1816 1816 (setq newval offset -
branches/working-0711/ccl/compiler/optimizers.lisp
r12339 r12534 326 326 call))) 327 327 328 (define-compiler-macro apply (&whole call &environment envfn arg0 &rest args)328 (define-compiler-macro apply (&whole call fn arg0 &rest args) 329 329 ;; Special-case (apply #'make-instance 'name ...) 330 330 ;; Might be good to make this a little more general, e.g., there … … 481 481 482 482 483 (define-compiler-macro cons (&whole call &environment envx y &aux dcall ddcall)483 (define-compiler-macro cons (&whole call x y &aux dcall ddcall) 484 484 (if (consp (setq dcall y)) 485 485 (cond … … 527 527 call))) 528 528 529 (define-compiler-macro dpb (&whole call &environment envvalue byte integer)529 (define-compiler-macro dpb (&whole call value byte integer) 530 530 (cond ((and (integerp byte) (> byte 0)) 531 531 (if (integerp value) … … 558 558 call))) 559 559 560 (define-compiler-macro %ilsr (&whole call &environment envshift value)560 (define-compiler-macro %ilsr (&whole call shift value) 561 561 (if (eql shift 0) 562 562 value … … 608 608 `(locally ,@body))) 609 609 610 (define-compiler-macro list* (&whole call & environment env &rest rest &aux (n (list-length rest)) last)610 (define-compiler-macro list* (&whole call &rest rest &aux (n (list-length rest)) last) 611 611 (cond ((%izerop n) nil) 612 612 ((null (setq last (%car (last call)))) … … 870 870 call)) 871 871 872 (define-compiler-macro memq ( &whole call &environment envitem list)872 (define-compiler-macro memq (item list) 873 873 ;;(memq x '(y)) => (if (eq x 'y) '(y)) 874 874 ;;Would it be worth making a two elt list into an OR? Maybe if … … 896 896 (some-xx-transform call env)) 897 897 898 (define-compiler-macro nth ( &whole call &environment envcount list)898 (define-compiler-macro nth (count list) 899 899 (if (and (fixnump count) 900 900 (%i>= count 0) … … 903 903 `(car (nthcdr ,count ,list)))) 904 904 905 (define-compiler-macro nthcdr ( &whole call &environment envcount list)905 (define-compiler-macro nthcdr (count list) 906 906 (if (and (fixnump count) 907 907 (%i>= count 0) … … 1025 1025 ;;; expand find-if and find-if-not 1026 1026 1027 (define-compiler-macro find-if (&whole call &environment env 1028 test sequence &rest keys) 1027 (define-compiler-macro find-if (test sequence &rest keys) 1029 1028 `(find ,test ,sequence 1030 1029 :test #'funcall 1031 1030 ,@keys)) 1032 1031 1033 (define-compiler-macro find-if-not (&whole call &environment env 1034 test sequence &rest keys) 1032 (define-compiler-macro find-if-not (test sequence &rest keys) 1035 1033 `(find ,test ,sequence 1036 1034 :test-not #'funcall … … 1077 1075 ;;; expand position-if and position-if-not 1078 1076 1079 (define-compiler-macro position-if (&whole call &environment env 1080 test sequence &rest keys) 1077 (define-compiler-macro position-if (test sequence &rest keys) 1081 1078 `(position ,test ,sequence 1082 1079 :test #'funcall 1083 1080 ,@keys)) 1084 1081 1085 (define-compiler-macro position-if-not (&whole call &environment env 1086 test sequence &rest keys) 1082 (define-compiler-macro position-if-not (test sequence &rest keys) 1087 1083 `(position ,test ,sequence 1088 1084 :test-not #'funcall … … 1214 1210 `(/=-2 ,n0 ,n1)))) 1215 1211 1216 (define-compiler-macro + (& whole w &environment env &optional (n0 nil n0p) (n1 nil n1p) &rest more)1212 (define-compiler-macro + (&optional (n0 nil n0p) (n1 nil n1p) &rest more) 1217 1213 (if more 1218 1214 `(+ (+-2 ,n0 ,n1) ,@more) … … 1223 1219 0)))) 1224 1220 1225 (define-compiler-macro - ( &whole w &environment envn0 &optional (n1 nil n1p) &rest more)1221 (define-compiler-macro - (n0 &optional (n1 nil n1p) &rest more) 1226 1222 (if more 1227 1223 `(- (--2 ,n0 ,n1) ,@more) … … 1874 1870 1875 1871 1876 (define-compiler-macro make-sequence (&whole call &environment envtypespec len &rest keys &key initial-element)1872 (define-compiler-macro make-sequence (&whole call typespec len &rest keys &key initial-element) 1877 1873 (declare (ignore typespec len keys initial-element)) 1878 1874 call) … … 2033 2029 2034 2030 2035 (define-compiler-macro sbit (& environment env &whole call v &optional sub0 &rest others)2031 (define-compiler-macro sbit (&whole call v &optional sub0 &rest others) 2036 2032 (if (and sub0 (null others)) 2037 2033 `(aref (the simple-bit-vector ,v) ,sub0) 2038 2034 call)) 2039 2035 2040 (define-compiler-macro %sbitset (& environment env &whole call v sub0 &optional (newval nil newval-p) &rest newval-was-really-sub1)2036 (define-compiler-macro %sbitset (&whole call v sub0 &optional (newval nil newval-p) &rest newval-was-really-sub1) 2041 2037 (if (and newval-p (not newval-was-really-sub1) ) 2042 2038 `(setf (aref (the simple-bit-vector ,v) ,sub0) ,newval) … … 2296 2292 call)) 2297 2293 2298 (define-compiler-macro instance-slots ( &whole winstance &environment env)2294 (define-compiler-macro instance-slots (instance &environment env) 2299 2295 (if (and (nx-form-constant-p instance env) 2300 2296 (eql (typecode (nx-form-constant-value instance env)) (nx-lookup-target-uvector-subtag :instance))) … … 2356 2352 (and (integerp ,val) (not (< ,val 0))))))) 2357 2353 2358 (define-compiler-macro subtypep (&whole w t1 t2 &optional rtenv &environment env)2354 (define-compiler-macro subtypep (&whole w t1 t2 &optional rtenv) 2359 2355 (if (and (consp t1) 2360 2356 (consp (cdr t1)) … … 2368 2364 2369 2365 2370 (define-compiler-macro string-equal ( &whole ws1 s2 &rest keys)2366 (define-compiler-macro string-equal (s1 s2 &rest keys) 2371 2367 (if (null keys) 2372 2368 `(%fixed-string-equal ,s1 ,s2) … … 2454 2450 w)) 2455 2451 2456 (define-compiler-macro %char-code-upcase ( &whole w code &environment env)2452 (define-compiler-macro %char-code-upcase (code) 2457 2453 (if (typep code '(mod #x110000)) 2458 2454 (%char-code-upcase code) 2459 2455 `(%char-code-case-fold ,code *lower-to-upper*))) 2460 2456 2461 (define-compiler-macro %char-code-downcase ( &whole w code &environment env)2457 (define-compiler-macro %char-code-downcase (code) 2462 2458 (if (typep code '(mod #x110000)) 2463 2459 (%char-code-downcase code) -
branches/working-0711/ccl/lib/level-2.lisp
r11821 r12534 49 49 ; that have been scarfed out of a macro-like lambda list. 50 50 ; The returned value is supposed to be suitable for splicing ... 51 #+not-used 51 52 (defun hoist-special-decls (sym decls) 52 53 (when sym … … 65 66 (error "Invalid lambda list ~s" arglist)) 66 67 (multiple-value-bind (lambda-list whole environment) 67 68 (normalize-lambda-list arglist t t) 68 69 (multiple-value-bind (body local-decs doc) 69 (parse-body body env t) 70 (unless whole (setq whole (gensym))) 71 (unless environment (setq environment (gensym))) 72 (multiple-value-bind (bindings binding-decls) 73 (%destructure-lambda-list lambda-list whole nil nil 74 :cdr-p t 75 :whole-p nil 76 :use-whole-var t 77 :default-initial-value default-initial-value) 78 (values 79 `(lambda (,whole ,environment) 80 (declare (ignorable ,environment)) 81 ,@(hoist-special-decls whole local-decs) 82 ,@(hoist-special-decls environment local-decs) 83 (block ,name 84 (let* ,(nreverse bindings) 85 ,@(when binding-decls `((declare ,@binding-decls))) 86 ,@local-decs 87 ,@body))) 88 doc))))) 70 (parse-body body env t) 71 (let ((whole-var (gensym "WHOLE")) 72 (env-var (gensym "ENVIRONMENT"))) 73 (multiple-value-bind (bindings binding-decls) 74 (%destructure-lambda-list lambda-list whole-var nil nil 75 :cdr-p t 76 :whole-p nil 77 :use-whole-var t 78 :default-initial-value default-initial-value) 79 (when environment 80 (setq bindings (nconc bindings (list `(,environment ,env-var))))) 81 (when whole 82 (setq bindings (nconc bindings (list `(,whole ,whole-var))))) 83 (values 84 `(lambda (,whole-var ,env-var) 85 (declare (ignorable ,whole-var ,env-var)) 86 (block ,name 87 (let* ,(nreverse bindings) 88 ,@(when binding-decls `((declare ,@binding-decls))) 89 ,@local-decs 90 ,@body))) 91 doc)))))) 89 92 90 93 -
branches/working-0711/ccl/lib/macros.lisp
r12408 r12534 761 761 762 762 763 (defmacro defloadvar ( &environment envvar value &optional doc)763 (defmacro defloadvar (var value &optional doc) 764 764 `(progn 765 765 (defstaticvar ,var ,nil ,@(if doc `(,doc))) … … 1263 1263 (svref ,vtemp ,itemp))))) 1264 1264 1265 (defmacro %svset (v i new &environment env)1265 (defmacro %svset (v i new) 1266 1266 (let* ((vtemp (make-symbol "VECTOR")) 1267 1267 (itemp (make-symbol "INDEX")) … … 2751 2751 2752 2752 2753 (defmacro with-hash-table-iterator ((mname hash-table) &body body &environment env)2753 (defmacro with-hash-table-iterator ((mname hash-table) &body body) 2754 2754 "WITH-HASH-TABLE-ITERATOR ((function hash-table) &body body) 2755 2755 provides a method of manually looping over the elements of a hash-table.
Note: See TracChangeset
for help on using the changeset viewer.