mirror of
https://gitlab.com/embeddable-common-lisp/ecl.git
synced 2026-04-27 19:50:44 -07:00
e32b5d5e1f
RPLACA and RPLACD macros were the only clients of SIMPLE-OPTIMIZER-FUNCTION and said optimizer took more code than explicitly writing twice the expansion as the compiler macro.
128 lines
3.7 KiB
Common Lisp
128 lines
3.7 KiB
Common Lisp
;;;; -*- Mode: Lisp; Syntax: Common-Lisp; indent-tabs-mode: nil; Package: C -*-
|
|
;;;; vim: set filetype=lisp tabstop=8 shiftwidth=2 expandtab:
|
|
|
|
;;;;
|
|
;;;; CMPOPT-CONS Optimization of CONS functions
|
|
;;;;
|
|
;;;; Copyright (c) 2010, Juan Jose Garcia-Ripoll
|
|
;;;;
|
|
;;;; See the file 'LICENSE' for the copyright details.
|
|
;;;;
|
|
|
|
(in-package "COMPILER")
|
|
|
|
(defun si:cons-car (x)
|
|
(declare (type cons x) (optimize (safety 0) (speed 3)))
|
|
(car x))
|
|
|
|
(defun si:cons-cdr (x)
|
|
(declare (type cons x) (optimize (safety 0) (speed 3)))
|
|
(cdr x))
|
|
|
|
;;;
|
|
;;; CONS
|
|
;;; turn repetitious cons's into a list*
|
|
;;;
|
|
|
|
(define-compiler-macro cons (&whole whole &rest args)
|
|
(labels ((cons-to-lista (x)
|
|
(let ((tem (last x)))
|
|
(if (and (consp tem)
|
|
(consp (car tem))
|
|
(eq (caar tem) 'CONS)
|
|
(eql (length (cdar tem)) 2))
|
|
(cons-to-lista (append (butlast x) (cdar tem)))
|
|
x))))
|
|
(let (temp)
|
|
(if (and (eql (length args) 2)
|
|
(not (eq args (setq temp (cons-to-lista args)))))
|
|
(if (equal '(nil) (last temp))
|
|
(cons 'LIST (butlast temp))
|
|
(cons 'LIST* temp))
|
|
whole))))
|
|
|
|
;;;
|
|
;;; RPLACA / RPLACD
|
|
;;;
|
|
|
|
(define-compiler-macro rplaca (&whole whole place value)
|
|
(if (policy-inline-accessors)
|
|
`(ffi:c-inline (,(if (policy-assume-right-type)
|
|
place
|
|
`(ext:checked-value cons ,place))
|
|
,value)
|
|
(:object :object) :object
|
|
"(ECL_CONS_CAR(#0)=#1,#0)" :one-liner t)
|
|
whole))
|
|
|
|
(define-compiler-macro rplacd (&whole whole place value)
|
|
(if (policy-inline-accessors)
|
|
`(ffi:c-inline (,(if (policy-assume-right-type)
|
|
place
|
|
`(ext:checked-value cons ,place))
|
|
,value)
|
|
(:object :object) :object
|
|
"(ECL_CONS_CDR(#0)=#1,#0)" :one-liner t)
|
|
whole))
|
|
|
|
;;;
|
|
;;; NTH / NTHCDR
|
|
;;;
|
|
|
|
(define-compiler-macro nth (&whole whole n list)
|
|
(case n
|
|
(0 `(car ,list))
|
|
(1 `(cadr ,list))
|
|
(2 `(caddr ,list))
|
|
(3 `(cadddr ,list))
|
|
(4 `(car (cddddr ,list)))
|
|
(5 `(cadr (cddddr ,list)))
|
|
(6 `(caddr (cddddr ,list)))
|
|
(7 `(cadddr (cddddr ,list)))
|
|
(t whole)))
|
|
|
|
(define-compiler-macro nthcdr (&whole whole n list)
|
|
(case n
|
|
(0 list)
|
|
(1 `(cdr ,list))
|
|
(2 `(cddr ,list))
|
|
(3 `(cdddr ,list))
|
|
(4 `(cddddr ,list))
|
|
(5 `(cdr (cddddr ,list)))
|
|
(6 `(cddr (cddddr ,list)))
|
|
(7 `(cdddr (cddddr ,list)))
|
|
(t whole)))
|
|
|
|
;;;
|
|
;;; FIRST, SECOND, THIRD, ...
|
|
;;;
|
|
|
|
(progn .
|
|
#.(loop for n in '(first second third fourth fifth sixth seventh eighth ninth tenth)
|
|
for i from 0
|
|
collect `(define-compiler-macro ,n (x) (list 'nth ,i x))))
|
|
|
|
(define-compiler-macro rest (x) `(cdr ,x))
|
|
|
|
;;;
|
|
;;; POP
|
|
;;;
|
|
|
|
(define-compiler-macro pop (&whole whole place &environment env)
|
|
(if (policy-inline-accessors)
|
|
(multiple-value-bind (vars vals stores store-form access-form)
|
|
(get-setf-expansion place env)
|
|
(let* ((store-var (first stores))
|
|
(saved-place (gensym)))
|
|
`(let* ,(mapcar #'list
|
|
(append vars (list saved-place))
|
|
(append vals (list access-form)))
|
|
(declare (:read-only ,@vars)) ; Beppe
|
|
(optional-type-check ,saved-place list)
|
|
(when ,saved-place
|
|
(let ((,store-var (si:cons-cdr ,saved-place)))
|
|
(declare (:read-only ,store-var))
|
|
,store-form
|
|
(setq ,saved-place (si:cons-car ,saved-place))))
|
|
,saved-place)))
|
|
whole))
|