aparler/RosettaCodeData
1
0
Fork 0
Code Issues 12 Pull requests 3 Projects Releases Packages Wiki Activity Actions

A-M baby

Browse source
This commit is contained in:
Ingy döt Net 2013-04-10 21:29:02 -07:00
parent 764da6cbbb
commit db842d013d
19005 changed files with 197040 additions and 7 deletions
Download patch file Download diff file Expand all files Collapse all files

5
Task/Metaprogramming/0DESCRIPTION Normal file
View file

@ -0,0 +1,5 @@
{{omit from|BBC BASIC}}
Name and briefly demonstrate any support your language has for metaprogramming. Your demonstration may take the form of cross-references to other tasks on Rosetta Code. When possible, provide links to relevant documentation.
For the purposes of this task, "support for metaprogramming" means any way the user can effectively modify the language's syntax that's built into the language (like Lisp macros) or that's conventionally used with the language (like the C preprocessor). Such facilities need not be very powerful: even user-defined infix operators count. On the other hand, in general, neither operator overloading nor <code>eval</code> count. The task author acknowledges that what qualifies as metaprogramming is largely a judgment call.

12
Task/Metaprogramming/C/metaprogramming-1.c Normal file
View file

@ -0,0 +1,12 @@
// http://stackoverflow.com/questions/3385515/static-assert-in-c
#define STATIC_ASSERT(COND,MSG) typedef char static_assertion_##MSG[(!!(COND))*2-1]
// token pasting madness:
#define COMPILE_TIME_ASSERT3(X,L) STATIC_ASSERT(X,static_assertion_at_line_##L)
#define COMPILE_TIME_ASSERT2(X,L) COMPILE_TIME_ASSERT3(X,L)
#define COMPILE_TIME_ASSERT(X) COMPILE_TIME_ASSERT2(X,__LINE__)
COMPILE_TIME_ASSERT(sizeof(long)==8);
int main()
{
COMPILE_TIME_ASSERT(sizeof(int)==4);
}

9
Task/Metaprogramming/C/metaprogramming-2.c Normal file
View file

@ -0,0 +1,9 @@
//requires C99
#define ITERATE_LIST(n, list) \
for(Node *n = (list)->head; n; n = n->next)
...
ITERATE_LIST(n, list)
{
printf("node value: %s\n", n->value);
}

3
Task/Metaprogramming/C/metaprogramming-3.c Normal file
View file

@ -0,0 +1,3 @@
#define my_min(x, y) ((x) < (y) ? (x) : (y))
...
printf("%f %d %ll\n", my_min(0.0f, 1.0f), my_min(1,2), my_min(1ll, 2ll));

10
Task/Metaprogramming/Common-Lisp/metaprogramming-1.lisp Normal file
View file

@ -0,0 +1,10 @@
(loop for count from 1
for x in '(1 2 3 4 5)
summing x into sum
summing (* x x) into sum-of-squares
finally
(return
(let* ((mean (/ sum count))
(spl-var (- (* count sum-of-squares) (* sum sum)))
(spl-dev (sqrt (/ spl-var (1- count)))))
(values mean spl-var spl-dev))))

35
Task/Metaprogramming/Common-Lisp/metaprogramming-2.lisp Normal file
View file

