diff options
Diffstat (limited to 'stdlib')
47 files changed, 13822 insertions, 0 deletions
diff --git a/stdlib/asm.tl b/stdlib/asm.tl new file mode 100644 index 00000000..624ddff6 --- /dev/null +++ b/stdlib/asm.tl @@ -0,0 +1,782 @@ +;; Copyright 2018-2021 +;; Kaz Kylheku <kaz@kylheku.com> +;; Vancouver, Canada +;; 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 HOLDER 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. + +(load "vm-param") + +(defstruct oc-base nil + (:static deprecated nil) + (:method synerr (me fmt . args) + (error `opcode @{me.symbol}: @fmt` . args)) + + (:method chk-arg-count (me n syntax) + (when (neq (length (rest syntax)) n) + me.(synerr "~s arguments required; ~s is invalid" + n syntax))) + + (:method chk-arg-count-min (me n syntax) + (when (< (length (rest syntax)) n) + me.(synerr "~s arguments required; ~s is invalid" + n syntax))) + + (:method backpatch (me asm at offs) + (asm-error `@{me.symbol} doesn't backpatch`))) + +(compile-only + (defstruct assembler nil + buf + bstr + (max-treg 0) + (labdef (hash)) + (labref (hash)) + (:static imm-width (relate '(si mi bi) '(10 16 32))) + (:static sign-bits (relate '(fixnum bignum chr) '(1 1 0))) + (:static operand-name (relate '(si mi bi l r rs d ds n o) + '("small immediate" + "medium immediate" + "big immediate" + "label" + "register operand" + "register small operand" + "register destination operand" + "register small destination operand" + "integer" + "any object"))))) + +(defmeth assembler :postinit (me) + (cond + (me.buf (set me.bstr (make-buf-stream me.buf))) + (me.bstr (set me.buf (get-buf-from-stream me.bstr))) + (t (set me.bstr (make-buf-stream) + me.buf (get-buf-from-stream me.bstr))))) + +(defmeth assembler cur-pos (me) + (seek-stream me.bstr 0 :from-current)) + +(defmeth assembler set-pos (me pos) + (seek-stream me.bstr pos :from-start)) + +(defmeth assembler lookup-label (me sym oc) + (condlet + (((n [me.labdef sym])) n) + (t (push (cons oc (trunc me.(cur-pos) 4)) [me.labref sym]) + 0))) + +(defmeth assembler define-label (me sym) + (let* ((pos me.(cur-pos)) + (ins (trunc pos 4))) + (set [me.labdef sym] ins) + (each ((entry (del [me.labref sym]))) + (tree-bind (oc . offs) entry + me.(set-pos (* 4 offs)) + oc.(backpatch me (* 4 offs) ins))) + me.(set-pos pos) + ins)) + +(defmeth assembler read-buf (me bytes) + (let ((buf (make-buf bytes))) + (when (neql (fill-buf buf 0 me.bstr) bytes) + (asm-error "read past instruction block")) + buf)) + +(defmeth assembler put-word (me word) + (let* ((buf (make-buf 0))) + (buf-put-u32 buf 0 word) + (put-buf buf 0 me.bstr))) + +(defmeth assembler put-insn (me code extension operand) + (let ((word (logior (ash code 26) (ash extension 16) operand)) + (buf (make-buf 0))) + (buf-put-u32 buf 0 word) + (put-buf buf 0 me.bstr))) + +(defmeth assembler put-pair (me op1 op2) + (let ((word (logior (ash op1 16) op2)) + (buf (make-buf 0))) + (buf-put-u32 buf 0 word) + (put-buf buf 0 me.bstr))) + +(defmeth assembler get-word (me) + (let* ((buf me.(read-buf (sizeof uint32)))) + (buf-get-u32 buf 0))) + +(defmeth assembler get-insn (me) + (let* ((buf me.(read-buf (sizeof uint32))) + (word (buf-get-u32 buf 0))) + (list (ash word -26) + (logtrunc (ash word -16) 10) + (logtrunc word 16)))) + +(defmeth assembler get-pair (me) + (let* ((buf me.(read-buf (sizeof uint32))) + (word (buf-get-u32 buf 0))) + (list (ash word -16) (logtrunc word 16)))) + +(defmeth assembler immediate-fits-type (me arg operand-type) + (and (member (typeof arg) + '(fixnum chr)) + (<= (+ (width arg) + [me.sign-bits (typeof arg)] + 2) + [me.imm-width operand-type]))) + +(defmeth assembler parse-args (me oc syntax pattern) + (mapcar (lambda (type arg n) + (let ((parg (caseql type + ((si mi bi) + (when me.(immediate-fits-type arg type) + arg)) + (l (cond + ((is-label arg) me.(lookup-label arg oc)) + ((integerp arg) arg))) + (n (if (integerp arg) arg)) + (o arg) + ((r rs d ds) + (cond + ((null arg) 0) + ((consp arg) + (parse-compound-operand arg)) + ((symbolp arg) + (parse-operand (symbol-name arg))))) + (t (asm-error "invalid arg type spec ~s" type))))) + (unless (or parg (eq type 'o)) + oc.(synerr "argument ~a of ~s invalid; ~a expected" + n syntax [me.operand-name type])) + (when (and (member type '(d ds)) + (or (zerop parg))) + oc.(synerr "argument ~a of ~s cannot be destination" + n syntax)) + (when (and (member type '(rs ds)) + (not (small-op-p parg))) + oc.(synerr "argument ~a of ~s isn't a small register" + n syntax)) + (when (and (member type '(r rs d ds)) (< parg %lev-size%)) + (set me.max-treg (max parg me.max-treg))) + parg)) + pattern (rest syntax) (range 1))) + +(defmeth assembler asm-one (me syntax) + (let ((oc (cond + ((is-label syntax) [%oc-hash% 'label]) + ((consp syntax) [%oc-hash% (car syntax)])))) + (unless oc + (asm-error "invalid instruction ~s" syntax)) + oc.(asm me syntax))) + +(defmeth assembler asm (me insns) + (each ((i insns)) + me.(asm-one i)) + (unless (empty me.labref) + (asm-error "dangling label references")) + (whenlet ((n (cdr [find-max me.labdef : cdr]))) + (unless (< -1 n (len me.buf)) + (asm-error "labels outside of code")))) + +(defmeth assembler dis-one (me) + (tree-bind (code extension operand) me.(get-insn) + (let ((oc [%oc-hash% code])) + oc.(dis me extension operand)))) + +(defmeth assembler dis (me) + me.(set-pos 0) + (build + (while (< me.(cur-pos) (len me.buf)) + (add me.(dis-one))))) + +(defmeth assembler dis-listing (me : (stream *stdout*)) + (let ((p 0) + (c 0) + (l (len me.buf))) + me.(set-pos p) + (while (< p l) + (let* ((dis me.(dis-one)) + (dis-txt (cat-str [mapcar tostringp dis] " ")) + (q me.(cur-pos))) + (inc c) + me.(set-pos p) + (format t "~,5d: ~,08X ~a\n" (trunc p 4) me.(get-word) dis-txt) + (while (< (inc p 4) q) + (format t "~,5d: ~,08X\n" (trunc p 4) me.(get-word))) + me.(set-pos q) + (set p q))) + c)) + +(defvarl %oc-list-builder% (new list-builder)) + +(defvarl %oc-hash% (hash)) + +(defparml %oc-code% 0) + +(defun asm-error (msg . args) + (error `~s: @msg` 'assembler . args)) + +(defun register-opcode (oc) + %oc-list-builder%.(add oc) + (set [%oc-hash% oc.symbol] oc) + (set [%oc-hash% oc.code] oc)) + +(defun is-label (obj) + (or (keywordp obj) + (and (symbolp obj) + (not (symbol-package obj))))) + +(defun parse-compound-operand (cons) + (tree-case cons + ((sym arg) + (when (< -1 arg %lev-size%) + (caseq sym + ((t) arg) + (d (+ arg %lev-size%))))) + ((sym arg1 arg2) + (when (and (<= 0 arg1 %max-v-lev%) + (<= 0 arg2 %max-lev-idx%)) + (caseq sym + (v (+ (* (ssucc arg1) %lev-size%) arg2))))))) + +(defun parse-operand (str) + (cond + ((r^$ #/t[0-9A-Fa-f][0-9A-Fa-f]?[0-9A-Fa-f]?/ str) + (int-str [str 1..:] 16)) + ((r^$ #/d[0-9A-Fa-f][0-9A-Fa-f]?[0-9A-Fa-f]?/ str) + (+ %lev-size% (int-str [str 1..:] 16))) + ((r^$ #/v[0-9A-Fa-f][0-9A-Fa-f][0-9A-Fa-f][0-9A-Fa-f][0-9A-Fa-f]/ str) + (let ((lv (int-str [`0@{str[1..:]}` -5..-3] 16)) + (ix (int-str [str -3..:] 16))) + (+ (* %lev-size% (ssucc lv)) ix))))) + +(eval-only + (defmacro with-lev-idx ((lev-var idx-var) val-expr . body) + (with-gensyms (val-var) + ^(let* ((,val-var ,val-expr) + (,lev-var (ash ,val-var (- %lev-bits%))) + (,idx-var (logtrunc ,val-var %lev-bits%))) + ,*body)))) + +(defun operand-to-sym (val) + (with-lev-idx (lv ix) val + (caseql lv + (0 (if (zerop ix) + nil + (intern (fmt "t~s" ix)))) + (1 (intern (fmt "d~s" ix))) + (t (intern (fmt "v~,02X~,03X" (ppred lv) ix)))))) + +(defun operand-to-exp (val) + (with-lev-idx (lv ix) val + (caseql lv + (0 (if (zerop ix) + nil + ^(t ,ix))) + (1 ^(d ,ix)) + (t ^(v ,(ppred lv) ,ix))))) + +(defun bits-to-obj (bits width) + (let ((tag (logtrunc bits 2)) + (val (ash bits -2))) + (caseq tag + (1 (sign-extend val (- width 2))) + (2 (chr-int val)) + (t (error "~s: bad immediate operand: ~x" 'assembler bits))))) + +(defun small-op-p (val) + (with-lev-idx (lv ix) val + (and (<= 0 ix %max-sm-lev-idx%) + (<= 0 lv %max-sm-lev%)))) + +(defun enc-small-op (val) + (with-lev-idx (lv ix) val + (logior (ash lv %sm-lev-bits%) ix))) + +(defun small-op-to-sym (sval) + (let ((lv (ash sval (- %sm-lev-bits%))) + (ix (logtrunc sval %sm-lev-bits%))) + (operand-to-sym (+ (* lv %lev-size%) ix)))) + +(defstruct backpatch-low16 nil + (:method backpatch (me asm at offs) + (tree-bind (hi lo) asm.(get-pair) + asm.(set-pos at) + asm.(put-pair hi offs)))) + +(defstruct backpatch-high16 nil + (:method backpatch (me asm at offs) + (tree-bind (hi lo) asm.(get-pair) + asm.(set-pos at) + asm.(put-pair offs lo)))) + +(defvarl %backpatch-low16% (new backpatch-low16)) +(defvarl %backpatch-high16% (new backpatch-high16)) + +(eval-only + (defmacro defopcode (class symbol code . slot-defs) + ^(symacrolet ((auto (pinc %oc-code%))) + (defstruct ,class oc-base + (:static symbol ',symbol) + (:static code ,code) + ,*slot-defs) + (register-opcode (new ,class)))) + + (defmacro defopcode-derived (class symbol code orig-class) + ^(symacrolet ((auto (pinc %oc-code%))) + (defstruct ,class ,orig-class + (:static symbol ',symbol) + (:static code ,code)) + (register-opcode (new ,class)))) + + (defmacro defopcode-alias (alias-symbol orig-symbol) + ^(let ((oc [%oc-hash% ',orig-symbol])) + (set [%oc-hash% ',alias-symbol] oc)))) + +(defopcode op-label label nil + (:method asm (me asm syntax) + (unless (is-label syntax) + asm.(synerr "label must be keyword or gensym")) + asm.(define-label syntax)) + + (:method dis (me asm extension operand))) + +(defopcode op-noop noop auto + (:method asm (me asm syntax) + me.(chk-arg-count 0 syntax) + asm.(put-insn me.code 0 0)) + + (:method dis (me asm extension operand) + ^(,me.symbol))) + +(defopcode op-frame frame auto + (:method asm (me asm syntax) + me.(chk-arg-count 2 syntax) + (tree-bind (lev size) asm.(parse-args me syntax '(n n)) + (unless (<= 2 lev %max-v-lev%) + me.(synerr "level must range from 2 to ~a" + %max-v-lev%)) + (unless (<= 0 size %lev-size%) + me.(synerr "size must range from 0 to ~a" + %lev-size%)) + asm.(put-insn me.code lev size))) + (:method dis (me asm lev size) + ^(,me.symbol ,lev ,size))) + +(defopcode-derived op-sframe sframe auto op-frame) + +(defopcode-derived op-dframe dframe auto op-frame) + +(defopcode op-end end auto + (:method asm (me asm syntax) + me.(chk-arg-count 1 syntax) + (let ((res (car asm.(parse-args me syntax '(r))))) + asm.(put-insn me.code 0 res))) + (:method dis (me asm extension res) + ^(,me.symbol ,(operand-to-sym res)))) + +(defopcode-alias jend end) + +(defopcode-derived op-prof prof auto op-end) + +(defopcode op-call call auto + (:method asm (me asm syntax) + me.(chk-arg-count-min 2 syntax) + (let* ((nargs (pred (len syntax))) + (syn-pat (repeat '(r) (succ nargs))) + (funargs (ppred nargs)) + (args asm.(parse-args me syntax syn-pat))) + asm.(put-insn me.code funargs (pop args)) + (while args + (let ((x (pop args)) + (y (or (pop args) 0))) + asm.(put-pair y x))))) + + (:method dis (me asm funargs arg0) + (build + (add me.symbol) + (add (operand-to-sym arg0)) + (inc funargs 1) + (while (> funargs 0) + (dec funargs 2) + (tree-bind (y x) asm.(get-pair) + (add (operand-to-sym x)) + (unless (minusp funargs) + (add (operand-to-sym y)))))))) + +(defopcode-derived op-apply apply auto op-call) + +(defopcode op-gcall gcall auto + (:method asm (me asm syntax) + me.(chk-arg-count-min 2 syntax) + (let* ((nargs (pred (len syntax))) + (syn-pat (list* 'r 'n (repeat '(r) (sssucc nargs)))) + (funargs (ppred nargs)) + (args asm.(parse-args me syntax syn-pat))) + asm.(put-insn me.code funargs (pop args)) + (while args + (let ((x (pop args)) + (y (or (pop args) 0))) + asm.(put-pair y x))))) + + (:method dis (me asm funargs arg0) + (let ((first t)) + (build + (add me.symbol) + (add (operand-to-sym arg0)) + (inc funargs 1) + (while (> funargs 0) + (dec funargs 2) + (tree-bind (y x) asm.(get-pair) + (add (if (zap first) x (operand-to-sym x))) + (unless (minusp funargs) + (add (operand-to-sym y))))))))) + +(defopcode-derived op-gapply gapply auto op-gcall) + +(defopcode op-movrs movrs auto + (:method asm (me asm syntax) + me.(chk-arg-count 2 syntax) + (tree-bind (dst src) asm.(parse-args me syntax '(d rs)) + asm.(put-insn me.code (enc-small-op src) dst))) + + (:method dis (me asm src dst) + ^(,me.symbol ,(operand-to-sym dst) ,(small-op-to-sym src)))) + +(defopcode op-movsr movsr auto + (:method asm (me asm syntax) + me.(chk-arg-count 2 syntax) + (tree-bind (dst src) asm.(parse-args me syntax '(ds r)) + asm.(put-insn me.code (enc-small-op dst) src))) + + (:method dis (me asm dst src) + ^(,me.symbol ,(small-op-to-sym dst) ,(operand-to-sym src)))) + +(defopcode op-movrr movrr auto + (:method asm (me asm syntax) + me.(chk-arg-count 2 syntax) + (tree-bind (dst src) asm.(parse-args me syntax '(d r)) + asm.(put-insn me.code 0 dst) + asm.(put-pair 0 src))) + + (:method dis (me asm extension dst) + (let ((src (cadr asm.(get-pair)))) + ^(,me.symbol ,(operand-to-sym dst) ,(operand-to-sym src))))) + +(defopcode op-mov-pseudo mov nil + (:method asm (me asm syntax) + (tree-bind (dst src) asm.(parse-args me syntax '(d r)) + (let ((real [%oc-hash% (cond + ((small-op-p dst) 'movsr) + ((small-op-p src) 'movrs) + (t 'movrr))])) + real.(asm asm syntax))))) + +(defopcode op-jmp jmp auto + (:method asm (me asm syntax) + me.(chk-arg-count 1 syntax) + (let ((dst (car asm.(parse-args me syntax '(l))))) + asm.(put-insn me.code (ash dst -16) (logtrunc dst 16)))) + + (:method backpatch (me asm at dst) + asm.(put-insn me.code (ash dst -16) (logtrunc dst 16))) + + (:method dis (me asm high16 low16) + ^(,me.symbol ,(logior (ash high16 16) low16)))) + +(defopcode op-if if auto + (:method asm (me asm syntax) + me.(chk-arg-count 2 syntax) + (tree-bind (reg dst) asm.(parse-args me syntax '(r l)) + asm.(put-insn me.code (ash dst -16) (logtrunc dst 16)) + asm.(put-pair 0 reg))) + + (:method backpatch (me asm at dst) + asm.(put-insn me.code (ash dst -16) (logtrunc dst 16))) + + (:method dis (me asm high16 low16) + (let ((dst (logior (ash high16 16) low16)) + (reg (cadr asm.(get-pair)))) + ^(,me.symbol ,(operand-to-sym reg) ,dst)))) + +(defopcode op-ifq ifq auto + (:method asm (me asm syntax) + me.(chk-arg-count 3 syntax) + (tree-bind (lreg rreg dst) asm.(parse-args me syntax '(r r l)) + asm.(put-insn me.code (ash dst -16) (logtrunc dst 16)) + asm.(put-pair lreg rreg))) + + (:method backpatch (me asm at dst) + asm.(put-insn me.code (ash dst -16) (logtrunc dst 16))) + + (:method dis (me asm high16 low16) + (let ((dst (logior (ash high16 16) low16))) + (tree-bind (lreg rreg) asm.(get-pair) + ^(,me.symbol ,(operand-to-sym lreg) ,(operand-to-sym rreg) ,dst))))) + +(defopcode-derived op-ifql ifql auto op-ifq) + +(defopcode op-swtch swtch auto + (:method asm (me asm syntax) + me.(chk-arg-count-min 1 syntax) + (let* ((args asm.(parse-args me syntax '(r))) + (lbls (cddr syntax)) + (tblsz (len lbls))) + asm.(put-insn me.code tblsz (car args)) + (while lbls + (let ((x asm.(lookup-label (pop lbls) %backpatch-low16%)) + (y (if lbls + asm.(lookup-label (pop lbls) %backpatch-high16%) + 0))) + asm.(put-pair y x))))) + + (:method dis (me asm tblsz switch-val) + (build + (add me.symbol) + (add (operand-to-sym switch-val)) + (while (> tblsz 0) + (dec tblsz 2) + (tree-bind (y x) asm.(get-pair) + (add x) + (unless (minusp tblsz) + (add y))))))) + +(defopcode-derived op-uwprot uwprot auto op-jmp) + +(defopcode op-block block auto + (:method asm (me asm syntax) + me.(chk-arg-count 3 syntax) + (tree-bind (outreg blname exitpt) asm.(parse-args me syntax '(d r l)) + asm.(put-insn me.code (ash exitpt -16) (logtrunc exitpt 16)) + asm.(put-pair outreg blname))) + + (:method backpatch (me asm at exitpt) + asm.(put-insn me.code (ash exitpt -16) (logtrunc exitpt 16))) + + (:method dis (me asm high16 low16) + (let ((exitpt (logior (ash high16 16) low16))) + (tree-bind (outreg blname) asm.(get-pair) + ^(,me.symbol ,(operand-to-sym outreg) ,(operand-to-sym blname) + ,exitpt))))) + +(defopcode op-retsr retsr auto + (:method asm (me asm syntax) + me.(chk-arg-count 2 syntax) + (tree-bind (name reg) asm.(parse-args me syntax '(rs r)) + asm.(put-insn me.code (enc-small-op name) reg))) + + (:method dis (me asm name reg) + ^(,me.symbol ,(small-op-to-sym name) ,(operand-to-sym reg)))) + +(defopcode op-retrs retrs auto + (:method asm (me asm syntax) + me.(chk-arg-count 2 syntax) + (tree-bind (name reg) asm.(parse-args me syntax '(r rs)) + asm.(put-insn me.code (enc-small-op reg) name))) + + (:method dis (me asm reg name) + ^(,me.symbol ,(operand-to-sym name) ,(small-op-to-sym reg)))) + +(defopcode op-retrr retrr auto + (:method asm (me asm syntax) + me.(chk-arg-count 2 syntax) + (tree-bind (name reg) asm.(parse-args me syntax '(r r)) + asm.(put-insn me.code 0 reg) + asm.(put-pair 0 name))) + + (:method dis (me asm extension reg) + (let ((name (cadr asm.(get-pair)))) + ^(,me.symbol ,(operand-to-sym name) ,(operand-to-sym reg))))) + +(defopcode op-ret-pseudo ret nil + (:method asm (me asm syntax) + me.(chk-arg-count 2 syntax) + (tree-bind (name reg) asm.(parse-args me syntax '(r r)) + (let ((real [%oc-hash% (cond + ((small-op-p name) 'retsr) + ((small-op-p reg) 'retrs) + (t 'retrr))])) + real.(asm asm syntax))))) + +(defopcode-derived op-abscsr abscsr auto op-retsr) + +(defopcode op-catch catch auto + (:method asm (me asm syntax) + me.(chk-arg-count 5 syntax) + (tree-bind (sym args catch-syms desc dst) + asm.(parse-args me syntax '(d d r r l)) + asm.(put-insn me.code (ash dst -16) (logtrunc dst 16)) + asm.(put-pair sym args) + asm.(put-pair desc catch-syms))) + + (:method backpatch (me asm at dst) + asm.(put-insn me.code (ash dst -16) (logtrunc dst 16))) + + (:method dis (me asm high16 low16) + (let ((dst (logior (ash high16 16) low16))) + (tree-bind (sym args) asm.(get-pair) + (tree-bind (desc catch-syms) asm.(get-pair) + ^(,me.symbol ,(operand-to-sym sym) ,(operand-to-sym args) + ,(operand-to-sym catch-syms) + ,(operand-to-sym desc) ,dst)))))) + +(defopcode op-handle handle auto + (:method asm (me asm syntax) + me.(chk-arg-count 2 syntax) + (tree-bind (fun handle-syms) asm.(parse-args me syntax '(r r)) + asm.(put-insn me.code 0 fun) + asm.(put-pair fun handle-syms))) + + (:method dis (me asm extension fun) + (let ((handle-syms (cadr asm.(get-pair)))) + ^(,me.symbol ,(operand-to-sym fun) ,(operand-to-sym handle-syms))))) + +(defopcode op-getv getv auto + (:method asm (me asm syntax) + me.(chk-arg-count 2 syntax) + (tree-bind (reg name) asm.(parse-args me syntax '(d r)) + (unless (small-op-p name) + asm.(asm-one ^(mov (t 1) ,(operand-to-exp name))) + (set name 1)) + asm.(put-insn me.code (enc-small-op name) reg))) + (:method dis (me asm name reg) + ^(,me.symbol ,(operand-to-sym reg) ,(small-op-to-sym name)))) + +(defopcode-derived op-oldgetf oldgetf auto op-getv) + +(defopcode-derived op-getl1 getl1 auto op-getv) + +(defopcode-derived op-getvb getvb auto op-getv) + +(defopcode-derived op-getfb getfb auto op-getv) + +(defopcode-derived op-getl1b getl1b auto op-getv) + +(defopcode op-setv setv auto + (:method asm (me asm syntax) + me.(chk-arg-count 2 syntax) + (tree-bind (reg name) asm.(parse-args me syntax '(r r)) + (unless (small-op-p name) + asm.(asm-one ^(mov (t 1) ,(operand-to-exp name))) + (set name 1)) + asm.(put-insn me.code (enc-small-op name) reg))) + (:method dis (me asm name reg) + ^(,me.symbol ,(operand-to-sym reg) ,(small-op-to-sym name)))) + +(defopcode-derived op-setl1 setl1 auto op-setv) + +(defopcode-derived op-bindv bindv auto op-setv) + +(defopcode op-close close auto + (:method asm (me asm syntax) + me.(chk-arg-count-min 6 syntax) + (let* ((syn-pat (repeat '(d) (- (length syntax) 7)))) + (tree-bind (reg frsize ntreg dst fix req vari . regs) + asm.(parse-args me syntax ^(d n n l n n o,*syn-pat)) + (unless (<= 0 frsize %lev-size%) + me.(synerr "frame size must be 0 to ~a" %lev-size%)) + asm.(put-insn me.code (ash dst -16) (logtrunc dst 16)) + asm.(put-pair (logior (ash (if vari 1 0) %lev-bits%) frsize) reg) + asm.(put-pair req fix) + asm.(put-pair 0 ntreg) + (unless (eql fix (- (len regs) (if vari 1 0))) + me.(synerr "wrong number of registers")) + (while regs + (let ((x (pop regs)) + (y (or (pop regs) 0))) + asm.(put-pair y x)))))) + + (:method backpatch (me asm at dst) + asm.(put-insn me.code (ash dst -16) (logtrunc dst 16))) + + (:method dis (me asm high16 low16) + (let ((dst (logior (ash high16 16) low16))) + (tree-bind (vari-frsize reg) asm.(get-pair) + (let ((vari (bit vari-frsize %lev-bits%))) + (tree-bind (req fix) asm.(get-pair) + (tree-bind (ign ntreg) asm.(get-pair) + (build + (add me.symbol (operand-to-sym reg) + (logtrunc vari-frsize %lev-bits%) + ntreg dst fix req vari) + (when vari + (inc fix)) + (while (> fix 0) + (dec fix 2) + (tree-bind (y x) asm.(get-pair) + (add (operand-to-sym x)) + (unless (minusp fix) + (add (operand-to-sym y))))))))))))) + +(defopcode op-getlx getlx auto + (:method asm (me asm syntax) + me.(chk-arg-count 2 syntax) + (tree-bind (dst idx) asm.(parse-args me syntax '(d n)) + (cond + ((small-op-p dst) + asm.(put-insn me.code (enc-small-op dst) idx)) + (t asm.(put-insn me.code (enc-small-op 1) idx) + asm.(asm-one ^(mov ,(operand-to-exp dst) t1)))))) + (:method dis (me asm dst idx) + ^(,me.symbol ,(small-op-to-sym dst) ,idx))) + +(defopcode op-setlx setlx auto + (:method asm (me asm syntax) + me.(chk-arg-count 2 syntax) + (tree-bind (src idx) asm.(parse-args me syntax '(r n)) + (cond + ((small-op-p src) + asm.(put-insn me.code (enc-small-op src) idx)) + (t asm.(asm-one ^(mov t1 ,(operand-to-exp src))) + asm.(put-insn me.code (enc-small-op 1) idx))))) + (:method dis (me asm src idx) + ^(,me.symbol ,(small-op-to-sym src) ,idx))) + +(defopcode-derived op-getf getf auto op-getlx) + +(defun disassemble-cdf (code data funv *stdout*) + (let ((asm (new assembler buf code))) + (put-line "data:") + (mapdo (do format t "~5d: ~s\n" @1 @2) (range 0) data) + (put-line "syms:") + (mapdo (do format t "~5d: ~s\n" @1 @2) (range 0) funv) + (put-line "code:") + (let ((ninsn asm.(dis-listing))) + (put-line "instruction count:") + (format t "~5d\n" ninsn)))) + +(defun disassemble (obj : (stream *stdout*)) + (symacrolet ((self 'vm-disassemble-obj)) + (typecase obj + (vm-desc (disassemble-cdf (vm-desc-bytecode obj) + (vm-desc-datavec obj) + (vm-desc-symvec obj) + stream)) + (fun (unless (vm-fun-p obj) + (error "~s: not a vm function: ~s" self obj)) + (let* ((clo (func-get-env obj)) + (desc (sys:vm-closure-desc clo)) + (ip (sys:vm-closure-entry clo))) + (disassemble desc stream) + (put-line "entry point:") + (format stream "~5d\n" ip))) + (t (iflet ((fun (symbol-function obj))) + (disassemble fun stream) + (error "~s: not a compiled object: ~s" self obj)))) + obj)) diff --git a/stdlib/awk.tl b/stdlib/awk.tl new file mode 100644 index 00000000..f94d6b9a --- /dev/null +++ b/stdlib/awk.tl @@ -0,0 +1,518 @@ +;; Copyright 2016-2021 +;; Kaz Kylheku <kaz@kylheku.com> +;; Vancouver, Canada +;; 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 HOLDER 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. + +(load "conv") + +(defstruct sys:awk-state () + (rs "\n") krs + fs ft kfs + fw fw-prev fw-ranges + (ofs " ") + (ors "\n") + (inputs) + (output *stdout*) + (file-num 0) + file-name + (file-rec-num 0) + (rec-num 0) + rec orig-rec fields nf + rng-vec (rng-n 0) + par-mode par-mode-fs par-mode-prev-fs + (streams (hash :equal-based)) + (:fini (self) + (dohash (k v self.streams) + (close-stream v))) + (:postinit (self) + (set self.inputs (or self.inputs (zap *args*) (list *stdin*))) + (if (plusp self.rng-n) + (set self.rng-vec (vector self.rng-n))) + (unless (streamp self.output) + (let ((stream (open-file self.output "w"))) + (set [self.streams ^(:outf ,self.output)] stream + self.output stream))))) + +(defstruct sys:awk-compile-time () + inputs output name lets + begin-file-actions end-file-actions + begin-actions end-actions + cond-actions + (nranges 0) + (rng-rec-temp (gensym)) + (rng-vec-temp (gensym)) + rng-expr-temps + rng-exprs + outer-env) + +(defmeth sys:awk-state rec-to-f (self) + (cond + (self.fw + (unless (eq self.fw-prev self.fw) + (let ((ranges (reduce-left + (tb ((list . sum) item) + (let ((ns (+ sum item))) + ^((,*list #R(,sum ,ns)) . ,ns))) + self.fw '(nil . 0)))) + (set self.fw-prev self.fw + self.fw-ranges (car ranges)))) + (let ((i 0) end + (l (length self.rec))) + (set self.fields + (build (each ((r self.fw-ranges)) + (set end (to r)) + (if (>= (from r) l) + (return nil)) + (add [self.rec r]) + (inc i)) + (if (< end l) + (add [self.rec end..:]))) + self.nf i))) + (self.fs + (when self.ft + (awk-error "both fs and ft set")) + (if (and (not self.kfs) (equal self.rec "")) + (set self.fields nil + self.nf 0) + (let ((eff-fs (if self.par-mode + (if (equal self.fs self.par-mode-prev-fs) + self.par-mode-fs + (set self.par-mode-prev-fs self.fs + self.par-mode-fs + (regex-compile ^(or ,(if (regexp self.fs) + (regex-source self.fs) + self.fs) + "\n")))) + self.fs))) + (set self.fields (split-str self.rec eff-fs self.kfs) + self.nf (length self.fields))))) + (self.ft + (set self.fields (tok-str self.rec self.ft self.kfs) + self.nf (length self.fields))) + ((set self.fields (tok-str self.rec #/[^ \t\n]+/ self.kfs) + self.nf (length self.fields))))) + +(defmeth sys:awk-state f-to-rec (self) + (set self.rec `@{self.fields self.ofs}`)) + +(defmeth sys:awk-state nf-to-f (self) + (set self.fields (take self.nf (append self.fields (repeat '(""))))) + self.(f-to-rec)) + +(defmeth sys:awk-state loop (aws func beg-file-func end-file-func) + (whilet ((in (pop aws.inputs))) + (block :awk-file + (inc aws.file-num) + (set aws.file-name (if (streamp in) + (stream-get-prop in :name) + in)) + (when beg-file-func + [beg-file-func aws]) + (let* ((*stdin* (cond + ((streamp in) in) + ((listp in) (make-strlist-input-stream in)) + ((open-file in)))) + (noted-rs (not aws.rs)) + (noted-krs (not aws.krs)) + (cached-rr nil)) + (flet ((get-rec-reader (*stdin*) + (cond + ((and (equal noted-rs aws.rs) (eq noted-krs aws.krs)) + cached-rr) + (t + (set noted-rs aws.rs noted-krs aws.krs) + (set cached-rr + (cond + ((and (equal aws.rs "\n") (not aws.krs)) + (set aws.par-mode nil) + (lambda () (get-line *stdin*))) + ((null aws.rs) + (set aws.par-mode t) + (let ((rin (record-adapter #/\n[ \n\t]*\n/)) + (flag t)) + (lambda () + (let ((r (get-line rin))) + (cond + (flag + (set flag nil) + (if (equal r "") + (get-line rin) + r)) + (t r)))))) + (t + (set aws.par-mode nil) + (let ((rin (record-adapter + (if (regexp aws.rs) aws.rs + (regex-compile ^(compound, aws.rs))) + *stdin* + aws.krs))) + (lambda () (get-line rin)))))))))) + (set aws.file-rec-num 0) + (unwind-protect + (whilet ((rr (get-rec-reader *stdin*)) + (rec (call rr))) + (set aws.rec rec aws.orig-rec rec) + (inc aws.rec-num) + (inc aws.file-rec-num) + (while* (eq :awk-again (block* :awk-rec [func aws])) + aws.(rec-to-f))) + (when end-file-func + [end-file-func aws]))))))) + +(defmeth sys:awk-state prn (self . args) + (cond + (args (for ((a args) next) (a) ((set a next)) + (put-string `@(car a)`) + (put-string (if (set next (cdr a)) self.ofs self.ors)))) + (t (put-string self.rec) + (put-string self.ors)))) + +(defmeth sys:awk-state ensure-stream (self kind path mode) + (hash-update-1 self.streams + ^(,kind ,path) + (do or @1 (caseq kind + ((:inf :outf) (open-file path mode)) + ((:inp :outp) (open-command path mode)))) + nil)) + +(defmeth sys:awk-state close-or-flush (self stream kind path val) + (cond + ((eq val :close) (whenlet ((s (del [self.streams ^(,kind ,path)]))) + (close-stream s))) + ((memq kind '(:outf outp)) (flush-stream stream) val) + (val))) + +(defun awk-error (msg . args) + (throwf 'eval-error `~s: @msg` 'awk . args)) + +(defun sys:awk-test (val rec) + (caseq (typeof val) + ((regex fun) (call val rec)) + (t val))) + +(defun sys:awk%--rng (rng-vec idx from-val to-val) + (placelet ((state (vecref rng-vec idx))) + (caseq state + (nil (cond + ((and from-val to-val) nil) + (from-val (set state :mid) nil))) + (:mid (cond + (to-val (set state nil) (not from-val)) + (from-val nil) + (t (set state t)))) + (t (cond + (to-val (set (vecref rng-vec idx) nil) t) + (t t)))))) + +(defun sys:awk%--rng- (rng-vec idx from-val to-val) + (placelet ((state (vecref rng-vec idx))) + (caseq state + (nil (cond + ((and from-val to-val) nil) + (from-val (set state :mid) nil))) + (:mid (cond + (to-val (set state nil)) + (from-val nil) + (t (set state t)))) + (t (cond + (to-val (set (vecref rng-vec idx) nil)) + (t t)))))) + +(defun sys:awk%rng+ (rng-vec idx from-val to-val) + (placelet ((state (vecref rng-vec idx))) + (caseq state + (nil (cond + ((and from-val to-val) (set state :end) t) + (from-val (set state t)))) + (:end (cond + (to-val t) + (from-val (set state t)) + (t (set state nil) nil))) + (t (cond + (to-val (set state :end) t) + (t t)))))) + +(defun sys:awk%-rng+ (rng-vec idx from-val to-val) + (placelet ((state (vecref rng-vec idx))) + (caseq state + (nil (cond + ((and from-val to-val) (set state :end) nil) + (from-val (set state t) nil))) + (:end (cond + (to-val t) + (from-val (set state t) nil) + (t (set state nil) nil))) + (t (cond + (to-val (set state :end) t) + (t t)))))) + +(defun sys:awk%--rng+ (rng-vec idx from-val to-val) + (placelet ((state (vecref rng-vec idx))) + (caseq state + (nil (cond + ((and from-val to-val) (set state :mid) nil) + (from-val (set state :mid) nil))) + (:mid (cond + (to-val (set state :end) (not from-val)) + (from-val nil) + (t (set state t)))) + (:end (cond + (to-val t) + (from-val (set state t) nil) + (t (set state nil) nil))) + (t (cond + (to-val (set state :end) t) + (t t)))))) + +(defmacro sys:awk-redir (aws-sym stream-var kind mode path body) + (with-gensyms (res-sym) + ^(let ((,res-sym ,path) + (,stream-var (qref ,aws-sym (ensure-stream ,kind ,res-sym ,mode)))) + ,(if body + ^(qref ,aws-sym (close-or-flush ,stream-var ,kind ,res-sym + (progn ,*body))) + stream-var)))) + +(defun sys:awk-expander (outer-env clauses) + (let ((awc (new sys:awk-compile-time outer-env outer-env))) + (each ((cl clauses)) + (tree-case cl + ((pattern . actions) (caseql pattern + (:inputs + (when awc.inputs + (awk-error "duplicate :input clauses")) + (set awc.inputs actions)) + (:output + (when awc.output + (awk-error "duplicate :output clauses")) + (when (or (atom actions) (cdr actions)) + (awk-error "bad :output syntax")) + (set awc.output (car actions))) + (:name + (when awc.name + (awk-error "duplicate :name clauses")) + (when (or (atom actions) (cdr actions)) + (awk-error "bad :name syntax")) + (set awc.name (car actions))) + (:let (push actions awc.lets)) + (:begin (push actions awc.begin-actions)) + (:set (push ^((set ,*actions)) awc.begin-actions)) + (:end (push actions awc.end-actions)) + (:begin-file (push actions awc.begin-file-actions)) + (:set-file (push ^((set ,*actions)) awc.begin-actions)) + (:end-file (push actions awc.end-file-actions)) + (t (push (if actions + cl + ^(,pattern (prn))) + awc.cond-actions)))) + (junk (awk-error "bad clause syntax ~s" junk)))) + (set awc.lets [apply append (nreverse awc.lets)] + awc.begin-actions [apply append (nreverse awc.begin-actions)] + awc.end-actions [apply append (nreverse awc.end-actions)] + awc.begin-file-actions [apply append (nreverse awc.begin-file-actions)] + awc.end-file-actions [apply append (nreverse awc.end-file-actions)] + awc.cond-actions (nreverse awc.cond-actions)) + awc)) + +(defun sys:awk-code-move-check (awc aws-sym mainform subform + suspicious-vars kind) + (when suspicious-vars + (compile-warning mainform "~!form ~s\n\ + is moved out of the apparent scope\n\ + and thus cannot refer to ~a ~s" + subform kind suspicious-vars))) + +(defmacro sys:awk-mac-let (awc aws-sym . body) + ^(symacrolet ((rec (usr:rslot ,aws-sym 'rec 'rec-to-f)) + (orec (usr:rslot ,aws-sym 'orig-rec 'rec-to-f)) + (f (usr:rslot ,aws-sym 'fields 'f-to-rec)) + (nf (usr:rslot ,aws-sym 'nf 'nf-to-f)) + (nr (qref ,aws-sym rec-num)) + (fnr (qref ,aws-sym file-rec-num)) + (arg (qref ,aws-sym file-num)) + (fname (qref ,aws-sym file-name)) + (rs (qref ,aws-sym rs)) + (krs (qref ,aws-sym krs)) + (fs (qref ,aws-sym fs)) + (ft (qref ,aws-sym ft)) + (fw (qref ,aws-sym fw)) + (kfs (qref ,aws-sym kfs)) + (ofs (qref ,aws-sym ofs)) + (ors (qref ,aws-sym ors))) + (macrolet ((next () '(return-from :awk-rec)) + (again () '(return-from :awk-rec :awk-again)) + (next-file () '(return-from :awk-file)) + (sys:rng-if (form from-expr to-expr :env e) + ^(sys:rng-impl ,form + (sys:awk-test ,from-expr ,(qref ,awc rng-rec-temp)) + (sys:awk-test ,to-expr ,(qref ,awc rng-rec-temp)))) + (sys:rng-impl (form from-expr to-expr :env e) + (let* ((style (car form)) + (ix (pinc (qref ,awc nranges))) + (rng-temp (gensym)) + (from-expr-ex (expand from-expr e)) + (from-expr-val (gensym)) + (to-expr-ex (expand to-expr e)) + (to-expr-val (gensym)) + (vec-temp (qref ,awc rng-vec-temp)) + (emul-broken (and (plusp sys:compat) (<= sys:compat 177))) + (rng-fun + (caseq style + (--rng 'sys:awk%--rng) + (--rng- 'sys:awk%--rng-) + (rng+ 'sys:awk%rng+) + (-rng+ 'sys:awk%-rng+) + (--rng+ 'sys:awk%--rng+))) + (state (gensym))) + (tree-bind ((from-expr-ex fe-fv fe-ff fe-ev fe-ef) + (to-expr-ex te-fv te-ff te-ev te-ef) + (from-expr-orig to-expr-orig)) + (list + (expand-with-free-refs from-expr e ,awc.outer-env) + (expand-with-free-refs to-expr e ,awc.outer-env) + (list (cadr form) (caddr form))) + (sys:awk-code-move-check ,awc ',aws-sym + form from-expr-orig + (diff fe-ev fe-fv) + 'variables) + (sys:awk-code-move-check ,awc ',aws-sym + form from-expr-orig + (diff fe-ef fe-ff) + 'functions) + (sys:awk-code-move-check ,awc ',aws-sym + form to-expr-orig + (diff te-ev te-fv) + 'variables) + (sys:awk-code-move-check ,awc ',aws-sym + form to-expr-orig + (diff te-ef te-ff) + 'functions) + (push rng-temp (qref ,awc rng-expr-temps)) + (caseq style + ((--rng --rng- rng+ -rng+ --rng+) + (push + ^(,rng-fun ,vec-temp ,ix ,from-expr-ex ,to-expr-ex) + (qref ,awc rng-exprs))) + (t (push + ^(placelet ((,state (vecref ,(qref ,awc rng-vec-temp) ,ix))) + (let ((,to-expr-val ,to-expr-ex)) + (caseq ,state + (nil (let ((,from-expr-val ,from-expr-ex)) + (cond + ((and ,from-expr-val ,to-expr-val) + ,(if (and (eq style 'rng) (not emul-broken)) t)) + (,from-expr-val (set ,state t) + ,(if (memq style '(rng rng-)) t))))) + (t (cond + (,to-expr-val (set ,state nil) + ,(if (memq style '(rng -rng)) t)) + (t t)))))) + (qref ,awc rng-exprs)))) + rng-temp))) + (rng (:form form from-expr to-expr) ^(sys:rng-if ,form ,from-expr ,to-expr)) + (-rng (:form form from-expr to-expr) ^(sys:rng-if ,form ,from-expr ,to-expr)) + (rng- (:form form from-expr to-expr) ^(sys:rng-if ,form ,from-expr ,to-expr)) + (-rng- (:form form from-expr to-expr) ^(sys:rng-if ,form ,from-expr ,to-expr)) + (--rng (:form form from-expr to-expr) ^(sys:rng-if ,form ,from-expr ,to-expr)) + (--rng- (:form form from-expr to-expr) ^(sys:rng-if ,form ,from-expr ,to-expr)) + (rng+ (:form form from-expr to-expr) ^(sys:rng-if ,form ,from-expr ,to-expr)) + (-rng+ (:form form from-expr to-expr) ^(sys:rng-if ,form ,from-expr ,to-expr)) + (--rng+ (:form form from-expr to-expr) ^(sys:rng-if ,form ,from-expr ,to-expr)) + (ff (. opip-args) + ^(symacrolet ((f (usr:rslot ,',aws-sym 'fields 'f-to-rec))) + (set f [(opip ,*opip-args) f]))) + (mf (. opip-args) + ^(symacrolet ((f (usr:rslot ,',aws-sym 'fields 'f-to-rec))) + (set f (mapcar (opip ,*opip-args) f)))) + (fconv (. conv-args) + ^(set f (sys:conv (,*conv-args) f))) + (-> (path . body) + ^(sys:awk-redir ,',aws-sym *stdout* :outf "w" ,path ,body)) + (->> (path . body) + ^(sys:awk-redir ,',aws-sym *stdout* :apf "a" ,path ,body)) + (<- (path . body) + ^(sys:awk-redir ,',aws-sym *stdin* :inf "r" ,path ,body)) + (!> (path . body) + ^(sys:awk-redir ,',aws-sym *stdout* :outp "w" ,path ,body)) + (<! (path . body) + ^(sys:awk-redir ,',aws-sym *stdin* :inp "r" ,path ,body))) + ,*body))) + +(defmacro sys:awk-fun-let (aws-sym . body) + ^(flet ((prn (. args) + (qref ,aws-sym (prn . args)))) + ,*body)) + +(defun sys:awk-fun-shadowing-env (up-env) + (make-env nil '((prn . sys:special)) up-env)) + +(defmacro awk (:env outer-env . clauses) + (let ((awc (sys:awk-expander outer-env clauses))) + (with-gensyms (aws-sym awk-begf-fun awk-fun awk-endf-fun awk-retval) + (let* ((p-actions-xform-unex (mapcar (aret ^(when (sys:awk-test ,@1 rec) + ,*@rest)) + awc.cond-actions)) + (p-actions-xform (expand + ^(sys:awk-mac-let ,awc ,aws-sym + ,*p-actions-xform-unex) + (sys:awk-fun-shadowing-env outer-env)))) + ^(block ,(or awc.name 'awk) + (let* (,*awc.lets ,awk-retval + (,aws-sym (new sys:awk-state + ,*(if awc.inputs ^(inputs (list ,*awc.inputs))) + ,*(if awc.output ^(output ,awc.output)) + rng-n (macro-time (qref ,awc nranges))))) + (sys:awk-mac-let ,awc ,aws-sym + (sys:awk-fun-let ,aws-sym + (let* (,*(if awc.output + ^((*stdout* (qref ,aws-sym output)))) + ,*(if (and awc.cond-actions awc.begin-file-actions) + ^((,awk-begf-fun (lambda (,aws-sym) + ,*awc.begin-file-actions)))) + ,*(if (and awc.cond-actions awc.end-file-actions) + ^((,awk-endf-fun (lambda (,aws-sym) + ,*awc.end-file-actions)))) + ,*(if (or awc.cond-actions awc.begin-file-actions + awc.end-file-actions awc.end-actions) + ^((,awk-fun (lambda (,aws-sym) + ,(if awc.rng-exprs + ^(let* ((,awc.rng-rec-temp rec) + (,awc.rng-vec-temp (qref ,aws-sym rng-vec)) + ,*(nreverse + (zip awc.rng-expr-temps + awc.rng-exprs))) + ,p-actions-xform) + p-actions-xform)))))) + ,*awc.begin-actions + (unwind-protect + ,(if (or awc.cond-actions awc.begin-file-actions + awc.end-file-actions awc.end-actions) + ^(qref ,aws-sym (loop ,awk-fun + ,(if awc.begin-file-actions + awk-begf-fun) + ,(if awc.end-file-actions + awk-endf-fun)))) + (set ,awk-retval (progn ,*awc.end-actions)) + (call-finalizers ,aws-sym)) + ,awk-retval))))))))) diff --git a/stdlib/build.tl b/stdlib/build.tl new file mode 100644 index 00000000..1b27d17b --- /dev/null +++ b/stdlib/build.tl @@ -0,0 +1,141 @@ +;; Copyright 2016-2021 +;; Kaz Kylheku <kaz@kylheku.com> +;; Vancouver, Canada +;; 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 HOLDER 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. + +(defstruct list-builder () + head tail + + (:postinit (bc) + (set bc.head (cons nil bc.head) + bc.tail bc.head)) + + (:method add (self . items) + (let ((st self.tail)) + (rplacd st (append (cdr st) nil)) + (let ((tl (last st))) + (usr:rplacd tl (append (cdr tl) items)) + (set self.tail tl))) + self) + + (:method add* (self . items) + (let ((h self.head)) + (usr:rplacd h (append items (cdr h)))) + self) + + (:method pend (self . lists) + (when lists + (let ((st self.tail)) + (rplacd st (append (cdr st) nil)) + (let* ((tl (last st)) + (cp (tailp tl (car (last lists)))) + (nl [apply append lists])) + (usr:rplacd tl (append (cdr tl) (if cp (copy-list nl) nl))) + (set self.tail tl))) + self)) + + (:method pend* (self . lists) + (let* ((h self.head) + (pf [apply append (append lists (list (cdr h)))])) + (usr:rplacd h pf) + (set self.tail h)) + self) + + (:method ncon (self . lists) + (when lists + (let* ((tl (last self.tail)) + (nl [apply nconc lists])) + (usr:rplacd tl (nconc (cdr tl) nl)) + (set self.tail tl)) + self)) + + (:method ncon* (self . lists) + (let* ((h self.head) + (pf [apply nconc (append lists (list (cdr h)))])) + (usr:rplacd h pf) + (if (eq self.tail h) + (set self.tail pf))) + self) + + (:method get (self) + (cdr self.head)) + + (:method del (self) + (whenlet ((hd self.head) + (chd (cdr self.head))) + (when (eq self.tail chd) + (set self.tail hd)) + (prog1 (car chd) (usr:rplacd hd (cdr chd))))) + + (:method del* (self) + (whenlet ((hd self.head) + (chd (cdr self.head))) + (if (cdr chd) + (let* ((tl self.tail) + (l2 (nthlast 2 tl))) + (if (cdr l2) + (prog1 + (cadr l2) + (usr:rplacd l2 nil)) + (let* ((l10 (nthlast 10 hd)) + (l2 (nthlast 2 l10))) + (prog1 + (cadr l2) + (usr:rplacd l2 nil) + (set self.tail l10))))) + (prog1 + (car chd) + (usr:rplacd hd nil) + (set self.tail hd)))))) + +(defun sys:list-builder-flets (lb-form) + (nconc + (collect-each ((op '(add add* pend pend* ncon ncon*))) + ^(,op (. args) + (qref ,lb-form (,op . args)) + nil)) + ^((get () + (qref ,lb-form (get))) + (del* () + (qref ,lb-form (del*))) + (do-del () + (qref ,lb-form (del)))))) + +(defun build-list (: init) + (new list-builder head init)) + +(defun sys:build-expander (forms return-get) + (with-gensyms (name) + ^(let ((,name (new list-builder))) + (flet ,(sys:list-builder-flets name) + (macrolet ((del (:form f : (expr nil expr-p)) + (if expr-p f '(do-del)))) + ,*forms + ,*(if return-get ^((qref ,name (get))))))))) + +(defmacro build (. forms) + (sys:build-expander forms t)) + +(defmacro buildn (. forms) + (sys:build-expander forms nil)) diff --git a/stdlib/cadr.tl b/stdlib/cadr.tl new file mode 100644 index 00000000..6648b145 --- /dev/null +++ b/stdlib/cadr.tl @@ -0,0 +1,1107 @@ +;; This file is generated by gencadr.txr + +;; Copyright 2015-2021 +;; Kaz Kylheku <kaz@kylheku.com> +;; Vancouver, Canada +;; 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 HOLDER 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. + +(defplace (caar cell) body + (getter setter + (with-gensyms (cell-sym) + ^(let ((,cell-sym (car ,cell))) + (macrolet ((,getter () ^(car ,',cell-sym)) + (,setter (val) ^(sys:rplaca ,',cell-sym ,val))) + ,body)))) + (ssetter + ^(macrolet ((,ssetter (val) ^(sys:rplaca (car ,',cell) ,val))) + ,body)) + (deleter + ^(macrolet ((,deleter () + (with-gensyms (tmp) + (with-update-expander (cgetter csetter) '(car ,cell) nil + ^(let ((,tmp (,cgetter))) + (prog1 (car ,tmp) (,csetter (cdr ,tmp)))))))) + ,body))) + +(defplace (cadr cell) body + (getter setter + (with-gensyms (cell-sym) + ^(let ((,cell-sym (cdr ,cell))) + (macrolet ((,getter () ^(car ,',cell-sym)) + (,setter (val) ^(sys:rplaca ,',cell-sym ,val))) + ,body)))) + (ssetter + ^(macrolet ((,ssetter (val) ^(sys:rplaca (cdr ,',cell) ,val))) + ,body)) + (deleter + ^(macrolet ((,deleter () + (with-gensyms (tmp) + (with-update-expander (cgetter csetter) '(cdr ,cell) nil + ^(let ((,tmp (,cgetter))) + (prog1 (car ,tmp) (,csetter (cdr ,tmp)))))))) + ,body))) + +(defplace (cdar cell) body + (getter setter + (with-gensyms (cell-sym) + ^(let ((,cell-sym (car ,cell))) + (macrolet ((,getter () ^(cdr ,',cell-sym)) + (,setter (val) ^(sys:rplacd ,',cell-sym ,val))) + ,body)))) + (ssetter + ^(macrolet ((,ssetter (val) ^(sys:rplacd (car ,',cell) ,val))) + ,body)) + (deleter + ^(macrolet ((,deleter () + (with-gensyms (tmp) + (with-update-expander (cgetter csetter) '(car ,cell) nil + ^(let ((,tmp (,cgetter))) + (prog1 (cdr ,tmp) (,csetter (car ,tmp)))))))) + ,body))) + +(defplace (cddr cell) body + (getter setter + (with-gensyms (cell-sym) + ^(let ((,cell-sym (cdr ,cell))) + (macrolet ((,getter () ^(cdr ,',cell-sym)) + (,setter (val) ^(sys:rplacd ,',cell-sym ,val))) + ,body)))) + (ssetter + ^(macrolet ((,ssetter (val) ^(sys:rplacd (cdr ,',cell) ,val))) + ,body)) + (deleter + ^(macrolet ((,deleter () + (with-gensyms (tmp) + (with-update-expander (cgetter csetter) '(cdr ,cell) nil + ^(let ((,tmp (,cgetter))) + (prog1 (cdr ,tmp) (,csetter (car ,tmp)))))))) + ,body))) + +(defplace (caaar cell) body + (getter setter + (with-gensyms (cell-sym) + ^(let ((,cell-sym (caar ,cell))) + (macrolet ((,getter () ^(car ,',cell-sym)) + (,setter (val) ^(sys:rplaca ,',cell-sym ,val))) + ,body)))) + (ssetter + ^(macrolet ((,ssetter (val) ^(sys:rplaca (caar ,',cell) ,val))) + ,body)) + (deleter + ^(macrolet ((,deleter () + (with-gensyms (tmp) + (with-update-expander (cgetter csetter) '(caar ,cell) nil + ^(let ((,tmp (,cgetter))) + (prog1 (car ,tmp) (,csetter (cdr ,tmp)))))))) + ,body))) + +(defplace (caadr cell) body + (getter setter + (with-gensyms (cell-sym) + ^(let ((,cell-sym (cadr ,cell))) + (macrolet ((,getter () ^(car ,',cell-sym)) + (,setter (val) ^(sys:rplaca ,',cell-sym ,val))) + ,body)))) + (ssetter + ^(macrolet ((,ssetter (val) ^(sys:rplaca (cadr ,',cell) ,val))) + ,body)) + (deleter + ^(macrolet ((,deleter () + (with-gensyms (tmp) + (with-update-expander (cgetter csetter) '(cadr ,cell) nil + ^(let ((,tmp (,cgetter))) + (prog1 (car ,tmp) (,csetter (cdr ,tmp)))))))) + ,body))) + +(defplace (cadar cell) body + (getter setter + (with-gensyms (cell-sym) + ^(let ((,cell-sym (cdar ,cell))) + (macrolet ((,getter () ^(car ,',cell-sym)) + (,setter (val) ^(sys:rplaca ,',cell-sym ,val))) + ,body)))) + (ssetter + ^(macrolet ((,ssetter (val) ^(sys:rplaca (cdar ,',cell) ,val))) + ,body)) + (deleter + ^(macrolet ((,deleter () + (with-gensyms (tmp) + (with-update-expander (cgetter csetter) '(cdar ,cell) nil + ^(let ((,tmp (,cgetter))) + (prog1 (car ,tmp) (,csetter (cdr ,tmp)))))))) + ,body))) + +(defplace (caddr cell) body + (getter setter + (with-gensyms (cell-sym) + ^(let ((,cell-sym (cddr ,cell))) + (macrolet ((,getter () ^(car ,',cell-sym)) + (,setter (val) ^(sys:rplaca ,',cell-sym ,val))) + ,body)))) + (ssetter + ^(macrolet ((,ssetter (val) ^(sys:rplaca (cddr ,',cell) ,val))) + ,body)) + (deleter + ^(macrolet ((,deleter () + (with-gensyms (tmp) + (with-update-expander (cgetter csetter) '(cddr ,cell) nil + ^(let ((,tmp (,cgetter))) + (prog1 (car ,tmp) (,csetter (cdr ,tmp)))))))) + ,body))) + +(defplace (cdaar cell) body + (getter setter + (with-gensyms (cell-sym) + ^(let ((,cell-sym (caar ,cell))) + (macrolet ((,getter () ^(cdr ,',cell-sym)) + (,setter (val) ^(sys:rplacd ,',cell-sym ,val))) + ,body)))) + (ssetter + ^(macrolet ((,ssetter (val) ^(sys:rplacd (caar ,',cell) ,val))) + ,body)) + (deleter + ^(macrolet ((,deleter () + (with-gensyms (tmp) + (with-update-expander (cgetter csetter) '(caar ,cell) nil + ^(let ((,tmp (,cgetter))) + (prog1 (cdr ,tmp) (,csetter (car ,tmp)))))))) + ,body))) + +(defplace (cdadr cell) body + (getter setter + (with-gensyms (cell-sym) + ^(let ((,cell-sym (cadr ,cell))) + (macrolet ((,getter () ^(cdr ,',cell-sym)) + (,setter (val) ^(sys:rplacd ,',cell-sym ,val))) + ,body)))) + (ssetter + ^(macrolet ((,ssetter (val) ^(sys:rplacd (cadr ,',cell) ,val))) + ,body)) + (deleter + ^(macrolet ((,deleter () + (with-gensyms (tmp) + (with-update-expander (cgetter csetter) '(cadr ,cell) nil + ^(let ((,tmp (,cgetter))) + (prog1 (cdr ,tmp) (,csetter (car ,tmp)))))))) + ,body))) + +(defplace (cddar cell) body + (getter setter + (with-gensyms (cell-sym) + ^(let ((,cell-sym (cdar ,cell))) + (macrolet ((,getter () ^(cdr ,',cell-sym)) + (,setter (val) ^(sys:rplacd ,',cell-sym ,val))) + ,body)))) + (ssetter + ^(macrolet ((,ssetter (val) ^(sys:rplacd (cdar ,',cell) ,val))) + ,body)) + (deleter + ^(macrolet ((,deleter () + (with-gensyms (tmp) + (with-update-expander (cgetter csetter) '(cdar ,cell) nil + ^(let ((,tmp (,cgetter))) + (prog1 (cdr ,tmp) (,csetter (car ,tmp)))))))) + ,body))) + +(defplace (cdddr cell) body + (getter setter + (with-gensyms (cell-sym) + ^(let ((,cell-sym (cddr ,cell))) + (macrolet ((,getter () ^(cdr ,',cell-sym)) + (,setter (val) ^(sys:rplacd ,',cell-sym ,val))) + ,body)))) + (ssetter + ^(macrolet ((,ssetter (val) ^(sys:rplacd (cddr ,',cell) ,val))) + ,body)) + (deleter + ^(macrolet ((,deleter () + (with-gensyms (tmp) + (with-update-expander (cgetter csetter) '(cddr ,cell) nil + ^(let ((,tmp (,cgetter))) + (prog1 (cdr ,tmp) (,csetter (car ,tmp)))))))) + ,body))) + +(defplace (caaaar cell) body + (getter setter + (with-gensyms (cell-sym) + ^(let ((,cell-sym (caaar ,cell))) + (macrolet ((,getter () ^(car ,',cell-sym)) + (,setter (val) ^(sys:rplaca ,',cell-sym ,val))) + ,body)))) + (ssetter + ^(macrolet ((,ssetter (val) ^(sys:rplaca (caaar ,',cell) ,val))) + ,body)) + (deleter + ^(macrolet ((,deleter () + (with-gensyms (tmp) + (with-update-expander (cgetter csetter) '(caaar ,cell) nil + ^(let ((,tmp (,cgetter))) + (prog1 (car ,tmp) (,csetter (cdr ,tmp)))))))) + ,body))) + +(defplace (caaadr cell) body + (getter setter + (with-gensyms (cell-sym) + ^(let ((,cell-sym (caadr ,cell))) + (macrolet ((,getter () ^(car ,',cell-sym)) + (,setter (val) ^(sys:rplaca ,',cell-sym ,val))) + ,body)))) + (ssetter + ^(macrolet ((,ssetter (val) ^(sys:rplaca (caadr ,',cell) ,val))) + ,body)) + (deleter + ^(macrolet ((,deleter () + (with-gensyms (tmp) + (with-update-expander (cgetter csetter) '(caadr ,cell) nil + ^(let ((,tmp (,cgetter))) + (prog1 (car ,tmp) (,csetter (cdr ,tmp)))))))) + ,body))) + +(defplace (caadar cell) body + (getter setter + (with-gensyms (cell-sym) + ^(let ((,cell-sym (cadar ,cell))) + (macrolet ((,getter () ^(car ,',cell-sym)) + (,setter (val) ^(sys:rplaca ,',cell-sym ,val))) + ,body)))) + (ssetter + ^(macrolet ((,ssetter (val) ^(sys:rplaca (cadar ,',cell) ,val))) + ,body)) + (deleter + ^(macrolet ((,deleter () + (with-gensyms (tmp) + (with-update-expander (cgetter csetter) '(cadar ,cell) nil + ^(let ((,tmp (,cgetter))) + (prog1 (car ,tmp) (,csetter (cdr ,tmp)))))))) + ,body))) + +(defplace (caaddr cell) body + (getter setter + (with-gensyms (cell-sym) + ^(let ((,cell-sym (caddr ,cell))) + (macrolet ((,getter () ^(car ,',cell-sym)) + (,setter (val) ^(sys:rplaca ,',cell-sym ,val))) + ,body)))) + (ssetter + ^(macrolet ((,ssetter (val) ^(sys:rplaca (caddr ,',cell) ,val))) + ,body)) + (deleter + ^(macrolet ((,deleter () + (with-gensyms (tmp) + (with-update-expander (cgetter csetter) '(caddr ,cell) nil + ^(let ((,tmp (,cgetter))) + (prog1 (car ,tmp) (,csetter (cdr ,tmp)))))))) + ,body))) + +(defplace (cadaar cell) body + (getter setter + (with-gensyms (cell-sym) + ^(let ((,cell-sym (cdaar ,cell))) + (macrolet ((,getter () ^(car ,',cell-sym)) + (,setter (val) ^(sys:rplaca ,',cell-sym ,val))) + ,body)))) + (ssetter + ^(macrolet ((,ssetter (val) ^(sys:rplaca (cdaar ,',cell) ,val))) + ,body)) + (deleter + ^(macrolet ((,deleter () + (with-gensyms (tmp) + (with-update-expander (cgetter csetter) '(cdaar ,cell) nil + ^(let ((,tmp (,cgetter))) + (prog1 (car ,tmp) (,csetter (cdr ,tmp)))))))) + ,body))) + +(defplace (cadadr cell) body + (getter setter + (with-gensyms (cell-sym) + ^(let ((,cell-sym (cdadr ,cell))) + (macrolet ((,getter () ^(car ,',cell-sym)) + (,setter (val) ^(sys:rplaca ,',cell-sym ,val))) + ,body)))) + (ssetter + ^(macrolet ((,ssetter (val) ^(sys:rplaca (cdadr ,',cell) ,val))) + ,body)) + (deleter + ^(macrolet ((,deleter () + (with-gensyms (tmp) + (with-update-expander (cgetter csetter) '(cdadr ,cell) nil + ^(let ((,tmp (,cgetter))) + (prog1 (car ,tmp) (,csetter (cdr ,tmp)))))))) + ,body))) + +(defplace (caddar cell) body + (getter setter + (with-gensyms (cell-sym) + ^(let ((,cell-sym (cddar ,cell))) + (macrolet ((,getter () ^(car ,',cell-sym)) + (,setter (val) ^(sys:rplaca ,',cell-sym ,val))) + ,body)))) + (ssetter + ^(macrolet ((,ssetter (val) ^(sys:rplaca (cddar ,',cell) ,val))) + ,body)) + (deleter + ^(macrolet ((,deleter () + (with-gensyms (tmp) + (with-update-expander (cgetter csetter) '(cddar ,cell) nil + ^(let ((,tmp (,cgetter))) + (prog1 (car ,tmp) (,csetter (cdr ,tmp)))))))) + ,body))) + +(defplace (cadddr cell) body + (getter setter + (with-gensyms (cell-sym) + ^(let ((,cell-sym (cdddr ,cell))) + (macrolet ((,getter () ^(car ,',cell-sym)) + (,setter (val) ^(sys:rplaca ,',cell-sym ,val))) + ,body)))) + (ssetter + ^(macrolet ((,ssetter (val) ^(sys:rplaca (cdddr ,',cell) ,val))) + ,body)) + (deleter + ^(macrolet ((,deleter () + (with-gensyms (tmp) + (with-update-expander (cgetter csetter) '(cdddr ,cell) nil + ^(let ((,tmp (,cgetter))) + (prog1 (car ,tmp) (,csetter (cdr ,tmp)))))))) + ,body))) + +(defplace (cdaaar cell) body + (getter setter + (with-gensyms (cell-sym) + ^(let ((,cell-sym (caaar ,cell))) + (macrolet ((,getter () ^(cdr ,',cell-sym)) + (,setter (val) ^(sys:rplacd ,',cell-sym ,val))) + ,body)))) + (ssetter + ^(macrolet ((,ssetter (val) ^(sys:rplacd (caaar ,',cell) ,val))) + ,body)) + (deleter + ^(macrolet ((,deleter () + (with-gensyms (tmp) + (with-update-expander (cgetter csetter) '(caaar ,cell) nil + ^(let ((,tmp (,cgetter))) + (prog1 (cdr ,tmp) (,csetter (car ,tmp)))))))) + ,body))) + +(defplace (cdaadr cell) body + (getter setter + (with-gensyms (cell-sym) + ^(let ((,cell-sym (caadr ,cell))) + (macrolet ((,getter () ^(cdr ,',cell-sym)) + (,setter (val) ^(sys:rplacd ,',cell-sym ,val))) + ,body)))) + (ssetter + ^(macrolet ((,ssetter (val) ^(sys:rplacd (caadr ,',cell) ,val))) + ,body)) + (deleter + ^(macrolet ((,deleter () + (with-gensyms (tmp) + (with-update-expander (cgetter csetter) '(caadr ,cell) nil + ^(let ((,tmp (,cgetter))) + (prog1 (cdr ,tmp) (,csetter (car ,tmp)))))))) + ,body))) + +(defplace (cdadar cell) body + (getter setter + (with-gensyms (cell-sym) + ^(let ((,cell-sym (cadar ,cell))) + (macrolet ((,getter () ^(cdr ,',cell-sym)) + (,setter (val) ^(sys:rplacd ,',cell-sym ,val))) + ,body)))) + (ssetter + ^(macrolet ((,ssetter (val) ^(sys:rplacd (cadar ,',cell) ,val))) + ,body)) + (deleter + ^(macrolet ((,deleter () + (with-gensyms (tmp) + (with-update-expander (cgetter csetter) '(cadar ,cell) nil + ^(let ((,tmp (,cgetter))) + (prog1 (cdr ,tmp) (,csetter (car ,tmp)))))))) + ,body))) + +(defplace (cdaddr cell) body + (getter setter + (with-gensyms (cell-sym) + ^(let ((,cell-sym (caddr ,cell))) + (macrolet ((,getter () ^(cdr ,',cell-sym)) + (,setter (val) ^(sys:rplacd ,',cell-sym ,val))) + ,body)))) + (ssetter + ^(macrolet ((,ssetter (val) ^(sys:rplacd (caddr ,',cell) ,val))) + ,body)) + (deleter + ^(macrolet ((,deleter () + (with-gensyms (tmp) + (with-update-expander (cgetter csetter) '(caddr ,cell) nil + ^(let ((,tmp (,cgetter))) + (prog1 (cdr ,tmp) (,csetter (car ,tmp)))))))) + ,body))) + +(defplace (cddaar cell) body + (getter setter + (with-gensyms (cell-sym) + ^(let ((,cell-sym (cdaar ,cell))) + (macrolet ((,getter () ^(cdr ,',cell-sym)) + (,setter (val) ^(sys:rplacd ,',cell-sym ,val))) + ,body)))) + (ssetter + ^(macrolet ((,ssetter (val) ^(sys:rplacd (cdaar ,',cell) ,val))) + ,body)) + (deleter + ^(macrolet ((,deleter () + (with-gensyms (tmp) + (with-update-expander (cgetter csetter) '(cdaar ,cell) nil + ^(let ((,tmp (,cgetter))) + (prog1 (cdr ,tmp) (,csetter (car ,tmp)))))))) + ,body))) + +(defplace (cddadr cell) body + (getter setter + (with-gensyms (cell-sym) + ^(let ((,cell-sym (cdadr ,cell))) + (macrolet ((,getter () ^(cdr ,',cell-sym)) + (,setter (val) ^(sys:rplacd ,',cell-sym ,val))) + ,body)))) + (ssetter + ^(macrolet ((,ssetter (val) ^(sys:rplacd (cdadr ,',cell) ,val))) + ,body)) + (deleter + ^(macrolet ((,deleter () + (with-gensyms (tmp) + (with-update-expander (cgetter csetter) '(cdadr ,cell) nil + ^(let ((,tmp (,cgetter))) + (prog1 (cdr ,tmp) (,csetter (car ,tmp)))))))) + ,body))) + +(defplace (cdddar cell) body + (getter setter + (with-gensyms (cell-sym) + ^(let ((,cell-sym (cddar ,cell))) + (macrolet ((,getter () ^(cdr ,',cell-sym)) + (,setter (val) ^(sys:rplacd ,',cell-sym ,val))) + ,body)))) + (ssetter + ^(macrolet ((,ssetter (val) ^(sys:rplacd (cddar ,',cell) ,val))) + ,body)) + (deleter + ^(macrolet ((,deleter () + (with-gensyms (tmp) + (with-update-expander (cgetter csetter) '(cddar ,cell) nil + ^(let ((,tmp (,cgetter))) + (prog1 (cdr ,tmp) (,csetter (car ,tmp)))))))) + ,body))) + +(defplace (cddddr cell) body + (getter setter + (with-gensyms (cell-sym) + ^(let ((,cell-sym (cdddr ,cell))) + (macrolet ((,getter () ^(cdr ,',cell-sym)) + (,setter (val) ^(sys:rplacd ,',cell-sym ,val))) + ,body)))) + (ssetter + ^(macrolet ((,ssetter (val) ^(sys:rplacd (cdddr ,',cell) ,val))) + ,body)) + (deleter + ^(macrolet ((,deleter () + (with-gensyms (tmp) + (with-update-expander (cgetter csetter) '(cdddr ,cell) nil + ^(let ((,tmp (,cgetter))) + (prog1 (cdr ,tmp) (,csetter (car ,tmp)))))))) + ,body))) + +(defplace (caaaaar cell) body + (getter setter + (with-gensyms (cell-sym) + ^(let ((,cell-sym (caaaar ,cell))) + (macrolet ((,getter () ^(car ,',cell-sym)) + (,setter (val) ^(sys:rplaca ,',cell-sym ,val))) + ,body)))) + (ssetter + ^(macrolet ((,ssetter (val) ^(sys:rplaca (caaaar ,',cell) ,val))) + ,body)) + (deleter + ^(macrolet ((,deleter () + (with-gensyms (tmp) + (with-update-expander (cgetter csetter) '(caaaar ,cell) nil + ^(let ((,tmp (,cgetter))) + (prog1 (car ,tmp) (,csetter (cdr ,tmp)))))))) + ,body))) + +(defplace (caaaadr cell) body + (getter setter + (with-gensyms (cell-sym) + ^(let ((,cell-sym (caaadr ,cell))) + (macrolet ((,getter () ^(car ,',cell-sym)) + (,setter (val) ^(sys:rplaca ,',cell-sym ,val))) + ,body)))) + (ssetter + ^(macrolet ((,ssetter (val) ^(sys:rplaca (caaadr ,',cell) ,val))) + ,body)) + (deleter + ^(macrolet ((,deleter () + (with-gensyms (tmp) + (with-update-expander (cgetter csetter) '(caaadr ,cell) nil + ^(let ((,tmp (,cgetter))) + (prog1 (car ,tmp) (,csetter (cdr ,tmp)))))))) + ,body))) + +(defplace (caaadar cell) body + (getter setter + (with-gensyms (cell-sym) + ^(let ((,cell-sym (caadar ,cell))) + (macrolet ((,getter () ^(car ,',cell-sym)) + (,setter (val) ^(sys:rplaca ,',cell-sym ,val))) + ,body)))) + (ssetter + ^(macrolet ((,ssetter (val) ^(sys:rplaca (caadar ,',cell) ,val))) + ,body)) + (deleter + ^(macrolet ((,deleter () + (with-gensyms (tmp) + (with-update-expander (cgetter csetter) '(caadar ,cell) nil + ^(let ((,tmp (,cgetter))) + (prog1 (car ,tmp) (,csetter (cdr ,tmp)))))))) + ,body))) + +(defplace (caaaddr cell) body + (getter setter + (with-gensyms (cell-sym) + ^(let ((,cell-sym (caaddr ,cell))) + (macrolet ((,getter () ^(car ,',cell-sym)) + (,setter (val) ^(sys:rplaca ,',cell-sym ,val))) + ,body)))) + (ssetter + ^(macrolet ((,ssetter (val) ^(sys:rplaca (caaddr ,',cell) ,val))) + ,body)) + (deleter + ^(macrolet ((,deleter () + (with-gensyms (tmp) + (with-update-expander (cgetter csetter) '(caaddr ,cell) nil + ^(let ((,tmp (,cgetter))) + (prog1 (car ,tmp) (,csetter (cdr ,tmp)))))))) + ,body))) + +(defplace (caadaar cell) body + (getter setter + (with-gensyms (cell-sym) + ^(let ((,cell-sym (cadaar ,cell))) + (macrolet ((,getter () ^(car ,',cell-sym)) + (,setter (val) ^(sys:rplaca ,',cell-sym ,val))) + ,body)))) + (ssetter + ^(macrolet ((,ssetter (val) ^(sys:rplaca (cadaar ,',cell) ,val))) + ,body)) + (deleter + ^(macrolet ((,deleter () + (with-gensyms (tmp) + (with-update-expander (cgetter csetter) '(cadaar ,cell) nil + ^(let ((,tmp (,cgetter))) + (prog1 (car ,tmp) (,csetter (cdr ,tmp)))))))) + ,body))) + +(defplace (caadadr cell) body + (getter setter + (with-gensyms (cell-sym) + ^(let ((,cell-sym (cadadr ,cell))) + (macrolet ((,getter () ^(car ,',cell-sym)) + (,setter (val) ^(sys:rplaca ,',cell-sym ,val))) + ,body)))) + (ssetter + ^(macrolet ((,ssetter (val) ^(sys:rplaca (cadadr ,',cell) ,val))) + ,body)) + (deleter + ^(macrolet ((,deleter () + (with-gensyms (tmp) + (with-update-expander (cgetter csetter) '(cadadr ,cell) nil + ^(let ((,tmp (,cgetter))) + (prog1 (car ,tmp) (,csetter (cdr ,tmp)))))))) + ,body))) + +(defplace (caaddar cell) body + (getter setter + (with-gensyms (cell-sym) + ^(let ((,cell-sym (caddar ,cell))) + (macrolet ((,getter () ^(car ,',cell-sym)) + (,setter (val) ^(sys:rplaca ,',cell-sym ,val))) + ,body)))) + (ssetter + ^(macrolet ((,ssetter (val) ^(sys:rplaca (caddar ,',cell) ,val))) + ,body)) + (deleter + ^(macrolet ((,deleter () + (with-gensyms (tmp) + (with-update-expander (cgetter csetter) '(caddar ,cell) nil + ^(let ((,tmp (,cgetter))) + (prog1 (car ,tmp) (,csetter (cdr ,tmp)))))))) + ,body))) + +(defplace (caadddr cell) body + (getter setter + (with-gensyms (cell-sym) + ^(let ((,cell-sym (cadddr ,cell))) + (macrolet ((,getter () ^(car ,',cell-sym)) + (,setter (val) ^(sys:rplaca ,',cell-sym ,val))) + ,body)))) + (ssetter + ^(macrolet ((,ssetter (val) ^(sys:rplaca (cadddr ,',cell) ,val))) + ,body)) + (deleter + ^(macrolet ((,deleter () + (with-gensyms (tmp) + (with-update-expander (cgetter csetter) '(cadddr ,cell) nil + ^(let ((,tmp (,cgetter))) + (prog1 (car ,tmp) (,csetter (cdr ,tmp)))))))) + ,body))) + +(defplace (cadaaar cell) body + (getter setter + (with-gensyms (cell-sym) + ^(let ((,cell-sym (cdaaar ,cell))) + (macrolet ((,getter () ^(car ,',cell-sym)) + (,setter (val) ^(sys:rplaca ,',cell-sym ,val))) + ,body)))) + (ssetter + ^(macrolet ((,ssetter (val) ^(sys:rplaca (cdaaar ,',cell) ,val))) + ,body)) + (deleter + ^(macrolet ((,deleter () + (with-gensyms (tmp) + (with-update-expander (cgetter csetter) '(cdaaar ,cell) nil + ^(let ((,tmp (,cgetter))) + (prog1 (car ,tmp) (,csetter (cdr ,tmp)))))))) + ,body))) + +(defplace (cadaadr cell) body + (getter setter + (with-gensyms (cell-sym) + ^(let ((,cell-sym (cdaadr ,cell))) + (macrolet ((,getter () ^(car ,',cell-sym)) + (,setter (val) ^(sys:rplaca ,',cell-sym ,val))) + ,body)))) + (ssetter + ^(macrolet ((,ssetter (val) ^(sys:rplaca (cdaadr ,',cell) ,val))) + ,body)) + (deleter + ^(macrolet ((,deleter () + (with-gensyms (tmp) + (with-update-expander (cgetter csetter) '(cdaadr ,cell) nil + ^(let ((,tmp (,cgetter))) + (prog1 (car ,tmp) (,csetter (cdr ,tmp)))))))) + ,body))) + +(defplace (cadadar cell) body + (getter setter + (with-gensyms (cell-sym) + ^(let ((,cell-sym (cdadar ,cell))) + (macrolet ((,getter () ^(car ,',cell-sym)) + (,setter (val) ^(sys:rplaca ,',cell-sym ,val))) + ,body)))) + (ssetter + ^(macrolet ((,ssetter (val) ^(sys:rplaca (cdadar ,',cell) ,val))) + ,body)) + (deleter + ^(macrolet ((,deleter () + (with-gensyms (tmp) + (with-update-expander (cgetter csetter) '(cdadar ,cell) nil + ^(let ((,tmp (,cgetter))) + (prog1 (car ,tmp) (,csetter (cdr ,tmp)))))))) + ,body))) + +(defplace (cadaddr cell) body + (getter setter + (with-gensyms (cell-sym) + ^(let ((,cell-sym (cdaddr ,cell))) + (macrolet ((,getter () ^(car ,',cell-sym)) + (,setter (val) ^(sys:rplaca ,',cell-sym ,val))) + ,body)))) + (ssetter + ^(macrolet ((,ssetter (val) ^(sys:rplaca (cdaddr ,',cell) ,val))) + ,body)) + (deleter + ^(macrolet ((,deleter () + (with-gensyms (tmp) + (with-update-expander (cgetter csetter) '(cdaddr ,cell) nil + ^(let ((,tmp (,cgetter))) + (prog1 (car ,tmp) (,csetter (cdr ,tmp)))))))) + ,body))) + +(defplace (caddaar cell) body + (getter setter + (with-gensyms (cell-sym) + ^(let ((,cell-sym (cddaar ,cell))) + (macrolet ((,getter () ^(car ,',cell-sym)) + (,setter (val) ^(sys:rplaca ,',cell-sym ,val))) + ,body)))) + (ssetter + ^(macrolet ((,ssetter (val) ^(sys:rplaca (cddaar ,',cell) ,val))) + ,body)) + (deleter + ^(macrolet ((,deleter () + (with-gensyms (tmp) + (with-update-expander (cgetter csetter) '(cddaar ,cell) nil + ^(let ((,tmp (,cgetter))) + (prog1 (car ,tmp) (,csetter (cdr ,tmp)))))))) + ,body))) + +(defplace (caddadr cell) body + (getter setter + (with-gensyms (cell-sym) + ^(let ((,cell-sym (cddadr ,cell))) + (macrolet ((,getter () ^(car ,',cell-sym)) + (,setter (val) ^(sys:rplaca ,',cell-sym ,val))) + ,body)))) + (ssetter + ^(macrolet ((,ssetter (val) ^(sys:rplaca (cddadr ,',cell) ,val))) + ,body)) + (deleter + ^(macrolet ((,deleter () + (with-gensyms (tmp) + (with-update-expander (cgetter csetter) '(cddadr ,cell) nil + ^(let ((,tmp (,cgetter))) + (prog1 (car ,tmp) (,csetter (cdr ,tmp)))))))) + ,body))) + +(defplace (cadddar cell) body + (getter setter + (with-gensyms (cell-sym) + ^(let ((,cell-sym (cdddar ,cell))) + (macrolet ((,getter () ^(car ,',cell-sym)) + (,setter (val) ^(sys:rplaca ,',cell-sym ,val))) + ,body)))) + (ssetter + ^(macrolet ((,ssetter (val) ^(sys:rplaca (cdddar ,',cell) ,val))) + ,body)) + (deleter + ^(macrolet ((,deleter () + (with-gensyms (tmp) + (with-update-expander (cgetter csetter) '(cdddar ,cell) nil + ^(let ((,tmp (,cgetter))) + (prog1 (car ,tmp) (,csetter (cdr ,tmp)))))))) + ,body))) + +(defplace (caddddr cell) body + (getter setter + (with-gensyms (cell-sym) + ^(let ((,cell-sym (cddddr ,cell))) + (macrolet ((,getter () ^(car ,',cell-sym)) + (,setter (val) ^(sys:rplaca ,',cell-sym ,val))) + ,body)))) + (ssetter + ^(macrolet ((,ssetter (val) ^(sys:rplaca (cddddr ,',cell) ,val))) + ,body)) + (deleter + ^(macrolet ((,deleter () + (with-gensyms (tmp) + (with-update-expander (cgetter csetter) '(cddddr ,cell) nil + ^(let ((,tmp (,cgetter))) + (prog1 (car ,tmp) (,csetter (cdr ,tmp)))))))) + ,body))) + +(defplace (cdaaaar cell) body + (getter setter + (with-gensyms (cell-sym) + ^(let ((,cell-sym (caaaar ,cell))) + (macrolet ((,getter () ^(cdr ,',cell-sym)) + (,setter (val) ^(sys:rplacd ,',cell-sym ,val))) + ,body)))) + (ssetter + ^(macrolet ((,ssetter (val) ^(sys:rplacd (caaaar ,',cell) ,val))) + ,body)) + (deleter + ^(macrolet ((,deleter () + (with-gensyms (tmp) + (with-update-expander (cgetter csetter) '(caaaar ,cell) nil + ^(let ((,tmp (,cgetter))) + (prog1 (cdr ,tmp) (,csetter (car ,tmp)))))))) + ,body))) + +(defplace (cdaaadr cell) body + (getter setter + (with-gensyms (cell-sym) + ^(let ((,cell-sym (caaadr ,cell))) + (macrolet ((,getter () ^(cdr ,',cell-sym)) + (,setter (val) ^(sys:rplacd ,',cell-sym ,val))) + ,body)))) + (ssetter + ^(macrolet ((,ssetter (val) ^(sys:rplacd (caaadr ,',cell) ,val))) + ,body)) + (deleter + ^(macrolet ((,deleter () + (with-gensyms (tmp) + (with-update-expander (cgetter csetter) '(caaadr ,cell) nil + ^(let ((,tmp (,cgetter))) + (prog1 (cdr ,tmp) (,csetter (car ,tmp)))))))) + ,body))) + +(defplace (cdaadar cell) body + (getter setter + (with-gensyms (cell-sym) + ^(let ((,cell-sym (caadar ,cell))) + (macrolet ((,getter () ^(cdr ,',cell-sym)) + (,setter (val) ^(sys:rplacd ,',cell-sym ,val))) + ,body)))) + (ssetter + ^(macrolet ((,ssetter (val) ^(sys:rplacd (caadar ,',cell) ,val))) + ,body)) + (deleter + ^(macrolet ((,deleter () + (with-gensyms (tmp) + (with-update-expander (cgetter csetter) '(caadar ,cell) nil + ^(let ((,tmp (,cgetter))) + (prog1 (cdr ,tmp) (,csetter (car ,tmp)))))))) + ,body))) + +(defplace (cdaaddr cell) body + (getter setter + (with-gensyms (cell-sym) + ^(let ((,cell-sym (caaddr ,cell))) + (macrolet ((,getter () ^(cdr ,',cell-sym)) + (,setter (val) ^(sys:rplacd ,',cell-sym ,val))) + ,body)))) + (ssetter + ^(macrolet ((,ssetter (val) ^(sys:rplacd (caaddr ,',cell) ,val))) + ,body)) + (deleter + ^(macrolet ((,deleter () + (with-gensyms (tmp) + (with-update-expander (cgetter csetter) '(caaddr ,cell) nil + ^(let ((,tmp (,cgetter))) + (prog1 (cdr ,tmp) (,csetter (car ,tmp)))))))) + ,body))) + +(defplace (cdadaar cell) body + (getter setter + (with-gensyms (cell-sym) + ^(let ((,cell-sym (cadaar ,cell))) + (macrolet ((,getter () ^(cdr ,',cell-sym)) + (,setter (val) ^(sys:rplacd ,',cell-sym ,val))) + ,body)))) + (ssetter + ^(macrolet ((,ssetter (val) ^(sys:rplacd (cadaar ,',cell) ,val))) + ,body)) + (deleter + ^(macrolet ((,deleter () + (with-gensyms (tmp) + (with-update-expander (cgetter csetter) '(cadaar ,cell) nil + ^(let ((,tmp (,cgetter))) + (prog1 (cdr ,tmp) (,csetter (car ,tmp)))))))) + ,body))) + +(defplace (cdadadr cell) body + (getter setter + (with-gensyms (cell-sym) + ^(let ((,cell-sym (cadadr ,cell))) + (macrolet ((,getter () ^(cdr ,',cell-sym)) + (,setter (val) ^(sys:rplacd ,',cell-sym ,val))) + ,body)))) + (ssetter + ^(macrolet ((,ssetter (val) ^(sys:rplacd (cadadr ,',cell) ,val))) + ,body)) + (deleter + ^(macrolet ((,deleter () + (with-gensyms (tmp) + (with-update-expander (cgetter csetter) '(cadadr ,cell) nil + ^(let ((,tmp (,cgetter))) + (prog1 (cdr ,tmp) (,csetter (car ,tmp)))))))) + ,body))) + +(defplace (cdaddar cell) body + (getter setter + (with-gensyms (cell-sym) + ^(let ((,cell-sym (caddar ,cell))) + (macrolet ((,getter () ^(cdr ,',cell-sym)) + (,setter (val) ^(sys:rplacd ,',cell-sym ,val))) + ,body)))) + (ssetter + ^(macrolet ((,ssetter (val) ^(sys:rplacd (caddar ,',cell) ,val))) + ,body)) + (deleter + ^(macrolet ((,deleter () + (with-gensyms (tmp) + (with-update-expander (cgetter csetter) '(caddar ,cell) nil + ^(let ((,tmp (,cgetter))) + (prog1 (cdr ,tmp) (,csetter (car ,tmp)))))))) + ,body))) + +(defplace (cdadddr cell) body + (getter setter + (with-gensyms (cell-sym) + ^(let ((,cell-sym (cadddr ,cell))) + (macrolet ((,getter () ^(cdr ,',cell-sym)) + (,setter (val) ^(sys:rplacd ,',cell-sym ,val))) + ,body)))) + (ssetter + ^(macrolet ((,ssetter (val) ^(sys:rplacd (cadddr ,',cell) ,val))) + ,body)) + (deleter + ^(macrolet ((,deleter () + (with-gensyms (tmp) + (with-update-expander (cgetter csetter) '(cadddr ,cell) nil + ^(let ((,tmp (,cgetter))) + (prog1 (cdr ,tmp) (,csetter (car ,tmp)))))))) + ,body))) + +(defplace (cddaaar cell) body + (getter setter + (with-gensyms (cell-sym) + ^(let ((,cell-sym (cdaaar ,cell))) + (macrolet ((,getter () ^(cdr ,',cell-sym)) + (,setter (val) ^(sys:rplacd ,',cell-sym ,val))) + ,body)))) + (ssetter + ^(macrolet ((,ssetter (val) ^(sys:rplacd (cdaaar ,',cell) ,val))) + ,body)) + (deleter + ^(macrolet ((,deleter () + (with-gensyms (tmp) + (with-update-expander (cgetter csetter) '(cdaaar ,cell) nil + ^(let ((,tmp (,cgetter))) + (prog1 (cdr ,tmp) (,csetter (car ,tmp)))))))) + ,body))) + +(defplace (cddaadr cell) body + (getter setter + (with-gensyms (cell-sym) + ^(let ((,cell-sym (cdaadr ,cell))) + (macrolet ((,getter () ^(cdr ,',cell-sym)) + (,setter (val) ^(sys:rplacd ,',cell-sym ,val))) + ,body)))) + (ssetter + ^(macrolet ((,ssetter (val) ^(sys:rplacd (cdaadr ,',cell) ,val))) + ,body)) + (deleter + ^(macrolet ((,deleter () + (with-gensyms (tmp) + (with-update-expander (cgetter csetter) '(cdaadr ,cell) nil + ^(let ((,tmp (,cgetter))) + (prog1 (cdr ,tmp) (,csetter (car ,tmp)))))))) + ,body))) + +(defplace (cddadar cell) body + (getter setter + (with-gensyms (cell-sym) + ^(let ((,cell-sym (cdadar ,cell))) + (macrolet ((,getter () ^(cdr ,',cell-sym)) + (,setter (val) ^(sys:rplacd ,',cell-sym ,val))) + ,body)))) + (ssetter + ^(macrolet ((,ssetter (val) ^(sys:rplacd (cdadar ,',cell) ,val))) + ,body)) + (deleter + ^(macrolet ((,deleter () + (with-gensyms (tmp) + (with-update-expander (cgetter csetter) '(cdadar ,cell) nil + ^(let ((,tmp (,cgetter))) + (prog1 (cdr ,tmp) (,csetter (car ,tmp)))))))) + ,body))) + +(defplace (cddaddr cell) body + (getter setter + (with-gensyms (cell-sym) + ^(let ((,cell-sym (cdaddr ,cell))) + (macrolet ((,getter () ^(cdr ,',cell-sym)) + (,setter (val) ^(sys:rplacd ,',cell-sym ,val))) + ,body)))) + (ssetter + ^(macrolet ((,ssetter (val) ^(sys:rplacd (cdaddr ,',cell) ,val))) + ,body)) + (deleter + ^(macrolet ((,deleter () + (with-gensyms (tmp) + (with-update-expander (cgetter csetter) '(cdaddr ,cell) nil + ^(let ((,tmp (,cgetter))) + (prog1 (cdr ,tmp) (,csetter (car ,tmp)))))))) + ,body))) + +(defplace (cdddaar cell) body + (getter setter + (with-gensyms (cell-sym) + ^(let ((,cell-sym (cddaar ,cell))) + (macrolet ((,getter () ^(cdr ,',cell-sym)) + (,setter (val) ^(sys:rplacd ,',cell-sym ,val))) + ,body)))) + (ssetter + ^(macrolet ((,ssetter (val) ^(sys:rplacd (cddaar ,',cell) ,val))) + ,body)) + (deleter + ^(macrolet ((,deleter () + (with-gensyms (tmp) + (with-update-expander (cgetter csetter) '(cddaar ,cell) nil + ^(let ((,tmp (,cgetter))) + (prog1 (cdr ,tmp) (,csetter (car ,tmp)))))))) + ,body))) + +(defplace (cdddadr cell) body + (getter setter + (with-gensyms (cell-sym) + ^(let ((,cell-sym (cddadr ,cell))) + (macrolet ((,getter () ^(cdr ,',cell-sym)) + (,setter (val) ^(sys:rplacd ,',cell-sym ,val))) + ,body)))) + (ssetter + ^(macrolet ((,ssetter (val) ^(sys:rplacd (cddadr ,',cell) ,val))) + ,body)) + (deleter + ^(macrolet ((,deleter () + (with-gensyms (tmp) + (with-update-expander (cgetter csetter) '(cddadr ,cell) nil + ^(let ((,tmp (,cgetter))) + (prog1 (cdr ,tmp) (,csetter (car ,tmp)))))))) + ,body))) + +(defplace (cddddar cell) body + (getter setter + (with-gensyms (cell-sym) + ^(let ((,cell-sym (cdddar ,cell))) + (macrolet ((,getter () ^(cdr ,',cell-sym)) + (,setter (val) ^(sys:rplacd ,',cell-sym ,val))) + ,body)))) + (ssetter + ^(macrolet ((,ssetter (val) ^(sys:rplacd (cdddar ,',cell) ,val))) + ,body)) + (deleter + ^(macrolet ((,deleter () + (with-gensyms (tmp) + (with-update-expander (cgetter csetter) '(cdddar ,cell) nil + ^(let ((,tmp (,cgetter))) + (prog1 (cdr ,tmp) (,csetter (car ,tmp)))))))) + ,body))) + +(defplace (cdddddr cell) body + (getter setter + (with-gensyms (cell-sym) + ^(let ((,cell-sym (cddddr ,cell))) + (macrolet ((,getter () ^(cdr ,',cell-sym)) + (,setter (val) ^(sys:rplacd ,',cell-sym ,val))) + ,body)))) + (ssetter + ^(macrolet ((,ssetter (val) ^(sys:rplacd (cddddr ,',cell) ,val))) + ,body)) + (deleter + ^(macrolet ((,deleter () + (with-gensyms (tmp) + (with-update-expander (cgetter csetter) '(cddddr ,cell) nil + ^(let ((,tmp (,cgetter))) + (prog1 (cdr ,tmp) (,csetter (car ,tmp)))))))) + ,body))) diff --git a/stdlib/compiler.tl b/stdlib/compiler.tl new file mode 100644 index 00000000..c30ebbd6 --- /dev/null +++ b/stdlib/compiler.tl @@ -0,0 +1,2394 @@ +;; Copyright 2018-2021 +;; Kaz Kylheku <kaz@kylheku.com> +;; Vancouver, Canada +;; 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 HOLDER 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. + +(load "vm-param") +(load "optimize") + +(compile-only + (load-for (struct sys:param-parser-base "param"))) + +(defstruct (frag oreg code : fvars ffuns pars) nil + oreg + code + pars + fvars + ffuns) + +(defstruct binding nil + sym + loc + used + sys:env) + +(defstruct vbinding binding) + +(defstruct fbinding binding + pars) + +(defstruct blockinfo nil + sym + used + sys:env) + +(defstruct sys:env nil + vb + fb + bb + up + co + lev + (v-cntr 0) + + (:postinit (me) + (unless me.lev + (set me.lev (succ (or me.up.?lev 0)))) + (unless (or me.co (null me.up)) + (set me.co me.up.co)) + me.co.(new-env me)) + + (:method lookup-var (me sym) + (condlet + (((cell (assoc sym me.vb))) + (cdr cell)) + (((up me.up)) up.(lookup-var sym)) + (t nil))) + + (:method lookup-fun (me sym : mark-used) + (condlet + (((cell (assoc sym me.fb))) + (let ((bi (cdr cell))) + (if mark-used (set bi.used t)) + bi)) + (((up me.up)) up.(lookup-fun sym mark-used)) + (t nil))) + + (:method lookup-lisp1 (me sym : mark-used) + (condlet + (((cell (or (assoc sym me.vb) + (assoc sym me.fb)))) + (let ((bi (cdr cell))) + (if mark-used (set bi.used t)) + bi)) + (((up me.up)) up.(lookup-lisp1 sym mark-used)) + (t nil))) + + (:method lookup-block (me sym : mark-used) + (condlet + (((cell (assoc sym me.bb))) + (let ((bi (cdr cell))) + (if mark-used (set bi.used t)) + bi)) + (((up me.up)) up.(lookup-block sym mark-used)) + (t nil))) + + (:method extend-var (me sym) + (when (assoc sym me.vb) + (compile-error me.co.last-form "duplicate variable: ~s" sym)) + (let* ((loc ^(v ,(ppred me.lev) ,(pinc me.v-cntr))) + (bn (new vbinding sym sym loc loc env me))) + (set me.vb (acons sym bn me.vb)))) + + (:method extend-var* (me sym) + (let* ((loc ^(v ,(ppred me.lev) ,(pinc me.v-cntr))) + (bn (new vbinding sym sym loc loc env me))) + (set me.vb (acons sym bn me.vb)))) + + (:method extend-fun (me sym) + (when (assoc sym me.fb) + (compile-error me.co.last-form "duplicate function ~s" sym)) + (let* ((loc ^(v ,(ppred me.lev) ,(pinc me.v-cntr))) + (bn (new fbinding sym sym loc loc env me))) + (set me.fb (acons sym bn me.fb)))) + + (:method rename-var (me from-sym to-sym) + (iflet ((cell (assoc from-sym me.vb))) + (rplaca cell to-sym) + (let ((bn (cdr cell))) + (set bn.sym to-sym)))) + + (:method out-of-scope (me reg) + (if (eq (car reg) 'v) + (let ((lev (ssucc (cadr reg)))) + (< me.lev lev)))) + + (:method extend-block (me sym) + (let* ((bn (new blockinfo sym sym env me))) + (set me.bb (acons sym bn me.bb))))) + +(defstruct closure-spy () + env + cap-vars + + (:method captured (me vbin sym) + (when (eq vbin.env me.env) + (pushnew sym me.cap-vars)))) + +(defstruct access-spy () + closure-spies + + (:method accessed (me vbin sym) + (each ((spy me.closure-spies)) + (when (neq spy me) + spy.(captured vbin sym)))) + + (:method assigned (me vbin sym) + (each ((spy me.closure-spies)) + (when (neq spy me) + spy.(captured vbin sym))))) + +(compile-only + (defstruct compiler nil + (treg-cntr 2) + (dreg-cntr 0) + (sidx-cntr 0) + (nlev 2) + (loop-nest 0) + (tregs nil) + (discards nil) + (dreg (hash :eql-based)) + (data (hash :eql-based)) + (sidx (hash :eql-based)) + (stab (hash :eql-based)) + datavec + symvec + lt-frags + last-form + closure-spies + access-spies + + (:method snapshot (me) + (let ((snap (copy me))) + (set snap.dreg (copy me.dreg) + snap.data (copy me.data) + snap.sidx (copy me.sidx) + snap.stab (copy me.stab)) + snap)) + + (:method restore (me snap) + (replace-struct me snap)))) + + +(eval-only + (defmacro compile-in-toplevel (me . body) + (with-gensyms (saved-tregs saved-treg-cntr saved-nlev saved-discards) + ^(let* ((,saved-tregs (qref ,me tregs)) + (,saved-treg-cntr (qref ,me treg-cntr)) + (,saved-discards (qref ,me discards))) + (unwind-protect + (progn + (set (qref ,me tregs) nil + (qref ,me treg-cntr) 2 + (qref ,me discards) nil) + (prog1 + (progn ,*body) + (qref ,me (check-treg-leak)))) + (set (qref ,me tregs) ,saved-tregs + (qref ,me treg-cntr) ,saved-treg-cntr + (qref ,me discards) ,saved-discards))))) + + (defmacro compile-with-fresh-tregs (me . body) + (with-gensyms (saved-tregs saved-treg-cntr saved-discards) + ^(let* ((,saved-tregs (qref ,me tregs)) + (,saved-treg-cntr (qref ,me treg-cntr)) + (,saved-discards (qref ,me discards))) + (unwind-protect + (progn + (set (qref ,me tregs) nil + (qref ,me treg-cntr) 2 + (qref ,me discards) nil) + (prog1 + (progn ,*body) + (qref ,me (check-treg-leak)))) + (set (qref ,me tregs) ,saved-tregs + (qref ,me treg-cntr) ,saved-treg-cntr + (qref ,me discards) ,saved-discards))))) + + (defun with-spy (me flag spy spy-expr body push-meth pop-meth) + ^(let ((,spy (if ,flag ,spy-expr))) + (unwind-protect + (progn + (if ,spy (qref ,me (,push-meth ,spy))) + ,*body) + (if ,spy (qref ,me (,pop-meth ,spy)))))) + + (defmacro with-closure-spy (me flag spy spy-expr . body) + (with-spy me flag spy spy-expr body 'push-closure-spy 'pop-closure-spy)) + + (defmacro with-access-spy (me flag spy spy-expr . body) + (with-spy me flag spy spy-expr body 'push-access-spy 'pop-access-spy))) + +(defvarl %gcall-op% (relate '(apply usr:apply call) '(gapply gapply gcall))) + +(defvarl %call-op% (relate '(apply usr:apply call) '(apply apply call))) + +(defvarl %test-funs-pos% '(eq eql)) + +(defvarl %test-funs-neg% '(neq neql)) + +(defvarl %test-funs-ops% '(ifq ifql)) + +(defvarl %test-funs% (append %test-funs-pos% %test-funs-neg%)) + +(defvarl %test-inv% (relate %test-funs-neg% %test-funs-pos%)) + +(defvarl %test-opcode% (relate %test-funs-pos% %test-funs-ops%)) + +(defvarl %block-using-funs% '(sys:capture-cont return* sys:abscond* match-fun + eval load compile compile-file compile-toplevel)) + +(defvarl %nary-ops% '(< > <= => = + - * /)) + +(defvarl %bin-ops% '(b< b> b<= b=> b= b+ b- b* b/)) + +(defvarl %bin-op% (relate %nary-ops% %bin-ops% nil)) + +(defvarl %const-foldable-funs% + '(+ - * / sum prod abs trunc mod zerop nzerop plusp minusp evenp oddp + > < >= <= = /= wrap wrap* expt exptmod isqrt square gcd lcm floor ceil + round trunc-rem floor-rem ceil-rem round-rem sin cos tan asin acos atan + atan2 sinh cosh tanh asinh acosh atanh log log10 log2 exp sqrt + logand logior logxor logtest lognot logtrunc sign-extend ash bit mask + width logcount bitset cum-norm-dist inv-cum-norm n-choose-k n-perm-k + fixnump bignump floatp integerp numberp signum bignum-len divides sys:bits + digpow digits poly rpoly b< b> b<= b=> b= b+ b- b* b/ neg + pred ppred ppred pppred succ ssucc ssucc sssucc + car cdr caar cadr cdar cddr caaar caadr cadar caddr cdaar cdadr cddar cdddr + caaaar caaadr caadar caaddr cadaar cadadr caddar cadddr cdaaar cdaadr + cdadar cdaddr cddaar cddadr cdddar cddddr caaaaar caaaadr caaadar caaaddr + caadaar caadadr caaddar caadddr cadaaar cadaadr cadadar cadaddr caddaar + caddadr cadddar caddddr cdaaaar cdaaadr cdaadar cdaaddr cdadaar cdadadr + cdaddar cdadddr cddaaar cddaadr cddadar cddaddr cdddaar cdddadr cddddar + cdddddr cons first rest sub-list identity typeof atom null false true have + consp listp endp proper-listp length-list second third fourth fifth + sixth seventh eighth ninth tenth conses ldiff nthcdr nth tailp + memq memql memqual rmemq rmemql rmemqual countq countql countqual + posq posql posqual rposq rposql rposqual eq eql equal meq meql mequal + neq neql nequal max min clamp bracket take drop uniq if or and progn + prog1 prog2 nilf tf tostring tostringp display-width sys:fmt-simple + sys:fmt-flex join join-with sys:fmt-join packagep + symbolp keywordp bindable stringp length-str + coded-length cmp-str string-lt str= str< str> str<= str>= int-str + flo-str num-str int-flo flo-int tofloat toint tointz less greater + lequal gequal chrp chr-isalnum chr-isalnum chr-isalpha chr-isascii + chr-iscntrl chr-isdigit chr-digit chr-isgraph chr-islower chr-isprint + chr-ispunct chr-isspace chr-isblank chr-isunisp chr-isupper chr-isxdigit + chr-xdigit chr-toupper chr-tolower num-chr int-chr chr-num chr-int + chr-str span-str compl-span-str break-str vectorp length-vec size-vec + assq assql assoc rassq rassql rassoc prop memp length len empty ref + rangep from to in-range in-range* nullify)) + +(defvarl %const-foldable% (hash-list %const-foldable-funs% :eq-based)) + +(defvarl %effect-free-funs% + '(append append* revappend list list* zip interpose copy-list reverse + flatten flatten* flatcar flatcar* tuples remq remql remqual + keepq keepq keepqual remq* remql* remq* make-sym gensym + mkstring copy-str upcase-str downcase-str cat-str split-str spl + split-str-set sspl tok-str tok tok-where list-str trim-str + get-lines lazy-str length-str-> length-str->= length-str-< + length-str-<= vector vec vector-list list-vector list-vec + copy-vec sub-vec cat-vec acons acons-new aconsql-new alist-remove + copy-cons copy-tree copy-alist plist-to-alist improper-plist-to-alist + merge sort shuffle list-seq vec-seq str-seq copy sub seq-begin + iter-begin rcons make-like nullify symbol-value symbol-function + symbol-macro boundp fboundp mboundp special-operator-p special-var-p + copy-fun func-get-form func-get-name func-get-env functionp + interp-fun-p vm-fun-p fun-fixparam-count fun-optparam-count + fun-variadic sys:ctx-form sys:ctx-name range range* rlist rlist* + repeat pad weave promisep rperm perm comb rcomb source-loc + source-loc-str macro-ancestor cptr-int cptr-obj cptr-buf + int-cptr cptrp cptr-type cptr-size-hint)) + +(defvarl %effect-free% (hash-uni %const-foldable% + (hash-list %effect-free-funs% :eq-based))) + + +(defvarl %functional-funs% + '(chain chand juxt andf orf notf iff iffi dup flipargs if or and + progn prog1 prog2 retf apf ipf callf mapf tf nilf umethod uslot)) + +(defvarl %functional% (hash-list %functional-funs% :eq-based)) + +(defvarl assumed-fun) + +(defvar *in-compilation-unit* nil) + +(defvar *dedup*) + +(defvar *unchecked-calls*) + +(defvarl %param-info% (hash :eq-based :weak-keys)) + +(defvar *load-time*) + +;; 0 - no optimization +;; 1 - constant folding, algebraics. +;; 2 - block elimination, frame elimination +;; 3 - lambda/combinator lifting +;; 4 - control-flow: jump-threading, dead code +;; 5 - data-flow: dead registers, useless regisers +;; 6 - more expensive size or speed optimizations +(defvar usr:*opt-level* 6) + +(defun dedup (obj) + (cond + ((null obj) nil) + ((null *dedup*) obj) + ((or (stringp obj) (bignump obj)) + (or [*dedup* obj] (set [*dedup* obj] obj))) + (t obj))) + +(defun null-reg (reg) + (equal reg '(t 0))) + +(defmeth compiler get-dreg (me obj) + (let ((dobj (dedup obj))) + (condlet + ((((null dobj))) '(t 0)) + (((dreg [me.dreg dobj])) dreg) + ((((< me.dreg-cntr %lev-size%))) + (let ((dreg ^(d ,(pinc me.dreg-cntr)))) + (set [me.data (cadr dreg)] dobj) + (set [me.dreg dobj] dreg))) + (t (compile-error me.last-form "code too complex: too many literals"))))) + +(defmeth compiler alloc-dreg (me) + (if (< me.dreg-cntr %lev-size%) + (let ((dreg ^(d ,(pinc me.dreg-cntr)))) + (set [me.data (cadr dreg)] nil) + dreg) + (compile-error me.last-form "code too complex: too many literals"))) + +(defmeth compiler get-sidx (me atom) + (iflet ((sidx [me.sidx atom])) + sidx + (let* ((sidx (pinc me.sidx-cntr))) + (set [me.stab sidx] atom) + (set [me.sidx atom] sidx)))) + +(defmeth compiler get-datavec (me) + (or me.datavec + (set me.datavec (vec-list [mapcar me.data (range* 0 me.dreg-cntr)])))) + +(defmeth compiler get-symvec (me) + (or me.symvec + (set me.symvec (vec-list [mapcar me.stab (range* 0 me.sidx-cntr)])))) + +(defmeth compiler alloc-treg (me) + (cond + (me.tregs (pop me.tregs)) + ((< me.treg-cntr %lev-size%) ^(t ,(pinc me.treg-cntr))) + (t (compile-error me.last-form "code too complex: out of registers")))) + +(defmeth compiler alloc-new-treg (me) + (cond + ((< me.treg-cntr %lev-size%) ^(t ,(pinc me.treg-cntr))) + (t (compile-error me.last-form "code too complex: out of registers")))) + +(defmeth compiler alloc-discard-treg (me) + (let ((treg me.(alloc-treg))) + (push treg me.discards) + treg)) + +(defmeth compiler free-treg (me treg) + (when (and (eq t (car treg)) (neq 0 (cadr treg))) + (when me.discards + (set me.discards (remqual treg me.discards))) + (push treg me.tregs))) + +(defmeth compiler free-tregs (me tregs) + (mapdo (meth me free-treg) tregs)) + +(defmeth compiler unalloc-reg-count (me) + (- %lev-size% me.treg-cntr)) + +(defmeth compiler maybe-alloc-treg (me given) + (if (and (eq t (car given)) (not (member given me.discards))) + given + me.(alloc-treg))) + +(defmeth compiler maybe-free-treg (me treg given) + (when (nequal treg given) + me.(free-treg treg))) + +(defmeth compiler check-treg-leak (me) + (let ((balance (- (ppred me.treg-cntr) (len me.tregs)))) + (unless (zerop balance) + (error "t-register leak in compiler: ~s outstanding" balance)))) + +(defmeth compiler maybe-mov (me to-reg from-reg) + (if (and (nequal to-reg from-reg) (not (member to-reg me.discards))) + ^((mov ,to-reg ,from-reg)))) + +(defmeth compiler new-env (me env) + (when (>= env.lev me.nlev) + (unless (<= env.lev %max-lev%) + (compile-error me.last-form + "code too complex: lexical nesting too deep")) + (set me.nlev (succ env.lev)))) + +(defmeth compiler push-closure-spy (me spy) + (push spy me.closure-spies)) + +(defmeth compiler pop-closure-spy (me spy) + (let ((top (pop me.closure-spies))) + (unless top + (error "closure spy stack bug in compiler")) + (unless (eq top spy) + (error "closure spy stack balance problem in compiler")))) + +(defmeth compiler push-access-spy (me spy) + (push spy me.access-spies)) + +(defmeth compiler pop-access-spy (me spy) + (let ((top (pop me.access-spies))) + (unless top + (error "access spy stack bug in compiler")) + (unless (eq top spy) + (error "access spy stack balance problem in compiler")))) + +(defmeth compiler compile (me oreg env form) + (set me.last-form form) + (cond + ((symbolp form) + (if (bindable form) + me.(comp-var oreg env form) + me.(comp-atom oreg form))) + ((atom form) me.(comp-atom oreg form)) + (t (let ((sym (car form))) + (cond + ((bindable sym) + (caseq sym + (quote me.(comp-atom oreg (cadr form))) + (sys:setq me.(comp-setq oreg env form)) + (sys:lisp1-setq me.(comp-lisp1-setq oreg env form)) + (sys:setqf me.(comp-setqf oreg env form)) + (cond me.(comp-cond oreg env form)) + (if me.(comp-if oreg env form)) + (switch me.(comp-switch oreg env form)) + (unwind-protect me.(comp-unwind-protect oreg env form)) + ((block block* sys:blk) me.(comp-block oreg env form)) + ((return-from sys:abscond-from) me.(comp-return-from oreg env form)) + (return me.(comp-return oreg env form)) + (handler-bind me.(comp-handler-bind oreg env form)) + (sys:catch me.(comp-catch oreg env form)) + ((let let*) me.(comp-let oreg env form)) + ((sys:fbind sys:lbind) me.(comp-fbind oreg env form)) + (lambda me.(comp-lambda oreg env form)) + (fun me.(comp-fun oreg env form)) + (sys:for-op me.(comp-for oreg env form)) + (sys:each-op me.(compile oreg env (expand-each form env))) + ((progn eval-only compile-only) me.(comp-progn oreg env (cdr form))) + (and me.(compile oreg env (expand-and form))) + (or me.(comp-or oreg env form)) + (prog1 me.(comp-prog1 oreg env form)) + (sys:quasi me.(comp-quasi oreg env form)) + (dohash me.(compile oreg env (expand-dohash form))) + (tree-bind me.(comp-tree-bind oreg env form)) + (mac-param-bind me.(comp-mac-param-bind oreg env form)) + (mac-env-param-bind me.(comp-mac-env-param-bind oreg env form)) + (tree-case me.(comp-tree-case oreg env form)) + (sys:lisp1-value me.(comp-lisp1-value oreg env form)) + (dwim me.(comp-dwim oreg env form)) + (prof me.(comp-prof oreg env form)) + (defvarl me.(compile oreg env (expand-defvarl form))) + (defun me.(compile oreg env (expand-defun form))) + (defmacro me.(compile oreg env (expand-defmacro form))) + (defsymacro me.(compile oreg env (expand-defsymacro form))) + (sys:upenv me.(compile oreg env.up (cadr form))) + (sys:dvbind me.(compile oreg env (caddr form))) + (sys:load-time-lit me.(comp-load-time-lit oreg env form)) + ;; compiler-only special operators: + (ift me.(comp-ift oreg env form)) + ;; specially treated functions + ((call apply usr:apply) me.(comp-apply-call oreg env form)) + ;; error cases + ((macrolet symacrolet macro-time) + (compile-error form "unexpanded ~s encountered" sym)) + ((sys:var sys:expr) + (compile-error form "meta with no meaning: ~s " form)) + ((usr:qquote usr:unquote usr:splice + sys:qquote sys:unquote sys:splice) + (compile-error form "unexpanded quasiquote encountered")) + ;; function call + ((+ *) me.(comp-arith-form oreg env form)) + ((- /) me.(comp-arith-neg-form oreg env form)) + (t me.(comp-fun-form oreg env form)))) + ((and (consp sym) + (eq (car sym) 'lambda)) me.(compile oreg env ^(call ,*form))) + (t (compile-error form "invalid operator"))))))) + +(defmeth compiler comp-atom (me oreg form) + (cond + ((null form) (new (frag '(t 0) nil))) + (t (let ((dreg me.(get-dreg form))) + (new (frag dreg nil)))))) + +(defmeth compiler comp-var (me oreg env sym) + (let ((vbin env.(lookup-var sym))) + (cond + (vbin + (each ((spy me.access-spies)) + spy.(accessed vbin sym)) + (new (frag vbin.loc nil (list sym)))) + ((special-var-p sym) + (let ((dreg me.(get-dreg sym))) + (new (frag oreg ^((getv ,oreg ,dreg)) (list sym))))) + (t (new (frag oreg ^((getlx ,oreg ,me.(get-sidx sym))) (list sym))))))) + +(defmeth compiler comp-setq (me oreg env form) + (mac-param-bind form (op sym value) form + (let* ((bind env.(lookup-var sym)) + (spec (special-var-p sym)) + (vloc (cond + (bind bind.loc) + (spec me.(get-dreg sym)) + (t me.(get-sidx sym)))) + (vfrag me.(compile (if bind vloc oreg) env value))) + (when bind + (each ((spy me.access-spies)) + spy.(assigned bind sym))) + (new (frag vfrag.oreg + ^(,*vfrag.code + ,*(if bind + me.(maybe-mov vloc vfrag.oreg) + (if spec + ^((setv ,vfrag.oreg ,vloc)) + ^((setlx ,vfrag.oreg ,me.(get-sidx sym)))))) + (uni (list sym) vfrag.fvars) + vfrag.ffuns))))) + +(defmeth compiler comp-lisp1-setq (me oreg env form) + (mac-param-bind form (op sym val) form + (let ((bind env.(lookup-lisp1 sym))) + (cond + ((typep bind 'fbinding) + (compile-error form "assignment to lexical function binding")) + ((null bind) + (let ((vfrag me.(compile oreg env val)) + (l1loc me.(get-dreg sym))) + (new (frag vfrag.oreg + ^(,*vfrag.code + (setl1 ,vfrag.oreg ,l1loc)) + (uni (list sym) vfrag.fvars) + vfrag.ffuns)))) + (t (each ((spy me.access-spies)) + spy.(assigned bind sym)) + me.(compile oreg env ^(sys:setq ,sym ,val))))))) + +(defmeth compiler comp-setqf (me oreg env form) + (mac-param-bind form (op sym val) form + (if env.(lookup-fun sym) + (compile-error form "assignment to lexical function binding") + (let ((vfrag me.(compile oreg env val)) + (fname me.(get-dreg sym)) + (rplcd me.(get-sidx 'usr:rplacd)) + (treg me.(alloc-treg))) + me.(free-treg treg) + (new (frag vfrag.oreg + ^(,*vfrag.code + (getfb ,treg ,fname) + (gcall ,treg ,rplcd ,treg ,vfrag.oreg)) + vfrag.fvars + (uni (list sym) vfrag.ffuns))))))) + +(defmeth compiler comp-cond (me oreg env form) + (tree-case form + ((op) me.(comp-atom oreg nil)) + ((op (test) . more) me.(compile oreg env ^(or ,test (cond ,*more)))) + ((op (test . forms) . more) me.(compile oreg env + ^(if ,test + (progn ,*forms) + (cond ,*more)))) + ((op atom . more) + (compile-error form "atom in cond syntax; pair expected")) + ((op . atom) + (compile-error form "trailing atom in cond syntax")))) + +(defmeth compiler comp-if (me oreg env form) + (match-case (cdr form) + (@(require ((@(and @(or equal nequal) @op) @a @b) . @rest) + (or (eql-comparable a) + (eql-comparable b))) + (let* ((pos (eq op 'equal)) + (cf (if (or (eq-comparable a) + (eq-comparable b)) + (if pos 'eq 'neq) + (if pos'eql 'neql)))) + me.(compile oreg env ^(if (,cf ,a ,b) ,*rest)))) + (((not (@(and @(or eq eql equal) @op) . @eargs)) . @args) + (let ((nop (caseq op (eq 'neq) (eql 'neql) (equal 'nequal)))) + me.(comp-if oreg env ^(if (,nop ,*eargs) ,*args)))) + ((@(constantp @test) @then @else) + me.(compile oreg env (if (eval test) then else))) + ((@(constantp @test) @then) + me.(compile oreg env (if (eval test) then))) + ((@(constantp @test)) + me.(compile oreg env nil)) + (((@(member @op %test-funs%) @a @b) . @rest) + me.(compile oreg env ^(ift ,op ,a ,b ,*rest))) + ((@test @then @else) + (let* ((te-oreg me.(maybe-alloc-treg oreg)) + (lelse (gensym "l")) + (lskip (gensym "l")) + (te-frag me.(compile te-oreg env test)) + (th-frag me.(compile oreg env then)) + (el-frag me.(compile oreg env else))) + me.(maybe-free-treg te-oreg oreg) + (new (frag oreg + ^(,*te-frag.code + (if ,te-frag.oreg ,lelse) + ,*th-frag.code + ,*me.(maybe-mov oreg th-frag.oreg) + (jmp ,lskip) + ,lelse + ,*el-frag.code + ,*me.(maybe-mov oreg el-frag.oreg) + ,lskip) + (uni te-frag.fvars (uni th-frag.fvars el-frag.fvars)) + (uni te-frag.ffuns (uni th-frag.ffuns el-frag.ffuns)))))) + ((@test @then) + (let* ((lskip (gensym "l")) + (te-oreg me.(maybe-alloc-treg oreg)) + (te-frag me.(compile te-oreg env test)) + (th-frag me.(compile oreg env then))) + me.(maybe-free-treg te-oreg oreg) + (new (frag oreg + ^(,*te-frag.code + ,*me.(maybe-mov oreg te-frag.oreg) + (if ,te-frag.oreg ,lskip) + ,*th-frag.code + ,*me.(maybe-mov oreg th-frag.oreg) + ,lskip) + (uni te-frag.fvars th-frag.fvars) + (uni te-frag.ffuns th-frag.ffuns))))) + ((@test) + (let ((te-frag me.(compile oreg env test))) + (new (frag oreg + ^(,*te-frag.code + (mov ,oreg nil)) + te-frag.fvars + te-frag.ffuns)))) + (() me.(compile oreg env nil)) + (@else (compile-error form "excess argument forms")))) + +(defmeth compiler comp-ift (me oreg env form) + (mac-param-bind form (op fun left right : then else) form + (when (member fun %test-funs-neg%) + (set fun [%test-inv% fun]) + (swap then else)) + (if (and (constantp left) (constantp right)) + me.(compile oreg env (if (call fun (eval left) (eval right)) then else)) + (let* ((opcode [%test-opcode% fun]) + (le-oreg me.(alloc-treg)) + (ri-oreg me.(alloc-treg)) + (lelse (gensym "l")) + (lskip (gensym "l")) + (le-frag me.(compile le-oreg env left)) + (ri-frag me.(compile ri-oreg env right)) + (th-frag me.(compile oreg env then)) + (el-frag me.(compile oreg env else))) + me.(free-treg le-oreg) + me.(free-treg ri-oreg) + (new (frag oreg + ^(,*le-frag.code + ,*ri-frag.code + (,opcode ,le-frag.oreg ,ri-frag.oreg ,lelse) + ,*th-frag.code + ,*me.(maybe-mov oreg th-frag.oreg) + (jmp ,lskip) + ,lelse + ,*el-frag.code + ,*me.(maybe-mov oreg el-frag.oreg) + ,lskip) + (uni (uni le-frag.fvars ri-frag.fvars) + (uni th-frag.fvars el-frag.fvars)) + (uni (uni le-frag.ffuns ri-frag.ffuns) + (uni th-frag.ffuns el-frag.ffuns)))))))) + +(defmeth compiler comp-switch (me oreg env form) + (mac-param-bind form (op idx-form cases-vec) form + (let* ((ncases (len cases-vec)) + (cs (and (plusp ncases) (conses [cases-vec 0]))) + (shared (and cs + (let ((c cs) + (d (cdr (list-vec cases-vec)))) + (whilet ((m (if d (memq (pop d) c)))) + (set c m)) + (null d)))) + (cases (if shared + (let ((cs-nil ^(,*cs nil))) + (vec-list [mapcar ldiff cs-nil (cdr cs-nil)])) + cases-vec)) + (lend (gensym "l")) + (clabels (mapcar (ret (gensym "l")) cases)) + (treg me.(maybe-alloc-treg oreg)) + (ifrag me.(compile treg env idx-form)) + (seen (unless shared (hash :eql-based))) + last-cfrag + (cfrags (collect-each ((cs cases) + (lb clabels) + (i (range 1))) + (iflet ((seen-lb (and seen [seen cs]))) + (progn + (set [clabels (pred i)] seen-lb) + (new (frag oreg nil))) + (let ((cfrag me.(comp-progn oreg env cs))) + (when (eq i ncases) + (set last-cfrag cfrag)) + (unless shared + (set [seen cs] lb)) + (new (frag oreg + ^(,lb + ,*cfrag.code + ,*(unless shared + ^(,*me.(maybe-mov oreg cfrag.oreg) + ,*(unless (= i ncases) + ^((jmp ,lend)))))) + cfrag.fvars cfrag.ffuns))))))) + me.(maybe-free-treg treg oreg) + (new (frag oreg + ^(,*ifrag.code + (swtch ,ifrag.oreg ,*(list-vec clabels)) + ,*(mappend .code cfrags) + ,*(when (and shared last-cfrag) + me.(maybe-mov oreg last-cfrag.oreg)) + ,lend) + (uni ifrag.fvars [reduce-left uni cfrags nil .fvars]) + (uni ifrag.ffuns [reduce-left uni cfrags nil .ffuns])))))) + +(defmeth compiler comp-unwind-protect (me oreg env form) + (mac-param-bind form (op prot-form . cleanup-body) form + (let* ((treg me.(alloc-treg)) + (pfrag me.(compile oreg env prot-form)) + (cfrag me.(comp-progn treg env cleanup-body)) + (lclean (gensym "l"))) + me.(free-treg treg) + (cond + ((null pfrag.code) + (new (frag pfrag.oreg + cfrag.code + cfrag.fvars + cfrag.ffuns))) + ((null cfrag.code) pfrag) + (t (new (frag pfrag.oreg + ^((uwprot ,lclean) + ,*pfrag.code + (end nil) + ,lclean + ,*cfrag.code + (end nil)) + (uni pfrag.fvars pfrag.fvars) + (uni cfrag.fvars cfrag.fvars)))))))) + +(defmeth compiler comp-block (me oreg env form) + (mac-param-bind form (op name . body) form + (let* ((star (and name (eq op 'block*))) + (nenv (unless star + (new env up env lev env.lev co me))) + (binfo (unless star + (cdar nenv.(extend-block name)))) + (treg (if star me.(maybe-alloc-treg oreg))) + (nfrag (if star me.(compile treg env name))) + (nreg (if star nfrag.oreg me.(get-dreg name))) + (bfrag me.(comp-progn oreg (or nenv env) body)) + (lskip (gensym "l"))) + (when treg + me.(maybe-free-treg treg oreg)) + (if (and (>= *opt-level* 2) + (not star) + (not binfo.used) + (if (eq op 'sys:blk) + [all bfrag.ffuns [orf system-symbol-p (op eq name)]] + [all bfrag.ffuns system-symbol-p]) + [none bfrag.ffuns (op member @1 %block-using-funs%)]) + bfrag + (new (frag oreg + ^(,*(if nfrag nfrag.code) + (block ,oreg ,nreg ,lskip) + ,*bfrag.code + ,*me.(maybe-mov oreg bfrag.oreg) + (end ,oreg) + ,lskip) + bfrag.fvars + bfrag.ffuns)))))) + +(defmeth compiler comp-return-from (me oreg env form) + (mac-param-bind form (op name : value) form + (let* ((nreg (if (null name) + nil + me.(get-dreg name))) + (opcode (if (eq op 'return-from) 'ret 'abscsr)) + (vfrag me.(compile oreg env value)) + (binfo env.(lookup-block name t))) + (new (frag oreg + ^(,*vfrag.code + (,opcode ,nreg ,vfrag.oreg)) + vfrag.fvars + vfrag.ffuns))))) + +(defmeth compiler comp-return (me oreg env form) + (mac-param-bind form (op : value) form + me.(comp-return-from oreg env ^(return-from nil ,value)))) + +(defmeth compiler comp-handler-bind (me oreg env form) + (mac-param-bind form (op func-form ex-syms . body) form + (let* ((freg me.(maybe-alloc-treg oreg)) + (ffrag me.(compile freg env func-form)) + (sreg me.(get-dreg ex-syms)) + (bfrag me.(comp-progn oreg env body))) + me.(maybe-free-treg freg oreg) + (new (frag bfrag.oreg + ^(,*ffrag.code + (handle ,ffrag.oreg ,sreg) + ,*bfrag.code + (end ,bfrag.oreg)) + (uni ffrag.fvars bfrag.fvars) + (uni ffrag.ffuns bfrag.ffuns)))))) + +(defmeth compiler comp-catch (me oreg env form) + (mac-param-bind form (op symbols try-expr desc-expr . clauses) form + (with-gensyms (ex-sym-var ex-args-var) + (let* ((nenv (new env up env co me)) + (esvb (cdar nenv.(extend-var ex-sym-var))) + (eavb (cdar nenv.(extend-var ex-args-var))) + (tfrag me.(compile oreg nenv try-expr)) + (dfrag me.(compile oreg nenv desc-expr)) + (coreg (if (equal tfrag.oreg '(t 0)) oreg tfrag.oreg)) + (lhand (gensym "l")) + (lhend (gensym "l")) + (treg me.(alloc-treg)) + (nclauses (len clauses)) + (cfrags (collect-each ((cl clauses) + (i (range 1))) + (mac-param-bind form (sym params . body) cl + (let* ((cl-src ^(apply (lambda ,params ,*body) + ,ex-sym-var ,ex-args-var)) + (cfrag me.(compile coreg nenv (expand cl-src))) + (lskip (gensym "l"))) + (new (frag coreg + ^((gcall ,treg + ,me.(get-sidx 'exception-subtype-p) + ,esvb.loc + ,me.(get-dreg sym)) + (if ,treg ,lskip) + ,*cfrag.code + ,*me.(maybe-mov coreg cfrag.oreg) + ,*(unless (eql i nclauses) + ^((jmp ,lhend))) + ,lskip) + cfrag.fvars + cfrag.ffuns))))))) + me.(free-treg treg) + (new (frag coreg + ^((frame ,nenv.lev ,nenv.v-cntr) + ,*dfrag.code + (catch ,esvb.loc ,eavb.loc + ,me.(get-dreg symbols) ,dfrag.oreg ,lhand) + ,*tfrag.code + ,*me.(maybe-mov coreg tfrag.oreg) + (jmp ,lhend) + ,lhand + ,*(mappend .code cfrags) + ,lhend + (end ,coreg) + (end ,coreg)) + (uni tfrag.fvars [reduce-left uni cfrags nil .fvars]) + (uni tfrag.ffuns [reduce-left uni cfrags nil .ffuns]))))))) + +(defmeth compiler eliminate-frame (me code env) + (if (>= me.(unalloc-reg-count) (len env.vb)) + (let ((trhash (hash)) + (vbhash (hash)) + (vlev (ppred env.lev)) + (tregs nil)) + (each ((cell env.vb)) + (tree-bind (sym . vbind) cell + (let ((treg me.(alloc-new-treg))) + (set [trhash vbind.loc] treg) + (set [vbhash vbind.loc] vbind) + (push treg tregs)))) + (let ((ncode (append-each ((insns (conses code))) + (match-case insns + (((frame @lev @size) . @rest) + ^((frame ,(pred lev) ,size))) + (((dframe @lev @size) . @rest) + ^((dframe ,(pred lev) ,size))) + (((@op . @args) . @rest) + (let ((nargs (mapcar (lambda-match + ((@(as arg (v @lev @idx))) + (or [trhash arg] + (if (> lev vlev) + ^(v ,(pred lev) ,idx) + arg))) + ((@arg) arg)) + args))) + ^((,op ,*nargs)))) + ((@else . @rest) (list else)))))) + (dohash (loc treg trhash) + (let ((vb [vbhash loc])) + (set vb.loc treg) + me.(free-treg treg))) + (if (plusp me.loop-nest) + (append (mapcar (ret ^(mov ,@1 (t 0))) (nreverse tregs)) ncode) + ncode))) + code)) + +(defmeth compiler comp-let (me oreg env form) + (mac-param-bind form (sym raw-vis . body) form + (let* ((vis (mapcar [iffi atom list] raw-vis)) + (specials [keep-if special-var-p vis car]) + (lexsyms [remove-if special-var-p [mapcar car vis]]) + allsyms + (specials-occur [find-if special-var-p vis car]) + (treg (if specials-occur me.(alloc-treg))) + (frsize (len lexsyms)) + (seq (eq sym 'let*)) + (nenv (new env up env co me)) + (fenv (if seq nenv (new env up env co me)))) + (with-closure-spy me (and (not specials-occur) + (>= *opt-level* 2)) + cspy (new closure-spy env nenv) + (unless seq + (each ((lsym lexsyms)) + nenv.(extend-var lsym))) + (let* (ffuns fvars + (code (build + (add ^(,(if specials-occur 'dframe 'frame) + ,nenv.lev ,frsize)) + (each ((vi vis)) + (tree-bind (sym : form) vi + (push sym allsyms) + (cond + ((special-var-p sym) + (let ((frag me.(compile treg fenv form)) + (dreg me.(get-dreg sym))) + (pend frag.code) + (add ^(bindv ,frag.oreg ,dreg)) + (set ffuns (uni ffuns frag.ffuns) + fvars (uni fvars + (if seq + (diff frag.fvars + (cdr allsyms)) + frag.fvars))))) + (form + (let* ((tmp (if seq (gensym))) + (bind (if seq + (cdar nenv.(extend-var tmp)) + nenv.(lookup-var sym))) + (frag me.(compile bind.loc fenv form))) + (when seq + fenv.(rename-var tmp sym)) + (pend frag.code) + (unless (null-reg frag.oreg) + (pend me.(maybe-mov bind.loc frag.oreg))) + (set ffuns (uni ffuns frag.ffuns) + fvars (uni fvars + (if seq + (diff frag.fvars + (cdr allsyms)) + frag.fvars))))) + (t (if seq nenv.(extend-var* sym)))))))) + (bfrag me.(comp-progn oreg nenv body)) + (boreg (if env.(out-of-scope bfrag.oreg) oreg bfrag.oreg)) + (code (append code bfrag.code + me.(maybe-mov boreg bfrag.oreg) + ^((end ,boreg))))) + (when (and cspy (null cspy.cap-vars)) + (set code me.(eliminate-frame [code 1..-1] nenv))) + (when treg + me.(free-treg treg)) + (new (frag boreg + code + (uni (diff bfrag.fvars allsyms) fvars) + (uni ffuns bfrag.ffuns)))))))) + +(defmeth compiler comp-fbind (me oreg env form) + (mac-param-bind form (sym raw-fis . body) form + (let* ((fis (mapcar [iffi atom list] raw-fis)) + (lexfuns [mapcar car fis]) + (frsize (len lexfuns)) + (rec (eq sym 'sys:lbind)) + (eenv (unless rec (new env up env co me))) + (nenv (new env up env co me))) + (each ((lfun lexfuns)) + nenv.(extend-fun lfun)) + (let* (ffuns fvars + (ffrags (collect-each ((fi fis)) + (tree-bind (sym : form) fi + (let* ((bind nenv.(lookup-fun sym)) + (frag me.(compile bind.loc + (if rec nenv eenv) + form))) + (set bind.pars frag.pars) + (list bind + (new (frag frag.oreg + (append frag.code + me.(maybe-mov bind.loc frag.oreg)) + frag.fvars + frag.ffuns))))))) + (bfrag me.(comp-progn oreg nenv body)) + (boreg (if env.(out-of-scope bfrag.oreg) oreg bfrag.oreg))) + (set ffrags (append-each ((bf ffrags)) + (tree-bind (bind ff) bf + (when bind.used + (set ffuns (uni ffuns ff.ffuns) + fvars (uni fvars ff.fvars)) + (list ff))))) + (new (frag boreg + (append ^((frame ,nenv.lev ,frsize)) + (mappend .code ffrags) + bfrag.code + me.(maybe-mov boreg bfrag.oreg) + ^((end ,boreg))) + (uni fvars bfrag.fvars) + (uni (diff bfrag.ffuns lexfuns) + (if rec (diff ffuns lexfuns) ffuns)))))))) + +(defmeth compiler comp-lambda-impl (me oreg env form) + (mac-param-bind form (op par-syntax . body) form + (with-access-spy me me.closure-spies + spy (new access-spy + closure-spies me.closure-spies) + (compile-with-fresh-tregs me + (let* ((*load-time* nil) + (pars (new (fun-param-parser par-syntax form))) + (need-frame (or (plusp pars.nfix) pars.rest)) + (nenv (if need-frame (new env up env co me) env)) + lexsyms fvars specials need-dframe) + (when (> pars.nfix %max-lambda-fixed-args%) + (compile-warning form "~s arguments in a lambda (max is ~s)" + pars.nfix %max-lambda-fixed-args%)) + (flet ((spec-sub (sym) + (cond + ((special-var-p sym) + (let ((sub (gensym))) + (push (cons sym sub) specials) + (set need-dframe t) + nenv.(extend-var sub) + sub)) + (t + (push sym lexsyms) + nenv.(extend-var sym) + sym)))) + (let* ((req-pars (collect-each ((rp pars.req)) + (spec-sub rp))) + (opt-pars (collect-each ((op pars.opt)) + (tree-bind (var-sym : init-form have-sym) op + (list (spec-sub var-sym) + init-form + (if have-sym (spec-sub have-sym)))))) + (rest-par (when pars.rest (spec-sub pars.rest))) + (allsyms req-pars)) + (upd specials nreverse) + (with-closure-spy me (and (not specials) + (>= *opt-level* 2)) + cspy (new closure-spy env nenv) + (let* ((col-reg (if opt-pars me.(get-dreg :))) + (tee-reg (if opt-pars me.(get-dreg t))) + (ifrags (collect-each ((op opt-pars)) + (tree-bind (var-sym init-form have-sym) op + (let* ((vbind nenv.(lookup-var var-sym)) + (ifrag me.(compile vbind.loc nenv init-form))) + (set fvars (uni fvars + (diff ifrag.fvars allsyms))) + (push var-sym allsyms) + (push have-sym allsyms) + ifrag)))) + (opt-code (append-each ((op opt-pars) + (ifrg ifrags)) + (tree-bind (var-sym init-form have-sym) op + (let ((vbind nenv.(lookup-var var-sym)) + (have-bind nenv.(lookup-var have-sym)) + (lskip (gensym "l"))) + ^(,*(if have-sym + ^((mov ,have-bind.loc ,tee-reg))) + (ifq ,vbind.loc ,col-reg ,lskip) + ,*(if have-sym + ^((mov ,have-bind.loc nil))) + ,*ifrg.code + ,*me.(maybe-mov vbind.loc ifrg.oreg) + ,lskip + ,*(whenlet ((spec-sub [find var-sym specials : cdr])) + (set specials [remq var-sym specials cdr]) + ^((bindv ,vbind.loc ,me.(get-dreg (car spec-sub))))) + ,*(whenlet ((spec-sub [find have-sym specials : cdr])) + (set specials [remq have-sym specials cdr]) + ^((bindv ,have-bind.loc ,me.(get-dreg (car spec-sub)))))))))) + (benv (if need-dframe (new env up nenv co me) nenv)) + (btreg me.(alloc-treg)) + (bfrag me.(comp-progn btreg benv body)) + (boreg (if env.(out-of-scope bfrag.oreg) btreg bfrag.oreg)) + (lskip (gensym "l")) + (frsize (if need-frame nenv.v-cntr 0)) + (code ^((close ,oreg ,frsize ,me.treg-cntr ,lskip + ,pars.nfix ,pars.nreq ,(if rest-par t nil) + ,*(collect-each ((rp req-pars)) + nenv.(lookup-var rp).loc) + ,*(collect-each ((op opt-pars)) + nenv.(lookup-var (car op)).loc) + ,*(if rest-par + (list nenv.(lookup-var rest-par).loc))) + ,*(if need-dframe + ^((dframe ,benv.lev 0))) + ,*(if specials + (collect-each ((vs specials)) + (tree-bind (special . gensym) vs + (let ((sub-bind nenv.(lookup-var gensym)) + (dreg me.(get-dreg special))) + ^(bindv ,sub-bind.loc ,dreg))))) + ,*opt-code + ,*bfrag.code + ,*(if need-dframe + ^((end ,boreg))) + ,*me.(maybe-mov boreg bfrag.oreg) + (jend ,boreg) + ,lskip))) + me.(free-treg btreg) + (when (and cspy (plusp frsize) (null cspy.cap-vars)) + (when-match ((close @reg @frsize @nreg . @irest) . @crest) + me.(eliminate-frame code nenv) + (set code ^((close ,reg 0 ,me.treg-cntr ,*irest) + ,*crest)))) + (new (frag oreg code + (uni fvars (diff bfrag.fvars lexsyms)) + (uni [reduce-left uni ifrags nil .ffuns] + bfrag.ffuns) + pars))))))))))) + +(defmeth compiler comp-lambda (me oreg env form) + (if (or *load-time* (< *opt-level* 3)) + me.(comp-lambda-impl oreg env form) + (let* ((snap me.(snapshot)) + (lambda-frag me.(comp-lambda-impl oreg env form)) + (ok-lift-var-pov (all lambda-frag.fvars + (lambda (sym) + (not env.(lookup-var sym))))) + (ok-lift-fun-pov (all lambda-frag.ffuns + (lambda (sym) + (not env.(lookup-fun sym)))))) + (cond + ((and ok-lift-var-pov ok-lift-fun-pov) + me.(restore snap) + me.(compile oreg env ^(sys:load-time-lit nil ,form))) + (t lambda-frag))))) + +(defmeth compiler comp-fun (me oreg env form) + (mac-param-bind form (op arg) form + (let ((fbin env.(lookup-fun arg t))) + (cond + (fbin (new (frag fbin.loc nil nil (list arg)))) + ((and (consp arg) (eq (car arg) 'lambda)) + me.(compile oreg env arg)) + (t (new (frag oreg ^((getf ,oreg ,me.(get-sidx arg))) + nil (list arg)))))))) + +(defmeth compiler comp-progn (me oreg env args) + (let* (ffuns fvars + (lead-forms (butlastn 1 args)) + (last-form (nthlast 1 args)) + (eff-lead-forms (remove-if [orf constantp symbolp] lead-forms)) + (forms (append eff-lead-forms last-form)) + (nargs (len forms)) + lastfrag + (oreg-discard me.(alloc-discard-treg)) + (code (build + (each ((form forms) + (n (range 1))) + (let ((islast (eql n nargs))) + (let ((frag me.(compile (if islast oreg oreg-discard) + env form))) + (when islast + (set lastfrag frag)) + (set fvars (uni fvars frag.fvars)) + (set ffuns (uni ffuns frag.ffuns)) + (pend frag.code))))))) + me.(free-treg oreg-discard) + (new (frag (if lastfrag lastfrag.oreg ^(t 0)) code fvars ffuns)))) + +(defmeth compiler comp-or (me oreg env form) + (tree-case (simplify-or form) + ((op) me.(compile oreg env nil)) + ((op arg) me.(compile oreg env arg)) + ((op . args) + (let* (ffuns fvars + (nargs (len args)) + lastfrag + (lout (gensym "l")) + (treg me.(maybe-alloc-treg oreg)) + (code (build + (each ((form args) + (n (range 1))) + (let ((islast (eql n nargs))) + (let ((frag me.(compile treg env form))) + (when islast + (set lastfrag frag)) + (pend frag.code + me.(maybe-mov treg frag.oreg)) + (unless islast + (add ^(ifq ,treg (t 0) ,lout))) + (set fvars (uni fvars frag.fvars)) + (set ffuns (uni ffuns frag.ffuns)))))))) + me.(maybe-free-treg treg oreg) + (new (frag oreg + (append code ^(,lout + ,*me.(maybe-mov oreg treg))) + fvars ffuns)))))) + +(defmeth compiler comp-prog1 (me oreg env form) + (tree-case form + ((prog1 fi . re) (let* ((igreg me.(alloc-discard-treg)) + (fireg me.(maybe-alloc-treg oreg)) + (fi-frag me.(compile fireg env fi)) + (re-frag me.(comp-progn igreg env + (append re '(nil))))) + me.(maybe-free-treg fireg oreg) + me.(free-treg igreg) + (new (frag fireg + (append fi-frag.code + me.(maybe-mov fireg fi-frag.oreg) + re-frag.code) + (uni fi-frag.fvars re-frag.fvars) + (uni fi-frag.ffuns re-frag.ffuns))))) + ((prog1 fi) me.(compile oreg env fi)) + ((prog1) me.(compile oreg env nil)))) + +(defmeth compiler comp-quasi (me oreg env form) + (let ((qexp (expand-quasi form))) + me.(compile oreg env (expand qexp)))) + +(defmeth compiler comp-arith-form (me oreg env form) + (if (plusp *opt-level*) + (let ((rform (reduce-constant env form))) + (tree-case rform + ((op . args) + (let* ((pargs [partition-by constantp args]) + (fargs (append-each ((pa pargs)) + (if (and (constantp (car pa)) + (all pa [chain eval integerp])) + (list (eval ^(,op ,*pa))) + pa)))) + me.(comp-fun-form oreg env ^(,op ,*fargs)))) + (else me.(compile oreg env rform)))) + me.(comp-fun-form oreg env form))) + +(defmeth compiler comp-arith-neg-form (me oreg env form) + (if (> (len form) 3) + (tree-bind (nop . args) form + (let ((op (caseq nop (- '+) (/ '*))) + (a1 (car args))) + (if (and (eq nop '-) + (constantp a1)) + me.(comp-arith-form oreg env + ^(,op (- ,a1) ,*(cdr args))) + me.(comp-fun-form oreg env + ^(,nop ,(car args) (,op ,*(cdr args))))))) + me.(comp-fun-form oreg env form))) + +(defmeth compiler comp-fun-form (me oreg env form) + (let* ((olev *opt-level*) + (sym (car form)) + (nargs (len (cdr form))) + (fbin env.(lookup-fun sym t)) + (pars (or fbin.?pars + (get-param-info sym)))) + (if pars + (param-check form nargs pars) + (push (cons form nargs) *unchecked-calls*)) + + (when (null fbin) + (when (plusp olev) + (match-case form + ((equal @a @b) + (cond + ((or (eq-comparable a) + (eq-comparable b)) + (set form ^(eq ,a ,b))) + ((or (eql-comparable a) + (eql-comparable b)) + (set form ^(eql ,a ,b))))) + ((not (@(and @(or eq eql equal) @op) @a @b)) + (let ((nop (caseq op (eq 'neq) (eql 'neql) (equal 'nequal)))) + (return-from comp-fun-form me.(compile oreg env ^(,nop ,a ,b))))) + ((@(or append cons list list*) . @args) + (set form (reduce-lisp form))) + ((@(@bin [%bin-op% @sym]) @a @b) + (set form ^(,bin ,a ,b))) + ((- @a) + (set form ^(neg ,a))) + ((@(or identity + * min max) @a) + (return-from comp-fun-form me.(compile oreg env a))))) + + (when (plusp olev) + (tree-case form + ((sym . args) + (set form (reduce-constant env form))))) + + (when (or (atom form) (special-operator-p (car form))) + (return-from comp-fun-form me.(compile oreg env form)))) + + (tree-bind (sym . args) form + (let* ((fbind env.(lookup-fun sym t))) + (macrolet ((comp-fun () + 'me.(comp-call-impl oreg env (if fbind 'call 'gcall) + (if fbind fbind.loc me.(get-sidx sym)) + args sym))) + (if (and (>= olev 3) + (not fbind) + (not *load-time*) + [%functional% sym]) + (let* ((snap me.(snapshot)) + (cfrag (comp-fun)) + (ok-lift-var-pov (null cfrag.fvars)) + (ok-lift-fun-pov (all cfrag.ffuns + (lambda (sym) + (and (not env.(lookup-fun sym)) + (eq (symbol-package sym) + user-package)))))) + (cond + ((and ok-lift-var-pov ok-lift-fun-pov) + me.(restore snap) + me.(compile oreg env ^(sys:load-time-lit nil ,form))) + (t (pushnew sym cfrag.ffuns) + cfrag))) + (let ((cfrag (comp-fun))) + (pushnew sym cfrag.ffuns) + cfrag))))))) + +(defmeth compiler comp-apply-call (me oreg env form) + (let ((olev *opt-level*)) + (tree-bind (sym . oargs) form + (let ((args (if (plusp olev) + [mapcar (op reduce-constant env) oargs] + oargs))) + (let ((gopcode [%gcall-op% sym]) + (opcode [%call-op% sym])) + (cond + ((and (plusp olev) + (eq sym 'call) + [all args constantp] + (let ((op (eval (car args)))) + (or [%const-foldable% op] + (not (bindable op))))) + me.(compile oreg env ^(quote ,(eval form)))) + (t (tree-case (car args) + ((op arg . more) + (caseq op + (fun (cond + (more (compile-error form "excess args in fun form")) + ((bindable arg) + (let ((fbind env.(lookup-fun arg t))) + me.(comp-call-impl oreg env (if fbind opcode gopcode) + (if fbind fbind.loc me.(get-sidx arg)) + (cdr args) arg))) + ((and (consp arg) (eq (car arg) 'lambda)) + me.(comp-fun-form oreg env ^(,sym ,arg ,*(cdr args)))) + (t :))) + (lambda me.(comp-inline-lambda oreg env opcode + (car args) (cdr args))) + (t :))) + (arg me.(comp-call oreg env + (if (eq sym 'usr:apply) 'apply sym) args)))))))))) + +(defmeth compiler comp-call (me oreg env opcode args) + (tree-bind (fform . fargs) args + (let* ((foreg me.(maybe-alloc-treg oreg)) + (ffrag me.(compile foreg env fform)) + (cfrag me.(comp-call-impl oreg env opcode ffrag.oreg fargs))) + me.(maybe-free-treg foreg oreg) + (new (frag cfrag.oreg + (append ffrag.code + cfrag.code) + (uni ffrag.fvars cfrag.fvars) + (uni ffrag.ffuns cfrag.ffuns)))))) + +(defmeth compiler comp-call-impl (me oreg env opcode freg args : extra-ffun) + (let* ((aoregs nil) + (afrags (collect-each ((arg args)) + (let* ((aoreg me.(alloc-treg)) + (afrag me.(compile aoreg env arg))) + (if (nequal afrag.oreg aoreg) + me.(free-treg aoreg) + (push aoreg aoregs)) + afrag))) + (fvars [reduce-left uni afrags nil .fvars]) + (ffuns [reduce-left uni afrags nil .ffuns])) + me.(free-tregs aoregs) + (when extra-ffun + (pushnew extra-ffun ffuns)) + (new (frag oreg + ^(,*(mappend .code afrags) + (,opcode ,oreg ,freg ,*(mapcar .oreg afrags))) + fvars ffuns)))) + +(defmeth compiler comp-inline-lambda (me oreg env opcode lambda args) + (let ((reg-args args) apply-list-arg) + (when (eql opcode 'apply) + (unless args + (compile-error lambda "apply requires arguments")) + (set reg-args (butlast args) + apply-list-arg (car (last args)))) + me.(compile oreg env (expand (lambda-apply-transform lambda + reg-args + apply-list-arg + nil))))) + +(defmeth compiler comp-for (me oreg env form) + (mac-param-bind form (op inits (: (test nil test-p) . rets) incs . body) form + (let* ((treg me.(alloc-treg)) + (ifrag me.(comp-progn treg env inits)) + (*load-time* nil) + (dummy (inc me.loop-nest)) + (tfrag (if test-p me.(compile treg env test))) + (rfrag me.(comp-progn oreg env rets)) + (nfrag me.(comp-progn treg env incs)) + (bfrag me.(comp-progn treg env body)) + (dummy (dec me.loop-nest)) + (lback (gensym "l")) + (lskip (gensym "l")) + (frags (build + (add ifrag) + (if test-p (add tfrag)) + (add rfrag nfrag bfrag)))) + me.(free-treg treg) + (new (frag rfrag.oreg + ^(,*ifrag.code + ,lback + ,*(if test-p + ^(,*tfrag.code + (if ,tfrag.oreg ,lskip))) + ,*bfrag.code + ,*nfrag.code + (jmp ,lback) + ,*(if test-p + ^(,lskip + ,*rfrag.code))) + [reduce-left uni frags nil .fvars] + [reduce-left uni frags nil .ffuns]))))) + +(defmeth compiler comp-tree-bind (me oreg env form) + (tree-bind (op params obj . body) form + (with-gensyms (obj-var) + (let ((expn (expand ^(let ((,obj-var ,obj)) + ,(expand-bind-mac-params ^',form + ^',(rlcp ^(,(car form)) + form) + params nil + obj-var t nil body))))) + me.(compile oreg env expn))))) + +(defmeth compiler comp-mac-param-bind (me oreg env form) + (mac-param-bind form (op context params obj . body) form + (with-gensyms (obj-var form-var) + (let ((expn (expand ^(let* ((,obj-var ,obj) + (,form-var ,context)) + ,(expand-bind-mac-params form-var + form-var + params nil + obj-var t nil body))))) + me.(compile oreg env expn))))) + +(defmeth compiler comp-mac-env-param-bind (me oreg env form) + (mac-param-bind form (op context menv params obj . body) form + (with-gensyms (obj-var form-var) + (let ((expn (expand ^(let* ((,obj-var ,obj) + (,form-var ,context)) + ,(expand-bind-mac-params form-var + form-var + params menv + obj-var t nil body))))) + me.(compile oreg env expn))))) + +(defmeth compiler comp-tree-case (me oreg env form) + (mac-param-bind form (op obj . cases) form + (let* ((ncases (len cases)) + (nenv (new env up env co me)) + (obj-immut-var (cdar nenv.(extend-var (gensym)))) + (obj-var (cdar nenv.(extend-var (gensym)))) + (err-blk (gensym)) + (lout (gensym "l")) + (ctx-form ^',form) + (err-form ^',(rlcp ^(,(car form)) form)) + (treg me.(maybe-alloc-treg oreg)) + (objfrag me.(compile treg env obj)) + (cfrags (collect-each ((c cases) + (i (range 1))) + (mac-param-bind form (params . body) c + (let* ((src (expand ^(block ,err-blk + (set ,obj-var.sym + ,obj-immut-var.sym) + ,(expand-bind-mac-params + ctx-form err-form + params nil obj-var.sym : + err-blk + body)))) + (lerrtest (gensym "l")) + (lnext (gensym "l")) + (cfrag me.(compile treg nenv src))) + (new (frag treg + ^(,*cfrag.code + ,*me.(maybe-mov treg cfrag.oreg) + (ifq ,treg ,me.(get-dreg :) ,lout)) + cfrag.fvars + cfrag.ffuns)))))) + (allfrags (cons objfrag cfrags))) + me.(maybe-free-treg treg oreg) + (new (frag oreg + ^(,*objfrag.code + (frame ,nenv.lev ,nenv.v-cntr) + ,*me.(maybe-mov obj-immut-var.loc objfrag.oreg) + ,*(mappend .code cfrags) + (mov ,treg nil) + ,lout + ,*me.(maybe-mov oreg treg) + (end ,oreg)) + [reduce-left uni allfrags nil .fvars] + [reduce-left uni allfrags nil .ffuns]))))) + +(defmeth compiler comp-lisp1-value (me oreg env form) + (mac-param-bind form (op arg) form + (cond + ((bindable arg) + (let ((bind env.(lookup-lisp1 arg t))) + (cond + (bind + (each ((spy me.access-spies)) + spy.(accessed bind arg)) + (new (frag bind.loc + nil + (if (typep bind 'vbinding) (list arg)) + (if (typep bind 'fbinding) (list arg))))) + ((not (boundp arg)) + (pushnew arg assumed-fun) + (new (frag oreg + ^((getf ,oreg ,me.(get-sidx arg))) + nil + (list arg)))) + ((special-var-p arg) + (new (frag oreg + ^((getv ,oreg ,me.(get-dreg arg))) + (list arg) + nil))) + (t (new (frag oreg + ^((getlx ,oreg ,me.(get-sidx arg))) + (list arg) + nil)))))) + (t me.(compile oreg env arg))))) + +(defmeth compiler comp-dwim (me oreg env form) + (mac-param-bind form (op obj . args) form + (let* ((l1-exprs (cdr form)) + (fun (car l1-exprs)) + (bind env.(lookup-lisp1 fun nil))) + me.(compile oreg env + (if (and (symbolp fun) + (not bind) + (not (boundp fun))) + (progn + (pushnew fun assumed-fun) + ^(,fun ,*(mapcar [iffi bindable (op list 'sys:lisp1-value)] (cdr l1-exprs)))) + ^(call ,*(mapcar [iffi bindable (op list 'sys:lisp1-value)] l1-exprs))))))) + +(defmeth compiler comp-prof (me oreg env form) + (mac-param-bind form (op . forms) form + (let ((bfrag me.(comp-progn oreg env forms))) + (new (frag oreg + ^((prof ,oreg) + ,*bfrag.code + (end ,bfrag.oreg)) + bfrag.fvars bfrag.ffuns))))) + +(defun misleading-ref-check (frag env form) + (each ((v frag.fvars)) + (when env.(lookup-var v) + (compile-warning form "cannot refer to lexical variable ~s" v))) + (each ((f frag.ffuns)) + (when env.(lookup-fun f) + (compile-warning form "cannot refer to lexical function ~s" f)))) + +(defmeth compiler comp-load-time-lit (me oreg env form) + (mac-param-bind form (op loaded-p exp) form + (cond + (loaded-p me.(compile oreg env ^(quote ,exp))) + ((or *load-time* (constantp exp)) me.(compile oreg env exp)) + (t (compile-in-toplevel me + (let* ((*load-time* t) + (dreg me.(alloc-dreg)) + (exp me.(compile dreg (new env co me) exp)) + (lt-frag (new (frag dreg + ^(,*exp.code + ,*me.(maybe-mov dreg exp.oreg)) + exp.fvars + exp.ffuns + exp.pars)))) + (misleading-ref-check exp env form) + (push lt-frag me.lt-frags) + (new (frag dreg nil nil nil exp.pars)))))))) + +(defmeth compiler optimize (me insns) + (let ((olev *opt-level*)) + (if (>= olev 4) + (let* ((lt-dregs (mapcar .oreg me.lt-frags)) + (bb (new (basic-blocks insns lt-dregs me.(get-symvec))))) + (when (>= olev 4) + bb.(thread-jumps) + bb.(elim-dead-code)) + (when (>= olev 5) + bb.(calc-liveness) + bb.(peephole)) + (cond + ((>= olev 6) + bb.(merge-jump-thunks) + bb.(late-peephole bb.(get-insns))) + (t bb.(get-insns)))) + insns))) + +(defun true-const-p (arg) + (and arg (constantp arg))) + +(defun eq-comparable (arg) + (and (constantp arg) + [[orf fixnump chrp symbolp] (eval arg)])) + +(defun eql-comparable (arg) + (and (constantp arg) + [[orf symbolp chrp numberp] (eval arg)])) + +(defun expand-and (form) + (match-case form + ((and) t) + ((and @a) a) + ((and @(true-const-p) . @rest) (expand-and ^(and ,*rest))) + ((and nil . @rest) nil) + ((and @a . @rest) ^(if ,a ,(expand-and ^(and ,*rest)))) + (@else else))) + +(defun flatten-or (form) + (match-case form + ((or . @args) ^(or ,*[mappend [chain flatten-or cdr] args])) + (@else ^(or ,else)))) + +(defun reduce-or (form) + (match-case form + ((or) form) + ((or @a) form) + ((or nil . @rest) (reduce-or ^(or ,*rest))) + ((or @(true-const-p @c) . @rest) ^(or ,c)) + ((or @a . @rest) ^(or ,a ,*(cdr (reduce-or ^(or ,*rest))))) + (@else else))) + +(defun simplify-or (form) + (reduce-or (flatten-or form))) + +(defmacro fixed-point (eqfn sym exp) + (with-gensyms (osym) + ^(let (,osym) + (while* (not (,eqfn ,osym ,sym)) + (set ,osym ,sym + ,sym ,exp)) + ,sym))) + +(defun reduce-lisp (form) + (fixed-point equal form + (rlcp + (match-case form + ((append (list . @largs) . @aargs) + ^(list* ,*largs (append ,*aargs))) + ((@(or append list*) @arg) arg) + (@(require (list* . @(listp @args)) + (equal '(nil) (last args))) + ^(list ,*(butlastn 1 args))) + (@(with (list* . @(listp @args)) + ((@(and @op @(or list list*)) . @largs)) (last args)) + ^(,op ,*(butlast args) ,*largs)) + (@(with (list* . @(listp @args)) + ((append . @aargs)) (last args)) + ^(list* ,*(butlast args) ,(reduce-lisp ^(append ,*aargs)))) + ((@(or append list list*)) nil) + ((cons @a @b) + (let* ((lstar ^(list* ,a ,b)) + (rstar (reduce-lisp lstar))) + (if (eq lstar rstar) form rstar))) + ((cons @a (cons @b @c)) + ^(list* ,a ,b ,c)) + ((cons @a (@(and @op @(or list list*)) . @args)) + ^(,op ,a ,*args)) + (@else else)) + form))) + +(defun reduce-constant (env form) + (if (consp form) + (tree-bind (op . args) form + (if (and [%const-foldable% op] + (not env.(lookup-fun op))) + (let ((cargs [mapcar (op reduce-constant env) args])) + (if [all cargs constantp] + ^(quote ,(eval (rlcp ^(,op ,*cargs) form))) + (rlcp ^(,op ,*cargs) form))) + form)) + form)) + +(defun expand-quasi-mods (obj mods : form) + (let (plist num sep rng-ix scalar-ix-p flex gens) + (flet ((get-sym (exp) + (let ((gen (gensym))) + (push (list gen exp) gens) + gen))) + (for () (mods) ((pop mods)) + (let ((mel (car mods))) + (cond + ((keywordp mel) + (set plist mods) + (return)) + ((integerp mel) + (when num + (compile-error form "duplicate modifier (width/alignment): ~s" + num)) + (set num mel)) + ((stringp mel) + (when sep + (compile-error form "duplicate modifier (separator): ~s" + num)) + (set sep mel)) + ((atom mel) + (push (get-sym mel) flex)) + (t + (caseq (car mel) + (dwim + (when rng-ix + (compile-error form "duplicate modifier (range/index): ~s" + mel)) + (unless (consp (cdr mel)) + (compile-error form "missing argument in range/index: ~s" + mel)) + (unless (null (cddr mel)) + (compile-error form "excess args in range/index: ~s" + num)) + (let ((arg (cadr mel))) + (cond + ((and (consp arg) (eq (car arg) 'range)) + (set rng-ix (get-sym ^(rcons ,(cadr arg) ,(caddr arg))))) + (t + (set rng-ix (get-sym arg)) + (set scalar-ix-p t))))) + (sys:expr (push (get-sym flex) (cadr mel))) + (t (push (get-sym mel) flex))))))) + (let ((mcount (+ (if num 1 0) + (if sep 1 0) + (if rng-ix 1 0) + (len flex)))) + (when (> mcount 3) + (compile-error form "too many formatting modifiers")) + ^(alet ,(nreverse gens) + ,(if flex + ^(sys:fmt-flex ,obj ',plist + ,*(remq nil (list* num sep + (if scalar-ix-p + ^(rcons ,rng-ix nil) + rng-ix) + (nreverse flex)))) + (cond + (plist ^(sys:fmt-simple ,obj ,num ,sep, rng-ix ',plist)) + (rng-ix ^(sys:fmt-simple ,obj ,num ,sep, rng-ix)) + (sep ^(sys:fmt-simple ,obj ,num ,sep)) + (num ^(sys:fmt-simple ,obj ,num)) + (t ^(sys:fmt-simple ,obj ,num))))))))) + +(defun expand-quasi-args (form) + (append-each ((el (cdr form))) + (cond + ((consp el) + (caseq (car el) + (sys:var (mac-param-bind form (sym exp : mods) el + (list (expand-quasi-mods exp mods)))) + (sys:quasi (expand-quasi-args el)) + (t (list ^(sys:fmt-simple ,el))))) + ((bindable el) + (list ^(sys:fmt-simple ,el))) + (t + (list el))))) + +(defun expand-quasi (form) + (let ((qa (expand-quasi-args form))) + (cond + ((cdr qa) ^(sys:fmt-join ,*qa)) + (qa (car qa)) + (t '(mkstring 0))))) + +(defun expand-dohash (form) + (mac-param-bind form (op (key-var val-var hash-form : res-form) . body) form + (with-gensyms (iter-var cell-var) + ^(let (,key-var ,val-var (,iter-var (hash-begin ,hash-form)) ,cell-var) + (block nil + (sys:for-op ((sys:setq ,cell-var (hash-next ,iter-var))) + (,cell-var ,res-form) + ((sys:setq ,cell-var (hash-next ,iter-var))) + (sys:setq ,key-var (car ,cell-var)) + (sys:setq ,val-var (cdr ,cell-var)) + ,*body)))))) + +(defun expand-each (form env) + (mac-param-bind form (op each-type vars . body) form + (when (eq vars t) + (set vars [mapcar car env.vb])) + (let* ((gens (mapcar (ret (gensym)) vars)) + (out (if (member each-type '(collect-each append-each)) + (gensym))) + (accum (if out (gensym)))) + ^(let* (,*(mapcar (ret ^(,@1 (iter-begin ,@2))) gens vars) + ,*(if accum ^((,out (cons nil nil)) (,accum ,out)))) + (block nil + (sys:for-op () + ((and ,*(mapcar (op list 'iter-more) gens)) + ,*(if accum (if (eq each-type 'collect-each) + ^((cdr ,out)) + ^((sys:apply (fun append) ,out))))) + (,*(mapcar (ret ^(sys:setq ,@1 (iter-step ,@1))) gens)) + ,*(mapcar (ret ^(sys:setq ,@1 (iter-item ,@2))) vars gens) + ,*(caseq each-type + ((collect-each append-each) + ^((rplacd ,accum (cons (progn ,*body) nil)) + (sys:setq ,accum (cdr ,accum)))) + (t body)))))))) + +(defun expand-bind-mac-params (ctx-form err-form params menv-var + obj-var strict err-block body) + (let (gen-stk stmt vars) + (labels ((get-gen () + (or (pop gen-stk) (gensym))) + (put-gen (g) + (push g gen-stk)) + (expand-rec (par-syntax obj-var check-var) + (labels ((emit-stmt (form) + (when form + (if check-var + (push ^(when ,check-var ,form) stmt) + (push form stmt)))) + (emit-var (sym init-form) + (push (if stmt + (prog1 + ^(,sym (progn ,*(nreverse stmt) + ,(if check-var + ^(when ,check-var ,init-form) + init-form))) + (set stmt nil)) + ^(,sym ,(if check-var + ^(when ,check-var ,init-form) + init-form))) + vars))) + (let ((pars (new (mac-param-parser par-syntax ctx-form)))) + (progn + (cond + ((eq strict t) + (emit-stmt + ^(sys:bind-mac-check ,err-form ',par-syntax + ,obj-var ,pars.nreq + ,(unless pars.rest + pars.nfix)))) + ((null strict)) + ((symbolp strict) + (emit-stmt + (let ((len-expr ^(if (consp ,obj-var) + (len ,obj-var) 0))) + (if pars.rest + ^(unless (<= ,pars.nreq ,len-expr) + (return-from ,err-block ',strict)) + ^(unless (<= ,pars.nreq ,len-expr ,pars.nfix) + (return-from ,err-block ',strict))))))) + (each ((k pars.key)) + (tree-bind (key . sym) k + (caseq key + (:whole (emit-var sym obj-var)) + (:form (emit-var sym ctx-form)) + (:env (emit-var sym menv-var))))) + (each ((p pars.req)) + (cond + ((listp p) + (let ((curs (get-gen))) + (emit-stmt ^(set ,curs (car ,obj-var))) + (emit-stmt ^(set ,obj-var (cdr ,obj-var))) + (expand-rec p curs check-var) + (put-gen curs))) + (t + (emit-var p ^(car ,obj-var)) + (emit-stmt ^(set ,obj-var (cdr ,obj-var)))))) + (each ((o pars.opt)) + (tree-bind (p : init-form pres-p) o + (cond + ((listp p) + (let* ((curs (get-gen)) + (stmt ^(cond + (,obj-var + (set ,curs (car ,obj-var)) + (set ,obj-var (cdr ,obj-var)) + ,*(if pres-p '(t))) + (t + (set ,curs ,init-form) + ,*(if pres-p '(nil)))))) + (if pres-p + (emit-var pres-p stmt) + (emit-stmt stmt)) + (let ((cv (gensym))) + (emit-var cv curs) + (expand-rec p curs cv) + (put-gen curs)))) + (t + (cond + (pres-p + (emit-var p nil) + (emit-var pres-p + ^(cond + (,obj-var + (set ,p (car ,obj-var)) + (set ,obj-var (cdr ,obj-var)) + ,(if pres-p t)) + (t + ,(if init-form + ^(set ,p ,init-form)) + ,(if pres-p nil))))) + (t + (emit-var p ^(if ,obj-var + (prog1 + (car ,obj-var) + (set ,obj-var (cdr ,obj-var))) + (if ,init-form ,init-form))))))))) + (when pars.rest + (emit-var pars.rest obj-var))))))) + (expand-rec params obj-var nil) + (when stmt + (push ^(,(gensym) (progn ,*(nreverse stmt))) vars)) + ^(let* (,*gen-stk ,*(nreverse vars)) + ,*body)))) + +(defun expand-defvarl (form) + (mac-param-bind form (op sym : value) form + (with-gensyms (cell) + (if value + ^(let ((,cell (sys:rt-defv ',sym))) + (if ,cell + (usr:rplacd ,cell ,value)) + ',sym) + ^(progn (sys:rt-defv ',sym) ',sym))))) + +(defun expand-defun (form) + (mac-param-bind form (op name args . body) form + (flet ((mklambda (block-name block-sym) + ^(lambda ,args (,block-sym ,block-name ,*body)))) + (cond + ((bindable name) + ^(sys:rt-defun ',name ,(mklambda name 'sys:blk))) + ((consp name) + (caseq (car name) + (meth + (mac-param-bind form (meth type slot) name + ^(sys:define-method ',type ',slot ,(mklambda slot 'block)))) + (macro + (mac-param-bind form (macro sym) name + ^(sys:rt-defmacro ',sym ',name ,(mklambda sym 'sys:blk)))) + (t (compile-error form "~s isn't a valid compound function name" + name)))) + (t (compile-error form "~s isn't a valid function name" name)))))) + +(defun expand-defmacro (form) + (mac-param-bind form (op name mac-args . body) form + (with-gensyms (form menv spine-iter) + (let ((exp-lam ^(lambda (,form ,menv) + (let ((,spine-iter (cdr ,form))) + ,(expand (expand-bind-mac-params form form mac-args + menv spine-iter + t nil + ^((sys:set-macro-ancestor + (block ,name ,*body) + ,form)))))))) + ^(progn + (sys:rt-defmacro ',name '(macro ,name) ,exp-lam) + ',name))))) + +(defun expand-defsymacro (form) + (mac-param-bind form (op name def) form + ^(sys:rt-defsymacro ',name ',def))) + +(defun lambda-apply-transform (lm-expr fix-arg-exprs apply-list-expr recursed) + (if (and (not recursed) + apply-list-expr + (constantp apply-list-expr)) + (let* ((apply-list-val (eval apply-list-expr)) + (apply-atom (nthlast 0 apply-list-val)) + (apply-fixed (butlastn 0 apply-list-val))) + (lambda-apply-transform lm-expr (append fix-arg-exprs + (mapcar (ret ^',@1) apply-fixed)) + ^',apply-atom t)) + (mac-param-bind lm-expr (lambda lm-args . lm-body) lm-expr + (let* ((pars (new (fun-param-parser lm-args lm-expr))) + (fix-vals (mapcar (ret (gensym)) fix-arg-exprs)) + (ign-sym (gensym)) + (al-val (gensym)) + (shadow-p (let ((all-vars (append pars.req pars.(opt-syms) + (if pars.rest (list pars.rest))))) + (or (isec all-vars fix-arg-exprs) + (member apply-list-expr all-vars))))) + ^(,(if shadow-p 'let 'alet) ,(zip fix-vals fix-arg-exprs) + (let* ,(build + (if apply-list-expr + (add ^(,al-val ,apply-list-expr))) + (while (and fix-vals pars.req) + (add ^(,(pop pars.req) ,(pop fix-vals)))) + (while (and fix-vals pars.opt) + (tree-bind (var-sym : init-form have-sym) (pop pars.opt) + (add ^(,var-sym ,(pop fix-vals))) + (if have-sym + (add ^(,have-sym t))))) + (cond + ((and (null pars.req) + (null pars.opt)) + (if fix-vals + (if pars.rest + (add ^(,pars.rest + (list* + ,*(nthcdr pars.nfix + ^(,*fix-arg-exprs ,apply-list-expr))))) + (lambda-too-many-args lm-expr)) + (when (or pars.rest apply-list-expr) + (add ^(,(or pars.rest ign-sym) ,apply-list-expr))))) + ((and fix-vals apply-list-expr) + (lambda-too-many-args lm-expr)) + (apply-list-expr + (when pars.req + (add ^(,ign-sym (if (< (len ,al-val) ,(len pars.req)) + (lambda-short-apply-list))))) + (while pars.req + (add ^(,(pop pars.req) (pop ,al-val)))) + (while pars.opt + (tree-bind (var-sym : init-form have-sym) (pop pars.opt) + (cond + (have-sym + (add ^(,var-sym (if ,al-val + (car ,al-val) + ,init-form))) + (add ^(,have-sym (when ,al-val + (pop ,al-val) + t)))) + (t (add ^(,var-sym (if ,al-val + (pop ,al-val) + ,init-form))))))) + (when pars.rest + (add ^(,pars.rest ,al-val)))) + (pars.req + (lambda-too-few-args lm-expr)) + (pars.opt + (while pars.opt + (tree-bind (var-sym : init-form have-sym) (pop pars.opt) + (add ^(,var-sym ,init-form)) + (if have-sym + (add ^(,have-sym))))) + (when pars.rest + (add ^(,pars.rest)))))) + ,*lm-body)))))) + +(defun system-symbol-p (sym) + (member (symbol-package sym) + (load-time (list user-package system-package)))) + +(defun usr:compile-toplevel (exp : (expanded-p nil)) + (let ((co (new compiler)) + (as (new assembler)) + (*dedup* (or *dedup* (hash))) + (*opt-level* (or *opt-level* 0))) + (let* ((*load-time* t) + (oreg co.(alloc-treg)) + (xexp (if expanded-p + exp + (unwind-protect + (expand* exp) + (unless *load-recursive* + (release-deferred-warnings))))) + (frag co.(compile oreg (new env co co) xexp))) + co.(free-treg oreg) + co.(check-treg-leak) + as.(asm co.(optimize ^(,*(mappend .code (nreverse co.lt-frags)) + ,*frag.code + (jend ,frag.oreg)))) + (vm-make-desc co.nlev (succ as.max-treg) as.buf co.(get-datavec) co.(get-symvec))))) + +(defun get-param-info (sym) + (whenlet ((fun (symbol-function sym))) + (or [%param-info% fun] + (set [%param-info% fun] + (new param-info fun fun))))) + +(defun param-check (form nargs pars) + (cond + ((< nargs pars.nreq) + (compile-warning form "too few arguments: needs ~s, given ~s" + pars.nreq nargs)) + (pars.rest) + ((> nargs pars.nfix) + (compile-warning form "too many arguments: max ~s, given ~s" + pars.nfix nargs)))) + +(defun compiler-emit-warnings () + (let ((warn-fun [keep-if boundp (zap assumed-fun)])) + (when warn-fun + (usr:catch + (throw 'warning + `uses of @{warn-fun ", "} compiled as functions,\ + \ then defined as vars`) + (continue ())))) + (each ((uc (zap *unchecked-calls*))) + (when-match (@(as form (@sym . @args)) . @nargs) uc + (whenlet ((fun (symbol-function sym))) + (param-check form nargs (get-param-info sym)))))) + +(defvarl %file-suff-rx% #/[.][^\\\/.]+/) + +(defvar *emit*) + +(defvar *eval*) + +(defvarl %big-endian% (equal (ffi-put 1 (ffi uint32)) #b'00000001')) + +(defvarl %tlo-ver% ^(7 0 ,%big-endian%)) + +(defvarl %package-manip% '(make-package delete-package + use-package unuse-package + set-package-fallback-list + intern unintern rehome-sym + use-sym unuse-sym)) + +(defun open-compile-streams (in-path out-path test-fn) + (let* ((parent (or *load-path* "")) + (sep [path-sep-chars 0]) + (in-path (if (and (pure-rel-path-p in-path) (not (empty parent))) + `@(dir-name parent)@sep@{in-path}` + in-path)) + (rsuff (r$ %file-suff-rx% in-path)) + (suff (if rsuff [in-path rsuff])) + (ip-nosuff (if rsuff [in-path 0..(from rsuff)] in-path)) + in-stream out-stream) + (cond + ((ends-with ".txr" in-path) + (error "~s: cannot compile TXR files" 'compile-file)) + ((ends-with ".tl" in-path) + (set in-stream (ignerr (open-file in-path)) + out-path (or out-path `@{in-path [0..-3]}.tlo`))) + (t + (set in-stream (or (ignerr (open-file `@{in-path}.tl`)) + (ignerr (open-file in-path))) + out-path (or out-path `@{in-path}.tlo`)))) + + (unless in-stream + (error "~s: unable to open input file ~s" 'compile-file in-path)) + + (unless [test-fn in-stream out-path] + (close-stream in-stream) + (return-from open-compile-streams nil)) + + (set out-stream (ignerr (open-file out-path "w"))) + + (unless out-stream + (close-stream in-stream) + (error "~s: unable to open output file ~s" 'compile-file out-path)) + + (list in-stream out-stream out-path))) + +(defun list-from-vm-desc (vd) + (list (sys:vm-desc-nlevels vd) + (sys:vm-desc-nregs vd) + (sys:vm-desc-bytecode vd) + (copy (sys:vm-desc-datavec vd)) + (sys:vm-desc-symvec vd))) + +(defmacro usr:with-compilation-unit (. body) + (with-gensyms (rec) + ^(let* ((,rec *in-compilation-unit*) + (*in-compilation-unit* t) + (sys:*load-recursive* t) + (*dedup* (or *dedup* (hash)))) + (unwind-protect + (progn ,*body) + (unless ,rec + (release-deferred-warnings) + (compiler-emit-warnings)))))) + +(defun dump-to-tlo (out-stream out) + (let* ((*print-circle* t) + (*package* (sys:make-anon-package)) + (out-forms (split* out.(get) (op where (op eq :fence))))) + (prinl %tlo-ver% out-stream) + [mapdo (op prinl @1 out-stream) out-forms] + (delete-package *package*))) + +(defun propagate-perms (in-stream out-stream) + (let ((sti (stat in-stream))) + (when (plusp (logand sti.mode s-ixusr)) + (let ((mode "+x") + (suid (if (plusp (logand sti.mode s-isuid)) ",u+s")) + (sgid (if (and (plusp (logand sti.mode s-isgid)) + (plusp (logand sti.mode s-ixgrp))) ",g+s"))) + (when (or suid sgid) + (let ((sto (stat out-stream))) + (set mode (append mode + (if (eql sti.uid sto.uid) suid) + (if (eql sti.gid sto.gid) sgid))))) + (chmod out-stream mode))))) + +(defun compile-file-conditionally (in-path out-path test-fn) + (whenlet ((success nil) + (perms nil) + (streams (open-compile-streams in-path out-path test-fn))) + (with-resources ((in-stream (car streams) (close-stream in-stream)) + (out-stream (cadr streams) (progn + (when perms + (propagate-perms in-stream + out-stream)) + (close-stream out-stream) + (unless success + (remove-path (caddr streams)))))) + (let* ((err-ret (gensym)) + (*package* *package*) + (*emit* t) + (*eval* t) + (*load-path* (stream-get-prop (car streams) :name)) + (*rec-source-loc* t) + (out (new list-builder))) + (with-compilation-unit + (iflet ((line (get-line in-stream)) + ((starts-with "#!" line))) + (progn + (set line `@line `) + (upd line (regsub #/--lisp[^\-]/ (ret `--compiled@[@1 -1]`))) + (put-line (butlast line) out-stream) + (set perms t)) + (seek-stream in-stream 0 :from-start)) + (labels ((compile-form (unex-form) + (let* ((form (macroexpand unex-form)) + (sym (if (consp form) (car form)))) + (caseq sym + (progn [mapdo compile-form (cdr form)]) + (compile-only (let ((*eval* nil)) + [mapdo compile-form (cdr form)])) + (eval-only (let ((*emit* nil)) + [mapdo compile-form (cdr form)])) + (sys:load-time-lit + (if (cadr form) + (compile-form ^(quote ,(caddr form))) + (compile-form (caddr form)))) + (t (when (and (or *eval* *emit*) + (not (constantp form))) + (let* ((vm-desc (compile-toplevel form)) + (flat-vd (list-from-vm-desc vm-desc)) + (fence (member sym %package-manip%))) + (when *eval* + (let ((pa *package-alist*)) + (sys:vm-execute-toplevel vm-desc) + (when (neq pa *package-alist*) + (set fence t)))) + (when (and *emit* (consp form)) + out.(add flat-vd) + (when fence + out.(add :fence)))))))))) + (unwind-protect + (whilet ((obj (read in-stream *stderr* err-ret)) + ((neq obj err-ret))) + (compile-form obj)) + (dump-to-tlo out-stream out)) + + (when (parse-errors in-stream) + (error "~s: compilation of ~s failed" 'compile-file + (stream-get-prop in-stream :name)))) + (flush-stream out-stream) + (set success t)))))) + +(defun usr:compile-file (in-path : out-path) + [compile-file-conditionally in-path out-path tf]) + +(defun usr:compile-update-file (in-path : out-path) + [compile-file-conditionally in-path out-path [mapf path-newer fstat identity]]) + +(defun usr:dump-compiled-objects (out-stream . compiled-objs) + (symacrolet ((self 'dump-compiled-objects)) + (let ((out (new list-builder))) + (flet ((vm-from-fun (fun) + (unless (vm-fun-p fun) + (error "~s: not a vm function: ~s" self fun)) + (sys:vm-closure-desc (func-get-env fun)))) + (each ((obj compiled-objs)) + (let* ((vm-desc (typecase obj + (vm-desc obj) + (fun (vm-from-fun obj)) + (t (iflet ((fun (symbol-function obj))) + (vm-from-fun fun) + (error "~s: not a compiled object: ~s" + self obj))))) + (symvec (sys:vm-desc-symvec vm-desc))) + out.(add (list-from-vm-desc vm-desc)) + (when (isec symvec %package-manip%) + out.(add :fence))))) + (dump-to-tlo out-stream out)))) + +(defun sys:env-to-let (env form) + (when env + (let ((vb (env-vbindings env)) + (fb (env-fbindings env)) + (up (env-next env))) + (when vb + (set form ^(let ,(mapcar (tb ((a . d)) ^(,a ',d)) vb) ,form))) + (when fb + (let (lbind fbind) + (each ((pair fb)) + (tree-bind (a . d) pair + (let* ((fun-p (interp-fun-p d)) + (fe (if fun-p (func-get-env d))) + (lb-p (and fe (eq fe env))) + (fb-p (and fe (eq fe up)))) + (cond + (lb-p (push ^(,a ,(func-get-form d)) lbind)) + (fb-p (push ^(,a ,(func-get-form d)) fbind)) + (t (push ^(,a ',d) fbind)))))) + (when lbind + (set form ^(sys:lbind ,(nreverse lbind) ,form))) + (when fbind + (set form ^(sys:fbind ,(nreverse fbind) ,form))))) + (if up + (set form (sys:env-to-let up form))))) + form) + +(defun usr:compile (obj) + (typecase obj + (fun (tree-bind (indicator args . body) (func-get-form obj) + (let* ((form (sys:env-to-let (func-get-env obj) + ^(lambda ,args ,*body))) + (vm-desc (compile-toplevel form t))) + (vm-execute-toplevel vm-desc)))) + (t (condlet + (((fun (symbol-function obj))) + (tree-bind (indicator args . body) (func-get-form fun) + (let* ((form (sys:env-to-let (func-get-env fun) + ^(lambda ,args ,*body))) + (vm-desc (compile-toplevel form t)) + (comp-fun (vm-execute-toplevel vm-desc))) + (set (symbol-function obj) comp-fun)))) + (t (error "~s: cannot compile ~s" 'compile obj)))))) diff --git a/stdlib/conv.tl b/stdlib/conv.tl new file mode 100644 index 00000000..5cd799f3 --- /dev/null +++ b/stdlib/conv.tl @@ -0,0 +1,98 @@ +;; Copyright 2016-2021 +;; Kaz Kylheku <kaz@kylheku.com> +;; Vancouver, Canada +;; 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 HOLDER 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. + +(defun sys:conv-let (. body) + ^(flet ((usr:i (arg : radix) + (toint arg radix)) + (usr:o (arg) + (toint arg 8)) + (usr:x (arg) + (toint arg 16)) + (usr:b (arg) + (toint arg 2)) + (usr:c (arg) + (toint arg #\c)) + (usr:r (arg) + (tofloat arg)) + (usr:iz (arg : radix) + (tointz arg radix)) + (usr:oz (arg) + (tointz arg 8)) + (usr:xz (arg) + (tointz arg 16)) + (usr:bz (arg) + (tointz arg 2)) + (usr:cz (arg) + (tointz arg #\c)) + (usr:rz (arg) + (tofloatz arg))) + ,*body)) + +(defun sys:do-conv (lfl mfl tfl nm list) + (while (and list lfl) + (set (car list) (call (car lfl) (car list))) + (set list (cdr list)) + (set lfl (cdr lfl))) + (dotimes (i nm) + (unless list + (return)) + (when mfl + (set (car list) (call (car mfl) (car list))) + (set mfl (cdr mfl))) + (set list (cdr list))) + (while (and list tfl) + (set (car list) (call (car tfl) (car list))) + (set list (cdr list)) + (set tfl (cdr tfl)))) + +(defun sys:conv-expand (form specs list-sym) + (mac-param-bind form (lead : mid trail) + (split* (mapcar [iff (op eq :) + identity + [iff (op eq '-) + (retf '(fun identity)) + (ret ^[identity ,@1])]] + specs) + (op where (op eq :))) + (let ((nl (length lead)) + (nt (length trail))) + (with-gensyms (i nm lfl mfl tfl) + (sys:conv-let + ^(let* ((,nm (- (length ,list-sym) ,(+ nl nt))) + (,lfl (list ,*lead)) + (,mfl (if (plusp ,nm) (repeat (list ,*mid)))) + (,tfl (list ,*trail))) + (sys:do-conv ,lfl ,mfl ,tfl ,nm ,list-sym))))))) + +(defmacro sys:conv (:form form (. specs) list-expr) + (cond + ((null specs) list-expr) + ((atom specs) + (throwf 'eval-error "~s: invalid conversion list: ~s" 'conv specs)) + (t (with-gensyms (list-sym) + ^(let ((,list-sym ,list-expr)) + ,(sys:conv-expand form specs list-sym) + ,list-sym))))) diff --git a/stdlib/copy-file.tl b/stdlib/copy-file.tl new file mode 100644 index 00000000..28460b72 --- /dev/null +++ b/stdlib/copy-file.tl @@ -0,0 +1,251 @@ +;; Copyright 2018-2021 +;; Kaz Kylheku <kaz@kylheku.com> +;; Vancouver, Canada +;; 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 HOLDER 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. + +(eval-only + (defsymacro copy-size 65536)) + +(defstruct copy-path-opts () + perms times owner symlinks (euid (geteuid))) + +(defstruct copy-path-stack-node () + path stat new-p) + +(defun make-copy-path-opts (opt-list) + (if opt-list + (let (opts) + (each ((opt opt-list)) + (if (structp opt) + (set opts opt) + (progn + (unless opts + (set opts (new copy-path-opts))) + (caseql opt + (:perms (set opts.perms t)) + (:times (set opts.times t)) + (:owner (set opts.owner t)) + (:symlinks (set opts.symlinks t)) + (:all (set opts.perms t + opts.times t + opts.owner t + opts.symlinks t)) + (t (error "~s: unrecognized option ~s" 'copy-path opt)))))) + opts) + (load-time (new copy-path-opts)))) + +(defun copy-file (from-path to-path : preserve-perms preserve-times) + (with-resources ((buf (make-buf copy-size) + (buf-set-length buf 0) (buf-trim buf)) + (ist (open-file from-path "b") (close-stream ist)) + (ista (fstat ist)) + (ost (if (path-dir-p ista) + (throwf 'path-permission `~s: ~a is a directory` + 'copy-file from-path) + (open-file to-path "wb")) + (close-stream ost))) + (while (eql (len buf) copy-size) + (fill-buf-adjust buf 0 ist) + (put-buf buf 0 ost)) + (when preserve-perms + (chmod ost ista.mode)) + (when preserve-times + (flush-stream ost) + (utimes ost + ista.atime (or ista.atime-nsec 0) + ista.mtime (or ista.mtime-nsec 0))) + nil)) + +(defun copy-files (paths dest-dir : preserve-perms preserve-times) + (each ((path paths)) + (while t + (catch** + (return (copy-file path (path-cat dest-dir (base-name path)) + preserve-perms preserve-times)) + (skip `skip copying @path` (exc . args) (return)) + (retry `retry copying @path` (exc . args)))))) + +(defun do-tweak-obj (to-path st opts link-p) + (when (and opts.perms (not link-p)) + (chmod to-path st.mode)) + (when opts.times + (lutimes to-path + st.atime (or st.atime-nsec 0) + st.mtime (or st.mtime-nsec 0))) + (when (and opts.owner + (or (zerop opts.euid) + (and (path-mine-p st) + (path-my-group-p st)))) + (lchown to-path st.uid st.gid))) + +(defun do-copy-obj (from-path to-path st opts) + (let ((type (logand st.mode s-ifmt)) + (initial-perms (if opts.perms #o700 #o777)) + (tweak t)) + (caseql* type + (s-ifreg + (copy-file from-path to-path opts.perms opts.times)) + (s-ifsock + (mknod to-path (logior type initial-perms))) + (s-ififo + (mkfifo to-path initial-perms)) + (s-iflnk + (if opts.symlinks + (symlink (readlink from-path) to-path) + (progn + (do-copy-obj from-path to-path (stat from-path) opts) + (set tweak nil)))) + ((s-ifblk s-ifchr) + (mknod to-path (logior type initial-perms) st.rdev)) + (s-ifdir + (ensure-dir to-path))) + (when tweak + (do-tweak-obj to-path st opts (eq type s-iflnk))))) + +(defun copy-path-rec (from-dir to-dir . opt-list) + (let* ((opts (make-copy-path-opts opt-list)) + (dir-stack nil)) + (unwind-protect + (ftw from-dir + (lambda (path type stat . rest) + (while t + (catch** + (let* ((rel-path (let ((p [path (len from-dir)..:])) + (if (pure-rel-path-p p) p [p 1..:]))) + (tgt-path (path-cat to-dir rel-path))) + (unless (starts-with from-dir path) + (error "~s: problem with directory traversal" 'copy-path)) + (caseql* type + ((ftw-dnr ftw-ns) (error "~s: unable to access ~s" + 'copy-path path)) + (ftw-d (let ((new-p (ensure-dir tgt-path))) + (whilet ((top (car dir-stack)) + ((and top + (not (starts-with tgt-path + top.path))))) + (do-tweak-obj top.path top.stat opts nil) + (pop dir-stack)) + (push (new copy-path-stack-node + path tgt-path + stat stat + new-p new-p) + dir-stack))) + (t (iflet ((cur (car dir-stack))) + (unless cur.new-p + (remove-path tgt-path))) + (do-copy-obj path tgt-path stat opts))) + (return)) + (skip `skip copying @path` (exc . args) (return)) + (retry `retry copying @path` (exc . args))))) + ftw-phys) + (whilet ((top (pop dir-stack))) + (do-tweak-obj top.path top.stat opts nil))))) + +(defun remove-path-rec (path) + (ftw path + (lambda (path type stat . rest) + (while t + (catch** + (return + (caseql* type + ((ftw-dnr ftw-ns) (error "~s: unable to access ~s" + 'remove-rec path)) + (ftw-dp (rmdir path)) + (t (remove-path path)))) + (skip `skip removing @path` (exc . args) (return)) + (retry `retry copying @path` (exc . args))))) + (logior ftw-phys ftw-depth))) + +(defun chmod-rec (path perm) + (ftw path + (lambda (path type stat . rest) + (while t + (catch** + (return + (caseql* type + ((ftw-dnr ftw-ns) (error "~s: unable to access ~s" + 'remove-rec path)) + (ftw-sl) + (t (chmod path perm)))) + (skip `skip chmod @path` (exc . args) (return)) + (retry `retry chmod @path` (exc . args))))) + (logior ftw-phys))) + +(defun chown-rec (path uid gid) + (ftw path + (lambda (path type stat . rest) + (while t + (catch** + (return + (caseql* type + ((ftw-dnr ftw-ns) (error "~s: unable to access ~s" + 'remove-rec path)) + (t (lchown path uid gid)))) + (skip `skip chown @path` (exc . args) (return)) + (retry `retry chown @path` (exc . args))))) + (logior ftw-phys))) + +(defun touch (path : ref-path) + (with-stream (s (or (ignerr (open-file path "mn")) (open-file path "n"))) + (if ref-path + (let ((rst (stat ref-path))) + (utimes s 0 nil rst.mtime rst.mtime-nsec)) + (utimes s 0 nil 0 t)))) + +(defun rel-path (from to) + (unless (eq (abs-path-p from) (abs-path-p to)) + (error "~s: mixture of absolute and relative paths ~s ~s given" + 'rel-path from to)) + + (macrolet ((if-windows (then : else) + (if (find #\\ path-sep-chars) then else))) + (if-windows + (when-match `@{fdrv #/[A-Za-z0-9]+:/}@nil` from + (when-match `@{tdrv #/[A-Za-z0-9]+:/}@nil` to + (unless (equal fdrv tdrv) + (error "~s: paths on different drives ~s ~s given" + 'rel-path from to))))) + + (flet ((canon (comp) + (let (out) + (each ((c comp)) + (casequal c + (".." (if (and out (nequal (car out) "..")) + (pop out) + (push c out))) + (("." "")) + (t (push c out)))) + (nreverse out)))) + (let* ((fcomp (canon (spl path-sep-chars from))) + (tcomp (canon (spl path-sep-chars to))) + (ncommon (mismatch fcomp tcomp))) + (cond + ((null ncommon) ".") + ((find ".." (nthcdr ncommon fcomp)) + (error "~s: from path uses ... to escapes common prefix: ~s ~s" + 'rel-path from to)) + (t (let ((nup (- (len fcomp) ncommon)) + (down [tcomp ncommon..:])) + (cat-str (append (repeat '("..") nup) down) + [path-sep-chars 0])))))))) diff --git a/stdlib/debugger.tl b/stdlib/debugger.tl new file mode 100644 index 00000000..8102eb24 --- /dev/null +++ b/stdlib/debugger.tl @@ -0,0 +1,102 @@ +;; Copyright 2019-2021 +;; Kaz Kylheku <kaz@kylheku.com> +;; Vancouver, Canada +;; 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 HOLDER 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. + +(defmacro with-disabled-debugging (. forms) + (let ((state (gensym))) + ^(let ((,state (dbg-clear dbg-all))) + (unwind-protect + (progn ,*forms) + (dbg-restore ,state))))) + +(defun make-command-env (command-table) + (let ((env (make-env ))) + (mapdo (ado env-vbind env @1 ^(,@2)) command-table) + env)) + +(defparml %dbg-commands% '((usr:? debugger-help "list command summary") + (usr:bt print-backtrace "print backtrace"))) + +(defparml %dbg-command-env% (make-command-env %dbg-commands%)) + +(defun debugger-help () + (mapdo (ap pprinl `@{@1 15} @3`) %dbg-commands%)) + +(defmeth fcall-frame loc (fr)) + +(defmeth fcall-frame print-trace (fr pr-fr nx-fr prefix) + (let* ((fun fr.fun) + (args fr.args) + (name (if (functionp fun) + (func-get-name fun))) + (loc (if nx-fr nx-fr.(loc))) + (kind + (cond + ((interp-fun-p fun) "I") + ((vm-fun-p fun) "V") + ((functionp fun) "C") + (t "O")))) + (put-string `@prefix @kind:@(if loc `(@loc):`)`) + (prinl ^[,(or name fun) ,*args]))) + +(defmeth eval-frame loc (fr) + (source-loc-str fr.form)) + +(defmeth eval-frame print-trace (fr pr-fr nx-fr prefix) + (when (or (null nx-fr) + (and (typep pr-fr 'fcall-frame) + (not (interp-fun-p pr-fr.fun)) + (not (vm-fun-p pr-fr.fun)))) + (let* ((form fr.form) + (sym (if (consp form) (car form))) + (loc (source-loc-str form))) + (when sym + (put-string `@prefix E:@(if loc `(@loc):`)`) + (prinl (if (eq sym 'dwim) + ^[,(cadr form)] + ^(,sym))))))) + +(defmeth expand-frame print-trace (fr pr-fr nx-fr prefix) + (let* ((form fr.form) + (loc (source-loc-str form))) + (put-string `@prefix X:@(if loc `(@loc):`)`) + (prinl form))) + +(defmeth expand-frame loc (fr) + (source-loc-str fr.form)) + +(defun print-backtrace (: (*stdout* *stdout*) (prefix "")) + (with-resources ((imode (set-indent-mode *stdout* indent-foff) + (set-indent-mode *stdout* imode)) + (depth (set-max-depth *stdout* 2) + (set-max-depth *stdout* depth)) + (length (set-max-length *stdout* 10) + (set-max-length *stdout* length))) + (window-mapdo 1 nil (lambda (pr el nx) el.(print-trace pr nx prefix)) + (find-frames-by-mask (logior uw-fcall uw-eval uw-expand))))) + +(defun debugger () + (with-disabled-debugging + (sys:repl nil *stdin* *stdout* %dbg-command-env%))) diff --git a/stdlib/defset.tl b/stdlib/defset.tl new file mode 100644 index 00000000..15b44411 --- /dev/null +++ b/stdlib/defset.tl @@ -0,0 +1,130 @@ +;; Copyright 2019-2021 +;; Kaz Kylheku <kaz@kylheku.com> +;; Vancouver, Canada +;; 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 HOLDER 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. + + +(compile-only + (load-for (struct sys:param-parser-base "param"))) + +(defun mac-env-flatten (env) + (when env + (let ((lexvars [mapcar car + [keep-if (op eq 'sys:special) + (env-vbindings env) cdr]])) + (append (mac-env-flatten (env-next env)) lexvars)))) + +(defun analyze-params (params) + (let* ((env (gensym)) + (lam ^(lambda ,params + (macrolet ((,env (:env e) + (set (symbol-value ',env) e))) + (,env)))) + (explam (expand lam)) + (syms (mac-env-flatten (symbol-value env)))) + (list (cadr explam) syms))) + +(defun defset-expander-simple (macform get-fun set-fun) + (with-gensyms (getter setter params) + ^(defplace (,get-fun . ,params) body + (,getter ,setter + (let ((pgens (mapcar (ret (gensym)) ,params))) + ^(alet ,(zip pgens (list ,*params)) + (macrolet ((,,getter () ^(,',',get-fun ,*',pgens)) + (,,setter (val) ^(,',',set-fun ,*',pgens ,val))) + ,body))))))) + +(defun defset-expander (env macform name params newval setform) + (with-gensyms (getter setter args gpf-pairs gpr-pairs ext-pairs + pgens rgens egens all-pairs agens nvsym) + (let* ((ap (analyze-params params)) + (exp-params (car ap)) + (total-syms (cadr ap)) + (fp (new fun-param-parser form macform syntax exp-params)) + (fixpars (append fp.req fp.(opt-syms))) + (restpar (if (symbol-package fp.rest) fp.rest)) + (extsyms [keep-if symbol-package + (diff total-syms (cons restpar fixpars))]) + (xsetform ^^(alet ((,',nvsym ,,newval)) + ,,(expand ^(symacrolet ((,newval ',nvsym)) + ,setform) + env)))) + ^(defplace (,name . ,args) body + (,getter ,setter + (tree-bind ,params ,args + (let* ((,gpf-pairs (mapcar (op (fun list) (gensym)) (list ,*fixpars))) + (,gpr-pairs (if ',restpar + (if (consp ,restpar) + (mapcar (op (fun list) (gensym)) ,restpar) + (list (list (gensym) ,restpar))))) + (,ext-pairs (mapcar (op (fun list) (gensym)) (list ,*extsyms))) + (,pgens (mapcar (fun car) ,gpf-pairs)) + (,rgens (mapcar (fun car) ,gpr-pairs)) + (,egens (mapcar (fun car) ,ext-pairs)) + (,all-pairs (append ,gpf-pairs ,gpr-pairs ,ext-pairs)) + (,agens (collect-each ((a ,args)) + (let ((p (pos a ,all-pairs (fun eq) (fun cadr)))) + (if p + (car (del [,all-pairs p])) + a))))) + ^(alet (,*,gpf-pairs ,*,gpr-pairs ,*,ext-pairs) + ,(expand ^(symacrolet (,*(zip ',fixpars + (mapcar (ret ^',@1) ,pgens)) + ,*(zip ',extsyms + (mapcar (ret ^',@1) ,egens)) + ,*(if ,gpr-pairs + (if (consp ,restpar) + ^((,',restpar ',,rgens)) + ^((,',restpar ',(car ,rgens)))))) + (macrolet ((,,getter () ^(,',',name ,',*,agens)) + (,,setter (,',newval) + ,',xsetform)) + ,body)) + ,env))))))))) + +(defmacro usr:defset (:env e :form mf . args) + (tree-case args + ((name (. params) newval setform) + (defset-expander e mf . args)) + ((get-fun set-fun) + (defset-expander-simple mf get-fun set-fun)) + (x (compile-error mf "invalid syntax")))) + +(defset sub-list (list : (from 0) (to t)) items + ^(progn (set ,list (replace-list ,list ,items ,from ,to)) ,items)) + +(defset sub-vec (vec : (from 0) (to t)) items + ^(progn (replace-vec ,vec ,items ,from ,to) ,items)) + +(defset sub-str (str : (from 0) (to t)) items + ^(progn (replace-str ,str ,items ,from ,to) ,items)) + +(defset left (node) nleft + ^(progn (set-left ,node ,nleft) ,nleft)) + +(defset right (node) nright + ^(progn (set-right ,node ,nright) ,nright)) + +(defset key (node) nkey + ^(progn (set-key ,node ,nkey) ,nkey)) diff --git a/stdlib/doc-lookup.tl b/stdlib/doc-lookup.tl new file mode 100644 index 00000000..f1d0d380 --- /dev/null +++ b/stdlib/doc-lookup.tl @@ -0,0 +1,49 @@ +(load "doc-syms") + +(defvarl usr:*doc-url* "https://www.nongnu.org/txr/txr-manpage.html") + +(defvar os-symbol + (if (ignerr (dlsym (dlopen "libandroid.so") "AAsset_close")) + :android + (let ((u (uname))) + [(orf (iff (f^ #/Linux/) (ret :linux)) + (iff (f^ #/SunOS/) + (ret (if (<= 5 (int-str u.release)) + :solaris10 + :solaris))) + (iff (f^ #/CYGWIN/) (ret :cygwin)) + (iff (f^ #/CYGNAL/) (ret :cygnal)) + (iff (f^ #/Darwin/) (ret :macos)) + (ret :unknown)) + u.sysname]))) + +(caseql os-symbol + ((:linux :macos :solaris :solaris10 :android) + (defun open-url (url) + (if (zerop (run (caseql os-symbol + ((:linux :solaris :android) "xdg-open") + (:solaris10 "/usr/dt/bin/sdtwebclient") + (:macos "open")) + (list url))) + t + (error `~s: failed to open ~s` 'open-url url)))) + ((:cygwin :cygnal) + (with-dyn-lib "shell32.dll" + (deffi shell-execute "ShellExecuteW" + cptr (cptr wstr wstr wstr wstr int)) + (defun open-url (url) + (let ((hinst (shell-execute cptr-null "open" url nil nil 0))) + (if (> (int-cptr hinst) 32) + t + (error `~s: failed to open ~s` 'open-url url)))))) + (t (defun open-url (url) (error "~s: not implemented" 'open-url)))) + +(defun usr:doc (: sym) + (iflet ((str (typecase sym + (null sym) + (sym (let ((*package* (find-package "pub"))) + (tostring sym))) + (t (tostringp sym)))) + (tag (if str [doc-syms str] ""))) + (open-url `@{*doc-url*}#@tag`) + (error "~s: ~s not found in symbol index" 'doc sym))) diff --git a/stdlib/doc-syms.tl b/stdlib/doc-syms.tl new file mode 100644 index 00000000..5bf473ee --- /dev/null +++ b/stdlib/doc-syms.tl @@ -0,0 +1,2084 @@ +(defparml doc-syms + (hash-from-pairs + '(("!>" "N-02B10DF9") + ("%e%" "N-03F0FA9E") + ("%pi%" "N-03F0FA9E") + ("*" "N-022396F7") + ("*-1" "N-02B67C9B") + ("*-2" "N-02B67C9B") + ("*-20" "N-02B67C9B") + ("*0" "N-03F9BE17") + ("*1" "N-03F9BE17") + ("*2" "N-03F9BE17") + ("*99" "N-03F9BE17") + ("*args*" "N-03DEE18A") + ("*args-eff*" "N-03DEE18A") + ("*args-full*" "N-03DEE18A") + ("*doc-url*" "N-0003D10B") + ("*expand" "N-00E0F5F5") + ("*filters*" "N-00E6A902") + ("*gensym-counter*" "N-0387B1B1") + ("*hash-seed*" "N-0041D85A") + ("*listener-greedy-eval-p*" "N-002B819C") + ("*listener-hist-len*" "N-007B676F") + ("*listener-multi-line-p*" "N-02C5CACF") + ("*listener-pprint-p*" "N-01E7ACFE") + ("*listener-sel-inclusive-p*" "N-02E4924F") + ("*load-path*" "N-01D1DB58") + ("*match-macro*" "N-012A473F") + ("*n" "N-02E7AE5A") + ("*opt-level*" "N-03F68BBC") + ("*package*" "N-000CBBA0") + ("*package-alist*" "N-00E20381") + ("*param-macro*" "N-03B67ED8") + ("*place-clobber-expander*" "N-01A2C58A") + ("*place-delete-expander*" "N-01A2C58A") + ("*place-macro*" "N-01B680E6") + ("*place-update-expander*" "N-01A2C58A") + ("*pprint-flo-format*" "N-02B252AA") + ("*print-base*" "N-01DD07CC") + ("*print-circle*" "N-01FC9977") + ("*print-flo-digits*" "N-00F41F6C") + ("*print-flo-format*" "N-02B252AA") + ("*print-flo-precision*" "N-02E97D03") + ("*r" "N-03A7AE5A") + ("*random-state*" "N-033875AD") + ("*random-warmup*" "N-010348CD") + ("*read-unknown-structs*" "N-0174F337") + ("*rec-source-loc*" "N-014AFEA9") + ("*stddebug*" "N-006566FB") + ("*stderr*" "N-006566FB") + ("*stdin*" "N-006566FB") + ("*stdlog*" "N-02841215") + ("*stdnull*" "N-006566FB") + ("*stdout*" "N-006566FB") + ("*trace-output*" "N-0067A6AC") + ("*tree-fun-whitelist*" "N-025AB9C9") + ("*unhandled-hook*" "N-02B4A4FB") + ("*v" "N-0367AE5A") + ("+" "D-0045") + ("-" "D-004B") + ("--" "N-0234C408") + ("--args" "N-03FCDE42") + ("--eargs" "N-03FCDE42") + ("--rng" "N-00BEA6DF") + ("--rng+" "N-00BEA6DF") + ("--rng-" "N-00BEA6DF") + ("->" "N-02B10DF9") + ("->>" "N-02B10DF9") + ("-C" "N-036F1A29") + ("-rng" "N-00BEA6DF") + ("-rng+" "N-00BEA6DF") + ("-rng-" "N-00BEA6DF") + (".." "N-0217A971") + ("..." "D-0035") + ("/" "D-004A") + ("//" "N-0054C409") + ("/=" "N-003BE40C") + (":key" "N-01697547") + (":match" "N-03B92C0D") + ("<" "D-0058") + ("<!" "N-02B10DF9") + ("<-" "N-02B10DF9") + ("<=" "D-001E") + ("=" "D-0078") + (">" "D-0061") + (">=" "D-0054") + ("TXR_COMPAT" "N-03F5D03D") + ("abort" "N-02F934F6") + ("abs" "D-0017") + ("abs-path-p" "N-00477B23") + ("accept" "D-0044") + ("acons" "N-02E9343D") + ("acons-new" "N-0371BAFA") + ("aconsql-new" "N-01E315BD") + ("acos" "D-0028") + ("acosh" "D-0042") + ("add" "N-03244398") + ("add*" "N-03244398") + ("addrinfo" "N-0110E961") + ("ado" "N-00BE749A") + ("af-inet" "N-0228EAE0") + ("af-inet6" "N-0228EAE0") + ("af-unix" "N-0228EAE0") + ("again" "N-000CD1AE") + ("ai-addrconfig" "N-020DFFDE") + ("ai-all" "N-020DFFDE") + ("ai-numerichost" "N-020DFFDE") + ("ai-numericserv" "N-020DFFDE") + ("ai-passive" "N-020DFFDE") + ("ai-v4mapped" "N-020DFFDE") + ("alet" "N-008215E0") + ("align" "N-01C7BC08") + ("alignof" "N-000F730E") + ("alist-nremove" "N-000CD07F") + ("alist-remove" "N-001A53C4") + ("all" "D-0055") + ("all*" "N-00F6E2A2") + ("allocate-struct" "N-03168BF2") + ("and" "D-0069") + ("andf" "N-01E7D2AD") + ("ap" "N-00BE749A") + ("apf" "N-012A7E6A") + ("append" "N-0014162F") + ("append*" "N-01143C2A") + ("append-each" "N-0105F01D") + ("append-each*" "N-0105F01D") + ("append-each-prod" "N-02CA3C70") + ("append-each-prod*" "N-02660E4F") + ("append-match-products" "N-026DC56D") + ("append-matches" "N-026DC56D") + ("apply" "N-026C3723") + ("aret" "N-008216A8") + ("arg" "N-02133AA5") + ("array" "N-0117BE95") + ("arraysize" "N-002129D6") + ("as" "N-028B26DD") + ("ash" "D-0064") + ("asin" "D-003D") + ("asinh" "D-0004") + ("assert" "D-0060") + ("assoc" "N-00E9306D") + ("assq" "N-00123702") + ("assql" "N-00123702") + ("at-exit-call" "N-003EEEF5") + ("at-exit-do-not-call" "N-003EEEF5") + ("atan" "D-0051") + ("atan2" "D-000A") + ("atanh" "D-0024") + ("atom" "N-0076C7BE") + ("awk" "D-0059") + ("base-name" "N-02C01721") + ("base64-decode" "N-01B05083") + ("base64-decode-buf" "N-01B05083") + ("base64-encode" "N-01B05083") + ("base64-stream-dec" "N-03BEDB34") + ("base64-stream-enc" "N-03BEDB34") + ("base64url-decode" "N-02D46C3D") + ("base64url-decode-buf" "N-02D46C3D") + ("base64url-encode" "N-02D46C3D") + ("base64url-stream-dec" "N-016A14B3") + ("base64url-stream-enc" "N-016A14B3") + ("bchar" "N-0008D7DC") + ("bignum-len" "N-020294AB") + ("bignump" "N-03E9D6E1") + ("bind" "D-006E") + ("bindable" "N-0222F2E3") + ("bit" "D-004D") + ("bitset" "D-0038") + ("blkcnt-t" "N-01D716FE") + ("blksize-t" "N-01D716FE") + ("block" "D-0070") + ("block*" "N-02F60DCE") + ("bool" "D-002D") + ("boundp" "N-01FBF828") + ("bracket" "N-02400F97") + ("break-str" "N-00A9DB25") + ("brkint" "N-02391683") + ("bs0" "N-03BD477F") + ("bs1" "N-03BD477F") + ("bsdly" "N-03BD477F") + ("bstr" "N-00C6B7C4") + ("bstr-d" "N-00C6B7C4") + ("buf" "D-005F") + ("buf-alloc-size" "N-013A3727") + ("buf-carray" "N-0022F54E") + ("buf-d" "D-0014") + ("buf-get-" "N-0095470A") + ("buf-get-char" "N-03E9074A") + ("buf-get-cptr" "N-00E90766") + ("buf-get-double" "N-006C6EB9") + ("buf-get-float" "N-001D239A") + ("buf-get-i16" "N-02E7C970") + ("buf-get-i32" "N-0127C970") + ("buf-get-i64" "N-03C7C972") + ("buf-get-i8" "N-0013E55F") + ("buf-get-int" "N-03C7C985") + ("buf-get-long" "N-02190DE0") + ("buf-get-short" "N-031CE896") + ("buf-get-u16" "N-02E7C960") + ("buf-get-u32" "N-0127C960") + ("buf-get-u64" "N-03C7C962") + ("buf-get-u8" "N-0013E556") + ("buf-get-uchar" "N-03BCF5D1") + ("buf-get-uint" "N-030913C8") + ("buf-get-ulong" "N-020CEF9D") + ("buf-get-ushort" "N-035691E9") + ("buf-int" "N-0291625A") + ("buf-list" "N-03E81617") + ("buf-put-" "N-035546D9") + ("buf-put-buf" "N-009FC934") + ("buf-put-char" "N-00690748") + ("buf-put-cptr" "N-03690764") + ("buf-put-double" "N-006A81D9") + ("buf-put-float" "N-001D2408") + ("buf-put-i16" "N-019FC970") + ("buf-put-i32" "N-035FC973") + ("buf-put-i64" "N-007FC973") + ("buf-put-i8" "N-002F655F") + ("buf-put-int" "N-007FC982") + ("buf-put-long" "N-00990DE3") + ("buf-put-short" "N-031CE904") + ("buf-put-u16" "N-019FC960") + ("buf-put-u32" "N-035FC963") + ("buf-put-u64" "N-007FC963") + ("buf-put-u8" "N-002F6556") + ("buf-put-uchar" "N-03BCF627") + ("buf-put-uint" "N-018913CB") + ("buf-put-ulong" "N-020CF007") + ("buf-put-ushort" "N-035696C9") + ("buf-set-length" "N-01208847") + ("buf-str" "N-012BF6AD") + ("buf-trim" "N-0057FBE2") + ("buf-uint" "N-0291625A") + ("bufp" "N-02C6CEE4") + ("build" "N-01346AAA") + ("build-list" "N-0315C467") + ("buildn" "N-01346AAA") + ("butlast" "N-026BB6FA") + ("butlastn" "N-01E2C334") + ("caar" "N-00209CEE") + ("cadr" "N-00209CEE") + ("call" "N-0386C775") + ("call-clobber-expander" "N-0223827D") + ("call-delete-expander" "N-021E7CC3") + ("call-finalizers" "N-02AF83A0") + ("call-super-fun" "N-0223E999") + ("call-super-method" "N-016185D1") + ("call-update-expander" "N-03B6BCE9") + ("callf" "N-00192C21") + ("car" "D-0023") + ("carray" "N-0139F9ED") + ("carray-blank" "N-00DD8DF1") + ("carray-buf" "N-00D75AD6") + ("carray-buf-sync" "N-02F23E0F") + ("carray-cptr" "N-03E001C5") + ("carray-dup" "N-00058922") + ("carray-free" "N-0010030E") + ("carray-get" "N-028920F5") + ("carray-getz" "N-028920F5") + ("carray-int" "N-02403ED4") + ("carray-list" "N-00E825E0") + ("carray-own" "N-00058922") + ("carray-pun" "N-0057639E") + ("carray-put" "N-02890B44") + ("carray-putz" "N-02890B44") + ("carray-ref" "N-001F5BCA") + ("carray-refset" "N-000127F9") + ("carray-replace" "N-01AAF602") + ("carray-set-length" "N-00705BC4") + ("carray-sub" "N-03DF5BC5") + ("carray-type" "N-030FEDE6") + ("carray-uint" "N-02403ED4") + ("carray-vec" "N-00E825E0") + ("carrayp" "N-027E7FFC") + ("caseq" "N-017EB9A1") + ("caseq*" "N-02FB71A2") + ("caseql" "N-017EB9A1") + ("caseql*" "N-02FB71A2") + ("casequal" "N-017EB9A1") + ("casequal*" "N-02FB71A2") + ("cases" "N-039458F2") + ("cat" "N-03336E1B") + ("cat-str" "N-00B6ACE3") + ("cat-streams" "N-020BF082") + ("cat-vec" "N-01AEB28B") + ("catch" "D-0011") + ("catch*" "N-0211F3D3") + ("catch**" "N-0211F3D3") + ("catch-frame" "N-0233BAE3") + ("catenated-stream-p" "N-021EE493") + ("catenated-stream-push" "N-0050A46A") + ("cbaud" "N-01B1B5DF") + ("cbaudex" "N-01B1B5DF") + ("cdar" "N-00209CEE") + ("cdddddr" "N-00209CEE") + ("cddr" "N-00209CEE") + ("cdr" "D-0077") + ("ceil" "D-007C") + ("ceil-rem" "N-02DE978F") + ("ceil1" "N-02C8FF28") + ("chain" "N-00C53CF7") + ("chand" "N-00C53CF7") + ("char" "N-0008D7DC") + ("chdir" "N-03D941C3") + ("chmod" "N-00F941E5") + ("chmod-rec" "N-02D8298E") + ("choose" "N-039458F2") + ("chown" "N-003B491C") + ("chown-rec" "N-02D8298E") + ("chr" "N-02D5D09D") + ("chr-digit" "N-01ED5020") + ("chr-int" "N-000AEC8B") + ("chr-isalnum" "N-01B18DF0") + ("chr-isalpha" "N-00F18E1B") + ("chr-isascii" "N-0171941F") + ("chr-isblank" "N-0251A159") + ("chr-iscntrl" "N-02A1A5A8") + ("chr-isdigit" "N-01ED5020") + ("chr-isgraph" "N-00617BD5") + ("chr-islower" "N-02BB58D0") + ("chr-isprint" "N-001B5076") + ("chr-ispunct" "N-011B4F35") + ("chr-isspace" "N-002B4C59") + ("chr-isunisp" "N-00DB3D75") + ("chr-isupper" "N-02BB451C") + ("chr-isxdigit" "N-021C89F4") + ("chr-str" "N-0378FEF2") + ("chr-str-set" "N-01743140") + ("chr-tolower" "N-015A58D0") + ("chr-toupper" "N-015A451C") + ("chr-xdigit" "N-021C89F4") + ("chrp" "N-02C6CEED") + ("clamp" "N-03B940D4") + ("clear-cflags" "N-02061924") + ("clear-dirty" "N-03AB857D") + ("clear-error" "D-000C") + ("clear-iflags" "N-02061924") + ("clear-lflags" "N-02061924") + ("clear-oflags" "N-02061924") + ("clear-struct" "N-03A968CA") + ("clearhash" "N-00836D97") + ("clocal" "N-01B1B5DF") + ("clock-t" "N-03258244") + ("clockid-t" "N-01D716FE") + ("close" "D-0016") + ("close-stream" "N-00596930") + ("closedir" "N-01FEE88A") + ("closelog" "N-02CEE7EA") + ("closure" "N-0216EF16") + ("cmp-str" "N-0143A273") + ("cmspar" "N-01B1B5DF") + ("coded-length" "N-0167F423") + ("coll" "D-005A") + ("collect" "D-0030") + ("collect-each" "N-0105F01D") + ("collect-each*" "N-0105F01D") + ("collect-each-prod" "N-02CA3C70") + ("collect-each-prod*" "N-02660E4F") + ("comb" "N-02E6CEDD") + ("command-get" "N-0062A33B") + ("command-get-buf" "N-00FA177D") + ("command-get-json" "N-028645A2") + ("command-get-jsons" "N-028645A2") + ("command-get-lines" "N-0062A33B") + ("command-get-string" "N-0062A33B") + ("command-put" "N-024D65F3") + ("command-put-buf" "N-02AE3A31") + ("command-put-json" "N-029045AE") + ("command-put-jsons" "N-029045AE") + ("command-put-lines" "N-024D65F3") + ("command-put-string" "N-024D65F3") + ("compare-swap" "N-02933F2A") + ("compile" "N-009542C1") + ("compile-defr-warning" "N-0205E7AF") + ("compile-error" "N-032EA7D7") + ("compile-file" "N-0211BE68") + ("compile-only" "N-030BF4F5") + ("compile-toplevel" "N-00DE8B13") + ("compile-update-file" "N-0211BE68") + ("compile-warning" "N-032EA7D7") + ("compl-span-str" "N-0171717F") + ("cond" "N-016C9E24") + ("conda" "N-025CC33C") + ("condlet" "N-03272DC8") + ("cons" "N-02D6CEDA") + ("conses" "N-00BBCCAA") + ("conses*" "N-00BBCCAA") + ("consp" "N-01B94132") + ("constantp" "N-0172F00A") + ("contains" "N-010AB2D7") + ("copy" "N-0036CED9") + ("copy-alist" "N-037A7464") + ("copy-buf" "N-00BE75E1") + ("copy-carray" "N-006593D0") + ("copy-cons" "N-037EBB77") + ("copy-file" "N-019D6582") + ("copy-files" "N-019D6582") + ("copy-fun" "N-003E7671") + ("copy-hash" "N-030E3A4A") + ("copy-list" "N-006ED237") + ("copy-path-rec" "N-034734A3") + ("copy-search-tree" "N-01EBE427") + ("copy-str" "N-02FE763D") + ("copy-struct" "N-032B3FDC") + ("copy-tnode" "N-018A17C0") + ("copy-tree" "N-015EB85E") + ("copy-tree-iter" "N-025C3140") + ("copy-vec" "N-010E7635") + ("cos" "D-0021") + ("cosh" "D-0080") + ("count-if" "N-00BBC726") + ("count-until-match" "N-00EFD668") + ("countq" "N-01DF131F") + ("countql" "N-01DF131F") + ("countqual" "N-01DF131F") + ("cptr" "D-0013") + ("cptr-buf" "N-037139E3") + ("cptr-cast" "N-01A212ED") + ("cptr-free" "N-02B1FBEF") + ("cptr-get" "N-00513A70") + ("cptr-int" "N-015139D6") + ("cptr-null" "N-01CB17AB") + ("cptr-obj" "N-013139D1") + ("cptr-put" "N-00513A38") + ("cptr-size-hint" "N-024CD90F") + ("cptr-type" "N-03B1F90C") + ("cptr-zap" "N-00913A85") + ("cptrp" "N-02B9289A") + ("cr0" "N-03BD477F") + ("cr1" "N-03BD477F") + ("cr2" "N-03BD477F") + ("cr3" "N-03BD477F") + ("crc32" "N-01D92859") + ("crc32-stream" "N-0119CE1D") + ("crdly" "N-03BD477F") + ("cread" "N-01B1B5DF") + ("crtscts" "N-01B1B5DF") + ("crypt" "N-00F928CE") + ("cs5" "N-01B1B5DF") + ("cs6" "N-01B1B5DF") + ("cs7" "N-01B1B5DF") + ("cs8" "N-01B1B5DF") + ("csize" "N-01B1B5DF") + ("cstopb" "N-01B1B5DF") + ("cum-norm-dist" "N-03AB449B") + ("cxr" "N-01DA4F04") + ("cyr" "N-01DA4F04") + ("daemon" "N-017C3515") + ("data" "N-03B6EA7D") + ("dec" "N-03A0AABD") + ("defer-warning" "N-001106AB") + ("defex" "D-005E") + ("deffi" "N-00DCE51D") + ("deffi-cb" "N-00C54FC8") + ("deffi-cb-unsafe" "N-00C54FC8") + ("deffi-struct" "N-0040FFE6") + ("deffi-sym" "N-02B237BB") + ("deffi-union" "N-0040FFE6") + ("deffi-var" "N-03C237C9") + ("deffilter" "N-00BDE41F") + ("define-accessor" "N-03C5F850") + ("define-modify-macro" "N-006E03C4") + ("define-option-struct" "N-0126C738") + ("define-param-expander" "N-019F25A5") + ("define-place-macro" "N-02C3089A") + ("defmacro" "N-02CAEF0B") + ("defmatch" "N-0049315A") + ("defmeth" "N-0047C7E8") + ("defpackage" "N-033951A2") + ("defparm" "N-039DD0E7") + ("defparml" "N-03F36A75") + ("defplace" "N-00F92066") + ("defset" "N-0157E559") + ("defstruct" "N-021CC672") + ("defsymacro" "N-0080256D") + ("defun" "N-00B44934") + ("defun-match" "N-02BF0F8C") + ("defvar" "N-039DD0E7") + ("defvarl" "N-03F36A75") + ("del" "D-0022") + ("del*" "N-0166445C") + ("delay" "N-00DCE524") + ("delete-package" "N-02E687F3") + ("derived" "N-0151798B") + ("dev-t" "N-01D716FE") + ("diff" "N-0385B074") + ("digits" "N-03CC559E") + ("digpow" "N-030C5561") + ("dir-name" "N-02C01721") + ("dirent" "N-036FE5B4") + ("dirstat" "N-02507FF2") + ("disassemble" "N-0289A0F1") + ("display-width" "N-0263C039") + ("divides" "N-02A088B3") + ("dlclose" "N-033F7DE5") + ("dlopen" "N-037C4BFE") + ("dlsym" "N-01B1E865") + ("dlsym-checked" "N-029063A0") + ("dlvsym" "N-01B1E865") + ("dlvsym-checked" "N-029063A0") + ("do" "D-0072") + ("doc" "N-0097F54C") + ("dohash" "N-039105E8") + ("doloop" "N-01FF4DDB") + ("doloop*" "N-01FF4DDB") + ("dotimes" "N-02D31F8C") + ("double" "N-03237030") + ("downcase-str" "N-03DA541E") + ("drop" "N-01C6C906") + ("drop-until" "N-011E5936") + ("drop-while" "N-011E5936") + ("dt-blk" "N-02D8CAF4") + ("dt-chr" "N-02D8CAF4") + ("dt-dir" "N-02D8CAF4") + ("dt-fifo" "N-02D8CAF4") + ("dt-lnk" "N-02D8CAF4") + ("dt-reg" "N-02D8CAF4") + ("dt-sock" "N-02D8CAF4") + ("dt-unknown" "N-02D8CAF4") + ("dump-compiled-objects" "N-02FE7607") + ("dump-deferred-warnings" "N-0335651E") + ("dup" "N-0387F549") + ("dupfd" "N-01F91AEF") + ("dwim" "D-001F") + ("e2big" "N-036B1BDB") + ("eacces" "N-036B1BDB") + ("each" "N-0105F01D") + ("each*" "N-0105F01D") + ("each-match" "N-01CB9595") + ("each-match-product" "N-01CB9595") + ("each-prod" "N-02CA3C70") + ("each-prod*" "N-02660E4F") + ("eaddrinuse" "N-036B1BDB") + ("eaddrnotavail" "N-036B1BDB") + ("eafnosupport" "N-036B1BDB") + ("eagain" "N-036B1BDB") + ("ealready" "N-036B1BDB") + ("ebadf" "N-036B1BDB") + ("ebadmsg" "N-036B1BDB") + ("ebusy" "N-036B1BDB") + ("ecanceled" "N-036B1BDB") + ("echild" "N-036B1BDB") + ("echo" "N-0072FF5E") + ("echoctl" "N-0072FF5E") + ("echoe" "N-0072FF5E") + ("echok" "N-0072FF5E") + ("echoke" "N-0072FF5E") + ("echonl" "N-0072FF5E") + ("echoprt" "N-0072FF5E") + ("econnaborted" "N-036B1BDB") + ("econnrefused" "N-036B1BDB") + ("econnreset" "N-036B1BDB") + ("edeadlk" "N-036B1BDB") + ("edestaddrreq" "N-036B1BDB") + ("edom" "N-036B1BDB") + ("edquot" "N-036B1BDB") + ("eexist" "N-036B1BDB") + ("efault" "N-036B1BDB") + ("efbig" "N-036B1BDB") + ("ehostunreach" "N-036B1BDB") + ("eidrm" "N-036B1BDB") + ("eighth" "N-01B0FA33") + ("eilseq" "N-036B1BDB") + ("einprogress" "N-036B1BDB") + ("eintr" "N-036B1BDB") + ("einval" "N-036B1BDB") + ("eio" "N-036B1BDB") + ("eisconn" "N-036B1BDB") + ("eisdir" "N-036B1BDB") + ("elemsize" "N-01D55CC4") + ("elemtype" "D-0006") + ("eloop" "N-036B1BDB") + ("emfile" "N-036B1BDB") + ("emlink" "N-036B1BDB") + ("empty" "N-004918EB") + ("emsgsize" "N-036B1BDB") + ("emultihop" "N-036B1BDB") + ("enametoolong" "N-036B1BDB") + ("end" "N-037C6608") + ("endgrent" "N-02CAC7FB") + ("endp" "N-00C6C858") + ("endpwent" "N-0377C43A") + ("ends-with" "N-004955D4") + ("enetdown" "N-036B1BDB") + ("enetreset" "N-036B1BDB") + ("enetunreach" "N-036B1BDB") + ("enfile" "N-036B1BDB") + ("enobufs" "N-036B1BDB") + ("enodata" "N-036B1BDB") + ("enodev" "N-036B1BDB") + ("enoent" "N-036B1BDB") + ("enoexec" "N-036B1BDB") + ("enolck" "N-036B1BDB") + ("enolink" "N-036B1BDB") + ("enomem" "N-036B1BDB") + ("enomsg" "N-036B1BDB") + ("enoprotoopt" "N-036B1BDB") + ("enospc" "N-036B1BDB") + ("enosr" "N-036B1BDB") + ("enostr" "N-036B1BDB") + ("enosys" "N-036B1BDB") + ("enotconn" "N-036B1BDB") + ("enotdir" "N-036B1BDB") + ("enotempty" "N-036B1BDB") + ("enotrecoverable" "N-036B1BDB") + ("enotsock" "N-036B1BDB") + ("enotsup" "N-036B1BDB") + ("enotty" "N-036B1BDB") + ("ensure-dir" "N-00C543B8") + ("enum" "N-01CDE57C") + ("enumed" "N-01096D60") + ("env" "N-0267F548") + ("env-fbind" "N-03389BE3") + ("env-fbindings" "N-0018DCDC") + ("env-hash" "N-011814B5") + ("env-next" "N-0018DCDC") + ("env-vbind" "N-03389BE3") + ("env-vbindings" "N-0018DCDC") + ("enxio" "N-036B1BDB") + ("eopnotsupp" "N-036B1BDB") + ("eoverflow" "N-036B1BDB") + ("eownerdead" "N-036B1BDB") + ("eperm" "N-036B1BDB") + ("epipe" "N-036B1BDB") + ("eproto" "N-036B1BDB") + ("eprotonosupport" "N-036B1BDB") + ("eprototype" "N-036B1BDB") + ("eq" "N-02550B35") + ("eql" "N-02550B35") + ("equal" "D-007A") + ("equot" "N-02ACCDDF") + ("erange" "N-036B1BDB") + ("erofs" "N-036B1BDB") + ("errno" "N-03A7137C") + ("error" "N-015466AD") + ("espipe" "N-036B1BDB") + ("esrch" "N-036B1BDB") + ("estale" "N-036B1BDB") + ("etime" "N-036B1BDB") + ("etimedout" "N-036B1BDB") + ("etxtbsy" "N-036B1BDB") + ("eval" "N-0286C8B8") + ("eval-only" "N-030BF4F5") + ("evenp" "D-001C") + ("ewouldblock" "N-036B1BDB") + ("exception-subtype-map" "N-03ABFA6D") + ("exception-subtype-p" "N-02E7F869") + ("exdev" "N-036B1BDB") + ("exec" "N-02D6C913") + ("exit" "N-0006C92F") + ("exit*" "N-03592671") + ("exp" "D-0036") + ("expand" "N-00E0F5F5") + ("expand-left" "N-00E168FE") + ("expand-right" "N-023B6B64") + ("expand-with-free-refs" "N-0334827B") + ("expt" "D-0076") + ("exptmod" "D-0037") + ("extproc" "N-0072FF5E") + ("f" "N-003BDFA9") + ("f$" "N-000B5ACD") + ("f-dupfd" "N-025E55E7") + ("f-dupfd-cloexec" "N-025E55E7") + ("f-getfd" "N-025E55E7") + ("f-getfl" "N-025E55E7") + ("f-getlk" "N-025E55E7") + ("f-rdlck" "N-0137046C") + ("f-setfd" "N-025E55E7") + ("f-setfl" "N-025E55E7") + ("f-setlk" "N-025E55E7") + ("f-setlkw" "N-025E55E7") + ("f-unlck" "N-0137046C") + ("f-wrlck" "N-0137046C") + ("f^" "N-000B5ACD") + ("f^$" "N-000B5ACD") + ("false" "N-03C679D2") + ("fboundp" "N-01FBF828") + ("fcntl" "N-03793032") + ("fconv" "N-018CCE37") + ("fd-cloexec" "N-021805C2") + ("ff" "N-006B6E54") + ("ff0" "N-03BD477F") + ("ff1" "N-03BD477F") + ("ffdly" "N-03BD477F") + ("ffi" "N-020F3A1C") + ("ffi-alignof" "N-00061B61") + ("ffi-arraysize" "N-03DC1AED") + ("ffi-call" "N-023DCFF9") + ("ffi-elemsize" "N-00DF8E15") + ("ffi-elemtype" "N-02DF8E12") + ("ffi-get" "N-023305C7") + ("ffi-in" "N-037AAB17") + ("ffi-make-call-desc" "N-01A96E1C") + ("ffi-make-closure" "N-0095DF58") + ("ffi-offsetof" "N-0318DA0C") + ("ffi-out" "N-02330623") + ("ffi-put" "N-0000F6A9") + ("ffi-put-into" "N-0000F6A9") + ("ffi-size" "N-00CDBB53") + ("ffi-type-compile" "N-02940F9A") + ("ffi-type-operator-p" "N-00E31038") + ("ffi-type-p" "N-01EE962E") + ("ffi-typedef" "N-0094D6D7") + ("fifth" "N-01B0FA33") + ("file-append" "N-000CCA8A") + ("file-append-buf" "N-02AE3A31") + ("file-append-lines" "N-000CCA8A") + ("file-append-string" "N-000CCA8A") + ("file-get" "N-02238370") + ("file-get-buf" "N-00FA177D") + ("file-get-json" "N-03C963BD") + ("file-get-jsons" "N-03C963BD") + ("file-get-lines" "N-02238370") + ("file-get-string" "N-02238370") + ("file-put" "N-0041C2E5") + ("file-put-buf" "N-02AE3A31") + ("file-put-json" "D-002A") + ("file-put-jsons" "D-007D") + ("file-put-lines" "N-0041C2E5") + ("file-put-string" "N-0041C2E5") + ("fileno" "N-008ACF75") + ("fill-buf" "D-0026") + ("fill-buf-adjust" "N-00D142E1") + ("fill-carray" "N-00737951") + ("fill-obj" "N-0039A1D1") + ("fill-vec" "N-03C9A237") + ("filter" "N-00B50006") + ("filter-equal" "N-03136087") + ("filter-string-tree" "N-00C9EEB0") + ("finalize" "N-01230613") + ("finally" "D-0079") + ("find" "N-005431FF") + ("find-frame" "N-02B97226") + ("find-frames" "N-02B97226") + ("find-if" "N-005431FF") + ("find-max" "N-02BB4231") + ("find-min" "N-02BB4231") + ("find-package" "N-0250826D") + ("find-struct-type" "N-01E5EEA7") + ("find-symbol" "N-01EA8B50") + ("find-symbol-fb" "N-01EA8B50") + ("first" "N-02D60463") + ("fixnum-max" "N-02A6CE24") + ("fixnum-min" "N-02A6CE24") + ("fixnump" "N-03E9D6E1") + ("flatcar" "N-01FF2F12") + ("flatcar*" "N-01FF2F12") + ("flatten" "D-000D") + ("flatten*" "N-0226672B") + ("flet" "N-0209307D") + ("flip" "N-0042153F") + ("flipargs" "N-02D06BA4") + ("flo-dig" "N-00998CE7") + ("flo-down" "N-013A1643") + ("flo-epsilon" "N-0085F231") + ("flo-get-round-mode" "N-0085ACA3") + ("flo-int" "N-03F852CF") + ("flo-max" "N-0085F231") + ("flo-max-dig" "N-01A2123A") + ("flo-min" "N-0085F231") + ("flo-near" "N-013A1643") + ("flo-set-round-mode" "N-0085ACA3") + ("flo-str" "N-028043AE") + ("flo-up" "N-013A1643") + ("flo-zero" "N-013A1643") + ("float" "N-03237030") + ("floatp" "N-03E9D6E1") + ("flock" "N-004E5B3E") + ("floor" "D-0029") + ("floor-rem" "N-02DE978F") + ("floor1" "N-01ED20D1") + ("flow" "N-02B2153E") + ("flush" "N-02390935") + ("flush-stream" "N-03999913") + ("flusho" "N-0072FF5E") + ("fmakunbound" "N-02964FC0") + ("fmt" "N-0347F537") + ("fname" "N-039E5F67") + ("fnm-casefold" "N-0330E15A") + ("fnm-extmatch" "N-0330E15A") + ("fnm-leading-dir" "N-0330E15A") + ("fnm-noescape" "N-0330E15A") + ("fnm-pathname" "N-0330E15A") + ("fnm-period" "N-0330E15A") + ("fnmatch" "N-03F8FF75") + ("fnr" "N-02E33A82") + ("for" "N-031372ED") + ("for*" "N-031372ED") + ("force" "N-0307223D") + ("force-break" "N-03B5FB1D") + ("forget" "N-02A1EE04") + ("fork" "N-0365C3E1") + ("format" "N-011ACA52") + ("fourth" "N-01B0FA33") + ("fr$" "N-031971BD") + ("fr^" "N-031971BD") + ("fr^$" "N-031971BD") + ("frame" "N-0233BAE3") + ("freeform" "N-00334C65") + ("from" "N-00AED1A7") + ("from-list" "N-01FFD230") + ("frr" "N-031971BD") + ("fs" "N-03B6902C") + ("fsblkcnt-t" "N-01D716FE") + ("fsfilcnt-t" "N-01D716FE") + ("fstat" "N-006DE1CC") + ("ft" "N-03B6902C") + ("ftw" "N-0057F54E") + ("ftw-actionretval" "N-01A802F2") + ("ftw-chdir" "N-01A802F2") + ("ftw-continue" "N-03853999") + ("ftw-d" "N-02ED8B51") + ("ftw-depth" "N-01A802F2") + ("ftw-dnr" "N-02ED8B51") + ("ftw-dp" "N-02ED8B51") + ("ftw-f" "N-02ED8B51") + ("ftw-mount" "N-01A802F2") + ("ftw-ns" "N-02ED8B51") + ("ftw-phys" "N-01A802F2") + ("ftw-skip-siblings" "N-03853999") + ("ftw-skip-subtree" "N-03853999") + ("ftw-sl" "N-02ED8B51") + ("ftw-sln" "N-02ED8B51") + ("ftw-stop" "N-03853999") + ("fun" "N-006E109C") + ("fun-fixparam-count" "N-015852B6") + ("fun-optparam-count" "N-015852B6") + ("fun-variadic" "N-02AA3799") + ("func-get-env" "N-009538DB") + ("func-get-form" "N-00722170") + ("func-get-name" "N-03F222DA") + ("functionp" "N-00F6F5F8") + ("fuzz" "N-03CAE17D") + ("fw" "N-0357AE6F") + ("gather" "D-002B") + ("gcd" "N-03D44645") + ("gen" "N-0323BEBD") + ("gen-hash-seed" "N-002CFA72") + ("generate" "N-02F671F4") + ("gensym" "N-03AA7FBB") + ("gequal" "N-00A3E42D") + ("get" "N-03D9F55D") + ("get-buf-from-stream" "N-02954B48") + ("get-byte" "D-0063") + ("get-char" "D-0066") + ("get-error" "D-0033") + ("get-error-str" "D-0010") + ("get-fd" "N-011D42AB") + ("get-frames" "N-010405DA") + ("get-hash-userdata" "N-030B41A7") + ("get-indent" "N-024E9FD8") + ("get-indent-mode" "N-03F3170C") + ("get-json" "N-014295FE") + ("get-jsons" "N-0124D378") + ("get-line" "D-0018") + ("get-line-as-buf" "N-007FD2F9") + ("get-lines" "N-00B65D06") + ("get-list-from-stream" "N-021DF087") + ("get-obj" "N-0315B229") + ("get-prop" "N-00663AE2") + ("get-sig-handler" "N-02E1B6FA") + ("get-stack-limit" "N-02492D13") + ("get-string" "N-00BE9AAC") + ("get-string-from-stream" "N-037412EE") + ("getaddrinfo" "N-0363FE99") + ("getegid" "N-00125C22") + ("getenv" "N-002E0364") + ("geteuid" "N-00125C22") + ("getgid" "N-00125C22") + ("getgrent" "N-02CAC7FB") + ("getgrgid" "N-03E5634E") + ("getgrnam" "N-03556394") + ("getgroups" "N-030FEE9B") + ("gethash" "N-0203B5FA") + ("getitimer" "N-02DE107D") + ("getopts" "N-01A5A2FF") + ("getpid" "N-02D7B5A3") + ("getppid" "N-02D7B5A3") + ("getpwent" "N-0377C43A") + ("getpwnam" "N-03552854") + ("getpwuid" "N-03E528C6") + ("getresgid" "N-03D37234") + ("getresuid" "N-03D37234") + ("getuid" "N-00125C22") + ("gid-t" "N-01D716FE") + ("ginterate" "N-02F671F4") + ("giterate" "N-02F671F4") + ("glob" "N-00E6C7DE") + ("glob-altdirfunc" "N-0188409B") + ("glob-brace" "N-0188409B") + ("glob-err" "N-0188409B") + ("glob-mark" "N-0188409B") + ("glob-nocheck" "N-0188409B") + ("glob-noescape" "N-0188409B") + ("glob-nomagic" "N-0188409B") + ("glob-nosort" "N-0188409B") + ("glob-onlydir" "N-0188409B") + ("glob-period" "N-0188409B") + ("glob-tilde" "N-0188409B") + ("glob-tilde-check" "N-0188409B") + ("go" "N-007E0D96") + ("go-cbreak" "N-03DCB007") + ("go-raw" "N-03DCB007") + ("grade" "N-00091853") + ("greater" "N-02AC1F73") + ("group" "N-03DE71BA") + ("group-by" "N-02F6F229") + ("group-reduce" "N-001A208F") + ("gun" "N-0323BEBD") + ("handle" "N-03F7D8B5") + ("handle*" "N-03F7D8B5") + ("handle-frame" "N-0233BAE3") + ("handler-bind" "N-00A4ECC9") + ("hash" "D-0001") + ("hash-begin" "N-0225209D") + ("hash-construct" "N-017E6F4C") + ("hash-count" "N-00766C80") + ("hash-diff" "N-02235BB2") + ("hash-eql" "N-0000455E") + ("hash-equal" "N-0000455E") + ("hash-from-alist" "N-017E6F4C") + ("hash-from-pairs" "N-017E6F4C") + ("hash-invert" "N-01D4F138") + ("hash-isec" "N-02235BB2") + ("hash-keys-of" "N-02FBE776") + ("hash-list" "N-02EE9235") + ("hash-next" "N-0225209D") + ("hash-peek" "N-0225209D") + ("hash-proper-subset" "N-024ACBBB") + ("hash-reset" "N-0225209D") + ("hash-revget" "N-02FBE776") + ("hash-subset" "N-024ACBBB") + ("hash-symdiff" "N-02235BB2") + ("hash-uni" "N-02235BB2") + ("hash-update" "N-02DBCCC8") + ("hash-update-1" "N-03EF9A2C") + ("hash-userdata" "N-038C1CEB") + ("hash-zip" "N-02767282") + ("hash_alist" "N-01BD56A5") + ("hash_keys" "N-01BD56A5") + ("hash_pairs" "N-01BD56A5") + ("hash_values" "N-01BD56A5") + ("hashp" "N-00B947EC") + ("have" "N-00373D97") + ("hlet" "N-01348099") + ("hlet*" "N-01348099") + ("html-decode" "N-01263EAE") + ("html-encode" "N-01263EAE") + ("html-encode*" "N-01263EAE") + ("hupcl" "N-01B1B5DF") + ("iapply" "N-026C3723") + ("icanon" "N-0072FF5E") + ("icrnl" "N-02391683") + ("id-t" "N-01D716FE") + ("identity" "N-004834CC") + ("identity*" "N-004834CC") + ("ido." "N-00BE749A") + ("iexten" "N-0072FF5E") + ("if" "D-001D") + ("if-match" "N-00CFBF5E") + ("ifa" "N-018F39B0") + ("iff" "N-000E3A74") + ("iffi" "N-000E3A74") + ("iflet" "N-02DA21F6") + ("ignbrk" "N-02391683") + ("igncr" "N-02391683") + ("ignerr" "N-007287AC") + ("ignpar" "N-02391683") + ("ignwarn" "N-02552A58") + ("imaxbel" "N-02391683") + ("improper-plist-to-alist" "N-006E31B5") + ("in" "N-016BE41C") + ("in-package" "D-0073") + ("in-range" "N-02C56FB6") + ("in-range*" "N-02C56FB6") + ("in6addr-any" "N-026A2C3B") + ("in6addr-loopback" "N-026A2C3B") + ("in6addr-str" "N-02456270") + ("inaddr-any" "N-026A2C3B") + ("inaddr-loopback" "N-026A2C3B") + ("inaddr-str" "N-02456270") + ("inc" "N-03A0AABD") + ("inc-indent" "N-024E9FD8") + ("include" "N-01A2ECA0") + ("indent-code" "N-00512FDD") + ("indent-data" "N-00512FDD") + ("indent-foff" "N-00512FDD") + ("indent-off" "N-00512FDD") + ("inhash" "N-0161147E") + ("inlcr" "N-02391683") + ("ino-t" "N-01D716FE") + ("inpck" "N-02391683") + ("int" "N-018C7C8C") + ("int-buf" "N-00DCFA5F") + ("int-carray" "N-00797A01") + ("int-chr" "N-000AEC8B") + ("int-cptr" "N-01768FB9") + ("int-flo" "N-03F852CF") + ("int-ptr-t" "N-03258244") + ("int-str" "N-028043AE") + ("int16" "N-03D0AA7B") + ("int32" "N-03D0AA7B") + ("int64" "N-03D0AA7B") + ("int8" "N-0131FBF2") + ("integerp" "N-03E9D6E1") + ("intern" "N-02722B58") + ("intern-fb" "N-02722B58") + ("interp-fun-p" "N-00AC0CF7") + ("interpose" "N-0030734D") + ("inv-cum-norm" "N-0036EAFB") + ("invoke-catch" "N-0337FC1B") + ("ip" "N-00BE749A") + ("ipf" "N-012A7E6A") + ("iread" "N-03FE5500") + ("isatty" "N-03709E8A") + ("isec" "N-0385B074") + ("isig" "N-0072FF5E") + ("isqrt" "D-0039") + ("istrip" "N-02391683") + ("iter-begin" "D-002E") + ("iter-item" "D-0005") + ("iter-more" "D-003E") + ("iter-reset" "D-0020") + ("iter-step" "D-0071") + ("iterable" "N-01156AE3") + ("itimer-prof" "N-02B7882A") + ("itimer-real" "N-02B7882A") + ("itimer-virtual" "N-02B7882A") + ("iuclc" "N-02391683") + ("iutf8" "N-02391683") + ("ixany" "N-02391683") + ("ixoff" "N-02391683") + ("ixon" "N-02391683") + ("join" "N-00B6ACE3") + ("join-with" "N-00B6ACE3") + ("json" "N-0222106A") + ("juxt" "N-0106CD7F") + ("keep-if" "N-01413802") + ("keep-if*" "N-01413802") + ("keep-match-products" "N-01A846D2") + ("keep-matches" "N-01A846D2") + ("keepq" "N-00583609") + ("keepql" "N-00583609") + ("keepqual" "N-00583609") + ("key" "N-020D5C1D") + ("key-t" "N-01D716FE") + ("keyword-package" "N-0383342A") + ("keywordp" "N-01405F25") + ("kfs" "N-02D33A30") + ("kill" "N-0386CCD5") + ("krs" "N-02D33A4D") + ("labels" "N-0209307D") + ("lambda" "D-002C") + ("lambda-match" "N-031E43FF") + ("lambda-set" "N-02FEBA97") + ("last" "D-0043") + ("lazy-str" "N-02AFF63D") + ("lazy-str-force" "N-03269DEF") + ("lazy-str-force-upto" "N-0212FED6") + ("lazy-str-get-trailing-list" "N-012701D6") + ("lazy-stream-cons" "N-00B65D06") + ("lazy-stringp" "N-0381BB2A") + ("lchown" "N-003B491C") + ("lcm" "N-03D44645") + ("lcons" "N-013CC637") + ("lcons-car" "N-03598F4D") + ("lcons-cdr" "N-03598F4D") + ("lcons-fun" "N-02E1BA6F") + ("lconsp" "N-02E217A2") + ("ldiff" "N-02193773") + ("ldo" "N-03EF3A27") + ("left" "N-020D5C1D") + ("len" "N-03AD172A") + ("length" "D-0049") + ("length-buf" "N-0026D89A") + ("length-carray" "N-03FF97BD") + ("length-list" "N-01F8186A") + ("length-str" "N-03E6D841") + ("length-str-<" "N-016D8C45") + ("length-str-<=" "N-016D8C45") + ("length-str->" "N-016D8C45") + ("length-str->=" "N-016D8C45") + ("length-vec" "N-03D6D851") + ("lequal" "N-00A3E42D") + ("less" "N-01D6CEA1") + ("let" "N-013AF20B") + ("let*" "N-013AF20B") + ("lexical-fun-p" "N-007B1A53") + ("lexical-lisp1-binding" "N-02D124AB") + ("lexical-var-p" "N-007B1A53") + ("lib-version" "N-032F57D4") + ("line" "N-02D5D09D") + ("link" "N-009EF0C8") + ("list" "N-0206CE91") + ("list*" "N-03593DE9") + ("list-builder" "N-018F6666") + ("list-carray" "N-03EB1E3D") + ("list-seq" "N-02F0880D") + ("list-str" "N-0236023D") + ("list-vec" "N-00460235") + ("listp" "N-03F70343") + ("lnew" "N-0230059D") + ("lnew*" "N-021E6FDC") + ("load" "D-0081") + ("load-for" "N-0020A085") + ("load-time" "D-0048") + ("loff-t" "N-01D716FE") + ("log" "D-0047") + ("log-alert" "N-035D75EC") + ("log-auth" "N-0116F48F") + ("log-authpriv" "N-0116F48F") + ("log-cons" "N-02371913") + ("log-crit" "N-035D75EC") + ("log-daemon" "N-0116F48F") + ("log-debug" "N-035D75EC") + ("log-emerg" "N-035D75EC") + ("log-err" "N-035D75EC") + ("log-info" "N-035D75EC") + ("log-ndelay" "N-02371913") + ("log-notice" "N-035D75EC") + ("log-nowait" "N-02371913") + ("log-odelay" "N-02371913") + ("log-perror" "N-02371913") + ("log-pid" "N-02371913") + ("log-user" "N-0116F48F") + ("log-warning" "N-035D75EC") + ("log10" "D-0052") + ("log2" "D-0074") + ("logand" "D-000E") + ("logcount" "D-003B") + ("logior" "D-004C") + ("lognot" "D-0012") + ("lognot1" "N-019541E2") + ("logtest" "N-00B1548A") + ("logtrunc" "D-0075") + ("logxor" "N-02D5AF97") + ("long" "N-018C7C8C") + ("long-suffix" "N-00A3183A") + ("longlong" "N-02299408") + ("lop" "N-017F3A22") + ("lset" "N-008216EC") + ("lstat" "N-006DE1CC") + ("lutimes" "N-00E96FCF") + ("m$" "N-02F44ECE") + ("m^" "N-02F44ECE") + ("m^$" "N-02F44ECE") + ("mac-env-param-bind" "N-021A9008") + ("mac-param-bind" "N-021A9008") + ("macro-ancestor" "N-00519E96") + ("macro-form-p" "N-02AC86DE") + ("macro-time" "N-0264A0BD") + ("macroexpand" "N-02ED5471") + ("macroexpand-1" "N-02ED5471") + ("macroexpand-1-lisp1" "N-01E62179") + ("macroexpand-lisp1" "N-01E62179") + ("macrolet" "N-00AC12C0") + ("major" "N-02F0F482") + ("make-buf" "N-011445E1") + ("make-buf-stream" "N-03F5647C") + ("make-byte-input-stream" "N-03F54E14") + ("make-catenated-stream" "N-020BF082") + ("make-env" "N-01144687") + ("make-hash" "N-026D4158") + ("make-lazy-cons" "N-038B9EC2") + ("make-lazy-struct" "N-01C734D9") + ("make-like" "N-01C1D23C") + ("make-package" "N-02512A9A") + ("make-random-state" "N-032BEE6C") + ("make-similar-hash" "N-030E3A4A") + ("make-similar-tree" "N-030D1EF5") + ("make-string-byte-input-stream" "N-022937CD") + ("make-string-input-stream" "N-00F0B9B0") + ("make-string-output-stream" "N-0144BF51") + ("make-strlist-input-stream" "N-01737CF9") + ("make-strlist-output-stream" "N-00F363E0") + ("make-struct" "N-002B3F64") + ("make-struct-delegate-stream" "N-03FB1671") + ("make-struct-type" "N-022EEF2D") + ("make-sym" "N-0084463A") + ("make-time" "N-007C486E") + ("make-time-utc" "N-007C486E") + ("make-trie" "N-03C1B843") + ("make-union" "N-010A23C0") + ("make-zstruct" "N-03855D2D") + ("makedev" "N-02F0F482") + ("makunbound" "N-01FA4070") + ("mapcar" "N-0202F92F") + ("mapcar*" "N-0202F92F") + ("mapdo" "N-03A943EE") + ("mapf" "N-0026CEF1") + ("maphash" "N-03E6917D") + ("mappend" "N-0202F92F") + ("mappend*" "N-0202F92F") + ("maprend" "N-015987D7") + ("maprod" "N-015987D7") + ("maprodo" "N-015987D7") + ("mask" "N-0056CEF1") + ("match-case" "N-012DEAC3") + ("match-fun" "N-033F766A") + ("match-regex" "N-02E3A26F") + ("match-regex-right" "N-019430C5") + ("match-regst" "N-02E3A26F") + ("match-regst-right" "N-019430C5") + ("match-str" "N-03FF771E") + ("match-str-tree" "N-01859E7F") + ("max" "N-023C3643") + ("maybe" "N-039458F2") + ("mboundp" "N-01FBF828") + ("md5" "N-019F97A2") + ("md5-begin" "N-025F32FD") + ("md5-end" "N-025F32FD") + ("md5-hash" "N-025F32FD") + ("md5-stream" "N-006C94B6") + ("mdo" "N-028DBD1B") + ("member" "N-0176FBE7") + ("member-if" "N-0176FBE7") + ("memp" "N-03C6CE65") + ("memq" "N-0387CD82") + ("memql" "N-0387CD82") + ("memqual" "N-0387CD82") + ("meq" "N-020A0042") + ("meql" "N-020A0042") + ("mequal" "N-020A0042") + ("merge" "D-005B") + ("merge-delete-package" "N-0160EA2C") + ("meth" "N-02C216C3") + ("method" "N-022200C1") + ("mf" "N-036B6E55") + ("min" "N-023C3643") + ("minor" "N-02F0F482") + ("minusp" "D-0050") + ("mismatch" "N-03164F4F") + ("mkdir" "N-00C543B8") + ("mkdtemp" "N-026E4871") + ("mkfifo" "N-0091FD43") + ("mknod" "N-00F93A39") + ("mkstemp" "N-026E0471") + ("mkstring" "N-033DD796") + ("mlet" "N-008216E0") + ("mmakunbound" "N-02964FC0") + ("mod" "D-0040") + ("mode-t" "N-01D716FE") + ("multi" "N-034946BA") + ("multi-sort" "N-0132852F") + ("n-choose-k" "N-02ACFDE6") + ("n-perm-k" "N-02ACFDE6") + ("name" "N-01557906") + ("ncon" "N-022F6E60") + ("ncon*" "N-022F6E60") + ("nconc" "N-0014162F") + ("neg" "N-02C9F5F9") + ("neq" "N-0216A942") + ("neql" "N-0216A942") + ("nequal" "N-0216A942") + ("new" "N-0230059D") + ("new*" "N-021E6FDC") + ("nexpand-left" "N-00E168FE") + ("next" "D-006D") + ("next-file" "N-00839D2F") + ("nf" "N-0267AE6D") + ("nil" "N-015134D8") + ("nilf" "N-032070EB") + ("ninth" "N-01B0FA33") + ("nl0" "N-03BD477F") + ("nl1" "N-03BD477F") + ("nldly" "N-03BD477F") + ("nlink-t" "N-01D716FE") + ("noflsh" "N-0072FF5E") + ("none" "D-006C") + ("not" "D-006A") + ("notf" "N-0026CE18") + ("nr" "N-03A7AE6D") + ("nreconc" "N-012FF2DC") + ("nreverse" "N-03D8471B") + ("nshuffle" "N-01F12561") + ("nsort" "N-01FE5176") + ("nth" "N-0039F3FB") + ("nthcdr" "N-03D71D22") + ("nthlast" "N-02FC66FA") + ("null" "N-03C679D2") + ("nullify" "D-0008") + ("num-str" "N-028043AE") + ("numberp" "N-03E9D6E1") + ("nzerop" "N-0197FF9D") + ("o-accmode" "N-034BF6C9") + ("o-append" "N-034BF6C9") + ("o-async" "N-034BF6C9") + ("o-cloexec" "N-034BF6C9") + ("o-creat" "N-034BF6C9") + ("o-direct" "N-034BF6C9") + ("o-directory" "N-034BF6C9") + ("o-noatime" "N-034BF6C9") + ("o-noctty" "N-034BF6C9") + ("o-nofollow" "N-034BF6C9") + ("o-nonblock" "N-034BF6C9") + ("o-path" "N-034BF6C9") + ("o-rdonly" "N-034BF6C9") + ("o-rdwr" "N-034BF6C9") + ("o-sync" "N-034BF6C9") + ("o-trunc" "N-034BF6C9") + ("o-wronly" "N-034BF6C9") + ("oand" "N-01937C5A") + ("obtain" "N-01556613") + ("obtain*" "N-0102F0EB") + ("obtain*-block" "N-0102F0EB") + ("obtain-block" "N-01C791D0") + ("ocrnl" "N-03BD477F") + ("oddp" "D-003A") + ("ofdel" "N-03BD477F") + ("off-t" "N-01D716FE") + ("offsetof" "N-013D0A5C") + ("ofill" "N-03BD477F") + ("ofs" "N-02D33AA0") + ("olcuc" "N-03BD477F") + ("onlcr" "N-03BD477F") + ("onlret" "N-03BD477F") + ("onocr" "N-03BD477F") + ("op" "N-0068EA9D") + ("open-command" "N-02B03D38") + ("open-directory" "N-0221AE09") + ("open-file" "N-02B8FBBD") + ("open-fileno" "N-02BEAF24") + ("open-files" "N-018C5606") + ("open-files*" "N-018C5606") + ("open-process" "N-02B03D38") + ("open-socket" "N-026B766B") + ("open-socket-pair" "N-01A7ECBB") + ("open-tail" "N-0348F89A") + ("opendir" "N-024AA6F4") + ("openlog" "N-037AA654") + ("opip" "N-01937C5A") + ("opost" "N-03BD477F") + ("opt" "N-0047F5AB") + ("opt-desc" "N-03FC5092") + ("opthelp" "N-016C6171") + ("opts" "N-01D911E8") + ("or" "D-001A") + ("orec" "N-0003ED2C") + ("orf" "N-01E7D2AD") + ("ors" "N-02D33A3D") + ("output" "N-0159EBE7") + ("package-alist" "N-017F684C") + ("package-fallback-list" "N-027A535C") + ("package-foreign-symbols" "N-030C06F5") + ("package-local-symbols" "N-030C06F5") + ("package-name" "N-038581D9") + ("package-symbols" "N-03AF0206") + ("packagep" "N-007A478F") + ("pad" "N-0247F5FA") + ("parenb" "N-01B1B5DF") + ("parmrk" "N-02391683") + ("parodd" "N-01B1B5DF") + ("parse-errors" "N-00F843D4") + ("partition" "N-0142889E") + ("partition*" "N-03951D7A") + ("partition-by" "N-000167DF") + ("passwd" "N-036B0636") + ("path-blkdev-p" "N-00198FC7") + ("path-cat" "N-0033B27E") + ("path-chrdev-p" "N-00198FC7") + ("path-dir-empty" "N-01EFC15D") + ("path-dir-p" "N-00198FC7") + ("path-executable-to-me-p" "N-014A4B85") + ("path-exists-p" "N-03C41AE2") + ("path-file-p" "N-00198FC7") + ("path-mine-p" "N-020F44B5") + ("path-my-group-p" "N-020F44B5") + ("path-newer" "N-0155004F") + ("path-older" "N-0155004F") + ("path-pipe-p" "N-00198FC7") + ("path-private-to-me-p" "N-03B3F844") + ("path-read-writable-to-me-p" "N-028A5109") + ("path-readable-to-me-p" "N-02933008") + ("path-same-object" "N-0103E27B") + ("path-sep-chars" "N-03985DE5") + ("path-setgid-p" "N-02FBA677") + ("path-setuid-p" "N-02FBA677") + ("path-sock-p" "N-00198FC7") + ("path-sticky-p" "N-02FBA677") + ("path-strictly-private-to-me-p" "N-03B3F844") + ("path-symlink-p" "N-00198FC7") + ("path-writable-to-me-p" "N-02033190") + ("pdec" "N-00E4BC37") + ("pend" "N-03975507") + ("pend*" "N-03975507") + ("pendin" "N-0072FF5E") + ("perm" "N-0176D3A1") + ("pic" "N-02AF39D2") + ("pid-t" "N-01D716FE") + ("pinc" "N-00E4BC37") + ("pipe" "N-03F6D390") + ("placelet" "N-0393C970") + ("placelet*" "N-0393C970") + ("plist-to-alist" "N-006E31B5") + ("plusp" "D-0068") + ("poll" "N-0386D39D") + ("poly" "N-026201AD") + ("pop" "N-017F39D2") + ("portable-abs-path-p" "N-00477B23") + ("pos" "N-02C2BBDB") + ("pos-if" "N-02C2BBDB") + ("pos-max" "N-027D45DD") + ("pos-min" "N-027D45DD") + ("posq" "N-00A2B785") + ("posql" "N-00A2B785") + ("posqual" "N-00A2B785") + ("pppred" "N-038E636C") + ("ppred" "N-038E636C") + ("pprinl" "N-02FCCE0D") + ("pprint" "N-02FCCE0D") + ("pprof" "N-018C92AB") + ("pred" "N-038E636C") + ("prinl" "N-02FCCE0D") + ("print" "D-0046") + ("prn" "N-01E7F5F7") + ("prod" "N-0163FFE2") + ("prof" "N-004C9B10") + ("prog" "N-018A4BA9") + ("prog*" "N-018A4BA9") + ("prog1" "N-03F7A8B8") + ("prog2" "N-03A0E48C") + ("progn" "N-03F7A8B8") + ("promisep" "N-00C7553F") + ("prop" "N-01C6D406") + ("proper-list-p" "N-03F70343") + ("pset" "N-008211EC") + ("ptr" "N-027B04D0") + ("ptr-in" "N-00A494BF") + ("ptr-in-d" "N-01D7AC98") + ("ptr-out" "N-03D4DF7E") + ("ptr-out-d" "N-02036BEC") + ("ptr-out-s" "N-02D36BEC") + ("ptrdiff-t" "N-03258244") + ("pure-rel-path-p" "N-019DEA44") + ("purge-deferred-warning" "N-0077C4FE") + ("push" "N-01C211C1") + ("pushhash" "N-022660B2") + ("pushnew" "N-02C37AB0") + ("put-buf" "D-007F") + ("put-byte" "D-002F") + ("put-carray" "N-00737951") + ("put-char" "D-0003") + ("put-json" "N-009C27EF") + ("put-jsonl" "N-009C27EF") + ("put-jsons" "N-0124CAE6") + ("put-line" "N-012163C3") + ("put-lines" "N-0367B282") + ("put-obj" "N-025DB229") + ("put-string" "D-007B") + ("put-strings" "N-0367B282") + ("pwd" "N-0047F5F6") + ("qquote" "N-01665185") + ("qref" "D-006F") + ("quip" "N-03C6D422") + ("quote" "N-0163F998") + ("r$" "N-03BBB0C5") + ("r-atan2" "N-03BBA063") + ("r-ceil" "N-0399208F") + ("r-expt" "N-00192012") + ("r-floor" "N-00BBC669") + ("r-lognot" "N-00495055") + ("r-logtrunc" "N-02439AC4") + ("r-mod" "N-02F8C918") + ("r-round" "N-031D7670") + ("r-trunc" "N-02CD7330") + ("r^" "N-03BBB0C5") + ("r^$" "N-03BBB0C5") + ("raise" "N-0108FFCE") + ("rand" "N-03A57C86") + ("random" "N-03A57C86") + ("random-fixnum" "N-03A57C86") + ("random-float" "N-01572D27") + ("random-state-get-vec" "N-005C0F98") + ("random-state-p" "N-00C9A749") + ("range" "N-033BE5A1") + ("range*" "N-033BE5A1") + ("range-regex" "N-0250D465") + ("rangep" "N-00DDB00B") + ("rassoc" "N-03B49598") + ("rassq" "N-03B49598") + ("rassql" "N-03B49598") + ("rcomb" "N-02D9003C") + ("rcons" "N-02E9003D") + ("read" "N-03FE5500") + ("read-until-match" "N-001D3F81") + ("readdir" "N-0289D074") + ("readlink" "N-0338B219") + ("real-time-stream-p" "N-0121FDEB") + ("realpath" "N-0168BEB4") + ("rebind" "N-019F9FB7") + ("rec" "N-0003ED2C") + ("recip" "N-01B8BAB0") + ("record-adapter" "N-009C0AC4") + ("reduce-left" "N-00FB426F") + ("reduce-right" "N-00FB426F") + ("ref" "N-01A419FB") + ("refset" "N-01A419FB") + ("regex-compile" "N-0168C611") + ("regex-from-trie" "N-00E48912") + ("regex-parse" "N-01C9C361") + ("regex-prefix-match" "N-02CE60DF") + ("regex-source" "N-0218BD2B") + ("regexp" "N-03DDC533") + ("register-exception-subtypes" "N-005EB97F") + ("register-tentative-def" "N-033CBAA9") + ("regsub" "N-03BDC5F6") + ("rehome-sym" "N-03627360") + ("reject" "N-031DC0F2") + ("rel-path" "N-016892B4") + ("relate" "N-032DBF7E") + ("release-deferred-warnings" "N-012F0BE9") + ("remhash" "N-0029C57A") + ("remove-if" "N-01413802") + ("remove-if*" "N-01413802") + ("remove-path" "N-014AF3F7") + ("remove-path-rec" "N-03E81B3A") + ("remq" "N-000ECD82") + ("remq*" "N-00B85CD2") + ("remql" "N-000ECD82") + ("remql*" "N-00B85CD2") + ("remqual" "N-000ECD82") + ("remqual*" "N-00B85CD2") + ("rename-path" "N-016EF40C") + ("rep" "D-004F") + ("repeat" "D-006B") + ("replace" "N-035991E1") + ("replace-buf" "N-01C59E4E") + ("replace-list" "N-03E43DA2") + ("replace-str" "N-02059F0A") + ("replace-struct" "N-01A8343B") + ("replace-tree-iter" "N-01225FF3") + ("replace-vec" "N-01F59E62") + ("require" "D-007E") + ("reset-struct" "N-002A609F") + ("rest" "N-02288559") + ("ret" "N-033F39EF") + ("retf" "N-0026CB20") + ("return" "N-03E500DF") + ("return*" "N-0309887F") + ("return-from" "N-03E500DF") + ("revappend" "N-012FF2DC") + ("reverse" "N-03D8471B") + ("rfind" "N-0301CDB6") + ("rfind-if" "N-0301CDB6") + ("right" "N-020D5C1D") + ("rlcp" "N-024EB211") + ("rlcp-tree" "N-024EB211") + ("rlet" "N-008212A0") + ("rlist" "N-02FD60D0") + ("rlist*" "N-02FD60D0") + ("rmdir" "N-03D90503") + ("rmember" "N-0188A56C") + ("rmember-if" "N-0188A56C") + ("rmemq" "N-0188A56C") + ("rmemql" "N-0188A56C") + ("rmemqual" "N-0188A56C") + ("rmismatch" "N-008F3C16") + ("rng" "N-00BEA6DF") + ("rng+" "N-00BEA6DF") + ("rng-" "N-00BEA6DF") + ("rotate" "N-0166291D") + ("round" "D-0002") + ("round-rem" "N-02DE978F") + ("round1" "N-03EA1351") + ("rperm" "N-0188EBDE") + ("rplaca" "D-004E") + ("rplacd" "D-0009") + ("rpoly" "N-026201AD") + ("rpos" "N-01F68300") + ("rpos-if" "N-01F68300") + ("rposq" "N-01F68300") + ("rposql" "N-01F68300") + ("rposqual" "N-01F68300") + ("rr" "N-03BBB0C5") + ("rra" "N-0177F5FF") + ("rs" "N-0397AE68") + ("rsearch" "N-03405F7D") + ("rtld-deepbind" "N-0083A22A") + ("rtld-global" "N-0083A22A") + ("rtld-lazy" "N-0083A22A") + ("rtld-local" "N-0083A22A") + ("rtld-nodelete" "N-0083A22A") + ("rtld-noload" "N-0083A22A") + ("rtld-now" "N-0083A22A") + ("run" "N-0158244A") + ("s-ifblk" "N-03F32D57") + ("s-iflnk" "N-03F32D57") + ("s-ifmt" "N-03F32D57") + ("s-ifreg" "N-03F32D57") + ("s-ixoth" "N-03F32D57") + ("save-exe" "N-02850687") + ("sbit" "N-011F2878") + ("scan" "N-03E989D0") + ("scan-until-match" "N-00EFD668") + ("search" "N-015D8676") + ("search-regex" "N-0250D465") + ("search-regst" "N-0250D465") + ("search-str" "N-0257180F") + ("search-str-tree" "N-02783DAA") + ("second" "N-01B0FA33") + ("seek" "N-0136D6A2") + ("seek-cur" "N-01D6E4D8") + ("seek-end" "N-01D6E4D8") + ("seek-set" "N-01D6E4D8") + ("seek-stream" "N-031B5075") + ("select" "N-031D7F72") + ("self-path" "N-03561A65") + ("seq-begin" "N-0068A845") + ("seq-next" "N-02E3D643") + ("seq-reset" "N-01CA6912") + ("seqp" "N-03C6CAE0") + ("set" "D-0015") + ("set-cflags" "N-02061924") + ("set-hash-userdata" "N-030B40A7") + ("set-iflags" "N-02061924") + ("set-indent" "N-024E9FD8") + ("set-indent-mode" "N-03F3170C") + ("set-key" "N-033F7D05") + ("set-left" "N-033F7D05") + ("set-lflags" "N-02061924") + ("set-max-depth" "N-027D3FB4") + ("set-max-length" "N-031FA9E5") + ("set-oflags" "N-02061924") + ("set-package-fallback-list" "N-027A535C") + ("set-prop" "N-03663AE4") + ("set-right" "N-033F7D05") + ("set-sig-handler" "N-02E1B6FA") + ("set-stack-limit" "N-02492D13") + ("setegid" "N-03897D65") + ("setenv" "N-002E0364") + ("seteuid" "N-03897D65") + ("setgid" "N-03897D65") + ("setgrent" "N-02CAC7FB") + ("setgroups" "N-030FEE97") + ("sethash" "N-0025A17A") + ("setitimer" "N-02DE107D") + ("setlogmask" "N-0085DB47") + ("setpwent" "N-0377C43A") + ("setresgid" "N-027671E8") + ("setresuid" "N-027671E8") + ("setuid" "N-03897D65") + ("seventh" "N-01B0FA33") + ("sh" "N-0158244A") + ("sha256" "N-019F97A2") + ("sha256-begin" "N-03B36E53") + ("sha256-end" "N-03B36E53") + ("sha256-hash" "N-03B36E53") + ("sha256-stream" "N-006C94B6") + ("shift" "N-01AC8471") + ("short" "N-018C7C8C") + ("short-suffix" "N-00A3183A") + ("shuffle" "N-01F12561") + ("shut-rd" "N-028953A4") + ("shut-rdwr" "N-028953A4") + ("shut-wr" "N-028953A4") + ("sig-abrt" "N-0176430F") + ("sig-alrm" "N-0176430F") + ("sig-atomic-t" "N-03258244") + ("sig-bus" "N-0176430F") + ("sig-check" "N-0360A99A") + ("sig-chld" "N-0176430F") + ("sig-cont" "N-0176430F") + ("sig-fpe" "N-0176430F") + ("sig-hup" "N-0176430F") + ("sig-ill" "N-0176430F") + ("sig-int" "N-0176430F") + ("sig-io" "N-0176430F") + ("sig-iot" "N-0176430F") + ("sig-kill" "N-0176430F") + ("sig-lost" "N-0176430F") + ("sig-pipe" "N-0176430F") + ("sig-poll" "N-0176430F") + ("sig-prof" "N-0176430F") + ("sig-pwr" "N-0176430F") + ("sig-quit" "N-0176430F") + ("sig-segv" "N-0176430F") + ("sig-stkflt" "N-0176430F") + ("sig-stop" "N-0176430F") + ("sig-sys" "N-0176430F") + ("sig-term" "N-0176430F") + ("sig-trap" "N-0176430F") + ("sig-tstp" "N-0176430F") + ("sig-ttin" "N-0176430F") + ("sig-ttou" "N-0176430F") + ("sig-urg" "N-0176430F") + ("sig-usr1" "N-0176430F") + ("sig-usr2" "N-0176430F") + ("sig-vtalrm" "N-0176430F") + ("sig-winch" "N-0176430F") + ("sig-xcpu" "N-0176430F") + ("sig-xfsz" "N-0176430F") + ("sign-extend" "D-0031") + ("signum" "D-000F") + ("sin" "D-000B") + ("sinh" "D-0067") + ("sixth" "N-01B0FA33") + ("size-t" "N-03258244") + ("size-vec" "N-01000634") + ("sizeof" "N-0235DCAE") + ("skip" "N-021FCB7C") + ("slet" "N-00821260") + ("slot" "N-0326F62D") + ("slotp" "N-00B90177") + ("slots" "N-00E90177") + ("slotset" "N-02657437") + ("sme" "N-008C6621") + ("sock-accept" "N-00AF0FE8") + ("sock-bind" "N-02B052CF") + ("sock-connect" "N-00E5DFD4") + ("sock-dgram" "N-01D17D22") + ("sock-family" "N-0323EB36") + ("sock-listen" "N-02F624A8") + ("sock-peer" "N-015ABEC7") + ("sock-recv-timeout" "N-03DF15F2") + ("sock-send-timeout" "N-03DF15F2") + ("sock-set-peer" "N-01FE18ED") + ("sock-shutdown" "N-0222BA70") + ("sock-stream" "N-01D17D22") + ("sock-type" "N-0323EB36") + ("sockaddr" "N-02C48759") + ("sockaddr-in" "N-01DD05D9") + ("sockaddr-in6" "N-013DD169") + ("sockaddr-un" "N-01DD05D2") + ("some" "D-0041") + ("sort" "N-01FE5176") + ("sort-group" "N-01E65DDC") + ("source-loc" "N-0370CD69") + ("source-loc-str" "N-0370CD69") + ("span-str" "N-0394CA3A") + ("special-operator-p" "N-01E259AD") + ("special-var-p" "N-00833473") + ("spl" "N-03C7F5FA") + ("splice" "N-03BC798C") + ("split" "N-02FD4882") + ("split*" "N-02FD4882") + ("split-str" "N-000386B4") + ("split-str-set" "N-0296195B") + ("sqrt" "D-0027") + ("square" "D-0032") + ("ssize-t" "N-01D716FE") + ("sspl" "N-0296195B") + ("sssucc" "N-038E636C") + ("ssucc" "N-038E636C") + ("starts-with" "N-004955D4") + ("stat" "D-005C") + ("static-slot" "N-02C47D17") + ("static-slot-ensure" "N-02E71F31") + ("static-slot-home" "N-01F88B0D") + ("static-slot-p" "N-032FD510") + ("static-slot-set" "N-0017D1B5") + ("stdlib" "N-008E4BC2") + ("str" "N-00C6B7C4") + ("str-buf" "N-012BF6AD") + ("str-d" "N-00C6B7C4") + ("str-in6addr" "N-01FF658D") + ("str-in6addr-net" "N-00918411") + ("str-inaddr" "N-01FF658D") + ("str-inaddr-net" "N-00918411") + ("str-seq" "N-02F0880D") + ("str<" "N-01AA954A") + ("str<=" "N-01AA954A") + ("str=" "N-01AA954A") + ("str>" "N-01AA954A") + ("str>=" "N-01AA954A") + ("stream-get-prop" "N-005268C8") + ("stream-set-prop" "N-005268C8") + ("stream-wrap" "N-00FE2393") + ("streamp" "N-02BB4421") + ("strerror" "N-02A1DB65") + ("string-decode" "N-033502F8") + ("string-encode" "N-033502F8") + ("string-extend" "N-03D5358A") + ("string-lt" "N-03ABBED1") + ("stringp" "N-00BB392B") + ("strsignal" "N-00234BED") + ("struct" "D-001B") + ("struct-from-args" "N-01515451") + ("struct-from-plist" "N-01515451") + ("struct-get-initfun" "N-03946F2A") + ("struct-get-postinitfun" "N-03946F2A") + ("struct-set-initfun" "N-00946F18") + ("struct-set-postinitfun" "N-00946F18") + ("struct-type" "N-02C33D76") + ("struct-type-name" "N-00088BD7") + ("struct-type-p" "N-00717410") + ("structp" "N-01BB3FB3") + ("sub" "N-01D9F42F") + ("sub-buf" "N-000FFE37") + ("sub-list" "N-038E3E1D") + ("sub-str" "N-03CFFEF2") + ("sub-tree" "N-0398FBE2") + ("sub-vec" "N-03BFFF0A") + ("subtypep" "N-00699D3B") + ("succ" "N-038E636C") + ("sum" "N-0163FFE2") + ("super" "N-03D8EEEE") + ("super-method" "N-02AC8367") + ("suspend" "N-02E7852D") + ("swap" "N-0042131D") + ("symacrolet" "N-00321AB1") + ("symbol-function" "N-00004DDC") + ("symbol-macro" "N-00004DDC") + ("symbol-name" "N-035D3BBF") + ("symbol-package" "N-02AB2428") + ("symbol-value" "N-00004DDC") + ("symbolp" "N-01C0BF69") + ("symdiff" "N-0385B074") + ("symlink" "N-009EF0C8") + ("sys:abscond*" "N-02DF20E5") + ("sys:abscond-from" "N-02E20FE2") + ("sys:capture-cont" "N-02199305") + ("sys:gc" "N-01C75157") + ("sys:gc-set-delta" "N-02C0C748") + ("syslog" "N-02075291") + ("system-package" "N-0383342A") + ("t" "N-015134D8") + ("tab0" "N-03BD477F") + ("tab1" "N-03BD477F") + ("tab2" "N-03BD477F") + ("tab3" "N-03BD477F") + ("tabdly" "N-03BD477F") + ("tagbody" "N-007E0D96") + ("tailp" "N-00B8D7B5") + ("take" "N-00F6D433") + ("take-until" "N-01E42C4C") + ("take-while" "N-01E42C4C") + ("tan" "D-003C") + ("tanh" "D-0062") + ("tb" "N-02AB6E53") + ("tc" "N-029B6E53") + ("tcdrain" "N-01AC4760") + ("tcflow" "N-03081D51") + ("tcflush" "N-034C4A4D") + ("tcgetattr" "N-013D13CA") + ("tciflush" "N-0279ED46") + ("tcioff" "N-02173FF9") + ("tcioflush" "N-0279ED46") + ("tcion" "N-02173FF9") + ("tcoflush" "N-0279ED46") + ("tcooff" "N-02173FF9") + ("tcoon" "N-02173FF9") + ("tcsadrain" "N-02C6ECF5") + ("tcsaflush" "N-02C6ECF5") + ("tcsanow" "N-02C6ECF5") + ("tcsendbreak" "N-033C365C") + ("tcsetattr" "N-013D13CA") + ("tentative-def-exists" "N-0186D1B7") + ("tenth" "N-01B0FA33") + ("termios" "N-039CD619") + ("test-clear" "N-036C7E9E") + ("test-clear-dirty" "N-03AB857D") + ("test-dec" "N-01A4228F") + ("test-dirty" "N-03AB857D") + ("test-inc" "N-01A4228F") + ("test-neq-set-indent-mode" "N-01A1F89C") + ("test-set" "N-036C7E9E") + ("test-set-indent-mode" "N-01A1F89C") + ("tf" "N-032070EB") + ("third" "N-01B0FA33") + ("throw" "D-0053") + ("throwf" "N-015466AD") + ("time" "D-0034") + ("time-fields-local" "N-00789418") + ("time-fields-utc" "N-00789418") + ("time-local" "N-001284ED") + ("time-nsec" "N-03B6DB3D") + ("time-parse" "D-0065") + ("time-parse-local" "N-00207C99") + ("time-parse-utc" "N-00207C99") + ("time-string" "N-007B1819") + ("time-string-local" "N-00F192AD") + ("time-string-utc" "N-00F192AD") + ("time-struct-local" "N-00B758FD") + ("time-struct-utc" "N-00B758FD") + ("time-t" "N-03258244") + ("time-usec" "N-03B6DB3D") + ("time-utc" "N-001284ED") + ("tmpfile" "N-00FF7C41") + ("tnode" "N-0008DDFB") + ("tnodep" "N-00D8534F") + ("to" "N-00AED1A7") + ("tofloat" "N-01DBC9D7") + ("tofloatz" "N-03E2D4B8") + ("toint" "N-01DBC9D7") + ("tointz" "N-03E2D4B8") + ("tojson" "N-017848BD") + ("tok" "N-0117F60C") + ("tok-str" "N-0225F28F") + ("tok-where" "N-0225F28F") + ("tostop" "N-0072FF5E") + ("tostring" "N-02FCCE0D") + ("tostringp" "N-02FCCE0D") + ("touch" "N-0038DD42") + ("tprint" "N-0217DE45") + ("trace" "N-02833733") + ("trailer" "D-0057") + ("transpose" "N-03AA85AD") + ("tree" "N-02F6D50B") + ("tree-begin" "N-02887FCA") + ("tree-bind" "N-021A9008") + ("tree-case" "N-03D834A5") + ("tree-clear" "N-03C88274") + ("tree-delete" "N-022035DF") + ("tree-delete-node" "N-00772FAE") + ("tree-find" "N-0149BC05") + ("tree-insert" "N-0114FF9E") + ("tree-insert-node" "N-008B4AD9") + ("tree-lookup" "N-01D63E47") + ("tree-lookup-node" "N-03FE4877") + ("tree-next" "N-02443382") + ("tree-peek" "N-02443382") + ("tree-reset" "N-002A407C") + ("tree-root" "N-0149BF2D") + ("treep" "N-03B8E442") + ("trie-add" "N-0006C677") + ("trie-compress" "N-00026B83") + ("trie-lookup-begin" "N-02D16290") + ("trie-lookup-feed-char" "N-014E6D7B") + ("trie-value-at" "N-012A1BAD") + ("trim-left" "N-00CF29CC") + ("trim-right" "N-00CF29CC") + ("trim-str" "N-00E6E63B") + ("true" "N-00373D97") + ("trunc" "D-005D") + ("trunc-rem" "N-02DE978F") + ("trunc1" "N-02E91F51") + ("truncate" "N-0032FBF3") + ("truncate-stream" "N-009F5B3F") + ("try" "N-0328371B") + ("tuples" "N-00C801EF") + ("txr-case" "N-03813122") + ("txr-exe-path" "N-014C116E") + ("txr-if" "N-00355D4E") + ("txr-parse" "N-02AC7FB4") + ("txr-version" "N-032F57D4") + ("txr-when" "N-02311DCA") + ("typecase" "N-0384D122") + ("typedef" "N-01BE95E8") + ("typeof" "N-01F81275") + ("typep" "N-03B8D9EE") + ("ubit" "N-011F2878") + ("uchar" "N-0008D7DC") + ("uid-t" "N-01D716FE") + ("uint" "N-018C7C8C") + ("uint-buf" "N-00DCFA5F") + ("uint-carray" "N-00797A01") + ("uint-ptr-t" "N-03258244") + ("uint16" "N-03D0AA7B") + ("uint32" "N-03D0AA7B") + ("uint64" "N-03D0AA7B") + ("uint8" "N-0131FBF2") + ("ulong" "N-018C7C8C") + ("ulonglong" "N-02299408") + ("umask" "N-0068D92E") + ("umeth" "N-02ECA31C") + ("umethod" "N-000BCBC5") + ("uname" "N-0308D954") + ("unget-byte" "D-0007") + ("unget-char" "D-0056") + ("uni" "N-0385B074") + ("unintern" "N-01B6BFC2") + ("union" "N-01C78B86") + ("union-get" "N-02FA4F0C") + ("union-in" "N-02258991") + ("union-members" "N-008912E4") + ("union-out" "N-02258991") + ("union-put" "N-02FA4EBC") + ("uniq" "N-03B6D456") + ("unique" "N-0028147F") + ("unless" "N-017EFAB6") + ("unquote" "N-036B313D") + ("unsetenv" "N-002E0364") + ("until" "D-0025") + ("until*" "N-01F7BF0B") + ("untrace" "N-02833733") + ("unuse-package" "N-024BF63F") + ("unuse-sym" "N-01AF42B7") + ("unwind-protect" "N-03162B0C") + ("upcase-str" "N-029EEA82") + ("upd" "N-033F39DC") + ("update" "N-0327B17E") + ("uref" "N-03A211AB") + ("url-decode" "N-0388DB26") + ("url-encode" "N-0388DB26") + ("use" "N-004834CC") + ("use-package" "N-024BF63F") + ("use-sym" "N-01747674") + ("user-package" "N-0383342A") + ("ushort" "N-018C7C8C") + ("usl" "N-00BF39DD") + ("usleep" "N-00D79773") + ("uslot" "N-01F8E0A1") + ("utimes" "N-00E96FCF") + ("utsname" "N-003D12F6") + ("val" "N-00DB04DD") + ("vdiscard" "N-01812D70") + ("vec" "N-0297F5F5") + ("vec-carray" "N-03EB1E3D") + ("vec-list" "N-03295612") + ("vec-push" "N-01693B82") + ("vec-seq" "N-02F0880D") + ("vec-set-length" "N-01723847") + ("vecref" "N-001963BF") + ("vector" "N-02B6C6F1") + ("vectorp" "N-03B9C3E5") + ("veof" "N-01812D70") + ("veol" "N-01812D70") + ("veol2" "N-01812D70") + ("verase" "N-01812D70") + ("vintr" "N-01812D70") + ("vkill" "N-01812D70") + ("vlnext" "N-01812D70") + ("vm-fun-p" "N-00B99FC5") + ("vmin" "N-01812D70") + ("void" "N-013DE1A3") + ("vquit" "N-01812D70") + ("vreprint" "N-01812D70") + ("vstart" "N-01812D70") + ("vstop" "N-01812D70") + ("vsusp" "N-01812D70") + ("vswtc" "N-01812D70") + ("vt0" "N-03BD477F") + ("vt1" "N-03BD477F") + ("vtdly" "N-03BD477F") + ("vtime" "N-01812D70") + ("vwerase" "N-01812D70") + ("w-coredump" "N-0243C575") + ("w-exitstatus" "N-0243C575") + ("w-ifexited" "N-0243C575") + ("w-ifsignaled" "N-0243C575") + ("w-ifstopped" "N-0243C575") + ("w-stopsig" "N-0243C575") + ("w-termsig" "N-0243C575") + ("wait" "N-0365C3E1") + ("weave" "N-0208F32F") + ("when" "N-017EFAB6") + ("when-match" "N-00CFBF5E") + ("whena" "N-005C93DF") + ("whenlet" "N-02DA21F6") + ("where" "N-0208F1DE") + ("while" "N-01026F48") + ("while*" "N-01F7BF0B") + ("while-match" "N-015B0AD0") + ("while-match-case" "N-007220BC") + ("while-true-match-case" "N-007220BC") + ("whilet" "N-0154DC75") + ("width" "D-0019") + ("width-check" "N-01A9EA49") + ("window-map" "N-015AFD48") + ("window-mapdo" "N-015AFD48") + ("window-mappend" "N-015AFD48") + ("wint-t" "N-03258244") + ("with" "N-03098987") + ("with-clobber-expander" "N-0181ED4C") + ("with-compilation-unit" "N-013AAB51") + ("with-delete-expander" "N-02A6E020") + ("with-dyn-lib" "N-023E0D2C") + ("with-gensyms" "N-034F045B") + ("with-hash-iter" "N-001B79C0") + ("with-in-buf-stream" "N-01150550") + ("with-in-string-byte-stream" "N-00FD832E") + ("with-in-string-stream" "N-004ED7A0") + ("with-objects" "N-00AECEBA") + ("with-out-buf-stream" "N-01150550") + ("with-out-string-stream" "N-0001C63C") + ("with-out-strlist-stream" "N-024F86B3") + ("with-resources" "N-012CE06E") + ("with-slots" "N-00C411A2") + ("with-stream" "N-013E33A2") + ("with-update-expander" "N-006EA023") + ("wrap" "N-026DDCEC") + ("wrap*" "N-026DDCEC") + ("wstr" "N-032DB6DC") + ("wstr-d" "N-032DB6DC") + ("xcase" "N-0072FF5E") + ("yield" "N-02AE5C1E") + ("yield-from" "N-01556613") + ("zap" "N-037F3A8C") + ("zarray" "N-017039ED") + ("zchar" "N-0008D7DC") + ("zero-fill" "N-016D3BB5") + ("zerop" "D-003F") + ("zip" "N-03AA85AD") + ("znew" "N-00B1FC38")))) diff --git a/stdlib/doloop.tl b/stdlib/doloop.tl new file mode 100644 index 00000000..56540d9e --- /dev/null +++ b/stdlib/doloop.tl @@ -0,0 +1,54 @@ +;; Copyright 2017-2021 +;; Kaz Kylheku <kaz@kylheku.com> +;; Vancouver, Canada +;; 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 HOLDER 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. + +(defun sys:expand-doloop (f vars cexp body) + (let ((xvars (mapcar (tc + (((:whole w v i s . r)) + (if r (compile-error f "excess elements in ~s" w) w)) + (((:whole w v i . r)) + (if r + (compile-error f "bad variable clause syntax ~s" w) + ^(,v ,i ,i))) + (((:whole w v . r)) + (if r + (compile-error f "bad variable clause syntax ~s" w) + ^(,v nil ,v))) + ((v) ^(,v nil ,v))) + vars)) + (pllel (eq (car f) 'doloop))) + ^(,(if pllel 'for 'for*) + ,(mapcar (aret ^(,@1 ,@2)) xvars) + ,cexp + ((,(if pllel 'pset 'set) ,*(mappend (ado unless (eq @1 @3) + ^(,@1 ,@3)) + xvars))) + (tagbody ,*body)))) + +(defmacro doloop (:form f vars cexp . body) + (sys:expand-doloop f vars cexp body)) + +(defmacro doloop* (:form f vars cexp . body) + (sys:expand-doloop f vars cexp body)) diff --git a/stdlib/each-prod.tl b/stdlib/each-prod.tl new file mode 100644 index 00000000..7b7150c0 --- /dev/null +++ b/stdlib/each-prod.tl @@ -0,0 +1,75 @@ +;; Copyright 2020-2021 +;; Kaz Kylheku <kaz@kylheku.com> +;; Vancouver, Canada +;; 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 HOLDER 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. + +(defun sys:vars-check (form vars) + (unless (listp vars) + (compile-error form "~s is expected to be variable binding syntax" vars)) + (whenlet ((bad (find-if [notf consp] vars))) + (compile-error form "~s isn't a var-initform pair" bad))) + +(defun sys:bindable-check (form syms) + (whenlet ((bad (find-if [notf bindable] syms))) + (compile-error form "~s isn't a bindable symbol" bad))) + +(defun sys:expand-each-prod (form vars body) + (sys:vars-check form vars) + (let ((syms [mapcar car vars]) + (inits [mapcar cadr vars])) + (sys:bindable-check form syms) + (let ((fun (caseq (car form) + (each-prod 'maprodo) + (collect-each-prod 'maprod) + (append-each-prod 'maprend)))) + ^(,fun (lambda (,*syms) ,*body) ,*inits)))) + +(defun sys:expand-each-prod* (form vars body) + (sys:vars-check form vars) + (let* ((each-prod-op (caseq (car form) + (each-prod* 'each-prod) + (collect-each-prod* 'collect-each-prod) + (append-each-prod* 'append-each-prod))) + (syms [mapcar car vars]) + (inits [mapcar cadr vars])) + ^(let* ,vars + (,each-prod-op ,(zip syms syms) ,*body)))) + +(defmacro each-prod (:form f vars . body) + (sys:expand-each-prod f vars body)) + +(defmacro collect-each-prod (:form f vars . body) + (sys:expand-each-prod f vars body)) + +(defmacro append-each-prod (:form f vars . body) + (sys:expand-each-prod f vars body)) + +(defmacro each-prod* (:form f vars . body) + (sys:expand-each-prod* f vars body)) + +(defmacro collect-each-prod* (:form f vars . body) + (sys:expand-each-prod* f vars body)) + +(defmacro append-each-prod* (:form f vars . body) + (sys:expand-each-prod* f vars body)) diff --git a/stdlib/error.tl b/stdlib/error.tl new file mode 100644 index 00000000..7f70391e --- /dev/null +++ b/stdlib/error.tl @@ -0,0 +1,95 @@ +;; Copyright 2017-2021 +;; Kaz Kylheku <kaz@kylheku.com> +;; Vancouver, Canada +;; 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 HOLDER 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. + +(defun sys:dig (ctx) + (whilet ((form (sys:ctx-form ctx)) + (anc (unless (source-loc form) + (macro-ancestor form)))) + (set ctx anc)) + ctx) + +(defun sys:loc (ctx) + (source-loc-str (sys:ctx-form ctx))) + +(defun compile-error (ctx fmt . args) + (let* ((nctx (sys:dig ctx)) + (loc (sys:loc nctx)) + (name (sys:ctx-name nctx))) + (let ((msg (fmt `@loc: ~s: @fmt` name . args))) + (when (and *load-recursive* + (null (find-frame 'error 'catch-frame))) + (dump-deferred-warnings *stderr*) + (put-line msg *stderr*)) + (throw 'eval-error msg)))) + +(defun compile-warning (ctx fmt . args) + (let* ((nctx (sys:dig ctx)) + (loc (sys:loc nctx)) + (name (sys:ctx-name nctx))) + (usr:catch + (throwf 'warning `@loc: warning: ~s: @fmt` name . args) + (continue ())))) + +(defun compile-defr-warning (ctx tag fmt . args) + (let* ((nctx (sys:dig ctx)) + (loc (sys:loc nctx)) + (name (sys:ctx-name nctx))) + (usr:catch + (throw 'defr-warning (fmt `@loc: warning: ~s: @fmt` name . args) tag) + (continue ())))) + +(defun sys:bind-mac-error (ctx-form params obj too-few-p) + (cond + ((atom obj) + (compile-error ctx-form "extra element ~s not matched by params ~a" + obj params)) + ((null obj) + (compile-error ctx-form "params ~a require arguments" params)) + (t (compile-error ctx-form "too ~a elements in ~s for params ~a" + (if too-few-p "few" "many") + obj params)))) + +(defun sys:bind-mac-check (ctx-form params obj req fix) + (if (and obj (atom obj)) + (compile-error ctx-form "extra element ~s not matched by params ~a" + obj params) + (let ((l (len obj))) + (iflet ((problem (cond + ((< l req) "few") + ((and fix (> l fix)) "many")))) + (if (zerop l) + (compile-error ctx-form "params ~a require arguments" params) + (compile-error ctx-form "too ~a elements in ~s for params ~a" + problem obj params)))))) + +(defun lambda-too-many-args (form) + (compile-error form "excess arguments given")) + +(defun lambda-too-few-args (form) + (compile-error form "inufficient arguments given")) + +(defun lambda-short-apply-list () + (throwf 'eval-error "~s: applied argument list too short" 'lambda)) diff --git a/stdlib/except.tl b/stdlib/except.tl new file mode 100644 index 00000000..60f2fe51 --- /dev/null +++ b/stdlib/except.tl @@ -0,0 +1,88 @@ +;; Copyright 2015-2021 +;; Kaz Kylheku <kaz@kylheku.com> +;; Vancouver, Canada +;; 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 HOLDER 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. + +(defun sys:handle-bad-syntax (item) + (throwf 'eval-error "~s: bad clause syntax: ~s" 'handle item)) + +(defmacro usr:catch (:form form :env e try-form . catch-clauses) + (let ((catch-syms [mapcar car catch-clauses]) + (sys-catch-clauses (mapcar (do mac-param-bind @1 (type args . body) @1 + (tree-bind (args-ex . body-ex) + (sys:expand-params args body + e nil form) + ^(,type (,(gensym) ,*args-ex) ,*body-ex))) + catch-clauses))) + ^(sys:catch ,catch-syms ,try-form nil ,*sys-catch-clauses))) + +(defmacro catch* (try-form . catch-clauses) + (let ((catch-syms [mapcar car catch-clauses])) + ^(sys:catch ,catch-syms ,try-form nil ,*catch-clauses))) + +(defmacro catch** (:env menv try-form . catch-clauses) + (let ((catch-syms [mapcar car catch-clauses]) + sys-catch-clauses descs) + (each ((cl catch-clauses)) + (mac-param-bind cl (type desc args . body) cl + (push ^(,type ,args ,*body) sys-catch-clauses) + (push desc descs))) + (sys:setq sys-catch-clauses (nreverse sys-catch-clauses)) + (sys:setq descs (nreverse descs)) + (let ((desc-expr (if [all descs (op constantp @1 menv)] + ^'(,*[mapcar eval descs]) + ^(list ,*descs)))) + ^(sys:catch ,catch-syms ,try-form ,desc-expr ,*sys-catch-clauses)))) + +(defun sys:expand-handle (form try-form handle-clauses) + (let* ((oper (car form)) + (exc-sym (gensym)) + (exc-args (gensym)) + (syms-fragments (collect-each ((hc handle-clauses)) + (tree-case hc + ((name arglist . body) + (unless (symbolp name) + (sys:handle-bad-syntax hc)) + (list name ^(apply (lambda ,arglist ,*body) + ,*(if (or (eq oper 'handle*) + (and (plusp sys:compat) + (<= 161 sys:compat))) + ^(,exc-sym)) + ,exc-args))) + (else (sys:handle-bad-syntax hc)))))) + ^(handler-bind (lambda (,exc-sym . ,exc-args) + (cond + ,*(mapcar (aret ^((exception-subtype-p ,exc-sym ',@1) ,@2)) + syms-fragments))) + ,[mapcar car syms-fragments] + ,try-form))) + +(defmacro handle (:form form try-form . handle-clauses) + (sys:expand-handle form try-form handle-clauses)) + +(defmacro handle* (:form form try-form . handle-clauses) + (sys:expand-handle form try-form handle-clauses)) + +(defmacro ignwarn (. forms) + ^(handler-bind (lambda (exc-sym . args) (throw 'continue)) (warning) ,*forms)) diff --git a/stdlib/ffi.tl b/stdlib/ffi.tl new file mode 100644 index 00000000..dbf7888c --- /dev/null +++ b/stdlib/ffi.tl @@ -0,0 +1,181 @@ +;; Copyright 2017-2021 +;; Kaz Kylheku <kaz@kylheku.com> +;; Vancouver, Canada +;; 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 HOLDER 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. + +(defmacro sys:dlib-expr (spec) + (typecase spec + (null ^(dlopen)) + (str ^(dlopen ,spec rtld-now)) + (t spec))) + +(defmacro with-dyn-lib (lib . body) + (let ((keep-var (gensym "lib-"))) + ^(prog1 + (defvarl ,keep-var (sys:dlib-expr ,lib)) + (symacrolet ((sys:ffi-lib ,keep-var)) + ,*body)))) + +(defun sys:with-dyn-lib-check (f e ref) + (when (eq (macroexpand 'sys:ffi-lib e) 'sys:ffi-lib) + (compile-warning f "simple ref ~s requires ~s" + ref 'with-dyn-lib))) + +(defun sys:expand-sym-ref (f e exp) + (cond + ((stringp exp) + (sys:with-dyn-lib-check f e exp) + ^(dlsym-checked sys:ffi-lib ,exp)) + ((and (consp exp) (stringp (car exp))) + (mac-param-bind f (sym ver) exp + (sys:with-dyn-lib-check f e exp) + ^(dlvsym-checked sys:ffi-lib ,sym ,ver))) + (t exp))) + +(defun sys:analyze-argtypes (form argtypes) + (tree-bind (: ftypes vtypes) (split* argtypes (op where (op eq :))) + (when vtypes + (when (null ftypes) + (compile-error form "variadic with zero fixed arguments not allowed")) + (set vtypes + (collect-each ((vt vtypes)) + (caseq vt + ((float) 'double) + ((be-float le-float) + (compile-error form "variadic argument cannot be of type ~s" + vt)))))) + (list* (+ (len ftypes) (len vtypes)) (len ftypes) (append ftypes vtypes)))) + + +(defmacro deffi (:form f :env e name fun-expr rettype argtypes) + (let ((fun-ref (sys:expand-sym-ref f e fun-expr)) + (ret-type-sym (gensym "ret-type-")) + (arg-types-sym (gensym "arg-types-")) + (call-desc-sym (gensym "call-desc-")) + (fun-sym (gensym "ffi-fun-"))) + (tree-bind (nargs nfixed . argtypes) (sys:analyze-argtypes f argtypes) + (let ((arg-syms (take nargs (gun (gensym))))) + ^(progn + (defvarl ,ret-type-sym (ffi-type-compile ',rettype)) + (defvarl ,arg-types-sym [mapcar ffi-type-compile ',argtypes]) + (defvarl ,call-desc-sym (ffi-make-call-desc ,nargs ,nfixed + ,ret-type-sym + ,arg-types-sym + ',name)) + (defvarl ,fun-sym ,fun-ref) + (defun ,name ,arg-syms + (ffi-call ,fun-sym ,call-desc-sym ,*arg-syms))))))) + +(defmacro deffi-type (name type-expr) + ^(ffi-typedef ',name (ffi-type-compile ',type-expr))) + +(defmacro typedef (name type-expr) + ^(ffi-typedef ',name (ffi-type-compile ',type-expr))) + +(defun sys:deffi-cb-expander (f name rettype argtypes safe-p abort-retval) + (let ((ret-type-sym (gensym "ret-type-")) + (arg-types-sym (gensym "arg-types-")) + (call-desc-sym (gensym "call-desc-")) + (fun-sym (gensym "fun-"))) + (tree-bind (nargs nvariadic . argtypes) (sys:analyze-argtypes f argtypes) + ^(progn + (defvarl ,ret-type-sym (ffi-type-compile ',rettype)) + (defvarl ,arg-types-sym [mapcar ffi-type-compile ',argtypes]) + (defvarl ,call-desc-sym (ffi-make-call-desc ,nargs ,nvariadic + ,ret-type-sym + ,arg-types-sym + ',name)) + (defun ,name (,fun-sym) + [ffi-make-closure ,fun-sym ,call-desc-sym ,safe-p ,abort-retval]))))) + +(defmacro deffi-cb (:form f name rettype argtypes : abort-retval) + (sys:deffi-cb-expander f name rettype argtypes t abort-retval)) + +(defmacro deffi-cb-unsafe (:form f name rettype argtypes) + (sys:deffi-cb-expander f name rettype argtypes nil nil)) + +(defmacro deffi-sym (:form f :env e name var-expr : type-sym) + (let ((var-ref (sys:expand-sym-ref f e var-expr))) + ^(defparml ,name ,(if type-sym + ^(cptr-cast ',type-sym ,var-ref) + var-ref)))) + +(defmacro deffi-var (:form f :env e name var-expr type) + (let ((var-ref (sys:expand-sym-ref f e var-expr)) + (type-sym (gensym "type-")) + (var-sym (gensym "var-"))) + ^(progn + (defvarl ,type-sym (ffi ,type)) + (defvarl ,var-sym (carray-cptr ,var-ref ,type-sym 1)) + (defsymacro ,name (carray-ref ,var-sym 0))))) + +(defmacro deffi-struct (name . body) + ^(typedef ,name (struct ,name ,*body))) + +(defmacro deffi-union (name . body) + ^(typedef ,name (union ,name ,*body))) + +(defmacro sizeof (type : (obj nil obj-p) :env menv) + (if obj-p + (if (constantp obj menv) + (sys:dyn-size (ffi-type-compile type) obj) + ^(sys:dyn-size (load-time (ffi-type-compile ',type)) ,obj)) + (ffi-size (ffi-type-compile type)))) + +(defmacro alignof (type) + (ffi-alignof (ffi-type-compile type))) + +(defmacro offsetof (struct memb) + (ffi-offsetof (ffi-type-compile struct) memb)) + +(defmacro arraysize (arr) + (ffi-arraysize (ffi-type-compile arr))) + +(defmacro elemtype (type) + ^(ffi-elemtype (ffi-type-compile ',type))) + +(defmacro elemsize (type) + (ffi-elemsize (ffi-type-compile type))) + +(defmacro ffi (type) + ^(ffi-type-compile ',type)) + +(define-accessor carray-ref carray-refset) + +(defset carray-sub (carray : (from 0) (to t)) items + (with-gensyms (it) + ^(alet ((,it ,items)) + (progn (carray-replace ,carray ,it ,from ,to) ,it)))) + +(defset sub-buf (buf : (from 0) (to t)) items + (with-gensyms (it) + ^(alet ((,it ,items)) + (progn (replace-buf ,buf ,it ,from ,to) ,it)))) + +(defmacro znew (type . pairs) + (if (oddp (length pairs)) + (throwf 'eval-error "~s: slot initform arguments must occur pairwise" + 'znew)) + (let ((qpairs (mappend (aret ^(',@1 ,@2)) (tuples 2 pairs)))) + ^(make-zstruct (ffi ,type) ,*qpairs))) diff --git a/stdlib/getopts.tl b/stdlib/getopts.tl new file mode 100644 index 00000000..99ce9f9b --- /dev/null +++ b/stdlib/getopts.tl @@ -0,0 +1,407 @@ +;; Copyright 2016-2021 +;; Kaz Kylheku <kaz@kylheku.com> +;; Vancouver, Canada +;; 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 HOLDER 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. + +(defex opt-error error) + +(defstruct opt-desc nil + short + long + helptext + arg-p + (type :bool) + (:static valid-types '(:bool :dec :hex :oct :cint :float :str :text)) + (:postinit (me) + me.(check) + (set me.arg-p (neq me.type :bool)))) + +(defstruct (sys:opt-parsed name arg desc : eff-type) nil + name + arg ;; string, integer, real, ... + desc ;; opt-desc + eff-type + cumul + (:postinit (me) me.(convert-type))) + +(defstruct opts nil + (opt-hash (hash :equal-based)) ;; string to sys:opt-parsed + in-args + out-args) + +(defstruct sys:opt-processor nil + od-list + (od-hash (hash :equal-based)) ;; string to opt-desc + opts + (:postinit (me) + me.(build-hash))) + +(defun sys:opt-err (. args) + (throwf 'opt-error . args)) + +(defun getopts-error (msg . args) + (error `~s: @msg` 'getopts . args)) + +(defun sys:opt-dash (name) + `@(if (> (length name) 1) "-")-@name`) + +(defmeth opt-desc basic-type-p (me type) + (or (functionp type) (fboundp type) (member type me.valid-types))) + +(defmeth opt-desc list-type-p (me type) + (tree-case type + ((indicator btype) (and (eq indicator 'list) + me.(basic-type-p btype))) + (x nil))) + +(defmeth opt-desc cumul-type-p (me type) + (tree-case type + ((indicator btype) (and (eq indicator 'usr:cumul) + (or me.(basic-type-p btype) + me.(list-type-p btype)))) + (x nil))) + +(defmeth opt-desc check (me) + (unless (or me.(basic-type-p me.type) + me.(list-type-p me.type) + me.(cumul-type-p me.type)) + (getopts-error "invalid option type specifier ~s" + me.type)) + (when me.long + (when (< (length me.long) 2) + (getopts-error "long option ~a has a short name" me.long)) + (when (eql [me.long 0] #\-) + (getopts-error "long option ~a starts with - character" me.long))) + (when me.short + (when (neq (length me.short) 1) + (getopts-error "short option ~a not one character long" me.short)) + (when (eql [me.short 0] #\-) + (getopts-error "short option ~a starts with - character" me.short)))) + +(defmeth sys:opt-parsed convert-type (me) + (let ((name (sys:opt-dash me.name)) + (type (or me.eff-type me.desc.type))) + (when (and (neq type :bool) + (eq me.arg :explicit-no)) + (sys:opt-err "Non-Boolean option ~a explicitly specified as false" name)) + (caseql type + (:bool + (set me.arg (neq me.arg :explicit-no))) + (:dec (set me.arg + (or (and (r^$ #/[+\-]?\d+/ me.arg) (int-str me.arg)) + (sys:opt-err "option ~a needs decimal integer arg, not ~a" + name me.arg)))) + (:hex (set me.arg + (or (and (r^$ #/[+\-]?[\da-fA-F]+/ me.arg) (int-str me.arg 16)) + (sys:opt-err "option ~a needs hexadecimal integer arg, not ~a" + name me.arg)))) + (:oct (set me.arg + (or (and (r^$ #/[+\-]?[0-7]+/ me.arg) (int-str me.arg 8)) + (sys:opt-err "option ~a needs octal integer arg, not ~a" + name me.arg)))) + (:cint (set me.arg + (cond + ((r^$ #/[+\-]?0x[\da-fA-F]+/ me.arg) + (int-str (regsub #/0x/ "" me.arg) 16)) + ((r^$ #/[+\-]?0[0-7]+/ me.arg) + (int-str me.arg 8)) + ((r^$ #/[+\-]?0[\da-fA-F]+/ me.arg) + (sys:opt-err "option ~a argument ~a non octal, but leading 0" + name me.arg)) + ((r^$ #/[+\-]?\d+/ me.arg) + (int-str me.arg)) + (t (sys:opt-err "option ~a needs C style numeric arg, not ~a" + name me.arg))))) + (:float (set me.arg + (cond + ([[chand (orf (f^$ #/[+\-]?\d+[.]?([Ee][+\-]?\d+)?/) + (f^$ #/[+\-]?\d*[.]?\d+([Ee][+\-]?\d+)?/)) + flo-str] me.arg]) + (t (sys:opt-err "option ~a needs floating-point arg, not ~a" + name me.arg))))) + (:str (set me.arg + (or (ignerr (read `"@{me.arg}"`)) + (sys:opt-err "option ~a needs string lit syntax, ~a given" + name me.arg)))) + (:text) + (t (cond + ((and (consp type) (eq (car type) 'list)) + (let* ((rec-type (cadr type)) + (pieces (split-str me.arg #/,/)) + (sub-opts (mapcar (do new (sys:opt-parsed me.name @1 + me.desc + rec-type)) + pieces))) + (set me.arg (mapcar (usl arg) sub-opts)))) + ((and (consp type) (eq (car type) 'cumul)) + (let* ((rec-type (cadr type)) + (sub-opt (new (sys:opt-parsed me.name me.arg + me.desc rec-type)))) + (set me.arg sub-opt.arg + me.cumul t))) + ((or (symbolp type) (functionp type)) + (set me.arg (call type me.arg)))))))) + +(defmeth opts lambda (me key : dfl) + (iflet ((o [me.opt-hash key])) o.arg dfl)) + +(defmeth opts lambda-set (me key val) + (iflet ((o [me.opt-hash key])) + (set o.arg val) + (error "opts: cannot set option ~s to ~s: no such option" key val))) + +(defmeth opts add-opt (me opt) + (when opt.cumul + (let* ((old-opt [me.opt-hash (or opt.desc.long + opt.desc.short)]) + (old-arg (if old-opt old-opt.arg))) + (set opt.arg (cons opt.arg old-arg)))) + (whenlet ((n opt.desc.short)) + (set [me.opt-hash n] opt)) + (whenlet ((n opt.desc.long)) + (set [me.opt-hash n] opt))) + +(defmeth sys:opt-processor build-hash (me) + (each ((od me.od-list)) + (unless (or od.long od.short) + (error "opt-processor: no short or long name in option ~s" od)) + (each ((str (list od.long od.short))) + (when (and str [me.od-hash str]) + (error "opt-processor: duplicate option ~s" str)) + (set [me.od-hash str] od)))) + +(defmeth sys:opt-processor parse-long (me opt : arg) + (iflet ((ieq (unless (stringp arg) (break-str opt "=")))) + (let ((oname [opt 0..ieq]) + (arg [opt (succ ieq)..:])) + me.(parse-long oname arg)) + (let ((od [me.od-hash opt]) + (opts me.opts)) + (cond + ((null od) + (sys:opt-err "unrecognized option: --~a" opt)) + ((and arg od.arg-p) + opts.(add-opt (new (sys:opt-parsed opt arg od)))) + ((stringp arg) + (sys:opt-err "option --~a doesn't take an argument" opt)) + (od.arg-p + (iflet ((arg (pop opts.out-args))) + opts.(add-opt (new (sys:opt-parsed opt arg od))) + (sys:opt-err "option --~a requires an argument" opt))) + (t opts.(add-opt (new (sys:opt-parsed opt arg od)))))))) + +(defmeth sys:opt-processor parse-shorts (me oarg) + (each ((o (split-str oarg #//))) + (iflet ((opts me.opts) + (od [me.od-hash o])) + (let ((arg (when od.arg-p + (when (> (length oarg) 1) + (sys:opt-err "argument -~a includes -~a, which does not clump" + oarg o)) + (unless opts.out-args + (sys:opt-err "option -~a requires an argument" o)) + (pop opts.out-args)))) + opts.(add-opt (new (sys:opt-parsed o arg od)))) + (sys:opt-err "unrecognized option: -~a" o)))) + +(defmeth sys:opt-processor parse-opts (me args) + (let ((opts me.opts)) + (whilet ((arg (pop opts.out-args))) + (cond + ((equal "--" arg) (return)) + ((r^ #/--no-/ arg) me.(parse-long [arg 5..:] :explicit-no)) + ((r^ #/--/ arg) me.(parse-long [arg 2..:])) + ((r^ #/-.+/ arg) me.(parse-shorts [arg 1..:])) + (t (push arg opts.out-args) + (return)))) + opts)) + +(defun sys:wdwrap (string columns) + (let ((words (tok-str string #/\S+/)) + line) + (build + (whilet ((word (pop words)) + (wpart (cond + ((and word (r^$ #/\w+[\w\-]*\w[.,;:!?"]?/ word)) + (split-str word #/-/)) + (word (list word)))) + (wpart-orig wpart)) + (whilet ((wp0 (eq wpart wpart-orig)) + (wp (pop wpart)) + (w (if wp `@wp@(if wpart "-")`))) + (cond + ((not line) + (set line w)) + ((> (+ (length line) (length w) 1) columns) + (add line) + (set line w)) + (t (set line `@line@(if wp0 " ")@w`))))) + (if line + (add line))))) + +(defun opt (short long : (type :bool) helptext) + (new opt-desc short short long long helptext helptext type type)) + +(defun getopts (opt-desc-list args) + (let* ((opts (new opts in-args args out-args args)) + (opr (new sys:opt-processor od-list opt-desc-list opts opts))) + opr.(parse-opts args))) + +(defun opthelp (opt-desc-list : (stream *stdout*)) + (let ((sorted [nsort (copy-list (remove-if (op null @1.helptext) + opt-desc-list)) : + (do if @1.long @1.long @1.short)]) + (undocumented (keep-if (op null @1.helptext) opt-desc-list))) + (put-line "\nOptions:\n") + (each ((od sorted)) + (let* ((type (if (and (consp od.type) (eq (car od.type) 'cumul)) + (cadr od.type) + od.type)) + (tstr (cond + ((keywordp type) (upcase-str (symbol-name type))) + ((and (consp type) (eq (car type) 'list)) + (let ((ts (upcase-str (symbol-name (cadr type))))) + `@ts[,@ts...]`)) + (t "ARG"))) + (long (if od.long + `--@{od.long}@(if od.arg-p `=@tstr`)`)) + (short (if od.short + `-@{od.short}@(if od.arg-p ` @tstr`)`)) + (ls (cond + ((and long short) `@{long 21} (@short)`) + (long long) + (short `@{"" 21} @short`))) + (lines (if od.helptext (sys:wdwrap od.helptext 43)))) + (put-line ` @{ls 34}@(pop lines)`) + (while lines + (put-line ` @{"" 34}@(pop lines)`)))) + (put-line) + (when undocumented + (put-line "Undocumented options:\n") + (let* ((undoc-str `@{[mapcar sys:opt-dash + (flatten (mappend (op list @1.short @1.long) + undocumented))] ", "}`)) + (each ((line (sys:wdwrap undoc-str 75))) + (put-line ` @line`))) + (put-line)) + (put-line "Notes:\n") + (let* ((have-short (some sorted (usl short))) + (have-long (some sorted (usl long))) + (have-arg-p (some sorted (usl arg-p))) + (have-bool (some sorted (op eq @1.type :bool))) + (texts (list (if have-short + "Short options can be invoked with long syntax: \ \ + for example, --a can be used when -a exists.\ \ + Short no-argument options can be clumped into\ \ + one argument as exemplified by -xyz.") + (if have-bool + (if have-arg-p + "Options that take no argument are Boolean:" + (if undocumented + "All documented options are Boolean:" + "All options are Boolean:"))) + (if have-bool + "they are true when present, false when absent.") + (if (and have-bool have-arg-p) + "The --no- prefix can explicitly specify \ \ + Boolean options as false: if a Boolean option\ \ + X exists,\ \ + --no-X specifies it as false. This is useful\ \ + for making false those options which default\ \ + to true. " + "The --no- prefix can explicitly specify \ \ + options as false: if an X option exists,\ \ + --no-X specifies it as false. This is useful\ \ + for making false those options which default\ \ + to true. ") + (if (not have-long) + "Note the double dash on --no.") + (if (and have-short have-long) + "The --no- prefix can be applied to a short\ \ + or long option name.") + (if have-arg-p + "The argument to a long option can be given in one\ \ + argument as --option=arg or as a separate\ \ + argument using --option arg.") + "The special argument -- can be used where an option\ \ + may appear. It means \"end of options\": the\ \ + arguments which follow are not treated as options\ \ + even if they look like options."))) + (mapdo (do put-line ` @1`) + (sys:wdwrap `@{(flatten texts)}` 77))) + (put-line) + (whenlet ((types (keep-if [andf keywordp (op neq :bool)] + (uniq (mapcar (usl type) sorted))))) + (put-line "Type legend:\n") + (each ((ty types)) + (iflet ((ln (caseql ty + (:dec " DEC - Decimal integer: -123, 0, 5, +73") + (:hex " HEX - Hexadecimal integer -EF, 2D0, +9A") + (:oct " OCT - Octal integer: -773, 5677, +326") + (:cint " CINT - C-style integer: leading 0 octal,\ + \ leading 0x hex, else decimal;\n\ + \ leading sign allowed: -0777, 0xFDC, +123") + (:float " FLOAT - Floating-point: -1.3e+03, +5, 3.3,\ + \ 3., .5, .12e9, 53.e-3, 3e-015") + (:str " STR - String with embedded escapes, valid\ + \ as TXR Lisp string literals\n\ + \ syntax: foo, foo\\tbar, abc\\nxyz") + (:text " TEXT - Unprocessed text")))) + (put-line ln))) + (put-line)))) + + +(defstruct sys:option-base nil + in-args + out-args + (:static slot-hash) + (:static opt-desc-list) + (:method add-opt (me opt) + (let* ((sl [me.slot-hash (or opt.desc.long opt.desc.short)]) + (arg (if opt.cumul + (cons opt.arg (slot me sl)) + opt.arg))) + (slotset me sl arg))) + (:method getopts (me args) + (set me.in-args args me.out-args args) + (let ((opr (new sys:opt-processor od-list me.opt-desc-list opts me))) + opr.(parse-opts args))) + (:method opthelp (me : (stream *stdout*)) + (opthelp me.opt-desc-list stream))) + +(defmacro define-option-struct (name super-spec . opts) + (let* ((slots (mapcar (tb ((short long . rest)) + (or long short)) + opts)) + (supers (if (and super-spec (atom super-spec)) + (list super-spec) + super-spec))) + ^(defstruct ,name (,*supers sys:option-base) + ,*slots + (:static slot-hash #H(() ,*(mapcar [juxt symbol-name identity] slots))) + (:static opt-desc-list ',(mapcar (tb ((short long . rest)) + (opt (if short (symbol-name short)) + (if long (symbol-name long)) + . rest)) + opts))))) diff --git a/stdlib/getput.tl b/stdlib/getput.tl new file mode 100644 index 00000000..13ffba4b --- /dev/null +++ b/stdlib/getput.tl @@ -0,0 +1,188 @@ +;; Copyright 2016-2021 +;; Kaz Kylheku <kaz@kylheku.com> +;; Vancouver, Canada +;; 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 HOLDER 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. + +(defun sys:get-buf-common (s bytes seek) + (let ((b (make-buf 0 0 (min bytes 4096))) + (o 0)) + (when (plusp seek) + (unless (ignerr (seek-stream s seek :from-current)) + (let ((b (make-buf (min seek 4096))) + (c 0)) + (while (< c seek) + (let ((p (fill-buf b 0 s))) + (if (zerop p) + (return)) + (inc c p)))))) + (while (or (null bytes) (< (len b) bytes)) + (let ((p (fill-buf-adjust b o s))) + (when (= p o) + (return)) + (set o p) + (when (eql p (buf-alloc-size b)) + (buf-set-length b (min (+ p p) bytes))))) + b)) + +(defun get-jsons (: (s *stdin*)) + (when (stringp s) + (set s (make-string-byte-input-stream s))) + (build + (catch* + (while t + (add (get-json s))) + (syntax-error (type . args) + (if (parse-errors s) + (throw type . args)))))) + +(defun put-jsons (list : (s *stdout*) flat-p) + (each ((obj list)) + (put-jsonl obj s flat-p)) + t) + +(defun file-get (name) + (with-stream (s (open-file name)) + (read s))) + +(defun file-put (name obj) + (with-stream (s (open-file name "w")) + (prinl obj s))) + +(defun file-append (name obj) + (with-stream (s (open-file name "a")) + (prinl obj s))) + +(defun file-get-string (name) + (with-stream (s (open-file name)) + (get-string s))) + +(defun file-put-string (name string) + (with-stream (s (open-file name "w")) + (put-string string s))) + +(defun file-append-string (name string) + (with-stream (s (open-file name "a")) + (put-string string s))) + +(defun file-get-lines (name) + (get-lines (open-file name))) + +(defun file-put-lines (name lines) + (with-stream (s (open-file name "w")) + (put-lines lines s))) + +(defun file-append-lines (name lines) + (with-stream (s (open-file name "a")) + (put-lines lines s))) + +(defun file-get-buf (name : bytes (seek 0)) + (with-stream (s (open-file name "rb")) + (sys:get-buf-common s bytes seek))) + +(defun file-put-buf (name buf : (seek 0)) + (with-stream (s (open-file name "wb")) + (unless (zerop seek) + (seek-stream s seek :from-current)) + (put-buf buf 0 s))) + +(defun file-place-buf (name buf : (seek 0)) + (with-stream (s (open-file name "mb")) + (unless (zerop seek) + (seek-stream s seek :from-current)) + (put-buf buf 0 s))) + +(defun file-append-buf (name buf) + (with-stream (s (open-file name "ab")) + (put-buf buf 0 s))) + +(defun file-get-json (name) + (with-stream (s (open-file name)) + (get-json s))) + +(defun file-put-json (name obj : flat-p) + (with-stream (s (open-file name "w")) + (put-jsonl obj s flat-p))) + +(defun file-append-json (name obj : flat-p) + (with-stream (s (open-file name "a")) + (put-jsonl obj s flat-p))) + +(defun file-get-jsons (name) + (with-stream (s (open-file name)) + (get-jsons s))) + +(defun file-put-jsons (name seq : flat-p) + (with-stream (s (open-file name "w")) + (put-jsons seq s flat-p))) + +(defun file-append-jsons (name seq : flat-p) + (with-stream (s (open-file name "a")) + (put-jsons s seq flat-p))) + +(defun command-get (cmd) + (with-stream (s (open-command cmd)) + (read s))) + +(defun command-put (cmd obj) + (with-stream (s (open-command cmd "w")) + (prinl obj s))) + +(defun command-get-string (cmd) + (with-stream (s (open-command cmd)) + (get-string s))) + +(defun command-put-string (cmd string) + (with-stream (s (open-command cmd "w")) + (put-string string s))) + +(defun command-get-lines (cmd) + (get-lines (open-command cmd))) + +(defun command-put-lines (cmd lines) + (with-stream (s (open-command cmd "w")) + (put-lines lines s))) + +(defun command-get-buf (cmd : bytes (skip 0)) + (with-stream (s (open-command cmd "rb")) + (sys:get-buf-common s bytes skip))) + +(defun command-put-buf (cmd buf) + (with-stream (s (open-command cmd "wb")) + (put-buf buf 0 s))) + +(defun command-get-json (cmd) + (with-stream (s (open-command cmd)) + (get-json s))) + +(defun command-put-json (cmd obj : flat-p) + (with-stream (s (open-command cmd "w")) + (put-jsonl obj s flat-p))) + +(defun command-get-jsons (cmd) + (with-stream (s (open-command cmd)) + (get-jsons s))) + +(defun command-put-jsons (cmd seq : flat-p) + (with-stream (s (open-command cmd "w")) + (put-jsons seq s flat-p))) diff --git a/stdlib/hash.tl b/stdlib/hash.tl new file mode 100644 index 00000000..b9010500 --- /dev/null +++ b/stdlib/hash.tl @@ -0,0 +1,42 @@ +;; Copyright 2015-2021 +;; Kaz Kylheku <kaz@kylheku.com> +;; Vancouver, Canada +;; 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 HOLDER 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. + +(defmacro with-hash-iter ((name hash-form : key val) . body) + (let ((hash (gensym)) + (iter (gensym)) + (next (gensym))) + ^(let* ((,hash ,hash-form) + (,iter (hash-begin ,hash)) + ,*(if key ^((,key))) + ,*(if val ^((,val)))) + (flet ((,name () + ,(if (not (or key val)) + ^(hash-next ,iter) + ^(let ((,next (hash-next ,iter))) + ,*(if key ^((set ,key (car ,next)))) + ,*(if val ^((set ,val (cdr ,next)))) + ,next)))) + ,*body)))) diff --git a/stdlib/ifa.tl b/stdlib/ifa.tl new file mode 100644 index 00000000..f643cf92 --- /dev/null +++ b/stdlib/ifa.tl @@ -0,0 +1,82 @@ +;; Copyright 2015-2021 +;; Kaz Kylheku <kaz@kylheku.com> +;; Vancouver, Canada +;; 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 HOLDER 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. + +(defmacro ifa (:env e :form f test then : else) + (flet ((candidate-p (form) + (not (or (constantp form e) (symbolp form))))) + (cond + ((or (atom test) (null (cdr test))) ^(let ((it ,test)) + (if it ,then ,else))) + ((member (first test) '(not null false)) + (unless (eql (length test) 2) + (compile-error f "wrong number of arguments to ~s" (first test))) + ^(ifa ,(second test) ,else ,then)) + (t (let* ((sym (first test)) + (args (if (eq 'dwim sym) (cddr test) (cdr test))) + (n-candidate-args [count-if candidate-p args]) + (pos-candidate (or [pos-if candidate-p args] 0))) + (unless (or (lexical-fun-p e sym) + (and (or (functionp (symbol-function sym)) + (eq sym 'dwim) + (null (symbol-function sym))))) + (compile-error f "test expression must be \ + \ a simple function call")) + (when (> n-candidate-args 1) + (compile-error f "ambiguous situation: \ + \ not clear what can be \"it\"")) + (iflet ((it-form (macroexpand [args pos-candidate] e)) + (is-place (place-form-p it-form e))) + (let ((before-it [args 0..pos-candidate]) + (after-it [args (succ pos-candidate)..:])) + (let* ((btemps (mapcar (ret (gensym)) before-it)) + (atemps (mapcar (ret (gensym)) after-it))) + ^(let (,*(zip btemps before-it)) + (placelet ((it ,it-form)) + (let (,*(zip atemps after-it)) + (if (,sym ,*(if (eq 'dwim sym) ^(,(second test))) + ,*btemps it ,*atemps) + ,then ,else)))))) + (let* ((temps (mapcar (ret (gensym)) args)) + (it-temp [temps pos-candidate])) + ^(let* (,*(zip temps args) (it ,it-temp)) + (if (,sym ,*(if (eq 'dwim sym) ^(,(second test))) + ,*temps) ,then ,else))))))))) + +(defmacro whena (test . body) + ^(ifa ,test (progn ,*body))) + +(defun sys:if-to-cond (f if-oper cond-oper pairs) + (tree-case pairs + (((test . forms) . rest) ^(,if-oper ,test (progn ,*forms) + (,cond-oper ,*rest))) + (() ()) + (else (compile-error f "bad syntax: ~s" pairs)))) + +(defmacro conda (:form f . pairs) + (sys:if-to-cond f 'ifa 'conda pairs)) + +(defmacro condlet (:form f . pairs) + (sys:if-to-cond f 'iflet 'condlet pairs)) diff --git a/stdlib/keyparams.tl b/stdlib/keyparams.tl new file mode 100644 index 00000000..e1eba2d0 --- /dev/null +++ b/stdlib/keyparams.tl @@ -0,0 +1,90 @@ +;; Copyright 2017-2021 +;; Kaz Kylheku <kaz@kylheku.com> +;; Vancouver, Canada +;; 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 HOLDER 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. + +(defun sys:extract-keys (keys args) + (build + (each ((k keys)) + (iflet ((f (memp (car k) args))) + (add (cadr f)) + (add (cdr k)))))) + +(defun sys:extract-keys-p (keys args) + (build + (each ((k keys)) + (add (if (memp k args) t))))) + +(defun sys:build-key-list-expr (key-params menv) + (let ((exprs (collect-each ((kp key-params)) + (let ((kw (intern (symbol-name (first kp)) 'keyword)) + (ex (second kp))) + (if (constantp ex menv) + ^(quote (,kw . ,(second kp))) + ^(cons ,kw ,(second kp))))))) + (if [all exprs (op eq 'quote) car] + ^(quote ,[mapcar cadr exprs]) + ^(list ,*exprs)))) + +(define-param-expander :key (param body menv form) + (let* ((excluding-rest (butlastn 0 param)) + (key-start (memq '-- excluding-rest)) + (rest-param (or (nthlast 0 param) (gensym))) + (before-key (ldiff excluding-rest key-start)) + (key-params-raw (butlastn 0 (cdr key-start))) + (key-params [mapcar [iffi atom (op list @1)] key-params-raw]) + (eff-param (append before-key rest-param))) + (each ((key-spec key-params)) + (tree-case key-spec + ((sym init var-p . junk) + (when (consp junk) + (compile-error form "superfluous forms in ~s" key-spec)) + (when junk + (compile-error form "invalid dotted form ~s" key-spec)) + (unless (bindable var-p) + (compile-error form "~s isn't a bindable symbol" var-p)) + :) + ((sym init . more) + (unless (listp more) + (compile-error form "invalid dotted form ~s" key-spec)) + :) + ((sym . more) + (unless (listp more) + (compile-error form "invalid dotted form ~s" key-spec)) + (unless (bindable sym) + (compile-error form "~s isn't a bindable symbol" sym))))) + (let* ((key-params-p [keep-if third key-params]) + (key-vars [mapcar first key-params]) + (key-vars-p [mapcar third key-params-p]) + (keys (sys:build-key-list-expr key-params menv)) + (keys-p (mapcar (op intern (symbol-name (first @1)) 'keyword) + key-params-p))) + (list eff-param + ^(tree-bind ,key-vars + (sys:extract-keys ,keys ,rest-param) + ,*(if keys-p + ^((tree-bind ,key-vars-p + (sys:extract-keys-p ',keys-p ,rest-param) + ,*body)) + body)))))) diff --git a/stdlib/match.tl b/stdlib/match.tl new file mode 100644 index 00000000..3502688b --- /dev/null +++ b/stdlib/match.tl @@ -0,0 +1,1070 @@ +;; Copyright 2021 +;; Kaz Kylheku <kaz@kylheku.com> +;; Vancouver, Canada +;; 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 HOLDER 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. + +(defvar *match-form*) + +(defvar *match-macro* (hash)) + +(defstruct match-guard () + temps + vars + var-exprs + pure-temps + pure-temp-exprs + (guard-expr t) + (test-expr t) + + (:method assignments (me) + (mapcar (op list 'set) me.vars me.var-exprs)) + + (:method lets (me) + (zip me.pure-temps me.pure-temp-exprs)) + + (:method wrap-expr (g exp) + (let ((lets g.(lets)) + (temps g.temps)) + (if (neq t g.test-expr) + (set exp ^(if ,g.test-expr ,exp))) + (cond + ((and lets temps) + (set exp ^(alet ,lets + (let ,temps + ,*g.(assignments) + ,exp)))) + (lets + (set exp ^(alet ,lets + ,*g.(assignments) + ,exp))) + (temps + (set exp ^(let ,temps + ,*g.(assignments) + ,exp))) + (t + (set exp ^(progn ,*g.(assignments) + ,exp)))) + (when (neq t g.guard-expr) + (set exp ^(if ,g.guard-expr ,exp))) + exp))) + +(defstruct guard-disjunction () + guard-chains + sub-patterns + all-vars + + (:method wrap-expr (g exp) + (let* ((vars [mapcar get-vars g.guard-chains]) + (back-vars (cons nil + (reverse + [mapcar (ap append) (conses (reverse vars))]))) + (branches (collect-each ((gc g.guard-chains) + (v vars) + (bv back-vars)) + ^(progn + (set ,*(mappend (ret ^(,@1 nil)) (diff bv v))) + ,(reduce-right (umeth wrap-expr) gc t))))) + (set exp ^(when (or ,*branches) + ,exp)) + exp))) + +(defstruct compiled-match () + pattern + obj-var + guard-chain + + (:method get-vars (me) + (uniq (get-vars me.guard-chain))) + + (:method wrap-guards (me . forms) + (reduce-right (umeth wrap-expr) me.guard-chain ^(progn ,*forms))) + + (:method add-guard-pre (me guard) + (push guard me.guard-chain)) + + (:method add-guards-pre (me . guards) + (set me.guard-chain + (append guards + me.guard-chain))) + + (:method add-guards-post (me . guards) + (set me.guard-chain + (append me.guard-chain + guards)))) + +(defstruct var-list () + vars + menv + + (:method exists (me sym) (or (member sym me.vars) + (lexical-var-p me.menv sym) + (boundp sym))) + (:method record (me sym) (push sym me.vars)) + (:method merge (me copy) (each ((v copy.vars)) (pushnew v me.vars)))) + +(defun get-vars (guard-chain) + (append-each ((g guard-chain)) + (typecase g + (match-guard + g.vars) + (guard-disjunction + (append-each ((gc g.guard-chains)) (get-vars gc))) + (t (compile-error *match-form* + "internal error: bad guard ~s" g))))) + +(defun compile-struct-match (struct-pat obj-var var-list) + (mac-param-bind *match-form* (op required-type . pairs) struct-pat + (let* ((loose-p (not (bindable required-type))) + (slot-pairs (plist-to-alist pairs)) + (required-slots [mapcar car slot-pairs]) + (slot-gensyms [mapcar gensym required-slots]) + (type-gensym (if loose-p + (gensym "type-"))) + (slot-patterns [mapcar cdr slot-pairs]) + (slot-matches [mapcar (lop compile-match var-list) + slot-patterns slot-gensyms]) + (type-match (if loose-p + (compile-match required-type type-gensym var-list))) + (slot-val-exprs [mapcar (ret ^(slot ,obj-var ',@1)) required-slots]) + (guard0 (if loose-p + (list (new match-guard + pure-temps (list type-gensym) + pure-temp-exprs (list ^(struct-type ,obj-var)) + guard-expr ^(structp ,obj-var))))) + (guard1 (list (new match-guard + pure-temps slot-gensyms + pure-temp-exprs slot-val-exprs + guard-expr (if loose-p + ^(and ,*(mapcar + (ret ^(slotp ,type-gensym + ',@1)) + required-slots)) + ^(subtypep (typeof ,obj-var) + ',required-type)))))) + (unless loose-p + (let ((type (find-struct-type required-type))) + (if type + (each ((slot required-slots)) + (unless (slotp type slot) + (compile-defr-warning *match-form* ^(slot . ,slot) + "~s has no slot ~s" + required-type slot))) + (compile-defr-warning *match-form* ^(struct-type . ,required-type) + "no such struct type: ~s" + required-type)))) + (new compiled-match + pattern struct-pat + obj-var obj-var + guard-chain (append guard0 + type-match.?guard-chain + guard1 + (mappend .guard-chain slot-matches)))))) + +(defun compile-var-match (sym obj-var var-list) + (cond + ((null sym) + (new compiled-match + obj-var obj-var)) + ((not (bindable sym)) + (compile-error *match-form* "~s is not a bindable symbol" sym)) + ((not var-list.(exists sym)) + var-list.(record sym) + (new compiled-match + pattern sym + obj-var obj-var + guard-chain (if sym (list (new match-guard + vars (list sym) + var-exprs (list obj-var)))))) + (t (new compiled-match + pattern sym + obj-var obj-var + guard-chain (list (new match-guard + guard-expr ^(equal ,obj-var ,sym))))))) + +(defun compile-new-var-match (sym obj-var var-list) + (cond + ((null sym) + (new compiled-match + obj-var obj-var)) + ((not (bindable sym)) + (compile-error *match-form* "~s is not a bindable symbol" sym)) + (t var-list.(record sym) + (new compiled-match + pattern sym + obj-var obj-var + guard-chain (if sym (list (new match-guard + vars (list sym) + var-exprs (list obj-var)))))))) + +(defun compile-vec-match (vec-pat obj-var var-list) + (let* ((elem-gensyms (mapcar (op gensym `elem-@1-`) (range* 0 (len vec-pat)))) + (elem-exprs (mapcar (ret ^[,obj-var ,@1]) (range* 0 (len vec-pat)))) + (elem-matches (list-vec [mapcar (lop compile-match var-list) + vec-pat elem-gensyms])) + (pruned-triple (multi (op keep-if .guard-chain @1 third) + elem-gensyms + elem-exprs + elem-matches)) + (guard (new match-guard + pure-temps (first pruned-triple) + pure-temp-exprs (second pruned-triple) + guard-expr ^(and (vectorp ,obj-var) + (eql (len ,obj-var) ,(len vec-pat)))))) + (new compiled-match + pattern vec-pat + obj-var obj-var + guard-chain (cons guard (mappend .guard-chain elem-matches))))) + +(defun compile-range-match (range-expr obj-var var-list) + (let ((from (from range-expr)) + (to (to range-expr))) + (let* ((from-match (compile-match from (gensym "from") var-list)) + (to-match (compile-match to (gensym "to") var-list)) + (guard (new match-guard + guard-expr ^(rangep ,obj-var) + pure-temps (list from-match.obj-var to-match.obj-var) + pure-temp-exprs (list ^(from ,obj-var) ^(to ,obj-var))))) + (new compiled-match + pattern range-expr + obj-var obj-var + guard-chain (cons guard (append from-match.guard-chain + to-match.guard-chain)))))) + +(defun compile-atom-match (atom obj-var var-list) + (flet ((compile-as-atom () + (new compiled-match + pattern atom + obj-var obj-var + guard-chain (list (new match-guard + guard-expr ^(equal ,obj-var ',atom)))))) + (typecase atom + (vec (if (non-triv-pat-p atom) + (compile-vec-match atom obj-var var-list) + (compile-as-atom))) + (range (if (non-triv-pat-p atom) + (compile-range-match atom obj-var var-list) + (compile-as-atom))) + (t (compile-as-atom))))) + +(defun compile-predicate-match (exp obj-var var-list) + (let ((head (car exp))) + (if (and (consp head) (eq (car head) 'sys:var)) + (tree-case exp + (((sv rvar) (op . args)) + (let* ((avar + (condlet + (((vm (member-if [andf consp (op eq (car @1) 'sys:var)] + args))) + (let ((sym (cadar vm))) + (set args (append (ldiff args vm) + (list sym) + (cdr vm))) + sym)) + (((vm (memq 'sys:var args))) + (let ((sym (cadr vm))) + (set args (append (ldiff args vm) sym)) + sym)))) + (res-var (gensym "res-")) + (arg-var (if avar avar (gensym "obj-")))) + (unless avar + (set args (append args (list arg-var)))) + (let* ((guard (new match-guard + pure-temps (list res-var) + pure-temp-exprs ^((alet ((,arg-var ,obj-var)) + (,op ,*args))) + test-expr res-var)) + (avar-match (compile-var-match avar obj-var var-list)) + (rvar-match (compile-var-match rvar res-var var-list))) + (new compiled-match + pattern exp + obj-var obj-var + guard-chain (append avar-match.guard-chain + (list guard) + rvar-match.guard-chain))))) + (els (compile-error *match-form* "invalid predicate syntax: ~s" exp))) + (compile-predicate-match (list '@nil exp) obj-var var-list)))) + +(defun compile-cons-structure (cons-pat obj-var var-list) + (mac-param-bind *match-form* (car . cdr) cons-pat + (let* ((car-gensym (gensym)) + (cdr-gensym (gensym)) + (car-match (compile-match car car-gensym var-list)) + (cdr-match (if (consp cdr) + (caseq (car cdr) + ((sys:expr sys:var sys:quasi) + (compile-match cdr cdr-gensym var-list)) + (t (compile-cons-structure cdr cdr-gensym var-list))) + (compile-atom-match cdr cdr-gensym var-list))) + (guard (new match-guard + pure-temps (append (if car-match.guard-chain + (list car-gensym)) + (if cdr-match.guard-chain + (list cdr-gensym))) + pure-temp-exprs (append (if car-match.guard-chain + ^((car ,obj-var))) + (if cdr-match.guard-chain + ^((cdr ,obj-var)))) + guard-expr ^(consp ,obj-var)))) + (new compiled-match + pattern cons-pat + obj-var obj-var + guard-chain (cons guard (append car-match.guard-chain + cdr-match.guard-chain)))))) + +(defun compile-require-match (exp obj-var var-list) + (mac-param-bind *match-form* (op match . conditions) exp + (let ((match (compile-match match obj-var var-list))) + match.(add-guards-post (new match-guard + guard-expr ^(and ,*conditions))) + match))) + +(defun compile-as-match (exp obj-var var-list) + (mac-param-bind *match-form* (op sym pat) exp + (let ((var-match (compile-new-var-match sym obj-var var-list)) + (pat-match (compile-match pat obj-var var-list))) + (new compiled-match + pattern exp + obj-var obj-var + guard-chain (append var-match.guard-chain + pat-match.guard-chain))))) + +(defun compile-with-match (exp obj-var var-list) + (tree-case exp + ((op main-pat side-pat-var side-expr) + (let* ((side-var (gensym)) + (side-pat (if (or (null side-pat-var) (bindable side-pat-var)) + ^(sys:var ,side-pat-var) + side-pat-var)) + (main-match (compile-match main-pat obj-var var-list)) + (side-match (compile-match side-pat side-var var-list)) + (guard (new match-guard + pure-temps (list side-var) + pure-temp-exprs (list side-expr)))) + (new compiled-match + pattern exp + obj-var obj-var + guard-chain (append main-match.guard-chain + (list guard) + side-match.guard-chain)))) + ((op side-pat-var side-expr) + (compile-with-match ^(,op @nil ,side-pat-var ,side-expr) obj-var var-list)) + (x (compile-error *match-form* "bad syntax: ~s" exp)))) + +(defun compile-loop-match (exp obj-var var-list) + (mac-param-bind *match-form* (op match) exp + (let* ((no-vac-p (memq op '(coll usr:all*))) + (some-p (eq op 'some)) + (coll-p (eq op 'coll)) + (item-var (gensym "item-")) + (in-vars var-list.vars) + (cm (compile-match match item-var var-list)) + (loop-success-p-var (gensym "loop-success-p-")) + (loop-continue-p-var (gensym "loop-terminate-p")) + (loop-iterated-var (if no-vac-p (gensym "loop-iterated-p"))) + (matched-p-var (gensym "matched-p-")) + (iter-var (gensym "iter-")) + (cm-vars cm.(get-vars)) + (collect-vars (diff cm-vars in-vars)) + (collect-gens [mapcar gensym collect-vars]) + (loop ^(for ((,iter-var (iter-begin ,obj-var)) + (,loop-continue-p-var t) + ,*(if no-vac-p ^((,loop-iterated-var nil)))) + ((and ,loop-continue-p-var (iter-more ,iter-var)) + ,(cond + (some-p ^(not ,loop-continue-p-var)) + (no-vac-p ^(and ,loop-iterated-var + ,loop-continue-p-var)) + (t loop-continue-p-var))) + ((set ,iter-var (iter-step ,iter-var))) + (let ((,cm.obj-var (iter-item ,iter-var)) + ,matched-p-var + ,*(unless some-p cm-vars)) + ,cm.(wrap-guards + ^(progn + (set ,matched-p-var t) + ,*(if no-vac-p + ^((set ,loop-iterated-var t))) + ,*(unless some-p + (mapcar (ret ^(push ,@1 ,@2)) + collect-vars + collect-gens)))) + ,(unless coll-p ^(,(if some-p 'when 'unless) + ,matched-p-var + (set ,loop-continue-p-var nil)))))) + (guard0 (new match-guard + vars cm-vars + temps (unless some-p collect-gens) + guard-expr ^(seqp ,obj-var))) + (guard1 (new match-guard + vars (list loop-success-p-var) + var-exprs (list loop) + test-expr (if some-p + loop-success-p-var + ^(when ,loop-success-p-var + ,*(mapcar (ret ^(set ,@1 (nreverse ,@2))) + collect-vars collect-gens) + t))))) + (new compiled-match + pattern exp + obj-var obj-var + guard-chain (list guard0 guard1))))) + +(defun compile-or-match (par-pat obj-var var-list) + (mac-param-bind *match-form* (op . pats) par-pat + (let* ((var-lists (mapcar (ret (copy var-list)) pats)) + (par-matches (mapcar (op compile-match @1 obj-var @2) + pats var-lists)) + (dj-guard (new guard-disjunction + guard-chains (mapcar .guard-chain par-matches) + sub-patterns par-matches))) + (each ((vl var-lists)) + var-list.(merge vl)) + (new compiled-match + pattern par-pat + obj-var obj-var + guard-chain (list dj-guard))))) + +(defun compile-and-match (and-pat obj-var var-list) + (mac-param-bind *match-form* (op . pats) and-pat + (let* ((par-matches (mapcar (lop compile-match obj-var var-list) pats))) + (new compiled-match + pattern and-pat + obj-var obj-var + guard-chain (mappend .guard-chain par-matches))))) + +(defun compile-not-match (pattern obj-var var-list) + (mac-param-bind *match-form* (op pattern) pattern + (let* ((pm (compile-match pattern obj-var var-list)) + (guard (new match-guard + guard-expr ^(not (let ,pm.(get-vars) + ,pm.(wrap-guards t)))))) + (new compiled-match + pattern pattern + obj-var obj-var + guard-chain (list guard))))) + +(defun compile-hash-match (hash-expr obj-var var-list) + (mac-param-bind *match-form* (op . pairs) hash-expr + (let* ((hash-alist-var (gensym "hash-alist-")) + (hash-alt-val ^',(gensym "alt")) + (need-alist-p nil) + (hash-keys-var (gensym "hash-keys-")) + (need-keys-p nil) + (hash-matches + (collect-each ((pair pairs)) + (mac-param-bind *match-form* (key : (val nil val-p)) pair + (let ((key-pat-p (non-triv-pat-p key)) + (val-pat-p (non-triv-pat-p val)) + (key-var-sym (var-pat-p key))) + (cond + ((and (not val-p) key-var-sym var-list.(exists key-var-sym)) + (let ((guard (new match-guard + test-expr ^(inhash ,obj-var + ,key-var-sym)))) + (new compiled-match + guard-chain (list guard)))) + ((and (not val-p) (not key-pat-p)) + (let ((guard (new match-guard + test-expr ^(inhash ,obj-var + ',key)))) + (new compiled-match + guard-chain (list guard)))) + ((not val-p) + (set need-keys-p t) + (compile-match key hash-keys-var var-list)) + ((and key-var-sym var-list.(exists key-var-sym)) + (let ((vm (compile-match val (gensym "val") var-list))) + vm.(add-guards-pre + (new match-guard + vars (list vm.obj-var) + var-exprs ^((gethash ,obj-var ,key-var-sym + ,hash-alt-val)) + test-expr ^(neq ,vm.obj-var + ,hash-alt-val))) + vm)) + ((and key-pat-p val-pat-p) + (set need-alist-p t) + (compile-match ^@(coll (,key . ,val)) + hash-alist-var var-list)) + (key-pat-p + (let ((km (compile-match key (gensym "keys") + var-list))) + km.(add-guards-pre + (new match-guard + pure-temps (list km.obj-var) + pure-temp-exprs ^((hash-keys-of ,obj-var + ',val)))) + km)) + (t + (let ((vm (compile-match val (gensym "val") var-list))) + vm.(add-guards-pre + (new match-guard + pure-temps (list vm.obj-var) + pure-temp-exprs ^((gethash ,obj-var ',key + ,hash-alt-val)) + test-expr ^(neq ,vm.obj-var ,hash-alt-val))) + vm))))))) + (guard (new match-guard + guard-expr ^(hashp ,obj-var) + vars (append + (if need-alist-p + (list hash-alist-var)) + (if need-keys-p + (list hash-keys-var))) + var-exprs (append + (if need-alist-p + (list ^(hash-alist ,obj-var))) + (if need-keys-p + (list ^(hash-keys ,obj-var))))))) + (new compiled-match + pattern hash-expr + obj-var obj-var + guard-chain (cons guard (mappend .guard-chain hash-matches)))))) + +(defun compile-scan-match (scan-syntax obj-var var-list) + (mac-param-bind *match-form* (op pattern) scan-syntax + (with-gensyms (iter found-p cont-p success-p) + (let* ((cm (compile-match pattern iter var-list)) + (loop ^(for ((,iter ,obj-var) (,cont-p t) ,found-p) + (,cont-p ,found-p) + ((cond + ((null ,cont-p)) + ((consp ,iter) (set ,iter (cdr ,iter))) + (t (zap ,cont-p)))) + ,cm.(wrap-guards ^(set ,found-p t ,cont-p nil)))) + (guard (new match-guard + vars (cons success-p cm.(get-vars)) + var-exprs (list loop) + test-expr success-p))) + (new compiled-match + pattern scan-syntax + obj-var obj-var + guard-chain (list guard)))))) + +(defun compile-exprs-match (exprs-syntax uexprs var-list) + (let ((upats (cdr exprs-syntax)) + (utemps (mapcar (ret (gensym)) uexprs))) + (tree-bind (pats temps exprs) (multi-sort (list upats utemps uexprs) + [list less] + [list non-triv-pat-p]) + (let* ((matches (mapcar (op compile-match @1 @2 var-list) + pats temps))) + (new compiled-match + pattern exprs-syntax + obj-var nil + guard-chain (cons (new match-guard + pure-temps utemps + pure-temp-exprs uexprs) + (mappend .guard-chain matches))))))) + +(defun compile-match (pat : (obj-var (gensym)) (var-list (new var-list))) + (cond + ((consp pat) + (caseq (car pat) + (sys:expr + (let ((exp (cadr pat))) + (if (consp exp) + (let ((op (car exp))) + (caseq op + (struct (compile-struct-match exp obj-var var-list)) + (require (compile-require-match exp obj-var var-list)) + (usr:as (compile-as-match exp obj-var var-list)) + (usr:with (compile-with-match exp obj-var var-list)) + (all (compile-loop-match exp obj-var var-list)) + (usr:all* (compile-loop-match exp obj-var var-list)) + (some (compile-loop-match exp obj-var var-list)) + (coll (compile-loop-match exp obj-var var-list)) + (or (compile-or-match exp obj-var var-list)) + (and (compile-and-match exp obj-var var-list)) + (not (compile-not-match exp obj-var var-list)) + (hash (compile-hash-match exp obj-var var-list)) + (usr:scan (compile-scan-match exp obj-var var-list)) + (exprs (compile-exprs-match exp obj-var var-list)) + (t (iflet ((xfun [*match-macro* op])) + (let* ((var-env (make-env (mapcar (lop cons + 'sys:special) + var-list.vars) + nil var-list.menv)) + (xexp [xfun exp var-env])) + (if (neq xexp exp) + (compile-match xexp obj-var var-list) + (compile-predicate-match exp obj-var var-list))) + (compile-predicate-match exp obj-var var-list))))) + (compile-error *match-form* + "unrecognized pattern syntax ~s" pat)))) + (sys:var (compile-var-match (cadr pat) obj-var var-list)) + (sys:quasi (compile-match (expand-quasi-match (cdr pat) var-list) + obj-var var-list)) + (sys:qquote (compile-match (transform-qquote (cadr pat)) + obj-var var-list)) + (t (if (non-triv-pat-p pat) + (compile-cons-structure pat obj-var var-list) + (compile-atom-match pat obj-var var-list))))) + (t (compile-atom-match pat obj-var var-list)))) + +(defun get-var-list (env) + (new var-list menv env)) + +(defmacro when-match (:form *match-form* :env e pat obj . body) + (let ((cm (compile-match pat : (get-var-list e)))) + ^(alet ((,cm.obj-var ,obj)) + (let ,cm.(get-vars) + ,cm.(wrap-guards . body))))) + +(defmacro if-match (:form *match-form* :env e pat obj then : else) + (let ((cm (compile-match pat : (get-var-list e))) + (result (gensym "result-"))) + ^(alet ((,cm.obj-var ,obj)) + (let* (,result ,*cm.(get-vars)) + (if ,cm.(wrap-guards + ^(set ,result ,then) + t) + ,result + ,else))))) + +(defmacro while-match (:form *match-form* :env e pat obj . body) + (let ((cm (compile-match pat : (get-var-list e)))) + ^(for () + ((alet ((,cm.obj-var ,obj)) + (let ,cm.(get-vars) + ,cm.(wrap-guards ^(progn ,*body t))))) + ()))) + +(defmacro match-case (:form *match-form* :env e obj . clauses) + (unless [all clauses [andf proper-listp [chain len plusp]]] + (compile-error *match-form* "bad clause syntax")) + (let* ((matched-p-temp (gensym "matched-p-")) + (result-temp (gensym "result-")) + (objvar (gensym "obj-")) + (var-list (get-var-list e)) + (clause-matches [mapcar (op compile-match (car @1) + objvar (copy var-list)) + clauses]) + (nclauses (len clauses)) + (clause-code (collect-each ((cl clauses) + (cm clause-matches)) + (mac-param-bind *match-form* (match . forms) cl + ^(let (,*cm.(get-vars)) + ,cm.(wrap-guards ^(set ,result-temp + (progn ,*forms)) + t)))))) + ^(alet ((,objvar ,obj)) + (let (,result-temp) + (or ,*clause-code) + ,result-temp)))) + +(defmacro while-match-case (:form *match-form* :env e obj . clauses) + (unless [all clauses [andf proper-listp [chain len plusp]]] + (compile-error *match-form* "bad clause syntax")) + ^(for () + ((match-case ,obj + ,*(mapcar (ret ^(,(car @1) ,*(cdr @1) t)) clauses))) + ())) + +(defmacro while-true-match-case (:form *match-form* :env e obj . clauses) + (unless [all clauses [andf proper-listp [chain len plusp]]] + (compile-error *match-form* "bad clause syntax")) + ^(for () + ((match-case ,obj + (nil) + ,*(mapcar (ret ^(,(car @1) ,*(cdr @1) t)) clauses))) + ())) + +(defmacro when-exprs-match (:form *match-form* :env e pats exprs . forms) + (let ((em (compile-match ^@(exprs ,*pats) exprs (get-var-list e)))) + ^(let* (,*em.(get-vars)) + ,em.(wrap-guards . forms)))) + +(defstruct lambda-clause () + orig-syntax + fixed-patterns + variadic-pattern + nfixed + forms + + (:postinit (me) + (set me.nfixed (len me.fixed-patterns)))) + +(defun parse-lambda-match-clause (clause) + (mac-param-bind *match-form* (args . body) clause + (cond + ((atom args) (new lambda-clause + orig-syntax args + variadic-pattern args + forms body)) + ((proper-list-p args) + (let* ((vpos (pos-if (lop meq 'sys:expr 'sys:var 'sys:quasi) args))) + (tree-bind (fixed-pats . variadic-pat) (split args vpos) + (new lambda-clause + orig-syntax args + fixed-patterns fixed-pats + variadic-pattern (car variadic-pat) + forms body)))) + (t (new lambda-clause + orig-syntax args + fixed-patterns (butlast args 0) + variadic-pattern (last args 0) + forms body))))) + +(defun expand-lambda-match (clauses) + (let* ((parsed-clauses [mapcar parse-lambda-match-clause clauses]) + (max-args (or [find-max parsed-clauses : .nfixed].?nfixed 0)) + (min-args (or [find-min parsed-clauses : .nfixed].?nfixed 0)) + (variadic [some parsed-clauses .variadic-pattern]) + (fix-arg-temps (mapcar (op gensym `arg-@1`) + (range* 0 min-args))) + (opt-arg-temps (mapcar (op gensym `arg-@1`) + (range* min-args max-args))) + (rest-temp (if variadic (gensym `rest`))) + (present-p-temps (mapcar (op gensym `have-@1`) + (range* min-args max-args))) + (arg-temps (append fix-arg-temps opt-arg-temps)) + (present-vec (vec-list (append (repeat '(t) min-args) + present-p-temps))) + (result-temp (gensym "result")) + (nclauses (len parsed-clauses)) + (ex-clauses (collect-each ((pc parsed-clauses)) + (let* ((vp pc.variadic-pattern) + (exp ^(when-exprs-match + (,*pc.fixed-patterns + ,*(if vp (list vp))) + (,*[arg-temps 0..pc.nfixed] + ,*(if vp + ^((list* ,*[arg-temps pc.nfixed..:] + ,rest-temp)))) + (set ,result-temp (progn ,*pc.forms)) + t))) + (sys:set-macro-ancestor exp pc.orig-syntax) + (when (> pc.nfixed min-args) + (set exp ^(when ,[present-vec (pred pc.nfixed)] + ,exp))) + (when (< pc.nfixed max-args) + (set exp ^(unless ,[present-vec pc.nfixed] + ,exp))) + (when (and variadic (not vp) (= pc.nfixed max-args)) + (set exp ^(unless ,rest-temp + ,exp))) + exp)))) + ^(lambda (,*fix-arg-temps + ,*(if opt-arg-temps + (cons : (mapcar (ret ^(,@1 nil ,@2)) + opt-arg-temps present-p-temps))) + . ,rest-temp) + (let (,result-temp) + (or ,*ex-clauses) + ,result-temp)))) + +(defmacro lambda-match (:form *match-form* . clauses) + (expand-lambda-match clauses)) + +(defmacro defun-match (:form *match-form* name . clauses) + (tree-bind (lambda args . body) (expand-lambda-match clauses) + ^(defun ,name ,args . ,body))) + +(define-param-expander :match (params clauses menv form) + (let ((*match-form* form)) + (unless (proper-list-p params) + (compile-error form + "~s is incompatible with dotted parameter lists" + :match)) + (when (find : params) + (compile-error form + "~s is incompatible with optional parameters" + :match)) + (tree-bind (lambda lparams . body) (expand-lambda-match clauses) + (let ((dashdash (member '-- params))) + (cons (append (ldiff params dashdash) + (butlastn 0 lparams) + dashdash + (nthlast 0 lparams)) + body))))) + +(defmacro defmatch (name destructuring-args . body) + (with-gensyms (name-dummy args) + ^(progn + (sethash *match-macro* ',name + (lambda (,args vars-env) + (mac-env-param-bind *match-form* vars-env + (,name-dummy ,*destructuring-args) + ,args ,*body))) + ',name))) + +(defun check (f op pat) + (if (or (not (listp pat)) + (meq (car pat) 'sys:expr 'sys:var 'sys:quasi)) + (compile-error f "~s: list pattern expected, not ~s" op pat) + pat)) + +(defun check-end (f op pat) + (if (and (listp pat) + (meq (car pat) 'sys:expr 'sys:var 'sys:quasi)) + (compile-error f "~s: list or atom pattern expected, not ~s" op pat) + pat)) + +(defun check-sym (f op sym : nil-ok) + (cond + ((bindable sym) sym) + ((and (null sym) nil-ok) sym) + (t (compile-error f "~s: bindable symbol expected, not ~s" op sym)))) + +(defun loosen (f pat) + (if (proper-list-p pat) + (append pat '@nil) + pat)) + +(defun pat-len (f pat) + (if (consp pat) + (let ((var-op-pos (pos-if (op meq 'sys:var 'sys:expr 'sys:quasi) + (butlastn 0 pat)))) + (if var-op-pos var-op-pos (len pat))) + 0)) + +(defmatch sme (:form f sta mid end : (mvar (gensym)) eobj) + (let* ((psta (loosen f (check f 'sme sta))) + (pmid (loosen f (check f 'sme mid))) + (pend (check-end f 'sme end)) + (lsta (pat-len f psta)) + (lmid (pat-len f pmid)) + (lend (pat-len f pend)) + (obj (gensym))) + ^@(as ,(check-sym f 'sme obj) + @(and ,psta + @(with @(scan @(as ,(check-sym f 'sme mvar) ,pmid)) + (nthcdr ,lsta ,obj)) + @(with @(as ,(check-sym f 'sme eobj t) ,pend) + (nthlast ,lend (nthcdr ,lmid ,mvar))))))) + +(defmatch end (:form f end : evar) + (let* ((pend (check-end f 'end end)) + (lend (pat-len f pend)) + (obj (gensym))) + ^@(as ,(check-sym f 'end obj) + @(with @(as ,(check-sym f 'end evar t) ,pend) + (nthlast ,lend ,obj))))) + +(defun non-triv-pat-p (syntax) t) + +(defun non-triv-pat-p (syntax) + (match-case syntax + ((@(eq 'sys:expr) (@(bindable) . @nil)) t) + ((@(eq 'sys:var) @(or @(bindable) nil) . @nil) t) + ((@(eq 'sys:quasi) . @(some @(consp))) t) + ((@(eq 'sys:qquote) @nil) t) + ((@pat . @rest) (or (non-triv-pat-p pat) + (non-triv-pat-p rest))) + (#R(@from @to) (or (non-triv-pat-p from) + (non-triv-pat-p to))) + (@(some @(non-triv-pat-p)) t))) + +(defun var-pat-p (syntax) + (when-match (@(eq 'sys:var) @(bindable @sym) . @nil) syntax + sym)) + +(defun expand-quasi-match (args var-list) + (labels ((bound-p (vlist vars sym) + (cond + ((bindable sym) (or (member sym vars) vlist.(exists sym))) + ((null sym) nil) + ((compile-error *match-form* "bindable symbol expected, not ~s" + sym)))) + (normalize (args) + (mapcar (do if-match (@(eq 'sys:var) @sym nil) @1 + ^(sys:var ,sym) + @1) + args)) + (quasi-match (vlist args vars str pos) + (match-case args + ;; `text` + ((@(stringp @txt)) + (list ^@(require @nil (match-str ,str ,txt ,pos)))) + ;; `txt@...` + ((@(stringp @txt) . @rest) + (with-gensyms (npos) + (cons ^@(require @(with ,npos (+ ,pos (len ,txt))) + (match-str ,str ,txt ,pos)) + (quasi-match vlist rest vars str npos)))) + ;; `@var` (existing binding) + (((@(eq 'sys:var) @(bound-p vlist vars @sym) . @nil)) + (list ^@(require @nil (match-str ,str (sys:quasi ,(car args)) + ,pos)))) + ;; `@var@...` (existing binding) + ((@(as avar (@(eq 'sys:var) @(bound-p vlist vars @sym) . @nil)) + . @rest) + (with-gensyms (txt len npos) + (list* ^@(with ,txt (sys:quasi ,avar)) + ^@(with ,len (len ,txt)) + ^@(with ,npos (+ ,pos ,len)) + ^@(require @nil + (match-str ,str ,txt ,pos)) + (quasi-match vlist rest vars str npos)))) + ;; `@var` (new binding) + (((@(eq 'sys:var) @sym)) + (list ^@(with ,sym (sub-str ,str ,pos t)))) + ;; `@{var #/rx/}` (new binding) + (((@(eq 'sys:var) @sym (@(regexp @reg)))) + (list ^@(require @(with ,sym (sub-str ,str ,pos t)) + (m^$ ,reg ,sym)))) + ;; `@{var #/rx/}@...` (new binding) + (((@(eq 'sys:var) @sym (@(regexp @reg))) . @rest) + (with-gensyms (len npos) + (list* ^@(require @(with ,len (match-regex ,str ,reg ,pos)) + ,len) + ^@(with ,npos (+ ,pos ,len)) + ^@(with ,sym (sub-str ,str ,pos ,npos)) + (quasi-match vlist rest (cons sym vars) str npos)))) + ;; `@{var 123}` (new binding) + (((@(eq 'sys:var) @sym (@(integerp @len)))) + (unless (plusp len) + (compile-error *match-form* + "variable ~s: positive integer required,\ \ + not ~a" sym)) + (with-gensyms (npos) + (list ^@(require @(with ,npos (+ ,pos ,len)) + (eql ,npos (len ,str))) + ^@(with ,sym (sub-str ,str ,pos t))))) + ;; `@{var 123}@...`` (new binding) + (((@(eq 'sys:var) @sym (@(integerp @len))) . @rest) + (unless (plusp len) + (compile-error *match-form* + "variable ~s: positive integer required,\ \ + not ~a" sym)) + (with-gensyms (npos) + (list* ^@(require @(with ,npos (+ ,pos ,len)) + (<= ,npos (len ,str))) + ^@(with ,sym (sub-str ,str ,pos ,npos)) + (quasi-match vlist rest (cons sym vars) str npos)))) + ;; `@{var}txt` (new binding) + (((@(eq 'sys:var) @sym) @(stringp @txt)) + (with-gensyms (len end) + (list ^@(require @(with ,end (search-str ,str ,txt ,pos)) + ,end (eql (+ ,end ,(len txt)) (len ,str))) + ^@(with ,sym (sub-str ,str ,pos ,end))))) + ;; `@{var}txt...` (new binding) + (((@(eq 'sys:var) @sym) @(stringp @txt) . @rest) + (with-gensyms (len end npos) + (list* ^@(require @(with ,end (search-str ,str ,txt ,pos)) + ,end) + ^@(with ,npos (+ ,end ,(len txt))) + ^@(with ,sym (sub-str ,str ,pos ,end)) + (quasi-match vlist rest (cons sym vars) str npos)))) + ;; `@var0@var1` (unbound followed by bound) + (((@(eq 'sys:var) @sym) + @(as bvar (@(eq 'sys:var) @(bound-p vlist vars @bsym) . @mods))) + (with-gensyms (txt end) + (list ^@(with ,txt (sys:quasi ,bvar)) + ^@(require @(with ,end (search-str ,str ,txt ,pos)) + ,end (eql (+ , end (len ,txt)) (len ,str))) + ^@(with ,sym (sub-str ,str ,pos ,end))))) + ;; `@var0@var1...` (unbound followed by bound) + (((@(eq 'sys:var) @sym) + @(as bvar (@(eq 'sys:var) @(bound-p vlist vars @bsym) . @mods)) + . @rest) + (with-gensyms (txt end npos) + (list* ^@(with ,txt (sys:quasi ,bvar)) + ^@(require @(with ,end (search-str ,str ,txt ,pos)) + ,end) + ^@(with ,npos (+ ,end (len ,txt))) + ^@(with ,sym (sub-str ,str ,pos ,end)) + (quasi-match vlist rest (cons sym vars) str npos)))) + ;; `@{var whatever}@...`(new binding, unsupported modifiers) + (((@(eq 'sys:var) @sym @mods . @nil) . @rest) + (compile-error *match-form* + "variable ~s: unsupported modifiers ~s" + sym mods)) + + ;; `@var0@var1` (unbound followed by unbound) + (((@(eq 'sys:var) @sym0) + (@(eq 'sys:var) @sym1 . @mods) + . @rest) + (compile-error *match-form* + "consecutive unbound variables ~s and ~s" + sym0 sym1)) + ((@bad . @rest) (compile-error *match-form* + "unsupported syntax ~s" + ^(sys:quasi ,bad))) + (@else (compile-error *match-form* "bad quasiliteral syntax"))))) + + (with-gensyms (str pos) + ^@(and @(require (sys:var ,str) + (stringp ,str)) + @(with ,pos 0) + ,*(quasi-match var-list (normalize args) nil str pos))))) + +(defun transform-qquote (syn) + (match-case syn + ((sys:hash-lit nil . @(coll (@key @val))) + ^@(hash ,*(zip [mapcar transform-qquote key] + [mapcar transform-qquote val]))) + ((sys:struct-lit @type . @args) + ^@(struct ,(transform-qquote type) + ,*[mapcar transform-qquote args])) + ((sys:vector-lit @elems) + ^#(,*[mapcar transform-qquote elems])) + ((json quote @arg) (transform-qquote arg)) + ((sys:unquote @pat) (if (symbolp pat) + ^(sys:var ,pat) + ^(sys:expr ,pat))) + ((sys:hash-lit @(have) . @nil) + (compile-error *match-form* + "only equal hash tables supported")) + ((@(or sys:qquote) . @nil) + (compile-error *match-form* + "pattern-matching quasiquote doesn't support nesting")) + ((sys:splice . @nil) + (compile-error *match-form* + "pattern-matching quasiquote doesn't support splicing")) + ((@ca . @cd) (cons (transform-qquote ca) + (transform-qquote cd))) + (@else else))) + +(defun each-match-expander (f pat-seq-list body fun) + (unless (and (proper-list-p pat-seq-list) + (evenp (len pat-seq-list))) + (compile-error f "pattern-sequence arguments must form pairs")) + (let ((pat-seq-pairs (tuples 2 pat-seq-list))) + (each ((pair pat-seq-pairs)) + (unless (and (proper-list-p pair) + (eql 2 (length pair))) + (compile-error f "invalid pattern-sequence pair ~s" pair))) + (let* ((pats [mapcar car pat-seq-pairs]) + (seqs [mapcar cadr pat-seq-pairs])) + ^(,fun (lambda-match ((,*pats) (progn ,*body))) ,*seqs)))) + +(defmacro each-match (:form f pat-seq-pairs . body) + (each-match-expander f pat-seq-pairs body 'mapdo)) + +(defmacro append-matches (:form f pat-seq-pairs . body) + (each-match-expander f pat-seq-pairs body 'mappend)) + +(defmacro keep-matches (:form f pat-seq-pairs . body) + (each-match-expander f pat-seq-pairs ^((list (progn ,*body))) 'mappend)) + +(defmacro each-match-product (:form f pat-seq-pairs . body) + (each-match-expander f pat-seq-pairs body 'maprodo)) + +(defmacro append-match-products (:form f pat-seq-pairs . body) + (each-match-expander f pat-seq-pairs body 'maprend)) + +(defmacro keep-match-products (:form f pat-seq-pairs . body) + (each-match-expander f pat-seq-pairs ^((list (progn ,*body))) 'maprend)) diff --git a/stdlib/op.tl b/stdlib/op.tl new file mode 100644 index 00000000..182055f0 --- /dev/null +++ b/stdlib/op.tl @@ -0,0 +1,203 @@ +;; Copyright 2017-2021 +;; Kaz Kylheku <kaz@kylheku.com> +;; Vancouver, Canada +;; 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 HOLDER 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. + +(defvar sys:*op-ctx*) + +(sys:make-struct-type + 'sys:op-ctx nil nil '(form gens up meta rec recvar) nil + (lambda (me) + (slotset me 'up sys:*op-ctx*) + (slotset me 'meta (gensym "meta-"))) + nil nil) + +(defun sys:ensure-op-arg (ctx n) + (let ((ag (slot ctx 'gens))) + (when (> n 1024) + ['compile-error (slot ctx 'form) + "@~a calls for function with too many arguments" n]) + (for ((i (len ag)) (l)) + ((<= i n) + (sys:setq ag (append ag (nreverse l))) + (slotset ctx 'gens ag) + [ag n]) + ((sys:setq i (succ i))) + (sys:setq l (cons (gensym `arg-@(if (plusp i) i "rest")-`) l))))) + +(defun sys:op-meta-p (expr) + (tree-case expr + ((x y . r) (and (null r) + (cond + ((eq x 'sys:expr) (sys:op-meta-p y)) + ((eq x 'sys:var) (or (integerp y) + (eq y 'rest)))))))) + +(defun sys:op-rec-p (expr) + (tree-case expr + ((x (y . r)) (and (eq x 'sys:expr) (eq y 'usr:rec))))) + +(defun sys:op-ensure-rec (ctx : recvar) + (when recvar + (slotset ctx 'recvar t)) + (or (slot ctx 'rec) (slotset ctx 'rec (gensym "rec-")))) + +(defun sys:op-alpha-rename (f e op-args do-nested-metas) + (let* ((ctx sys:*op-ctx*) + (code ^(macrolet ((sys:expr (:form f arg) + (let ((ctx ,ctx)) + (cond + ((and (slot ctx 'up) + (or (sys:op-meta-p arg) + (sys:op-rec-p arg) + (equal arg '(sys:var usr:rec)))) + ^(,(slot (slot ctx 'up) 'meta) (quote ,arg))) + ((sys:op-rec-p f) + ^(,(sys:op-ensure-rec ctx) ,*(rest arg))) + (t f)))) + (sys:var (:form f arg . mods) + (cond + ((sys:op-meta-p f) + (unless (integerp arg) + (sys:setq arg 0)) + (sys:ensure-op-arg ,ctx arg)) + ((equal f '(sys:var usr:rec)) + (sys:op-ensure-rec ,ctx t)) + (t f))) + ,*(if do-nested-metas + ^((,(slot ctx 'meta) ((quote arg)) arg)))) + ,op-args))) + (expand code e))) + +(eval-only + (defmacro op-ignerr (x) + ^(sys:catch (error) ,x () (error (. args))))) + +(defun sys:op-expand (f e args) + (unless args + ['compile-error f "arguments required"]) + (let* ((compat (and (plusp sys:compat) (<= sys:compat 225))) + (ctx (make-struct 'sys:op-ctx ^(form ,f))) + (do-gen) + (sys:*op-ctx* ctx) + (sym (car f)) + (syntax-0 (if (eq sym 'do) args ^[,*args])) + (syntax-1 (if (or (null syntax-0) (neq sym 'do) compat) + (sys:op-alpha-rename f e syntax-0 nil) + (or (op-ignerr (sys:op-alpha-rename f e syntax-0 nil)) + (let ((syn (sys:op-alpha-rename + f e (append syntax-0 + (list (sys:setq do-gen + (gensym)))) + nil))) + (when (slot ctx 'gens) + (sys:op-alpha-rename f e syntax-0 nil)) + syn)))) + (syntax-2 (sys:op-alpha-rename f e syntax-1 t)) + (metas (slot ctx 'gens)) + (rec (slot ctx 'rec)) + (recvar (slot ctx 'recvar)) + (rest-sym (sys:ensure-op-arg ctx 0)) + (lambda-interior (let ((fargs (tree-case syntax-2 + ((a b . fa) fa)))) + (cond + ((and (eq sym 'lop) fargs) + (let ((fargs-l1 (mapcar (lambda (farg) + ^(sys:l1-val ,farg)) + fargs))) + ;; no cadr here to avoid circular autoload + ^[sys:apply ,(car (cdr syntax-2)) + (append ,rest-sym (list ,*fargs-l1))])) + (metas syntax-2) + ((eq sym 'do) + (cond + (compat syntax-2) + (do-gen + (let ((arg1 (sys:ensure-op-arg ctx 1))) + ^(symacrolet ((,do-gen ,arg1)) + ,syntax-2))) + (t (let ((arg1 (sys:ensure-op-arg ctx 1))) + (append syntax-2 (list arg1)))))) + (t (append syntax-2 rest-sym)))))) + (let ((metas (slot ctx 'gens))) + (cond + (recvar ^(sys:lbind ((,rec (lambda (,*(cdr metas) . ,rest-sym) + (let ((,rec (fun ,rec))) + ,lambda-interior)))) + (fun ,rec))) + (rec ^(sys:lbind ((,rec (lambda (,*(cdr metas) . ,rest-sym) + ,lambda-interior))) + (fun ,rec))) + (t ^(lambda (,*(cdr metas) . ,rest-sym) + ,lambda-interior)))))) + +(defmacro op (:form f :env e . args) + (sys:op-expand f e args)) + +(defmacro do (:form f :env e . args) + (sys:op-expand f e args)) + +(defmacro lop (:form f :env e . args) + (sys:op-expand f e args)) + +(defmacro ldo (op . args) + ^(do ,op @1 ,*args)) + +(defmacro ap (. args) + ^(apf (op ,*args))) + +(defmacro ip (. args) + ^(ipf (op ,*args))) + +(defmacro ado (. args) + ^(apf (do ,*args))) + +(defmacro ido (. args) + ^(ipf (do ,*args))) + +(defmacro ret (. args) + ^(op identity (progn @rest ,*args))) + +(defmacro aret (. args) + ^(ap identity (progn @rest ,*args))) + +(defun sys:opip-expand (e clauses) + (collect-each ((c clauses)) + (if (atom c) + c + (let ((sym (car c))) + (if (member sym '(dwim uref qref)) + c + (let ((opdo (if (or (special-operator-p (car c)) + (macro-form-p c e)) 'do 'op))) + ^(,opdo ,*c))))))) + +(defmacro opip (:env e . clauses) + ^[chain ,*(sys:opip-expand e clauses)]) + +(defmacro oand (:env e . clauses) + ^[chand ,*(sys:opip-expand e clauses)]) + +(defmacro flow (val . opip-args) + ^(call (opip ,*opip-args) ,val)) diff --git a/stdlib/optimize.tl b/stdlib/optimize.tl new file mode 100644 index 00000000..b011c568 --- /dev/null +++ b/stdlib/optimize.tl @@ -0,0 +1,606 @@ +;; Copyright 2021 +;; Kaz Kylheku <kaz@kylheku.com> +;; Vancouver, Canada +;; 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 HOLDER 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. + +(compile-only + (defstruct live-info nil + (defined 0) + (used 0) + def) + + (defstruct basic-block (live-info) + live + label + next + links + rlinks + insns + + (:method print (bl stream pretty-p) + (put-string "#S" stream) + (print ^(basic-block live ,bl.live + label ,bl.label + insns ,bl.insns + links ,(mapcar .label bl.links) + rlinks ,(mapcar .label bl.rlinks) + next ,bl.next) stream))) + + (defstruct (basic-blocks insns lt-dregs symvec) nil + insns + lt-dregs + symvec + root + (hash (hash)) + (li-hash (hash :eq-based)) + list + rescan + recalc + reelim + (:static start (gensym "start-")) + (:static jump-ops '(jmp if ifq ifql close swtch ret abscsr + uwprot catch block jend)) + + (:postinit (bb) + (let* ((insns (early-peephole (dedup-labels (cons bb.start bb.insns)))) + (cuts (merge [where symbolp insns] + [where [andf consp + (op memq (car @1) bb.jump-ops)] + (cons nil insns)])) + (parts (partition insns cuts)) + (lparts (mapcar [iff [chain car symbolp] + use + (op cons (gensym))] + parts))) + (set bb.list (mapcar (do new basic-block + insns @1 label (car @1)) + lparts)) + (mapdo (do set [bb.hash @1.label] @1) bb.list)) + bb.(link-graph)) + + (:method get-insns (bb) + [mappend .insns bb.list]) + + (:method cut-block (bb bl at insns) + (let* ((nlabel (gensym "nl")) + (ltail (cdr (memq bl bb.list))) + (nbl (new basic-block + label nlabel + insns (cons nlabel at)))) + (set bb.list (append (ldiff bb.list ltail) (list nbl) ltail)) + (set bl.insns (ldiff insns at)) + (set [bb.hash nlabel] nbl) + (pushnew bl bb.rescan) + (pushnew nbl bb.rescan) + nbl)) + + (:method next-block (bb bl) + (let ((ltail (memq bl bb.list))) + (iflet ((next (cdr ltail))) + (car next)))) + + (:method join-block (bb bl nxbl) + (when (eql (car nxbl.insns) nxbl.label) + (pop nxbl.insns)) + (set bl.insns (append bl.insns nxbl.insns)) + (set bl.next nxbl.next) + (set bl.links nxbl.links) + (set bb.list (remq nxbl bb.list)) + (del [bb.hash nxbl.label]) + (each ((nx bl.links)) + (upd nx.rlinks (remq nxbl)) + (pushnew bl nx.rlinks))))) + +(defmacro rewrite-case (sym list . cases) + ^(rewrite (lambda (,sym) + (match-case ,sym + ,*cases)) + ,list)) + +(defmeth basic-blocks link-graph (bb) + (set bb.root (car bb.list)) + (each ((bl bb.list)) + (let* ((code bl.insns) + (tail (last code)) + (linsn (car tail)) + (link-next t) + (nxbl (cadr (memq bl bb.list)))) + (set bl.next nxbl) + (match-case linsn + ((jmp @jlabel) + (set bl.links (list [bb.hash jlabel]) + bl.next nil)) + ((if @nil @jlabel) + (set bl.links (list [bb.hash jlabel]))) + ((@(or ifq ifql) @nil @nil @jlabel) + (set bl.links (list [bb.hash jlabel]))) + ((close @nil @nil @nil @jlabel . @nil) + (set bl.links (list [bb.hash jlabel]) + link-next nil)) + ((swtch @nil . @jlabels) + (set bl.links [mapcar bb.hash (uniq jlabels)] + bl.next nil)) + ((catch @nil @nil @nil @nil @hlabel) + (set bl.links (list [bb.hash hlabel]))) + ((block @nil @nil @slabel) + (set bl.links (list [bb.hash slabel]))) + ((uwprot @clabel) + (set bl.links (list [bb.hash clabel]))) + ((@(or abscsr ret jend) . @nil) + (set bl.next nil))) + (if (and bl.next link-next) + (pushnew bl.next bl.links)) + (each ((nxbl bl.links)) + (pushnew bl nxbl.rlinks))))) + +(defmeth basic-blocks local-liveness (bb bl) + (set bl.live nil) + (labels ((regnum (reg) + (when-match (t @num) reg num)) + (regnums (regs) + (mappend (do when-match + (t @num) @1 (list num)) regs)) + (def (li insn def) + (set li (copy li) + li.def def + [bb.li-hash insn] li) + (let* ((dn (regnum def)) + (dmask (if dn (mask dn)))) + (cond + (dn (new live-info + used (logand li.used (lognot dmask)) + defined (logior li.defined dmask))) + (t (set [bb.li-hash insn] li))))) + (refs (li insn . refs) + (set [bb.li-hash insn] li) + (let* ((rn (regnums refs)) + (rmask (mask . rn))) + (new live-info + used (logior li.used rmask) + defined (logand li.defined (lognot rmask))))) + (def-ref (li insn def . refs) + (set li (copy li) + li.def def + [bb.li-hash insn] li) + (let* ((rn (regnums refs)) + (dn (regnum def)) + (dmask (if dn (mask dn))) + (rmask (mask . rn))) + (cond + (dn (new live-info + used (logior (logand li.used (lognot dmask)) rmask) + defined (logior (logand li.defined (lognot rmask)) dmask))) + (t (set [bb.li-hash insn] li) + (new live-info + used (logior li.used rmask) + defined (logand li.defined (lognot rmask))))))) + (liveness (insns) + (if (null insns) + (new live-info used 0) + (let* ((li (liveness (cdr insns))) + (insn (car insns))) + (match-case insn + ((@(or end jend prof) @reg) + (refs li insn reg)) + ((@(or apply call) @def . @refs) + (def-ref li insn def . refs)) + ((@(or gapply gcall) @def @fidx . @refs) + (def-ref li insn def . refs)) + ((mov @def @ref) + (def-ref li insn def ref)) + ((if @reg . @nil) + (refs li insn reg)) + ((@(or ifq ifql) @reg @creg . @nil) + (refs li insn reg creg)) + ((swtch @reg . @nil) + (refs li insn reg)) + ((block @reg @nreg . @nil) + (refs li insn reg nreg)) + ((@(or ret abscsr) @nreg @reg) + (refs li insn reg nreg)) + ((catch @esreg @eareg @syreg @descreg . @nil) + (refs li insn esreg eareg syreg descreg)) + ((handle @funreg @syreg) + (refs li insn funreg syreg)) + ((@(or getv getvb getfb getl1b getlx getf) @def . @nil) + (def li insn def)) + ((@(or setv setl1 setlx bindv) @reg . @nil) + (refs li insn reg)) + ((close @reg . @nil) + (def li insn reg)) + ((@op . @nil) + (caseq op + ((end jend prof or apply call or gapply gcall mov if + ifq ifql swtch block ret abscsr catch handle getv + getvb getfb getl1b getlx getf setl1 setlx bindv close) + (error `wrongly handled @insn instruction`)) + (t (set [bb.li-hash insn] li)))) + (@else (set [bb.li-hash insn] li))))))) + (let ((li (liveness bl.insns))) + (set bl.used li.used + bl.defined li.defined)))) + +(defmeth basic-blocks calc-liveness (bb : (blist bb.list)) + (each ((bl blist)) + bb.(local-liveness bl)) + (let (changed) + (while* changed + (let ((visited (hash :eq-based))) + (labels ((upd-used (bl insns live) + (tree-case insns + ((fi . re) + (let* ((live (upd-used bl re live)) + (lif [bb.li-hash fi])) + (set live (logand live (lognot lif.defined))) + (set lif.used (logior live lif.used)) + live)) + (else live))) + (visit (bl) + (unless [visited bl] + (set [visited bl] t) + (when bl.next + (visit bl.next)) + (let ((used 0) + (old-live (or bl.live 0))) + (each ((nx bl.links)) + (visit nx) + (set used (logior used nx.used))) + (when (neql (set bl.live (logior used old-live)) + old-live) + (let ((live-in (logand (upd-used bl bl.insns bl.live) + (lognot bl.defined)))) + (set bl.used (logior live-in bl.used))) + (set changed t)))))) + (set changed nil) + (visit bb.root)))))) + +(defmeth basic-blocks thread-jumps-block (bb code) + (let* ((tail (last code)) + (oinsn (car tail)) + (insn oinsn) + (ninsn oinsn)) + (while* (nequal ninsn insn) + (set insn ninsn + ninsn (match-case insn + (@(require (if @(as reg (d @dn)) @jlabel) + (not (memqual reg bb.lt-dregs))) + nil) + ((if (t 0) @jlabel) + ^(jmp ,jlabel)) + ((jmp @jlabel) + (let ((jinsns [bb.hash jlabel].insns)) + (match-case jinsns + ((@jlabel + (jmp @(and @jjlabel @(not @jlabel))) . @nil) + ^(jmp ,jjlabel)) + (@jelse insn)))) + ((if @reg @jlabel) + (let ((jinsns [bb.hash jlabel].insns)) + (match-case jinsns + ((@jlabel + (if @reg + @(and @jjlabel @(not @jlabel))) . @nil) + ^(if ,reg ,jjlabel)) + ((@jlabel + (jmp @(and @jjlabel @(not @jlabel))) . @nil) + ^(if ,reg ,jjlabel)) + ((@jlabel + (ifq @reg (t 0) @jjlabel) . @jrest) + (let ((xbl (if jrest + bb.(cut-block [bb.hash jlabel] jrest jinsns) + bb.(next-block [bb.hash jlabel])))) + (if xbl + ^(if ,reg ,xbl.label) + insn))) + (@jelse insn)))) + ((ifq @reg @creg @jlabel) + (let ((jinsns [bb.hash jlabel].insns)) + (match-case jinsns + ((@jlabel + (ifq @reg @creg + @(and @jjlabel @(not @jlabel))) . @nil) + ^(ifq ,reg ,creg ,jjlabel)) + ((@(require @jlabel (equal creg '(t 0))) + (if @reg + @(and @jjlabel @(not @jlabel))) . @jrest) + (let ((xbl (if jrest + bb.(cut-block [bb.hash jlabel] jrest jinsns) + bb.(next-block [bb.hash jlabel])))) + (if xbl + ^(ifq ,reg ,creg ,xbl.label) + insn))) + ((@jlabel + (jmp @(and @jjlabel @(not @jlabel))) . @nil) + ^(ifq ,reg ,creg ,jjlabel)) + (@jelse insn)))) + ((close @reg @frsize @ntregs @jlabel . @cargs) + (let ((jinsns [bb.hash jlabel].insns)) + (match-case jinsns + ((@jlabel + (jmp @(and @jjlabel @(not @jlabel))) . @nil) + ^(close ,reg ,frsize ,ntregs ,jjlabel ,*cargs)) + (@jelse insn)))) + (@else else)))) + (cond + ((null ninsn) (ldiff code tail)) + ((nequal ninsn oinsn) (append (ldiff code tail) (list ninsn))) + (t code)))) + +(defun subst (x y list) + (mapcar (lambda (item) + (if (equal item x) y item)) + list)) + +(defun subst-preserve (x y bb li list) + (let ((sub (subst x y list))) + (cond + ((equal sub list) list) + (t (set [bb.li-hash sub] li) sub)))) + +(defmeth basic-blocks peephole-block (bb bl code) + (labels ((dead-treg (insn n) + (let ((li [bb.li-hash insn])) + (and li (not (bit li.used n))))) + (only-locally-used-treg (insn n) + (let ((li [bb.li-hash insn])) + (and li (bit li.used n) (not (bit bl.live n)))))) + (rewrite-case insns code + ;; dead t-reg + (@(require ((@(or mov getlx getv getf getfb) (t @n) . @nil) . @nil) + (dead-treg (car insns) n)) + (pushnew bl bb.rescan) + (set bb.recalc t) + (cdr insns)) + (@(require ((close (t @n) @nil @nil @jlabel . @nil) . @nil) + (dead-treg (car insns) n)) + (pushnew bl bb.rescan) + (set bb.recalc t + bb.reelim t) + ^((jmp ,jlabel) ,*(cdr insns))) + (@(require ((@(or gcall gapply) (t @n) @idx . @nil) . @nil) + (dead-treg (car insns) n) + [%effect-free% [bb.symvec idx]]) + (pushnew bl bb.rescan) + (set bb.recalc t) + (cdr insns)) + ;; unnecessary copying t-reg + (@(require ((mov @(as dst (t @n)) @src) . @rest) + (only-locally-used-treg (car insns) n) + (or (neq (car src) 'v) + (none rest [andf [chain car (op eq 'end)] + [chain bb.li-hash .used (lop bit n)]])) + (not (find dst rest : [chain bb.li-hash .def])) + (not (find src rest : [chain bb.li-hash .def]))) + (pushnew bl bb.rescan) + (labels ((rename (insns n dst src) + (tree-case insns + ((fi . re) + (cons (subst-preserve dst src bb [bb.li-hash fi] fi) + (rename (cdr insns) n dst src))) + (else else)))) + (rename (cdr insns) n dst src))) + ;; wasteful moves + (((mov @reg0 @nil) (mov @reg0 @nil) . @nil) + (cdr insns)) + (((mov @reg0 @reg1) (mov reg1 @reg0) . @rest) + ^(,(car insns) ,*rest)) + ;; frame reduction + (((@(or frame dframe) @lev @size) + (@(or call gcall mov) + . @(require @(coll (v @vlev @nil)) + (none vlev (op eql (ppred lev))))) + . @rest) + ^(,(cadr insns) ,(car insns) ,*rest)) + (((@(or frame dframe) . @nil) + (if (t @reg) @jlabel)) + (let ((jinsns [bb.hash jlabel].insns)) + (match-case jinsns + ((@jlabel + (end (t @reg)) . @jrest) + (let* ((xbl (if jrest + bb.(cut-block [bb.hash jlabel] jrest jinsns) + bb.(next-block [bb.hash jlabel]))) + (ybl bb.(next-block bl)) + (yinsns ybl.insns)) + (cond + ((and xbl ybl) + (set ybl.insns ^(,ybl.label ,(car insns) ,*(cdr yinsns))) + (pushnew ybl bb.rescan) + ^((if (t ,reg) ,xbl.label))) + (t insns)))) + (@jelse insns)))) + (@(require ((if @(as reg (d @dn)) @jlabel) . @nil) + (not (memqual reg bb.lt-dregs))) + nil) + (@(require ((ifq @(as reg (d @dn)) (t 0) @jlabel) . @nil) + (not (memqual reg bb.lt-dregs))) + ^((jmp ,jlabel))) + (((jmp @jlabel) . @rest) + (let* ((jinsns (cdr [bb.hash jlabel].insns)) + (oinsns (match-case jinsns + (((jend @nil) . @nil) + ^(,(car jinsns) ,*rest)) + ((@nil (jend @nil) . @nil) + ^(,(car jinsns) ,(cadr jinsns) ,*rest)) + (@else insns)))) + (when (neq insns oinsns) + (pushnew bl bb.rescan) + (set bb.recalc t + bl.next nil + bl.links nil)) + oinsns)) + (@else insns)))) + +(defmeth basic-blocks peephole (bb) + (each ((bl bb.list)) + (set bl.insns bb.(peephole-block bl bl.insns))) + (whilet ((rescan bb.rescan)) + (set bb.rescan nil) + (when bb.recalc + bb.(calc-liveness rescan) + (set bb.recalc nil)) + (each ((bl rescan)) + (set bl.insns bb.(peephole-block bl bl.insns)))) + (when bb.reelim + bb.(elim-dead-code))) + +(defmeth basic-blocks thread-jumps (bb) + (each ((bl bb.list)) + (set bl.insns bb.(thread-jumps-block bl.insns)))) + +(defmeth basic-blocks elim-next-jump (bb bl) + (let* ((tail (last bl.insns)) + (linsn (car tail))) + (when-match (jmp @jlabel) linsn + (let ((nxbl bb.(next-block bl))) + (when (eql nxbl.?label jlabel) + (set bl.insns (butlast bl.insns))))))) + +(defmeth basic-blocks join-blocks (bb) + (labels ((joinbl (list) + (tree-case list + ((bl nxbl . rest) + (cond + ((and (eq bl.next nxbl) + (eq (car bl.links) nxbl) + (null (cdr bl.links)) + (null (cdr nxbl.rlinks))) + bb.(join-block bl nxbl) + (joinbl (cons bl rest))) + (t (cons bl (joinbl (cdr list)))))) + (else else)))) + (set bb.list (joinbl bb.list)))) + +(defmeth basic-blocks elim-dead-code (bb) + (each ((bl bb.list)) + (set bl.links nil) + (set bl.rlinks nil)) + bb.(link-graph) + (let* ((visited (hash :eq-based))) + (labels ((visit (bl) + (when (test-set [visited bl]) + (when bl.next + (visit bl.next)) + [mapcar visit bl.links]))) + (for ((bl bb.root)) (bl) ((set bl bl.next)) + (visit bl)) + (visit bb.root)) + (set bb.list [keep-if visited bb.list]) + (each ((bl bb.list)) + bb.(elim-next-jump bl))) + bb.(join-blocks)) + +(defmeth basic-blocks merge-jump-thunks (bb) + (let* ((candidates (mappend [andf [chain .links len (op eql 1)] + [chain .insns len (lop < 4)] + [chain .insns last car + [iff consp + [chain car (op eq 'jmp)]]] + list] + bb.list)) + (hash (group-by [chain .insns cdr] candidates))) + (dohash (insns bls hash) + (when (cdr bls) + (whenlet ((keep (or (keep-if (op some @1.rlinks (op eq @@1) .next) bls) + (list (car bls)))) + (leader (car keep))) + (whenlet ((dupes (diff bls keep))) + (each ((bl dupes)) + (each ((pbl bl.rlinks)) + (let* ((code pbl.insns) + (tail (last code)) + (lins (car tail)) + (sins (subst bl.label leader.label lins))) + (set pbl.insns (append (ldiff code tail) (list sins)))))) + (set bb.list (remove-if (lop memq dupes) bb.list)))))))) + +(defmeth basic-blocks late-peephole (bb code) + (rewrite-case insns code + (((if @reg @lab1) + @lab2 + (jmp @lab3) + @lab1 + . @rest) + (let* ((bl [bb.hash lab2])) + (if (some bl.rlinks (op eq bb) .next) + insns + ^((ifq ,reg (t 0) ,lab3) + ,lab1 + ,*rest)))) + (((mov (t @tn) (d @dn)) + (jmp @lab3) + @lab1 + (mov (t @tn) (t 0)) + (jmp @lab3) + @lab2 + (mov (t @tn) (t 0)) + @(symbolp @lab3) + (ifq (t @tn) (t 0) @lab4) + . @rest) + (let ((lab5 (gensym "nl"))) + ^((mov (t ,tn) (d ,dn)) + (jmp ,lab4) + ,lab1 + ,lab2 + (mov (t ,tn) (t 0)) + (jmp ,lab5) + ,lab3 + (ifq (t ,tn) (t 0) ,lab4) + ,lab5 + ,*rest))) + (@else else))) + +(defun rewrite (fun list) + (build + (while* list + (let ((nlist [fun list])) + (if (eq list nlist) + (if list (add (pop list))) + (set list nlist)))))) + +(defun dedup-labels (insns) + (rewrite-case tail insns + ((@(symbolp @label0) @(symbolp @label1) . @rest) + (set insns (mapcar [iffi listp (op subst label1 label0)] + (remq label1 insns))) + (cons label0 rest)) + (@else tail)) + insns) + +(defun early-peephole (code) + (rewrite-case insns code + (((mov (t @t1) (d @d1)) + (jmp @lab2) + @(symbolp @lab1) + (mov (t @t1) (t 0)) + @lab2 + (ifq (t @t1) (t 0) @lab3) + . @rest) + ^((mov (t ,t1) (d ,d1)) + (jmp ,lab3) + ,lab1 + (mov (t ,t1) (t 0)) + ,lab2 + ,*rest)) + (@else else))) diff --git a/stdlib/package.tl b/stdlib/package.tl new file mode 100644 index 00000000..63c13f5e --- /dev/null +++ b/stdlib/package.tl @@ -0,0 +1,91 @@ +;; Copyright 2016-2021 +;; Kaz Kylheku <kaz@kylheku.com> +;; Vancouver, Canada +;; 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 HOLDER 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. + +(defun sys:name-str (kind sym-or-string) + (cond + ((symbolp sym-or-string) (symbol-name sym-or-string)) + ((stringp sym-or-string) sym-or-string) + (t (throw 'eval-error "~s: ~s isn't a valid ~a name" + 'defpackage sym-or-string kind)))) + +(defmacro defpackage (name . clauses) + (let* ((pkg (gensym "pkg-")) + (nstr (sys:name-str 'package name)) + (exp-clauses (append-each ((c clauses)) + (tree-case c + ((keyword package . rest) + (caseql keyword + (:use-from + ^((let ((p (find-package ',package))) + (unless p + (throwf 'eval-error + "~s: no such package: ~s" + 'defpackage ',package)) + (each ((n ',(mapcar (op sys:name-str 'symbol) + rest))) + (let ((s (intern n p))) + (unless (eq (symbol-package s) p) + (throwf 'eval-error + "~s: won't use non-local ~s from ~s" + 'defpackage s p)) + (use-sym s ,pkg)))))) + (t :))) + ((keyword . rest) + (caseql keyword + (:use + (if rest ^((use-package ',rest ,pkg)))) + (:use-syms + ^((each ((s ',rest)) + (use-sym s ,pkg)))) + (:local + ^((each ((n ',(mapcar (op sys:name-str 'symbol) + rest))) + (let ((s (intern n ,pkg))) + (unless (eq (symbol-package s) ,pkg) + (unuse-sym s ,pkg) + (intern n ,pkg)))))) + (:fallback + (if rest ^((set-package-fallback-list ,pkg + ',rest)))) + (:use-from + (throwf 'eval-error + "~s: :use-from clause needs package argument" + 'defpackage)) + (t :))) + (atom + (throwf 'eval-error "~s: invalid clause: ~s" + 'defpackage atom)))))) + ^(let ((,pkg (or (find-package ,nstr) + (make-package ,nstr)))) + ,*exp-clauses + ,pkg))) + +(defmacro in-package (pkg) + (unless (or (symbolp pkg) (stringp pkg)) + (throwf 'eval-error "~s: ~s isn't a package name" 'in-package pkg)) + ^(set *package* (or (find-package ',pkg) + (throwf 'eval-error "~s: no such package: ~s" + 'in-package ',pkg)))) diff --git a/stdlib/param.tl b/stdlib/param.tl new file mode 100644 index 00000000..0551e9ce --- /dev/null +++ b/stdlib/param.tl @@ -0,0 +1,81 @@ +;; Copyright 2019-2021 +;; Kaz Kylheku <kaz@kylheku.com> +;; Vancouver, Canada +;; 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 HOLDER 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. + +(compile-only + (defstruct param-parser-base nil + syntax form + rest req opt key + nreq nopt nfix + + (:postinit (me) + (let* ((rest (nthlast 0 me.syntax)) + (fixed (ldiff me.syntax rest)) + nonkey key) + (cond + (me.mac-param-p + (while fixed + (let ((pp (pop fixed))) + (caseq pp + ((:env :whole :form) + (unless fixed + (compile-error me.form "~s requires argument" pp)) + (push (cons pp (pop fixed)) key)) + (t (push pp nonkey))))) + (set nonkey (nreverse nonkey) + key (nreverse key))) + (t (set nonkey fixed))) + (tree-bind (: rp opt) (split* nonkey (op where (op eq :))) + (set me.rest rest + me.req rp + me.opt (mapcar [iffi atom list] opt) + me.key key + me.nreq (len rp) + me.nopt (len opt) + me.nfix (+ me.nreq me.nopt))))) + + (:method opt-syms (me) + (build + (each ((o me.opt)) + (caseql (len o) + ((1 2) (add (car o))) + (3 (add (car o) (caddr o)))))))) + + (defstruct (fun-param-parser syntax form) param-parser-base + (mac-param-p nil)) + + (defstruct (mac-param-parser syntax form) param-parser-base + (mac-param-p t)) + + (defstruct (param-info fun) nil + fun + nreq nopt nfix rest + (:postinit (me) + (let* ((fix (fun-fixparam-count me.fun)) + (opt (fun-optparam-count me.fun))) + (set me.nreq (- fix opt) + me.nopt opt + me.nfix fix + me.rest (fun-variadic me.fun)))))) diff --git a/stdlib/path-test.tl b/stdlib/path-test.tl new file mode 100644 index 00000000..fb132f7f --- /dev/null +++ b/stdlib/path-test.tl @@ -0,0 +1,187 @@ +;; Copyright 2015-2021 +;; Kaz Kylheku <kaz@kylheku.com> +;; Vancouver, Canada +;; 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 HOLDER 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. + +(defun sys:do-path-test (statfun path testfun) + [testfun (if (typep path 'stat) + path + (ignerr [statfun path]))]) + +(eval-only + (defmacro sys:path-test ((sym statfun path) . body) + ^[sys:do-path-test ,statfun ,path + (lambda (,sym) (when ,sym ,*body))])) + +(defun sys:path-test-type (statfun path code) + (sys:path-test (s statfun path) + (eql (logand s.mode s-ifmt) code))) + +(defun sys:path-test-mode (statfun path mask) + (sys:path-test (s statfun path) + (plusp (logand s.mode mask)))) + +(defun path-exists-p (path) + (sys:path-test (s stat path) t)) + +(defun path-file-p (path) + [sys:path-test-type stat path s-ifreg]) + +(defun path-dir-p (path) + [sys:path-test-type stat path s-ifdir]) + +(defun path-symlink-p (path) + [sys:path-test-type lstat path s-iflnk]) + +(defun path-blkdev-p (path) + [sys:path-test-type stat path s-ifblk]) + +(defun path-chrdev-p (path) + [sys:path-test-type stat path s-ifchr]) + +(defun path-sock-p (path) + [sys:path-test-type stat path s-ifsock]) + +(defun path-pipe-p (path) + [sys:path-test-type stat path s-ififo]) + +(defun path-setgid-p (path) + [sys:path-test-mode stat path s-isgid]) + +(defun path-setuid-p (path) + [sys:path-test-mode stat path s-isuid]) + +(defun path-sticky-p (path) + [sys:path-test-mode stat path s-isvtx]) + +(defun path-mine-p (path) + (sys:path-test (s stat path) + (= s.uid (geteuid)))) + +(defun path-my-group-p (path) + (sys:path-test (s stat path) + (let ((g s.gid)) + (or (= g (getegid)) + (find g (getgroups)))))) + +;; umask, gmask and omask must test identical permissions +;; multiple permissions may be tested, but not a combination +;; of x with any other permission. +(defun sys:path-access (path umask gmask omask) + (sys:path-test (s stat path) + (let ((m s.mode) + (euid (geteuid))) + (cond + ((zerop euid) (or (zerop (logand umask s-ixusr)) + (plusp (logand m (logior umask gmask omask))))) + ((= euid s.uid) (= umask (logand m umask))) + ((let ((g s.gid)) + (or (= g (getegid)) + (find g (getgroups)))) + (= gmask (logand m gmask))) + (t (= omask (logand m omask))))))) + +(defun path-executable-to-me-p (path) + (sys:path-access path s-ixusr s-ixgrp s-ixoth)) + +(defun path-writable-to-me-p (path) + (sys:path-access path s-iwusr s-iwgrp s-iwoth)) + +(defun path-readable-to-me-p (path) + (sys:path-access path s-irusr s-irgrp s-iroth)) + +(defun path-read-writable-to-me-p (path) + (sys:path-access path + (logior s-irusr s-iwusr) + (logior s-irgrp s-iwgrp) + (logior s-iroth s-iwoth))) + +(defun path-private-to-me-p (path) + (sys:path-test (s stat path) + (let ((m s.mode) + (euid (geteuid))) + (mlet ((g (getgrgid s.gid)) + (name (let ((pw (getpwuid euid))) + (if pw pw.name))) + (suname (let ((pw (getpwuid 0))) + (if pw pw.name)))) + (and (or (zerop s.uid) + (eql euid s.uid)) + (zerop (logand m s-iwoth)) + (or (zerop (logand m s-iwgrp)) + (null g.mem) + (and (all g.mem (orf (op equal name) + (op equal suname)))))))))) + +(defun path-strictly-private-to-me-p (path) + (sys:path-test (s stat path) + (let ((m s.mode) + (euid (geteuid))) + (mlet ((g (getgrgid s.gid)) + (name (let ((pw (getpwuid euid))) + (if pw pw.name))) + (suname (let ((pw (getpwuid 0))) + (if pw pw.name)))) + (and (or (zerop s.uid) + (eql euid s.uid)) + (zerop (logand m (logior s-iroth s-iwoth))) + (or (zerop (logand m (logior s-irgrp s-iwgrp))) + (null g.mem) + (and (all g.mem (orf (op equal name) + (op equal suname)))))))))) + + +(defmacro sys:path-examine ((sym statfun path) . body) + ^[sys:do-path-test ,statfun ,path + (lambda (,sym) ,*body)]) + +(defun path-newer (path-0 path-1) + (sys:path-examine (s0 stat path-0) + (sys:path-examine (s1 stat path-1) + (if s0 + (or (null s1) + (let ((mt0 s0.mtime) + (mt1 s1.mtime)) + (or (> mt0 mt1) + (and (= mt0 mt1) + (> s0.mtime-nsec s1.mtime-nsec))))))))) + +(defun path-older (path-0 path-1) + (path-newer path-1 path-0)) + +(defun path-same-object (path-0 path-1) + (sys:path-examine (s0 stat path-0) + (sys:path-examine (s1 stat path-1) + (and s0 s1 + (eql s0.dev s1.dev) + (eql s0.ino s1.ino))))) + +(defun path-dir-empty (path) + (when (path-dir-p path) + (let ((name (if (stringp path) path path.path))) + (with-stream (ds (open-directory name)) + (for (ent) ((set ent (get-line ds)) t) () + (casequal ent + (("." "..")) + (t (return nil)))))))) diff --git a/stdlib/pic.tl b/stdlib/pic.tl new file mode 100644 index 00000000..6c2c8048 --- /dev/null +++ b/stdlib/pic.tl @@ -0,0 +1,119 @@ +;; Copyright 2021 +;; Kaz Kylheku <kaz@kylheku.com> +;; Vancouver, Canada +;; 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 HOLDER 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. + +(defun expand-pic-num (fmt val) + (let* ((zero (or (starts-with "0" fmt) + (starts-with "+0" fmt) + (starts-with "-0" fmt))) + (plus (eql [fmt 0] #\+)) + (minus (eql [fmt 0] #\-)) + (exc (pos #\! fmt)) + (dot (or exc (pos #\. fmt))) + (fmt (if (and exc (eq #\! [fmt -1])) [fmt 0..-1] fmt)) + (int (if dot [fmt 0..dot] fmt)) + (fra (if dot [fmt (succ dot)..:] ""))) + (let ((code (if (or minus plus (not zero)) + ^(fmt ,`~@(len fmt),@(if plus "+")@(if zero "0")@(len fra)f` + ,val) + ^(fmt ,`~@(len fmt),-0@(len fra)f` + ,val)))) + (if exc + (with-gensyms (str) + ^(let ((,str ,code)) + (if (> (len ,str) ,(len fmt)) + ,(mkstring (len fmt) #\#) + ,str))) + code)))) + +(defun expand-pic-align (chr fmt val) + ^(fmt ,`~@(if chr chr)@(len fmt)a` ,val)) + +(defun pic-join-opt (join-form) + (labels ((et (str) (regsub #/\~/ "~~" str))) + (match-case join-form + ((join @(stringp @s) (fmt `@fmt` . @args) . @rest) + (pic-join-opt ^(join (fmt ,`@(et s)@fmt` ,*args) ,*rest))) + ((join (fmt `@fmt` . @args) @(stringp @s) . @rest) + (pic-join-opt ^(join (fmt ,`@fmt@(et s)` ,*args) ,*rest))) + ((join (fmt `@fmt1` . @args1) (fmt `@fmt2` . @args2) . @rest) + (pic-join-opt ^(join (fmt ,`@fmt1@fmt2` ,*args1 ,*args2) ,*rest))) + ((join @(stringp @s1) @(stringp @s2) . @rest) + (pic-join-opt ^(join ,`@s1@s2` ,*rest))) + ((join "" @item . @rest) + (pic-join-opt ^(join ,item ,*rest))) + ((join @item "" . @rest) + (pic-join-opt ^(join ,item ,*rest))) + ((join @item) item) + (@else else)))) + +(defun expand-pic (f fmt val) + (unless (stringp fmt) + (compile-error f "~s is required to be a format string" fmt)) + (cond + ([m^$ #/\~[~#<>\|\-+0.!]/ fmt] [fmt 1..2]) + ([m^$ #/\~./ fmt] (compile-error f "unrecognized escape sequence ~a" fmt)) + ([m^$ #/\~/ fmt] (compile-error f "incomplete ~~ escape")) + ([m^$ #/[+\-]?0?#+([.!]#+|!)?/ fmt] (expand-pic-num fmt val)) + ([m^$ #/<+/ fmt] (expand-pic-align "<" fmt val)) + ([m^$ #/>+/ fmt] (expand-pic-align nil fmt val)) + ([m^$ #/\|+/ fmt] (expand-pic-align "^" fmt val)) + (t (compile-error f "unrecognized format string ~s" fmt)))) + +(defmacro pic (:form f :env e bigfmt . args) + (let* ((regex #/[+\-]?0?#+([.!]#+|!)?| \ + <+| \ + >+| \ + \|+| \ + \~.|\~/)) + (labels ((pic-compile-string (fmtstr) + (let ((items (collect-each ((piece (tok regex t fmtstr))) + (cond + ((m^$ regex piece) + (cond + ((starts-with "~" piece) + (expand-pic f piece nil)) + (args + (expand-pic f piece (pop args))) + (t (compile-error + f "insufficient arguments for format")))) + (t piece))))) + (pic-join-opt ^(join ,*items))))) + (match-case bigfmt + (@(stringp @s) + (let ((out (pic-compile-string s))) + (if args + (compile-warning f "excess arguments")) + out)) + ((@(or sys:quasi) . @qargs) + (let ((nqargs (build (each ((q qargs)) + (if (stringp q) + (add (pic-compile-string q)) + (add q)))))) + (if args + (compile-warning f "excess arguments")) + ^(sys:quasi ,*nqargs))) + (@else (compile-error + f "~s is required to be a string or quasiliteral" else)))))) diff --git a/stdlib/place.tl b/stdlib/place.tl new file mode 100644 index 00000000..3ee0ea8c --- /dev/null +++ b/stdlib/place.tl @@ -0,0 +1,971 @@ +;; Copyright 2015-2021 +;; Kaz Kylheku <kaz@kylheku.com> +;; Vancouver, Canada +;; 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 HOLDER 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. + +(defvar *place-clobber-expander* (hash)) +(defvar *place-update-expander* (hash)) +(defvar *place-delete-expander* (hash)) +(defvar *place-macro* (hash)) +(defvar sys:*pl-env* nil) +(defvar sys:*pl-form* nil) + +(defun sys:eval-err (. params) + (throwf 'eval-error . params)) + +(defun sys:sym-update-expander (getter-name setter-name + place-expr op-body) + ^(macrolet ((,getter-name () ',place-expr) + (,setter-name (val-expr) ^(sys:setq ,',place-expr + ,val-expr))) + ,op-body)) + +(defun sys:sym-clobber-expander (simple-setter-name + place-expr op-body) + ^(macrolet ((,simple-setter-name (val-expr) + ^(sys:setq ,',place-expr ,val-expr))) + ,op-body)) + +(defun sys:sym-delete-expander (deleter-name + place-expr . op-body) + ^(macrolet ((,deleter-name (:env env) + (when (lexical-var-p env ',place-expr) + (sys:eval-err "~s is a lexical variable, thus not deletable" + ',place-expr)) + ^(prog1 + (symbol-value ',',place-expr) + (makunbound ',',place-expr)))) + ,*op-body)) + +(defun sys:get-place-macro (sym) + (or [*place-macro* sym] + (progn (sys:try-load sym) [*place-macro* sym]))) + +(defun sys:pl-expand (unex-place env) + (while t + (let ((place unex-place) + pm-expander) + (while (and (consp place) + (sys:setq pm-expander (sys:get-place-macro (car place))) + (sys:setq place (sys:set-macro-ancestor [pm-expander place] place)) + (neq place unex-place)) + (sys:setq unex-place place)) + (sys:setq place (macroexpand-1 place env)) + (when (or (eq place unex-place) + (null place) + (and (atom place) (not (symbolp place)))) + (return-from sys:pl-expand place)) + (sys:setq unex-place place)))) + +(defun place-form-p (unex-place env) + (let ((place (sys:pl-expand unex-place env))) + (or (bindable place) + (and (consp place) [*place-update-expander* (car place)] t)))) + +(defun get-update-expander (place) + (cond + ((symbolp place) (fun sys:sym-update-expander)) + ((consp place) (or [*place-update-expander* (car place)] + (sys:eval-err "~s is not an assignable place" place))) + (t (sys:eval-err "form ~s is not syntax denoting an assignable place" place)))) + +(defun get-clobber-expander (place) + (cond + ((symbolp place) (fun sys:sym-clobber-expander)) + ((consp place) (or [*place-clobber-expander* (car place)] + (iflet ((fun [*place-update-expander* (car place)])) + (op apply fun (gensym) @1 @2 @rest)) + (sys:eval-err "~s is not an assignable place" place))) + (t (sys:eval-err "form ~s is not syntax denoting an assignable place" place)))) + +(defun get-delete-expander (place) + (cond + ((symbolp place) (fun sys:sym-delete-expander)) + ((consp place) (or [*place-delete-expander* (car place)] + (sys:eval-err "~s is not a deletable place" place))) + (t (sys:eval-err "form ~s is not syntax denoting a deletable place" place)))) + +(defun sys:r-s-let-expander (bindings body e letsym pred) + (let ((exp-bindings (mapcar (aret ^(,@1 ,(macroexpand @2 e))) bindings))) + (let ((renames [keep-if pred exp-bindings second]) + (regular [remove-if pred exp-bindings second])) + (cond ((and renames regular) + ^(symacrolet ,renames + (,letsym ,regular ,*body))) + (renames ^(symacrolet ,renames ,*body)) + (regular ^(,letsym ,regular ,*body)) + (t ^(progn ,*body)))))) + +(defmacro rlet (bindings :env e . body) + [sys:r-s-let-expander bindings body e 'let constantp]) + +(defmacro slet (bindings :env e . body) + (sys:r-s-let-expander bindings body e 'let [orf constantp bindable])) + +(defmacro alet (bindings :env e . body) + (let ((exp-bindings (mapcar (aret ^(,@1 ,(macroexpand @2 e))) bindings))) + (if [some exp-bindings constantp second] + [sys:r-s-let-expander exp-bindings body e 'alet constantp] + ^(,(if [all exp-bindings bindable second] + 'symacrolet 'let) + ,exp-bindings ,*body)))) + +(defmacro with-gensyms (syms . body) + ^(let ,(zip syms (repeat '((gensym)))) ,*body)) + +(defun sys:propagate-ancestor (to-tree from-form . syms) + (unless (macro-ancestor to-tree) + (tree-case to-tree + ((a . d) + (when (memq a syms) + (sys:set-macro-ancestor to-tree from-form)) + (sys:propagate-ancestor a from-form . syms) + (sys:propagate-ancestor d from-form . syms)))) + to-tree) + +(defun call-update-expander (getter setter unex-place env body) + (sys:propagate-ancestor body unex-place getter setter) + (let* ((place (sys:pl-expand unex-place env)) + (expander (get-update-expander place)) + (sys:*pl-env* env) + (sys:*pl-form* unex-place) + (expansion [expander getter setter place body]) + (expansion-ex (expand expansion env))) + (sys:propagate-ancestor expansion-ex place getter setter))) + +(defun call-clobber-expander (ssetter unex-place env body) + (sys:propagate-ancestor body unex-place ssetter) + (let* ((place (sys:pl-expand unex-place env)) + (expander (get-clobber-expander place)) + (sys:*pl-env* env) + (sys:*pl-form* unex-place) + (expansion [expander ssetter place body]) + (expansion-ex (expand expansion env))) + (sys:propagate-ancestor expansion-ex place ssetter))) + +(defun call-delete-expander (deleter unex-place env body) + (sys:propagate-ancestor body unex-place deleter) + (let* ((place (sys:pl-expand unex-place env)) + (expander (get-delete-expander place)) + (sys:*pl-env* env) + (sys:*pl-form* unex-place) + (expansion [expander deleter place body]) + (expansion-ex (expand expansion env))) + (sys:propagate-ancestor expansion-ex place deleter))) + +(defmacro with-update-expander ((getter setter) unex-place env body) + ^(with-gensyms (,getter ,setter) + (call-update-expander ,getter ,setter ,unex-place ,env ,body))) + +(defmacro with-clobber-expander ((ssetter) unex-place env body) + ^(with-gensyms (,ssetter) + (call-clobber-expander ,ssetter ,unex-place ,env ,body))) + +(defmacro with-delete-expander ((deleter) unex-place env body) + ^(with-gensyms (,deleter) + (call-delete-expander ,deleter ,unex-place ,env ,body))) + +(defmacro set (:env env . place-value-pairs) + (let ((assign-forms (mapcar (tb ((place : (value nil value-present-p))) + (unless value-present-p + (sys:eval-err "set: arguments must be pairs")) + (with-clobber-expander (ssetter) place env + ^(,ssetter ,value))) + (tuples 2 place-value-pairs)))) + (if (cdr assign-forms) + ^(progn ,*assign-forms) + (car assign-forms)))) + +(defmacro pset (:env env . place-value-pairs) + (let ((len (length place-value-pairs))) + (cond + ((oddp len) (sys:eval-err "pset: arguments must be pairs")) + ((<= len 2) ^(set ,*place-value-pairs)) + (t (let* ((pvtgs (mapcar (tb ((a b)) + (list a b (gensym) (gensym) (gensym))) + (tuples 2 place-value-pairs))) + (ls (reduce-left (tb ((lets stores) (place value temp getter setter)) + (list ^((,temp ,value) ,*lets) + ^((,setter ,temp) ,*stores))) + pvtgs '(nil nil))) + (lets (first ls)) + (stores (second ls)) + (body-form ^(rlet (,*lets) ,*stores))) + (reduce-left (tb (accum-form (place value temp getter setter)) + (call-update-expander getter setter + place env accum-form)) + pvtgs body-form)))))) + +(defmacro zap (place : (new-val nil) :env env) + (with-update-expander (getter setter) place env + ^(prog1 (,getter) (,setter ,new-val)))) + +(defmacro flip (place :env env) + (with-update-expander (getter setter) place env + ^(,setter (not (,getter))))) + +(defmacro inc (place : (delta 1) :env env) + (with-update-expander (getter setter) place env + (caseql delta + (0 place) + (1 ^(,setter (succ (,getter)))) + (2 ^(,setter (ssucc (,getter)))) + (3 ^(,setter (sssucc (,getter)))) + (t ^(,setter (+ (,getter) ,delta)))))) + +(defmacro dec (place : (delta 1) :env env) + (with-update-expander (getter setter) place env + (caseql delta + (0 place) + (1 ^(,setter (pred (,getter)))) + (2 ^(,setter (ppred (,getter)))) + (3 ^(,setter (pppred (,getter)))) + (t ^(,setter (- (,getter) ,delta)))))) + +(defmacro pinc (place : (delta 1) :env env) + (with-gensyms (oldval) + (with-update-expander (getter setter) place env + (caseql delta + (0 place) + (1 ^(let ((,oldval (,getter))) (,setter (succ ,oldval)) ,oldval)) + (2 ^(let ((,oldval (,getter))) (,setter (ssucc ,oldval)) ,oldval)) + (3 ^(let ((,oldval (,getter))) (,setter (sssucc ,oldval)) ,oldval)) + (t ^(let ((,oldval (,getter))) (,setter (+ ,oldval, delta)) ,oldval)))))) + +(defmacro pdec (place : (delta 1) :env env) + (with-gensyms (oldval) + (with-update-expander (getter setter) place env + (caseql delta + (0 place) + (1 ^(let ((,oldval (,getter))) (,setter (pred ,oldval)) ,oldval)) + (2 ^(let ((,oldval (,getter))) (,setter (ppred ,oldval)) ,oldval)) + (3 ^(let ((,oldval (,getter))) (,setter (pppred ,oldval)) ,oldval)) + (t ^(let ((,oldval (,getter))) (,setter (- ,oldval, delta)) ,oldval)))))) + +(defmacro swap (place-0 place-1 :env env) + (with-gensyms (tmp) + (with-update-expander (getter-0 setter-0) place-0 env + (with-update-expander (getter-1 setter-1) place-1 env + ^(let ((,tmp (,getter-0))) + (,setter-0 (,getter-1)) + (,setter-1 ,tmp)))))) + +(defmacro push (new-item place :env env) + (with-gensyms (new-sym) + ^(alet ((,new-sym ,new-item)) + ,(with-update-expander (getter setter) place env + ^(,setter (cons ,new-sym (,getter))))))) + +(defmacro pop (place :env env) + (with-gensyms (tmp) + (with-update-expander (getter setter) place env + ^(alet ((,tmp (,getter))) + (prog1 (car ,tmp) (,setter (cdr ,tmp))))))) + +(defmacro pushnew (new-item place :env env : + (testfun :) + (keyfun :)) + (with-update-expander (getter setter) place env + (with-gensyms (new-item-sym old-list-sym) + ^(rlet ((,new-item-sym ,new-item)) + ,(with-update-expander (getter setter) place env + ^(let ((,old-list-sym (,getter))) + (if (member ,new-item-sym ,old-list-sym ,testfun ,keyfun) + ,old-list-sym + (,setter (cons ,new-item-sym ,old-list-sym))))))))) + +(defmacro shift (:form f :env env . places) + (tree-case places + (() (compile-error f "need at least two arguments")) + ((place) (compile-error f "need at least two arguments")) + ((place newvalue) + (with-update-expander (getter setter) place env + ^(prog1 (,getter) (,setter ,newvalue)))) + ((place . others) + (with-update-expander (getter setter) place env + ^(prog1 (,getter) (,setter (shift ,*others))))))) + +(defmacro rotate (:env env . places) + (tree-case places + (() ()) + ((fplace) fplace) + ((fplace . rplaces) + (with-gensyms (tmp) + (with-update-expander (getter-f setter-f) fplace env + ^(let ((,tmp (,getter-f))) + (,setter-f (shift ,*rplaces ,tmp)) + ,tmp)))))) + +(defmacro test-set (:env env place) + (with-update-expander (getter setter) place env + ^(unless (,getter) + (,setter t)))) + +(defmacro test-clear (:env env place) + (with-update-expander (getter setter) place env + ^(when (,getter) + (,setter nil) + t))) + +(defmacro compare-swap (:env env comp-fun place comp-val store-val) + (with-update-expander (getter setter) place env + ^(when (,comp-fun (,getter) ,comp-val) + (,setter ,store-val) + t))) + +(defmacro test-inc (place : (delta 1) (upfrom-val 0)) + ^(eql (pinc ,place ,delta) ,upfrom-val)) + +(defmacro test-dec (place : (delta 1) (downto-val 0)) + ^(eql (dec ,place ,delta) ,downto-val)) + +(defmacro del (place :env env) + (with-delete-expander (deleter) place env + ^(,deleter))) + +(defmacro lset (:form f . places-source) + (let ((places (butlast places-source)) + (source (last places-source)) + (orig (gensym)) + (iter (gensym))) + (unless places + (compile-error f "require one or more places followed by expression")) + ^(let* ((,orig ,(car source)) + (,iter ,orig)) + ,*(butlast (mappend (ret ^((set ,@1 (car ,iter)) (set ,iter (cdr ,iter)))) + places)) + ,orig))) + +(defmacro upd (place . opip-args) + (with-gensyms (pl) + ^(placelet ((,pl ,place)) + (set ,pl (call (opip ,*opip-args) ,pl))))) + +(defmacro defplace (place-destructuring-args body-sym + (getter-sym setter-sym update-body) : + ((ssetter-sym clobber-body)) + ((deleter-sym delete-body))) + (let ((name (car place-destructuring-args)) + (args (cdr place-destructuring-args))) + (unless (and name + (symbolp name) + (not (keywordp name)) + (not (eq t name))) + (compile-error sys:*pl-form* "~s cannot be used as a place name" name)) + (with-gensyms (place) + ^(progn + (sethash *place-update-expander* ',name + (lambda (,getter-sym ,setter-sym ,place ,body-sym) + (tree-bind ,args (cdr ,place) + ,update-body))) + ,*(if ssetter-sym + ^((sethash *place-clobber-expander* ',name + (lambda (,ssetter-sym ,place ,body-sym) + (tree-bind ,args (cdr ,place) + ,clobber-body))))) + ,*(if deleter-sym + ^((sethash *place-delete-expander* ',name + (lambda (,deleter-sym ,place ,body-sym) + (tree-bind ,args (cdr ,place) + ,delete-body))))) + ',name)))) + +(defmacro define-place-macro (name place-destructuring-args . body) + (with-gensyms (name-dummy args) + ^(progn + (sethash *place-macro* ',name + (lambda (,args) + (mac-param-bind ,args + (,name-dummy ,*place-destructuring-args) + ,args ,*body))) + ',name))) + +(defplace (sys:var arg) body + (getter setter + ^(macrolet ((,getter () ^(sys:var ,',arg)) + (,setter (val) ^(sys:setq ,'(sys:var ,arg) ,val))) + ,body))) + +(defplace (sys:l1-val arg) body + (getter setter + ^(macrolet ((,getter () ^(sys:l1-val ,',arg)) + (,setter (val) ^(sys:l1-setq ,',arg ,val))) + ,body)) + (ssetter + ^(macrolet ((,ssetter (val) ^(sys:l1-setq ,',arg ,val))) + ,body))) + +(defplace (sys:lisp1-value arg) body + (getter setter + ^(macrolet ((,getter () ^(sys:lisp1-value ,',arg)) + (,setter (val) ^(sys:lisp1-setq ,',arg ,val))) + ,body)) + (ssetter + ^(macrolet ((,ssetter (val) ^(sys:lisp1-setq ,',arg ,val))) + ,body))) + +(defplace (car cell) body + (getter setter + (with-gensyms (cell-sym) + ^(slet ((,cell-sym ,cell)) + (macrolet ((,getter () ^(car ,',cell-sym)) + (,setter (val) ^(sys:rplaca ,',cell-sym ,val))) + ,body)))) + (ssetter + ^(macrolet ((,ssetter (val) ^(sys:rplaca ,',cell ,val))) + ,body)) + (deleter + ^(macrolet ((,deleter () ^(pop ,',cell))) + ,body))) + +(defplace (cdr cell) body + (getter setter + (with-gensyms (cell-sym) + ^(slet ((,cell-sym ,cell)) + (macrolet ((,getter () ^(cdr ,',cell-sym)) + (,setter (val) ^(sys:rplacd ,',cell-sym ,val))) + ,body)))) + (ssetter + ^(macrolet ((,ssetter (val) ^(sys:rplacd ,',cell ,val))) + ,body)) + (deleter + ^(macrolet ((,deleter () + (with-gensyms (tmp) + (with-update-expander (cgetter csetter) ',cell nil + ^(let ((,tmp (,cgetter))) + (prog1 (cdr ,tmp) (,csetter (car ,tmp)))))))) + ,body))) + +(defplace (nthcdr index list) body + (getter setter + (with-gensyms (index-sym list-sym sentinel-head-sym parent-cell-sym) + (if (place-form-p list sys:*pl-env*) + (with-update-expander (lgetter lsetter) list sys:*pl-env* + ^(alet ((,index-sym ,index) + (,list-sym (,lgetter))) + (let* ((,sentinel-head-sym (cons nil ,list-sym)) + (,parent-cell-sym (nthcdr ,index-sym ,sentinel-head-sym))) + (macrolet ((,getter () ^(cdr ,',parent-cell-sym)) + (,setter (val) + ^(prog1 (sys:rplacd ,',parent-cell-sym ,val) + (,',lsetter (cdr ,',sentinel-head-sym))))) + ,body)))) + ^(alet ((,index-sym ,index) + (,list-sym ,list)) + (let ((,parent-cell-sym (nthcdr (pred ,index-sym) ,list-sym))) + (macrolet ((,getter () ^(cdr ,',parent-cell-sym)) + (,setter (val) + ^(sys:rplacd ,',parent-cell-sym ,val))) + ,body))))))) + +(defplace (nthlast index list) body + (getter setter + (with-gensyms (index-sym list-sym sentinel-head-sym parent-cell-sym) + (if (place-form-p list sys:*pl-env*) + (with-update-expander (lgetter lsetter) list sys:*pl-env* + ^(alet ((,index-sym ,index) + (,list-sym (,lgetter))) + (let* ((,sentinel-head-sym (cons nil ,list-sym)) + (,parent-cell-sym (nthlast (succ ,index-sym) + ,sentinel-head-sym))) + (macrolet ((,getter () ^(cdr ,',parent-cell-sym)) + (,setter (val) + ^(prog1 (sys:rplacd ,',parent-cell-sym ,val) + (,',lsetter (cdr ,',sentinel-head-sym))))) + ,body)))) + ^(alet ((,index-sym index) + (,list-sym ,list)) + (let ((,parent-cell-sym (nthlast (succ ,index-sym) ,list-sym))) + (macrolet ((,getter () ^(cdr ,',parent-cell-sym)) + (,setter (val) + ^(sys:rplacd ,',parent-cell-sym ,val))) + ,body))))))) + +(defplace (butlastn num list) body + (getter setter + (with-gensyms (num-sym list-sym head-sym tail-sym val-sym) + (with-update-expander (lgetter lsetter) list sys:*pl-env* + ^(alet ((,num-sym ,num) + (,list-sym (,lgetter))) + (let* ((,tail-sym (nthlast ,num-sym ,list-sym)) + (,head-sym (ldiff ,list-sym ,tail-sym))) + (macrolet ((,getter () ,head-sym) + (,setter (val) + ^(alet ((,',val-sym ,val)) + (progn (,',lsetter (append ,',val-sym + ,',tail-sym)) + ,',val-sym)))) + ,body))))))) + +(defplace (vecref vector index :whole args) body + (getter setter + (with-gensyms (vec-sym ind-sym) + ^(alet ((,vec-sym ,vector) + (,ind-sym ,index)) + (macrolet ((,getter () ^(vecref ,',vec-sym ,',ind-sym)) + (,setter (val) ^(refset ,',vec-sym ,',ind-sym ,val))) + ,body)))) + (ssetter + ^(macrolet ((,ssetter (val) ^(refset ,*',args ,val))) + ,body)) + (deleter + (with-gensyms (vec-sym ind-sym) + ^(alet ((,vec-sym ,vector) + (,ind-sym ,index)) + (macrolet ((,deleter () + ^(prog1 (vecref ,',vec-sym ,',ind-sym) + (replace-vec ,',vec-sym nil + ,',ind-sym (succ ,',ind-sym))))) + ,body))))) + +(defplace (chr-str string index :whole args) body + (getter setter + (with-gensyms (str-sym ind-sym) + ^(alet ((,str-sym ,string) + (,ind-sym ,index)) + (macrolet ((,getter () ^(chr-str ,',str-sym ,',ind-sym)) + (,setter (val) ^(chr-str-set ,',str-sym ,',ind-sym ,val))) + ,body)))) + (ssetter + ^(macrolet ((,ssetter (val) ^(chr-str-set ,*',args ,val))) + ,body)) + (deleter + (with-gensyms (str-sym ind-sym) + ^(alet ((,str-sym ,string) + (,ind-sym ,index)) + (macrolet ((,deleter () + ^(prog1 (chr-str ,',str-sym ,',ind-sym) + (replace-str ,',str-sym nil + ,',ind-sym (succ ,',ind-sym))))) + ,body))))) + +(defplace (ref seq index :whole args) body + (getter setter + (with-gensyms (seq-sym ind-sym) + ^(alet ((,seq-sym ,seq) + (,ind-sym ,index)) + (macrolet ((,getter () ^(ref ,',seq-sym ,',ind-sym)) + (,setter (val) ^(refset ,',seq-sym ,',ind-sym ,val))) + ,body)))) + (ssetter + ^(macrolet ((,ssetter (val) ^(refset ,*',args ,val))) + ,body)) + (deleter + (with-gensyms (seq-sym ind-sym) + ^(alet ((,seq-sym ,seq) + (,ind-sym ,index)) + (macrolet ((,deleter () + ^(prog1 (ref ,',seq-sym ,',ind-sym) + (replace ,',seq-sym nil + ,',ind-sym (succ ,',ind-sym))))) + ,body))))) + +(defplace (sub seq :whole args : (from 0) (to t)) body + (getter setter + (with-gensyms (seq-sym from-sym to-sym v-sym) + (with-update-expander (seq-getter seq-setter) seq sys:*pl-env* + ^(alet ((,seq-sym (,seq-getter)) + (,from-sym ,from) + (,to-sym ,to)) + (macrolet ((,getter () ^(sub ,',seq-sym ,',from-sym ,',to-sym)) + (,setter (val) + ^(alet ((,',v-sym ,val)) + (,',seq-setter (replace ,',seq-sym ,',v-sym + ,',from-sym ,',to-sym)) + ,',v-sym))) + ,body))))) + (ssetter + (with-gensyms (seq-sym from-sym to-sym v-sym) + (with-update-expander (seq-getter seq-setter) seq sys:*pl-env* + ^(macrolet ((,ssetter (val) + ^(alet ((,',seq-sym (,',seq-getter)) + (,',from-sym ,',from) + (,',to-sym ,',to) + (,',v-sym ,val)) + (,',seq-setter (replace ,',seq-sym ,',v-sym + ,',from-sym ,',to-sym)) + ,',v-sym))) + ,body)))) + (deleter + (with-gensyms (seq-sym from-sym to-sym) + (with-update-expander (seq-getter seq-setter) seq sys:*pl-env* + ^(alet ((,seq-sym (,seq-getter)) + (,from-sym ,from) + (,to-sym ,to)) + (macrolet ((,deleter () + ^(prog1 + (sub ,',seq-sym ,',from-sym ,',to-sym) + (,',seq-setter (replace ,',seq-sym nil + ,',from-sym ,',to-sym))))) + ,body)))))) + +(defplace (gethash hash key : (default nil have-default-p)) body + (getter setter + (with-gensyms (entry-sym) + ^(let ((,entry-sym (inhash ,hash ,key ,default))) + (macrolet ((,getter () ^(cdr ,',entry-sym)) + (,setter (val) ^(sys:rplacd ,',entry-sym ,val))) + ,body)))) + nil + (deleter + ^(macrolet ((,deleter () + (if ,have-default-p + (with-gensyms (entry-sym + dfl-sym) + ^(alet ((,entry-sym (inhash ,',hash ,',key)) + (,dfl-sym ,',default)) + (if ,entry-sym + (remhash ,',hash ,',key) + ,dfl-sym))) + ^(remhash ,',hash ,',key)))) + ,body))) + +(defplace (hash-userdata hash) body + (getter setter + (with-gensyms (hash-sym) + ^(slet ((,hash-sym ,hash)) + (macrolet ((,getter () ^(hash-userdata ,',hash-sym)) + (,setter (val) ^(set-hash-userdata ,',hash-sym ,val))) + ,body)))) + (ssetter + ^(macrolet ((,ssetter (val) + ^(set-hash-userdata ,',hash ,val))) + ,body))) + +(defplace (dwim obj-place :env env . args) body + (getter setter + (with-gensyms (ogetter-sym osetter-sym obj-sym newval-sym) + (let ((arg-syms (mapcar (ret (gensym)) args))) + (if (place-form-p obj-place sys:*pl-env*) + (with-update-expander (ogetter-sym osetter-sym) + ^(sys:l1-val ,obj-place) sys:*pl-env* + ^(rlet ((,obj-sym (,ogetter-sym)) + ,*(mapcar (ret ^(,@1 (sys:l1-val ,@2))) arg-syms args)) + (macrolet ((,getter () + '[,obj-sym ,*arg-syms]) + (,setter (val) + ^(rlet ((,',newval-sym ,val)) + (,',osetter-sym + (sys:dwim-set t ,',obj-sym + ,*',arg-syms ,',newval-sym)) + ,',newval-sym))) + ,body))) + ^(rlet ((,obj-sym ,obj-place) + ,*(mapcar (ret ^(,@1 (sys:l1-val ,@2))) arg-syms args)) + (macrolet ((,getter () + '[,obj-sym ,*arg-syms]) + (,setter (val) + ^(rlet ((,',newval-sym ,val)) + (sys:dwim-set nil ,',obj-sym + ,*',arg-syms ,',newval-sym) + ,',newval-sym))) + ,body)))))) + (ssetter + (with-gensyms (osetter-sym ogetter-sym obj-sym newval-sym) + (let ((arg-syms (mapcar (ret (gensym)) args))) + (if (place-form-p obj-place sys:*pl-env*) + (with-update-expander (ogetter-sym osetter-sym) + ^(sys:l1-val ,obj-place) sys:*pl-env* + ^(macrolet ((,ssetter (val) + ^(rlet ((,',obj-sym (,',ogetter-sym)) + ,*(mapcar (ret ^(,@1 (sys:l1-val ,@2))) + ',arg-syms ',args) + (,',newval-sym ,val)) + (,',osetter-sym + (sys:dwim-set t ,',obj-sym + ,*',arg-syms + ,',newval-sym)) + ,',newval-sym))) + ,body)) + ^(macrolet ((,ssetter (val) + ^(rlet ((,',obj-sym ,',obj-place) + ,*(mapcar (ret ^(,@1 (sys:l1-val ,@2))) + ',arg-syms ',args) + (,',newval-sym ,val)) + (sys:dwim-set nil ,',obj-sym + ,*',arg-syms + ,',newval-sym) + ,',newval-sym))) + ,body))))) + + (deleter + (with-gensyms (osetter-sym ogetter-sym obj-sym oldval-sym) + (let ((arg-syms (mapcar (ret (gensym)) args))) + (if (place-form-p obj-place sys:*pl-env*) + (with-update-expander (ogetter-sym osetter-sym) + ^(sys:l1-val ,obj-place) sys:*pl-env* + ^(macrolet ((,deleter () + ^(rlet ((,',obj-sym (,',ogetter-sym)) + ,*(mapcar (ret ^(,@1 (sys:l1-val ,@2))) + ',arg-syms ',args)) + (let ((,',oldval-sym [,',obj-sym ,*',arg-syms])) + (progn + (,',osetter-sym + (sys:dwim-del t ,',obj-sym ,*',arg-syms)) + ,',oldval-sym))))) + ,body)) + ^(macrolet ((,deleter () + ^(rlet ((,',obj-sym ,',obj-place) + ,*(mapcar (ret ^(,@1 (sys:l1-val ,@2))) + ',arg-syms ',args)) + (let ((,',oldval-sym [,',obj-sym ,*',arg-syms])) + (progn + (sys:dwim-del nil ,',obj-sym ,*',arg-syms) + ,',oldval-sym))))) + ,body)))))) + +(defplace (force promise) body + (getter setter + (with-gensyms (promise-sym) + ^(rlet ((,promise-sym ,promise)) + (macrolet ((,getter () + ^(force ,',promise-sym)) + (,setter (val) + ^(set (car (cdr ,',promise-sym)) ,val))) + ,body)))) + (ssetter + (with-gensyms (promise-sym) + ^(rlet ((,promise-sym ,promise)) + (macrolet ((,ssetter (val) + ^(prog1 + (set (car (cdr ,',promise-sym)) ,val) + (set (car ,',promise-sym) 'sys:promise-forced)))) + ,body))))) + +(defplace (errno) body + (getter setter + ^(macrolet ((,getter () '(errno)) + (,setter (val-expr) + (with-gensyms (val-sym) + ^(slet ((,val-sym ,val-expr)) + (progn (errno ,val-sym) ,val-sym))))) + ,body))) + +(defplace (fun sym) body + (getter setter + ^(macrolet ((,getter () ^(fun ,',sym)) + (,setter (val) ^(sys:setqf ,',sym ,val))) + ,body)) + nil + (deleter + ^(macrolet ((,deleter (:env env) + (when (lexical-fun-p env ',sym) + (compile-error ',sys:*pl-form* + "~s is a lexical function, \ + \ thus not deletable")) + ^(fmakunbound ',',sym))) + ,body))) + +(defun sys:get-fun-getter-setter (sym : f) + (tree-case sym + ((type struct slot) + (if (eq type 'meth) + (caseql slot + (:init (cons (op struct-get-initfun struct) + (op struct-set-initfun struct))) + (:postinit (cons (op struct-get-postinitfun struct) + (op struct-set-postinitfun struct))) + (t (cons (op static-slot struct slot) + (op static-slot-ensure struct slot)))) + :)) + ((type sym) + (if (eq type 'macro) + (let ((cell (or (gethash sys:top-mb sym) + (sethash sys:top-mb sym (cons sym nil))))) + (cons (op cdr) + (op sys:rplacd cell))) + :)) + ((op . rest) + (if (eq op 'lambda) + (compile-error f "cannot assign to lambda") + (compile-error f "invalid function syntax ~s" sym))) + (else + (let ((cell (or (gethash sys:top-fb sym) + (sethash sys:top-fb sym (cons sym nil))))) + (cons (op cdr) + (op sys:rplacd cell)))))) + +(defplace (symbol-function sym-expr) body + (getter setter + (with-gensyms (gs-sym) + ^(let ((,gs-sym (sys:get-fun-getter-setter ,sym-expr ',sys:*pl-form*))) + (macrolet ((,getter () ^(call (car ,',gs-sym))) + (,setter (val) ^(call (cdr ,',gs-sym) ,val))) + ,body)))) + nil + (deleter + ^(macrolet ((,deleter () ^(fmakunbound ,',sym-expr))) + ,body))) + +(defun sys:get-mb (f sym) + (or (gethash sys:top-mb sym) + (compile-error f "unbound macro ~s" sym))) + +(defplace (symbol-macro sym-expr) body + (getter setter + (with-gensyms (binding-sym) + ^(let ((,binding-sym (sys:get-mb ',sys:*pl-form* ,sym-expr))) + (macrolet ((,getter () ^(cdr ,',binding-sym)) + (,setter (val) ^(sys:rplacd ,',binding-sym ,val))) + ,body)))) + nil + (deleter + ^(macrolet ((,deleter () ^(mmakunbound ,',sym-expr))) + ,body))) + +(defun sys:get-vb (sym) + (or (gethash sys:top-vb sym) + (sethash sys:top-vb sym (cons sym nil)))) + +(defplace (symbol-value sym-expr) body + (getter setter + (with-gensyms (binding-sym) + ^(let ((,binding-sym (sys:get-vb ,sym-expr))) + (macrolet ((,getter () ^(cdr ,',binding-sym)) + (,setter (val) ^(sys:rplacd ,',binding-sym ,val))) + ,body)))) + nil + (deleter + ^(macrolet ((,deleter () ^(makunbound ,',sym-expr))) + ,body))) + +(defplace (slot struct sym) body + (getter setter + (with-gensyms (struct-sym slot-sym) + ^(alet ((,struct-sym ,struct) + (,slot-sym ,sym)) + (macrolet ((,getter () ^(slot ,',struct-sym ,',slot-sym)) + (,setter (val) ^(slotset ,',struct-sym ,',slot-sym ,val))) + ,body)))) + (ssetter + ^(macrolet ((,ssetter (val) ^(slotset ,',struct ,',sym ,val))) + ,body))) + +(defmacro define-modify-macro (name lambda-list function) + (let ((cleaned-lambda-list (mapcar [iffi consp car] + (remql : lambda-list)))) + (with-gensyms (place-sym args-sym) + ^(defmacro ,name (:env env ,place-sym ,*lambda-list) + (with-update-expander (getter setter) ,place-sym env + ^(,setter (,',function (,getter) ,,*cleaned-lambda-list))))))) + +(defmacro sys:placelet-1 (((sym place)) :env env . body) + (with-gensyms (tmp-place pl-getter pl-setter) + (unwind-protect + (progn + ;; This temporary proxy place installed into the + ;; *place-update-expander* hash, and the forced expansion + ;; of the symacrolet form are necessary for correctness. + ;; If we don't perform that expand, then the temporary proxy + ;; place is not used, and sym ends up being an alias + ;; for the getter form (,',pl-getter) of the original place. + ;; Then, placelet will only work for places whose getter forms + ;; themselves places. This is not required in general. A (foo ...) + ;; place can, for instance, use (get-foo ...) and (set-foo ...) + ;; getters and setters, where (get-foo ...) is not a place. + ;; If sym turns into a symbol macro for a (get-foo ...) form, + ;; uses of sym as a place will fail due to get-foo not being a place. + (sethash *place-update-expander* tmp-place + (lambda (tmp-getter tmp-setter tmp-place tmp-body) + ^(macrolet ((,tmp-getter () ^(,',pl-getter)) + (,tmp-setter (val) ^(,',pl-setter ,val))) + ,tmp-body))) + (call-update-expander pl-getter pl-setter place env + ^(macrolet ((,tmp-place () ^(,',pl-getter))) + ,(expand ^(symacrolet ((,sym (,tmp-place))) + ,*body) env)))) + (remhash *place-update-expander* tmp-place)))) + +(defmacro placelet* (:form f sym-place-pairs . body) + (tree-case sym-place-pairs + (() ^(progn ,*body)) + (((sym place)) ^(sys:placelet-1 ((,sym ,place)) ,*body)) + (((sym place) . rest-pairs) ^(sys:placelet-1 ((,sym ,place)) + (placelet* (,*rest-pairs) ,*body))) + (obj (compile-error f "bad syntax: ~s" obj)))) + +(defmacro placelet (:form f sym-place-pairs . body) + (unless (all sym-place-pairs + [andf consp (opip length (= 2)) (oand first bindable)]) + (compile-error f "bad syntax: ~s" sym-place-pairs)) + (tree-bind (: syms places) (transpose sym-place-pairs) + (let ((temps (mapcar (ret (gensym)) syms))) + ^(placelet* (,*(zip temps places)) + (symacrolet (,*(zip syms temps)) + ,*body))))) + +(defun sys:register-simple-accessor (get-fun set-fun) + (sethash *place-update-expander* get-fun + (lambda (getter setter place body) + (let* ((args (cdr place)) + (temps (mapcar (ret (gensym)) args))) + ^(let (,(zip temps args)) + (macrolet ((,getter () ^(,',get-fun ,*',temps)) + (,setter (val) + ^(,',set-fun ,*',temps ,val))) + ,body))))) + (sethash *place-clobber-expander* get-fun + (lambda (ssetter place body) + ^(macrolet ((,ssetter (val) + ^(,',set-fun ,*(cdr ',place) ,val))) + ,body))) + get-fun) + +(defmacro define-accessor (get-fun set-fun) + ^(sys:register-simple-accessor ',get-fun ',set-fun)) + +(define-place-macro first (obj) ^(car ,obj)) +(define-place-macro rest (obj) ^(cdr ,obj)) +(define-place-macro second (obj) ^(ref ,obj 1)) +(define-place-macro third (obj) ^(ref ,obj 2)) +(define-place-macro fourth (obj) ^(ref ,obj 3)) +(define-place-macro fifth (obj) ^(ref ,obj 4)) +(define-place-macro sixth (obj) ^(ref ,obj 5)) +(define-place-macro seventh (obj) ^(ref ,obj 6)) +(define-place-macro eighth (obj) ^(ref ,obj 7)) +(define-place-macro ninth (obj) ^(ref ,obj 8)) +(define-place-macro tenth (obj) ^(ref ,obj 9)) + +(define-place-macro last (:env e obj : (n nil have-n)) + (cond + ((and have-n (constantp n e) (not (plusp n))) + ^(sub ,obj t t)) + ((and have-n (constantp n e)) + ^(sub ,obj ,(- n) t)) + (have-n + ^(sub ,obj (- (max ,n 0)) t)) + (t ^(sub ,obj -1 t)))) + +(define-place-macro butlast (:env e obj : (n nil have-n)) + (cond + ((and have-n (constantp n e) (not (plusp n))) + obj) + ((and have-n (constantp n e)) + ^(sub ,obj 0 ,(- n))) + (have-n + ^(sub ,obj 0 (- (max ,n 0)))) + (t ^(sub ,obj 0 -1)))) + +(define-place-macro nth (index obj) + ^(car (nthcdr ,index ,obj))) diff --git a/stdlib/pmac.tl b/stdlib/pmac.tl new file mode 100644 index 00000000..e439220c --- /dev/null +++ b/stdlib/pmac.tl @@ -0,0 +1,34 @@ +;; Copyright 2017-2021 +;; Kaz Kylheku <kaz@kylheku.com> +;; Vancouver, Canada +;; 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 HOLDER 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. + +(defmacro define-param-expander (keyword + (parms body : (env (gensym)) (form (gensym))) + . forms) + ^(progn + (set [*param-macro* ,keyword] + (lambda (,parms ,body ,env ,form) + ,*forms)) + ,keyword)) diff --git a/stdlib/quips.tl b/stdlib/quips.tl new file mode 100644 index 00000000..4b787209 --- /dev/null +++ b/stdlib/quips.tl @@ -0,0 +1,95 @@ +;; Copyright 2020-2021 +;; Kaz Kylheku <kaz@kylheku.com> +;; Vancouver, Canada +;; 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 HOLDER 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. + +(defvarl sys:%quips% + #("TXR was taped live before a studio audience. The laughter is genuine." + "Exclusive of recycled stuffing, TXR contains new materials only." + "TXR is not a toy, but should be kept within easy reach of children." + "Do not remove this label until TXR is delivered to the consumer." + "Remove TXR any time for a complete refund of your disk space." + "Store TXR in a cool, dry storage device. Keep out of direct sunlight." + "Do not operate heavy equipment or motor vehicles while using TXR." + "Use full-strength TXR for tough tasks, or dilute with shell scripts." + "TXR causes vomiting if accidentally ingested; no need to induce such." + "If unwanted side effects persist, discontinue imperative programming." + "TXR works even if the application surface is not free of dirt and grease." + "TXR may be used in areas that are not necessarily well ventilated." + "TXR's button pops up when original seal is broken." + "TXR is tested on nothing but animals (so to speak)." + "Disclaimer: TXR has been found to cure cancer in lab mice only." + "Garbage collection is on Tuesdays: bring unwanted pointers to curb by 7:30." + "Warning: may explode if heated, cooled or maintained at room temperature." + "TXR is made with 75% post-consumer recycled cons cells." + "Poke a few holes in TXR with a fork before heating in the microwave." + "Caution: objects in heap are farther from reality than they appear." + "TXR doesn't really whip the llama's ass so much as the lambda's." + "TXR is recommended for either internal or external use. Whatever, y'know?" + "TXR is enteric coated to release over 24 hours of lasting relief." + "TXR contains many small parts, unsuitable for children under 12 months." + "TXR is packaged by the byte; contents may compress during shipping." + "Discontinue coding TXR if experiencing dizziness or shortness of breath." + "Self-assembly keeps TXR costs low; but ask about our installation service!" + "Some mild discoloration of syntax highlighting may occur with age." + "TXR is made with equipment not contaminated by peanuts ... r-r-right?" + "TXR is believed by fools to be free of defects in workmanship and materials." + "Adults using TXR should be closely supervised by children." + "TXR may be worn in seven different ways, in any weather." + "TXR is light and portable; take it camping, or to the Bahamas." + "Psst! The complimentary Allen key that comes with TXR is inpired by IKEA." + "Ethically produced using volunteer geek labor in a first world country." + "Program contains violence and coarse language, demanding user indiscretion." + "TXR is written, directed and produced by, not to mention starring, Kaz." + "Emergency exits are located in the standard library." + "Your history may used for automatic recommendations, like 'stick to Python'." + "Without the generosity of users like you, this program would exist just fine." + "TXR's no-spray organic production means every bug is carefully removed by hand." + "Upgrade to TXR Pro for a one-time fee of learning Lisp!" + "When transferring between containers, do not siphon TXR by mouth." + "Use TXR only as directed. Unless you are intelligent, curious and creative." + "Reminder: your account balance of 37 closing parentheses is past due." + "Check with your physician before commencing any strenuous Lisp program." + "Apply today for a TXR credit card, and get 1MB off your next allocation." + "Join TXR Rewards now, and get 15000 closing parentheses you can use anywhere." + "TXR's car insurance now offers cdr coverage for bumper-to-bumper protection." + "Please listen carefully to the following spec, as our Lisp has changed." + "If TXR were TV, it would require music by Mike Post and Peter Carpenter." + "TXR was set to appear on the cover of SI. Yeah, no. Learned about the jinx." + " |E|\n|V A N|\n |S|\n |T|" + "Lispが好き、とても好き、私はLispの...全てにいつも...夢中なの。" + "こんな広い分野の中、私が愛する...言語なら、やはり...Lispだけ。" + "This area is under 24 hour TTY surveillance." + "Imitation is the benignest form of forgery." + "This could be the year of the TXR desktop; I can feel it!" + )) + +(defparml sys:%quip-rand-state% (make-random-state)) + +(defvarl sys:%shuffled-quips%) + +(defun quip () + (unless sys:%shuffled-quips% + (set sys:%shuffled-quips% (shuffle sys:%quips% sys:%quip-rand-state%))) + (pop sys:%shuffled-quips%)) diff --git a/stdlib/save-exe.tl b/stdlib/save-exe.tl new file mode 100644 index 00000000..e645c10a --- /dev/null +++ b/stdlib/save-exe.tl @@ -0,0 +1,38 @@ +;; Copyright 2019-2021 +;; Kaz Kylheku <kaz@kylheku.com> +;; Vancouver, Canada +;; 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 HOLDER 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. + +(defun save-exe (path string) + (let* ((fbuf (file-get-buf txr-exe-path)) + (bs (make-buf-stream fbuf)) + (pre (progn + (stream-set-prop bs :byte-oriented t) + (scan-until-match #/@\(txr\)/ bs))) + (sbuf (ffi-put string (ffi (zarray 128 char))))) + (unless pre + (throwf 'error "~s: ~a isn't a TXR executable" 'save-txr-exe path)) + (put-buf sbuf 0 bs) + (file-put-buf path fbuf) + (chmod path #o766))) diff --git a/stdlib/socket.tl b/stdlib/socket.tl new file mode 100644 index 00000000..58f81e61 --- /dev/null +++ b/stdlib/socket.tl @@ -0,0 +1,273 @@ +;; Copyright 2016-2021 +;; Kaz Kylheku <kaz@kylheku.com> +;; Vancouver, Canada +;; 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 HOLDER 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. + +(defstruct sockaddr nil + (:static family nil)) + +(defstruct sockaddr-in sockaddr + (addr 0) (port 0) + (prefix 32) + (:static family af-inet)) + +(defstruct sockaddr-in6 sockaddr + (addr 0) (port 0) (flow-info 0) (scope-id 0) + (prefix 128) + (:static family af-inet6)) + +(defstruct sockaddr-un sockaddr + path + (:static family af-unix)) + +(defstruct addrinfo nil + (flags 0) + (family 0) + (socktype 0) + (protocol 0) + (canonname 0)) + +(defvarl shut-rd 0) +(defvarl shut-wr 1) +(defvarl shut-rdwr 2) + +(defun str-inaddr (addr : port) + (let ((d (logand addr #xFF)) + (c (logand (ash addr -8) #xFF)) + (b (logand (ash addr -16) #xFF)) + (a (ash addr -24)) + (p (if port `:@port` ""))) + (if (or (> a 255) (minusp a)) + (throwf 'eval-error "~s: ~a out of range for IPv4 address" + 'str-inaddr addr) + `@a.@b.@c.@d@p`))) + + +(defun sys:in6addr-condensed-text (numeric-pieces) + (let* ((str (cat-str [mapcar (op fmt "~x") numeric-pieces] ":")) + (zr (rra #/0(:0)+/ str)) + (lp [pos-max zr : [callf - to from]]) + (lr [zr lp])) + (when lp + (del [str lr])) + (cond + ((equal "" str) "::") + ((starts-with ":" str) `:@str`) + ((ends-with ":" str) `@str:`) + (t str)))) + +(defun str-in6addr (addr : port) + (let ((str (if (and (<= (width addr) 48) + (= (ash addr -32) #xFFFF)) + `::ffff:@(str-inaddr (logtrunc addr 32))` + (let* ((pieces (let ((count 8)) + (nexpand-left (lambda (val) + (if (minusp (dec count)) + (unless (zerop val) + (throwf 'eval-error + "~s: \ + \ ~a out of range \ + \ for IPv6 address" + 'str-in6addr + addr)) + (cons (logand val #xFFFF) + (ash val -16)))) + addr)))) + (sys:in6addr-condensed-text pieces))))) + (if port + `[@str]:@port` + str))) + +(defun sys:str-inaddr-net-impl (addr wextra : weff) + (let ((mask addr)) + (set mask (logior mask (ash mask 1))) + (set mask (logior mask (ash mask 2))) + (set mask (logior mask (ash mask 4))) + (set mask (logior mask (ash mask 8))) + (set mask (logior mask (ash mask 16))) + (let* ((w (- 32 (width (lognot mask 32)))) + (d (logand addr #xFF)) + (c (logand (ash addr -8) #xFF)) + (b (logand (ash addr -16) #xFF)) + (a (ash addr -24)) + (we (or weff (+ w wextra)))) + (cond + ((or (> a 255) (minusp a)) + (throwf 'eval-error "~s: ~a out of range for IPv4 address" + 'str-inaddr-net addr)) + ((> w 24) `@a.@b.@c.@d/@we`) + ((> w 16) `@a.@b.@c/@we`) + ((> w 8) `@a.@b/@we`) + (t `@a/@we`))))) + +(defun str-inaddr-net (addr : width) + (sys:str-inaddr-net-impl addr 0 width)) + +(defun str-in6addr-net (addr : width) + (if (and (<= (width addr) 48) + (= (ash addr -32) #xFFFF)) + `::ffff:@(sys:str-inaddr-net-impl (logtrunc addr 32) 96 width)` + (let ((mask addr)) + (set mask (logior mask (ash mask 1))) + (set mask (logior mask (ash mask 2))) + (set mask (logior mask (ash mask 4))) + (set mask (logior mask (ash mask 8))) + (set mask (logior mask (ash mask 16))) + (set mask (logior mask (ash mask 32))) + (set mask (logior mask (ash mask 64))) + (let* ((w (- 128 (width (lognot mask 128)))) + (pieces (let ((count 8)) + (nexpand-left (lambda (val) + (if (minusp (dec count)) + (unless (zerop val) + (throwf 'eval-error + "~s: \ + \ ~a out of range \ + \ for IPv6 address" + 'str-in6addr-net + addr)) + (cons (logand val #xFFFF) + (ash val -16)))) + addr))) + (cand-prefix [pieces 0..(trunc (+ w 15) 16)]) + (prefix (if (search cand-prefix '(0 0)) pieces cand-prefix))) + `@(sys:in6addr-condensed-text prefix)/@(or width w)`)))) + +(defun inaddr-str (str) + (labels ((invalid () + (error "~s: invalid address ~s" 'inaddr-str str)) + (mkaddr (octets port) + (unless [all octets (op <= 0 @1 255)] + (invalid)) + (unless (<= 0 port 65535) + (invalid)) + (new sockaddr-in + addr (+ (ash (pop octets) 24) + (ash (pop octets) 16) + (ash (pop octets) 8) + (car octets)) + port port)) + (mkaddr-pf (octets prefix port) + (unless [all octets (op <= 0 @1 255)] + (invalid)) + (unless (<= 0 prefix 32) + (invalid)) + (unless (<= 0 port 65535) + (invalid)) + (let* ((addr (+ (ash (or (pop octets) 0) 24) + (ash (or (pop octets) 0) 16) + (ash (or (pop octets) 0) 8) + (or (car octets) 0)))) + (new sockaddr-in + addr (logand addr (ash -1 (- 32 prefix))) + port port + prefix prefix)))) + (cond + ((r^$ #/\d+\.\d+\.\d+\.\d+:\d+/ str) + (tree-bind (addr port) (split* str (rpos #\: str)) + (mkaddr [mapcar toint (spl #\. addr)] (toint port)))) + ((r^$ #/\d+\.\d+\.\d+\.\d+(:\d+)?/ str) + (mkaddr [mapcar toint (spl #\. str)] 0)) + ((r^$ #/\d+(\.\d+(\.\d+(\.\d+)?)?)?\/\d+/ str) + (tree-bind (addr prefix) (spl #\/ str) + (mkaddr-pf [mapcar toint (spl #\. addr)] (toint prefix) 0))) + ((r^$ #/\d+(\.\d+(\.\d+(\.\d+)?)?)?\/\d+:\d+/ str) + (tree-bind (addr prefix port) (split-str-set str ":/") + (mkaddr-pf [mapcar toint (spl #\. addr)] (toint prefix) (toint port)))) + (t (invalid))))) + +(defun in6addr-str (str) + (labels ((invalid () + (error "~s: invalid address ~s" 'in6addr-str str)) + (mkaddr-full (pieces) + (unless [all pieces (op <= 0 @1 #xffff)] + (invalid)) + (unless (eql 8 (length pieces)) + (invalid)) + (new sockaddr-in6 + addr (reduce-left (op + @2 (ash @1 16)) pieces))) + (mkaddr-brev (pieces-x pieces-y) + (let ((len-x (len pieces-x)) + (len-y (len pieces-y))) + (unless (<= (+ len-x len-y) 7) + (invalid)) + (let* ((val-x (reduce-left (op + @2 (ash @1 16)) pieces-x 0)) + (val-y (reduce-left (op + @2 (ash @1 16)) pieces-y 0)) + (addr (cond + ((null pieces-x) val-y) + ((null pieces-y) (ash val-x (* 16 (- 8 len-x)))) + (t (+ val-y + (ash val-x (* 16 (- 8 len-x)))))))) + (new sockaddr-in6 + addr addr)))) + (str-to-pieces (str) + (unless (empty str) + [mapcar (lop toint 16) (spl #\: str)])) + (octets-to-pieces (octets) + (unless [all octets (op <= 0 @1 255)] + (invalid)) + (list (+ (ash (pop octets) 8) + (pop octets)) + (+ (ash (pop octets) 8) + (pop octets))))) + (cond + ((r^$ #/\[.*\]:\d+/ str) + (tree-bind (addr-str port-str) (split* str (rpos #\: str)) + (let ((addr (in6addr-str [addr-str 1..-1])) + (port (toint port-str))) + (unless (<= 0 port 65535) + (invalid)) + (set addr.port port) + addr))) + ((r^$ #/[^\/]+\/\d+/ str) + (tree-bind (addr-str prefix-str) (split* str (rpos #\/ str)) + (let ((addr (in6addr-str addr-str)) + (prefix (toint prefix-str))) + (unless (<= 0 prefix 128) + (invalid)) + (upd addr.addr (logand (ash -1 (- 128 prefix)))) + (set addr.prefix prefix) + addr))) + ((r^$ #/[\da-fA-F]*(:[\da-fA-F]*)*/ str) + (upd str (regsub #/::/ "@")) + (let* ((str-splat (regsub #/::/ "@" str)) + (maj-pieces (spl #\@ str-splat))) + (caseql (len maj-pieces) + (1 (mkaddr-full (str-to-pieces (car maj-pieces)))) + (2 (mkaddr-brev (str-to-pieces (car maj-pieces)) + (str-to-pieces (cadr maj-pieces)))) + (t (invalid))))) + ((r^$ #/::0*[fF][fF][fF][fF]:\d+\.\d+\.\d+\.\d+/ str) + (let* ((bigsplit (split* str (rpos #\: str))) + (4part (cadr bigsplit)) + (octets [mapcar toint (spl #\. 4part)]) + (pieces (cons #xffff (octets-to-pieces octets)))) + (mkaddr-brev nil pieces))) + (t (invalid))))) + +(defplace (sock-peer sock) body + (getter setter + ^(macrolet ((,getter () ^(sock-peer ',',sock)) + (,setter (val) ^(sock-set-peer ,',sock ,val))) + ,body))) diff --git a/stdlib/stream-wrap.tl b/stdlib/stream-wrap.tl new file mode 100644 index 00000000..042af813 --- /dev/null +++ b/stdlib/stream-wrap.tl @@ -0,0 +1,68 @@ +;; Copyright 2017-2021 +;; Kaz Kylheku <kaz@kylheku.com> +;; Vancouver, Canada +;; 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 HOLDER 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. + +(defstruct stream-wrap nil + stream + (:method put-string (me str) + (put-string str me.stream)) + (:method put-char (me chr) + (put-char chr me.stream)) + (:method put-byte (me byte) + (put-byte byte me.stream)) + (:method get-line (me) + (get-line me.stream)) + (:method get-char (me) + (get-char me.stream)) + (:method get-byte (me) + (get-byte me.stream)) + (:method unget-char (me chr) + (unget-char chr me.stream)) + (:method unget-byte (me byte) + (unget-byte byte me.stream)) + (:method put-buf (me buf pos) + (put-buf buf pos me.stream)) + (:method fill-buf (me buf pos) + (fill-buf buf pos me.stream)) + (:method close (me) + (close-stream me.stream)) + (:method flush (me) + (flush-stream me.stream)) + (:method seek (me offs whence) + (seek-stream me.stream offs whence)) + (:method truncate (me len) + (truncate-stream me.stream len)) + (:method get-prop (me sym) + (stream-get-prop me.stream sym)) + (:method set-prop (me sym nval) + (stream-set-prop me.stream sym nval)) + (:method get-error (me) + (get-error me.stream)) + (:method get-error-str (me) + (get-error-str me.stream)) + (:method clear-error (me) + (clear-error me.stream)) + (:method get-fd (me) + (fileno me.stream))) diff --git a/stdlib/struct.tl b/stdlib/struct.tl new file mode 100644 index 00000000..bd62637f --- /dev/null +++ b/stdlib/struct.tl @@ -0,0 +1,378 @@ +;; Copyright 2015-2021 +;; Kaz Kylheku <kaz@kylheku.com> +;; Vancouver, Canada +;; 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 HOLDER 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. + +(defun sys:bad-slot-syntax (form arg) + (compile-error form "bad slot syntax ~s" arg)) + +(defun sys:prune-missing-inits (slot-init-forms) + (remove-if (tb ((kind name : (init-form nil init-form-present))) + (and (member kind '(:static :instance :function)) + (not init-form-present))) + slot-init-forms)) + +(defmacro defstruct (:form form name-spec super-spec . slot-specs) + (tree-bind (name args) (tree-case name-spec + ((atom . args) (list atom args)) + (atom (list atom nil))) + (unless (bindable name) + (compile-error form "~s isn't a bindable symbol" name)) + (unless (proper-listp slot-specs) + (compile-error form "bad syntax: dotted form")) + (let* ((instance-init-form nil) + (instance-postinit-form nil) + (instance-fini-form nil) + (slot-init-forms (collect-each ((slot slot-specs)) + (tree-case slot + ((word name args . body) + (caseq word + (:method + (when (not args) + (compile-error form + "method ~s needs \ + \ at least one parameter" + name)) + ^(:function ,name + (lambda ,args + (block ,name ,*body)))) + (:function ^(,word ,name + (lambda ,args + (block ,name + ,*body)))) + ((:static :instance) + (when body + (sys:bad-slot-syntax form slot)) + ^(,word ,name ,args)) + (t :))) + ((word (arg) . body) + (caseq word + (:init + (unless (bindable arg) + (sys:bad-slot-syntax form slot)) + (when instance-init-form + (compile-error form + "duplicate :init")) + (set instance-init-form + (cons arg body)) + ^(,word nil nil)) + (:postinit + (unless (bindable arg) + (sys:bad-slot-syntax form slot)) + (when instance-postinit-form + (compile-error form + "duplicate :postinit")) + (set instance-postinit-form + (cons arg body)) + ^(,word nil nil)) + (:fini + (unless (bindable arg) + (sys:bad-slot-syntax form slot)) + (when instance-fini-form + (compile-error form + "duplicate :fini")) + (set instance-fini-form + (cons arg body)) + ^(,word nil nil)) + (t (when body + (sys:bad-slot-syntax form slot)) + :))) + ((word name) + (caseq word + ((:static) + ^(,word ,name)) + ((:instance) + ^(,word ,name nil)) + ((:method :function) + (sys:bad-slot-syntax form slot)) + (t ^(:instance ,word ,name)))) + ((name) + ^(:instance ,name nil)) + (name + ^(:instance ,name nil))))) + (supers (if (and super-spec (atom super-spec)) + (list super-spec) + super-spec)) + (stat-si-forms [keep-if (op member @1 '(:static :function)) + slot-init-forms car]) + (pruned-si-forms (sys:prune-missing-inits stat-si-forms)) + (func-si-forms [keep-if (op eq :function) pruned-si-forms car]) + (val-si-forms [keep-if (op eq :static) pruned-si-forms car]) + (inst-si-forms [keep-if (op eq :instance) slot-init-forms car]) + (stat-slots [mapcar second stat-si-forms]) + (inst-slots [mapcar second inst-si-forms])) + (whenlet ((bad [find-if [notf bindable] + (append stat-slots inst-slots)])) + (compile-error form + (if (symbolp bad) + "slot name ~s isn't a bindable symbol" + "invalid slot specifier syntax: ~s") + bad)) + (each ((s supers)) + (or (find-struct-type s) + (compile-defr-warning form ^(struct-type . ,s) + "inheritance base ~s \ + \ does not name a struct type" + s))) + (let ((arg-sym (gensym)) + (type-sym (gensym))) + (register-tentative-def ^(struct-type . ,name)) + (each ((s stat-slots)) + (register-tentative-def ^(slot . ,s))) + (each ((s inst-slots)) + (register-tentative-def ^(slot . ,s))) + ^(sys:make-struct-type + ',name ',supers ',stat-slots ',inst-slots + ,(if (or func-si-forms val-si-forms) + ^(lambda (,arg-sym) + ,*(mapcar (aret ^(when (static-slot-p ,arg-sym ',@2) + (static-slot-set ,arg-sym ',@2 ,@3))) + (append func-si-forms val-si-forms)))) + ,(if (or inst-si-forms instance-init-form instance-fini-form) + ^(lambda (,arg-sym) + ,*(if (cdr instance-fini-form) + ^((finalize ,arg-sym (lambda (,(car instance-fini-form)) + ,*(cdr instance-fini-form)) + t))) + ,*(if inst-si-forms + ^((let ((,type-sym (struct-type ,arg-sym))) + ,*(mapcar (aret ^(unless (static-slot-p ,type-sym ',@2) + (slotset ,arg-sym ',@2 ,@3))) + inst-si-forms)))) + ,*(if (cdr instance-init-form) + ^((let ((,(car instance-init-form) ,arg-sym)) + ,*(cdr instance-init-form)))))) + ,(when args + (when (> (countql : args) 1) + (compile-error form + "multiple colons in boa syntax")) + (let ((col-pos (posq : args))) + (let ((req-args [args 0..col-pos]) + (opt-args (if col-pos [args (succ col-pos)..:]))) + (let ((r-gens (mapcar (ret (gensym)) req-args)) + (o-gens (mapcar (ret (gensym)) opt-args)) + (p-gens (mapcar (ret (gensym)) opt-args))) + ^(lambda (,arg-sym ,*r-gens + ,*(if opt-args '(:)) + ,*(if opt-args + (mapcar (ret ^(,@1 nil ,@2)) + o-gens p-gens))) + ,*(mapcar (ret ^(slotset ,arg-sym ',@1 ,@2)) + req-args r-gens) + ,*(mapcar (ret ^(if ,@3 + (slotset ,arg-sym ',@1 ,@2))) + opt-args o-gens p-gens)))))) + ,(if instance-postinit-form + ^(lambda (,arg-sym) + ,*(if (cdr instance-postinit-form) + ^((let ((,(car instance-postinit-form) ,arg-sym)) + ,*(cdr instance-postinit-form))))))))))) + +(defmacro sys:struct-lit (name . plist) + ^(sys:make-struct-lit ',name ',plist)) + +(defun sys:check-slot (form slot) + (unless (or (sys:slot-types slot) + (sys:static-slot-types slot)) + (compile-defr-warning form ^(slot . ,slot) + "symbol ~s isn't the name of a struct slot" + slot)) + slot) + +(defun sys:check-struct (form stype) + (unless (find-struct-type stype) + (compile-defr-warning form ^(struct-type . ,stype) + "~s does not name a struct type" + stype))) + +(defmacro qref (:form form obj . refs) + (when (null refs) + (throwf 'eval-error "~s: bad syntax" 'qref)) + (tree-case obj + ((a b) (if (eq a 't) + (let ((s (gensym))) + ^(slet ((,s ,b)) + (if ,s (qref ,s ,*refs)))) + :)) + (x (tree-case refs + (() ()) + (((pref sym) . more) + (if (eq pref t) + (let ((s (gensym))) + ^(let ((,s (qref ,obj ,sym))) + (if ,s (qref ,s ,*more)))) + :)) + (((dw sym . args)) + (if (eq dw 'dwim) + (let ((osym (gensym))) + (sys:check-slot form sym) + ^(slet ((,osym ,obj)) + ,(if (and (plusp sys:compat) (<= sys:compat 251)) + ^[(slot ,osym ',sym) ,*args] + ^[(slot ,osym ',sym) ,osym ,*args]))) + :)) + (((dw sym . args) . more) + (if (eq dw 'dwim) + (let ((osym (gensym))) + (sys:check-slot form sym) + ^(qref (slet ((,osym ,obj)) + ,(if (and (plusp sys:compat) (<= sys:compat 251)) + ^[(slot ,osym ',sym) ,*args] + ^[(slot ,osym ',sym) ,osym ,*args])) ,*more)) + :)) + (((sym . args)) + (let ((osym (gensym))) + (sys:check-slot form sym) + ^(slet ((,osym ,obj)) + (call (slot ,osym ',sym) ,osym ,*args)))) + (((sym . args) . more) + (let ((osym (gensym))) + (sys:check-slot form sym) + ^(qref (slet ((,osym ,obj)) + (call (slot ,osym ',sym) ,osym ,*args)) ,*more))) + ((sym) + (sys:check-slot form sym) + ^(slot ,obj ',sym)) + ((sym . more) + (sys:check-slot form sym) + ^(qref (slot ,obj ',sym) ,*more)) + (obj (throwf 'eval-error "~s: bad syntax: ~s" 'qref refs)))))) + +(defmacro uref (. args) + (cond + ((null args) (throwf 'eval-error "~s: bad syntax" 'uref)) + ((null (cdr args)) + (if (consp (car args)) + ^(umeth ,*(car args)) + ^(usl ,(car args)))) + ((eq t (car args)) + (with-gensyms (ovar) + ^(lambda (,ovar) (qref (t ,ovar) ,*(cdr args))))) + (t (with-gensyms (ovar) + ^(lambda (,ovar) (qref ,ovar ,*args)))))) + +(defun sys:new-type (op form type) + (caseq op + ((new lnew) (sys:check-struct form type) ^',type) + (t type))) + +(defun sys:new-expander (op form spec pairs) + (when (oddp (length pairs)) + (compile-error form "slot initform arguments must occur pairwise")) + (let ((qpairs (mappend (aret ^(',@1 ,@2)) (tuples 2 pairs)))) + (tree-case spec + ((texpr . args) + (let ((type (sys:new-type op form texpr))) + (caseq op + ((new new*) (if qpairs + ^(make-struct ,type (list ,*qpairs) ,*args) + ^(struct-from-args ,type ,*args))) + ((lnew lnew*) ^(make-lazy-struct ,type + (lambda () + (cons (list ,*qpairs) + (list ,*args)))))))) + (texpr + (let ((type (sys:new-type op form texpr))) + (caseq op + ((new new*) ^(struct-from-plist ,type ,*qpairs)) + ((lnew lnew*) ^(make-lazy-struct ,type + (lambda () + (list (list ,*qpairs))))))))))) + +(defmacro new (:form form spec . pairs) + (sys:new-expander (car form) form spec pairs)) + +(defmacro new* (:form form spec . pairs) + (sys:new-expander (car form) form spec pairs)) + +(defmacro lnew (:form form spec . pairs) + (sys:new-expander (car form) form spec pairs)) + +(defmacro lnew* (:form form spec . pairs) + (sys:new-expander (car form) form spec pairs)) + +(defmacro meth (obj slot . bound-args) + ^[(fun method) ,obj ',slot ,*bound-args]) + +(defmacro usl (:form form slot) + (sys:check-slot form slot) + ^(uslot ',slot)) + +(defmacro umeth (:form form slot . bound-args) + (sys:check-slot form slot) + ^[(fun umethod) ',slot ,*bound-args]) + +(defun sys:define-method (type-sym name fun) + (caseq name + (:init (struct-set-initfun type-sym fun)) + (:postinit (struct-set-postinitfun type-sym fun)) + (t (static-slot-ensure type-sym name fun))) + ^(meth ,type-sym ,name)) + +(defmacro defmeth (:form form type-sym name arglist . body) + (cond + ((not (bindable type-sym)) + (compile-error form "~s isn't a valid struct name" type-sym)) + ((not (find-struct-type type-sym)) + (compile-defr-warning form ^(struct-type . ,type-sym) + "definition of struct ~s not seen here" type-sym))) + (register-tentative-def ^(slot . ,name)) + ^(sys:define-method ',type-sym ',name (lambda ,arglist + (block ,name ,*body)))) + +(defmacro with-slots ((. slot-specs) obj-expr . body) + (with-gensyms (obj-sym) + ^(let ((,obj-sym ,obj-expr)) + (symacrolet (,*(mapcar [iff consp + (aret ^(,@1 (slot ,obj-sym ',@2))) + (ret ^(,@1 (slot ,obj-sym ',@1)))] + slot-specs)) + ,*body)))) + +(defun sys:rslotset (struct sym meth-sym val) + (prog1 + (slotset struct sym val) + (call (umethod meth-sym) struct))) + +(defmacro usr:rslot (struct sym meth-sym) + ^(slot ,struct ,sym)) + +(define-place-macro usr:rslot (struct sym meth-sym) + ^(sys:rslot ,struct ,sym ,meth-sym)) + +(defplace (sys:rslot struct sym meth-sym) body + (getter setter + (with-gensyms (struct-sym slot-sym meth-slot-sym) + ^(slet ((,struct-sym ,struct) + (,slot-sym ,sym) + (,meth-slot-sym ,meth-sym)) + (macrolet ((,getter () ^(slot ,',struct-sym ,',slot-sym)) + (,setter (val) ^(sys:rslotset ,',struct-sym ,',slot-sym + ,',meth-slot-sym ,val))) + ,body)))) + (ssetter + ^(macrolet ((,ssetter (val) ^(progn + (sys:rslotset ,',struct ,',sym + ,',meth-sym ,val)))) + ,body))) diff --git a/stdlib/tagbody.tl b/stdlib/tagbody.tl new file mode 100644 index 00000000..ed670871 --- /dev/null +++ b/stdlib/tagbody.tl @@ -0,0 +1,72 @@ +;; Copyright 2016-2021 +;; Kaz Kylheku <kaz@kylheku.com> +;; Vancouver, Canada +;; 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 HOLDER 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. + +(defmacro tagbody (:env env . forms) + (when forms + (let* ((tb-id (gensym "tb-id-")) + (next-var (gensym "next-")) + (bblocks (partition forms (op where [orf symbolp integerp chrp]))) + (start-lbl (if bblocks [[orf symbolp integerp chrp] (caar bblocks)]))) + (unless start-lbl + (push (gensym "entry-") (car bblocks))) + (if (and (not start-lbl) (not (cdr bblocks))) + ^(progn nil ,*forms nil) + (let* ((lbls [mapcar car bblocks]) + (forms [mapcar cdr bblocks]) + ;; This trickery transform the individually labeled form + ;; blocks into branches, such that each branch falls through + ;; to the next one thanks to substructure sharing. + (threaded-1 (mapcar (op member-if true) (conses forms))) + (threaded-2 [apply nconc forms]) ;; important side effect + (codes [mapcar car threaded-1])) + (unless (eql (length (uniq lbls)) (length lbls)) + (throwf 'eval-error "~s: duplicate labels occur" 'tagbody)) + (let* ((basic-code ^(let ((,tb-id (gensym "tb-dyn-id-")) + (,next-var 0)) + (sys:for-op () + (,next-var) + ((set ,next-var + (block* ,tb-id + (sys:switch ,next-var #(,*codes)) + nil))))))) + ^(macrolet ((go (:form form label) + (let ((index (posql label ',lbls))) + (if index ^(return* ,',tb-id ,index) form)))) + ,basic-code))))))) + +(defmacro go (label) + (if [[orf symbolp integerp chrp] label] + (throwf 'eval-error "~s: no ~s label visible" 'go label) + (throwf 'eval-error "~s: ~s isn't a symbol, integer or character" 'go label))) + + +(defmacro prog (vars . body) + ^(block nil + (let ,vars (tagbody ,*body)))) + +(defmacro prog* (vars . body) + ^(block nil + (let* ,vars (tagbody ,*body)))) diff --git a/stdlib/termios.tl b/stdlib/termios.tl new file mode 100644 index 00000000..5d2423dc --- /dev/null +++ b/stdlib/termios.tl @@ -0,0 +1,79 @@ +;; Copyright 2016-2021 +;; Kaz Kylheku <kaz@kylheku.com> +;; Vancouver, Canada +;; 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 HOLDER 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. + +(defmeth termios set-iflags (tio . values) + (set tio.iflag (logior tio.iflag . values))) + +(defmeth termios set-oflags (tio . values) + (set tio.oflag (logior tio.oflag . values))) + +(defmeth termios set-cflags (tio . values) + (set tio.cflag (logior tio.cflag . values))) + +(defmeth termios set-lflags (tio . values) + (set tio.lflag (logior tio.lflag . values))) + +(defmeth termios clear-iflags (tio . values) + (set tio.iflag (logand tio.iflag (lognot (logior . values))))) + +(defmeth termios clear-oflags (tio . values) + (set tio.oflag (logand tio.oflag (lognot (logior . values))))) + +(defmeth termios clear-cflags (tio . values) + (set tio.cflag (logand tio.cflag (lognot (logior . values))))) + +(defmeth termios clear-lflags (tio . values) + (set tio.lflag (logand tio.lflag (lognot (logior . values))))) + +(defmeth termios go-raw (tio) + tio.(clear-iflags ignbrk brkint parmrk istrip inlcr igncr icrnl ixon) + tio.(clear-oflags opost) + tio.(clear-cflags csize parenb) + tio.(clear-lflags echo echonl icanon isig) + (if (boundp 'iexten) + tio.(clear-lflags iexten)) + tio.(set-cflags cs8) + (set [tio.cc vmin] 1) + (set [tio.cc vtime] 0)) + +(defmeth termios go-cbreak (tio) + tio.(clear-iflags icrnl) + tio.(clear-lflags icanon) + tio.(set-lflags isig) + (set [tio.cc vmin] 1) + (set [tio.cc vtime] 0)) + +(defmeth termios string-encode (tio) + (let ((*print-base* 16)) + tio.(sys:encode-speeds) + (downcase-str `@{tio.iflag}:@{tio.oflag}:@{tio.cflag}:@{tio.lflag}:\ + @{(list-vec tio.cc) ":"}`))) + +(defmeth termios string-decode (tio string) + (let ((vals (mapcar (op int-str @1 16) (split-str string ":")))) + (lset tio.iflag tio.oflag tio.cflag tio.lflag vals) + (set tio.cc (vec-list (cddddr vals))) + tio.(sys:decode-speeds))) diff --git a/stdlib/trace.tl b/stdlib/trace.tl new file mode 100644 index 00000000..8c0fbd4c --- /dev/null +++ b/stdlib/trace.tl @@ -0,0 +1,123 @@ +;; Copyright 2016-2021 +;; Kaz Kylheku <kaz@kylheku.com> +;; Vancouver, Canada +;; 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 HOLDER 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. + +(defvar *trace-output* *stdout*) + +(defvar sys:*trace-hash* (hash :equal-based)) +(defvar sys:*trace-level* -1) + +(defvarl sys:tr* (fun *)) +(defvarl sys:trfm (fun format)) + +(defun sys:trace-enter (name args) + [sys:trfm *trace-output* "~*a(~s ~s\n" [sys:tr* sys:*trace-level* 2] "" name args]) + +(defun sys:trace-leave (name val) + [sys:trfm *trace-output* "~*a ~s)\n" [sys:tr* sys:*trace-level* 2] "" val]) + +(defun sys:trace-canonicalize-name (name) + (if (and (consp name) + (eq (car name) 'meth)) + (let* ((req-type-sym (cadr name)) + (slot-sym (caddr name)) + (req-type (find-struct-type req-type-sym)) + (s-s-p (if req-type + (static-slot-p req-type slot-sym))) + (actual-type-sym (if s-s-p + (static-slot-home req-type-sym slot-sym)))) + (if (and s-s-p (neq req-type-sym actual-type-sym)) + ^(meth ,actual-type-sym ,slot-sym) + name)) + name)) + +(defun sys:trace (names) + (cond + ((null names) (hash-keys sys:*trace-hash*)) + (t + (each ((orig-n names) + (n [mapcar sys:trace-canonicalize-name names])) + (unless [sys:*trace-hash* n] + (when (neq n orig-n) + (usr:catch + (throwf 'warning "~s: ~s is actually ~s: tracing that instead" + 'trace orig-n n) + (continue ()))) + (let* ((prev (or (symbol-function n) + (throwf 'eval-error + "~s: ~s does not name a function" 'trace n))) + (lex-n n) + (hook (lambda (. args) + (let ((abandoned t) + (sys:*trace-level* (succ sys:*trace-level*))) + (unwind-protect + (progn + (sys:trace-enter lex-n args) + (let ((val (apply prev args))) + (sys:trace-leave lex-n val) + (set abandoned nil) + val)) + (if abandoned + (sys:trace-leave lex-n :abandoned))))))) + (set (symbol-function n) hook + [sys:*trace-hash* n] prev))))))) + +(defun sys:untrace (names) + (flet ((disable (name-orig name) + (let ((prev (del [sys:*trace-hash* name]))) + (when prev + (when (neq name-orig name) + (usr:catch + (throwf 'warning "~s: ~s is actually ~s: untracing that instead" + 'trace name-orig name) + (continue ()))) + (set (symbol-function name) prev))))) + (if names + (each ((n-orig names) + (n [mapcar sys:trace-canonicalize-name names])) + (disable n-orig n)) + (dohash (n v sys:*trace-hash*) + (disable n n))))) + +(defun sys:trace-redefine-check (orig-name) + (let ((name (sys:trace-canonicalize-name orig-name))) + (when [sys:*trace-hash* name] + (usr:catch + (cond + ((neq name orig-name) + (throwf 'warning "~!~s won't be traced, though it overrides\n\ + ~s which is currently traced" + name orig-name)) + (t (sys:untrace (list name)) + (throwf 'warning "previously traced ~s is redefined and no\ \ + longer traced" + name))) + (continue ()))))) + +(defmacro usr:trace (. names) + ^(sys:trace ',names)) + +(defmacro usr:untrace (. names) + ^(sys:untrace ',names)) diff --git a/stdlib/txr-case.tl b/stdlib/txr-case.tl new file mode 100644 index 00000000..244c58b7 --- /dev/null +++ b/stdlib/txr-case.tl @@ -0,0 +1,70 @@ +;; Copyright 2015-2021 +;; Kaz Kylheku <kaz@kylheku.com> +;; Vancouver, Canada +;; 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 HOLDER 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. + +(defmacro txr-if (name args input : then else) + (let ((syms (keep-if [andf true symbolp [notf keywordp] [notf (op eq t)]] + args)) + (arg-exprs [mapcar [iffi symbolp (ret ^',@1)] args]) + (result (gensym "res-")) + (bindings (gensym "bindings-")) + (insym (gensym "input-"))) + ^(let* ((,insym ,input) + (,result (match-fun ',name (list ,*arg-exprs) + (if (stringp ,insym) (list ,insym) ,insym) + nil))) + (if ,result + (let ((,bindings (car ,result))) + (let (,*[mapcar (ret ^(,@1 (cdr (assoc ',@1 ,bindings)))) + syms]) + ,then)) + ,else)))) + +(defmacro txr-when (name args input . body) + ^(txr-if ,name ,args ,input (progn ,*body))) + +(defmacro txr-case-impl (:form f sym . clauses) + (tree-case clauses + (((name args . body) . other-clauses) + (if (eq name t) : + ^(txr-if ,name ,args ,sym + (progn ,*body) + (txr-case-impl ,sym ,*other-clauses)))) + (((sym . rest) . other-clauses) + (if (eq sym t) + (if other-clauses + (compile-error f "clauses after (t ...) clause ignored") + ^(progn ,*rest)) + (compile-error f "bad syntax: ~s" (car clauses)))) + (() ()) + (atom + (compile-error f "unexpected atom in syntax: ~s" atom)))) + +(defmacro txr-case (input-expr . clauses) + (let ((input (gensym "input-"))) + ^(let ((,input ,input-expr)) + (if (streamp ,input) + (set ,input (get-lines ,input))) + (txr-case-impl ,input ,*clauses)))) diff --git a/stdlib/txr-case.txr b/stdlib/txr-case.txr new file mode 100644 index 00000000..9b65d1bc --- /dev/null +++ b/stdlib/txr-case.txr @@ -0,0 +1 @@ +@(load "txr-case.tl") diff --git a/stdlib/type.tl b/stdlib/type.tl new file mode 100644 index 00000000..a97ac6bd --- /dev/null +++ b/stdlib/type.tl @@ -0,0 +1,39 @@ +;; Copyright 2015-2021 +;; Kaz Kylheku <kaz@kylheku.com> +;; Vancouver, Canada +;; 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 HOLDER 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. + +(defmacro typecase (form . clauses) + (let* ((val (gensym)) + (cond-pairs (collect-each ((cl clauses)) + (tree-case cl + ((type . body) + (if (symbolp type) + ^((typep ,val ',type) ,*body) + :)) + (else (throwf 'eval-error + "~s: bad clause syntax: ~s" + 'typecase cl)))))) + ^(let ((,val ,form)) + (cond ,*cond-pairs)))) diff --git a/stdlib/ver.tl b/stdlib/ver.tl new file mode 100644 index 00000000..e85d7ac6 --- /dev/null +++ b/stdlib/ver.tl @@ -0,0 +1,2 @@ +(defvarl lib-version 263) +(defvarl *lib-version* lib-version) diff --git a/stdlib/ver.txr b/stdlib/ver.txr new file mode 100644 index 00000000..2339bda7 --- /dev/null +++ b/stdlib/ver.txr @@ -0,0 +1 @@ +@(load "ver.tl") diff --git a/stdlib/vm-param.tl b/stdlib/vm-param.tl new file mode 100644 index 00000000..d87e5bf3 --- /dev/null +++ b/stdlib/vm-param.tl @@ -0,0 +1,36 @@ +;; Copyright 2018-2021 +;; Kaz Kylheku <kaz@kylheku.com> +;; Vancouver, Canada +;; 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 HOLDER 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. + +(defsymacro %lev-size% 1024) +(defsymacro %max-lev-idx% (pred %lev-size%)) +(defsymacro %lev-bits% 10) +(defsymacro %max-lev% 63) +(defsymacro %max-v-lev% (ppred %max-lev%)) +(defsymacro %sm-lev-size% 64) +(defsymacro %max-sm-lev-idx% (pred %sm-lev-size%)) +(defsymacro %max-sm-lev% 15) +(defsymacro %sm-lev-bits% 6) +(defsymacro %max-lambda-fixed-args% 127) diff --git a/stdlib/with-resources.tl b/stdlib/with-resources.tl new file mode 100644 index 00000000..9d4a89c9 --- /dev/null +++ b/stdlib/with-resources.tl @@ -0,0 +1,51 @@ +;; Copyright 2015-2021 +;; Kaz Kylheku <kaz@kylheku.com> +;; Vancouver, Canada +;; 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 HOLDER 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. + +(defmacro with-resources (:form f res-bindings . body) + (tree-case res-bindings + (((sym init) . rest) + ^(let ((,sym ,init)) + (with-resources ,rest ,*body))) + (((sym init . cleanup) . rest) + ^(let ((,sym ,init)) + (when ,sym + (unwind-protect + (with-resources ,rest ,*body) + ,*cleanup)))) + ((sym . rest) + ^(let (,sym) + (with-resources ,rest ,*body))) + (nil + ^(progn ,*body)) + (other (compile-error f "bad syntax")))) + +(defmacro with-objects (var-init-forms . body) + (let ((gens (mapcar (ret (gensym)) var-init-forms))) + ^(let ,gens + (unwind-protect + (let* ,(mapcar (aret ^(,@2 (set ,@1 ,@3))) gens var-init-forms) + ,*body) + ,*(reverse (mapcar (ret ^(call-finalizers ,@1)) gens)))))) diff --git a/stdlib/with-stream.tl b/stdlib/with-stream.tl new file mode 100644 index 00000000..2904ea3d --- /dev/null +++ b/stdlib/with-stream.tl @@ -0,0 +1,58 @@ +;; Copyright 2015-2021 +;; Kaz Kylheku <kaz@kylheku.com> +;; Vancouver, Canada +;; 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 HOLDER 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. + +(defmacro with-out-string-stream ((stream) . body) + ^(let ((,stream (make-string-output-stream))) + ,*body + (get-string-from-stream ,stream))) + +(defmacro with-out-strlist-stream ((stream) . body) + ^(let ((,stream (make-strlist-output-stream))) + ,*body + (get-list-from-stream ,stream))) + +(defmacro with-out-buf-stream ((stream : buf) . body) + ^(let ((,stream (make-buf-stream ,*[[iff have list] buf]))) + ,*body + (get-buf-from-stream ,stream))) + +(defmacro with-in-string-stream ((stream string) . body) + ^(let ((,stream (make-string-input-stream ,string))) + ,*body)) + +(defmacro with-in-string-byte-stream ((stream string) . body) + ^(let ((,stream (make-string-byte-input-stream ,string))) + ,*body)) + +(defmacro with-in-buf-stream ((stream buf) . body) + ^(let ((,stream (make-buf-stream ,buf))) + ,*body)) + +(defmacro with-stream ((sym stream) . body) + ^(let ((,sym ,stream)) + (unwind-protect + (progn ,*body) + (close-stream ,sym)))) diff --git a/stdlib/yield.tl b/stdlib/yield.tl new file mode 100644 index 00000000..866ab8fb --- /dev/null +++ b/stdlib/yield.tl @@ -0,0 +1,118 @@ +;; Copyright 2015-2021 +;; Kaz Kylheku <kaz@kylheku.com> +;; Vancouver, Canada +;; 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 HOLDER 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. + +(defstruct (sys:yld-item val cont) nil val cont) + +(defstruct (sys:rcv-item val cont) nil val cont) + +(defun sys:obtain-impl (fun) + (finalize + (lambda (: resume-val) + (let ((yi (call fun resume-val))) + (while t + (cond + ((eq (typeof yi) 'sys:yld-item) + (call fun 'sys:cont-free) + (set fun yi.cont) + (return yi.val)) + ((eq (typeof yi) 'sys:rcv-item) + (call fun 'sys:cont-free) + (set fun yi.cont) + (set yi (call fun resume-val))) + (t (return yi)))))) + (lambda (cont) + (call cont 'sys:cont-poison)))) + +(defmacro obtain (. body) + (let ((arg (gensym "arg"))) + ^(sys:obtain-impl (lambda (,arg) + (unless (eq ,arg 'sys:cont-free) + ,*body))))) + +(defmacro obtain-block (name . body) + ^(obtain (block ,name ,*body))) + +(defmacro obtain* (. body) + (let ((arg (gensym "arg")) + (fun (gensym "fun"))) + ^(let ((,fun (sys:obtain-impl (lambda (,arg) + (unless (eq ,arg 'sys:cont-free) + ,*body))))) + (call ,fun nil) + ,fun))) + +(defmacro obtain*-block (name . body) + ^(obtain* (block ,name ,*body))) + +(defmacro yield-from (:form ctx-form name : (form nil have-form-p)) + (let ((cont-sym (gensym))) + ^(sys:capture-cont ',name + (lambda (,cont-sym) + (sys:abscond-from ,name + ,(if have-form-p + ^(new (sys:yld-item + ,form ,cont-sym)) + ^(new (sys:rcv-item + nil ,cont-sym))))) + ',ctx-form))) + +(defmacro yield (: (form nil have-form-p)) + (if have-form-p + ^(yield-from nil ,form) + ^(yield-from nil))) + +(defmacro suspend (:form form name sym . body) + ^(sys:capture-cont ',name (lambda (,sym) + (sys:abscond-from ,name (progn ,*body))) + ',form)) + +(defun hlet-expand (op raw-vis body) + (let* ((vis (mapcar [iffi atom list] raw-vis)) + (nvars (len vis)) + (syms [mapcar car vis]) + (inits [mapcar cadr vis]) + (letop (if (eq op 'hlet*) 'let* 'let)) + (gens (mapcar (ret (gensym)) vis)) + (vec (gensym)) + (macs (mapcar (ret ^(,@1 (vecref ,vec ,@2))) + syms (range 0))) + (inits (mapcar (ret ^(set (vecref ,vec ,@1) ,@2)) + (range 0) inits))) + (if (eq op 'hlet*) + ^(let* ((,vec (vector ,nvars))) + (symacrolet ,macs + ,*inits + ,*body)) + ^(let* ((,vec (vector ,nvars))) + ,*inits + (symacrolet ,macs + ,*body))))) + +(defmacro hlet (var-inits . body) + (hlet-expand 'hlet var-inits body)) + +(defmacro hlet* (var-inits . body) + (hlet-expand 'hlet* var-inits body)) |