src/boot.lisp

   1 ;;; boot.lisp --- First forms to be cross compiled
   2
   3 ;; Copyright (C) 2012, 2013 David Vazquez
   4 ;; Copyright (C) 2012 Raimon Grau
   5
   6 ;; JSCL is free software: you can redistribute it and/or
   7 ;; modify it under the terms of the GNU General Public License as
   8 ;; published by the Free Software Foundation, either version 3 of the
   9 ;; License, or (at your option) any later version.
  10 ;;
  11 ;; JSCL is distributed in the hope that it will be useful, but
  12 ;; WITHOUT ANY WARRANTY; without even the implied warranty of
  13 ;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the GNU
  14 ;; General Public License for more details.
  15 ;;
  16 ;; You should have received a copy of the GNU General Public License
  17 ;; along with JSCL.  If not, see <http://www.gnu.org/licenses/>.
  18
  19 ;;; This code is executed when JSCL compiles this file itself. The
  20 ;;; compiler provides compilation of some special forms, as well as
  21 ;;; funcalls and macroexpansion, but no functions. So, we define the
  22 ;;; Lisp world from scratch. This code has to define enough language
  23 ;;; to the compiler to be able to run.
  24
  25 (/debug "loading boot.lisp!")
  26
  27 (eval-when (:compile-toplevel)
  28   (let ((defmacro-macroexpander
  29          '#'(lambda (form)
  30               (destructuring-bind (name args &body body)
  31                   form
  32                 (let ((whole (gensym)))
  33                   `(eval-when (:compile-toplevel :execute)
  34                      (%compile-defmacro ',name
  35                                         '#'(lambda (,whole)
  36                                              (destructuring-bind ,args ,whole
  37                                                ,@body)))))))))
  38     (%compile-defmacro 'defmacro defmacro-macroexpander)))
  39
  40 (defmacro declaim (&rest decls)
  41   `(eval-when (:compile-toplevel :execute)
  42      ,@(mapcar (lambda (decl) `(!proclaim ',decl)) decls)))
  43
  44 (defmacro defconstant (name value &optional docstring)
  45   `(progn
  46      (declaim (special ,name))
  47      (declaim (constant ,name))
  48      (setq ,name ,value)
  49      ,@(when (stringp docstring) `((oset ,docstring ',name "vardoc")))
  50      ',name))
  51
  52 (defconstant t 't)
  53 (defconstant nil 'nil)
  54 (%js-vset "nil" nil)
  55 (%js-vset "t" t)
  56
  57 (defmacro lambda (args &body body)
  58   `(function (lambda ,args ,@body)))
  59
  60 (defmacro when (condition &body body)
  61   `(if ,condition (progn ,@body) nil))
  62
  63 (defmacro unless (condition &body body)
  64   `(if ,condition nil (progn ,@body)))
  65
  66 (defmacro defvar (name &optional (value nil value-p) docstring)
  67   `(progn
  68      (declaim (special ,name))
  69      ,@(when value-p `((unless (boundp ',name) (setq ,name ,value))))
  70      ,@(when (stringp docstring) `((oset ,docstring ',name "vardoc")))
  71      ',name))
  72
  73 (defmacro defparameter (name value &optional docstring)
  74   `(progn
  75      (setq ,name ,value)
  76      ,@(when (stringp docstring) `((oset ,docstring ',name "vardoc")))
  77      ',name))
  78
  79 (defmacro defun (name args &rest body)
  80   `(progn
  81      (eval-when (:compile-toplevel)
  82        (fn-info ',name :defined t))
  83      (fset ',name #'(named-lambda ,name ,args ,@body))
  84      ',name))
  85
  86 (defmacro return (&optional value)
  87   `(return-from nil ,value))
  88
  89 (defmacro while (condition &body body)
  90   `(block nil (%while ,condition ,@body)))
  91
  92 (defvar *gensym-counter* 0)
  93 (defun gensym (&optional (prefix "G"))
  94   (setq *gensym-counter* (+ *gensym-counter* 1))
  95   (make-symbol (concat prefix (integer-to-string *gensym-counter*))))
  96
  97 (defun boundp (x)
  98   (boundp x))
  99
 100 (defun fboundp (x)
 101   (fboundp x))
 102
 103 (defun eq (x y) (eq x y))
 104 (defun eql (x y) (eq x y))
 105
 106 (defun not (x) (if x nil t))
 107
 108 (defun funcall (function &rest args)
 109   (apply function args))
 110
 111 (defun apply (function arg &rest args)
 112   (apply function (apply #'list* arg args)))
 113
 114 ;; Basic macros
 115
 116 (defmacro dolist ((var list &optional result) &body body)
 117   (let ((g!list (gensym)))
 118     (unless (symbolp var) (error "`~S' is not a symbol." var))
 119     `(block nil
 120        (let ((,g!list ,list)
 121              (,var nil))
 122          (%while ,g!list
 123                  (setq ,var (car ,g!list))
 124                  (tagbody ,@body)
 125                  (setq ,g!list (cdr ,g!list)))
 126          ,result))))
 127
 128 (defmacro dotimes ((var count &optional result) &body body)
 129   (let ((g!count (gensym)))
 130     (unless (symbolp var) (error "`~S' is not a symbol." var))
 131     `(block nil
 132        (let ((,var 0)
 133              (,g!count ,count))
 134          (%while (< ,var ,g!count)
 135                  (tagbody ,@body)
 136                  (incf ,var))
 137          ,result))))
 138
 139 (defmacro cond (&rest clausules)
 140   (unless (null clausules)
 141     (destructuring-bind (condition &body body)
 142         (first clausules)
 143       (cond
 144         ((eq condition t)
 145          `(progn ,@body))
 146         ((null body)
 147          (let ((test-symbol (gensym)))
 148            `(let ((,test-symbol ,condition))
 149               (if ,test-symbol
 150                   ,test-symbol
 151                   (cond ,@(rest clausules))))))
 152         (t
 153          `(if ,condition
 154               (progn ,@body)
 155               (cond ,@(rest clausules))))))))
 156
 157 (defmacro case (form &rest clausules)
 158   (let ((!form (gensym)))
 159     `(let ((,!form ,form))
 160        (cond
 161          ,@(mapcar (lambda (clausule)
 162                      (destructuring-bind (keys &body body)
 163                          clausule
 164                        (if (or (eq keys 't) (eq keys 'otherwise))
 165                            `(t nil ,@body)
 166                            (let ((keys (if (listp keys) keys (list keys))))
 167                              `((or ,@(mapcar (lambda (key) `(eql ,!form ',key)) keys))
 168                                nil ,@body)))))
 169                    clausules)))))
 170
 171 (defmacro ecase (form &rest clausules)
 172   (let ((g!form (gensym)))
 173     `(let ((,g!form ,form))
 174        (case ,g!form
 175          ,@(append
 176             clausules
 177             `((t
 178                (error "ECASE expression failed for the object `~S'." ,g!form))))))))
 179
 180 (defmacro and (&rest forms)
 181   (cond
 182     ((null forms)
 183      t)
 184     ((null (cdr forms))
 185      (car forms))
 186     (t
 187      `(if ,(car forms)
 188           (and ,@(cdr forms))
 189           nil))))
 190
 191 (defmacro or (&rest forms)
 192   (cond
 193     ((null forms)
 194      nil)
 195     ((null (cdr forms))
 196      (car forms))
 197     (t
 198      (let ((g (gensym)))
 199        `(let ((,g ,(car forms)))
 200           (if ,g ,g (or ,@(cdr forms))))))))
 201
 202 (defmacro prog1 (form &body body)
 203   (let ((value (gensym)))
 204     `(let ((,value ,form))
 205        ,@body
 206        ,value)))
 207
 208 (defmacro prog2 (form1 result &body body)
 209   `(prog1 (progn ,form1 ,result) ,@body))
 210
 211 (defmacro prog (inits &rest body )
 212   (multiple-value-bind (forms decls docstring) (parse-body body)
 213     `(block nil
 214        (let ,inits
 215          ,@decls
 216          (tagbody ,@forms)))))
 217
 218 (defmacro psetq (&rest pairs)
 219   (let (;; For each pair, we store here a list of the form
 220         ;; (VARIABLE GENSYM VALUE).
 221         (assignments '()))
 222     (while t
 223       (cond
 224         ((null pairs) (return))
 225         ((null (cdr pairs))
 226          (error "Odd paris in PSETQ"))
 227         (t
 228          (let ((variable (car pairs))
 229                (value (cadr pairs)))
 230            (push `(,variable ,(gensym) ,value)  assignments)
 231            (setq pairs (cddr pairs))))))
 232     (setq assignments (reverse assignments))
 233     ;;
 234     `(let ,(mapcar #'cdr assignments)
 235        (setq ,@(!reduce #'append (mapcar #'butlast assignments) nil)))))
 236
 237 (defmacro do (varlist endlist &body body)
 238   `(block nil
 239      (let ,(mapcar (lambda (x) (if (symbolp x)
 240                                    (list x nil)
 241                                  (list (first x) (second x)))) varlist)
 242        (while t
 243          (when ,(car endlist)
 244            (return (progn ,@(cdr endlist))))
 245          (tagbody ,@body)
 246          (psetq
 247           ,@(apply #'append
 248                    (mapcar (lambda (v)
 249                              (and (listp v)
 250                                   (consp (cddr v))
 251                                   (list (first v) (third v))))
 252                            varlist)))))))
 253
 254 (defmacro do* (varlist endlist &body body)
 255   `(block nil
 256      (let* ,(mapcar (lambda (x1) (if (symbolp x1)
 257                                      (list x1 nil)
 258                                    (list (first x1) (second x1)))) varlist)
 259        (while t
 260          (when ,(car endlist)
 261            (return (progn ,@(cdr endlist))))
 262          (tagbody ,@body)
 263          (setq
 264           ,@(apply #'append
 265                    (mapcar (lambda (v)
 266                              (and (listp v)
 267                                   (consp (cddr v))
 268                                   (list (first v) (third v))))
 269                            varlist)))))))
 270
 271 (defmacro with-collect (&body body)
 272   (let ((head (gensym))
 273         (tail (gensym)))
 274     `(let* ((,head (cons 'sentinel nil))
 275             (,tail ,head))
 276        (flet ((collect (x)
 277                 (rplacd ,tail (cons x nil))
 278                 (setq ,tail (cdr ,tail))
 279                 x))
 280          ,@body)
 281        (cdr ,head))))
 282
 283
 284 (defmacro loop (&body body)
 285   `(while t ,@body))
 286
 287 (defun identity (x) x)
 288
 289 (defun complement (x)
 290   (lambda (&rest args)
 291     (not (apply x args))))
 292
 293 (defun constantly (x)
 294   (lambda (&rest args)
 295     x))
 296
 297 (defun code-char (x)
 298   (code-char x))
 299
 300 (defun char-code (x)
 301   (char-code x))
 302
 303 (defun char= (x y)
 304   (eql x y))
 305
 306 (defun char< (x y)
 307   (< (char-code x) (char-code y)))
 308
 309 (defun atom (x)
 310   (not (consp x)))
 311
 312 (defun alpha-char-p (x)
 313   (or (<= (char-code #\a) (char-code x) (char-code #\z))
 314       (<= (char-code #\A) (char-code x) (char-code #\Z))))
 315
 316 (defun digit-char-p (x)
 317   (if (and (<= (char-code #\0) (char-code x) (char-code #\9)))
 318       (- (char-code x) (char-code #\0))
 319       nil))
 320
 321 (defun digit-char (weight)
 322   (and (<= 0 weight 9)
 323        (char "0123456789" weight)))
 324
 325 (defun equal (x y)
 326   (cond
 327     ((eql x y) t)
 328     ((consp x)
 329      (and (consp y)
 330           (equal (car x) (car y))
 331           (equal (cdr x) (cdr y))))
 332     ((stringp x)
 333      (and (stringp y) (string= x y)))
 334     (t nil)))
 335
 336 (defun fdefinition (x)
 337   (cond
 338     ((functionp x)
 339      x)
 340     ((symbolp x)
 341      (symbol-function x))
 342     (t
 343      (error "Invalid function `~S'." x))))
 344
 345 (defun disassemble (function)
 346   (write-line (lambda-code (fdefinition function)))
 347   nil)
 348
 349 (defmacro multiple-value-bind (variables value-from &body body)
 350   `(multiple-value-call (lambda (&optional ,@variables &rest ,(gensym))
 351                           ,@body)
 352      ,value-from))
 353
 354 (defmacro multiple-value-list (value-from)
 355   `(multiple-value-call #'list ,value-from))
 356
 357
 358 ;; Incorrect typecase, but used in NCONC.
 359 (defmacro typecase (x &rest clausules)
 360   (let ((value (gensym)))
 361     `(let ((,value ,x))
 362        (cond
 363          ,@(mapcar (lambda (c)
 364                      (if (find (car c) '(t otherwise))
 365                          `(t ,@(rest c))
 366                          `((,(ecase (car c)
 367                                     (integer 'integerp)
 368                                     (cons 'consp)
 369                                     (list 'listp)
 370                                     (vector 'vectorp)
 371                                     (character 'characterp)
 372                                     (sequence 'sequencep)
 373                                     (symbol 'symbolp)
 374                                     (function 'functionp)
 375                                     (float 'floatp)
 376                                     (array 'arrayp)
 377                                     (string 'stringp)
 378                                     (atom 'atom)
 379                                     (null 'null)
 380                                     (package 'packagep))
 381                              ,value)
 382                            ,@(or (rest c)
 383                                  (list nil)))))
 384                    clausules)))))
 385
 386 (defmacro etypecase (x &rest clausules)
 387   (let ((g!x (gensym)))
 388     `(let ((,g!x ,x))
 389        (typecase ,g!x
 390          ,@clausules
 391          (t (error "~S fell through etypecase expression." ,g!x))))))
 392
 393 (defun notany (fn seq)
 394   (not (some fn seq)))
 395
 396 (defconstant internal-time-units-per-second 1000)
 397
 398 (defun get-internal-real-time ()
 399   (get-internal-real-time))
 400
 401 (defun get-unix-time ()
 402   (truncate (/ (get-internal-real-time) 1000)))
 403
 404 (defun get-universal-time ()
 405   (+ (get-unix-time) 2208988800))
 406
 407 (defun values-list (list)
 408   (values-array (list-to-vector list)))
 409
 410 (defun values (&rest args)
 411   (values-list args))
 412
 413 (defun error (fmt &rest args)
 414   (%throw (apply #'format nil fmt args)))
 415
 416 (defmacro nth-value (n form)
 417   `(multiple-value-call (lambda (&rest values)
 418                           (nth ,n values))
 419      ,form))