@ -0,0 +1,35 @@
[5]>
(macroexpand'
(loop for count from 1
for x in '(1 2 3 4 5)
summing x into sum
summing (* x x) into sum-of-squares
finally
(return
(let* ((mean (/ sum count))
(spl-var (- (* count sum-of-squares) (* sum sum)))
(spl-dev (sqrt (/ spl-var (1- count)))))
(values mean spl-var spl-dev)))))
(MACROLET ((LOOP-FINISH NIL (SYSTEM::LOOP-FINISH-ERROR)))
(BLOCK NIL
(LET ((COUNT 1))
(LET ((#:LIST-3047 '(1 2 3 4 5)))
(PROGN
(LET ((X NIL))
(LET ((SUM-OF-SQUARES 0) (SUM 0))
(MACROLET ((LOOP-FINISH NIL '(GO SYSTEM::END-LOOP)))
(TAGBODY SYSTEM::BEGIN-LOOP (WHEN (ENDP #:LIST-3047) (LOOP-FINISH))
(SETQ X (CAR #:LIST-3047))
(PROGN (SETQ SUM (+ SUM X))
(SETQ SUM-OF-SQUARES (+ SUM-OF-SQUARES (* X X))))
(PSETQ COUNT (+ COUNT 1)) (PSETQ #:LIST-3047 (CDR #:LIST-3047))
(GO SYSTEM::BEGIN-LOOP) SYSTEM::END-LOOP
(MACROLET
((LOOP-FINISH NIL (SYSTEM::LOOP-FINISH-WARN) '(GO SYSTEM::END-LOOP)))
(PROGN
(RETURN
(LET*
((MEAN (/ SUM COUNT))
(SPL-VAR (- (* COUNT SUM-OF-SQUARES) (* SUM SUM)))
(SPL-DEV (SQRT (/ SPL-VAR (1- COUNT)))))
(VALUES MEAN SPL-VAR SPL-DEV)))))))))))))) ; T

8
Task/Metaprogramming/Common-Lisp/metaprogramming-3.lisp Normal file
View file

@ -0,0 +1,8 @@
;; The -> notation is not part of Lisp, it is used in examples indicate the output of a form.
;;
;;
(comprehend 'list-monad (cons x y) (x '(1 2 3)) (y '(A B C)))
-> ((1 . A) (1 . B) (1 . C)
(2 . A) (2 . B) (2 . C)
(3 . A) (3 . B) (3 . C))

2
Task/Metaprogramming/Common-Lisp/metaprogramming-4.lisp Normal file
View file

@ -0,0 +1,2 @@
(identity-comp (list x y z) (x 1) (y (* 3 x)) (z (+ x y)))
-> (1 3 4)

99
Task/Metaprogramming/Common-Lisp/metaprogramming-5.lisp Normal file
View file

@ -0,0 +1,99 @@
(defgeneric monadic-map (monad-class function))
(defgeneric monadic-join (monad-class container-of-containers &rest additional))
(defgeneric monadic-instance (monad-class-name))
(defmacro comprehend (monad-instance expr &rest clauses)
(let ((monad-var (gensym "CLASS-")))
(cond
((null clauses) `(multiple-value-call #'monadic-unit
,monad-instance ,expr))
((rest clauses) `(let ((,monad-var ,monad-instance))
(multiple-value-call #'monadic-join ,monad-var
(comprehend ,monad-var
(comprehend ,monad-var ,expr ,@(rest clauses))
,(first clauses)))))
(t (destructuring-bind (var &rest container-exprs) (first clauses)
(cond
((and var (symbolp var))
`(funcall (monadic-map ,monad-instance (lambda (,var) ,expr))
,(first container-exprs)))
((and (consp var) (every #'symbolp var))
`(multiple-value-call (monadic-map ,monad-instance
(lambda (,@var) ,expr))
,@container-exprs))
(t (error "COMPREHEND: bad variable specification: ~s" vars))))))))
(defmacro define-monad (class-name
&key comprehension
(monad-param (gensym "MONAD-"))
bases slots initargs
((:map ((map-param)
&body map-body)))
((:join ((join-param
&optional
(j-rest-kw '&rest)
(j-rest (gensym "JOIN-REST-")))
&body join-body)))
((:unit ((unit-param
&optional
(u-rest-kw '&rest)
(u-rest (gensym "UNIT-REST-")))
&body unit-body))))
`(progn
(defclass ,class-name ,bases ,slots)
(defmethod monadic-instance ((monad (eql ',class-name)))
(load-time-value (make-instance ',class-name ,@initargs)))
(defmethod monadic-map ((,monad-param ,class-name) ,map-param)
(declare (ignorable ,monad-param))
,@map-body)
(defmethod monadic-join ((,monad-param ,class-name)
,join-param &rest ,j-rest)
(declare (ignorable ,monad-param ,j-rest))
,@join-body)
(defmethod monadic-unit ((,monad-param ,class-name)
,unit-param &rest ,u-rest)
(declare (ignorable ,monad-param ,u-rest))
,@unit-body)
,@(if comprehension
`((defmacro ,comprehension (expr &rest clauses)
`(comprehend (monadic-instance ',',class-name)
,expr ,@clauses))))))
(defmethod monadic-map ((monad symbol) function)
(monadic-map (monadic-instance monad) function))
(defmethod monadic-join ((monad symbol) container-of-containers &rest rest)
(apply #'monadic-join (monadic-instance monad) container-of-containers rest))
(defmethod monadic-unit ((monad symbol) element &rest rest)
(apply #'monadic-unit (monadic-instance monad) element rest))
(define-monad list-monad
:comprehension list-comp
:map ((function) (lambda (container) (mapcar function container)))
:join ((list-of-lists) (reduce #'append list-of-lists))
:unit ((element) (list element)))
(define-monad identity-monad
:comprehension identity-comp
:map ((f) f)
:join ((x &rest rest) (apply #'values x rest))
:unit ((x &rest rest) (apply #'values x rest)))
(define-monad state-xform-monad
:comprehension state-xform-comp
:map ((f)
(lambda (xformer)
(lambda (s)
(identity-comp (values (funcall f x) new-state)
((x new-state) (funcall xformer s))))))
:join ((nested-xformer)
(lambda (s)
(identity-comp (values x new-state)
((embedded-xformer intermediate-state)
(funcall nested-xformer s))
((x new-state)
(funcall embedded-xformer intermediate-state)))))
:unit ((x) (lambda (s) (values x s))))

13
Task/Metaprogramming/D/metaprogramming.d Normal file
View file

@ -0,0 +1,13 @@
template GenStruct(string name, string fieldName) {
enum GenStruct = "struct " ~ name ~ "{ int " ~ fieldName ~ "; }";
}
mixin(GenStruct!("Foo", "bar"));
// Is equivalent to:
// struct Foo { int bar; }
void main() {
Foo f;
f.bar = 10;
}

4
Task/Metaprogramming/Lua/metaprogramming.lua Normal file
View file

@ -0,0 +1,4 @@
class "foo" : inherits "bar"
{
}

5
Task/Metaprogramming/Perl/metaprogramming-1.pl Normal file
View file

@ -0,0 +1,5 @@
package UnicodeEllipsis;
use Filter::Simple;
FILTER_ONLY code => sub { s/…/../g };

3
Task/Metaprogramming/Perl/metaprogramming-2.pl Normal file
View file

@ -0,0 +1,3 @@
use UnicodeEllipsis;
print join(' … ', 1 … 5), "\n";

53
Task/Metaprogramming/REXX/metaprogramming.rexx Normal file
View file

@ -0,0 +1,53 @@
/*┌───────────────────────────────────────────────────────────────────┐
│ The REXX language doesn't allow for the changing or overriding of │
│ syntax per se, but any of the built-in-functions (BIFs) can be │
│ overridden by just specifying your own. │
│ │
│ To use the REXX's version of a built-in-function, you simply just │
│ enclose the BIF in quotation marks (and uppercase the name). │
│ │
│ The intent is two-fold: the REXX language doesn't have any │
│ reserved words, nor reserved BIFs (Built-In-Functions). │
│ │
│ So, if you don't know that VERIFY is a BIF, you can just code │
│ a subroutine (or function) with that name (or any name), and not │
│ worry about your subroutine being pre-empted. │
│ │
│ Second: if you're not satisfied how a BIF works, you can code │
│ your own. This also allows you to front-end a BIF for debugging │
│ or modifying the BIF's behavior. │
└───────────────────────────────────────────────────────────────────┘ */
yyy='123456789abcdefghi'
rrr = substr(yyy,5) /*returns efghi */
mmm = 'SUBSTR'(yyy,5) /*returns 56789abcdefgji */
sss = "SUBSTR"(yyy,5) /* (same as above) */
exit /*stick a fork in it, we're done.*/
/*──────────────────────────────────SUBSTR subroutine───────────────────*/
substr: return right(arg(1),arg(2))
/*┌───────────────────────────────────────────────────────────────────┐
│ Also, some REXX interpreters treat whitespace(s) as blanks when │
│ performing comparisons. Some of the whitespace characters are: │
│ │
│ NL (newLine) │
│ FF (formFeed) │
│ VT (vertical tab) │
│ HT (horizontal tab or TAB) │
│ LF (lineFeed) │
│ CR (carriage return) │
│ EOF (end-of-file) │
│ and/or others. │
│ │
│ Note that some of the above are ASCII or EBCDIC specific. │
│ │
│ Some REXX interpreters use the OPTIONS statement to force │
│ REXX to only treat blanks as spaces. │
│ │
│ (Both the verb and option may be in lower/upper/mixed case.) │
│ │
│ REXX interpreters which don't recognize any option won't treat │
│ the (below) statement as an error. │
└───────────────────────────────────────────────────────────────────┘ */
options strict_white_space_comparisons /*can be in lower/upper/mixed.*/

12
Task/Metaprogramming/Ruby/metaprogramming.rb Normal file
View file

@ -0,0 +1,12 @@
class IDVictim
# Create elements of this man, woman, or child's identification.
attr_accessor :name, :birthday, :gender, :hometown
# Allows you to put in a space for anything which is not covered by the
# preexisting elements.
def self.new_element(element)
attr_accessor element
end
end

14
Task/Metaprogramming/Tcl/metaprogramming-1.tcl Normal file
View file

@ -0,0 +1,14 @@
proc loopVar {var from lower to upper script} {
if {$from ne "from" || $to ne "to"} {error "syntax error"}
upvar 1 $var v
if {$lower <= $upper} {
for {set v $lower} {$v <= $upper} {incr v} {
uplevel 1 $script
}
} else {
# $upper and $lower really the other way round here
for {set v $lower} {$v >= $upper} {incr v -1} {
uplevel 1 $script
}
}
}

6
Task/Metaprogramming/Tcl/metaprogramming-2.tcl Normal file
View file

@ -0,0 +1,6 @@
loopVar x from 1 to 4 {
loopVar y from $x to 6 {
puts "pair is ($x,$y)"
if {$y >= 4} break
}
}

1
Task/Metaprogramming/Tcl/metaprogramming-3.tcl Normal file
View file

@ -0,0 +1 @@
set set set