├── rark.sublime-workspace ├── rark.sublime-project ├── main.rkt ├── runtime-config.rkt ├── language-info.rkt ├── lang └── reader.rkt ├── load └── lang │ └── reader.rkt ├── README.md ├── language.rkt ├── load.rkt ├── private ├── shared-syntax.rkt ├── core.rkt └── functions.rkt ├── logging.rkt ├── reader.rkt ├── LICENSE └── rark.rkt /rark.sublime-workspace: -------------------------------------------------------------------------------- 1 | {} -------------------------------------------------------------------------------- /rark.sublime-project: -------------------------------------------------------------------------------- 1 | { 2 | "folders": 3 | [ 4 | { 5 | "path": "." 6 | } 7 | ] 8 | } 9 | -------------------------------------------------------------------------------- /main.rkt: -------------------------------------------------------------------------------- 1 | #lang racket/base 2 | 3 | (require "language.rkt") 4 | 5 | (provide (all-from-out "language.rkt")) 6 | 7 | (displayln "Welcome to rark") 8 | -------------------------------------------------------------------------------- /runtime-config.rkt: -------------------------------------------------------------------------------- 1 | #lang racket/base 2 | 3 | (require (prefix-in arc- (file "reader.rkt"))) 4 | 5 | (provide configure) 6 | 7 | (define (configure data) 8 | (current-readtable (arc-make-readtable)) 9 | (current-read-interaction arc-read-syntax)) 10 | -------------------------------------------------------------------------------- /language-info.rkt: -------------------------------------------------------------------------------- 1 | #lang racket/base 2 | 3 | (provide language-info) 4 | 5 | (define (language-info data) 6 | (lambda (key default) 7 | (case key 8 | [(configure-runtime) 9 | '(#((planet kogir/rark/runtime-config) configure #f))] 10 | [else default]))) 11 | -------------------------------------------------------------------------------- /lang/reader.rkt: -------------------------------------------------------------------------------- 1 | #lang s-exp syntax/module-reader 2 | (planet kogir/rark/language) 3 | #:read arc-read 4 | #:read-syntax arc-read-syntax 5 | #:wrapper1 arc-read-wrapper 6 | #:language-info '#((planet kogir/rark/language-info) language-info #f) 7 | 8 | (require (prefix-in arc- (planet kogir/rark/reader))) -------------------------------------------------------------------------------- /load/lang/reader.rkt: -------------------------------------------------------------------------------- 1 | #lang s-exp syntax/module-reader 2 | (planet kogir/rark/load) 3 | #:read arc-read 4 | #:read-syntax arc-read-syntax 5 | #:wrapper1 arc-read-wrapper 6 | #:language-info '#((planet kogir/rark/language-info) language-info #f) 7 | 8 | (require (prefix-in arc- (planet kogir/rark/reader))) 9 | 10 | ;; Idea and method ripped from racket/load/lang/reader.rkt 11 | -------------------------------------------------------------------------------- /README.md: -------------------------------------------------------------------------------- 1 | rark 2 | ==== 3 | 4 | A **R**acket language inspired by **Ar**c, by **k**ogir. 5 | 6 | This is my plaything, nothing more. In its current form it shouldn't even be considered an Arc fork. 7 | 8 | Clone and in the package directory: 9 | 10 | ``` 11 | > raco planet link kogir rark.plt 1 0 `pwd` 12 | > raco planet show 13 | Development links: 14 | kogir rark.plt 1 0 15 | --> /path/to/git/clone 16 | ``` 17 | 18 | Then just 19 | 20 | ```racket 21 | #lang planet kogir/rark 22 | 23 | (= test (table)) 24 | (= (test 'a) "A") 25 | ``` 26 | -------------------------------------------------------------------------------- /language.rkt: -------------------------------------------------------------------------------- 1 | #lang racket/base 2 | 3 | (require (for-syntax racket/base) 4 | racket/provide 5 | racket/require) 6 | 7 | ;;; 8 | ;;; Arc language macros, syntax, and functions 9 | ;;; 10 | 11 | ;; This hack keeps us from writing this out multiple times 12 | (define-syntax-rule (export-arc phase ...) 13 | (begin 14 | (begin 15 | (require (for-meta phase 16 | ;(prefix-in arc- (file "reader.rkt")) 17 | (file "private/shared-syntax.rkt") 18 | (file "private/core.rkt") 19 | (file "private/functions.rkt"))) 20 | 21 | (provide (for-meta phase 22 | it 23 | self 24 | throw 25 | ;TODO: Do I need these? 26 | ;(rename-out [arc-read read] 27 | ; [arc-read-syntax read-syntax]) 28 | (filtered-out 29 | (lambda (name) 30 | (and (regexp-match? #rx"^arc-" name) 31 | (regexp-replace #rx"^arc-" name ""))) 32 | (combine-out (all-from-out 33 | (file "private/shared-syntax.rkt") 34 | (file "private/core.rkt") 35 | (file "private/functions.rkt"))))))) 36 | ...)) 37 | 38 | ;(export-arc 0 1 2) 39 | (export-arc 0 1) -------------------------------------------------------------------------------- /load.rkt: -------------------------------------------------------------------------------- 1 | #lang racket/base 2 | 3 | ;;; 4 | ;;; Used to keep the dynamic/loadable style of current arc code 5 | ;;; Ripped straight out of racket/load 6 | ;;; 7 | 8 | (require syntax/strip-context) 9 | 10 | (provide (rename-out [module-begin #%module-begin] 11 | [top-interaction #%top-interaction])) 12 | 13 | (define-syntax-rule (module-begin form ...) 14 | (#%plain-module-begin 15 | (top-interaction . (#%top-interaction . (require (planet kogir/rark/rark)))) 16 | (top-interaction . (#%top-interaction . (compile-allow-set!-undefined #t))) 17 | (top-interaction . (#%top-interaction . form)) ...)) 18 | 19 | (define-syntax-rule (top-interaction . form) 20 | (strip-context-and-eval (quote-syntax form))) 21 | 22 | ;; Make a new namespace to run user code. All evaluation has to start 23 | ;; with `module-begin' or `top-interaction', and we wrap such 24 | ;; evaluations to swap the namespace in and out. 25 | 26 | ;; One way in which this differs from Arc is that 27 | ;; `#reader'-loaded modules see a different top-level namespace, 28 | ;; though it's the same module registry. 29 | 30 | (define-namespace-anchor a) 31 | (define namespace (namespace-anchor->empty-namespace a)) 32 | (parameterize ([current-namespace namespace]) 33 | (namespace-require '(planet kogir/rark/language))) 34 | 35 | (define (strip-context-and-eval e) 36 | (let ([ns (current-namespace)]) 37 | (dynamic-wind 38 | (lambda () 39 | (current-namespace namespace)) 40 | (lambda () 41 | (call-with-continuation-prompt 42 | (lambda () 43 | (eval-syntax (namespace-syntax-introduce 44 | (strip-context e)))) 45 | (default-continuation-prompt-tag) 46 | (lambda args 47 | (apply abort-current-continuation 48 | (default-continuation-prompt-tag) 49 | args)))) 50 | (lambda () 51 | (set! namespace (current-namespace)) 52 | (current-namespace ns))))) 53 | -------------------------------------------------------------------------------- /private/shared-syntax.rkt: -------------------------------------------------------------------------------- 1 | #lang racket/base 2 | 3 | ;;; 4 | ;;; This module contains commonly used syntax classes. 5 | ;;; It is usually required for-syntax. 6 | ;;; 7 | 8 | (require (for-syntax racket/base 9 | racket/string) 10 | racket/performance-hint 11 | racket/stxparam 12 | syntax/parse) 13 | 14 | (provide (all-defined-out)) 15 | 16 | ;;; 17 | ;;; Shared syntax class definitions 18 | ;;; 19 | 20 | (define-splicing-syntax-class binding-pair 21 | #:description "binding pair" 22 | (pattern (~seq var:id rhs:expr))) 23 | 24 | (define-splicing-syntax-class expression-pair 25 | #:description "expression pair" 26 | (pattern (~seq a:expr b:expr))) 27 | 28 | ;;; 29 | ;;; Template syntax classes 30 | ;;; 31 | 32 | (define-splicing-syntax-class template-declaration 33 | #:description "template name and includes" 34 | (pattern (~or (~seq name:id) 35 | (name:id include ...+)))) 36 | 37 | (define-splicing-syntax-class template-field 38 | #:description "template field definition" 39 | #:attributes (name value) 40 | (pattern (~seq name:id value:expr))) 41 | 42 | ;;; 43 | ;;; Anamorphic Macro Placeholders 44 | ;;; 45 | 46 | (define-syntax-parameter it 47 | (lambda (stx) 48 | (raise-syntax-error 49 | #f 50 | "it can only be used inside an anaphoric macro." 51 | stx))) 52 | 53 | (define-syntax-parameter self 54 | (lambda (stx) 55 | (raise-syntax-error 56 | #f 57 | "self can only be used inside afn." 58 | stx))) 59 | 60 | (define-syntax-parameter throw 61 | (lambda (stx) 62 | (raise-syntax-error 63 | #f 64 | "throw can only be used inside catch." 65 | stx))) 66 | 67 | ;;; 68 | ;;; Utility Functions 69 | ;;; 70 | 71 | (define-syntax-rule (idefine body ...) 72 | (begin-encourage-inline 73 | (define body ...))) 74 | 75 | ; Inspired by Danny Yoo's arctangent 76 | ; https://github.com/dyoo/arctangent/blob/master/language.rkt 77 | ; Returns true if stx is an identifier that is lexically bound. 78 | (define (lexically-bound? stx) 79 | (let ([expanded (local-expand stx (syntax-local-context) #f)]) 80 | (cond [(not (identifier? expanded)) #t] 81 | [(identifier-binding expanded) #t] 82 | [else #f]))) 83 | 84 | (define (warn-on-redefinition id-stx) 85 | (when (lexically-bound? id-stx) 86 | (eprintf "*** redefining ~s\n" (syntax->datum id-stx)))) 87 | 88 | ;; Sometimes you want to intern a literal composed at compile time 89 | (define-for-syntax (coerce-string val) 90 | ;; TODO: print to a string instead? 91 | (cond [(string? val) val] 92 | [(number? val) (number->string val)] 93 | [(symbol? val) (symbol->string val)] 94 | [(char? val) (string val)] 95 | [(list? val) (string-join (map coerce-string val) " ")])) 96 | 97 | (define-syntax (istring stx) 98 | (let* ([syntaxes (cdr (syntax->list stx))] 99 | [datums (map syntax->datum syntaxes)] 100 | [strings (map coerce-string datums)] 101 | [str (apply string-append strings)] 102 | [lit (datum-intern-literal str)]) 103 | (datum->syntax stx lit stx stx))) 104 | -------------------------------------------------------------------------------- /logging.rkt: -------------------------------------------------------------------------------- 1 | #lang racket/base 2 | 3 | ;; NS Logging 4 | 5 | (require srfi/13 6 | racket/match 7 | racket/file 8 | racket/date 9 | (for-syntax racket/base)) 10 | 11 | (provide ns-log-enabled? 12 | ns-log-current-directory 13 | ns-log-enable 14 | ns-log-disable 15 | ns-log) 16 | 17 | ;; Variables for internal state tracking 18 | (define internal-logger (make-logger)) 19 | (define logger-thread #f) 20 | (define log-ports #f) 21 | (define log-directory #f) 22 | 23 | ;; [#t|#f] when logging is [enabled|disabled] 24 | (define (ns-log-enabled?) 25 | (if (and logger-thread log-ports log-directory) 26 | #t 27 | #f)) 28 | 29 | ;; Returns the current log directory when logging is enabled 30 | ;; #f when logging is disabled 31 | (define (ns-log-current-directory) 32 | (if (ns-log-enabled?) 33 | log-directory 34 | #f)) 35 | 36 | ;; Enables logging to the specified directory 37 | ;; Returns #t if successful, and #f if an error is encountered 38 | ;; Will not make the directory if it does not exist 39 | ;; Write access is (somewhat obviously) required 40 | ;; TODO: Make thread safe? 41 | (define (ns-log-enable log-dir) 42 | (cond [(not (string? log-dir)) #f] 43 | [(eq? log-dir log-directory) #t] 44 | [(not (directory-exists? log-dir)) #f] 45 | [#t (ns-log-disable) 46 | (set! log-directory log-dir) 47 | (set! log-ports (make-hasheq)) 48 | (set! logger-thread (make-logger-thread log-directory 49 | internal-logger)) 50 | #t])) 51 | 52 | ;; Disables logging 53 | (define (ns-log-disable) 54 | (when logger-thread 55 | (kill-thread logger-thread) 56 | (set! logger-thread #f)) 57 | (when log-ports 58 | (hash-map log-ports 59 | (lambda (source port) (close-log-port port))) 60 | (set! log-ports #f)) 61 | (when log-directory 62 | (set! log-directory #f))) 63 | 64 | ;; Code that sends entries to the logger 65 | 66 | (define (ns-log source format-string . args) 67 | (when (log-level? internal-logger 'debug) 68 | (log-message internal-logger 69 | 'debug 70 | (format "~a ~a" 71 | (current-inexact-milliseconds) 72 | (if (null? args) 73 | format-string 74 | (apply format `(,format-string ,@args)))) 75 | source))) 76 | 77 | ;; These functions let us tag the end of log file names 78 | ;; They're stolen in spirit from srv.arc and arc.arc 79 | 80 | (define (tomorrow-seconds) 81 | (let* ([now-seconds (current-seconds)] 82 | [overshoot-seconds (+ now-seconds (* 24 60 60))] 83 | [overshoot-tomorrow-date (seconds->date overshoot-seconds)] 84 | [tomorrow-seconds (- overshoot-seconds 85 | (date-second overshoot-tomorrow-date) 86 | (* 60 (date-minute overshoot-tomorrow-date)) 87 | (* 60 60 (date-hour overshoot-tomorrow-date)))]) 88 | tomorrow-seconds)) 89 | 90 | (define (tomorrow-milliseconds) 91 | (* 1000 (tomorrow-seconds))) 92 | 93 | (define (date-string) 94 | (let* ([today (current-date)] 95 | [y (number->string (date-year today))] 96 | [m (number->string (date-month today))] 97 | [d (number->string (date-day today))]) 98 | (string-append y "-" (string-pad m 2 #\0) "-" (string-pad d 2 #\0)))) 99 | 100 | (define (logfile-path log-dir source) 101 | (build-path log-dir (string-append (symbol->string source) "-" (date-string)))) 102 | 103 | ;; Log Ports 104 | 105 | (struct log-port (port expire) 106 | #:transparent) 107 | 108 | (define (acquire-port source) 109 | (let ([port (hash-ref! log-ports source (lambda () (create-log-port source)))]) 110 | (when (log-port-expired? port) 111 | (close-log-port port) 112 | (set! port (create-log-port source)) 113 | (hash-set! log-ports source port)) 114 | port)) 115 | 116 | (define (log-port-expired? port) 117 | (< (log-port-expire port) (current-milliseconds))) 118 | 119 | (define (close-log-port port) 120 | (close-output-port (log-port-port port))) 121 | 122 | (define (create-log-port source) 123 | (log-port 124 | (open-output-file (logfile-path log-directory source) #:mode 'text #:exists 'append) 125 | (tomorrow-milliseconds))) 126 | 127 | (define (write-log-port port line) 128 | (let ([port (log-port-port port)]) 129 | (fprintf port "~a\n" line) 130 | (flush-output port))) 131 | 132 | ;; Log Writer 133 | 134 | (define (make-logger-thread log-dir logger) 135 | (define (read-forever receiver) 136 | (match (sync receiver) 137 | [(vector _ message source) 138 | (when (and (string? message) (symbol? source)) 139 | (let ([port (acquire-port source)]) 140 | (write-log-port port message)))]) 141 | (read-forever receiver)) 142 | (thread (lambda () (read-forever (make-log-receiver internal-logger 'debug))))) 143 | -------------------------------------------------------------------------------- /reader.rkt: -------------------------------------------------------------------------------- 1 | #lang racket 2 | 3 | (provide (rename-out [arc-make-readtable make-readtable] 4 | [arc-read read] 5 | [arc-read-syntax read-syntax]) 6 | read-wrapper 7 | set-compiler-debug!) 8 | 9 | ;;; 10 | ;;; Debugging Helpers 11 | ;;; 12 | 13 | (define compiler-debug #f) 14 | 15 | (define (set-compiler-debug! flag) 16 | (set! compiler-debug (eq? flag #t))) 17 | 18 | ;;; 19 | ;;; Helper syntax 20 | ;;; 21 | 22 | (define-syntax-rule (datum->syntax/clone src-stx datum) 23 | (datum->syntax src-stx datum src-stx src-stx)) 24 | 25 | (define-syntax-rule (with-arc-readtable expr ...) 26 | (parameterize ([current-readtable (arc-make-readtable)]) 27 | expr ...)) 28 | 29 | ;;; 30 | ;;; Readtable Extensions: 31 | ;;; ===================== 32 | ;;; [ stuff ... ] => (square-brackets stuff ...) 33 | ;;; This allows nesting and extension from arc itself. 34 | ;;; 35 | 36 | (define (read-square-brackets ch port src line col pos) 37 | (let ([next (read-syntax/recursive src port #\[ #f)]) 38 | (datum->syntax/clone 39 | next 40 | ;`(square-brackets ,next)))) 41 | `(fn (_) ,next)))) 42 | 43 | (define (arc-make-readtable) 44 | ; Only [ _ ] lambdas can be handled at the readtable level. 45 | ; Other language forms are implemented as macros, special 46 | ; (%#top, %#app, etc) forms, or in the reader. 47 | (make-readtable #f 48 | #\[ 'terminating-macro read-square-brackets)) 49 | 50 | ;; 51 | ;; Reader Extensions 52 | ;; 53 | 54 | (define (read-wrapper thunk read-syntax) 55 | (with-arc-readtable (thunk))) 56 | 57 | (define (arc-read-syntax src in) 58 | (let* ([next (read-syntax src in)] 59 | [expanded (ssyntax-expand next)]) 60 | (when (and compiler-debug 61 | (not (eof-object? next))) 62 | (printf "Source: ~s\n" next) 63 | (printf "Expanded: ~s\n" expanded)) 64 | (or expanded next))) 65 | 66 | (define (arc-read in) 67 | (let ([syntax (arc-read-syntax 'none in)]) 68 | (if (eof-object? syntax) 69 | syntax 70 | (syntax->datum syntax)))) 71 | 72 | ;;; 73 | ;;; SSyntax Expansion: 74 | ;;; ================== 75 | ;;; ssyntax-expand-* functions should return #f or an expanded syntax object. 76 | ;;; (a&b ...) => (and-ssyntax (a b) ...) 77 | ;;; 78 | 79 | (define (ssyntax-expand stx) 80 | (and (syntax? stx) 81 | (or (ssyntax-expand-list stx) 82 | (and (ssyntax? stx) 83 | (perform-ssyntax-expand stx))))) 84 | 85 | (define (ssyntax-expand-list stx) 86 | (let ([stx-list (syntax->list stx)]) 87 | (and stx-list 88 | (or (ssyntax-expand-proc stx-list) 89 | (ssyntax-expand-preserve stx stx-list))))) 90 | 91 | (define (ssyntax-expand-proc stx-list) 92 | (and (not (null? stx-list)) 93 | (ssyntax? (car stx-list)) 94 | (perform-ssyntax-expand (car stx-list) (cdr stx-list)))) 95 | 96 | (define (ssyntax-expand-preserve stx-ctx stx-list) 97 | (let ([expanded-list (map ssyntax-expand stx-list)]) 98 | (and (ormap identity expanded-list) 99 | (datum->syntax/clone 100 | stx-ctx 101 | (map (lambda (old new) (or new old)) 102 | stx-list 103 | expanded-list))))) 104 | 105 | (define (perform-ssyntax-expand stx [stx-arg-list null]) 106 | (let* ([sym (syntax-e stx)] 107 | [string-id (symbol->string sym)] 108 | [datum (cond [(ssyntax-compose? string-id) 109 | (ssyntax-expand-compose string-id stx stx-arg-list)] 110 | [(and (ssyntax-sexpr? string-id) 111 | (null? stx-arg-list)) 112 | ; Only expand sexprs as expressions, never procedures 113 | (ssyntax-expand-sexpr sym)] 114 | [(ssyntax-and? string-id) 115 | (ssyntax-expand-and string-id stx stx-arg-list)] 116 | [else #f])] 117 | [result (and datum 118 | (datum->syntax/clone stx datum))]) 119 | (or (ssyntax-expand result) result))) 120 | 121 | 122 | (define (ssyntax-expand-sexpr sym) 123 | (build-sexpr (reverse (tokens (lambda (c) (or (eqv? c #\.) (eqv? c #\!))) 124 | (symbol->chars sym) 125 | '() 126 | '() 127 | #t)) 128 | sym)) 129 | 130 | (define (ssyntax-expand-compose string-id stx-ctx stx-args) 131 | (define (ssyntax-expand-complement string-id) 132 | ;(regexp-replace* #rx"~(?!($|:))" string-id "complement-ssyntax:")) 133 | (regexp-replace* #rx"~(?!($|:))" string-id "no:")) 134 | 135 | (define (compose-call funs args) 136 | (if (null? (cdr funs)) 137 | (if (list? args) 138 | `(,(car funs) ,@args) 139 | `(apply ,(car funs) ,args)) 140 | `(,(car funs) ,(compose-call (cdr funs) args)))) 141 | 142 | (let* ([negated (ssyntax-expand-complement string-id)] 143 | [parts (regexp-split #rx"(?symbol parts)] 145 | [funcs (map (lambda (sym) (datum->syntax/clone stx-ctx sym)) 146 | symbols)]) 147 | (if (null? stx-args) 148 | `(fn args ,(compose-call funcs 'args)) ; Expression 149 | (compose-call funcs stx-args)))) 150 | 151 | (define (ssyntax-expand-and string-id stx-ctx stx-args) 152 | (let* ([parts (regexp-split #rx"(?symbol parts)] 154 | [funcs (map (lambda (sym) (datum->syntax/clone stx-ctx sym)) 155 | symbols)] 156 | [expanded-funcs (or (ssyntax-expand-preserve stx-ctx funcs) funcs)] 157 | [expanded-args (or (ssyntax-expand-preserve stx-ctx stx-args) stx-args)]) 158 | `(and-ssyntax ,expanded-funcs ,@expanded-args))) 159 | 160 | (define (build-sexpr toks orig) 161 | (cond ((null? toks) 162 | 'get) 163 | ((null? (cdr toks)) 164 | (chars->value (car toks))) 165 | (#t 166 | (list (build-sexpr (cddr toks) orig) 167 | (if (eqv? (cadr toks) #\!) 168 | (list 'quote (chars->value (car toks))) 169 | (if (or (eqv? (car toks) #\.) (eqv? (car toks) #\!)) 170 | (error "Bad ssyntax" orig) 171 | (chars->value (car toks)))))))) 172 | 173 | (define (ssyntax? stx) 174 | (and (identifier? stx) 175 | (let ([string-id (symbol->string (syntax-e stx))]) 176 | (or (ssyntax-compose? string-id) 177 | (ssyntax-sexpr? string-id) 178 | (ssyntax-and? string-id))))) 179 | 180 | (define (ssyntax-compose? string-id) 181 | (or (regexp-match? #rx"~(?!($|:))" string-id) 182 | (regexp-match? #rx"(?chars x) (string->list (symbol->string x))) 217 | 218 | (define (chars->value chars) (read-from-string (list->string chars))) 219 | 220 | (define (read-from-string str) 221 | (let ((port (open-input-string str))) 222 | (let ((val (read port))) 223 | (close-input-port port) 224 | val))) 225 | 226 | -------------------------------------------------------------------------------- /LICENSE: -------------------------------------------------------------------------------- 1 | Artistic License 2.0 2 | Copyright (c) 2000-2006, The Perl Foundation. 3 | 4 | Everyone is permitted to copy and distribute verbatim copies of this license 5 | document, but changing it is not allowed. 6 | 7 | Preamble 8 | This license establishes the terms under which a given free software Package may 9 | be copied, modified, distributed, and/or redistributed. The intent is that the 10 | Copyright Holder maintains some artistic control over the development of that 11 | Package while still keeping the Package available as open source and free 12 | software. 13 | 14 | You are always permitted to make arrangements wholly outside of this license 15 | directly with the Copyright Holder of a given Package. If the terms of this 16 | license do not permit the full use that you propose to make of the Package, you 17 | should contact the Copyright Holder and seek a different licensing arrangement. 18 | 19 | Definitions 20 | "Copyright Holder" means the individual(s) or organization(s) named in the 21 | copyright notice for the entire Package. 22 | 23 | "Contributor" means any party that has contributed code or other material to the 24 | Package, in accordance with the Copyright Holder's procedures. 25 | 26 | "You" and "your" means any person who would like to copy, distribute, or modify 27 | the Package. 28 | 29 | "Package" means the collection of files distributed by the Copyright Holder, and 30 | derivatives of that collection and/or of those files. A given Package may 31 | consist of either the Standard Version, or a Modified Version. 32 | 33 | "Distribute" means providing a copy of the Package or making it accessible to 34 | anyone else, or in the case of a company or organization, to others outside of 35 | your company or organization. 36 | 37 | "Distributor Fee" means any fee that you charge for Distributing this Package or 38 | providing support for this Package to another party. It does not mean licensing 39 | fees. 40 | 41 | "Standard Version" refers to the Package if it has not been modified, or has 42 | been modified only in ways explicitly requested by the Copyright Holder. 43 | 44 | "Modified Version" means the Package, if it has been changed, and such changes 45 | were not explicitly requested by the Copyright Holder. 46 | 47 | "Original License" means this Artistic License as Distributed with the Standard 48 | Version of the Package, in its current version or as it may be modified by The 49 | Perl Foundation in the future. 50 | 51 | "Source" form means the source code, documentation source, and configuration 52 | files for the Package. 53 | 54 | "Compiled" form means the compiled bytecode, object code, binary, or any other 55 | form resulting from mechanical transformation or translation of the Source form. 56 | 57 | Permission for Use and Modification Without Distribution 58 | (1) You are permitted to use the Standard Version and create and use Modified 59 | Versions for any purpose without restriction, provided that you do not 60 | Distribute the Modified Version. 61 | 62 | Permissions for Redistribution of the Standard Version 63 | (2) You may Distribute verbatim copies of the Source form of the Standard 64 | Version of this Package in any medium without restriction, either gratis or for 65 | a Distributor Fee, provided that you duplicate all of the original copyright 66 | notices and associated disclaimers. At your discretion, such verbatim copies may 67 | or may not include a Compiled form of the Package. 68 | 69 | (3) You may apply any bug fixes, portability changes, and other modifications 70 | made available from the Copyright Holder. The resulting Package will still be 71 | considered the Standard Version, and as such will be subject to the Original 72 | License. 73 | 74 | Distribution of Modified Versions of the Package as Source 75 | (4) You may Distribute your Modified Version as Source (either gratis or for a 76 | Distributor Fee, and with or without a Compiled form of the Modified Version) 77 | provided that you clearly document how it differs from the Standard Version, 78 | including, but not limited to, documenting any non-standard features, 79 | executables, or modules, and provided that you do at least ONE of the following: 80 | 81 | (a) make the Modified Version available to the Copyright Holder of the Standard 82 | Version, under the Original License, so that the Copyright Holder may include 83 | your modifications in the Standard Version. 84 | (b) ensure that installation of your Modified Version does not prevent the user 85 | installing or running the Standard Version. In addition, the Modified Version 86 | must bear a name that is different from the name of the Standard Version. 87 | (c) allow anyone who receives a copy of the Modified Version to make the Source 88 | form of the Modified Version available to others under 89 | (i) the Original License or 90 | (ii) a license that permits the licensee to freely copy, modify and redistribute 91 | the Modified Version using the same licensing terms that apply to the copy that 92 | the licensee received, and requires that the Source form of the Modified 93 | Version, and of any works derived from it, be made freely available in that 94 | license fees are prohibited but Distributor Fees are allowed. 95 | 96 | Distribution of Compiled Forms of the Standard Version or Modified Versions 97 | without the Source 98 | (5) You may Distribute Compiled forms of the Standard Version without the 99 | Source, provided that you include complete instructions on how to get the Source 100 | of the Standard Version. Such instructions must be valid at the time of your 101 | distribution. If these instructions, at any time while you are carrying out such 102 | distribution, become invalid, you must provide new instructions on demand or 103 | cease further distribution. If you provide valid instructions or cease 104 | distribution within thirty days after you become aware that the instructions are 105 | invalid, then you do not forfeit any of your rights under this license. 106 | 107 | (6) You may Distribute a Modified Version in Compiled form without the Source, 108 | provided that you comply with Section 4 with respect to the Source of the 109 | Modified Version. 110 | 111 | Aggregating or Linking the Package 112 | (7) You may aggregate the Package (either the Standard Version or Modified 113 | Version) with other packages and Distribute the resulting aggregation provided 114 | that you do not charge a licensing fee for the Package. Distributor Fees are 115 | permitted, and licensing fees for other components in the aggregation are 116 | permitted. The terms of this license apply to the use and Distribution of the 117 | Standard or Modified Versions as included in the aggregation. 118 | 119 | (8) You are permitted to link Modified and Standard Versions with other works, 120 | to embed the Package in a larger work of your own, or to build stand-alone 121 | binary or bytecode versions of applications that include the Package, and 122 | Distribute the result without restriction, provided the result does not expose a 123 | direct interface to the Package. 124 | 125 | Items That are Not Considered Part of a Modified Version 126 | 127 | (9) Works (including, but not limited to, modules and scripts) that merely 128 | extend or make use of the Package, do not, by themselves, cause the Package to 129 | be a Modified Version. In addition, such works are not considered parts of the 130 | Package itself, and are not subject to the terms of this license. 131 | 132 | General Provisions 133 | 134 | (10) Any use, modification, and distribution of the Standard or Modified 135 | Versions is governed by this Artistic License. By using, modifying or 136 | distributing the Package, you accept this license. Do not use, modify, or 137 | distribute the Package, if you do not accept this license. 138 | 139 | (11) If your Modified Version has been derived from a Modified Version made by 140 | someone other than you, you are nevertheless required to ensure that your 141 | Modified Version complies with the requirements of this license. 142 | 143 | (12) This license does not grant you the right to use any trademark, service 144 | mark, tradename, or logo of the Copyright Holder. 145 | 146 | (13) This license includes the non-exclusive, worldwide, free-of-charge patent 147 | license to make, have made, use, offer to sell, sell, import and otherwise 148 | transfer the Package with respect to any patent claims licensable by the 149 | Copyright Holder that are necessarily infringed by the Package. If you institute 150 | patent litigation (including a cross-claim or counterclaim) against any party 151 | alleging that the Package constitutes direct or contributory patent 152 | infringement, then this Artistic License to you shall terminate on the date that 153 | such litigation is filed. 154 | 155 | (14) Disclaimer of Warranty: THE PACKAGE IS PROVIDED BY THE COPYRIGHT HOLDER AND 156 | CONTRIBUTORS "AS IS' AND WITHOUT ANY EXPRESS OR IMPLIED WARRANTIES. THE IMPLIED 157 | WARRANTIES OF MERCHANTABILITY, FITNESS FOR A PARTICULAR PURPOSE, OR 158 | NON-INFRINGEMENT ARE DISCLAIMED TO THE EXTENT PERMITTED BY YOUR LOCAL LAW. 159 | UNLESS REQUIRED BY LAW, NO COPYRIGHT HOLDER OR CONTRIBUTOR WILL BE LIABLE FOR 160 | ANY DIRECT, INDIRECT, INCIDENTAL, OR CONSEQUENTIAL DAMAGES ARISING IN ANY WAY 161 | OUT OF THE USE OF THE PACKAGE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH 162 | DAMAGE. 163 | -------------------------------------------------------------------------------- /private/core.rkt: -------------------------------------------------------------------------------- 1 | #lang racket/base 2 | 3 | ;;; 4 | ;;; Minimal Arc 5 | ;;; 6 | ;;; This file contains the immutable core upon which the rest of Arc is built. 7 | ;;; Changes to anything in this file would fundamentally change Arc itself. 8 | ;;; Everything included herein is meant to be inlined, optimized, and whenever 9 | ;;; possible, erased by later macro transformation and compilation steps. 10 | ;;; 11 | 12 | (require (for-syntax racket/base 13 | racket/list 14 | syntax/parse 15 | (file "shared-syntax.rkt")) 16 | ;racket/match 17 | racket/provide 18 | racket/splicing 19 | racket/stxparam 20 | racket/unsafe/ops 21 | (file "shared-syntax.rkt")) 22 | 23 | (provide (matching-identifiers-out #rx"^arc-" (all-defined-out)) 24 | ;(rename-out [#%app arc-#%app]) 25 | (prefix-out core: (combine-out nil? 26 | ~nil? 27 | nil->null 28 | nil->#f))) 29 | 30 | ;;; 31 | ;;; Procedure Application 32 | ;;; 33 | 34 | (define app-apply 35 | (case-lambda 36 | [(efn arg) 37 | (cond [(procedure? efn) (#%app efn arg)] 38 | [(pair? efn) (#%app list-ref efn arg)] 39 | [(string? efn) (#%app string-ref efn arg)] 40 | [(hash? efn) (#%app hash-ref efn arg arc-nil)] 41 | [else (#%app efn arg)])] 42 | [(efn arg1 arg2) 43 | (if (hash? efn) 44 | ; Have to use the lamda in case arg2 is a function 45 | ; See hash-ref docs for more info 46 | (#%app hash-ref efn arg1 (lambda () arg2)) 47 | (#%app efn arg1 arg2))])) 48 | 49 | ;; Faster version for DrRacket 50 | (define-syntax (arc-#%app stx) 51 | (syntax-parse 52 | stx 53 | [(_ fn:expr arg:expr) 54 | #'(#%app app-apply fn arg)] 55 | [(_ fn:expr arg1:expr arg2:expr) 56 | #'(#%app app-apply fn arg1 arg2)] 57 | [(_ args ...) 58 | #'(#%app args ...)])) 59 | 60 | ;(define-syntax (arc-#%app stx) 61 | ; (syntax-parse 62 | ; stx 63 | ; [(_ fn:expr arg:expr) 64 | ; #'(let ([efn fn]) 65 | ; (cond [(procedure? efn) (#%app efn arg)] 66 | ; [(pair? efn) (#%app list-ref efn arg)] 67 | ; [(string? efn) (#%app string-ref efn arg)] 68 | ; [(hash? efn) (#%app hash-ref efn arg arc-nil)] 69 | ; [else (#%app efn arg)]))] 70 | ; [(_ fn:expr arg1:expr arg2:expr) 71 | ; #'(let ([efn fn]) 72 | ; (if (hash? efn) 73 | ; ; Have to use the lamda in case arg2 is a function 74 | ; ; See hash-ref docs for more info 75 | ; (#%app hash-ref efn arg1 (lambda () arg2)) 76 | ; (#%app efn arg1 arg2)))] 77 | ; [(_ args ...) 78 | ; #'(#%app args ...)])) 79 | 80 | ;;; 81 | ;;; Datums 82 | ;;; 83 | ;;; In Racket strings are immutable by default. Make them mutable for Arc. 84 | ;;; 85 | 86 | ;; TODO: Come back to this. Reader extensions required too? 87 | ;(define-syntax (arc-#%datum stx) 88 | ; (syntax-parse 89 | ; stx 90 | ; [(_ . datum) 91 | ; #:when (string? (syntax->datum #'datum)) 92 | ; #`(#%datum . #,(string-copy (syntax->datum #'datum)))] 93 | ; [(_ . datum) 94 | ; #'(#%datum . datum)])) 95 | 96 | ;; TODO: Override #%module-begin to 97 | ;; 1) unify namespaces 98 | ;; 2) allow set! without definition 99 | ;; 3) allow redefinition of constants 100 | 101 | ;;; 102 | ;;; Booleans 103 | ;;; 104 | ;;; Hide Arc's nil from Racket for performance wins. The pain is worth it. 105 | ;;; 106 | 107 | ; t is straightforward. 108 | (idefine arc-t #t) 109 | 110 | ; nil means #f, '(), and void all at the same time. Most of the time #f is an 111 | ; acceptable standin, so default to that. In other cases use special checks to 112 | ; make it serve the inferred role. 113 | ; 114 | ; Note: It's not possible to create the pair (something . #f) in this 115 | ; implementation, since our cons will assume nil is terminating a list, not 116 | ; standing in for #f. Likewise, (something . void) is also impossible. 117 | (idefine arc-nil #f) 118 | 119 | (idefine (nil? value) 120 | (or (not value) (null? value) (void? value))) 121 | 122 | (idefine (~nil? value) 123 | (not (nil? value))) 124 | 125 | ; Used when we want nil to be treated as '() 126 | ; Examples: cons, scdr 127 | (idefine (nil->null value) 128 | (if (nil? value) null value)) 129 | 130 | ; Used when we want nil to be treated as #f 131 | ; Examples: if, and, or, ... 132 | (idefine (nil->#f value) 133 | (if (nil? value) #f value)) 134 | 135 | ; Unfortunately, we can't implement 'and or 'or as arc-level macros since they 136 | ; need to hide our nil implementation. 137 | ; TODO: expose a true? or false? macro to arc that does the dirty work? 138 | 139 | (define-syntax-rule (arc-and arg ...) 140 | (and (nil->#f arg) ...)) 141 | 142 | (define-syntax-rule (arc-or arg ...) 143 | (or (nil->#f arg) ...)) 144 | 145 | (idefine (is2 a b) 146 | (or (eqv? a b) 147 | (and (string? a) (string? b) (string=? a b)) 148 | (and (nil? a) (nil? b)))) 149 | 150 | ; In this case, 'is can't be an Arc macro because we want better parse errors 151 | ; and transparent pairwise grouping. 152 | ; TODO: Find a way to enable grouping macros in Arc. 153 | (define-syntax (arc-is stx) 154 | (syntax-parse 155 | stx 156 | [(_ first rest ...+) 157 | #'(let ([tmp first]) 158 | (and (is2 tmp rest) ...))] 159 | [(_ any ...) 160 | #'arc-t])) 161 | 162 | ; Supports Arc's ...&... ssyntax 163 | (define-syntax (arc-and-ssyntax stx) 164 | (syntax-case stx () 165 | ; Whether in expression or functional position, expand base usage 166 | ; to a lambda safe for application. 167 | [(_ (func ...)) 168 | #'(lambda args 169 | (arc-and (apply func args) ...))] 170 | ; For performance, translate direct calls into direct calls. 171 | [(_ (func ...) args ...) 172 | (with-syntax ([(temps ...) (generate-temporaries #'(args ...))]) 173 | #'(let-values ([(temps ...) (values args ...)]) 174 | (arc-and (func temps ...) ...)))])) 175 | 176 | ;;; 177 | ;;; Control Flow 178 | ;;; 179 | 180 | (define-syntax (arc-if stx) 181 | (syntax-parse 182 | stx 183 | ; TODO: Special forms for two and three arguments? 184 | [(_ clause:expression-pair ...+) 185 | #'(cond [(nil->#f clause.a) clause.b] ...)] 186 | [(_ clause:expression-pair ...+ final:expr) 187 | #'(cond [(nil->#f clause.a) clause.b] ... 188 | [else final])])) 189 | 190 | (define-syntax (arc-caselet stx) 191 | (syntax-parse 192 | stx 193 | [(_ var:id val:expr (~seq sym:expr result:expr) ...+) 194 | #'(let [(var val)] 195 | (case var [(sym) result] ...))] 196 | [(_ var:id val:expr (~seq sym:expr result:expr) ...+ else-expr:expr) 197 | #'(let [(var val)] 198 | (case val [(sym) result] ... [else else-expr]))])) 199 | 200 | (define-syntax (arc-case stx) 201 | (syntax-parse 202 | stx 203 | [(_ val:expr (~seq sym:expr result:expr) ...+) 204 | #'(case val [(sym) result] ...)] 205 | [(_ val:expr (~seq sym:expr result:expr) ...+ else-expr:expr) 206 | #'(case val [(sym) result] ... [else else-expr])])) 207 | 208 | (define-syntax (arc-catch stx) 209 | (syntax-parse 210 | stx 211 | [(_ body ...+) 212 | #'(call/cc (lambda (escape) 213 | (syntax-parameterize ([throw (make-rename-transformer #'escape)]) 214 | body ...)))])) 215 | 216 | ;;; 217 | ;;; Lists (Can't have a LISP without them) 218 | ;;; 219 | ;;; Careful application of nil->null and nil->#f allow us to keep Racket lists 220 | ;;; internally without Arc seeing them. 221 | ;;; 222 | ;;; Note: A pair in Arc can never contain #f or void. DO NOT VIOLATE THIS RULE 223 | ;;; or Racket functions will mysteriously fail when you accidentally give them 224 | ;;; #f instead of '() 225 | ;;; 226 | ;;; TODO: For now leave in redundant checks, but remove them later for better 227 | ;;; performance. Ex: (1 . void) is impossible, so use null->#f instead. 228 | ;;; 229 | ;;; TODO: Make sure cond condition ordering is optimal for most common use. 230 | ;;; 231 | ;;; TODO: Consider switching to mpairs instead. 232 | ;;; 233 | 234 | (idefine (arc-cons head tail) 235 | (cons (nil->null head) (nil->null tail))) 236 | 237 | (idefine (arc-car pair) 238 | (cond [(pair? pair) (nil->null (car pair))] 239 | ; (arc-car nil) -> nil 240 | ; (arc-car '()) -> nil 241 | [(nil? pair) null] 242 | [else (raise-type-error 'car "pair" pair)])) 243 | 244 | (idefine (arc-cdr pair) 245 | (cond [(pair? pair) (nil->null (cdr pair))] 246 | ; (arc-cdr nil) -> nil 247 | ; (arc-cdr '()) -> nil 248 | [(nil? pair) null] 249 | [else (raise-type-error 'cdr "pair" pair)])) 250 | 251 | (idefine (arc-append . args) 252 | (apply append (map nil->null args))) 253 | 254 | ;; TODO: Should scar and scdr have the value in tail position? 255 | 256 | (idefine (arc-scar pair car) 257 | (cond [(pair? pair) (unsafe-set-mcar! pair (nil->null car))] 258 | [(string? pair) (string-set! pair 0 car)] 259 | [else (raise-type-error 'scar "string or pair" 0 pair car)])) 260 | 261 | (idefine (arc-scdr pair cdr) 262 | (if (pair? pair) 263 | (unsafe-set-mcdr! pair (nil->null cdr)) 264 | (raise-type-error 'scdr "pair" 0 pair cdr))) 265 | 266 | ;;; 267 | ;;; Common syntax classes 268 | ;;; 269 | 270 | (begin-for-syntax 271 | (define-syntax-class function-argument 272 | #:description "function argument" 273 | #:attributes (argument match-bind-expr) 274 | ; (fn ((o var default)) ...) 275 | (pattern ((~datum o) 276 | var:id 277 | (~optional default:expr #:defaults([default #'arc-nil]))) 278 | #:with argument #'[var default] 279 | #:attr match-bind-expr #f) 280 | ; (fn (var) ...) 281 | (pattern argument:id 282 | #:attr match-bind-expr #f) 283 | ; (fn ((a b)) ...) 284 | ; (fn ((a b . c)) ...) 285 | (pattern match-bind-expr:match-target 286 | #:attr argument (datum->syntax #'var (gensym 'match-arg) #'var))) 287 | 288 | (define-syntax-class match-target 289 | #:description "destructuring target" 290 | (pattern var:id) 291 | (pattern ((~datum o) var:id (~optional default:expr))) 292 | (pattern (elt:match-target ...)) 293 | (pattern (elt:match-target ... . rest:id))) 294 | 295 | (define-splicing-syntax-class match-binding-pair 296 | #:description "destructuring binding pair" 297 | (pattern (~seq var:match-target rhs:expr)))) 298 | 299 | ;;; 300 | ;;; Destructuring assignment 301 | ;;; 302 | 303 | (define-syntax (expand-extract-protect stx) 304 | (syntax-parse 305 | stx 306 | ;; Do nothing at end of list 307 | [(_ () src) #'()] 308 | ;; Assign remainder to lone variables 309 | [(_ var:id src:expr) 310 | #'((var src))] 311 | [(me (arg args ... . rest) src) 312 | #`(#,@(local-expand #'(expand-extract arg (arc-car src)) 'expression #f) 313 | #,@(local-expand #'(me (args ... . rest) (arc-cdr src)) 'expression #f))])) 314 | 315 | (define-syntax (expand-extract stx) 316 | (syntax-parse 317 | stx 318 | ;; Handle defaults 319 | [(_ ((~datum o) var (~optional default #:defaults([default #'arc-nil]))) src) 320 | #'((var (arc-or src default)))] 321 | [(_ anything ... . goes) 322 | #`(#,@(local-expand #'(expand-extract-protect anything ... . goes) 'expression #f))])) 323 | 324 | (define-syntax (expand-extract-let stx) 325 | (syntax-parse 326 | stx 327 | [(_ ()) #'()] 328 | [(me ([bind src] [binds srcs] ...)) 329 | #`(#,@(local-expand #'(expand-extract bind src) 'expression #f) 330 | #,@(local-expand #'(me ([binds srcs] ...)) 'expression #f))])) 331 | 332 | (define-syntax (extract-let stx) 333 | (syntax-parse 334 | stx 335 | [(me ([arg src] ...) body ...+) 336 | #'(me let* ([arg src] ...) body ...)] 337 | [(_ letform ([arg src] ...) body ...+) 338 | ;; Note: letform has to be let*/letrec because optional args can reference 339 | ;; prior bindings. 340 | #`(letform (#,@(local-expand #'(expand-extract-let ([arg src] ...)) 341 | 'expression 342 | #f)) 343 | body ...)])) 344 | 345 | ;;; 346 | ;;; Lambda (fn) 347 | ;;; 348 | 349 | (define-syntax (arc-fn stx) 350 | (syntax-parse 351 | stx 352 | [(_ (ignored ...)) #'void] 353 | [(_ (a:function-argument ... . rest) body ...+) 354 | (let ([matchers (filter-map (lambda (a b) (and (syntax? a) (cons a b))) 355 | (attribute a.match-bind-expr) 356 | (attribute a.argument))]) 357 | (if (empty? matchers) 358 | #'(lambda (a.argument ... . rest) body ...) 359 | (with-syntax ([(match-target ...) (map car matchers)] 360 | [(match-source ...) (map cdr matchers)]) 361 | #'(lambda (a.argument ... . rest) 362 | (extract-let ([match-target match-source] ...) 363 | body ...)))))])) 364 | 365 | ;;; 366 | ;;; Local Bindings (let, with, withs) 367 | ;;; 368 | ;;; TODO: Fix to support destructuring in top-level and module context 369 | ;;; 370 | 371 | (define-syntax (def-with stx) 372 | (syntax-parse 373 | stx 374 | [(_ name:id let-form:id splicing-let-form:id) 375 | #'(define-syntax (name stx) 376 | (syntax-parse 377 | stx 378 | ;; First try to match non-destructuring let 379 | [(_ (b:binding-pair (... ...)) body ...+) 380 | (with-syntax ([let-style (case (syntax-local-context) 381 | [(top-level module) #'splicing-let-form] 382 | [else #'let-form])]) 383 | #'(let-style (b (... ...)) body (... ...)))] 384 | ;; Destructuring let 385 | [(_ (b:match-binding-pair (... ...)) body ...+) 386 | (with-syntax ([let-style (case (syntax-local-context) 387 | [(top-level module) #'splicing-letrec] 388 | [else #'let*])] 389 | [(vals (... ...)) (generate-temporaries #'(b.rhs (... ...)))]) 390 | ;; TODO: Don't create unneeded temporaries 391 | #'(extract-let let-style ([vals b.rhs] (... ...) 392 | [b.var vals] (... ...)) 393 | body (... ...)))]))])) 394 | 395 | (def-with arc-with let splicing-let) 396 | 397 | (def-with arc-withs let* splicing-letrec) 398 | 399 | (define-syntax (arc-let stx) 400 | (syntax-parse 401 | stx 402 | [(_ b:match-binding-pair body ...+) 403 | #'(arc-with b body ...)])) 404 | 405 | ;;; 406 | ;;; Definitions (def mac) 407 | ;;; 408 | 409 | (define-syntax (arc-def stx) 410 | (syntax-parse 411 | stx 412 | [(_ name:id (ignored ...)) 413 | (warn-on-redefinition #'name) 414 | #'(define name void)] 415 | [(_ name:id (a:function-argument ... . rest) body ...+) 416 | (warn-on-redefinition #'name) 417 | (let ([matchers (filter-map (lambda (a b) (and (syntax? a) (cons a b))) 418 | (attribute a.match-bind-expr) 419 | (attribute a.argument))]) 420 | (if (empty? matchers) 421 | #'(define (name a.argument ... . rest) body ...) 422 | (with-syntax ([(match-target ...) (map car matchers)] 423 | [(match-source ...) (map cdr matchers)]) 424 | #'(define (name a.argument ... . rest) 425 | (extract-let ([match-target match-source] ...) 426 | body ...)))))])) 427 | 428 | (begin-for-syntax 429 | (define-splicing-syntax-class macro-argument 430 | #:description "macro argument" 431 | #:attributes (pattern) 432 | ;; TODO: Does this eat o's? let/with/fn/def did. 433 | (pattern ((~datum o) 434 | name:id 435 | (~optional default:expr #:defaults([default #'arc-nil]))) 436 | #:attr pattern #'(~optional name #:defaults ([name #'default]))) 437 | (pattern (~seq name:id) 438 | #:attr pattern #'name) 439 | (pattern ((~datum ^) elt:macro-argument ...+) 440 | #:attr pattern #'(~seq elt.pattern ...)) 441 | (pattern (elt:macro-argument ...+) 442 | #:attr pattern #'(elt.pattern ...)))) 443 | 444 | (define-syntax (arc-mac stx) 445 | (define-splicing-syntax-class anemic-body 446 | #:description "minimal length body form" 447 | (pattern (~seq body:expr)) 448 | (pattern (~seq e:expr ...+) 449 | #:attr body #'(begin e ...))) 450 | (syntax-parse 451 | stx 452 | [(_ name:id (arg ... . rest) 453 | (~optional (~seq #:leak (leaks:id ...))) 454 | body:anemic-body) 455 | #`(arc-cmac name 456 | #,@(if (attribute leaks) (list #'#:leak #'(leaks ...)) '()) 457 | (arg ... . rest) 458 | body.body)])) 459 | 460 | (define-syntax (arc-cmac stx) 461 | (syntax-parse 462 | stx 463 | [(_ name:id 464 | (~optional (~seq #:leak (leaks:id ...))) 465 | (~seq (arg:macro-argument ... . rest) body:expr) ...+ 466 | (~do (warn-on-redefinition #'name))) 467 | #`(begin 468 | #,@(if (attribute leaks) (list #'(arc-leak leaks ...)) '()) 469 | (define-syntax (name stx) 470 | (syntax-parse 471 | stx 472 | [(_ arg.pattern ... . rest) 473 | #'body] ...)))])) 474 | 475 | ;;; 476 | ;;; Anaphoric Macros 477 | ;;; 478 | ;;; The current 'mac syntax does not allow for breaking hygiene, so these have 479 | ;;; to be defined here for the time being. 480 | ;;; 481 | ;;; TODO: Move these back to Arc now that mac can capture. 482 | ;;; 483 | 484 | (define-syntax-rule (arc-afn (args ...) body ...) 485 | (letrec ([myself 486 | (syntax-parameterize ([self (make-rename-transformer #'myself)]) 487 | (arc-fn (args ...) body ...))]) 488 | myself)) 489 | 490 | (define-syntax-rule (it-lambda body ...) 491 | (lambda (val) 492 | (syntax-parameterize ([it (make-rename-transformer #'val)]) 493 | body ...))) 494 | 495 | (define-syntax (arc-aif stx) 496 | (syntax-parse 497 | stx 498 | ; TODO: Special forms for two and three arguments? 499 | [(_ clause:expression-pair ...+) 500 | #'(cond [(nil->#f clause.a) => (it-lambda clause.b)] ...)] 501 | [(_ clause:expression-pair ...+ final:expr) 502 | #'(cond [(nil->#f clause.a) => (it-lambda clause.b)] ... 503 | [else final])])) 504 | 505 | ; TODO: There has to be a better way... 506 | ; Technically it *is* tail recursive, just dirty. 507 | (define-syntax (arc-aand stx) 508 | (syntax-parse 509 | stx 510 | ; Note: The ordering of these forms is important 511 | [(_ a:expr b:expr ...+) 512 | #'(arc-aif a (arc-aand b ...) #f)] 513 | [(_ a:expr ...) 514 | #'(and a ...)])) 515 | 516 | ;; Sometimes you need an empty (do) form in Arc 517 | (define-syntax (arc-do stx) 518 | (syntax-case stx () 519 | [(_) #'(void)] 520 | [(_ body ...) #'(begin body ...)])) 521 | 522 | ;; If this works I wish I'd discovered it sooner! 523 | (define-syntax (arc-leak stx) 524 | (syntax-parse 525 | stx 526 | [(_ name:id) 527 | (if (lexically-bound? #'name) 528 | #'(void) 529 | #'(define-syntax-parameter name 530 | (lambda (stx) 531 | (with-syntax ([source stx]) 532 | #'(raise-syntax-error 533 | #f 534 | (istring name " can only be used as an ephemeral syntax parameter") 535 | #'source)))))] 536 | [(self name:id ...) 537 | #'(begin (self name) ...)])) 538 | 539 | (define-syntax (arc-bind stx) 540 | (syntax-parse 541 | stx 542 | [(_ pair:binding-pair body ...+) 543 | #'(arc-bind (pair.var pair.rhs) body ...)] 544 | [(_ (pair:binding-pair ...) body ...+) 545 | (with-syntax ([(temps ...) (generate-temporaries #'(pair.var ...))]) 546 | #'(begin 547 | (let ([temps pair.rhs] ...) 548 | (syntax-parameterize ([pair.var (make-rename-transformer #'temps)] ...) 549 | body ...))))])) 550 | -------------------------------------------------------------------------------- /private/functions.rkt: -------------------------------------------------------------------------------- 1 | #lang racket 2 | 3 | ;;; 4 | ;;; Arc Runtime 5 | ;;; 6 | 7 | (require (for-syntax syntax/parse 8 | (file "shared-syntax.rkt")) 9 | (prefix-in arc- (file "../reader.rkt")) 10 | (file "core.rkt") 11 | (file "shared-syntax.rkt") 12 | ffi/unsafe 13 | racket/provide 14 | racket/splicing 15 | openssl/sha1) 16 | 17 | (provide (matching-identifiers-out #rx"^arc-" (all-defined-out))) 18 | 19 | (define-syntax (xdef stx) 20 | (define-splicing-syntax-class id-pair 21 | #:description "arc mapping pair" 22 | #:attributes (arc-name racket-name) 23 | (pattern (~seq arc-name:id) 24 | #:with racket-name #'arc-name) 25 | (pattern [arc-name:id racket-name:id])) 26 | 27 | (syntax-parse 28 | stx 29 | [(_ m:id-pair ...+) 30 | #'(provide (prefix-out arc- (rename-out [m.racket-name m.arc-name] ...)))])) 31 | 32 | (xdef ... 33 | #%datum 34 | [#%module-begin #%plain-module-begin] 35 | #%top 36 | #%top-interaction 37 | 38 | compile-allow-set!-undefined 39 | 40 | [no core:nil?] 41 | 42 | void 43 | 44 | all-defined-out 45 | all-from-out 46 | file 47 | for-syntax 48 | for-template 49 | only-in 50 | provide 51 | planet 52 | rename-out 53 | require 54 | 55 | begin-for-syntax 56 | define-for-syntax 57 | syntax-case 58 | syntax 59 | 60 | apply ; TODO: Is this safe? 61 | compose 62 | [do1 begin0] 63 | [break-thread break-thread] 64 | ;[ccc call-with-current-continuation] 65 | [gc collect-garbage] 66 | [stderr current-error-port] 67 | [current-gc-milliseconds current-gc-milliseconds] 68 | [stdin current-input-port] 69 | [memory current-memory-use] 70 | [msec current-milliseconds] 71 | [current-process-milliseconds current-process-milliseconds] 72 | [stdout current-output-port] 73 | [seconds current-seconds] 74 | [current-thread current-thread] 75 | [rmfile delete-file] 76 | [dms dump-memory-stats] 77 | eval 78 | [even even?] 79 | [quit exit] 80 | [uniq gensym] 81 | [inside get-output-string] 82 | [kill-thread kill-thread] 83 | [newstring make-string] 84 | [complement negate] 85 | [odd odd?] 86 | [infile open-input-file] 87 | [instring open-input-string] 88 | istring 89 | [outstring open-output-string] 90 | quasiquote 91 | quote 92 | [rand random] ; need to use a better seed 93 | sleep 94 | system 95 | [new-thread thread] 96 | [dead thread-dead?] 97 | unquote 98 | unquote-splicing 99 | 100 | ; Strings (for speed) 101 | [rkt-string=? string=?] 102 | [rkt-string? string>?] 105 | [rkt-string>=? string>=?] 106 | [rkt-substring substring] 107 | [rkt-string-length string-length] 108 | 109 | ; Math 110 | [sin sin] 111 | [cos cos] 112 | [tan tan] 113 | [asin asin] 114 | [acos acos] 115 | [atan atan] 116 | [log log] 117 | 118 | ; Incorrect Racket Exports 119 | displayln 120 | printf) 121 | 122 | ;;; 123 | ;;; This is a temporary dirty hack 124 | ;;; 125 | (define-syntax (arc-ensure-var stx) 126 | (syntax-parse 127 | stx 128 | [(_ name:id) 129 | (case (syntax-local-context) 130 | [(top-level) (if (compile-allow-set!-undefined) 131 | #'(set! name (namespace-variable-value 'name #t (lambda () arc-nil))) 132 | (raise-syntax-error #f 133 | "(compile-allow-set!-undefined) must be true to use globals in load mode" 134 | stx))] 135 | [else (if (lexically-bound? #'name) 136 | #'(void) 137 | #'(=2 name arc-nil))])])) 138 | 139 | (define arc-permwrite (make-hash)) 140 | 141 | (define-syntax-rule (perm-check id body) 142 | (if (hash-has-key? arc-permwrite 'id) 143 | (begin0 body 144 | ((hash-ref arc-permwrite 'id) id)) 145 | body)) 146 | 147 | (define-syntax (set-check-perm stx) 148 | (syntax-parse 149 | stx 150 | [(_ p:binding-pair) 151 | ;; TODO: Implement perm! 152 | #'(begin (set! p.var p.rhs) p.var)])) 153 | 154 | ; This allows cross module mutation of globals 155 | (define-syntax (declare-with-set-transformer stx) 156 | (syntax-parse 157 | stx 158 | [(_ var:id) 159 | #'(declare-with-set-transformer var (gensym 'unintialized))] 160 | [(_ var:id init-val:expr) 161 | (let ([store-name (gensym (syntax->datum #'var))]) 162 | #`(begin 163 | (define #,store-name init-val) 164 | (splicing-let ([set (lambda (val) 165 | (set! #,store-name val))]) 166 | (define-syntax var 167 | (make-set!-transformer 168 | (lambda (stx) 169 | (syntax-case stx (set!) 170 | [(set! id val) #'(set val)] 171 | [(id args (... ...)) #'(arc-#%app #,store-name args (... ...))] ; function application 172 | [id (identifier? #'id) #'#,store-name])))))))])) 173 | 174 | (define-syntax (assign1-unbound stx) 175 | (syntax-parse 176 | stx 177 | [(_ p:binding-pair) 178 | (case (syntax-local-context) 179 | [(top-level) (if (compile-allow-set!-undefined) 180 | #'(set-check-perm p.var p.rhs) 181 | (raise-syntax-error #f 182 | "(compile-allow-set!-undefined) must be true to use globals in load mode" 183 | stx))] 184 | ; In proper modules we require things to be defined 185 | [(module) #'(declare-with-set-transformer p.var p.rhs)] 186 | ; In local contexts, check for existing binding and error if not found 187 | [else #'(if (arc-bound p.var) 188 | (set-check-perm p.var p.rhs) 189 | (raise-syntax-error 190 | 'p.var 191 | "reference to an identifier before its definition"))])])) 192 | 193 | ;; TODO: Disallow creating globals accidentally from local scopes. 194 | ;; TODO: Does perm work with local aliases? 195 | ;; TODO: Disallow t and nil assignment 196 | ; Note: Perm bindings are only checked at top-level and module contexts 197 | (define-syntax (assign1 stx) 198 | (syntax-parse 199 | stx 200 | [(_ p:binding-pair) 201 | (let* ([expanded (local-expand #'p.var (syntax-local-context) #f)] 202 | [binding (and (identifier? expanded) (identifier-binding expanded))]) 203 | (cond [(eq? binding 'lexical) 204 | ; Locally bound - No need to check for perm 205 | #'(begin (set! p.var p.rhs) p.var)] 206 | [binding 207 | ; Module bound - check perm, set transformer allows mutation 208 | #'(set-check-perm p.var p.rhs)] 209 | [else 210 | ; Unbound - may exist as (%#top . id) 211 | #'(assign1-unbound p.var p.rhs)]))])) 212 | 213 | (define-syntax (arc-assign stx) 214 | (syntax-parse 215 | stx 216 | [(_ p:binding-pair ...+) 217 | #'(begin (assign1 p.var p.rhs) ...)])) 218 | 219 | ;; Note: leftmost argument must be fully expanded! 220 | (define-syntax (=2 stx) 221 | (define-splicing-syntax-class list-set-form 222 | #:description "assignment target" 223 | #:attributes (set-form target) 224 | (pattern ((~datum car) target:id) 225 | #:attr set-form #'(lambda (val) (arc-scar target val))) 226 | (pattern ((~datum cdr) target:id) 227 | #:attr set-form #'(lambda (val) (arc-scdr target val))) 228 | (pattern ((~datum caar) target:id) 229 | #:attr set-form #'(lambda (val) (arc-scar (arc-car target) val))) 230 | (pattern ((~datum cadr) target:id) 231 | #:attr set-form #'(lambda (val) (arc-scar (arc-cdr target) val))) 232 | (pattern ((~datum caar) target:id) 233 | #:attr set-form #'(lambda (val) (arc-scdr (arc-cdr target) val)))) 234 | 235 | (syntax-parse 236 | stx 237 | ;; TODO Allow extension from arc 238 | ; For simple identifiers, just assign 239 | [(_ place:id val:expr) 240 | #'(assign1 place val)] 241 | ; For list references more magic is required 242 | [(_ place:list-set-form val:expr) 243 | #'(perm-check place.target 244 | (let [(tmp val)] 245 | (place.set-form tmp) 246 | tmp))] 247 | ; Handle hash tables, list element references, etc. 248 | [(_ (com:expr indx:expr) val:expr) 249 | #'(perm-check com 250 | (let [(tmp val)] 251 | (arc-sref com tmp indx) 252 | tmp))] 253 | ; Hash table references with default values - default ignored 254 | ; TODO: More rigorous type checking? 255 | [(_ (com:expr indx:expr default:expr) val:expr) 256 | #'(perm-check com 257 | (let [(tmp val)] 258 | (arc-sref com tmp indx) 259 | tmp))])) 260 | 261 | (define-syntax (arc-= stx) 262 | (define-splicing-syntax-class partially-expanding-expression-pair 263 | #:description "expression pair" 264 | #:attributes (a b a-expanded) 265 | ; Don't expand syntax transformers 266 | (pattern (~seq a:id b:expr) 267 | #:when (set!-transformer? 268 | (syntax-local-value #'a (lambda () #f))) 269 | #:attr a-expanded #'a) 270 | (pattern (~seq (a:id args ...) b:expr) 271 | #:when (set!-transformer? 272 | (syntax-local-value #'a (lambda () #f))) 273 | #:attr a-expanded #'(a args ...)) 274 | (pattern (~seq a:expr b:expr) 275 | #:attr a-expanded (local-expand #'a 276 | (syntax-local-context) 277 | (list #'arc-#%app)))) 278 | (syntax-parse 279 | stx 280 | [(_ s:partially-expanding-expression-pair ...+) 281 | #'(begin (=2 s.a-expanded s.b) ...)])) 282 | 283 | (define-syntax (arc-safeset stx) 284 | (syntax-parse 285 | stx 286 | [(_ name:id val:expr 287 | (~do (warn-on-redefinition #'name))) 288 | #'(assign1 name val)])) 289 | 290 | ;; TODO: Use arc car/cdr here? 291 | (define (pairwise pred lst) 292 | (cond [(null? lst) arc-t] 293 | [(null? (cdr lst)) arc-t] 294 | [(core:~nil? (pred (car lst) (cadr lst))) 295 | (pairwise pred (cdr lst))] 296 | [else arc-nil])) 297 | 298 | (xdef [err error]) 299 | 300 | (define (arc-+ . args) 301 | (cond [(null? args) 0] 302 | [(char-or-string? (car args)) 303 | (apply string-append 304 | (map (lambda (a) (arc-coerce a 'string)) 305 | args))] 306 | [(list? (core:nil->null (car args))) 307 | (apply arc-append args)] 308 | [else (apply + args)])) 309 | 310 | (idefine (char-or-string? x) (or (string? x) (char? x))) 311 | 312 | (xdef - 313 | * 314 | / 315 | [mod modulo] 316 | expt 317 | sqrt) 318 | 319 | ; generic comparison 320 | 321 | (define-syntax (all stx) 322 | (syntax-parse 323 | stx 324 | [(_ pred arg:id ...) 325 | #'(and (pred arg) ...)])) 326 | 327 | (define (arc->2 x y) 328 | (cond [(all number? x y) (> x y)] 329 | [(all string? x y) (string>? x y)] 330 | [(all symbol? x y) (string>? (symbol->string x) 331 | (symbol->string y))] 332 | [(all char? x y) (char>? x y)] 333 | [else (> x y)])) 334 | 335 | (define (arc-> . args) 336 | (pairwise arc->2 args)) 337 | 338 | (define (arc-<2 x y) 339 | (cond [(all number? x y) (< x y)] 340 | [(all string? x y) (stringstring x) 342 | (symbol->string y))] 343 | [(all char? x y) (charnull x))])) 353 | 354 | (idefine (exint? x) (and (integer? x) (exact? x))) 355 | 356 | (define (arc-type x) 357 | (cond [(pair? x) 'cons] 358 | [(symbol? x) 'sym] 359 | [(core:nil? x) 'sym] 360 | [(procedure? x) 'fn] 361 | [(char? x) 'char] 362 | [(string? x) 'string] 363 | [(exint? x) 'int] 364 | [(number? x) 'num] ; unsure about this 365 | [(hash? x) 'table] 366 | [(output-port? x) 'output] 367 | [(input-port? x) 'input] 368 | [(tcp-listener? x) 'socket] 369 | [(exn? x) 'exception] 370 | [(thread? x) 'thread] 371 | [else (error 'type "unknown type: ~s" x)])) 372 | 373 | (define (arc-outfile f [mode #f]) 374 | (open-output-file f 375 | #:'text 376 | #:exists (if (eq? mode 'append) 377 | 'append 378 | 'truncate))) 379 | 380 | (define (arc-call-w/stdout port thunk) 381 | (parameterize ((current-output-port port)) (thunk))) 382 | 383 | (define (arc-call-w/stdin port thunk) 384 | (parameterize ((current-input-port port)) (thunk))) 385 | 386 | (define (arc-readc . str) 387 | (let ([c (read-char (if (pair? str) 388 | (car str) 389 | (current-input-port)))]) 390 | (if (eof-object? c) arc-nil c))) 391 | 392 | (define (arc-readb . str) 393 | (let ([c (read-byte (if (pair? str) 394 | (car str) 395 | (current-input-port)))]) 396 | (if (eof-object? c) arc-nil c))) 397 | 398 | (define (arc-writec c . args) 399 | (write-char c 400 | (if (pair? args) 401 | (car args) 402 | (current-output-port))) 403 | c) 404 | 405 | (define (arc-writeb b . args) 406 | (write-byte b 407 | (if (pair? args) 408 | (car args) 409 | (current-output-port))) 410 | b) 411 | 412 | (define explicit-flush #f) 413 | 414 | (define (printwith f args) 415 | (let ([port (if (> (length args) 1) 416 | (cadr args) 417 | (current-output-port))]) 418 | (when (pair? args) 419 | (f (car args) port)) 420 | (unless explicit-flush (flush-output port)))) 421 | 422 | (define (arc-write . args) (printwith write args)) 423 | (define (arc-disp . args) (printwith display args)) 424 | 425 | ; sread = scheme read. eventually replace by writing read 426 | 427 | ;; TODO: *** make sure this is the correct reader 428 | (define (arc-sread p eof) 429 | (let ([expr (arc-read p)]) 430 | (if (eof-object? expr) eof expr))) 431 | 432 | (idefine (iround x) (inexact->exact (round x))) 433 | 434 | ; is write that (coerce nil 'string) -> "" 435 | 436 | (define (arc-coerce x type . args) 437 | (cond [(eqv? type (arc-type x)) x] 438 | [(char? x) (case type 439 | [(int) (char->integer x)] 440 | [(string) (string x)] 441 | [(sym) (integer->char (string x))] 442 | [else (error 'coerce "Can't coerce ~s to ~s" x type)])] 443 | [(exint? x) (case type 444 | [(num) x] 445 | [(char) (integer->char x)] 446 | [(string) (apply number->string x args)] 447 | [else (error 'coerce "Can't coerce ~s to ~s" x type)])] 448 | [(number? x) (case type 449 | [(int) (iround x)] 450 | [(char) (integer->char (iround x))] 451 | [(string) (apply number->string x args)] 452 | [else (error 'coerce "Can't coerce ~s to ~s" x type)])] 453 | [(string? x) (case type 454 | [(sym) (string->symbol x)] 455 | [(cons) (string->list x)] 456 | [(num) (or (apply string->number x args) 457 | (error 'coerce "Can't coerce ~s to ~s" x type))] 458 | [(int) (let ([n (apply string->number x args)]) 459 | (if n 460 | (iround n) 461 | (error 'coerce "Can't coerce ~s to ~s" x type)))] 462 | [else (error 'coerce "Can't coerce ~s to ~s" x type)])] 463 | [(pair? x) (case type 464 | [(string) (apply string-append 465 | (map (lambda (y) (arc-coerce y 'string)) 466 | x))] 467 | [else (error 'coerce "Can't coerce ~s to ~s" x type)])] 468 | [(core:nil? x) (case type 469 | [(string) ""] 470 | [else (error 'coerce "Can't coerce ~s to ~s" x type)])] 471 | [(symbol? x) (case type 472 | [(string) (symbol->string x)] 473 | [else (error 'coerce "Can't coerce ~s to ~s" x type)])] 474 | [else x])) 475 | 476 | ;; TODO: hard coded IP is a bit of a hack 477 | (define (arc-open-socket num) (tcp-listen num 500 #t "127.0.0.1")) 478 | 479 | (define (arc-socket-accept s) 480 | (parameterize ([current-custodian (make-custodian)]) 481 | (let*-values ([(in out) (tcp-accept s)] 482 | [(server-ip client-ip) (tcp-addresses out)] 483 | [(in1) (make-limited-input-port in 100000 #t)]) 484 | (associate-custodian (current-custodian) in1 out) 485 | (list in1 out client-ip)))) 486 | 487 | (define (arc-on-err errfn f) 488 | ((call-with-current-continuation 489 | (lambda (k) 490 | (lambda () 491 | (with-handlers ((exn:fail? (lambda (c) 492 | (k (lambda () (errfn c)))))) 493 | (f))))))) 494 | 495 | (define (arc-pipe-from cmd) 496 | (let ((tf (ar-tmpname))) 497 | (system (string-append cmd " > " tf)) 498 | (let ((str (open-input-file tf))) 499 | (system (string-append "rm -f " tf)) 500 | str))) 501 | 502 | (define (ar-tmpname) 503 | (call-with-input-file "/dev/urandom" 504 | (lambda (rstr) 505 | (do ((s "/tmp/") 506 | (c (read-char rstr) (read-char rstr)) 507 | (i 0 (+ i 1))) 508 | ((>= i 16) s) 509 | (set! s (string-append s 510 | (string 511 | (integer->char 512 | (+ (char->integer #\a) 513 | (modulo 514 | (char->integer (read-char rstr)) 515 | 26)))))))))) 516 | 517 | ; PLT scheme provides only eq? and equal? hash tables, 518 | ; we need the latter for strings. 519 | 520 | (define (arc-table . args) 521 | (let ([h (make-hash)]) 522 | (when (pair? args) ((car args) h)) 523 | h)) 524 | 525 | ; eq-table in temload makes a big difference 526 | (define (arc-eq-table) (make-hasheq)) 527 | 528 | (idefine (arc-maptable fn table) ; arg is (fn (key value) ...) 529 | (hash-for-each table fn) 530 | table) 531 | 532 | (define (arc-protect during after) 533 | (dynamic-wind (lambda () #t) during after)) 534 | 535 | (define (arc-dir name) 536 | (map path->string (directory-list name))) 537 | 538 | ; Would def mkdir in terms of make-directory and call that instead 539 | ; of system in ensure-dir, but make-directory is too weak: it doesn't 540 | ; create intermediate directories like mkdir -p. 541 | 542 | (define (arc-file-exists name) 543 | (if (file-exists? name) name arc-nil)) 544 | 545 | (define (arc-dir-exists name) 546 | (if (directory-exists? name) name arc-nil)) 547 | 548 | (define (arc-make-dir name) 549 | (make-directory* name)) 550 | 551 | (define (arc-mvfile old new) 552 | (rename-file-or-directory old new #t)) 553 | 554 | ; If an err occurs in an on-err expr, no val is returned and code 555 | ; after it doesn't get executed. Not quite what I had in mind. 556 | 557 | (define (disp-to-string x) 558 | (let ([o (open-output-string)]) 559 | (display x o) 560 | (close-output-port o) 561 | (get-output-string o))) 562 | 563 | (define (arc-details c) 564 | (disp-to-string (exn-message c))) 565 | 566 | ; Later may want to have multiple indices. 567 | 568 | (define (arc-sref com val ind) 569 | (cond [(hash? com) (if (core:nil? val) 570 | (hash-remove! com ind) 571 | (hash-set! com ind val))] 572 | [(string? com) (string-set! com ind val)] 573 | [(pair? com) (nth-set! com ind val)] 574 | [else (raise-user-error 'sref 575 | "Can't set reference ~s ~s ~s" 576 | com ind val)])) 577 | 578 | (define-syntax-rule (nth-set! lst n val) 579 | (arc-scar (list-tail lst n) val)) 580 | 581 | ; If you're calling this directly, you probably meant to use arc-bound instead. 582 | (splicing-let ([top-unbound (gensym)]) 583 | (define (top-bound? sym) 584 | (if (eq? top-unbound 585 | (namespace-variable-value sym 586 | #t 587 | (lambda () top-unbound))) 588 | arc-nil 589 | arc-t))) 590 | 591 | ;; TODO: Currently checks local lexical scopes - Is that desired? 592 | (define-syntax (arc-bound stx) 593 | (syntax-case stx () 594 | [(_ sym) 595 | (if (lexically-bound? #'sym) 596 | #'arc-t 597 | #'(top-bound? 'sym))])) 598 | 599 | (define (arc-trunc x) (inexact->exact (truncate x))) 600 | 601 | ; bad name 602 | 603 | (define (arc-exact x) 604 | (exint? x)) 605 | 606 | (define (arc-thread-milliseconds) 607 | (current-process-milliseconds (current-thread))) 608 | 609 | ; make sure only one thread at a time executes anything 610 | ; inside an atomic-invoke. atomic-invoke is allowed to 611 | ; nest within a thread; the thread-cell keeps track of 612 | ; whether this thread already holds the lock. 613 | 614 | (define ar-the-sema (make-semaphore 1)) 615 | 616 | (define ar-sema-cell (make-thread-cell #f)) 617 | 618 | (define (arc-atomic-invoke f) 619 | (if (thread-cell-ref ar-sema-cell) 620 | (f) 621 | (begin 622 | (thread-cell-set! ar-sema-cell #t) 623 | (arc-protect 624 | (lambda () 625 | (call-with-semaphore 626 | ar-the-sema 627 | (lambda () (f)))) 628 | (lambda () 629 | (thread-cell-set! ar-sema-cell #f)))))) 630 | 631 | ; Added because Mzscheme buffers output. Not a permanent part of Arc. 632 | ; Only need to use when declare explicit-flush optimization. 633 | 634 | (define (arc-flushout) (flush-output) arc-t) 635 | 636 | ;; TODO: Is this still true? 637 | ;; Verify and remove if not needed 638 | 639 | ; there are two ways to close a TCP output port. 640 | ; (close o) waits for output to drain, then closes UNIX descriptor. 641 | ; (force-close o) discards buffered output, then closes UNIX desc. 642 | ; web servers need the latter to get rid of connections to 643 | ; clients that are not reading data. 644 | ; mzscheme close-output-port doesn't work (just raises an error) 645 | ; if there is buffered output for a non-responsive socket. 646 | ; must use custodian-shutdown-all instead. 647 | 648 | (define custodians (make-hash)) 649 | 650 | (define (associate-custodian c i o) 651 | (hash-set! custodians i c) 652 | (hash-set! custodians o c)) 653 | 654 | ; if a port has a custodian, use it to close the port forcefully. 655 | ; also get rid of the reference to the custodian. 656 | ; sadly doing this to the input port also kills the output port. 657 | 658 | (define (try-custodian p) 659 | (let ([c (hash-ref custodians p #f)]) 660 | (if c 661 | (begin 662 | (custodian-shutdown-all c) 663 | (hash-remove! custodians p) 664 | #t) 665 | #f))) 666 | 667 | (define (arc-close . args) 668 | (map (lambda (p) 669 | (cond [(input-port? p) (close-input-port p)] 670 | [(output-port? p) (close-output-port p)] 671 | [(tcp-listener? p) (tcp-close p)] 672 | [else (error "Can't close " p)])) 673 | args) 674 | (map (lambda (p) (try-custodian p)) args) ; free any custodian 675 | (void)) 676 | 677 | (define (arc-force-close . args) 678 | (map (lambda (p) 679 | (when (not (try-custodian p)) 680 | (arc-close p))) 681 | args) 682 | (void)) 683 | 684 | ; how many bytes has this thread allocated, cumulatively? 685 | ; only works with a modified mzscheme. 686 | 687 | (define (arc-thread-alloced) 688 | (arc-on-err (lambda (e) 0) 689 | (lambda() (current-memory-use (current-thread))))) 690 | 691 | (define (arc-declare key val) 692 | (let ([flag (core:~nil? val)]) 693 | (case key 694 | ;; TODO: Support this? 695 | ;[(atstrings) (set! atstrings flag)] 696 | ; New runtime makes all calls direct :) 697 | ;[(direct-calls) (set! direct-calls flag)] 698 | [(explicit-flush) (set! explicit-flush flag)])) 699 | val) 700 | 701 | (let ([quiet (putenv "TZ" ":GMT")]) 702 | (void)) 703 | 704 | (define (gmt-date sec) (seconds->date sec)) 705 | 706 | (define (arc-timedate . args) 707 | (let ([d (gmt-date (if (pair? args) (car args) (current-seconds)))]) 708 | (list (date-second d) 709 | (date-minute d) 710 | (date-hour d) 711 | (date-day d) 712 | (date-month d) 713 | (date-year d)))) 714 | 715 | (define (arc-shash s) (sha1 (open-input-string s))) 716 | 717 | ;; TODO: Find a way to put this back into arc.arc 718 | 719 | (define arc-templates* (make-hash)) 720 | 721 | (define-syntax (arc-deftem stx) 722 | (syntax-parse 723 | stx 724 | [(_ decl:template-declaration field:template-field ...) 725 | #`(hash-set! arc-templates* 726 | 'decl.name 727 | (append #,(if (attribute decl.include) 728 | #'(filter-map (lambda (x) 729 | (hash-ref arc-templates* x #f)) 730 | (reverse '(decl.include ...))) 731 | #''()) 732 | (list (list 'field.name (lambda () field.value)) ...)))])) 733 | 734 | (define-syntax (arc-addtem stx) 735 | (syntax-parse 736 | stx 737 | [(_ name:id field:template-field ...) 738 | #'(hash-set! arc-templates* 739 | 'name 740 | (remove-duplicates 741 | (append '((field.name (lambda () field.value)) ...) 742 | (hash-ref arc-templates* 'name '())) 743 | (lambda (x y) (arc-is (car x) (car y)))))])) 744 | 745 | (define-syntax (arc-obj stx) 746 | (define-splicing-syntax-class obj-field 747 | #:description "object field entry" 748 | (pattern (~seq key:expr val:expr))) 749 | (syntax-parse 750 | stx 751 | [(_ field:obj-field ...+) 752 | #'(let ([h (arc-table)]) 753 | (hash-set! h 'field.key field.val) ... 754 | h)])) 755 | 756 | (idefine (arc-map1 fn seq) 757 | (map fn (core:nil->null seq))) 758 | 759 | (idefine (arc-each1 fn seq) 760 | (for-each fn (core:nil->null seq))) 761 | -------------------------------------------------------------------------------- /rark.rkt: -------------------------------------------------------------------------------- 1 | #lang planet kogir/rark 2 | 3 | ;; TODO: Kill this before release 4 | (displayln "loading rark.rkt...") 5 | 6 | (provide (all-defined-out)) 7 | 8 | ;; I implemented square brackets in the reader as follows: 9 | ;; [stuff ...] => (square-brackets stuff ...) 10 | ;; This idea was stolen from multiple of the arc spinoffs on the arc forum 11 | ;(mac square-brackets (body ...) 12 | 13 | ;; Let's make ~ ssyntax extensible: 14 | ;(mac complement-ssyntax (body ...) 15 | 16 | ;; do - mapped to racket (begin ...) (performance) 17 | ;; safeset - mostly integrated into def and mac. Now more of a noisy = 18 | ;; def - sucked into core (required) 19 | 20 | (def caar (xs) (car (car xs))) 21 | (def cadr (xs) (car (cdr xs))) 22 | (def cddr (xs) (cdr (cdr xs))) 23 | 24 | ;; no - sucked into core (performance) 25 | 26 | (def acons (x) (is (type x) 'cons)) 27 | 28 | (def atom (x) (no (acons x))) 29 | 30 | (def copylist (xs) 31 | (if (no xs) 32 | nil 33 | (cons (car xs) (copylist (cdr xs))))) 34 | 35 | ;; TODO: map this to Racket's (list)? 36 | ;; No more need to copy since rest args are proper lists 37 | (def list args args) 38 | 39 | (def idfn (x) x) 40 | 41 | ;; map1 - sucked into core (performance) 42 | 43 | (def pair (xs (o f list)) 44 | (if (no xs) 45 | nil 46 | (no (cdr xs)) 47 | (list (list (car xs))) 48 | (cons (f (car xs) (cadr xs)) 49 | (pair (cddr xs) f)))) 50 | 51 | ;; mac - sucked into core (required) 52 | ;; and - Sucked into core (performance, nil handling) 53 | 54 | (def assoc (key al) 55 | (if (atom al) 56 | nil 57 | (and (acons (car al)) (is (caar al) key)) 58 | (car al) 59 | (assoc key (cdr al)))) 60 | 61 | (def alref (al key) (cadr (assoc key al))) 62 | 63 | ;; with - sucked into core (performance) 64 | ;; let - sucked into core (performance) 65 | ;; withs - sucked into core (performance) 66 | 67 | (def join args 68 | (if (no args) 69 | nil 70 | (let a (car args) 71 | (if (no a) 72 | (apply join (cdr args)) 73 | (cons (car a) (apply join (cdr a) (cdr args))))))) 74 | 75 | ;; rfn - no longer needed, since afn is now hygenic :) 76 | ;; afn - sucked into core (performance + hygene) 77 | 78 | ;; reader expands x:y:z into (compose x y z), ~x into (no x) 79 | ;; compose - Sucked into core (performance + ssyntax support) 80 | ;; complement - sucked into core (performance) 81 | 82 | (def rev (xs) 83 | ((afn (xs acc) 84 | (if (no xs) 85 | acc 86 | (self (cdr xs) (cons (car xs) acc)))) 87 | xs nil)) 88 | 89 | (def isnt (x y) (no (is x y))) 90 | 91 | ;; w/uniq - killed for now - see how far hygiene can get us 92 | 93 | ;; or - sucked into core (performance, nil handling) 94 | 95 | (def alist (x) (or (no x) (is (type x) 'cons))) 96 | 97 | (mac in (x choice ...) 98 | (or (is x choice) ...)) 99 | 100 | (def iso (x y) 101 | (or (is x y) 102 | (and (acons x) 103 | (acons y) 104 | (iso (car x) (car y)) 105 | (iso (cdr x) (cdr y))))) 106 | 107 | (mac when (test body ...) 108 | (if test (do body ...))) 109 | 110 | (mac unless (test body ...) 111 | (if (no test) (do body ...))) 112 | 113 | (mac while (test body ...) 114 | ((afn () (when test body ... (self))))) 115 | 116 | (def empty (seq) 117 | (or (no seq) 118 | (and (or (is (type seq) 'string) (is (type seq) 'table)) 119 | (is (len seq) 0)))) 120 | 121 | (def reclist (f xs) 122 | (and xs (or (f xs) (reclist f (cdr xs))))) 123 | 124 | (def recstring (test s (o start 0)) 125 | ((afn (i) 126 | (and (< i (len s)) 127 | (or (test i) 128 | (self (+ i 1))))) 129 | start)) 130 | 131 | (def testify (x) 132 | (if (isa x 'fn) x [is _ x])) 133 | 134 | (def some (test seq) 135 | (let f (testify test) 136 | (if (alist seq) 137 | (reclist f:car seq) 138 | (recstring f:seq seq)))) 139 | 140 | (def all (test seq) 141 | (~some (complement (testify test)) seq)) 142 | 143 | (def mem (test seq) 144 | (let f (testify test) 145 | (reclist [if (f:car _) _] seq))) 146 | 147 | (def find (test seq) 148 | (let f (testify test) 149 | (if (alist seq) 150 | (reclist [if (f:car _) (car _)] seq) 151 | (recstring [if (f:seq _) (seq _)] seq)))) 152 | 153 | (def isa (x y) (is (type x) y)) 154 | 155 | ;; TODO: Add hack to allow (mappend (table) '(1 2 3 4)) 156 | (def map (f . seqs) 157 | (if (some [isa _ 'string] seqs) 158 | (withs (n (apply min (map len seqs)) 159 | new (newstring n)) 160 | ((afn (i) 161 | (if (is i n) 162 | new 163 | (do (sref new (apply f (map [_ i] seqs)) i) 164 | (self (+ i 1))))) 165 | 0)) 166 | (no (cdr seqs)) 167 | (map1 f (car seqs)) 168 | ((afn (seqs) 169 | (if (some no seqs) 170 | nil 171 | (cons (apply f (map1 car seqs)) 172 | (self (map1 cdr seqs))))) 173 | seqs))) 174 | 175 | (def mappend (f . args) 176 | (apply + nil (apply map f args))) 177 | 178 | (def firstn (n xs) 179 | (if (no n) xs 180 | (and (> n 0) xs) (cons (car xs) (firstn (- n 1) (cdr xs))) 181 | nil)) 182 | 183 | (def nthcdr (n xs) 184 | (if (no n) xs 185 | (> n 0) (nthcdr (- n 1) (cdr xs)) 186 | xs)) 187 | 188 | (def tuples (xs (o n 2)) 189 | (if (no xs) 190 | nil 191 | (cons (firstn n xs) 192 | (tuples (nthcdr n xs) n)))) 193 | 194 | (def caris (x val) 195 | (and (acons x) (is (car x) val))) 196 | 197 | (def warn (msg . args) 198 | (disp (+ "Warning: " msg ". ")) 199 | (map [do (write _) (disp " ")] args) 200 | (disp #\newline)) 201 | 202 | (mac atomic (body ...) 203 | (atomic-invoke (fn () body ...))) 204 | 205 | (mac atlet (args ...) 206 | (atomic (let args ...))) 207 | 208 | (mac atwith (args ...) 209 | (atomic (with args ...))) 210 | 211 | (mac atwiths (args ...) 212 | (atomic (withs args ...))) 213 | 214 | (def treewise (f base tree) 215 | (if (atom tree) 216 | (base tree) 217 | (f (treewise f base (car tree)) 218 | (treewise f base (cdr tree))))) 219 | 220 | ;; do1 - mapped to racket begin0 (performance) 221 | 222 | ;; TODO: Find a way to push this back into arc.arc 223 | ;; expand=, expand=list, and = sucked into core (performance, required) 224 | 225 | ;; TODO: See if I can eliminate sets here using a different construction 226 | (mac loop (start test update body ...) 227 | (do start 228 | ((afn () 229 | (if test 230 | (do body ... 231 | update 232 | (self))))))) 233 | 234 | ;; TODO: Consider using Racket's for construct with in-range 235 | (mac for (v init max body ...) 236 | (with (v nil i init stop (+ max 1)) 237 | (loop (assign v i) (< v stop) (assign v (+ v 1)) 238 | body ...))) 239 | 240 | (mac down (v init min body ...) 241 | (with (v nil i init stop (- min 1)) 242 | (loop (assign v i) (> v stop) (assign v (- v 1)) 243 | body ...))) 244 | 245 | (mac repeat (n body ...) 246 | (for reps 1 n body ...)) 247 | 248 | ;; TODO: Use Racket's for-each to skip creating the list 249 | ;; TODO: Special case strings 250 | (mac each (var expr body ...) 251 | (with (seq expr 252 | mapfn (fn (var) body ...)) 253 | (if (alist seq) 254 | (each1 mapfn seq) 255 | (isa seq 'table) 256 | ; TODO: You can do better 257 | (maptable (fn var body ...) seq) 258 | (for iter 0 (- (len seq) 1) 259 | (mapfn (seq iter))))) 260 | (void)) 261 | 262 | (def cut (seq start (o end)) 263 | (let end (if (no end) (len seq) 264 | (< end 0) (+ (len seq) end) 265 | end) 266 | (if (isa seq 'string) 267 | (let s2 (newstring (- end start)) 268 | (for i 0 (- end start 1) 269 | (= (s2 i) (seq (+ start i)))) 270 | s2) 271 | (firstn (- end start) (nthcdr start seq))))) 272 | 273 | (mac whilet (var test body ...) 274 | ((afn (var) 275 | (when var 276 | body ... 277 | (self test))) 278 | test)) 279 | 280 | (def last (xs) 281 | (if (cdr xs) 282 | (last (cdr xs)) 283 | (car xs))) 284 | 285 | (def rem (test seq) 286 | (let f (testify test) 287 | (if (alist seq) 288 | ((afn (s) 289 | (if (no s) nil 290 | (f (car s)) (self (cdr s)) 291 | (cons (car s) (self (cdr s))))) 292 | seq) 293 | (coerce (rem test (coerce seq 'cons)) 'string)))) 294 | 295 | (def keep (test seq) 296 | (rem (complement (testify test)) seq)) 297 | 298 | (def trues (f xs) 299 | (and xs 300 | (let fx (f (car xs)) 301 | (if fx 302 | (cons fx (trues f (cdr xs))) 303 | (trues f (cdr xs)))))) 304 | 305 | ;; caselet - sucked into core (argument pairing, performance) 306 | ;; case - sucked into core (argument pairing, performance) 307 | 308 | (mac push (x place) 309 | (atomic 310 | (= place (cons x place)) 311 | place)) 312 | 313 | (mac swap (place1 place2) 314 | (atwiths (p1 place1 315 | p2 place2) 316 | (= place1 p2) 317 | (= place2 p1))) 318 | 319 | (mac rotate (a c ...) 320 | (shift (c ... a) (a c ...))) 321 | 322 | (mac shift ((from0 from ...) (to0 to ...)) 323 | (let tmp from0 324 | (= to from) ... 325 | (= to0 tmp))) 326 | 327 | (mac pop (place) 328 | (atwiths (val place) 329 | (do1 (car val) 330 | (= place (cdr val))))) 331 | 332 | (def adjoin (x xs (o test iso)) 333 | (if (some [test x _] xs) 334 | xs 335 | (cons x xs))) 336 | 337 | (mac pushnew (x place args ...) 338 | (atomic 339 | (= place (adjoin x place args ...)))) 340 | 341 | (mac pull (test place) 342 | (atomic 343 | (= place (rem test place)))) 344 | 345 | (mac togglemem (x place args ...) 346 | (atwiths (val place 347 | tmp x) 348 | (= place (if (mem tmp val) 349 | (rem tmp val) 350 | (adjoin tmp val args ...))))) 351 | 352 | ;; TODO: move atomic within = and lost it here 353 | (mac ++ (place (o i 1)) 354 | (if (isa 'place 'sym) 355 | (= place (+ place i)) 356 | (atomic 357 | (= place (+ place i))))) 358 | 359 | ;; TODO: Ditto 360 | (mac -- (place (o i 1)) 361 | (if (isa 'place 'sym) 362 | (= place (- place i)) 363 | (atomic 364 | (= place (- place i))))) 365 | 366 | ;; TODO: Check this with PG 367 | (mac zap (op place args ...) 368 | (atomic 369 | (= place (op place args ...)))) 370 | 371 | (def pr args 372 | (each1 disp args) 373 | (car args)) 374 | 375 | (def prt args 376 | (each1 [if _ (disp _)] args) 377 | (car args)) 378 | 379 | (def prn args 380 | (do1 (apply pr args) 381 | (writec #\newline))) 382 | 383 | (mac wipe (arg ...) 384 | (do (= arg nil) ...)) 385 | 386 | (mac set (arg ...) 387 | (do (= arg t) ...)) 388 | 389 | (mac iflet (var expr then rest ...) 390 | (let temp expr 391 | (if temp 392 | (let var temp then) 393 | rest ...))) 394 | 395 | (mac whenlet (var expr body ...) 396 | (iflet var expr (do body ...))) 397 | 398 | ;; aif - sucked into core (hygiene) 399 | 400 | (mac awhen (expr body ...) 401 | (aif expr (do body ...))) 402 | 403 | ;; aand - sucked into core (hygiene) 404 | 405 | (mac accum (accfn body ...) 406 | (withs (acc nil accfn [push _ acc]) 407 | body ... 408 | (rev acc))) 409 | 410 | (mac drain (expr (o eof nil)) 411 | (with (acc nil done nil) 412 | (while (no done) 413 | (let res expr 414 | (if (is res eof) 415 | (= done t) 416 | (push res acc)))) 417 | (rev acc))) 418 | 419 | (mac whiler (var expr endval body ...) 420 | (withs (var nil test (testify endval)) 421 | (while (no (test (= var expr))) 422 | body ...))) 423 | 424 | ;; macex - No longer needed, Racket does the expansion for us 425 | 426 | (def consif (x y) (if x (cons x y) y)) 427 | 428 | (def string args 429 | (apply + "" (map [coerce _ 'string] args))) 430 | 431 | (def flat x 432 | ((afn (x acc) 433 | (if (no x) acc 434 | (atom x) (cons x acc) 435 | (self (car x) (self (cdr x) acc)))) 436 | x nil)) 437 | 438 | (mac check (x test (o alt)) 439 | (let temp x 440 | (if (test temp) temp alt))) 441 | 442 | (def pos (test seq (o start 0)) 443 | (let f (testify test) 444 | (if (alist seq) 445 | ((afn (seq n) 446 | (if (no seq) 447 | nil 448 | (f (car seq)) 449 | n 450 | (self (cdr seq) (+ n 1)))) 451 | (nthcdr start seq) 452 | start) 453 | (recstring [if (f (seq _)) _] seq start)))) 454 | 455 | ;; even - Sucked into core (performance) 456 | 457 | ;; odd - Sucked into core (performance) 458 | 459 | (mac after (x ys ...) 460 | (protect (fn () x) (fn () ys ...))) 461 | 462 | (mac io-expander (f var name body ...) 463 | (let var (f name) 464 | (after (do body ...) (close var)))) 465 | 466 | (mac w/infile (var name body ...) 467 | (io-expander infile var name body ...)) 468 | 469 | (mac w/outfile (var name body ...) 470 | (io-expander outfile var name body ...)) 471 | 472 | (mac w/instring (var str body ...) 473 | (io-expander instring var str body ...)) 474 | 475 | (mac w/socket (var port body ...) 476 | (io-expander open-socket var port body ...)) 477 | 478 | (mac w/outstring (var body ...) 479 | (let var (outstring) body ...)) 480 | 481 | (mac w/appendfile (var name body ...) 482 | (let var (outfile name 'append) 483 | (after (do body ...) (close var)))) 484 | 485 | (mac w/stdout (str body ...) 486 | (call-w/stdout str (fn () body ...))) 487 | 488 | (mac w/stdin (str body ...) 489 | (call-w/stdin str (fn () body ...))) 490 | 491 | (mac tostring (body ...) 492 | (w/outstring temp 493 | (w/stdout temp body ...) 494 | (inside temp))) 495 | 496 | (mac fromstring (str body ...) 497 | (w/instring temp str 498 | (w/stdin temp body ...))) 499 | 500 | (def readstring1 (s (o eof nil)) (w/instring i s (read i eof))) 501 | 502 | (def read ((o x (stdin)) (o eof nil)) 503 | (if (isa x 'string) (readstring1 x eof) (sread x eof))) 504 | 505 | (def readfile (name) (w/infile s name (drain (read s)))) 506 | 507 | (def readfile1 (name) (w/infile s name (read s))) 508 | 509 | (def readall (src (o eof nil)) 510 | ((afn (i) 511 | (let x (read i eof) 512 | (if (is x eof) 513 | nil 514 | (cons x (self i))))) 515 | (if (isa src 'string) (instring src) src))) 516 | 517 | (def allchars (str) 518 | (tostring (whiler c (readc str nil) no 519 | (writec c)))) 520 | 521 | (def filechars (name) 522 | (w/infile s name (allchars s))) 523 | 524 | (let counter 0 525 | (def writefile (val file) 526 | (let tmpfile (+ file ".tmp." (atomic (++ counter))) 527 | (w/outfile o tmpfile (write val o)) 528 | (mvfile tmpfile file)) 529 | val)) 530 | 531 | (def sym (x) (coerce x 'sym)) 532 | 533 | (def int (x (o b 10)) (coerce x 'int b)) 534 | 535 | ;; TODO: Check performance - using eval is a hack 536 | (mac rand-choice (expr ...) 537 | (let choices (list 'expr ...) 538 | (eval (choices (rand (len choices)))))) 539 | 540 | (mac n-of (n expr) 541 | (let acc nil 542 | (repeat n (push expr acc)) 543 | (rev acc))) 544 | 545 | ;; TODO: Use OpenSSL for this to make it cross platform 546 | (let str (infile "/dev/urandom") 547 | (def rand-string (n) 548 | (let c "0123456789abcdefghijklmnopqrstuvwxyzABCDEFGHIJKLMNOPQRSTUVWXYZ" 549 | (with (nc 62 s (newstring n) i 0) 550 | (while (< i n) 551 | (let x (readb str) 552 | (unless (> x 247) 553 | (= (s i) (c (mod x nc))) 554 | (++ i)))) 555 | s)))) 556 | 557 | ;; TODO: Is this as inefficient as it looks? for uses the equivalent of list-ref 558 | (mac forlen (var s body ...) 559 | (for var 0 (- (len s) 1) body ...)) 560 | 561 | (def best (f seq) 562 | (if (no seq) 563 | nil 564 | (let wins (car seq) 565 | (each elt (cdr seq) 566 | (if (f elt wins) (= wins elt))) 567 | wins))) 568 | 569 | (def max args (best > args)) 570 | (def min args (best < args)) 571 | 572 | (def most (f seq) 573 | (unless (no seq) 574 | (withs (wins (car seq) topscore (f wins)) 575 | (each elt (cdr seq) 576 | (let score (f elt) 577 | (if (> score topscore) (= wins elt topscore score)))) 578 | wins))) 579 | 580 | (def insert-sorted (test elt seq) 581 | (if (no seq) 582 | (list elt) 583 | (test elt (car seq)) 584 | (cons elt seq) 585 | (cons (car seq) (insert-sorted test elt (cdr seq))))) 586 | 587 | (mac insort (test elt seq) 588 | (zap [insert-sorted test elt _] seq)) 589 | 590 | (def reinsert-sorted (test elt seq) 591 | (if (no seq) 592 | (list elt) 593 | (is elt (car seq)) 594 | (reinsert-sorted test elt (cdr seq)) 595 | (test elt (car seq)) 596 | (cons elt (rem elt seq)) 597 | (cons (car seq) (reinsert-sorted test elt (cdr seq))))) 598 | 599 | (mac insortnew (test elt seq) 600 | (zap [reinsert-sorted test elt _] seq)) 601 | 602 | (def memo (f) 603 | (with (cache (table) nilcache (table)) 604 | (fn args 605 | (or (cache args) 606 | (and (no (nilcache args)) 607 | (aif (apply f args) 608 | (= (cache args) it) 609 | (do (set (nilcache args)) 610 | nil))))))) 611 | 612 | (mac defmemo (name parms body ...) 613 | (safeset name (memo (fn parms body ...)))) 614 | 615 | ;; TODO: suck into core (performance) 616 | (def <= args 617 | (or (no args) 618 | (no (cdr args)) 619 | (and (no (> (car args) (cadr args))) 620 | (apply <= (cdr args))))) 621 | 622 | ;; TODO: Suck into core (performance) 623 | (def >= args 624 | (or (no args) 625 | (no (cdr args)) 626 | (and (no (< (car args) (cadr args))) 627 | (apply >= (cdr args))))) 628 | 629 | (def whitec (c) 630 | (in c #\space #\newline #\tab #\return)) 631 | 632 | (def nonwhite (c) (no (whitec c))) 633 | 634 | (def letter (c) (or (<= #\a c #\z) (<= #\A c #\Z))) 635 | 636 | (def digit (c) (<= #\0 c #\9)) 637 | 638 | (def alphadig (c) (or (letter c) (digit c))) 639 | 640 | (def punc (c) 641 | (in c #\. #\, #\; #\: #\! #\?)) 642 | 643 | (def readline ((o str (stdin))) 644 | (awhen (readc str) 645 | (tostring 646 | (writec it) 647 | (whiler c (readc str) [in _ nil #\newline] 648 | (writec c))))) 649 | 650 | (mac summing (sumfn body ...) 651 | (let c 0 652 | (let sumfn (fn (arg) (if arg (++ c))) 653 | body ...) 654 | c)) 655 | 656 | (def sum (f xs) 657 | (let n 0 658 | (each x xs (++ n (f x))) 659 | n)) 660 | 661 | (def carif (x) (if (atom x) x (car x))) 662 | 663 | (def prall (elts (o init "") (o sep ", ")) 664 | (when elts 665 | (pr init (car elts)) 666 | (map [pr sep _] (cdr elts)) 667 | elts)) 668 | 669 | (def prs args 670 | (prall args "" #\space)) 671 | 672 | (def tree-subst (old new tree) 673 | (if (is tree old) 674 | new 675 | (atom tree) 676 | tree 677 | (cons (tree-subst old new (car tree)) 678 | (tree-subst old new (cdr tree))))) 679 | 680 | (def ontree (f tree) 681 | (f tree) 682 | (unless (atom tree) 683 | (ontree f (car tree)) 684 | (ontree f (cdr tree)))) 685 | 686 | (def dotted (x) 687 | (if (atom x) 688 | nil 689 | (and (cdr x) (or (atom (cdr x)) 690 | (dotted (cdr x)))))) 691 | 692 | (def fill-table (table data) 693 | (each arg (pair data) (with (k (car arg) v (cdr arg)) 694 | (= (table k) v))) 695 | table) 696 | 697 | (def keys (h) 698 | (accum a (each (k v) h (a k)))) 699 | 700 | (def vals (h) 701 | (accum a (each (k v) h (a v)))) 702 | 703 | 704 | (def tablist (h) 705 | (let z nil 706 | (maptable (fn (k v) (= z (cons (list k v) z))) h) 707 | z)) 708 | 709 | (def listtab (al) 710 | (let h (table) 711 | (map (fn ((k v)) (= (h k) v)) 712 | al) 713 | h)) 714 | 715 | ;; TODO: Find a syntax to bring these back to Arc 716 | ;; obj - sucked into core (arg grouping) 717 | 718 | (mac w/table (var body ...) 719 | (let var (table) body ... var)) 720 | 721 | (def load-table (file (o eof) (o multiple)) 722 | (w/infile i file (read-table i eof multiple))) 723 | 724 | (def read-table ((o i (stdin)) (o eof) (o multiple)) 725 | (if multiple 726 | (w/table h 727 | (whiler e (read i eof) eof 728 | (= (h (car e)) (cadr e)))) 729 | (let e (read i eof) 730 | (if (alist e) (listtab e) e)))) 731 | 732 | (def load-tables (file) 733 | (w/infile i file 734 | (let eof (uniq) 735 | (drain (read-table i eof) eof)))) 736 | 737 | (def save-table (h file) 738 | (writefile (tablist h) file)) 739 | 740 | (def write-table (h (o o (stdout))) 741 | (write (tablist h) o)) 742 | 743 | (def copy (x . args) 744 | (let x2 (case (type x) 745 | sym x 746 | cons (copylist x) ; (apply (fn args args) x) 747 | string (let new (newstring (len x)) 748 | (forlen i x 749 | (= (new i) (x i))) 750 | new) 751 | table (let new (table) 752 | (each (k v) x 753 | (= (new k) v)) 754 | new) 755 | (err "Can't copy " x)) 756 | (map (fn ((k v)) (= (x2 k) v)) 757 | (pair args)) 758 | x2)) 759 | 760 | (def abs (n) 761 | (if (< n 0) (- n) n)) 762 | 763 | (def round (n) 764 | (withs (base (trunc n) rem (abs (- n base))) 765 | (if (> rem 1/2) ((if (> n 0) + -) base 1) 766 | (< rem 1/2) base 767 | (odd base) ((if (> n 0) + -) base 1) 768 | base))) 769 | 770 | (def roundup (n) 771 | (withs (base (trunc n) rem (abs (- n base))) 772 | (if (>= rem 1/2) 773 | ((if (> n 0) + -) base 1) 774 | base))) 775 | 776 | (def nearest (n quantum) 777 | (* (roundup (/ n quantum)) quantum)) 778 | 779 | (def avg (ns) (/ (apply + ns) (len ns))) 780 | 781 | (def med (ns (o test >)) 782 | ((sort test ns) (round (/ (len ns) 2)))) 783 | 784 | (def sort (test seq) 785 | (if (alist seq) 786 | (mergesort test (copylist seq)) 787 | (coerce (mergesort test (coerce seq 'cons)) (type seq)))) 788 | 789 | 790 | (def mergesort (less? lst) 791 | (with (n (len lst)) 792 | (if (<= n 1) lst 793 | ; ; check if the list is already sorted 794 | ; ; (which can be a common case, eg, directory lists). 795 | ; (let loop ([last (car lst)] [next (cdr lst)]) 796 | ; (or (null? next) 797 | ; (and (not (less? (car next) last)) 798 | ; (loop (car next) (cdr next))))) 799 | ; lst 800 | ((afn (n) 801 | (if (> n 2) 802 | ; needs to evaluate L->R 803 | (withs (j (/ (if (even n) n (- n 1)) 2) ; faster than round 804 | a (self j) 805 | b (self (- n j))) 806 | (merge less? a b)) 807 | ; the following case just inlines the length 2 case, 808 | ; it can be removed (and use the above case for n>1) 809 | ; and the code still works, except a little slower 810 | (is n 2) 811 | (with (x (car lst) y (cadr lst) p lst) 812 | (= lst (cddr lst)) 813 | (when (less? y x) (scar p y) (scar (cdr p) x)) 814 | (scdr (cdr p) nil) 815 | p) 816 | (is n 1) 817 | (with (p lst) 818 | (= lst (cdr lst)) 819 | (scdr p nil) 820 | p) 821 | nil)) 822 | n)))) 823 | 824 | (def merge (less? x y) 825 | (if (no x) y 826 | (no y) x 827 | (let lup (afn (r x y r-x?) ; r-x? for optimization -- is r connected to x? 828 | (if (less? (car y) (car x)) 829 | (do (if r-x? (scdr r y)) 830 | (if (cdr y) (self y x (cdr y) nil) (scdr y x))) 831 | ; (car x) <= (car y) 832 | (do (if (no r-x?) (scdr r x)) 833 | (if (cdr x) (self x (cdr x) y t) (scdr x y))))) 834 | (if (less? (car y) (car x)) 835 | (do (if (cdr y) (lup y x (cdr y) nil) (scdr y x)) 836 | y) 837 | ; (car x) <= (car y) 838 | (do (if (cdr x) (lup x (cdr x) y t) (scdr x y)) 839 | x))))) 840 | 841 | (def bestn (n f seq) 842 | (firstn n (sort f seq))) 843 | 844 | (def split (seq pos) 845 | (list (cut seq 0 pos) (cut seq pos))) 846 | 847 | (mac time (expr) 848 | (let t1 (msec) 849 | (do1 expr 850 | (let t2 (msec) 851 | (prn "time: " (- t2 t1) " msec."))))) 852 | 853 | (mac etime (expr) 854 | (let t1 (msec) 855 | (do1 expr 856 | (let t2 (msec) 857 | (disp (string "time: " (- t2 t1) " msec.\n") (stderr)))))) 858 | 859 | (mac ttime (tag expr) 860 | (let t1 (msec) 861 | (do1 expr 862 | (let t2 (msec) 863 | (disp (string tag " time: " (- t2 t1) " msec.\n") 864 | (stderr)))))) 865 | 866 | (mac jtime (expr) 867 | (do1 'ok (time expr))) 868 | 869 | (mac time10 (expr) 870 | (time (repeat 10 expr))) 871 | 872 | (def union (f xs ys) 873 | (+ xs (rem (fn (y) (some [f _ y] xs)) 874 | ys))) 875 | 876 | ;; TODO: find a way to move these back out 877 | ;; deftem - sucked into functions :( 878 | ;; addtem - sucked into functions :( 879 | 880 | (def inst (tem . args) 881 | (let x (eq-table) 882 | (each (k v) (if (acons tem) tem (templates* tem)) 883 | (unless (no v) (= (x k) (v)))) 884 | (each (k v) (pair args) 885 | (= (x k) v)) 886 | x)) 887 | 888 | (def temread (tem (o str (stdin))) 889 | (templatize tem (read str))) 890 | 891 | 892 | (def templatize (tem raw) 893 | (with (x (inst tem) fields (if (acons tem) tem (templates* tem))) 894 | (each (k v) raw 895 | (when (assoc k fields) 896 | (= (x k) v))) 897 | x)) 898 | 899 | (def temload (tem file) 900 | (w/infile i file (temread tem i))) 901 | 902 | (def temloadall (tem file) 903 | (map (fn (pairs) (templatize tem pairs)) 904 | (w/infile in file (readall in)))) 905 | 906 | (def number (n) (in (type n) 'int 'num)) 907 | 908 | (def since (t1) (- (seconds) t1)) 909 | 910 | (def minutes-since (t1) (/ (since t1) 60)) 911 | (def hours-since (t1) (/ (since t1) 3600)) 912 | (def days-since (t1) (/ (since t1) 86400)) 913 | 914 | (def cache (timef valf) 915 | (with (cached nil gentime nil) 916 | (fn () 917 | (unless (and cached (< (since gentime) (timef))) 918 | (= cached (valf) 919 | gentime (seconds))) 920 | cached))) 921 | 922 | (mac defcache (name lasts body ...) 923 | (safeset name (cache (fn () lasts) 924 | (fn () body ...)))) 925 | 926 | (mac errsafe (expr) 927 | (on-err (fn (c) nil) 928 | (fn () expr))) 929 | 930 | (def saferead (arg) (errsafe (read arg))) 931 | 932 | (def safe-load-table (filename) 933 | (or (errsafe (load-table filename)) 934 | (table))) 935 | 936 | (def date ((o s (seconds))) 937 | (rev (nthcdr 3 (timedate s)))) 938 | 939 | (def datestring ((o s (seconds))) 940 | (let (y m d) (date s) 941 | (string y "-" (if (< m 10) "0") m "-" (if (< d 10) "0") d))) 942 | 943 | (def count (test x) 944 | (with (n 0 testf (testify test)) 945 | (each elt x 946 | (if (testf elt) (++ n))) 947 | n)) 948 | 949 | (def ellipsize (str (o limit 80)) 950 | (if (<= (len str) limit) 951 | str 952 | (+ (cut str 0 limit) "..."))) 953 | 954 | (def rand-elt (seq) 955 | (seq (rand (len seq)))) 956 | 957 | (mac until (test body ...) 958 | (while (no test) body ...)) 959 | 960 | (def before (x y seq (o i 0)) 961 | (with (xp (pos x seq i) yp (pos y seq i)) 962 | (and xp (or (no yp) (< xp yp))))) 963 | 964 | (def orf fns 965 | (fn args 966 | ((afn (fs) 967 | (and fs (or (apply (car fs) args) (self (cdr fs))))) 968 | fns))) 969 | 970 | (def andf fns 971 | (fn args 972 | ((afn (fs) 973 | (if (no fs) t 974 | (no (cdr fs)) (apply (car fs) args) 975 | (and (apply (car fs) args) (self (cdr fs))))) 976 | fns))) 977 | 978 | (def atend (i s) 979 | (> i (- (len s) 2))) 980 | 981 | (def multiple (x y) 982 | (is 0 (mod x y))) 983 | 984 | (mac nor (args ...) (no (or args ...))) 985 | 986 | (def compare (comparer scorer) 987 | (fn (x y) (comparer (scorer x) (scorer y)))) 988 | 989 | (def only (f) 990 | (fn args (if (car args) (apply f args)))) 991 | 992 | (mac conswhen (f x y) 993 | (with (tf f tx x) 994 | (if (tf tx) (cons tx y) y))) 995 | 996 | (def retrieve (n f xs) 997 | (if (no n) (keep f xs) 998 | (or (<= n 0) (no xs)) nil 999 | (f (car xs)) (cons (car xs) (retrieve (- n 1) f (cdr xs))) 1000 | (retrieve n f (cdr xs)))) 1001 | 1002 | (def dedup (xs) 1003 | (with (h (table) acc nil) 1004 | (each x xs 1005 | (unless (h x) 1006 | (push x acc) 1007 | (set (h x)))) 1008 | (rev acc))) 1009 | 1010 | (def dupes (xs) 1011 | (with (h (table) acc nil) 1012 | (each x xs 1013 | (if (h x) 1014 | (push x acc) 1015 | (set (h x)))) 1016 | (rev acc))) 1017 | 1018 | (def single (x) (and (acons x) (no (cdr x)))) 1019 | 1020 | (def intersperse (x ys) 1021 | (and ys (cons (car ys) 1022 | (mappend [list x _] (cdr ys))))) 1023 | 1024 | (def counts (seq (o c (table))) 1025 | (if (no seq) 1026 | c 1027 | (do (++ (c (car seq) 0)) 1028 | (counts (cdr seq) c)))) 1029 | 1030 | (def commonest (seq) 1031 | (with (winner nil n 0) 1032 | (each (k v) (counts seq) 1033 | (when (> v n) (= winner k n v))) 1034 | (list winner n))) 1035 | 1036 | (def reduce (f xs) 1037 | (if (cddr xs) 1038 | (reduce f (cons (f (car xs) (cadr xs)) (cddr xs))) 1039 | (apply f xs))) 1040 | 1041 | (def rreduce (f xs) 1042 | (if (cddr xs) 1043 | (f (car xs) (rreduce f (cdr xs))) 1044 | (apply f xs))) 1045 | 1046 | (let argsym (uniq) 1047 | 1048 | (def parse-format (str) 1049 | (accum a 1050 | (with (chars nil i -1) 1051 | (w/instring s str 1052 | (whilet c (readc s) 1053 | (case c 1054 | #\# (do (a (coerce (rev chars) 'string)) 1055 | (wipe chars) 1056 | (a (read s))) 1057 | #\~ (do (a (coerce (rev chars) 'string)) 1058 | (wipe chars) 1059 | (readc s) 1060 | (a (list argsym (++ i)))) 1061 | (push c chars)))) 1062 | (when chars 1063 | (a (coerce (rev chars) 'string)))))) 1064 | ) 1065 | 1066 | (def load (file) 1067 | (w/infile f file 1068 | (let eof (uniq) 1069 | (whiler e (read f eof) eof 1070 | (eval e))))) 1071 | 1072 | (def positive (x) 1073 | (and (number x) (> x 0))) 1074 | 1075 | (def ero args 1076 | (w/stdout (stderr) 1077 | (each a args 1078 | (write a) 1079 | (writec #\space)) 1080 | (writec #\newline)) 1081 | (car args)) 1082 | 1083 | (def queue () (list nil nil 0)) 1084 | 1085 | (def enq (obj q) 1086 | (atomic 1087 | (++ (q 2)) 1088 | (if (no (car q)) 1089 | (= (cadr q) (= (car q) (list obj))) 1090 | (= (cdr (cadr q)) (list obj) 1091 | (cadr q) (cdr (cadr q)))) 1092 | (car q))) 1093 | 1094 | (def deq (q) 1095 | (atomic (unless (is (q 2) 0) (-- (q 2))) 1096 | (pop (car q)))) 1097 | 1098 | (def qlen (q) (q 2)) 1099 | 1100 | (def qlist (q) (car q)) 1101 | 1102 | (def enq-limit (val q (o limit 1000)) 1103 | (atomic 1104 | (unless (< (qlen q) limit) 1105 | (deq q)) 1106 | (enq val q))) 1107 | 1108 | (def median (ns) 1109 | ((sort > ns) (trunc (/ (len ns) 2)))) 1110 | 1111 | (mac noisy-each (n var val body ...) 1112 | (with (nc n c 0) 1113 | (each var val 1114 | (when (multiple (++ c) nc) 1115 | (pr ".") 1116 | (flushout)) 1117 | body ...) 1118 | (prn) 1119 | (flushout))) 1120 | 1121 | (def downcase (x) 1122 | (let downc (fn (c) 1123 | (let n (coerce c 'int) 1124 | (if (or (< 64 n 91) (< 191 n 215) (< 215 n 223)) 1125 | (coerce (+ n 32) 'char) 1126 | c))) 1127 | (case (type x) 1128 | string (map downc x) 1129 | char (downc x) 1130 | sym (if x (sym (map downc (coerce x 'string))) 'nil) 1131 | (err "Can't downcase" x)))) 1132 | 1133 | (def upcase (x) 1134 | (let upc (fn (c) 1135 | (let n (coerce c 'int) 1136 | (if (or (< 96 n 123) (< 223 n 247) (< 247 n 255)) 1137 | (coerce (- n 32) 'char) 1138 | c))) 1139 | (case (type x) 1140 | string (map upc x) 1141 | char (upc x) 1142 | sym (if x (sym (map upc (coerce x 'string))) 'NIL) 1143 | (err "Can't upcase" x)))) 1144 | 1145 | (def inc (x (o n 1)) 1146 | (coerce (+ (coerce x 'int) n) (type x))) 1147 | 1148 | (def range (start end) 1149 | (if (> start end) 1150 | nil 1151 | (cons start (range (inc start) end)))) 1152 | 1153 | ;; TODO: Generalize this for n lists? 1154 | (def zip (s1 s2 f (o eof (uniq)) (o index 0)) 1155 | (when (or s1 s2) 1156 | (f (if s1 (car s1) eof) 1157 | (if s2 (car s2) eof) 1158 | eof 1159 | index) 1160 | (zip (cdr s1) (cdr s2) f eof (+ 1 index)))) 1161 | 1162 | (def mismatch (s1 s2) 1163 | (catch 1164 | (zip s1 s2 (fn (s1 s2 eof index) 1165 | (when (isnt s1 s2) 1166 | (throw index)))))) 1167 | 1168 | (def memtable (ks) 1169 | (let h (table) 1170 | (each k ks (set (h k))) 1171 | h)) 1172 | 1173 | (= bar* " | ") 1174 | 1175 | (mac w/bars (body ...) 1176 | (let needbars nil 1177 | (let out (tostring body) 1178 | (unless (is out "") 1179 | (if needbars 1180 | (pr bar* out) 1181 | (do (set needbars) 1182 | (pr out))))) ...)) 1183 | 1184 | (def len< (x n) (< (len x) n)) 1185 | 1186 | (def len> (x n) (> (len x) n)) 1187 | 1188 | (mac thread (body ...) 1189 | (new-thread (fn () body ...))) 1190 | 1191 | (mac trav (x fs ...) 1192 | ((afn (g) 1193 | (when g 1194 | (fs g) ...)) 1195 | x)) 1196 | 1197 | (mac or= (place expr) 1198 | (atomic 1199 | (or place (= place expr)))) 1200 | 1201 | (= hooks* (table)) 1202 | 1203 | (def hook (name . args) 1204 | (aif (hooks* name) (apply it args))) 1205 | 1206 | (mac defhook (name rest ...) 1207 | (= (hooks* 'name) (fn rest ...))) 1208 | 1209 | ;; TODO: Add caching here 1210 | (mac out (expr) (pr (tostring expr))) 1211 | 1212 | (def get (index) [_ index]) 1213 | 1214 | (def ensure-dir (path) 1215 | (unless (dir-exists path) 1216 | (make-dir path))) 1217 | 1218 | (let permfile (fn (var) 1219 | (let s (string var) 1220 | (+ "perm/" 1221 | (rem ~alphadig s) 1222 | #\- 1223 | (string (intersperse #\- (map int (coerce s 'cons))))))) 1224 | 1225 | (mac perm (var (o init) (o load readfile1) (o save writefile) 1226 | (o file (permfile var))) 1227 | (ensure-var var) 1228 | (= var (or (and (bound var) var) 1229 | (do1 (iflet gf (file-exists file) 1230 | (load gf) 1231 | init) 1232 | (= (permwrite 'var) (fn (val) (save val file))))))) 1233 | 1234 | (mac permat (var file) 1235 | (perm var nil readfile1 writefile file)) 1236 | 1237 | (mac permtable (var (o file (permfile var))) 1238 | (perm var (table) load-table save-table file)) 1239 | 1240 | ) 1241 | 1242 | (mac evtil (expr test) 1243 | (let v expr 1244 | (while (no (test v)) 1245 | (= v expr)) 1246 | v)) 1247 | 1248 | (def rand-key (h) 1249 | (if (empty h) 1250 | nil 1251 | (let n (rand (len h)) 1252 | (catch 1253 | (each (k v) h 1254 | (when (is (-- n) -1) 1255 | (throw k))))))) 1256 | 1257 | (def ratio (test xs) 1258 | (if (empty xs) 1259 | 0 1260 | (/ (count test xs) (len xs)))) 1261 | 1262 | (def percent (n) 1263 | (round (* 100 n))) 1264 | 1265 | (def tfn args t) 1266 | --------------------------------------------------------------------------------