Skip to content
Fetching contributors…
Cannot retrieve contributors at this time
156 lines (136 sloc) 5.9 KB
;; Copyright (c) 2008-2011 Robert Virding. All rights reserved.
;; Redistribution and use in source and binary forms, with or without
;; modification, are permitted provided that the following conditions
;; are met:
;; 1. Redistributions of source code must retain the above copyright
;; notice, this list of conditions and the following disclaimer.
;; 2. Redistributions in binary form must reproduce the above copyright
;; notice, this list of conditions and the following disclaimer in the
;; documentation and/or other materials provided with the distribution.
;; THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS
;; "AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT
;; LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS
;; FOR A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE
;; COPYRIGHT HOLDERS OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT,
;; INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING,
;; BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES;
;; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER
;; CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT
;; LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN
;; ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE
;; POSSIBILITY OF SUCH DAMAGE.
;; File : core-macros.lfe
;; Author : Robert Virding
;; Purpose : Some of LFE core macrosas they could have been implemented in LFE.
;; This file contains some of the core LFE macros as they could have
;; been implemented in LFE. They are implemented in lfe_macro.erl
;; today as there is yet no way to compile macros, and to ensure that
;; they are always available. These are shown mostly without comments.
;;
;; For some macros we give two versions, an all-in-one version and a
;; recursive more syntax pattern based expansion. This to show
;; different styles of doing the same thing.
(defmacro caar (x) `(car (car ,x)))
(defmacro cadr (x) `(car (cdr ,x)))
(defmacro cdar (x) `(cdr (car ,x)))
(defmacro cddr (x) `(cdr (cdr ,x)))
(defmacro ++
;; Cases with quoted lists.
((cons (list 'quote (cons a as)) es) `(cons ',a (++ ',as . ,es)))
((cons (list 'quote ()) es) `(++ . ,es))
;; Cases with explicit cons/list/list*.
((cons (list 'list* a) es) `(++ ,a . ,es))
((cons (cons 'list* (cons a as)) es) `(cons ,a (++ (list* . ,as) . ,es)))
((cons (cons 'list (cons a as)) es) `(cons ,a (++ (list . ,as) . ,es)))
((cons (list 'list) es) `(++ . ,es))
((cons (list 'cons h t) es) `(cons ,h (++ ,t . ,es)))
((cons () es) `(++ . ,es))
;; Default cases with unquoted arg.
((list e) e)
((cons e es) `(call 'erlang '++ ,e (++ . ,es)))
(() ()))
(defmacro :
((list* m f as) `(call ',m ',f . ,as)))
(defmacro ?
((list to default)
`(receive (omega omega) (after ,to ,default)))
((list to) `(? ,to (exit 'timeout)))
(() `(receive (omega omega))))
(defmacro list*
((list e) e)
((cons e es) `(cons ,e (list* . ,es)))
(() ()))
;; (defmacro let*
;; ((cons vbs b)
;; (: lists foldr
;; (lambda (vb rest) `(let (,vb) ,rest)) `(progn . ,b) vbs)))
(defmacro let*
((cons (cons vb vbs) b) `(let (,vb) (let* ,vbs . ,b)))
((cons () b) `(progn . ,b))
((cons vb b) `(let ,vb . b))) ;Pass error to let
(defmacro flet*
((cons (cons fb fbs) b) `(flet (,fb) (flet* ,fbs . ,b)))
((cons () b) `(progn . ,b))
((cons fb b) `(flet ,fb . b))) ;Pass error to flet
(defmacro cond
((list (cons 'else b)) `(progn . ,b))
((cons (cons (list '?= p e) b) cond)
`(case ,e (,p . ,b) (_ (cond . ,cond))))
((cons (cons (list '?= p (= (cons 'when _) g) e) b) cond)
`(case ,e (,p ,g . ,b) (_ (cond . ,cond))))
((cons (cons test b) cond) `(if ,test (progn . ,b) (cond . ,cond)))
(() `'false))
(defmacro andalso
((list e) e)
((cons e es) `(if ,e (andalso . ,es) 'false))
(() `'true))
(defmacro orelse args ;Using single argument
(case args
((list e) e)
((cons e es) `(if ,e 'true (orelse . ,es)))
(() `'false)))
;; This version of backquote is almost an exact copy of a quasiquote
;; expander for Scheme by André van Tonder. It is very compact and
;; with some cons/append optimisations we have added produces quite
;; reasonable code.
(defmacro backquote (e) (bq-expand e 0))
(eval-when-compile
(defun bq-expand (exp n)
;; Note that we cannot *use* backquote or any macros using
;; backquote in here! It will cause us to loop.
(fletrec ((bq-app ;Optimise append
([(list '++ l) r] (bq-app l r)) ;Catch single unquote-splice
([() r] r)
([l ()] l)
([(list 'list l) (cons 'list r)] (cons 'list (cons l r)))
([(list 'list l) r] (list 'cons l r))
([l r] (list '++ l r)))
(bq-cons ;Optimise cons
([(list 'quote l) (list 'quote r)] (list 'quote (cons l r)))
([l (cons 'list r)] (cons 'list (cons l r)))
([l ()] (list 'list l))
([l r] (list 'cons l r))))
(case exp
((list 'backquote x) ;`(list 'backquote ,(bq-expand x (+ n 1)))
(list 'list (list 'quote 'backquote) (bq-expand x (+ n 1))))
((list 'unquote x) (when (> n 0))
(bq-cons 'unquote (bq-expand x (- n 1))))
((list 'unquote x) (when (=:= n 0)) x)
((list 'unquote-splicing . x) (when (> n 0))
(bq-cons (list 'quote 'unquote-splicing) (bq-expand x (- n 1))))
;; The next two cases handle splicing into a list.
(((list 'unquote . x) . y) (when (=:= n 0))
(bq-app (cons 'list x) (bq-expand y 0)))
(((list 'unquote-splicing . x) . y) (when (=:= n 0))
(bq-app (cons '++ x) (bq-expand y 0)))
((cons x y) ;The general list case
(bq-cons (bq-expand x n) (bq-expand y n)))
(_ (when (is_tuple exp))
;; Tuples need some smartness for efficient code to handle
;; when no splicing so as to avoid list_to_tuple.
(case (bq-expand (tuple_to_list exp) n)
(('list . es) (cons tuple es))
((= ('cons . _) e) (list 'list_to_tuple e))))
(_ (when (is_atom exp)) (list 'quote exp))
(_ exp)) ;Self quoting
)))
Something went wrong with that request. Please try again.